Re: `make' written in elisp

[Richard Stallman]

A year after you posted it, I finally read the source code of install.el.
(I was too backlogged to read source code last January.)

I found that it was extremely clean and appealing code.
If a package system for Emacs can mean something like this,
I am in favor of it.

I would suggest some small changes.

* Instead of asking the user every time whether to install for
everyone or just for him, I think it would be better to have different
command names, or use a prefix argument to mean "global".  It is
not feasible to use the commands from programs if they always
ask questions.

* It seems to assume that auto-compression-mode is enabled, that
just writing a file whose name ends in .gz will compress it.

* A number of functions need doc strings.

Here's the version that was posted a year ago; does anyone want
to work on it further?


;;; install.el --- Package to ease installation of Elisp packages

;; Copyright (C) 2001, 2003  Stefan Monnier

;; Author: Stefan Monnier <address@hidden>

;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;; This little package is meant to ease up the task of installing
;; third party ELisp packages.  I.e. it takes care of placing it in
;; an appropriate location, finds out what code is necessary to get
;; the package activated, sets up your .emacs file to activate the
;; package, and byte-compiles the package.

;; It should work on both single-file packages and tarballs.

;; On tarball packages, it does a bit of guess work to figure out
;; where are which files and how to use them.  This is bound to
;; fail sometimes.

;; Tested on:
;; + ProofGeneral
;; + sml-mode
;; + AUCTeX   (missed the info page)
;; + X-Symbol (as an XEmacs package)
;; + Gnus     (but doesn't install the info doc :-( )
;; + BBDB     (misses the main info page)
;; - WhizzyTeX (needs to hack the perl script and stuff :-( )
;; ? ECB
;; ? JDEE
;; ? preview-latex
;; ? VM
;; ? mmm-mode
;; ? Semantic

;; The on-disk structure is as follows:
;; - there are two area: the `home' and the `site' each with their
;;   respective directory (~/lib/emacs and /usr/share/emacs/site-lisp)
;;   and file (.emacs and site-start).
;; - There is a distinction between installing and activating.
;;   Installing only places the files on disk, whereas activating sets up
;;   autoloads and friends.
;; - Activation is done on a directory by directory basis.  Each directory
;;   has an `autoloads' file.  Loading it activates the package(s)
;;   in directory.
;; - Single-file packages are placed together in the toplevel directory
;;   whereas tarball-packages are placed in their own subdirectory (so they
;;   can be activated independently).

;;; Todo:

;; - don't ask whether to activate site-wide packages installed in home.
;; - Create Info from Texinfo when needed.
;; - Try harder to find Info files such as doc/auctex.
;; - UI to (un)install and (de)activate packages, get a list, ...
;; - If a single-file package lacks ;;;###autoload, try to add them
;;   based on the Commentary section or something.
;; - don't leave out reams of `autoloads~' backup files.

;;; Code:

(require 'em-glob)

(defgroup install nil
  "Elisp package installation")

(defmacro install-filter (list exp)
  (declare (debug t))
  `(let ((res nil))
     (dolist (x ,list (nreverse res))
       (if ,exp (push x res)))))

(defcustom install-site-file
  (or
   (locate-file (or site-run-file "site-start") load-path load-suffixes)
   (let ((lp (mapcar 'abbreviate-file-name load-path)))
     ;; Prefer non-user directories.
     (setq lp (or (install-filter lp (not (string-match "\\`~/" x))) lp))
     ;; Prefer site-lisp directories.
     (setq lp (or (install-filter lp (string-match "/site-lisp\\'" x)) lp))
     ;; Prefer shorter directory names (i.e. parents rather than subdirs).
     (setq lp (sort lp (lambda (d1 d2) (< (length d1) (length d2)))))
     ;; 
     (expand-file-name (concat (or site-run-file "site-start") ".el") (car 
lp))))
  "Site-wide customization file."
  :type 'file)

