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)
  33 (require 'path-util)                    ; default-load-path
  34
  35 (defvar emacs-major-version (string-to-int emacs-version))
  36 (defvar emacs-minor-version
  37   (string-to-int
  38    (substring emacs-version
  39               (string-match (format "%d\\." emacs-major-version)
  40                             emacs-version))))
  41
  42 ;; verbatim copy of `defun-maybe' from poe.el, and
  43 ;; `make-directory-internal' and `make-directory' from poe-18.el
  44 (defmacro defun-maybe (name &rest everything-else)
  45   "Define NAME as a function if NAME is not defined.
  46 See also the function `defun'."
  47   (or (and (fboundp name)
  48            (not (get name 'defun-maybe)))
  49       (` (or (fboundp (quote (, name)))
  50              (prog1
  51                  (defun (, name) (,@ everything-else))
  52                (put (quote (, name)) 'defun-maybe t))))))
  53
  54 (defun-maybe make-directory-internal (dirname)
  55   "Create a directory. One argument, a file name string."
  56   (let ((dir (expand-file-name dirname)))
  57     (if (file-exists-p dir)
  58         (error "Creating directory: %s is already exist" dir)
  59       (call-process "mkdir" nil nil nil dir))))
  60
  61 (defun-maybe make-directory (dir &optional parents)
  62   "Create the directory DIR and any nonexistent parent dirs.
  63 The second (optional) argument PARENTS says whether
  64 to create parent directories if they don't exist."
  65   (let ((len (length dir))
  66         (p 0) p1 path)
  67     (catch 'tag
  68       (while (and (< p len) (string-match "[^/]*/?" dir p))
  69         (setq p1 (match-end 0))
  70         (if (= p1 len)
  71             (throw 'tag nil))
  72         (setq path (substring dir 0 p1))
  73         (if (not (file-directory-p path))
  74             (cond ((file-exists-p path)
  75                    (error "Creating directory: %s is not directory" path))
  76                   ((null parents)
  77                    (error "Creating directory: %s is not exist" path))
  78                   (t
  79                    (make-directory-internal path))))
  80         (setq p p1)))
  81     (make-directory-internal dir)))
  82
  83
  84 ;;; @ compile Emacs Lisp files
  85 ;;;
  86
  87 (defun compile-elisp-module (module &optional path every-time)
  88   (setq module (expand-file-name (symbol-name module) path))
  89   (let ((el-file (concat module ".el"))
  90         (elc-file (concat module ".elc")))
  91     (if (or every-time
  92             (file-newer-than-file-p el-file elc-file))
  93         (byte-compile-file el-file))))
  94
  95 (defun compile-elisp-modules (modules &optional path every-time)
  96   (mapcar (function
  97            (lambda (module)
  98              (compile-elisp-module module path every-time)))
  99           modules))
 100
 101
 102 ;;; @ install files
 103 ;;;
 104
 105 (defvar install-overwritten-file-modes (+ (* 64 6)(* 8 4) 4))
 106
 107 (defun install-file (file src dest &optional move overwrite just-print)
 108   (if just-print
 109       (princ (format "%s -> %s\n" file dest))
 110     (let ((src-file (expand-file-name file src)))
 111       (if (file-exists-p src-file)
 112           (let ((full-path (expand-file-name file dest)))
 113             (if (and (file-exists-p full-path) overwrite)
 114                 (delete-file full-path))
 115             (copy-file src-file full-path t t)
 116             (if move
 117                 (catch 'tag
 118                   (while (and (file-exists-p src-file)
 119                               (file-writable-p src-file))
 120                     (condition-case err
 121                         (progn
 122                           (delete-file src-file)
 123                           (throw 'tag nil))
 124                       (error (princ (format "%s\n" (nth 1 err))))))))
 125             (princ (format "%s -> %s\n" file dest)))))))
 126
 127 (defun install-files (files src dest &optional move overwrite just-print)
 128   (or (file-exists-p dest)
 129       (make-directory dest t))
 130   (mapcar (function
 131            (lambda (file)
 132              (install-file file src dest move overwrite just-print)))
 133           files))
 134
 135
 136 ;;; @@ install Emacs Lisp files
 137 ;;;
 138
 139 (defun install-elisp-module (module src dest &optional just-print)
 140   (let (el-file elc-file)
 141     (let ((name (symbol-name module)))
 142       (setq el-file (concat name ".el"))
 143       (setq elc-file (concat name ".elc")))
 144     (let ((src-file (expand-file-name el-file src)))
 145       (if (not (file-exists-p src-file))
 146           nil
 147         (if just-print
 148             (princ (format "%s -> %s\n" el-file dest))
 149           (let ((full-path (expand-file-name el-file dest)))
 150             (if (file-exists-p full-path)
 151                 (delete-file full-path))
 152             (copy-file src-file full-path t t)
 153             (princ (format "%s -> %s\n" el-file dest)))))
 154       (setq src-file (expand-file-name elc-file src))
 155       (if (not (file-exists-p src-file))
 156           nil
 157         (if just-print
 158             (princ (format "%s -> %s\n" elc-file dest))
 159           (let ((full-path (expand-file-name elc-file dest)))
 160             (if (file-exists-p full-path)
 161                 (delete-file full-path))
 162             (copy-file src-file full-path t t)
 163             (catch 'tag
 164               (while (file-exists-p src-file)
 165                 (condition-case err
 166                     (progn
 167                       (delete-file src-file)
 168                       (throw 'tag nil))
 169                   (error (princ (format "%s\n" (nth 1 err)))))))
 170             (princ (format "%s -> %s\n" elc-file dest))))))))
 171
 172 (defun install-elisp-modules (modules src dest &optional just-print)
 173   (or (file-exists-p dest)
 174       (make-directory dest t))
 175   (mapcar (function
 176            (lambda (module)
 177              (install-elisp-module module src dest just-print)))
 178           modules))
 179
 180
 181 ;;; @ detect install path
 182 ;;;
 183
 184 ;; install to shared directory (maybe "/usr/local")
 185 (defvar install-prefix
 186   (if (or (<= emacs-major-version 18)   ; running-emacs-18
 187           (featurep 'xemacs)            ; running-xemacs
 188           (and (boundp 'system-configuration-options) ; 19.29 or later
 189                (string= system-configuration-options "NT"))) ; for Meadow
 190       (expand-file-name "../../.." exec-directory)
 191     (expand-file-name "../../../.." data-directory)))
 192
 193 (defvar install-elisp-prefix
 194   (if (>= emacs-major-version 19)
 195       "site-lisp"
 196     "local.lisp"))
 197
 198 (defun install-detect-elisp-directory (&optional prefix elisp-prefix
 199                                                  allow-version-specific)
 200   (or prefix
 201       (setq prefix install-prefix))
 202   (or elisp-prefix
 203       (setq elisp-prefix install-elisp-prefix))
 204   (or
 205    (catch 'tag
 206      (let ((rest default-load-path)
 207            (pat (concat "^"
 208                         (expand-file-name (concat ".*/" elisp-prefix) prefix)
 209                         "/?$")))
 210        (while rest
 211          (if (string-match pat (car rest))
 212              (if (or allow-version-specific
 213                      (not (string-match (format "/%d\\.%d"
 214                                                 emacs-major-version
 215                                                 emacs-minor-version)
 216                                         (car rest))))
 217                  (throw 'tag (car rest))))
 218          (setq rest (cdr rest)))))
 219    (expand-file-name (concat
 220                       (if (and          ; running-emacs-19_29-or-later
 221                            (not (featurep 'xemacs))
 222                            (or (>= emacs-major-version 20)
 223                                (and (= emacs-major-version 19)
 224                                     (>= emacs-minor-version 29))))
 225                           "share/"
 226                         "lib/")
 227                       (cond ((boundp 'NEMACS) "nemacs/")
 228                             ((boundp 'MULE)   "mule/")
 229                             ((featurep 'xemacs) ; running-xemacs
 230                              (if (featurep 'mule)
 231                                  "xmule/"
 232                                "xemacs/"))
 233                             (t "emacs/"))
 234                       elisp-prefix)
 235                      prefix)))
 236
 237 (defvar install-default-elisp-directory
 238   (install-detect-elisp-directory))
 239
 240
 241 ;;; @ end
 242 ;;;
 243
 244 (provide 'install)
 245
 246 ;;; install.el ends here