install.el

   1 ;;; install.el --- Emacs Lisp package install utility
   2
   3 ;; Copyright (C) 1996,1997,1998,1999 Free Software Foundation, Inc.
   4
   5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; Created: 1996/08/18
   7 ;; Keywords: install, byte-compile, directory detection
   8
   9 ;; This file is part of APEL (A Portable Emacs Library).
  10
  11 ;; This program is free software; you can redistribute it and/or
  12 ;; modify it under the terms of the GNU General Public License as
  13 ;; published by the Free Software Foundation; either version 2, or (at
  14 ;; your option) any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful, but
  17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  23 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Code:
  27
  28 ;; for historical reason, we do (require 'emu) in this file.
  29 ;; but you should do (require 'emu) explicitly if you use functions and/or
  30 ;; variables defined in emu module.
  31 ;;(require 'emu)
  32 (require 'poe)          ; emacs-major-version, emacs-minor-version
  33 (require 'path-util)    ; default-load-path
  34
  35 ;; verbatim copy of `defun-maybe' from poe.el, and
  36 ;; `make-directory-internal' and `make-directory' from poe-18.el
  37 (defmacro defun-maybe (name &rest everything-else)
  38   "Define NAME as a function if NAME is not defined.
  39 See also the function `defun'."
  40   (or (and (fboundp name)
  41            (not (get name 'defun-maybe)))
  42       (` (or (fboundp (quote (, name)))
  43              (prog1
  44                  (defun (, name) (,@ everything-else))
  45                (put (quote (, name)) 'defun-maybe t))))))
  46
  47 (defun-maybe make-directory-internal (dirname)
  48   "Create a directory. One argument, a file name string."
  49   (let ((dir (expand-file-name dirname)))
  50     (if (file-exists-p dir)
  51         (error "Creating directory: %s is already exist" dir)
  52       (call-process "mkdir" nil nil nil dir))))
  53
  54 (defun-maybe make-directory (dir &optional parents)
  55   "Create the directory DIR and any nonexistent parent dirs.
  56 The second (optional) argument PARENTS says whether
  57 to create parent directories if they don't exist."
  58   (let ((len (length dir))
  59         (p 0) p1 path)
  60     (catch 'tag
  61       (while (and (< p len) (string-match "[^/]*/?" dir p))
  62         (setq p1 (match-end 0))
  63         (if (= p1 len)
  64             (throw 'tag nil))
  65         (setq path (substring dir 0 p1))
  66         (if (not (file-directory-p path))
  67             (cond ((file-exists-p path)
  68                    (error "Creating directory: %s is not directory" path))
  69                   ((null parents)
  70                    (error "Creating directory: %s is not exist" path))
  71                   (t
  72                    (make-directory-internal path))))
  73         (setq p p1)))
  74     (make-directory-internal dir)))
  75
  76
  77 ;;; @ compile Emacs Lisp files
  78 ;;;
  79
  80 (defun compile-elisp-module (module &optional path every-time)
  81   (setq module (expand-file-name (symbol-name module) path))
  82   (let ((el-file (concat module ".el"))
  83         (elc-file (concat module ".elc")))
  84     (if (or every-time
  85             (file-newer-than-file-p el-file elc-file))
  86         (byte-compile-file el-file))))
  87
  88 (defun compile-elisp-modules (modules &optional path every-time)
  89   (mapcar (function
  90            (lambda (module)
  91              (compile-elisp-module module path every-time)))
  92           modules))
  93
  94
  95 ;;; @ install files
  96 ;;;
  97
  98 (defvar install-overwritten-file-modes (+ (* 64 6)(* 8 4) 4))
  99
 100 (defun install-file (file src dest &optional move overwrite just-print)
 101   (if just-print
 102       (princ (format "%s -> %s\n" file dest))
 103     (let ((src-file (expand-file-name file src)))
 104       (if (file-exists-p src-file)
 105           (let ((full-path (expand-file-name file dest)))
 106             (if (and (file-exists-p full-path) overwrite)
 107                 (delete-file full-path))
 108             (copy-file src-file full-path t t)
 109             (if move
 110                 (catch 'tag
 111                   (while (and (file-exists-p src-file)
 112                               (file-writable-p src-file))
 113                     (condition-case err
 114                         (progn
 115                           (delete-file src-file)
 116                           (throw 'tag nil))
 117                       (error (princ (format "%s\n" (nth 1 err))))))))
 118             (princ (format "%s -> %s\n" file dest)))))))
 119
 120 (defun install-files (files src dest &optional move overwrite just-print)
 121   (or (file-exists-p dest)
 122       (make-directory dest t))
 123   (mapcar (function
 124            (lambda (file)
 125              (install-file file src dest move overwrite just-print)))
 126           files))
 127
 128
 129 ;;; @@ install Emacs Lisp files
 130 ;;;
 131
 132 (defun install-elisp-module (module src dest &optional just-print)
 133   (let (el-file elc-file)
 134     (let ((name (symbol-name module)))
 135       (setq el-file (concat name ".el"))
 136       (setq elc-file (concat name ".elc")))
 137     (let ((src-file (expand-file-name el-file src)))
 138       (if (not (file-exists-p src-file))
 139           nil
 140         (if just-print
 141             (princ (format "%s -> %s\n" el-file dest))
 142           (let ((full-path (expand-file-name el-file dest)))
 143             (if (file-exists-p full-path)
 144                 (delete-file full-path))
 145             (copy-file src-file full-path t t)
 146             (princ (format "%s -> %s\n" el-file dest)))))
 147       (setq src-file (expand-file-name elc-file src))
 148       (if (not (file-exists-p src-file))
 149           nil
 150         (if just-print
 151             (princ (format "%s -> %s\n" elc-file dest))
 152           (let ((full-path (expand-file-name elc-file dest)))
 153             (if (file-exists-p full-path)
 154                 (delete-file full-path))
 155             (copy-file src-file full-path t t)
 156             (catch 'tag
 157               (while (file-exists-p src-file)
 158                 (condition-case err
 159                     (progn
 160                       (delete-file src-file)
 161                       (throw 'tag nil))
 162                   (error (princ (format "%s\n" (nth 1 err)))))))
 163             (princ (format "%s -> %s\n" elc-file dest))))))))
 164
 165 (defun install-elisp-modules (modules src dest &optional just-print)
 166   (or (file-exists-p dest)
 167       (make-directory dest t))
 168   (mapcar (function
 169            (lambda (module)
 170              (install-elisp-module module src dest just-print)))
 171           modules))
 172
 173
 174 ;;; @ detect install path
 175 ;;;
 176
 177 ;; install to shared directory (maybe "/usr/local")
 178 (defvar install-prefix
 179   (if (or (<= emacs-major-version 18)   ; running-emacs-18
 180           (featurep 'xemacs)            ; running-xemacs
 181           (and (boundp 'system-configuration-options) ; 19.29 or later
 182                (string= system-configuration-options "NT"))) ; for Meadow
 183       (expand-file-name "../../.." exec-directory)
 184     (expand-file-name "../../../.." data-directory)))
 185
 186 (defvar install-elisp-prefix
 187   (if (>= emacs-major-version 19)
 188       "site-lisp"
 189     "local.lisp"))
 190
 191 (defun install-detect-elisp-directory (&optional prefix elisp-prefix
 192                                                  allow-version-specific)
 193   (or prefix
 194       (setq prefix install-prefix))
 195   (or elisp-prefix
 196       (setq elisp-prefix install-elisp-prefix))
 197   (or
 198    (catch 'tag
 199      (let ((rest default-load-path)
 200            (pat (concat "^"
 201                         (expand-file-name (concat ".*/" elisp-prefix) prefix)
 202                         "/?$")))
 203        (while rest
 204          (if (string-match pat (car rest))
 205              (if (or allow-version-specific
 206                      (not (string-match (format "/%d\\.%d"
 207                                                 emacs-major-version
 208                                                 emacs-minor-version)
 209                                         (car rest))))
 210                  (throw 'tag (car rest))))
 211          (setq rest (cdr rest)))))
 212    (expand-file-name (concat
 213                       (if (and          ; running-emacs-19_29-or-later
 214                            (not (featurep 'xemacs))
 215                            (or (>= emacs-major-version 20)
 216                                (and (= emacs-major-version 19)
 217                                     (>= emacs-minor-version 29))))
 218                           "share/"
 219                         "lib/")
 220                       (cond ((boundp 'NEMACS) "nemacs/")
 221                             ((boundp 'MULE)   "mule/")
 222                             ((featurep 'xemacs) ; running-xemacs
 223                              (if (featurep 'mule)
 224                                  "xmule/"
 225                                "xemacs/"))
 226                             (t "emacs/"))
 227                       elisp-prefix)
 228                      prefix)))
 229
 230 (defvar install-default-elisp-directory
 231   (install-detect-elisp-directory))
 232
 233
 234 ;;; @ end
 235 ;;;
 236
 237 (provide 'install)
 238
 239 ;;; install.el ends here