install.el

   1 ;;; install.el --- Emacs Lisp package install utility
   2
   3 ;; Copyright (C) 1996 Free Software Foundation, Inc.
   4
   5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; Created: 1996/8/18
   7 ;; Version: $Id: install.el,v 1.6 1996/08/30 15:12:25 morioka Exp $
   8 ;; Keywords: install
   9
  10 ;; This file is part of tl (Tiny 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 this program; see the file COPYING.  If not, write to
  24 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26
  27 ;;; Code:
  28
  29 (defun compile-elisp-module (module &optional path every-time)
  30   (setq module (expand-file-name (symbol-name module) path))
  31   (let ((el-file (concat module ".el"))
  32         (elc-file (concat module ".elc"))
  33         )
  34     (if (or every-time
  35             (file-newer-than-file-p el-file elc-file))
  36         (byte-compile-file el-file)
  37       )
  38     ))
  39
  40 (defun compile-elisp-modules (modules &optional path every-time)
  41   (mapcar (function
  42            (lambda (module)
  43              (compile-elisp-module module path every-time)
  44              ))
  45           modules))
  46
  47
  48 (defvar install-overwritten-file-modes (+ (* 64 6)(* 8 4) 4))
  49
  50 (defun install-file (file src dest &optional move overwrite)
  51   (let ((src-file (expand-file-name file src)))
  52     (if (file-exists-p src-file)
  53         (let ((full-path (expand-file-name file dest)))
  54           (if (and (file-exists-p full-path) overwrite)
  55               (set-file-modes full-path install-overwritten-file-modes)
  56             )
  57           (copy-file src-file full-path t t)
  58           (if move
  59               (catch 'tag
  60                 (while (and (file-exists-p src-file)
  61                             (file-writable-p src-file))
  62                   (condition-case err
  63                       (progn
  64                         (delete-file src-file)
  65                         (throw 'tag nil)
  66                         )
  67                     (error (princ (format "%s\n" (nth 1 err))))
  68                     ))))
  69           (princ (format "%s -> %s\n" file dest))
  70           ))
  71     ))
  72
  73 (defun install-files (files src dest &optional move overwrite)
  74   (or (file-exists-p dest)
  75       (make-directory dest t)
  76       )
  77   (mapcar (function (lambda (file)
  78                       (install-file file src dest move overwrite)
  79                       ))
  80           files))
  81
  82 (defun install-elisp-module (module src dest)
  83   (let (el-file elc-file)
  84     (let ((name (symbol-name module)))
  85       (setq el-file (concat name ".el"))
  86       (setq elc-file (concat name ".elc"))
  87       )
  88     (let ((src-file (expand-file-name el-file src)))
  89       (if (file-exists-p src-file)
  90           (let ((full-path (expand-file-name el-file dest)))
  91             (if (file-exists-p full-path)
  92                 (set-file-modes full-path install-overwritten-file-modes)
  93               )
  94             (copy-file src-file full-path t t)
  95             (princ (format "%s -> %s\n" el-file dest))
  96             ))
  97       (setq src-file (expand-file-name elc-file src))
  98       (if (file-exists-p src-file)
  99           (let ((full-path (expand-file-name elc-file dest)))
 100             (copy-file src-file full-path t t)
 101             (catch 'tag
 102               (while (file-exists-p src-file)
 103                 (condition-case err
 104                     (progn
 105                       (delete-file src-file)
 106                       (throw 'tag nil)
 107                       )
 108                   (error (princ (format "%s\n" (nth 1 err))))
 109                   )))
 110             (princ (format "%s -> %s\n" elc-file dest))
 111             ))
 112       )))
 113
 114 (defun install-elisp-modules (modules src dest)
 115   (or (file-exists-p dest)
 116       (make-directory dest t)
 117       )
 118   (mapcar (function (lambda (module)
 119                       (install-elisp-module module src dest)
 120                       ))
 121           modules))
 122
 123
 124 ;;; @ end
 125 ;;;
 126
 127 (provide 'install)
 128
 129 ;;; install.el ends here