install.el

   1 ;;; install.el --- Emacs Lisp package install utility
   2
   3 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2006
   4 ;;      Free Software Foundation, Inc.
   5
   6 ;; Author: MORIOKA Tomohiko <tomo@m17n.org>
   7 ;; Created: 1996/08/18
   8 ;; Keywords: install, byte-compile, directory detection
   9
  10 ;; This file is part of APEL (A Portable Emacs Library).
  11
  12 ;; This program is free software; you can redistribute it and/or
  13 ;; modify it under the terms of the GNU General Public License as
  14 ;; published by the Free Software Foundation; either version 2, or (at
  15 ;; your option) any later version.
  16
  17 ;; This program is distributed in the hope that it will be useful, but
  18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20 ;; General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  24 ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  25 ;; Boston, MA 02110-1301, USA.
  26
  27 ;;; Code:
  28
  29 (require 'poe)                          ; make-directory for v18
  30 (require 'path-util)                    ; default-load-path
  31
  32
  33 ;;; @ compile Emacs Lisp files
  34 ;;;
  35
  36 (defun compile-elisp-module (module &optional path every-time)
  37   (setq module (expand-file-name (symbol-name module) path))
  38   (let ((el-file (concat module ".el"))
  39         (elc-file (concat module ".elc")))
  40     (if (or every-time
  41             (file-newer-than-file-p el-file elc-file))
  42         (byte-compile-file el-file))))
  43
  44 (defun compile-elisp-modules (modules &optional path every-time)
  45   (mapcar
  46    (function
  47     (lambda (module)
  48       (compile-elisp-module module path every-time)))
  49    modules))
  50
  51
  52 ;;; @ install files
  53 ;;;
  54
  55 (defvar install-overwritten-file-modes (+ (* 64 6)(* 8 4) 4)) ; 0644
  56
  57 (defun install-file (file src dest &optional move overwrite just-print)
  58   (if just-print
  59       (princ (format "%s -> %s\n" file dest))
  60     (let ((src-file (expand-file-name file src)))
  61       (if (file-exists-p src-file)
  62           (let ((full-path (expand-file-name file dest)))
  63             (if (and (file-exists-p full-path) overwrite)
  64                 (delete-file full-path))
  65             (copy-file src-file full-path t t)
  66             (set-file-modes full-path install-overwritten-file-modes)
  67             (if move
  68                 (catch 'tag
  69                   (while (and (file-exists-p src-file)
  70                               (file-writable-p src-file))
  71                     (condition-case err
  72                         (progn
  73                           (delete-file src-file)
  74                           (throw 'tag nil))
  75                       (error (princ (format "%s\n" (nth 1 err))))))))
  76             (princ (format "%s -> %s\n" file dest)))))))
  77
  78 (defun install-files (files src dest &optional move overwrite just-print)
  79   (or just-print
  80       (file-exists-p dest)
  81       (make-directory dest t))
  82   (mapcar
  83    (function
  84     (lambda (file)
  85       (install-file file src dest move overwrite just-print)))
  86    files))
  87
  88
  89 ;;; @@ install Emacs Lisp files
  90 ;;;
  91
  92 (defun install-elisp-module (module src dest &optional just-print del-elc)
  93   (let (el-file elc-file)
  94     (let ((name (symbol-name module)))
  95       (setq el-file (concat name ".el"))
  96       (setq elc-file (concat name ".elc")))
  97     (let ((src-file (expand-file-name el-file src)))
  98       (if (not (file-exists-p src-file))
  99           nil
 100         (if just-print
 101             (princ (format "%s -> %s\n" el-file dest))
 102           (let ((full-path (expand-file-name el-file dest)))
 103             (if (file-exists-p full-path)
 104                 (delete-file full-path))
 105             (copy-file src-file full-path t t)
 106             (set-file-modes full-path install-overwritten-file-modes)
 107             (princ (format "%s -> %s\n" el-file dest)))))
 108       (setq src-file (expand-file-name elc-file src))
 109       (if (not (file-exists-p src-file))
 110           (let ((full-path (expand-file-name elc-file dest)))
 111             (if (and del-elc (file-exists-p full-path))
 112                 (if just-print
 113                     (princ (format "%s -> to be deleted\n" full-path))
 114                   (delete-file full-path)
 115                   (princ (format "%s -> deleted\n" full-path)))))
 116         (if just-print
 117             (princ (format "%s -> %s\n" elc-file dest))
 118           (let ((full-path (expand-file-name elc-file dest)))
 119             (if (file-exists-p full-path)
 120                 (delete-file full-path))
 121             (copy-file src-file full-path t t)
 122             (set-file-modes full-path install-overwritten-file-modes)
 123             (catch 'tag
 124               (while (file-exists-p src-file)
 125                 (condition-case err
 126                     (progn
 127                       (delete-file src-file)
 128                       (throw 'tag nil))
 129                   (error (princ (format "%s\n" (nth 1 err)))))))
 130             (princ (format "%s -> %s\n" elc-file dest))))))))
 131
 132 (defun install-elisp-modules (modules src dest &optional just-print del-elc)
 133   (or just-print
 134       (file-exists-p dest)
 135       (make-directory dest t))
 136   (mapcar
 137    (function
 138     (lambda (module)
 139       (install-elisp-module module src dest just-print del-elc)))
 140    modules))
 141
 142
 143 ;;; @ detect install path
 144 ;;;
 145
 146 ;; install to shared directory (maybe "/usr/local")
 147 (defvar install-prefix
 148   (if (or (<= emacs-major-version 18)
 149           (featurep 'xemacs)
 150           (featurep 'meadow) ; for Meadow
 151           (and (eq system-type 'windows-nt) ; for NTEmacs
 152                (>= emacs-major-version 20)))
 153       (expand-file-name "../../.." exec-directory)
 154     (expand-file-name "../../../.." data-directory)))
 155
 156 (defvar install-elisp-prefix
 157   (if (>= emacs-major-version 19)
 158       "site-lisp"
 159     ;; v18 does not have standard site directory.
 160     "local.lisp"))
 161
 162 ;; Avoid compile warning.
 163 (eval-when-compile (autoload 'replace-in-string "subr"))
 164
 165 (defun install-detect-elisp-directory (&optional prefix elisp-prefix
 166                                                  allow-version-specific)
 167   (or prefix
 168       (setq prefix install-prefix))
 169   (or elisp-prefix
 170       (setq elisp-prefix install-elisp-prefix))
 171   (or (catch 'tag
 172         (let ((rest (delq nil (copy-sequence default-load-path)))
 173               (regexp
 174                (concat "^"
 175                        (regexp-quote (if (featurep 'xemacs)
 176                                          ;; Handle backslashes (Windows)
 177                                          (replace-in-string
 178                                           (file-name-as-directory
 179                                            (expand-file-name prefix))
 180                                           "\\\\" "/")
 181                                        (file-name-as-directory
 182                                         (expand-file-name prefix))))
 183                        ".*/"
 184                        (regexp-quote
 185                         (if (featurep 'xemacs)
 186                             ;; Handle backslashes (Windows)
 187                             (replace-in-string elisp-prefix "\\\\" "/")
 188                           elisp-prefix))
 189                        "/?$"))
 190               dir)
 191           (while rest
 192             (setq dir (if (featurep 'xemacs)
 193                           ;; Handle backslashes (Windows)
 194                           (replace-in-string (car rest) "\\\\" "/")
 195                         (car rest)))
 196             (if (string-match regexp dir)
 197                 (if (or allow-version-specific
 198                         (not (string-match (format "/%d\\.%d"
 199                                                    emacs-major-version
 200                                                    emacs-minor-version)
 201                                            dir)))
 202                     (throw 'tag (car rest))))
 203             (setq rest (cdr rest)))))
 204       (expand-file-name (concat (if (and (not (featurep 'xemacs))
 205                                          (or (>= emacs-major-version 20)
 206                                              (and (= emacs-major-version 19)
 207                                                   (> emacs-minor-version 28))))
 208                                     "share/"
 209                                   "lib/")
 210                                 (cond
 211                                  ((featurep 'xemacs)
 212                                   (if (featurep 'mule)
 213                                       "xmule/"
 214                                     "xemacs/"))
 215                                  ;; unfortunately, unofficial mule based on
 216                                  ;; 19.29 and later use "emacs/" by default.
 217                                  ((boundp 'MULE) "mule/")
 218                                  ((boundp 'NEMACS) "nemacs/")
 219                                  (t "emacs/"))
 220                                 elisp-prefix)
 221                         prefix)))
 222
 223 (defvar install-default-elisp-directory
 224   (install-detect-elisp-directory))
 225
 226
 227 ;;; @ for XEmacs package system
 228 ;;;
 229
 230 (defun install-get-default-package-directory ()
 231   (let ((dirs (append
 232                (cond
 233                 ((boundp 'early-package-hierarchies)
 234                  (append (if early-package-load-path
 235                              early-package-hierarchies)
 236                          (if late-package-load-path
 237                              late-package-hierarchies)
 238                          (if last-package-load-path
 239                              last-package-hierarchies)) )
 240                 ((boundp 'early-packages)
 241                  (append (if early-package-load-path
 242                              early-packages)
 243                          (if late-package-load-path
 244                              late-packages)
 245                          (if last-package-load-path
 246                              last-packages)) ))
 247                (if (and (boundp 'configure-package-path)
 248                         (listp configure-package-path))
 249                    (delete "" configure-package-path))))
 250         dir)
 251     (while (and (setq dir (car dirs))
 252                 (not (file-exists-p dir)))
 253       (setq dirs (cdr dirs)))
 254     dir))
 255
 256 (defun install-update-package-files (package dir &optional just-print)
 257   (cond
 258    (just-print
 259     (princ (format "Updating autoloads in directory %s..\n\n" dir))
 260
 261     (princ (format "Processing %s\n" dir))
 262     (princ "Generating custom-load.el...\n\n")
 263
 264     (princ (format "Compiling %s...\n"
 265                    (expand-file-name "auto-autoloads.el" dir)))
 266     (princ (format "Wrote %s\n"
 267                    (expand-file-name "auto-autoloads.elc" dir)))
 268
 269     (princ (format "Compiling %s...\n"
 270                    (expand-file-name "custom-load.el" dir)))
 271     (princ (format "Wrote %s\n"
 272                    (expand-file-name "custom-load.elc" dir))))
 273    (t
 274     (if (fboundp 'batch-update-directory-autoloads)
 275         ;; XEmacs 21.5.19 and newer.
 276         (let ((command-line-args-left (list package dir)))
 277           (batch-update-directory-autoloads))
 278       (setq autoload-package-name package)
 279       (let ((command-line-args-left (list dir)))
 280         (batch-update-directory)))
 281
 282     (let ((command-line-args-left (list dir)))
 283       (Custom-make-dependencies))
 284
 285     (byte-compile-file (expand-file-name "auto-autoloads.el" dir))
 286     (byte-compile-file (expand-file-name "custom-load.el" dir)))))
 287
 288
 289 ;;; @ Other Utilities
 290 ;;;
 291
 292 (defun install-just-print-p ()
 293   (let ((flag (getenv "MAKEFLAGS"))
 294         (case-fold-search nil))
 295     (princ (format "%s\n" flag))
 296     (if flag
 297         (string-match "^\\(\\(--[^ ]+ \\)+-\\|[^ =-]\\)*n" flag))))
 298
 299
 300 ;;; @ end
 301 ;;;
 302
 303 (require 'product)
 304 (product-provide (provide 'install) (require 'apel-ver))
 305
 306 ;;; install.el ends here