Towards having elinstall-proceed-p take simpler parameters

[elinstall.git] / elinstall.el

;;;_ elinstall.el --- Automatically and flexibly install elisp files

;;;_. Headers
;;;_ , License
;; Copyright (C) 2010  Tom Breton (Tehom)

;; Author: Tom Breton (Tehom) <tehom@panix.com>
;; Keywords: maint, tools, internal

;; 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.
;;;_ , Version
;;Version: 1.0

;;;_ , Commentary:

;; Entry points:
;; elinstall  Use this for overall loading
;;
;; elinstall-arrange-preload - Use this for non-autogenerated
;; files that need to be linked in.

;; elinstall-update-directory-autoloads 
;; elinstall-update-file-autoloads

;;;_ , Requires

(require 'autoload)
(require 'pp)
(require 'cus-edit)  ;;Because we save "installedness" manually
(require 'byte-compile nil t) ;;


;;;_. Body
;;;_ , Customizations
;;;_  . Group
(defgroup elinstall
   '()
   "Customizations for elinstall"
   :group 'development)
;;;_  . elinstall-default-priority
(defcustom elinstall-default-priority 
   50
   "Default priority for site-start" 
   :group 'elinstall
   :type 'integer)
;;;_  . elinstall-default-preload-target
(defcustom elinstall-default-preload-target
   "~/.emacs.d/site-start.d/"
   "Default preload-target for registering autoloads" 
   :group 'elinstall
   :type
   '(choice 
       (const  "~/.emacs.d/site-start.d/")
       (const  "/etc/emacs/site-start.d/")
       (directory "" )
       (const nil)
       (const 'dot-emacs)))
;;;_  . elinstall-restrain-install
(defcustom elinstall-restrain-install '() 
   "Restrain elinstall for specific packages" 
   :group 'elinstall
   :type 
   '(repeat
       (list 
          (choice :format "%[%t%]: %v"
             (string :tag "Package name")
             (const :tag "All packages" t))
          ;;Spec
          )))

;;;_  . elinstall-already-installed
(with-no-warnings
   (defcustom elinstall-already-installed
      '()
      "(AUTOMATIC) Things that have already been installed.
This exists for recording what has been installed.  

Though it's saved as customizable, user interaction is not
contemplated." ))
;;Tell the byte-compiler it's a variable.
(defvar elinstall-already-installed) 
;;;_ , Types
;;;_  . elinstall-stages
(defstruct (elinstall-stages
              (:constructor elinstall-make-stages)
              (:conc-name elinstall-stages->)
              (:copier nil))
   "The elinstall stages"
   build-deffiles
   run-tests
   byte-compile
   arrange-preloads)
;;;_ , Data
;;;_  . Regular expressions
;;;_   , elinstall-elisp-regexp
(defconst elinstall-elisp-regexp
   (let ((tmp nil))
      (dolist 
         (suf (get-load-suffixes))
         (unless (string-match "\\.elc" suf) (push suf tmp)))
      (concat "^[^=.].*" (regexp-opt tmp t) "\\'"))
   "Regular expression that matches elisp files" )
;;;_ , Utilities
;;;_  . elinstall-file-mod-time
(defsubst elinstall-file-mod-time (file)
   "Return the modification time of FILE"
   (nth 5 (file-attributes file)))

;;;_  . elinstall-directory-true-name
(defun elinstall-directory-true-name ()
   "Get the true name of the directory the calling code lives in.
CAUTION:  This is sensitive to where it's called.  That's the point of it."
   (file-name-directory
      (if load-file-name
         (file-truename load-file-name)
         (file-truename buffer-file-name))))
;;;_  . Checking installedness
;;;_   , elinstall-get-installation-record
(defun elinstall-get-installation-record (project-name)
   "Return the installation record for PROJECT-NAME."

   (assoc project-name elinstall-already-installed))

;;;_   , elinstall-already-installed
(defun elinstall-already-installed (project-name)
   "Return non-nil if PROJECT-NAME has been installed."
   (elinstall-get-installation-record project-name))

;;;_   , elinstall-record-installed
(defun elinstall-record-installed (project-name &optional version)
   "Record that PROJECT-NAME has been installed."
   (let
      ((new-item
          (list 
             project-name 
             (or version "0") 
             (current-time) 
             'installed))
         (old-item
            (elinstall-get-installation-record project-name))
         (print-length nil)
         (print-level  nil))
      (when old-item
         (setq elinstall-already-installed
            (delete old-item elinstall-already-installed)))
      (push new-item elinstall-already-installed)
      (customize-save-variable 
         'elinstall-already-installed 
         elinstall-already-installed
         "Set by elinstall-record-installed")))
;;;_  . Finding deffiles
;;;_   , elinstall-expand-deffile-name
(defun elinstall-expand-deffile-name (deffile)
   "Expand DEFFILE autoload.el's way."
   
   (expand-file-name (or deffile "loaddefs.el")
      (expand-file-name "lisp"
         source-directory)))
;;;_  . Checking restraint specs
;;;_   , elinstall-call-with-restraints
(defun elinstall-call-with-restraints (restraints package func &rest args)
   "Call FUNC with ARGS, in scope of RESTRAINTS.
RESTRAINTS is a list of package restraints.  User restraints for the
given package will also be applied in scope.

PACKAGE can be `t' or a string naming a package."
   
   (let*  
      ((elinstall:*pkg-restraints* restraints)
         ;;$$PUNT for now.  Figure out user restraints for this
         ;;package.
         (elinstall:*user-restraints*
            nil))
      (declare (special 
                  elinstall:*pkg-restraints*
                  elinstall:*user-restraints*))
      (apply func args)))
;;;_   , 
(defun elinstall-proceed-p 
   (topic ask-prompt &optional already-p redo-prompt noredo-msg)
   "Return non-nil if actions on TOPIC should proceed.
Call this transitively only thru `elinstall-call-with-restraints'"
   
   (check-type topic symbol)
   (declare (special 
               elinstall:*pkg-restraints*
               elinstall:*user-restraints*))
   (unless (and 
              (boundp 'elinstall:*pkg-restraints*)
              (boundp 'elinstall:*user-restraints*))
      (error "elinstall-proceed-p called out of scope"))

   (let*
      (  (cell (assq topic elinstall:*user-restraints*))
         (cell (or cell (assq t elinstall:*user-restraints*)))
         (cell
            ;;`t' means use the pkg-restraints value instead.
            (if 
               (or (not cell) (eq (second cell) t))
               (assq topic elinstall:*pkg-restraints*)
               cell))
         (cell (or cell (assq t elinstall:*pkg-restraints*)))
         ;;Default is to just update.
         (treatment
            (if cell (second cell) 'update)))
      (case treatment
         ((nil) 
            nil)
         ((t always) 
            t)
         (update 
            (if already-p
               (progn
                  (message noredo-msg)
                  nil)
               t))
         (ask-for-old
            (if already-p
               (y-or-n-p redo-prompt)
               t))
         (ask
            (y-or-n-p ask-prompt)))))

;;;_ , Work
;;;_  . Doing actions

;;;_   , Doing autoload actions (adapted from autoload.el)
;;;_    . Utilities about the action list
;;;_     , elinstall-remove-autogen-action
(defun elinstall-remove-autogen-action (file actions)
   "Return ACTIONS minus any add-file-autoloads on FILE removed."

   (delq nil
      (mapcar
         #'(lambda (act)
              (case (car act)
                 (add-file-autoloads
                    (if (equal file (third act))
                       nil
                       act))
                 (t act)))
         actions)))
;;;_     , elinstall-get-autogen-action
(defun elinstall-get-autogen-action (file actions)
   ""
   (let
      ((the-act))
      (dolist (act actions)
         (case (car act)
            (add-file-autoloads
               (when (equal file (third act))
                  (setq the-act act)))))
      the-act))
;;;_    . About printing to autoload file
;;;_     , elinstall-insert-section-header
(defun elinstall-insert-section-header (outbuf form)
  "Insert the section-header line,
which lists the file name and which functions are in it, etc."
  (insert generate-autoload-section-header)
  (prin1 form outbuf)
  (terpri outbuf)
  ;; Break that line at spaces, to avoid very long lines.
  ;; Make each sub-line into a comment.
  (with-current-buffer outbuf
    (save-excursion
      (forward-line -1)
      (while (not (eolp))
        (move-to-column 64)
        (skip-chars-forward "^ \n")
        (or (eolp)
            (insert "\n" generate-autoload-section-continuation))))))

;;;_     , elinstall-insert-autoload-section
(defun elinstall-insert-autoload-section (text form &optional comment-string)
   "Insert TEXT into current buffer as an autoload section"
   
   (let* ( 
            (print-length nil)
            (print-level  nil)
            ;; This does something in Lucid Emacs.
            (print-readably t)   
            (float-output-format nil))
   
      (elinstall-insert-section-header (current-buffer) form)
      (when comment-string
         (insert ";;; " comment-string "\n"))
      (insert text)
      (insert generate-autoload-section-trailer)))

;;;_    . Making autoloads
;;;_     , elinstall-make-autoload-action
(defun elinstall-make-autoload-action (buf def-file load-path-element full-path)
   "Return the autoloads for current buffer as a string"

   ;;We put all the text into a temp buffer, then get that buffer's
   ;;string.
   (let
      ((outbuf
          (generate-new-buffer " *temp*"))
         (autoloads-done '())
         (short-name
            (file-name-nondirectory full-path))

         (print-length nil)
         (print-level  nil)
         ;; Apparently this does something in Lucid Emacs.
         (print-readably t)      
         (float-output-format nil)

         ;;load-name relative to a member of load-path.
         (relative-name
            (file-name-sans-extension
               (file-relative-name
                  full-path
                  load-path-element))))
      
      (with-current-buffer buf
         (unwind-protect
            (save-excursion
               (save-restriction
                  (widen)
                  (goto-char (point-min))
                  (message "Finding autoloads for %s..." short-name)
                  (while (not (eobp))
                     (skip-chars-forward " \t\n\f")
                     (cond
                        ((looking-at (regexp-quote generate-autoload-cookie))
                           (search-forward generate-autoload-cookie)
                           (skip-chars-forward " \t")
                           (if (eolp)
                              ;; Read the next form and make an autoload.
                              (let* ((form (prog1 (read (current-buffer))
                                              (or (bolp) (forward-line 1))))
                                       (autoload 
                                          (make-autoload form relative-name)))
                                 (if autoload
                                    (push (nth 1 form) autoloads-done)
                                    (setq autoload form))
                                 (let ((autoload-print-form-outbuf outbuf))
                                    (autoload-print-form autoload)))

                              ;; Copy the rest of the line to the output.
                              (princ (buffer-substring
                                        (progn
                                           ;; Back up over whitespace,
                                           ;; to preserve it.
                                           (skip-chars-backward " \f\t")
                                           (if (= (char-after (1+ (point))) ? )
                                              ;; Eat one space.
                                              (forward-char 1))
                                           (point))
                                        (progn (forward-line 1) (point)))
                                 outbuf)))
                        ((looking-at ";")
                           ;; Don't read the comment.
                           (forward-line 1))
                        (t
                           (forward-sexp 1)
                           (forward-line 1))))
                  (message "Finding autoloads for %s...done" short-name))

               ;;Return this action.  The temp buffer's contents is
               ;;our final string.
               `(add-file-autoloads
                   ,def-file
                   ,relative-name
                   ,full-path
                   ,(with-current-buffer outbuf (buffer-string))
                   ,autoloads-done))
            
            ;;This in unwind-protected
            (when (buffer-live-p outbuf) (kill-buffer outbuf))))))


;;;_     , elinstall-generate-file-autoloads 

(defun elinstall-generate-file-autoloads 
   (relative-name full-name text autoloads-done)
   "Insert at point a loaddefs autoload section for FILE.
Autoloads are generated for defuns and defmacros in FILE
marked by `generate-autoload-cookie' (which see).
If FILE is being visited in a buffer, the contents of the buffer
are used.
Return non-nil in the case where no autoloads were added at point.

FULL-NAME is the absolute name of the file.
RELATIVE-NAME is its name respective to some component of load-path."
   (if (not (equal text ""))
      ;; Insert the section-header line which lists the file name and
      ;; which functions are in it, etc.
      (elinstall-insert-autoload-section
         text
         (list 'autoloads 
            autoloads-done
            relative-name
            (autoload-trim-file-name full-name)
            (elinstall-file-mod-time full-name))
         (concat
            "Generated autoloads from " 
            (autoload-trim-file-name full-name)))
      t))

;;;_     , elinstall-deffile-insert-autoloads
(defun elinstall-deffile-insert-autoloads (file args)
   "Update the autoloads for FILE in current buffer.
Return FILE if there was no autoload cookie in it, else nil.

Current buffer must be a loaddef-style file.

LOAD-NAME is the absolute name of the file.
RELATIVE-NAME is its name respective to some component of load-path."
   (let (
           (found nil)
           (no-autoloads nil))

      (save-excursion
         (save-restriction
            (widen)
            (goto-char (point-min))
            ;; Look for the section for FILE
            (while (and (not found)
                      (search-forward generate-autoload-section-header nil t))
               (let ((form (autoload-read-section-header)))
                  (cond 
                     ((equal (nth 2 form) file)
                        ;; We found the section for this file.
                        (let ((begin (match-beginning 0)))
                           (progn
                              (search-forward generate-autoload-section-trailer)
                              (delete-region begin (point))
                              (setq found t))))
                     ((string< file (nth 2 form))
                        ;; We've come to a section alphabetically later than
                        ;; FILE.  We assume the file is in order and so
                        ;; there must be no section for FILE.  We will
                        ;; insert one before the section here.
                        (goto-char (match-beginning 0))
                        (setq found 'new)))))
            (unless found
               (progn
                  (setq found 'new)
                  ;; No later sections in the file.  Put before the last page.
                  (goto-char (point-max))
                  (search-backward "\f" nil t)))
            (setq no-autoloads 
               (apply #'elinstall-generate-file-autoloads
                  file args))))
      
      (if no-autoloads file nil)))
;;;_    . Arranging to add to info-path and load-path
;;;_     , elinstall-generate-add-to-path
(defun elinstall-generate-add-to-path (path-element type)
  "Insert code at point  to add PATH-ELEMENT to a path.
If TYPE is:
 * `add-to-load-path', add to load-path
 * `add-to-info-path', add to Info-additional-directory-list

Current buffer must be a loaddef-style file."
  (let (  (path-symbol
             (case type
                (add-to-load-path 'load-path)
                (add-to-info-path 'Info-additional-directory-list)
                (t (error "Type not recognized"))))
          (description
             (case type
                (add-to-load-path "load-path")
                (add-to-info-path "info-path")))
          (autoloads-done '())
          (print-length nil)
          (print-level  nil)
          ;; This does something in Lucid Emacs.
          (print-readably t)     
          (float-output-format nil))

     (message "Generating %s additions..." description)

     (elinstall-insert-autoload-section
        (pp-to-string
           `(add-to-list ',path-symbol
               (expand-file-name 
                  ,(file-relative-name path-element)
                  (if load-file-name
                     (file-name-directory
                        (file-truename load-file-name))))))
        (list type (list path-element) nil nil nil)
        nil)
     (message "Generating %s additions...done" description)))


;;;_     , elinstall-deffile-insert-add-to-path
(defun elinstall-deffile-insert-add-to-path (path-element type)
   "Insert code in current buffer to add PATH-ELEMENT to a path.
If TYPE is:
 * `add-to-load-path', add to load-path
 * `add-to-info-path', add to Info-default-directory-list

Current buffer must be a loaddef-style file."
   (let (
           (found nil)
           (no-autoloads nil))

      (save-excursion
         (save-restriction
            (widen)
            (goto-char (point-min))
            ;; Look for the section for PATH-ELEMENT
            (while (and (not found)
                      (search-forward generate-autoload-section-header nil t))
               (let ((form (autoload-read-section-header)))
                  (cond 
                     ((and
                         (equal (nth 0 form) type)
                         (member path-element (nth 1 form)))
                        
                        ;; We found the section for this add.
                        (let ((begin (match-beginning 0)))
                           (progn
                              (search-forward generate-autoload-section-trailer)
                              (delete-region begin (point))
                              (setq found t)))))))
            
            (unless found
               (progn
                  (setq found 'new)
                  ;; No later sections in the file.  Put before the last page.
                  (goto-char (point-max))
                  (search-backward "\f" nil t)))

            (elinstall-generate-add-to-path path-element type)))

      ;;This never belongs in the no-autoloads section.
      nil))
;;;_    . elinstall-deffile-insert

(defun elinstall-deffile-insert (action)
   "Insert autoloads etc into current file according to ACTION.
The format of ACTION is described in the design docs.

Return filename if this action belongs in the no-autoload section."

   (when action
      (case (car action)
         (add-file-autoloads
            (elinstall-deffile-insert-autoloads
               (third action)
               (nthcdr 3 action)))
         
         (add-to-load-path
            (elinstall-deffile-insert-add-to-path
               (third action)
               'add-to-load-path)
            nil)

         (add-to-info-path
            (elinstall-deffile-insert-add-to-path
               (third action)
               'add-to-info-path)
            nil)
         
         ((preload-file run-tests byte-compile)
            (error "This case should not come here.")))))

;;;_    . elinstall-prepare-deffile
(defun elinstall-prepare-deffile (deffile)
   "Try to ensure that DEFFILE is available for receiving autoloads"
   
   (autoload-ensure-default-file deffile)
   (with-current-buffer (find-file-noselect deffile)

         
      ;; We must read/write the file without any code conversion,
      ;; but still decode EOLs.
      (let ((coding-system-for-read 'raw-text))

         ;; This is to make generated-autoload-file have Unix EOLs, so
         ;; that it is portable to all platforms.
         (setq buffer-file-coding-system 'raw-text-unix))
      (or (> (buffer-size) 0)
         (error "Autoloads file %s does not exist" buffer-file-name))
      (or (file-writable-p buffer-file-name)
         (error "Autoloads file %s is not writable"
            buffer-file-name))))

;;;_    . elinstall-update-deffile

;;Adapted from autoload.el `update-directory-autoloads'.

(defun elinstall-update-deffile (target actions &optional
                                   use-load-path force)
  "\
Update file TARGET with current autoloads as specified by ACTIONS.
Also remove any old definitions pointing to libraries that can no
longer be found.

ACTIONS must be a list of actions (See the format doc).  Each one's
filename must be relative to some element of load-path.

USE-LOAD-PATH is a list to use as load-path.  It should include
any new load-path that we are arranging to create.  If it's not given,
load-path itself is used.

If FORCE is `t', do it regardless of timestamps etc. (Not implemented)
Other non-nil cases of FORCE are reserved for future development.

This uses `update-file-autoloads' (which see) to do its work.
In an interactive call, you must give one argument, the name
of a single directory."
  (let
     (
        (use-load-path (or use-load-path load-path))
        (this-time (current-time))
        ;;files with no autoload cookies.
        (no-autoloads nil))
     
     (elinstall-prepare-deffile target)
     (with-current-buffer
        (find-file-noselect target)
        (save-excursion
           (setq actions
              (elinstall-remove-autogen-action
                 (autoload-trim-file-name target) 
                 actions))

           (goto-char (point-min))
           (while (search-forward generate-autoload-section-header nil t)
              (let* ((form (autoload-read-section-header))
                       (file (nth 3 form)))
                 (cond ((and (consp file) (stringp (car file)))
                          ;; This is a list of files that have no
                          ;; autoload cookies.
                          ;; There shouldn't be more than one such entry.
                          ;; Remove the obsolete section.
                          (autoload-remove-section (match-beginning 0))
                          (let ((last-time (nth 4 form)))
                             (dolist (file file)
                                (let ((file-time (elinstall-file-mod-time file)))
                                   (when (and file-time
                                            (not (time-less-p last-time file-time)))
                                      ;; file unchanged
                                      (push file no-autoloads)
                                      (setq actions
                                         (elinstall-remove-autogen-action
                                            file actions)))))))
                    ((not (stringp file)))
                    (t
                       (let
                          ((file-path
                              (locate-library file nil use-load-path)))
                          (cond
                             ;;File doesn't exist, so remove its
                             ;;section.
                             ((not file-path)
                                (autoload-remove-section 
                                   (match-beginning 0)))

                             ;; File hasn't changed, so do nothing.
                             ((equal 
                                 (nth 4 form) 
                                 (elinstall-file-mod-time file-path))
                                nil)
                             (t
                                (elinstall-deffile-insert
                                   (elinstall-get-autogen-action 
                                      file actions))))

                          (setq actions
                             (elinstall-remove-autogen-action
                                file actions))))))))

        ;; Remaining actions have no existing autoload sections yet.
        (setq no-autoloads
           (append no-autoloads
              (delq nil (mapcar #'elinstall-deffile-insert actions))))
        (when no-autoloads
           ;; Sort them for better readability.
           (setq no-autoloads (sort no-autoloads 'string<))
           ;; Add the `no-autoloads' section.
           (goto-char (point-max))
           (search-backward "\f" nil t)
           (elinstall-insert-autoload-section
              ""
              (list 'autoloads nil nil no-autoloads this-time)))
        (save-buffer))))

;;;_    . elinstall-stage-update-deffiles
(defun elinstall-stage-update-deffiles (segment-list force use-load-path)
   "Update any deffiles mentioned in SEGMENT-LIST.
FORCE and USE-LOAD-PATH have the same meaning as in
`elinstall-update-deffile'.
"
   (mapcar
      #'(lambda (segment)
           (let*
              ((deffile (car segment)))
              (if (stringp deffile)
                 (elinstall-update-deffile deffile (cdr segment) force
                    use-load-path))))
      segment-list))

;;;_   , Doing actions to arrange preloads
;;;_    . elinstall-symlink-on-emacs-start
(defun elinstall-symlink-on-emacs-start 
   (filename target-basename target-dir &optional priority force)
   "Symlink to TARGET-BASENAME.el in TARGET-DIR

If PRIORITY is given, it will be used as the priority prefix,
otherwise elinstall-default-priority will be.
PRIORITY must be an integer or nil.
If FORCE is `t', do it regardless of timestamps etc.
Other non-nil cases of FORCE are reserved for future development."
   (let*
      (  
         (priority   (or priority elinstall-default-priority))
         (target-name-nodir
            (format
               "%d%s.el"
               priority
               target-basename))
         (target 
            (expand-file-name target-name-nodir target-dir)))
      
      
      (cond
         ;;Path should already exist.
         ((not
             (file-exists-p target-dir))
            (message "The target directory doesn't exist."))
         ;;Target shouldn't already exist, but if force is given, let
         ;;user override.
         ;;$$IMPROVE ME If it is a symlink pointing to the same place,
         ;;do nothing even on force.
         ((and
             (file-exists-p target)
             (or
                (not force)
                (not
                   (yes-or-no-p 
                      (format "Really overwrite %s? " target))))
             (message "File %s already exists" target)))
         
         (t
            (make-symbolic-link 
               filename
               target
               nil)))))

;;;_    . elinstall-add-to-dot-emacs
(defun elinstall-add-to-dot-emacs (dot-emacs-name filename force &rest r)
   "Add code to load FILENAME to .emacs.
FILENAME should not have an extension"

   ;;Visit .emacs
   (with-current-buffer (find-file-noselect dot-emacs-name)
      (save-excursion
         ;;add at end of file
         (goto-char (point-max))
         (insert "\n;;Added by elinstall")
         (insert "\n;;Consider using my-site-start to manage .emacs\n")
         (pp `(load ,filename) (current-buffer))
         (save-buffer))))


;;;_    . elinstall-arrange-preload
;;;###autoload
(defun elinstall-arrange-preload (force filename basename &optional priority) 
   "Arrange for FILENAME to be loaded on emacs start.
FORCE has its usual meaning.
BASENAME and PRIORITY are used as arguments to
`elinstall-symlink-on-emacs-start'.
"

   (let
      ((preload-target elinstall-default-preload-target))
      
      ;;Dispatch the possibilities.
      (cond
         ((eq preload-target 'dot-emacs)
            (elinstall-add-to-dot-emacs "~/.emacs" filename force))
         ((stringp preload-target)
            (elinstall-symlink-on-emacs-start 
               filename basename preload-target priority force))
         ((null preload-target)
            (message "Not arranging for preloads"))
         (t
            (message "I don't recognize that")))))
;;;_    . elinstall-stage-arrange-preloads
(defun elinstall-stage-arrange-preloads (actions deffiles-used force)
   "Arrange any preloads mentioned in ACTIONS."
   
   (mapcar
      #'(lambda (act)
           (case (car act)
              (preload-file
                 (let*
                    (  (filename
                          (caddr act))
                       (proceed-p 
                          (case (second act)
                             ((t) t)
                             ((nil) nil)
                             (if-used
                                (member filename deffiles-used)))))

                    (when proceed-p
                       (apply
                          #'elinstall-arrange-preload
                          force
                          (cddr act)))))
              (t
                 (error
                    "elinstall-stage-arrange-preloads: Action not
           recognized.")))  )
      actions))


;;;_   , Run tests
;;;_    . elinstall-stage-run-tests
(defun elinstall-stage-run-tests (actions)
   "Run any tests mentioned in ACTIONS."

   (mapcar
      #'(lambda (act)
           (case (car act)
              (run-tests
                 ;;$$WRITE ME - not a high priority right now.
                 nil)
              (t
                 (error
                    "elinstall-stage-run-tests: Action not
           recognized.")))  )
      actions))


;;;_   , Byte compile
;;;_    . elinstall-stage-byte-compile
(defun elinstall-stage-byte-compile (actions)
   "Do any byte-compilation mentioned in ACTIONS."

   (mapcar
      #'(lambda (act)
           (case (car act)
              ;;$$IMPROVE ME Understand flags to control second
              ;;argument (whether to load file after
              ;;compilation)
              (byte-compile
                 (byte-compile-file (second act)))
              (t
                 (error
                    "elinstall-stage-byte-compile: Action not
           recognized.")))  )
      actions))
;;;_  . Segregating actions
;;;_   , elinstall-remove-empty-segs
(defun elinstall-remove-empty-segs (segment-list)
   "Return SEGMENT-LIST minus any segments that have no actions.
Intended only for the deffile stage data."
   (delq nil
      (mapcar
         #'(lambda (segment)
              (if (cdr segment)
                 segment
                 nil))
         segment-list)))

;;;_   , elinstall-segregate-actions
(defun elinstall-segregate-actions (actions)
   "Return actions segregated by deffile.

Returns a list whose elements are each a cons of:
 * deffile filename or nil
 * A list of actions to be done for that deffile."

   (let
      (
         (build-deffiles   '())
         (run-tests         '())
         (byte-compile     '())
         (arrange-preloads '()))
      
      (dolist (act actions)
         (when act
            (case (car act)
               ((add-file-autoloads 
                   add-to-info-path
                   add-to-load-path)
                  (let*
                     ((deffile-name (second act))
                        (cell-already
                           (assoc deffile-name build-deffiles)))
                     (if cell-already
                        ;;There are already actions on this deffile.
                        ;;Splice this action in.
                        (setcdr cell-already 
                           (cons act (cdr cell-already)))
                        ;;There are no actions on this deffile.  Add a
                        ;;place for them and include this action.
                        (push (list deffile-name act) build-deffiles))))
               (preload-file
                  (push act arrange-preloads))
               (run-tests
                  (push act run-tests))
               (byte-compile
                  (push act byte-compile)))))

      (elinstall-make-stages
         :build-deffiles
         (elinstall-remove-empty-segs build-deffiles)
         :run-tests
         run-tests
         :byte-compile
         byte-compile
         :arrange-preloads
         arrange-preloads)))
;;;_  . Finding actions
;;;_   , Utility
;;;_    . elinstall-dir-has-info

;;$$IMPROVE ME - Can this test be made more precise?
(defun elinstall-dir-has-info (dir)
   "Return non-nil if DIR has info files in it.
DIR should be an absolute path."
   (or
      (string-match "/info/" dir)
      (directory-files dir nil "\\.info\\(-[0-9]+\\)?\\(\\.gz\\)?$")))
;;;_    . elinstall-directory-files
(defun elinstall-directory-files (dirname)
   "Return a list of files in directory DIRNAME, minus certain files.
The following files are omitted:
 * Dot files
 * Files that match an entry in `block-in-subtree'.
Filenames are relative."
   (declare (special
               def-file block-in-dir block-in-subtree))
   (let*
      (
         ;;Relative filenames of this directory's files.  
         (all-files
            ;; Don't include dot files.  If user really wants to
            ;;explore one he can use (dir ".NAME") or (file ".NAME")
            (directory-files dirname nil "[^\\.]"))
         ;;We know our def-file isn't really source so remove it.
         ;;We'd have removed it anyways after seeing file local vars.
         (all-files
            (remove def-file all-files))
         
         (all-files
            (delq nil
               (mapcar
                  #'(lambda (filename)
                       (if
                          (and 
                             block-in-subtree
                             (some
                                #'(lambda (blocked)
                                     (string-match blocked filename))
                                block-in-subtree))
                          nil
                          filename))
                  all-files))))
      all-files))


;;;_   , Workers
;;;_    . List of special variables used in this section
;;load-path-element - The relevant element of load-path
;;def-file - The file the autoload definitions etc will go into.
;;add-to-load-path-p - Controls whether to add to load-path.
;;recurse-dirs-p - Whether to recurse into subdirectories.

;;block-in-dir - (NOT IMPLEMENTED) List of filenames to reject.  They
;;may include wildcards.  They apply wrt the original directory.

;;block-in-subtree - (NOT IMPLEMENTED) List of filenames to reject.
;;They may include wildcards.  They apply wrt any directory in the
;;tree.  Specifically, in the spec tree, which may differ from the
;;file subtree.
;;byte-compile - whether to byte-compile at all, t by default.
;;autoloads - boolean whether to make autoloads, t by default.
;;preloads - boolean whether to set up preloads, t by default.
(defconst elinstall-find-actions-control-vars 
   '(add-to-load-path-p recurse-dirs-p byte-compile
       autoloads preloads)
   "Control special variables that the find-actions tree recognizes" )
;;;_    . elinstall-actions-for-source-file
(defun elinstall-actions-for-source-file (filename dir)
   "Return a list of actions to do for FILENAME in DIR.
Special variables are as noted in \"List of special variables\"."
   (declare (special
               load-path-element def-file byte-compile))
   (let
      ((full-path
          (expand-file-name filename dir)))
      (when
         (and
            (file-readable-p full-path)
            (not (auto-save-file-name-p full-path)))
         ;;$$IMPROVE ME Use more of the control variables.
         (let*
            (
               (visited (get-file-buffer full-path))
               (buf 
                  (or 
                     visited
                     ;;Visit the file cheaply.
                     ;;hack-local-variables can give errors.
                     (ignore-errors (autoload-find-file full-path))))
               (def-file
                  (or
                     (ignore-errors
                        (with-current-buffer buf 
                           (if (local-variable-p 'generated-autoload-file)
                              (elinstall-expand-deffile-name
                                 generated-autoload-file)
                              nil)))
                     def-file))
               ;;Figure out whether to run some actions, by file local vars.
               (autoloads-p
                  (ignore-errors
                     (with-current-buffer buf 
                        (not no-update-autoloads))))
               (do-compile-p
                  (and
                     byte-compile
                     (featurep 'byte-compile)
                     (string-match emacs-lisp-file-regexp filename)
                     (ignore-errors 
                        (with-current-buffer buf 
                           (not no-byte-compile)))
                     (elinstall-proceed-p 'byte-compile 
                        (concat "Compile " filename "? ")
                        (let
                           ((dest (byte-compile-dest-file full-path)))
                           (and 
                              (file-exists-p dest) 
                              (file-newer-than-file-p full-path dest)))
                        (concat "Recompile " filename "? ")
                        (concat "Already compiled " filename "."))
                     '(elinstall-proceed-p 'byte-compile 
                         (list
                            '( "Compile %s? "
                                "Recompile %s? "
                                "Already compiled %s.")
                            filename)
                         (let
                            ((dest (byte-compile-dest-file full-path)))
                            (and 
                               (file-exists-p dest) 
                               (file-newer-than-file-p full-path dest)))))))
            
            (prog1
               (list
                  (if do-compile-p
                     `(byte-compile ,full-path)
                     nil)
                  (if autoloads-p
                     (elinstall-make-autoload-action
                        buf def-file load-path-element full-path)
                     nil))
               (unless visited (kill-buffer-if-not-modified buf)))))))
;;;_    . elinstall-actions-for-dir
(defun elinstall-actions-for-dir (dirname &optional recurse-dirs-p)
   "Make actions for DIR.
Recurse just if RECURSE-DIRS-P"
   (declare (special
               load-path-element def-file add-to-load-path-p))
   ;;This does not treat symlinks specially.  $$IMPROVE ME it could
   ;;treat/not treat them conditional on control variables.
   (let*
      (
         (files (elinstall-directory-files dirname))

         ;;Relative filenames of elisp source
         (elisp-source-files
            (delq nil
               (mapcar
                  #'(lambda (filename)
                       (if
                          (string-match elinstall-elisp-regexp filename)
                          filename
                          nil))
                  files)))

         ;;Absolute filenames of subdirectories.
         (sub-dirs
            (if recurse-dirs-p
               (delq nil
                  (mapcar
                     #'(lambda (filename)
                          (let
                             ((fn (expand-file-name filename dirname)))
                          (if
                             (file-directory-p fn)
                             fn
                             nil)))
                     files))
               '()))
                  
         (load-path-here-p
            (and 
               elisp-source-files ;;If list is not empty.
               add-to-load-path-p))
         (load-path-element
            (if load-path-here-p
               dirname
               load-path-element)))
               
      (append
         ;;Sometimes arrange to add this directory to load-path.
         (if load-path-here-p
            `((add-to-load-path
                 ,def-file
                 ,load-path-element))
            '())

         ;;$$IMPROVE ME - be controlled by a control variable.
         ;;Sometimes add this directory to info path.
         (if
            (elinstall-dir-has-info dirname)
            `((add-to-info-path
                 ,def-file
                 "."))
            '())

         (apply #'nconc
            (mapcar
               #'(lambda (filename)
                    (elinstall-actions-for-source-file
                       filename 
                       dirname))
               elisp-source-files))

         (if recurse-dirs-p
            (apply #'nconc
               (mapcar
                  #'(lambda (filename)
                       (elinstall-find-actions-by-spec-x
                          t
                          (expand-file-name
                             filename 
                             dirname)))
                  sub-dirs))
            '()))))

;;;_    . elinstall-find-actions-by-spec-x

(defun elinstall-find-actions-by-spec-x (spec dir)
   "Return a list of actions to do, controlled by SPEC."
   (declare (special
               load-path-element def-file add-to-load-path-p
               recurse-dirs-p block-in-dir block-in-subtree)) 

   (if (consp spec)
      (case (car spec)
         (all
            ;;(all . SPEC*)
            (apply #'nconc
               (mapcar
                  #'(lambda (sub-spec)
                       (elinstall-find-actions-by-spec-x 
                          sub-spec
                          dir))
                  (cdr spec))))
         (block-in-subtree
            ;;(block-in-subtree (* FN) SPEC)
            (let
               ((block-in-subtree (second spec)))
               (elinstall-find-actions-by-spec-x 
                  (third spec)
                  dir)))
         
         ;;Rather than trying to bind all control variables each time
         ;;thru, we use `set' and `unwind-protect'.
         (control
            ;;control TYPE DISPOSITION SPEC
            (let
               ((key (second spec))
                  old-value)
               (if (memq key elinstall-find-actions-control-vars)
                  (unwind-protect
                     (progn
                        (setq old-value (symbol-value key))
                        (set key (third spec))
                        (elinstall-find-actions-by-spec-x 
                           (fourth spec)
                           dir))
                     (set key old-value))
                  (error "Unrecognized control variable %s" key))))
         

         (def-file
            ;;(def-file FN ARGS SPEC)
            (let
               ((def-file
                   (expand-file-name
                      (second spec)
                      dir))
                  (for-preload (third spec)))
               (assert (listp for-preload))
               (append
                  (list
                     (if
                        (and for-preload (car for-preload))
                        `(preload-file
                            ,(car for-preload)
                            ,def-file
                            ,@(cdr for-preload))
                        '()))
                  
                  (elinstall-find-actions-by-spec-x
                     (fourth spec) dir))))       
         
         (dir
            ;;(dir FN)
            (elinstall-actions-for-dir
               (expand-file-name
                  (second spec) 
                  dir)
               nil))

         (file
            ;;(file FN)
            (elinstall-actions-for-source-file
               (second spec) dir))

         (in
            ;;(in FN SPEC)
            (let
               ((new-dir
                   (expand-file-name
                      (second spec)
                      dir)))
               
               (elinstall-find-actions-by-spec-x
                  (third spec)
                  new-dir)))
         
         (load-path
            ;;(load-path SPEC)
            (append
               `((add-to-load-path ,def-file ,dir))
               (let
                  ((load-path-element dir)
                     (add-to-load-path-p nil))
                  (elinstall-find-actions-by-spec-x 
                     (second spec)
                     dir))))

         (matching 
            ;;(matching PATTERN SPEC)
            (apply #'nconc
               (mapcar
                  #'(lambda (dir)
                       ;;$$PUNT Assume that `block-in-subtree' and
                       ;;`block-in-dir' aren't matched.
                       (elinstall-find-actions-by-spec-x 
                          (third spec)
                          dir))
                  (directory-files
                     dir t (second spec)))))
         (preload
            ;;(preload FN SYM &rest ARGS)
            (let
               ((key (third spec)))
               (if
                  (and (symbolp key) (symbol-value key))
                  `((preload-file
                       t
                       ,(expand-file-name (second spec) dir)
                       ,@(nthcdr 3 spec)))
                  '()))))
      
      ;;Single symbols
      (case spec
         (dir
            (elinstall-actions-for-dir dir nil))
         ((t)
            (elinstall-actions-for-dir dir t)))))

;;;_    . elinstall-find-actions-by-spec
(defun elinstall-find-actions-by-spec 
   (spec load-path-element dir def-file redo-old)
   "Find the list of actions to do according to SPEC."

   (let
      (
         (def-file-time      (elinstall-file-mod-time def-file))
         (add-to-load-path-p t)
         (recurse-dirs-p     t)
         (byte-compile       t)
         (autoloads          t)
         (preloads           t)
         (block-in-dir       '())
         (block-in-subtree '(".git" "RCS" "CVS" "SVN" "^tests\.el")))
      
      (declare (special
                  load-path-element def-file add-to-load-path-p
                  recurse-dirs-p byte-compile
                   block-in-dir block-in-subtree)) 
      
      (elinstall-find-actions-by-spec-x spec dir)))

;;;_  . high-level work
;;;_   , elinstall-get-relevant-load-path
(defun elinstall-get-relevant-load-path (actions)
   ""
   (delq nil
      (mapcar
         #'(lambda (act)
              (case (car act)
                 (add-to-load-path
                    (second act))
                 (t nil)))
         actions)))
;;;_   , elinstall-get-deffile-list
(defun elinstall-get-deffile-list (stages)
   "Get a list of deffile names"

   (mapcar 
      #'car
      (elinstall-stages->build-deffiles stages)))
;;;_   , elinstall-x
(defun elinstall-x (dir spec &optional force)
   "High-level worker function to install elisp files."
   (let*
      (  
         ;;This is just the default deffile, spec can override it.
         (def-file
            (elinstall-expand-deffile-name nil))
         (actions
            (elinstall-find-actions-by-spec
               spec
               nil
               dir
               def-file
               (eq force 'redo-old)))
         (stages (elinstall-segregate-actions actions))
         (use-load-path
            (elinstall-get-relevant-load-path
               actions)))

      (elinstall-stage-update-deffiles
         (elinstall-stages->build-deffiles stages)
         force 
         use-load-path)
      (elinstall-stage-arrange-preloads
         (elinstall-stages->arrange-preloads stages)
         (elinstall-get-deffile-list stages)
         force)
      (elinstall-stage-byte-compile
         (elinstall-stages->byte-compile stages))
      t))
;;;_   , elinstall-package
(defun elinstall-package (project-name path spec version-string)
   "Install elisp files.  See doc for `elinstall'."
   (when 
      (elinstall-proceed-p 'install
         (format "Install %s? " project-name)
         (elinstall-already-installed project-name) 
         (format "Re-install %s? " project-name)
         (format "Already installed %s. " project-name))
      '(elinstall-proceed-p 'install
          (list 
             '("Install %s? " 
                 "Re-install %s? " 
                 "Already installed %s.")
             project-name)
          (elinstall-already-installed project-name))
      (elinstall-x 
         path 
         `(def-file "loaddefs.el" (if-used ,project-name) ,spec) 
         force)
      (elinstall-record-installed project-name version-string)))

;;;_ , Entry points
;;;_  . elinstall
;;;###autoload
(defun elinstall (project-name path spec &optional force version-string)
   "Install elisp files.
They need not be a formal package.

Parameters:

PROJECT-NAME - the name of the project

PATH - Path to the project.
  Suggestion: Use (elinstall-directory-true-name) to get the real
  current directoery name even from loaded files.

SPEC - a spec for the autoloads etc to make.  It can be as simple
as `t'.

If FORCE is `t', install a package even if it has already been
installed.  If it's a list or `nil', it's treated as a list of
installation restraints.  User customizations override this
argument.

VERSION-STRING, if given, must be a string of the version for this package."

   (elinstall-call-with-restraints
      (if (eq force t)
         '((install always))
         force)
      project-name
      #'elinstall-package
      project-name path spec version-string))

;;;_  . elinstall-update-directory-autoloads

;;;###autoload
(defun elinstall-update-directory-autoloads (dir)
   "Update autoloads for directory DIR"
   
   (interactive "DUpdate autoloads for all elisp files from directory: ")
   (elinstall-call-with-restraints
      '((autoloads t)
          (t nil))
      t
      #'elinstall-x
      dir
      '(dir ".")))

;;;_  . elinstall-update-directory
;;;###autoload
(defun elinstall-update-directory (dir)
   "Update autoloads for directory DIR"
   
   (interactive "DInstall all elisp files from directory: ")
   (elinstall-call-with-restraints
      '()
      t
      #'elinstall-x
      dir
      '(dir ".")))

;;;_  . elinstall-update-file-autoloads
;;;###autoload
(defun elinstall-update-file-autoloads (file)
   "Update autoloads for elisp file FILE"
   
   (interactive "fUpdate autoloads for elisp file: ")
   (elinstall-call-with-restraints
      '()
      t
      #'elinstall-x
      (file-name-directory file)
      `(file ,(file-name-nondirectory file))))

;;;_  . elinstall-update-file
;;;###autoload
(defun elinstall-update-file (file)
   "Install elisp file FILE"
   
   (interactive "fInstall elisp file: ")
   (elinstall-call-with-restraints
      '((autoloads t)
          (t nil))
      t
      #'elinstall-x
      (file-name-directory file)
      `(file ,(file-name-nondirectory file))))

;;;_. Footers
;;;_ , Provides

(provide 'elinstall)

;;;_ * Local emacs vars.
;;;_  + Local variables:
;;;_  + mode: allout
;;;_  + End:

;;;_ , End
;;; elinstall.el ends here