Code towards getting autoload text during action-finding

[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.

;;;_ , 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-already-installed
(defvar 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." )
;;;_ , 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-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-already-installed
(defun elinstall-already-installed (project-name)
   "Return non-nil if PROJECT-NAME has been installed."
   (member project-name elinstall-already-installed))

;;;_   , elinstall-record-installed
(defun elinstall-record-installed (project-name)
   "Record that PROJECT-NAME has been installed."

   (add-to-list 'elinstall-already-installed project-name)
   (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)))

;;;_ , 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))
;;;_    . 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))))))

;;;_    . Making autoloads
;;;_     , elinstall-insert-autoload-section
'(elinstall-insert-autoload-section
    text
    (list 'autoloads 
       autoloads-done
       relative-name
       (autoload-trim-file-name full-name)
       (nth 5 (file-attributes full-name)))
    (concat
       "Generated autoloads from " 
       (autoload-trim-file-name full-name)))

(defun elinstall-insert-autoload-section (text form &optional comment-string)
   "Insert TEXT into current buffer as an autoload section"
   
   ;; Insert the section-header line which lists the file name
   ;; and which functions are in it, etc.
   
   (elinstall-insert-section-header (current-buffer) form)

   (when comment-string
      (insert ";;; " comment-string "\n"))
   (insert text)
   (insert generate-autoload-section-trailer))

;;;_     , 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
            (buffer-name buf))
         (relative-name
            (file-name-sans-extension
               (file-relative-name
                  full-path
                  load-path-element))))
      
      (message "Finding autoloads for %s..." short-name)
      (with-current-buffer buf
         (unwind-protect
            (save-excursion
               (save-restriction
                  (widen)
                  (goto-char (point-min))
                  (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")
                           (setq done-any 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
                   ;;load-name relative to a member of load-path.
                   ,relative-name
                   ,load-path-element
                   ,full-path
                   ,(with-current-buffer outbuf (buffer-string))))
            
            ;;The unwind-protected part
            (when (buffer-live-p outbuf) (kill-buffer outbuf))))))


;;;_     , elinstall-generate-file-autoloads 
;;override to allow slashed load-paths
;;Quick and dirty: We just adapt `generate-file-autoloads' and add
;;a new arg. 
;;`relative-to' can be:
;; * nil: act as at present.  Assume that FILE's immediate directory
;;is in load-path. 
;; * t :: use default-directory
;; * a string :: relative to it, as a filename

(defun elinstall-generate-file-autoloads (relative-name full-name text)
  "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."
  (let* ((outbuf (current-buffer))
          (autoloads-done '())
          (print-length nil)
          (print-readably t)     ; This does something in Lucid Emacs.
          (float-output-format nil)
          (done-any nil)
          (visited (get-file-buffer full-name))
          (source-buf 
             (or visited
                ;; It is faster to avoid visiting the file.
                (ignore-errors (autoload-find-file full-name))))
          output-start)
     (if source-buf
        (with-current-buffer source-buf
           (message "Generating autoloads for %s..." relative-name)
           (setq output-start (with-current-buffer outbuf (point)))
           (save-excursion
              (save-restriction
                 (widen)
                 (goto-char (point-min))
                 (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")
                          (setq done-any 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))))))

           (when done-any
              (with-current-buffer outbuf
                 (save-excursion
                    ;; Insert the section-header line which lists the file name
                    ;; and which functions are in it, etc.
                    (goto-char output-start)
                    (elinstall-insert-section-header
                       outbuf 
                       (list 'autoloads 
                          autoloads-done
                          relative-name
                          (autoload-trim-file-name full-name)
                          (nth 5 (file-attributes full-name))))
                       
                    (insert ";;; Generated autoloads from "
                       (autoload-trim-file-name full-name) "\n"))
                 (insert generate-autoload-section-trailer)))
           (message "Generating autoloads for %s...done" relative-name))

           (unless visited
              ;; We created this buffer, so we should kill it.
              (kill-buffer (current-buffer)))
        (message "Could not load %s" relative-name))
     
     (not done-any)))
;;

