Adapted stuff from autoload

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

;; 


;;;_ , Requires



;;;_. Body
;;;_ , Customizations
(defgroup elinstall
   '()
   "Customizations for elinstall"
   :group 'elinstall)

(defcustom elinstall-default-priority 
   50
   "Default priority for site-start" 
   :group 'elinstall
   :type 'integer)

(defcustom elinstall-default-target 
   'my-site-start
   "Default target for registering autoloads" 
   :group 'elinstall
   :options '(my-site-start))


(defcustom elinstall-already-installed
   '()
   "Things that have already been installed.
This exists for recording what has been installed.  User interaction is not
contemplated at this time." )

;;;_ , Compatibility
;;$$OBSOLETE
(defconst elinstall-autoload-updator
   (cond
      ((fboundp 'update-autoloads-from-directories)
         'update-autoloads-from-directories)
      ((fboundp  'update-directory-autoloads)
         'update-directory-autoloads))
   "Function used to extract autoloads.")

;;;_ , Utilities

(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))))

;;;_ , Work
;;;_  . Actions
;;;_   , elinstall-insert-add-to-path
(defun elinstall-insert-add-to-path (new path-sym)
   "Insert code to add NEW to PATH-SYM.
Insert this at point in current buffer."
   (insert "\n")
   (pp
      `(add-to-list ',path-sym
          (expand-file-name ,new
             (if load-file-name
                (file-name-directory
                   (file-truename load-file-name)))))
      (current-buffer)))

;;;_   , elinstall-insert-add-to-load-path
(defun elinstall-insert-add-to-load-path (new)
   "Insert code to add NEW to load-path.
Insert this at point in current buffer."
   (elinstall-insert-add-to-path new 'load-path))

;;;_   , elinstall-insert-add-to-info-path
(defun elinstall-insert-add-to-info-path (new)
   "Insert code to add NEW to info-path.
Insert this at point in current buffer."
   (elinstall-insert-add-to-path new 'Info-default-directory-list))

;;;_   , elinstall-insert-dir-autoloads
(defun elinstall-insert-dir-autoloads (autoloads-file directory)
   "Generate autoloads for DIRECTORY into AUTOLOADS-FILE."
   (declare (special elinstall-autoload-updator))
   (let ((generated-autoload-file autoloads-file))
      (elinstall-update-directory-autoloads directory)))

;;;_   , elinstall-do-actions
(defun elinstall-do-action (action)
   "Do a single installating action"
   (when action
      (case (car action)
         (add-dir-autoloads 
            (apply #'elinstall-insert-dir-autoloads (cdr action)))
      
         (add-to-load-path
            ;;Go to the right buffer, right position, then call:
            '(elinstall-insert-add-to-load-path))
      
         ;;Similar, but for info-path.
         (add-to-info-path
            'elinstall-insert-add-to-info-path)
         
         (preload-file
            ;;Symlink file to target.
         
            )
         )))
;;;_  . Overrides (All adapted from autoload.el)
;;;_   , generate-file-autoloads override to allow slashed load-paths
;;Quick and dirty: We just override `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 generate-file-autoloads (file &optional relative-to)
  "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."
  (interactive "fGenerate autoloads for file: ")
  (let ((outbuf (current-buffer))
        (autoloads-done '())
        (load-name (let ((name 
                            (cond
                               ((not relative-to) 
                                  (file-name-nondirectory file))
                               ((eq relative-to t)
                                  (file-relative-name file))
                               (t
                                  (file-relative-name relative-to)))))
                     (if (string-match "\\.elc?\\(\\.\\|$\\)" name)
                         (substring name 0 (match-beginning 0))
                       name)))
        (print-length nil)
        (print-readably t)              ; This does something in Lucid Emacs.
        (float-output-format nil)
        (done-any nil)
        (visited (get-file-buffer file))
        output-start)

    ;; If the autoload section we create here uses an absolute
    ;; file name for FILE in its header, and then Emacs is installed
    ;; under a different path on another system,
    ;; `update-autoloads-here' won't be able to find the files to be
    ;; autoloaded.  So, if FILE is in the same directory or a
    ;; subdirectory of the current buffer's directory, we'll make it
    ;; relative to the current buffer's directory.
    (setq file (expand-file-name file))
    (let* ((source-truename (file-truename file))
           (dir-truename (file-name-as-directory
                          (file-truename default-directory)))
           (len (length dir-truename)))
      (if (and (< len (length source-truename))
               (string= dir-truename (substring source-truename 0 len)))
          (setq file (substring source-truename len))))

    (with-current-buffer (or visited
                             ;; It is faster to avoid visiting the file.
                             (autoload-find-file file))
      ;; Obey the no-update-autoloads file local variable.
      (unless no-update-autoloads
        (message "Generating autoloads for %s..." file)
        (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 load-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)
              (autoload-insert-section-header
               outbuf autoloads-done load-name file
               (nth 5 (file-attributes file)))
              (insert ";;; Generated autoloads from "
                      (autoload-trim-file-name file) "\n"))
            (insert generate-autoload-section-trailer)))
        (message "Generating autoloads for %s...done" file))
      (or visited
          ;; We created this buffer, so we should kill it.
          (kill-buffer (current-buffer))))
    (not done-any)))
;;;_   , elinstall-update-file-autoloads
(defun elinstall-update-file-autoloads (file &optional save-after)
  "Update the autoloads for FILE in `generated-autoload-file'
\(which FILE might bind in its local variables).
If SAVE-AFTER is non-nil (which is always, when called interactively),
save the buffer too.

Return FILE if there was no autoload cookie in it, else nil."
  (interactive "fUpdate autoloads for file: \np")
  (let ((load-name (let ((name (file-name-nondirectory file)))
                     (if (string-match "\\.elc?\\(\\.\\|$\\)" name)
                         (substring name 0 (match-beginning 0))
                       name)))
        (found nil)
        (existing-buffer (get-file-buffer file))
        (no-autoloads nil))
    (save-excursion
      ;; We want to get a value for generated-autoload-file from
      ;; the local variables section if it's there.
      (if existing-buffer
          (set-buffer existing-buffer))
      ;; We must read/write the file without any code conversion,
      ;; but still decode EOLs.
      (let ((coding-system-for-read 'raw-text))
        (set-buffer (find-file-noselect
                     (autoload-ensure-default-file
                      (expand-file-name generated-autoload-file
                                        (expand-file-name "lisp"
                                                          source-directory)))))
        ;; 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))
      (save-excursion
        (save-restriction
          (widen)
          (goto-char (point-min))
          ;; Look for the section for LOAD-NAME.
          (while (and (not found)
                      (search-forward generate-autoload-section-header nil t))
            (let ((form (autoload-read-section-header)))
              (cond ((string= (nth 2 form) load-name)
                     ;; We found the section for this file.
                     ;; Check if it is up to date.
                     (let ((begin (match-beginning 0))
                           (last-time (nth 4 form))
                           (file-time (nth 5 (file-attributes file))))
                       (if (and (or (null existing-buffer)
                                    (not (buffer-modified-p existing-buffer)))
                                (listp last-time) (= (length last-time) 2)
                                (not (time-less-p last-time file-time)))
                           (progn
                             (if (interactive-p)
                                 (message "\
Autoload section for %s is up to date."
                                          file))
                             (setq found 'up-to-date))
                         (search-forward generate-autoload-section-trailer)
                         (delete-region begin (point))
                         (setq found t))))
                    ((string< load-name (nth 2 form))
                     ;; We've come to a section alphabetically later than
                     ;; LOAD-NAME.  We assume the file is in order and so
                     ;; there must be no section for LOAD-NAME.  We will
                     ;; insert one before the section here.
                     (goto-char (match-beginning 0))
                     (setq found 'new)))))
          (or 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)))
          (or (eq found 'up-to-date)
              (setq no-autoloads (generate-file-autoloads file)))))
      (and save-after
           (buffer-modified-p)
           (save-buffer))

      (if no-autoloads file))))

;;;_   , elinstall-update-directory-autoloads

(defun elinstall-update-directory-autoloads (&rest dirs)
  "\
Update loaddefs.el with all the current autoloads from DIRS, and no old ones.
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.  In a call from Lisp, you can supply multiple
directories as separate arguments, but this usage is discouraged.

The function does NOT recursively descend into subdirectories of the
directory or directories specified."
  (interactive "DUpdate autoloads from directory: ")
  (let* ((files-re (let ((tmp nil))
                     (dolist (suf (get-load-suffixes)
                                  (concat "^[^=.].*" (regexp-opt tmp t) "\\'"))
                       (unless (string-match "\\.elc" suf) (push suf tmp)))))
         (files (apply 'nconc
                       (mapcar (lambda (dir)
                                 (directory-files (expand-file-name dir)
                                                  t files-re))
                               dirs)))
         (this-time (current-time))
         (no-autoloads nil)             ;files with no autoload cookies.
         (autoloads-file
          (expand-file-name generated-autoload-file
                            (expand-file-name "lisp" source-directory)))
         (top-dir (file-name-directory autoloads-file)))

    (with-current-buffer
        (find-file-noselect (autoload-ensure-default-file autoloads-file))
      (save-excursion

        ;; Canonicalize file names and remove the autoload file itself.
        (setq files (delete (autoload-trim-file-name buffer-file-name)
                            (mapcar 'autoload-trim-file-name files)))

        (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 files (delete file files)))))))
                  ((not (stringp file)))
                  ((not (file-exists-p (expand-file-name file top-dir)))
                   ;; Remove the obsolete section.
                   (autoload-remove-section (match-beginning 0)))
                  ((equal (nth 4 form) (nth 5 (file-attributes file)))
                   ;; File hasn't changed.
                   nil)
                  (t
                   (elinstall-update-file-autoloads file)))
            (setq files (delete file files)))))
      ;; Elements remaining in FILES have no existing autoload sections yet.
      (setq no-autoloads
            (append no-autoloads
                    (delq nil (mapcar #'elinstall-update-file-autoloads files))))
      (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)
        (autoload-insert-section-header
         (current-buffer) nil nil no-autoloads this-time)
        (insert generate-autoload-section-trailer))
       ;;(save-buffer)
       )))

;;;_  . Generating autoloads etc by spec
;;;_   , Treating the parameter list
;;;_    . elinstall-add-parameter
(defun elinstall-add-parameter (alist key new-value)
   "Add a new value for KEY to ALIST"

   (cons
      (cons key new-value)
      (assq-delete-all key (copy-list alist))))

;;;_    . elinstall-get-parameter
(defun elinstall-get-parameter (alist key)
   "Get the value of KEY from ALIST"
   
   (cdr (assq key alist)))
;;;_    . elinstall-expand-filename
(defun elinstall-expand-filename (filename alist)
   "Expand FILENAME by the value of `path' in ALIST"
   
   (expand-file-name 
      filename
      (elinstall-get-parameter alist 'path)))

;;;_   , elinstall-find-actions-by-spec

(defun elinstall-find-actions-by-spec (spec parameters)
   "Return a list of actions to do, controlled by SPEC and PARAMETERS."
   (if (consp spec)
      ;;$$IMPROVE ME by adding the other cases in the design.
      (case (car spec)
         (in
            (let
               ((new-path
                   (elinstall-expand-filename
                      (second spec) 
                      parameters)))
               
               (elinstall-find-actions-by-spec
                  (third spec)
                  (elinstall-add-parameter parameters 
                     'path new-path))))
         
         (all
            (apply #'append
               (mapcar
                  #'(lambda (sub-spec)
                       (elinstall-find-actions-by-spec 
                          sub-spec
                          parameters))
                  (cdr spec))))
         
         (dir
            (list
               (unless
                  (elinstall-get-parameter 
                     parameters 'block-add-to-load-path)
                  `(add-to-load-path
                      ,(elinstall-get-parameter 
                          parameters 'def-file)
                      ,(elinstall-expand-filename
                          (second spec) 
                          parameters)))
               `(add-dir-autoloads
                   ,(elinstall-get-parameter 
                      parameters 'def-file)
                   ,(elinstall-expand-filename
                       (second spec) 
                       parameters))))
         
         (def-file
            (let
               ((new-def-file
                   (elinstall-expand-filename
                      (second spec) 
                      parameters)))
               (elinstall-find-actions-by-spec
                  (third spec)
                  (elinstall-add-parameter parameters 
                     'def-file new-def-file)))))
      
      ;;$$PUNTED
      (case spec
         (t))))

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

;;;_ , Entry points
(defun elinstall (project-name dir spec &optional target force)
   "Install elisp files.

They need not be presented as a package.

Parameters:
PROJECT-NAME - the name of the project
DIR - the root directory of the project.
  Suggestion: (elinstall-directory-true-name)

SPEC - a spec for the autoloads etc to make.  It can be as simple as
  `(in DIRECTORY t).  
  Suggestion: `(in ,(elinstall-directory-true-name) t)
TARGET is where the autoload files are to be symlinked in.  If
`nil' `elinstall-default-target' is used instead.

If FORCE is non-nil, install a package even if it has already been
installed."
   
   (when
      (and
         (or 
            force
            (not (elinstall-already-installed project-name)))
         ;;$$REMOVE ME - I commented it out just for development.
         '(yes-or-no-p (format "Install %s " project-name)))
      (let 
         ((actions
             (elinstall-find-actions-by-spec
                spec
                `(
                    (path . ,dir)
                    ;;This is just the default loaddefs file, spec actually
                    ;;controls it.
                    (def-file . "elinstall-loaddefs.el" )))))
         (mapcar #'elinstall-do-action actions)
         '(elinstall-record-installed project-name))))



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

(provide 'elinstall)

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

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