(defcustom install-site-dir (file-name-directory install-site-file)
  "Directory where site-wide packages should be installed."
  :type 'directory)

(defcustom install-home-file (or user-init-file
                                 (convert-standard-filename "~/.emacs"))
  "Main customization file into which Install should place `load' commands."
  :type 'file)

(defcustom install-home-dir
  ;; FIXME: We should be careful never to choose one of Emacs's own
  ;; directories, even if the user installed Emacs in his home dir.
  (let ((lp (mapcar 'abbreviate-file-name load-path)))
    ;; Only consider writable directories.
    (setq lp (install-filter lp (file-writable-p x)))
    ;; Only consider user directories.
    (setq lp (install-filter lp (string-match "\\`~/" x)))
    ;; Prefer shorter directory names (i.e. parents rather than subdirs).
    (setq lp (sort lp (lambda (d1 d2) (< (length d1) (length d2)))))
    ;; Default to ~/lib/emacs.
    (if (or (null lp)
            ;; If it's a subdir of lib/emacs, use lib/emacs.  This can happen
            ;; because Install does not automatically add lib/emacs to the
            ;; load-path if it only installs tar packages underneath.
            (string-match "\\`~/lib/emacs/" (car lp)))
        "~/lib/emacs/"
      (car lp)))
  "Directory into which elisp packages should be placed by Install."
  :type 'directory)

(defcustom install-autoload-file "autoloads"
  "Name of autoload files used by Install.")

(defcustom install-compress-source-files nil ;; ".gz"
  "If non-nil, Install will try to compress file.")

(defcustom install-byte-compile t
  "If non-nil, elisp files are byte-compiled during installation."
  :type 'boolean)

;;

(defun install-get-dir ()
  "Return the directory into which to install packages."
  (or (and (file-writable-p install-site-dir)
           (y-or-n-p "Install site-wide? ")
           install-site-dir)
      (progn
        (unless (file-writable-p install-home-dir)
          (setq install-home-dir
                (let ((default-directory install-home-dir))
                  (read-directory-name "Directory to install into: ")))
          (unless (file-directory-p install-home-dir)
            (make-directory install-home-dir t)))
        install-home-dir)))

(defun install-get-file ()
  "Return the file into which to activate packages."
  (or (and (file-writable-p install-site-file)
           (y-or-n-p "Activate site-wide? ")
           install-site-file)
      install-home-file))

(defmacro install-with-file (file &rest body)
  (declare (debug t) (indent 1))
  `(let ((install-with-existing-file (find-buffer-visiting ,file)))
     (with-current-buffer (or install-with-existing-file
                              (find-file-noselect ,file))
       (prog1 (save-current-buffer ,@body)
         (unless install-with-existing-file
           (kill-buffer (current-buffer)))))))

;;;###autoload
(defun install-file (file)
  (interactive "fFile to install: ")
  (with-current-buffer (find-file-noselect file)
    (install-buffer)))


;;;###autoload
(defun install-buffer ()
  "Install the current elisp buffer as a package.
The package is install in `install-home-dir', autoloads are added
to the `install-autoload-file' in that directory and the
`install-custom-file' is then updated to load these autoloads."
  (interactive)
  (cond
   ((derived-mode-p 'tar-mode) (install-tar-buffer))
   ((not (derived-mode-p 'emacs-lisp-mode))
    (error "I only know how to install tar.gz and elisp files."))
   (t
    (let* ((install-dir (install-get-dir))
           (package (file-name-nondirectory buffer-file-name))
           (file (expand-file-name package install-dir))
           (autoload (expand-file-name install-autoload-file install-dir)))
      (when (and install-compress-source-files
                 (string-match "\\.el\\'" file))
        (setq file (concat file (if (stringp install-compress-source-files)
                                    install-compress-source-files ".gz"))))
      ;; Install the elisp file.
      (write-region (point-min) (point-max) file)
      ;; Extract the autoloads into a separate file.
      (install-update-autoloads autoload)
      ;; Activate.
      (install-activate autoload)
      ;; Finally, byte compile.  In the present case (a single-file package),
      ;; this could be done before activation.
      (if install-byte-compile
          (byte-compile-file file))))))

(defun install-tar-buffer ()
  "Like `install-buffer' but for a tar package rather than single file."
  (let* ((name (file-name-nondirectory buffer-file-name))
         ;; Strip off ".tar.gz", ".tar", ".tgz", ".tar.Z", ...
         (name (if (string-match "\\.[tT][^.]+\\(\\.[^.]+\\)?\\'" name)
                   (substring name 0 (match-beginning 0)) name))
         (install-dir (install-get-dir))
         (default-directory (expand-file-name name install-dir)))
    ;; Install the files.
    ;; FIXME: check what `tar-untar-buffer' does with symlinks and stuff.
    ;; FIXME: the dir might already exist.
    (make-directory default-directory)
    (tar-untar-buffer)
    (let ((files (directory-files default-directory
                                  nil "\\`\\([^.]\\|\\.[^.]\\|\\.\\..\\)" t)))
      ;; If the tar file already had everything under a single directory,
      ;; remove the redundant level of directory.
      (when (and (= (length files) 1) (file-directory-p (car files)))
        (let* ((f (car files))
               ;; Keep the longest name of the two, assuming that the
               ;; difference is that the longer one has a version number.
               (final (if (> (length name) (length f)) name f))
               (temp (if (= (length name) (length f)) (concat f ".tmp") f)))
          ;; FIXME: the dir might already exist.
          (rename-file f (expand-file-name temp install-dir))
          (setq default-directory install-dir)
          (delete-directory name)
          ;; FIXME: the dir might already exist.
          (unless (equal final temp) (rename-file temp final))
          (setq name final)
          (setq default-directory (expand-file-name final)))))
    (install-directory-inplace)))

;;;###autoload
(defun install-directory-inplace ()
  "Prepare and activate the current directory for use by Emacs.
Sets up the autoload files, activates them and byte-compiles if needed."
  (interactive)
  ;; Extract the autoloads.
  (install-setup-tree)
  ;; Activate the package.
  (install-activate (expand-file-name (install-get-activation-file)))
  ;; Finally, byte-compile the files.
  (if install-byte-compile
      (install-byte-compile-dir)))

(defun install-dirs-of-files (files)
  "Return a list of subdirs containing elisp files."
  (let ((dirs nil)
        (ignore (regexp-opt
                 (cons
                  ;; Ignore contrib directories because they tend to contain
                  ;; either less-debugged code, or packages that might
                  ;; already be installed and can thus interfere.
                  "contrib/"
                  (let ((exts nil))
                    (dolist (ext completion-ignored-extensions exts)
                      (if (eq (aref ext (1- (length ext))) ?/)
                          (push ext exts))))))))
    ;; Collect the dirs that hold elisp files.
    (dolist (file files dirs)
      (let ((dir (file-name-directory file)))
        (unless (or (member dir dirs)
                    (and dir (string-match ignore dir)))
          (push dir dirs))))))

(defun install-find-elisp-dirs ()
  "Return a list of subdirs containing elisp files."
  (install-dirs-of-files (install-glob "**/*.el")))

(defun install-byte-compile-dir ()
  "Byte compile all elisp files under the current directory."
  (let ((load-path (append (mapcar (lambda (dir)
                                     (if dir
                                         (expand-file-name dir)
                                       default-directory))
                                   (install-find-elisp-dirs))
                           load-path)))
    (byte-recompile-directory default-directory 0)))

(defun install-glob (pattern)
  (let ((res (eshell-extended-glob pattern)))
    (if (listp res) res)))

(defun install-get-activation-file ()
  "Return the file to load to activate the package.
This is usually \"./autoloads\", but it can also be \"lisp/foo-site.el\"."
  (if (file-exists-p install-autoload-file)
      install-autoload-file
    (or (car (install-glob (concat "**/" install-autoload-file)))
        (car (install-glob "**/auto-autoloads.el"))
        (car (install-glob "**/*-site.el")))))

(defun install-setup-tree ()
  (eshell-glob-initialize)
  ;; Look for elisp files.
  (let ((dirs (install-find-elisp-dirs))
        (autoload-files nil)
        (toplevel nil))
    ;; Prepare each elisp subdir and collect info along the way.
    (dolist (dir dirs)
      (let ((default-directory (expand-file-name (or dir default-directory))))
        ;; Remove *.elc files, in case they were not compiled for our version.
        (mapc 'delete-file (install-glob "*.elc"))
        ;; Extract autoloads.
        (let ((sites (or (install-glob "auto-autoloads.el")
                         (install-glob "*-site.el"))))
          (if (= 1 (length sites))
              ;; Some packages come with a <pkg>-site.el file instead
              ;; of using autoloads.  In that case, just load that file.
              (push (concat dir (car sites)) autoload-files)
            ;; Otherwise.  Make an autoloads file and load it.
            ;; FIXME: Don't make hundreds of autoload files.
            (let ((exists (file-exists-p install-autoload-file)))
              (if (not (install-update-autoloads install-autoload-file))
                  ;; Don't stupidly add empty autoloads files.
                  (unless exists (delete-file install-autoload-file))
                (push (concat dir install-autoload-file) autoload-files)))))))
    (mapc 'install-ensure-autoloads-file autoload-files)
    ;; Setup the toplevel activation file.
    (if (and (= 1 (length autoload-files))
             (equal (car autoload-files) (install-get-activation-file)))
        (setq toplevel (car autoload-files))
      (setq toplevel install-autoload-file)
      (dolist (file autoload-files)
        (unless (equal file toplevel)
          (install-activate
           `(expand-file-name
             ,(file-relative-name
               (expand-file-name file)
               (file-name-directory (expand-file-name toplevel)))
             (file-name-directory load-file-name))
           toplevel))))
    ;; Make up an info/dir file if necessary and register the info dirs.
    (let ((info-dirs (install-make-info)))
      (when info-dirs
        (install-with-file toplevel
          (unless (derived-mode-p 'emacs-lisp-mode) (emacs-lisp-mode))
          (goto-char (point-min))
          (unless (re-search-forward "(add-to-list[ 
\t\n]+'Info-default-directory-list" nil t)
            (forward-comment (point-max))
            (while (re-search-backward "^" nil t))
            (unless (bolp) (newline))
            (let ((top-dir (file-name-directory (expand-file-name toplevel))))
              (dolist (dir info-dirs)
                (setq dir (expand-file-name (or dir default-directory)))
                (if (equal dir top-dir)
                    (insert "(add-to-list 'Info-default-directory-list 
(file-name-directory load-file-name))\n")
                  (let ((text (pp-to-string (file-relative-name dir top-dir))))
                    (if (string-match "\n\\'" text)
                        (setq text (substring text 0 -1)))
                    (insert "(add-to-list 'Info-default-directory-list\n"
                            "             (expand-file-name " text
                            " (file-name-directory load-file-name)))\n")))))
            (save-buffer)))))))

(defun install-ensure-autoloads-file (file)
  "Make sure that the autoload file FILE exists and if not create it."
  (install-with-file file
    (unless (derived-mode-p 'emacs-lisp-mode) (emacs-lisp-mode))
    (when buffer-read-only
      (set-file-modes buffer-file-name
                      (logior ?\200 (file-modes buffer-file-name)))
      (toggle-read-only))
    (goto-char (point-min))
    ;; Insert a little boiler plate if there's nothing yet.
    (when (eobp)
      (insert ";;; " (file-name-nondirectory file)
              " --- automatically extracted autoloads\n"
              ";;\n"
              ";;; Code:\n\n"
              "\n;; Local Variables:\n"
              ";; version-control: never\n"
              ";; no-byte-compile: t\n"
              ";; no-update-autoloads: t\n"
              ";; End:\n"
              ";;; " (file-name-nondirectory file)
              " ends here\n")
     (goto-char (point-min)))
    ;; Make sure it will setup the load path properly.
    (unless (re-search-forward "\\<load-file-name\\>" nil t)
      (forward-comment (point-max))
      (while (re-search-backward "^" nil t))
      (unless (bolp) (newline))
      (unless (eq (char-before (1- (point))) ?\n) (newline))
      (insert ";; Tell Emacs to look for elisp files in this directory."
              ;; Add some sort of signature.
              "  -- Install\n")
      (insert "(add-to-list 'load-path
              (or (file-name-directory load-file-name) (car load-path)))\n\n")
      (save-buffer)))
  file)

(defvar generated-autoload-file)

(defun install-update-autoloads (autoload)
  "Update file AUTOLOAD.  This will create the file if necessary.
Returns non-nil if there is anything autoloaded into it."
  (setq autoload (expand-file-name autoload))
  (let ((bufp (find-buffer-visiting autoload)))
    (let ((generated-autoload-file (install-ensure-autoloads-file autoload)))
      ;; (update-file-autoloads file)
      (update-directory-autoloads (file-name-directory autoload)))
    ;; Make sure the file sets up the load-path appropriately.
    (with-current-buffer (find-file-noselect autoload)
      (unless (derived-mode-p 'emacs-lisp-mode) (emacs-lisp-mode))
      (goto-char (point-min))
      (re-search-forward "^" nil t) ;Find the first autoload entry.
      (forward-comment (point-max))
      (prog1 (not (eobp))
        (unless bufp (kill-buffer (current-buffer)))))))

(defun install-activate (autoload &optional into)
  "Update INTO to make sure it loads AUTOLOAD.
AUTOLOAD can be an expression.
If it is a string, this also loads it into the currently running Emacs.
If provided, INTO specifies the file which should load AUTOLOAD.
The default is to use `install-get-file'."
  (when (stringp autoload)
    (setq autoload (abbreviate-file-name autoload))
    (load autoload))
  (install-with-file (or into (install-get-file))
    (unless (derived-mode-p 'emacs-lisp-mode) (emacs-lisp-mode))
    (save-excursion
      (let ((text (pp-to-string autoload)))
        (if (string-match "\n\\'" text)
            (setq text (substring text 0 -1)))
        (goto-char (point-min))
        (unless (re-search-forward (regexp-quote text) nil t)
          (goto-char (point-min))
          (forward-comment (point-max))
          (while (re-search-backward "^" nil t))
          (unless (bolp) (newline))
          ;; Pass `install' as argument to load: this both makes Emacs
          ;; ignore the load if the file is missing and is used as a marker
          ;; indicating that this load statement was introduced by us.
          (insert "(load " text " 'install)\n")
          (save-buffer))))))

;;;###autoload
(defun install-list-packages ()
  "Show the installed packages."
  (interactive)
  (dired (install-get-dir)))

;; Info files and DIR files.
;; Some of this should probably be moved to info.el.

(defconst install-info-dir "-*- Text -*-\n\n\
File: dir       Node: Top       This is the top of the INFO tree\
\n\n* Menu:\n\n"
  "Text content of a barebones empty `info/dir' file.")

(defun install-find-info-files ()
  (let ((files (or (install-glob "**/*.info*")
                   (install-glob "**/info/*")))
        (tmp nil))
    (dolist (f files)
      (unless (or (member f '("dir" "localdir"))
                  (and (string-match "-[0-9]+" f)
                       (member (replace-match "" t t f) files))
                  (not (string-match 
"\\.info\\>\\|\\(\\`\\|/\\)[^.]+\\(\\'\\|\\.\\(gz\\|Z\\)\\)" f)))
        (push f tmp)))
    tmp))

(defun install-make-info ()
  "Make an info/dir file if necessary and return the info directories."
  ;; FIXME: This should create the info files from the Texinfo files
  ;; if necessary !!
  ;; Problems to do that:
  ;; - detect when necessary.  E.g. BBDB comes with an info page for
  ;;   the bbdb-filters stuff, but the main bbdb doc is in texinfo.
  ;; - figure out how to makeinfo the thing.  E.g. AucTeX comes with
  ;;   a whole bunch of Texinfo files and it's really not clear which
  ;;   is the right one.
  ;; - The info file might be there, but not found.  E.e. AucTeX has its
  ;;   page in doc/auctex.
  (let* ((files (install-find-info-files))
         (dirs (install-dirs-of-files files))
         (dir-files nil))
    ;; Remove files that were in ignored directories.
    (dolist (file files)
      (unless (member (file-name-directory file) dirs)
        (setq files (delq file files))))
    ;; Check that there's something to do.
    (when files
      (assert dirs)
      (dolist (dir dirs)
        (if (file-exists-p (expand-file-name "dir" dir))
            (push (expand-file-name "dir" dir) dir-files)))
      (unless dir-files
        ;; Pick the dir closest to the toplevel to put the main dir file.
        (setq dirs (sort dirs (lambda (s1 s2) (< (length s1) (length s2)))))
        (install-with-file (expand-file-name "dir" (car dirs))
          (assert (= (point-min) (point-max)))
          (insert install-info-dir)
          (narrow-to-region (point) (point-max))
          (dolist (file files)
            (let ((section "Miscellaneous")
                  (entry nil))
              (install-with-file file
                (goto-char (point-min))
                (if (not (re-search-forward
                          (concat "^START-INFO-DIR-ENTRY\n"
                                  "\\([* \t].*\n\\)+"
                                  "END-INFO-DIR-ENTRY$") nil t))
                    ;; No entry in the file, let's build a default one.
                    (let ((base (file-name-nondirectory
                                 (file-name-sans-extension file))))
                      (setq entry (concat "* " (upcase base)
                                          ": (" base ").\n")))
                  (setq entry (match-string 1))
                  (goto-char (point-min))
                  (when (re-search-forward
                         "^INFO-DIR-SECTION[ \t]+\\(.*[^ \t\n]\\)" nil t)
                    (setq section (match-string 1)))))
              (goto-char (point-min))
              (unless (search-forward entry nil t)
                (unless (re-search-forward (concat "^" (regexp-quote section) 
"[ \t]*\n") nil 'move)
                  (unless (bobp) (newline))
                  (insert section) (newline))
                (insert entry))))
          (save-buffer)
          (kill-buffer (current-buffer))))
      dirs)))
              
              

(provide 'install)
;;; install.el ends here