;;;_     , elinstall-deffile-insert-autoloads
(defun elinstall-deffile-insert-autoloads (file load-name text)
   "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 
               (elinstall-generate-file-autoloads file load-name text))))

      (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-default-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-default-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-readably t)     ; This does something in Lucid Emacs.
          (float-output-format nil))

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


     (elinstall-insert-section-header
        (current-buffer)
        (list type (list path-element) nil nil nil))
     
     (insert ";;; Generated path addition\n")
     (pp
        `(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)))))
        (current-buffer))
     
     (insert generate-autoload-section-trailer)
     (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)
               (fifth action)
               (sixth 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 (nth 5 (file-attributes 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) 
                                 (nth 5 (file-attributes 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-section-header
              (current-buffer) 
              (list 'autoloads nil nil  no-autoloads this-time))
           (insert generate-autoload-section-trailer))
        (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
;;;_   , Informational
;;;_    . 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\\)?$")))

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

;;;_    . 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))
   (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 create and use relevant 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))))
               (compile-p
                  (and
                     (featurep 'byte-compile)
                     (string-match emacs-lisp-file-regexp filename)
                     (ignore-errors 
                        (with-current-buffer buf 
                           (not no-byte-compile)))
                     (let* 
                        ((dest (byte-compile-dest-file full-path))
                           ;;$$PUNT - currently, we wouldn't have
                           ;;gotten here if we weren't intending to do
                           ;;everything so set force variables accordingly.
                           (recompile-p nil)
                           (compile-new t))
                        (if (file-exists-p dest)
                           ;; File was already compiled.
                           (or recompile-p (file-newer-than-file-p full-path dest))
                           (or compile-new
                              (y-or-n-p (concat "Compile " filename "? "))))))))
            
            (prog1
               (list
                  (if 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-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))

   (if (consp spec)
      ;;$$IMPROVE ME by adding the other cases in the design.
      (case (car spec)
         (in
            (let
               ((new-dir
                   (expand-file-name
                      (second spec)
                      dir)))
               
               (elinstall-find-actions-by-spec-x
                  (third spec)
                  new-dir)))
         
         (all
            (apply #'nconc
               (mapcar
                  #'(lambda (sub-spec)
                       (elinstall-find-actions-by-spec-x 
                          sub-spec
                          dir))
                  (cdr spec))))

         (file
            (elinstall-actions-for-source-file
               filename dir))
         ;;$$ADD ME control, rather than trying to bind all control
         ;;variables so we can safely bind one, will use set and
         ;;unwind-protect. 

         (dir
            (let*
               ((dirname 
                   (expand-file-name
                      (second spec) 
                      dir))
                  ;;Relative filenames
                  (elisp-source-files
                     (directory-files
                        dirname 
                        nil 
                        elinstall-elisp-regexp))
                  (load-path-here
                     (and 
                        elisp-source-files ;;List not empty.
                        add-to-load-path-p))
                  (load-path-element
                     (if load-path-here
                        dirname
                        load-path-element)))
               
               (append
                  ;;$$IMPROVE ME - remove the current deffile from
                  ;;this list.
                  ;;Maybe arrange to add this directory to load-path.
                  (if load-path-here
                     `((add-to-load-path
                          ,def-file
                          ,load-path-element))
                     '())

                  ;;$$IMPROVE ME - be controlled by a control variable.
                  ;;If any info files are present, do add-to-info-path
                  ;;too. 
                  (if
                     (elinstall-dir-has-info dirname)
                     `((add-to-info-path
                          ,def-file
                          "."))
                     '())
                  


                  ;;$$FIXME Don't do directories, but maybe recurse on
                  ;;them, if a flag is set.  
                  ;;Maybe could follow/not symlinks similarly.
                  (apply #'nconc
                     (mapcar
                        #'(lambda (filename)
                             (elinstall-actions-for-source-file
                                filename 
                                dirname))
                        elisp-source-files)))))

         (load-path
            (append
               `((add-to-load-path ,def-file ,dir))
               (let
                  ((load-path-element dir))
                  (elinstall-find-actions-by-spec-x spec dir))))
         

         (def-file
            (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)))))
      
      ;;$$IMPROVE ME by adding the other cases in the design.
      (case spec
         (t))))
;;;_    . elinstall-find-actions-by-spec
(defun elinstall-find-actions-by-spec (spec load-path-element dir def-file)
   ""

   (let
      ((load-path-element load-path-element)
         (def-file def-file)
         (add-to-load-path-p t))
      (declare (special
                  load-path-element def-file add-to-load-path-p))
      
      (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)
   ""
   (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))
         (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))
;;;_ , Entry points
;;;_  . elinstall
;;;###autoload
(defun elinstall (project-name path spec &optional force)
   "Install elisp files.
They need not be a formal package.

Parameters:

PROJECT-NAME - the name of the project

PATH - Path to the project.
  Suggestion: (elinstall-directory-true-name)

SPEC - a spec for the autoloads etc to make.  It can be as simple as
\(dir \"\.\") for installing one directory.

If FORCE is t, install a package even if it has already been
installed.  Other non-nil cases of FORCE are reserved for future
development."
   
   (when
      (and
         (or 
            force
            (not (elinstall-already-installed project-name)))
         (yes-or-no-p (format "Re-install %s? " project-name)))
      (elinstall-x 
         path 
         `(def-file "loaddefs.el" (if-used ,project-name) ,spec) 
         force)
      (elinstall-record-installed project-name)))



;;;_  . elinstall-update-directory-autoloads
;;$$SPLIT ME - one to just classically update autoloads, one to
;;install a file.
;;$$TEST ME
;;;###autoload
(defun elinstall-update-directory-autoloads (dir)
   ""
   
   (interactive "DInstall all elisp files from directory: ")


   (let
      ((def-file-name
          (elinstall-expand-deffile-name 
             generated-autoload-file)))
      
      (elinstall-x
         dir
         `(def-file ,def-file-name (nil) (dir ".")))))



;;;_  . elinstall-update-file-autoloads
;;$$SPLIT ME - one to just classically update autoloads, one to
;;install a file.
;;$$TEST ME
;;;###autoload
(defun elinstall-update-file-autoloads (file)
   ""
   
   (interactive "fInstall elisp file: ")
   (let
      ((def-file-name
          ;;This is the default.  File local vars can override it.
          (elinstall-expand-deffile-name 
               generated-autoload-file)))
      (elinstall-x
         file
         `(def-file ,def-file-name (nil) (file ,file)))))
;;;_. Footers
;;;_ , Provides

(provide 'elinstall)

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

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