gnu-emacs-sources
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

A combined installer and configurer, with on-demand loading


From: John Sturdy
Subject: A combined installer and configurer, with on-demand loading
Date: Thu, 16 Aug 2007 06:34:14 -0700
User-agent: G2/1.0

Here's a combined installer and configurer, which defines an
"autofetch" (like autoload, but downloading from the network -- or
other media) and also conveniently sets up various things it's useful
to have on eval-after-load forms.

This lets you write package descriptions such as:
(use-package vm
             nil                        ; download to default directory
             (nil                       ; use default getter function
              "http://www.seanet.com/~kylemonger/vm/vm-7.19.tar.gz";
              ;; after-download form:
              (shell-command "cd vm-7.19; make"))
             ;; configuration arg to use-package:
             ("$COMMON/emacs/email"     ; string means directory for load-path
              (require 'jcgs-vm-stuff)  ; can add your own aux stuff
              ([ C-f11 ] . js-vm-get-mail) ; key definitions
              ([ M-C-f11 ] . vm-continue-composing-message)
              ;; autoloads/autofetches
              (vm "vm" "Run the VM mail reader" t)
              ;; things that look like auto-mode-alist entries are
              ("~/vm" . vm-mode)
              ("$COMMON/vm" . vm-mode))
             ;; remaining args to use-package are eval-after-load forms
             (setq vm-mutable-frames nil
                   bbdb-completion-type 'primary-or-name
                   read-mail-command 'vm
                   vm-folder-directory (if (file-directory-p
                                            (expand-file-name "~/vm/"))
                                           (expand-file-name "~/vm/")
                                         (substitute-in-file-name 
"$COMMON/vm/"))
                   vm-primary-inbox (expand-file-name "john" 
vm-folder-directory)))

I find this a handy way for keeping together definitions of how to get
a package, with how to configure it; it's particularly nice when I
arrive on an unfamiliar machine, and can load one startup file from
the web or my USB key drive, and have it pull the rest across as I use
it for the first time on that machine.

The next enhancement will probably be indirect URLs, where it searches
the page at the specified URL, for links whose anchor text matches a
particular pattern -- intended for giving it a downloads page such as
on SourceForge, and picking the URL from that. I'll probably add SHA1/
MD5 verirfication, too.

Code follows; and I'm working on a texinfo file for it.
;;;; use-package.el -- Arrange use of an elisp package
;;; Time-stamp: <2007-08-16 14:19:21 john>

;;  This program 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 of the License, or (at
your
;;  option) any later version.

;;  This program 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 this program; if not, write to the Free Software Foundation,
Inc.,
;;  59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

;;; use-package provides a way for you to gather together all the
;;; information about your configuration of a package, and how to
;;; fetch and install that package.  It defines and uses an
;;; `autofetch' facility, similar to `autoload', for fetching and
;;; installing packages from URLs (including file URLS as well as
;;; network ones, so you can pick packages up from removable media,
;;; too, as well as downloading them from the net).  This way, if you
;;; rove with your .emacs onto a machine you've not used before, you
;;; can simply type the command or press the key that invokes the
;;; package, and the package will be fetched, installed, and
;;; configured.  On subsequent runs, it just gets configured.

;;; Future versions may allow a list of URLs to try, so, for example,
;;; you could try an NFS mount to a server, a couple of mount points
;;; where your USB mass storage device might appear, and a web site as
;;; an ultimate fallback.

;;; Another possible extension would allow a search URL, the return
;;; from which is searched for a URL that looks like the file to
;;; download.  This should have a checksum specified too; I should
;;; probably do that separately anyway.

(defun use-package-fetch-file (url file)
  "Fetch URL into FILE."
  (message "Fetching %s into %s" url file)
  (cond
   ((string-match "^/\\([-.a-z0-9]+\\):\\(.+\\)$" url)
    (when (file-exists-p file)
      (message "Warning: %S already exists" file))
    (copy-file url file t))
   ((string-match "^file://\\(.+\\)$" url)
    (let ((source (match-string 1 url)))
      (when (file-exists-p file)
        (message "Warning: %S already exists" file))
      (copy-file source file t)))
   ((string-match "^\\([a-z]+\\)://\\([-a-z0-9.]+\\)/\\(.+\\)$" url)
    (let ((buffer (url-retrieve-synchronously url)))
      (set-buffer buffer)
      (goto-char (point-min))
      (re-search-forward "^$")
      (write-region (1+ (point)) (point-max) file)))
   (t
    (message "Don't know how to fetch %s" url))))

(defun use-package-unpack-file (bundle-file lisp-directory
recognizable-file &optional after-form)
  "Unpack the package BUNDLE-FILE into LISP-DIRECTORY, producing
RECOGNIZABLE-FILE among others.
If AFTER-FORM is given, evaluate that after unpacking.
Returns an updated value for LISP-DIRECTORY, found by searching
the directories below LISP-DIRECTORY for an occurrence of
RECOGNIZABLE-FILE."
  (unless (file-directory-p lisp-directory)
    (make-directory lisp-directory t))
  (cond
   ((string-match "\\.elc?$" bundle-file)
    (copy-file bundle-file
               (expand-file-name (file-name-nondirectory bundle-file)
                                 lisp-directory)))
   ((string-match "\\(\\.tar\\.gz\\|\\.taz\\)$" bundle-file)
    (message "expanding tarball %s into directory %s using tar -z"
             bundle-file lisp-directory)
    (shell-command
     (format "tar --directory %s --file=%s --ungzip --extract"
             lisp-directory bundle-file)))
   ((string-match "\\.gz$" bundle-file)
    (message "expanding tarball %s into directory %s using jka-compr"
             bundle-file lisp-directory)
    (let ((unzipped (jka-compr-file-local-copy)))
      (copy-file unzipped (substring bundle-file -3))))
   ((string-match "\\.tar$" bundle-file)
    (shell-command
     (message "expanding tarball %s into directory %s using tar"
              bundle-file lisp-directory)
     (format "tar --directory %s --file=%s --extract" lisp-directory
bundle-file)))
   (t (error "Don't know how to unpack %S into %S" bundle-file lisp-
directory)))
  (when after-form
    (let ((default-directory lisp-directory))
      (when use-package-verbose
        (message "Evaluating post-processing %S in directory %S"
                 after-form default-directory))
      (eval after-form)))
  (subdirectory-containing-file lisp-directory recognizable-file))

(defun files-matching-in-subdirs (pattern directory)
  "Return files matching PATTERN in any directories of DIRECTORY.
PATTERN is matched against the last part of the name only."
  (if (and (stringp directory)
           (file-directory-p directory)
           (file-readable-p directory))
      (let ((files nil))
        (dolist (file (directory-files directory t nil t))
          (if (and (file-directory-p file)
                   (not (string-match "\\.$" file)))
              (setq files (append (files-matching-in-subdirs pattern file)
                                  files))
            (when (string-match pattern (file-name-nondirectory file))
              (push file files))))
        files)))

(defun use-package-preferable-subdirectory (a b)
  "This sort predicate is designed to favour shorter directory
names (hence avoiding version control subdirectories like
_darcs/pristine) and if the names are the same length, to pick
the one with the higher version number.  Of course, this only
covers directory arrangements reasonably similar to those used by
the author!"
  (if (= (length a)
         (length b))
      (string< b a)
    (< (length a)
       (length b))))

(defun subdirectory-containing-file (directory file)
  "Find a subdirectory of DIRECTORY that contains FILE.
Extensions .el and .elc are tried for FILE.
The idea of this is that when you unpack an elisp package that
you've downloaded as a tarball, the file you want can end up in a
subdirectory of the directory you specify to unpack it in,
typically with a version number somewhere in the directory name."
  (when (symbolp file)
    (setq file (symbol-name file)))
  (when use-package-verbose
    (message "Looking in %S for %S" directory file))
  (if (not (and (stringp directory)
                (file-directory-p directory)))
      nil
    (let* ((pattern (if (string-match "\\.el" file)
                        (format "^%s" file)
                      (format "^%s.elc?" file)))
           ;; Sorting them then only using the first one may be a bit
           ;; wasteful (not that there will usually be that many of
           ;; them), but the code is quick to write and clear to read,
           ;; and I've put the result into a variable so we could list
           ;; the possibilities and even let the user choose
           ;; interactively.

           ;; We apply 'file-name-directory before sorting rather than
           ;; to the chosen file, as it gets rid of the el/elc
           ;; difference to stop it affecting the sort.

           (possibilities
            (sort (mapcar 'file-name-directory
                          (files-matching-in-subdirs pattern directory))
                  'use-package-preferable-subdirectory)))
      (when use-package-verbose
        (message "Picking the best of %S" possibilities))
      (car possibilities))))

(defun expand-file-name-possibly-deeply (file directory)
  "Quite like expand-file-name, but FILE can be in a subdirectory of
DIRECTORY.
The other difference is that if no such directory is found, this
function returns nil, rather than expanding the filename in the
default directory.
The idea of this is that when you unpack an elisp package that
you've downloaded as a tarball, the file you want can end up in a
subdirectory of the directory you specify to unpack it in,
typically with a version number somewhere in the directory name."
  (let ((subdir (subdirectory-containing-file directory file)))
    (if subdir
        (expand-file-name file
                          subdir)
      nil)))

(defun autofetch-fetch-it (directory getter recognizable-file)
  "Populate DIRECTORY using GETTER, expecting RECOGNIZABLE-FILE to
appear under it."
  (unless (file-directory-p directory)
    (when use-package-verbose
      (message "do-autofetch creating directory %S" directory))
    (make-directory directory t))
  (let ((lisp-actual-directory (use-package-get-package directory
                                                        getter
                                                        recognizable-file)))
    (unless (member lisp-actual-directory load-path)
      (when use-package-verbose
        (message "do-autofetch adding %S to load path" lisp-actual-
directory))
      (push lisp-actual-directory load-path))))

(defun do-autofetch (symbol args)
  "Do an autofetch on SYMBOL, passing in ARGS."
  (let ((directory (expand-file-name
                    (substitute-in-file-name
                     (get symbol 'autofetch-directory))))
        (file (get symbol 'autofetch-file))
        (getter (get symbol 'autofetch-getter))
        (interactive (get symbol 'autofetch-interactive)))
    (message "do-autofetch directory=%S file=%S getter=%S"
             directory file getter)
    (autofetch-fetch-it directory getter file)
    (load file)
    ;; Now the symbol should have been defun'ed (by the `(load file)')
    ;; and so this `apply' should use the real function:
    (apply symbol args)))

(defun autofetch1 (symbol file directory getter &optional doc
interactive)
  "Arrange SYMBOL to be loaded from FILE, first populating DIRECTORY
using GETTER."
  (when (or t (not (fboundp symbol))
            (and (consp (symbol-function symbol))
                 (eq (car (caddr (symbol-function symbol)))
                     'do-autofetch)))
    (message "setting autofetch on %S" symbol)
    (put symbol 'autofetch-directory directory)
    (put symbol 'documentation doc)
    (put symbol 'autofetch-interactive interactive)
    (put symbol 'autofetch-file file)
    (put symbol 'autofetch-getter getter)
    (fset symbol `(lambda (&rest args)
                    ,(if interactive '(interactive) nil)
                    (do-autofetch ',symbol args)))))

(defmacro autofetch (symbol file directory getter &optional doc
interactive)
  "Arrange SYMBOL to be loaded from FILE, first populating DIRECTORY
using GETTER.
Like autoload, but downloads the file first."
  `(autofetch1 ',symbol ,file ,directory ,getter ,doc ,interactive))

(defun use-package-get-package (lisp-directory getter recognizable-
file)
  "Populate LISP-DIRECTORY according to GETTER, producing RECOGNIZABLE-
FILE among others.
Should return an updated value for LISP-DIRECTORY, found by searching
the directories below LISP-DIRECTORY for an occurrence of
RECOGNIZABLE-FILE.
See use-package for description of GETTER."
  (if (functionp getter)
      (funcall getter)
    (let* ((url (cond
                 ((stringp getter)
                  getter)
                 ((and (consp getter)
                       (or (stringp (cadr getter))
                           (consp (cadr getter))))
                  (cadr getter))))
           (after-form (if (and (consp getter)
                                (consp (cdr getter)))
                           (caddr getter)
                         nil))
           (function (cond
                      ((and (consp getter)
                            (functionp (car getter)))
                       (car getter))
                      (t nil)))
           (last-part (file-name-nondirectory url))
           (staging nil)
           (dirs use-package-download-path))
      (when use-package-verbose
        (message "use-package-get-package on URL %S; last-part %S; dirs %S"
                 url last-part dirs))
      ;; first, see whether the tarball or whatever has been
downloaded
      (while dirs
        (let ((expanded (expand-file-name-possibly-deeply last-part
                                                          (car dirs))))
          (if (and (stringp expanded)
                   (file-readable-p expanded))
              (setq staging (car dirs)
                    dirs nil)
            (setq dirs (cdr dirs)))))
      ;; if it hasn't been downloaded yet, find a place to download it
      (when use-package-verbose
        (message "Staging %S" staging))
      (unless staging
        (when use-package-verbose
          (message "Looking for suitable staging directory (writable
directory for temporary files)"))
        (setq dirs use-package-download-path)
        (while dirs
          (when use-package-verbose
            (message "Trying %S as staging" (car dirs)))
          (if (and (file-directory-p (car dirs))
                   (file-writable-p (car dirs)))
              (setq staging (car dirs)
                    dirs nil)
            (setq dirs (cdr dirs))))
        (when use-package-verbose
          (message "Staging now %S" staging))
        (when (null staging)
          (when use-package-verbose
            (message "Null staging, creating one"))
          (make-directory (car use-package-download-path) t)
          (setq staging (car use-package-download-path))))
      (let ((stage-file (expand-file-name last-part staging)))
        (when use-package-verbose
          (message "Using staging directory %S; fetching %S into %S"
                   staging url stage-file))
        (if (stringp url)
            (use-package-fetch-file url stage-file)
          (while (and url
                      (not (file-readable-p stage-file)))
            (use-package-fetch-file (car url) stage-file)
            (setq url (cdr url))))
        ;; check it is ready, and unpack it if OK
        (if (file-readable-p stage-file)
            (when use-package-verbose
              (message "Successfully downloaded %S" stage-file))
          (error "Failed to download %s" url))
        (when use-package-verbose
          (message "Unpacking %S into %S with %S postprocessing"
                   stage-file lisp-directory after-form))
        (use-package-unpack-file stage-file
                                 lisp-directory
                                 recognizable-file
                                 after-form)))))

(defgroup use-package nil
  "Package use control.")

(defcustom use-package-download-path '("~/downloaded" "/tmp")
  "Directories in which downloaded packages may appear.
If use-package finds a file matching the nondirectory part of the url
it has been given, existing in any of these directories, it takes that
file as being the downloaded data. Otherwise, it uses the first
writable directory on this list as the download area for getting the
URL."
  :group 'use-package)

(defcustom use-package-only-these nil
  "If this is non-nil, only the packages on this list will be loaded."
  :group 'use-package)

(defcustom use-package-skip-these nil
  "List of packages not to load even if asked to.
You could set this if one of them is causing trouble from your .emacs,
while you get it debugged, for example."
  :group 'use-package)

(defcustom use-package-check-function nil
  "If non-nil, apply this function to each package name to see whether
to load it.
You could set it to something like
  \(lambda (package) (y-or-n-p (format \"load %s\" package)))"
  :group 'use-package)

(defcustom use-package-verbose nil
  "Whether use-package should output message about what it is doing."
  :group 'use-package
  :type 'boolean)

(defcustom downloaded-emacs-directory nil
  "Directory for files downloaded by autofetch and use-package.
If this is nil, user-emacs-directory is used instead."
  :group 'use-package
  :type 'directory)

(defun use-package-1 (package
                      lisp-directory
                      getter
                      configuration
                      init-forms)
  "Helper function for use-package, which see."
  (when (and (not (memq package use-package-skip-these))
             (or (null use-package-only-these)
                 (memq package use-package-only-these))
             (or (null use-package-check-function)
                 (funcall use-package-check-function package)))
    (when (and (consp package)
               (eq (car package) 'quote))
      ;; I meant it not to use quote (via the macro use-package) but
      ;; found I kept putting quote there myself, it sometimes seemed
      ;; natural. So allow either.
      (setq package (cadr package)))
    (when (null lisp-directory)
      (setq lisp-directory (or downloaded-emacs-directory
                               user-emacs-directory)))
    (when (stringp lisp-directory)
      (setq lisp-directory (expand-file-name
                            (substitute-in-file-name lisp-directory))))
    (let* ((main-file (symbol-name package))
           (lisp-actual-directory (and (stringp lisp-directory)
                                       (subdirectory-containing-file
                                        lisp-directory
                                        main-file)))
           (load-now nil))
      (when (and (stringp lisp-actual-directory)
                 (file-directory-p lisp-actual-directory)
                 (or (file-exists-p
                      (expand-file-name
                       (concat main-file ".el")
                       lisp-actual-directory))
                     (file-exists-p
                      (expand-file-name
                       (concat main-file ".elc")
                       lisp-actual-directory))))
        (when use-package-verbose
          (message "use-package %s: adding %S to load-path"
                   package lisp-actual-directory))
        (add-to-list 'load-path lisp-actual-directory)
        (when nil (directory-files lisp-actual-directory nil "\\.info$")
              (require 'info)
              (add-to-list 'Info-directory-list lisp-actual-directory)
              (when use-package-verbose
                (message "use-package %s: adding %S to Info-directory-list"
                         package lisp-actual-directory))))
      ;; Now go through the configuration parameters; see use-package
      ;; for description.
      (dolist (config configuration)
        (cond
         ((eq config t)
          (setq load-now t))
         ((stringp config)
          (add-to-list 'load-path
                       (expand-file-name (substitute-in-file-name config)
                                         lisp-actual-directory)
                       t)
          (when use-package-verbose
            (message "use-package %s: adding extra directory %S to load-path"
                     package (substitute-in-file-name config))))
         ((and (symbolp (car config))
               (consp (cdr config))
               (stringp (cadr config)))
          ;; If the lisp directory is present and populated, use
          ;; autoload; otherwise, use autofetch.
          (if lisp-actual-directory
              (apply 'autoload config)
            (autofetch1 (first config)  ; symbol
                        (second config) ; file
                        lisp-directory
                        getter
                        (third config)   ; docstring
                        (fourth config))) ; interactive
          (when use-package-verbose
            (message "use-package %s: arranging autoload of %s from %S"
                     package (car config) (cadr config))))
         ((and (symbolp (car config))
               (symbolp (cdr config)))
          (add-hook (car config) (cdr config))
          (when use-package-verbose
            (message "use-package %s: adding %s to hook %s" package (cdr
config) (car config))))
         ((and (eq (car config) 'require)
               (consp (cdr config)))
          (eval-after-load main-file
            `(mapcar 'require ',(mapcar (lambda (feature)
                                          (if (consp feature)
                                              (cadr feature)
                                            feature))
                                        (cdr config)))))
         ((and (stringp (car config))
               (symbolp (cdr config))
               (string-match "-mode$" (symbol-name (cdr config))))
          (when use-package-verbose
            (message "use-package %s: adding auto-mode %S" package config))
          (if (assoc (car config) auto-mode-alist)
              (rplacd (assoc (car config) auto-mode-alist)
                      (cdr config))
            (push config auto-mode-alist)))
         ((and (vectorp (car config))
               (symbolp (cdr config)))
          (global-set-key (car config) (cdr config))
          (when use-package-verbose
            (message "use-package %s: binding %s to %s" package (car config)
(cdr config))))
         (t (error "unknown configuration element %S" config))))
      ;; After the configuration parameters come any forms to be
      ;; evaluated on loading the package.
      (when use-package-verbose
        (message "use-package %s: Adding init forms %S" package init-forms)
        (setq init-forms (append
                          `((message ,(format "use-package %s: starting 
init-forms"
                                              package)))
                          init-forms
                          `((message ,(format "use-package %s: ending 
init-forms"
                                              package))))))
      (eval-after-load main-file
        `(progn ,@init-forms))
      (when load-now
        (when use-package-verbose
          (message "use-package %s: loading immediately" package))
        (unless (or lisp-actual-directory
                    (eq lisp-directory t))
          (autofetch-fetch-it lisp-directory getter main-file))
        (require package)))))

(defmacro use-package (package
                       lisp-directory
                       getter
                       configuration
                       &rest init-forms)
  ;; todo: should probably interface to require/provide; and make sure
that we run the init forms immediately if the package is already
loaded
  "Arrange use of PACKAGE in LISP-DIRECTORY. Get it with GETTER if
needed.

PACKAGE should be the name of a feature (as in provide and require).

LISP-DIRECTORY should be the directory in which the package is
expected to be found; alternatively, it may be `t', indicating
that it is part of the Emacs distribution.  If it is a directory,
it is processed using `substitute-in-file-name', allowing you to
set up an area for downloaded Lisp, that is different on
different machines you use.  It may also be `nil', in which case
`downloaded-emacs-directory' is used if non-nil, otherwise
`user-emacs-directory' is used.

The files may be in a subdirectory of LISP-DIRECTORY, and
use-package will find them for you.  This is because when you
unpack a tarball, the files you need will not necessarily be at
the top level.  You can redefine the function
'use-package-preferable-subdirectory' to control how it chooses
the subdirectory if there are several containing the file.

If the package is not present, GETTER describes how to get it.

GETTER can be:
* a URL
* a function to run
* a list of:
    * a function to run with the following URL and LISP-DIRECTORY
      as its arguments
   and
    * a URL (or a list of URLs to try in that order)
  An optional third element is a form to evaluate after unpacking;
  if you want to give this, but no getter function, give nil for the
  getter function; this form is run with `default-directory' bound
  to the directory in which the file was unpacked
* nil, indicating that the package is not expected to be fetched;
  for example, it might be part of the Emacs distribution

See `use-package-download-path' for more about getting the file.

CONFIGURATION indicates the use of the package: it is a list of
various types of element, many of them lists or pairs. The types
of these elements determine what is done with them.

* If an element is a pair of string and a function symbol whose
  name ends in \"-mode\", it is added to `auto-mode-alist'. This
  is done immediately.

* If an element is a list beginning with a symbol and a string,
  it is used as an autoload definition if the package is already
  in the specified directory, and an autofetch definition
  otherwise. This is done immediately.

* If an element is a string, it is passed through
  `substitute-in-file-name' and added to `load-path'. This is
  done immediately.  It is also passed through `expand-file-name'
  with the actual Lisp directory as the directory argument, so if
  the name is relative, it is taken relative to that directory.

* If an element is `t', the package will be loaded immediately,
  rather than autoloaded.

* If an element is a list of symbols, and the first is `require',
  the rest of the symbols are required. This is done when the
  package is loaded, or immediately if it has already been
  loaded (see `eval-after-load').

* If an element is a pair of two symbols, the first is taken as
  the name of a hook, and the second as a function to put on that
  hook. This is done immediately; you may want to make that
  function also be autoloaded, which you can do from this
  configuration list (see above).

* If an element is a pair of a vector and a symbol (which should
  name a command, that is, an interactive function),
  `global-set-key' is done on them. This is done immediately. You
  may want to make that function also be autoloaded, which you
  can do from this configuration list (see above).

Remaining arguments INIT-FORMS are used as initialization forms
by passing them to `eval-after-load'. These are done when the
package is loaded, or immediately if it has already been
loaded (see `eval-after-load').

See `use-package-only-these', `use-package-skip-these' and
`use-package-check-function' for ways to load packages
selectively."
  `(use-package-1 ',package ,lisp-directory ',getter
                  ',configuration ',init-forms))

(defun bundle-emacs-initialization (outfile &optional infile)
  "Produce a bundled version of your .emacs in OUTFILE.
If INFILE is given, use it instead of .emacs.
Directives obeyed are:
;;;###include FILENAME
  FILENAME may be an ordinary file or a directory; the \".el\"
  files in the directory are included, but subdirectories are not
  scanned.
  The included text is then re-parsed for directives.
;;;###if EXPR
;;;###endif
  These will typically be used with `nil' for EXPR, to suppress
  load and require forms that have been replaced with a ;;;###include
These directives must be at the start of a line.

This command was originally designed to go with use-package, so you
can condense your emacs initialization down to a single file and have
that file haul the rest across the internet or from a removable
storage
device."
  (interactive "FFile for bundled initialization code: ")
  (set-buffer (get-buffer-create "*Bundled emacs initialization*"))
  (erase-buffer)
  (emacs-lisp-mode)
  (let ((input (or infile (expand-file-name "~/.emacs"))))
    (insert-file-contents input)
    (setq default-directory (file-name-directory input)))
  (goto-char (point-min))
  (while (re-search-forward "^;;;###\\(include\\|endif\\)\\s-*\\(.*\
\)"
                            (point-max)
                            t)
    (let ((start (match-beginning 0))
          (end (match-end 0))
          (command (match-string-no-properties 1))
          (args (match-string-no-properties 2)))
      (message "Command %S with %S in %d..%d" command args start end)
      (delete-region start end)
      (cond
       ((string= command "include")
        (let* ((file-name (expand-file-name args
                                            (or (get-text-property start 
'default-directory)
                                                default-directory)))
               (included (if (file-directory-p file-name)
                             (car (mapcar 'insert-file-contents
                                          (directory-files file-name
                                                           t
                                                           "\\.el$")))
                           (insert-file-contents file-name))))
          (put-text-property start (+ start (cadr included))
                             'default-directory
                             (file-name-directory (car included))))
        ;; go back to re-scan what we have just included, to do
        ;; recursive inclusion
        (goto-char start))
       ((string= command "endif")
        ;; do it this way round to allow nested skips
        (if (re-search-backward "^;;;###if\\s-+\\(.+\\)$" (point-min) t)
            (let ((if-start (match-beginning 0))
                  (if-end (match-end 0))
                  (if-expr (read (match-string-no-properties 1))))
              (message "Keeping %d..%d: on condition %S" if-start start if-
expr)
              (if (eval if-expr)
                  (delete-region if-start if-end)
                (delete-region (match-beginning 0) start)
                (goto-char if-start)))
          (error ";;;###endif without ;;;###if"))))))
  (goto-char (point-min))
  (flush-lines "^\\s-*;.+$")
  (goto-char (point-min))
  (flush-lines "^\\s-*$")
  (goto-char (point-min))
  (insert ";;; condensed startup file for "
          (user-login-name)
          "@"
          (system-name)
          " produced at "
          (current-time-string)
          "\n")
  (write-file outfile))

(provide 'use-package)

;;; end of use-package.el



reply via email to

[Prev in Thread] Current Thread [Next in Thread]