cgit.sxemacs.org Git - sxemacs/blob - lisp/cus-dep.el

   1 ;;; cus-dep.el --- Find customization dependencies.
   2 ;;
   3 ;; Copyright (C) 1997 Free Software Foundation, Inc.
   4 ;; Copyright (C) 2003 Ben Wing.
   5 ;;
   6 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>, then
   7 ;;         Richard Stallman <rms@gnu.ai.mit.edu>, then
   8 ;;         Hrvoje Niksic <hniksic@xemacs.org>       (rewritten for XEmacs)
   9 ;; Maintainer: Hrvoje Niksic <hniksic@xemacs.org>
  10 ;; Keywords: internal
  11
  12 ;; This file is part of SXEmacs.
  13
  14 ;; SXEmacs is free software: you can redistribute it and/or modify
  15 ;; it under the terms of the GNU General Public License as published by
  16 ;; the Free Software Foundation, either version 3 of the License, or
  17 ;; (at your option) any later version.
  18
  19 ;; SXEmacs is distributed in the hope that it will be useful,
  20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 ;; GNU General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  26
  27 ;;; Synched up with: Not synched with FSF.
  28
  29 \f
  30 ;;; Commentary:
  31
  32 ;; This file generates the custom-load files, loaded by cus-load.el.
  33 ;; Entry points are `Custom-make-dependencies' and
  34 ;; `Custom-make-one-dependency'.
  35
  36 ;; It works by scanning all the `.el' files in a directory, and
  37 ;; evaluates any `defcustom', `defgroup', or `defface' expression that
  38 ;; it finds.  The symbol changed by this expression is stored to a
  39 ;; hash table as the hash key, file name being the value.
  40
  41 ;; After all the files have been examined, custom-loads.el is
  42 ;; generated by mapping all the atoms, and seeing if any of them
  43 ;; contains a `custom-group' property.  This property is a list whose
  44 ;; each element's car is the "child" group symbol.  If that property
  45 ;; is in the hash-table, the file name will be looked up from the
  46 ;; hash-table, and added to cusload-file.  Because the hash-table is
  47 ;; cleared whenever we process a new directory, we cannot get confused
  48 ;; by custom-loads from another directory, or from a previous
  49 ;; installation.  This is also why it is perfectly safe to have old
  50 ;; custom-loads around, and have them loaded by `cus-load.el' (as
  51 ;; invoked by `cus-edit.el').
  52
  53 ;; A trivial, but useful optimization is that if cusload-file exists,
  54 ;; and no .el files in the directory are newer than cusload-file, it
  55 ;; will not be generated.  This means that the directories where
  56 ;; nothing has changed will be skipped.
  57
  58 ;; The `custom-add-loads' function, used by files generated by
  59 ;; `Custom-make-dependencies', updates the symbol's `custom-loads'
  60 ;; property (a list of strings) with a new list of strings,
  61 ;; eliminating the duplicates.  Additionally, it adds the symbol to
  62 ;; `custom-group-hash-table'.  It is defined in `cus-load.el'.
  63
  64 ;; Example:
  65
  66 ;; (custom-add-loads 'foo 'custom-loads '("bar" "baz"))
  67 ;; (get 'foo 'custom-loads)
  68 ;;   => ("bar" "baz")
  69 ;;
  70 ;; (custom-add-loads 'foo 'custom-loads '("hmph" "baz" "quz"))
  71 ;; (get 'foo 'custom-loads)
  72 ;;   => ("bar" "baz" "hmph" "qux")
  73
  74 ;; Obviously, this allows correct incremental loading of custom-load
  75 ;; files.  This is not necessary under FSF (they simply use `put'),
  76 ;; since they have only one file with custom dependencies.  With the
  77 ;; advent of packages, we cannot afford the same luxury.
  78 ;;
  79 ;; Feb 2003: Added code to speed up building by caching the values we've
  80 ;; constructed, and using them instead of scanning a file when custom-load
  81 ;; is up-to-date w.r.t. the file.  Also use `message' not `princ' to print
  82 ;; out messages so nl's are correctly inserted when necessary. --ben
  83
  84 \f
  85 ;;; Code:
  86
  87 (require 'cl)
  88 (require 'widget)
  89 (require 'cus-face)
  90
  91 ;; #### This and the autoloads file naming variables belong in a separate
  92 ;; file to be required here.
  93 ;; #### Compare this with the autoloads handling.
  94 ;; Don't change this, unless you plan to change the code in
  95 ;; cus-start.el, too.
  96 (defconst cusload-base-file "custom-load.el")
  97 (defconst cusload-hash-table-marker ";old-cus-dep-hash: ")
  98
  99 ;; Be very careful when changing this function.  It looks easy to
 100 ;; understand, but is in fact very easy to break.  Be sure to read and
 101 ;; understand the commentary above!
 102
 103 (defun Custom-make-dependencies-1 (subdirs &optional outfile)
 104   (setq subdirs (mapcar #'expand-file-name subdirs))
 105   (with-temp-buffer
 106     (let ((enable-local-eval nil)
 107           (hash (make-hash-table :test 'eq))
 108           (hash-cache (make-hash-table :test 'equal))
 109           old-hash)
 110       (dolist (dir subdirs)
 111         (message "Processing %s\n" dir)
 112         (let ((cusload-file (or outfile
 113                                 (expand-file-name cusload-base-file dir)))
 114               (files (directory-files dir t #r"\`[^=].*\.el\'")))
 115           ;; A trivial optimization: if no file in the directory is
 116           ;; newer than custom-load.el, no need to do anything!
 117           (if (and (file-exists-p cusload-file)
 118                    (dolist (file files t)
 119                      (when (file-newer-than-file-p file cusload-file)
 120                        (return nil))))
 121               (message "(No changes need to be written)")
 122             (when (file-exists-p cusload-file)
 123               (let ((buf (find-file-noselect cusload-file)))
 124                 (with-current-buffer buf
 125                   (goto-char (point-min))
 126                   (when (search-forward cusload-hash-table-marker nil t)
 127                     (setq old-hash (read buf))))
 128                 (kill-buffer buf)))
 129             ;; Process directory
 130             (dolist (file files)
 131               (let ((old-cache (if (hash-table-p old-hash)
 132                                    (gethash file old-hash t)
 133                                  t)))
 134                 (if (and (not (file-newer-than-file-p file cusload-file))
 135                          (not (eq old-cache t)))
 136                     (progn
 137                       (dolist (c old-cache)
 138                         (puthash (car c) (cdr c) hash))
 139                       (puthash file old-cache hash-cache))
 140                   (erase-buffer)
 141                   (insert-file-contents file)
 142                   (goto-char (point-min))
 143                   (let ((name (file-name-sans-extension
 144                                (file-name-nondirectory file)))
 145                         cache
 146                         (first t))
 147                     ;; Search for defcustom/defface/defgroup
 148                     ;; expressions, and evaluate them.
 149                     (while (re-search-forward
 150                             #r"^(defcustom\|^(defface\|^(defgroup"
 151                             nil t)
 152                       (when first
 153                         (message "Computing custom-loads for %s..." name)
 154                         (setq first nil))
 155                       (beginning-of-line)
 156                       (let ((expr (read (current-buffer))))
 157                         ;; We need to ignore errors here, so that
 158                         ;; defcustoms with :set don't bug out.  Of
 159                         ;; course, their values will not be assigned in
 160                         ;; case of errors, but their `custom-group'
 161                         ;; properties will by that time be in place, and
 162                         ;; that's all we care about.
 163                         (ignore-errors
 164                           (eval expr))
 165                         ;; Hash the file of the affected symbol.
 166                         (setf (gethash (nth 1 expr) hash) name)
 167                         ;; Remember the values computed.
 168                         (push (cons (nth 1 expr) name) cache)))
 169                     (or cache
 170                         (message "No custom-loads for %s" name))
 171                     (puthash file cache hash-cache)))
 172                 ))
 173             (cond
 174              ((zerop (hash-table-count hash))
 175               (message "(No customization dependencies)")
 176               (write-region "" nil cusload-file))
 177              (t
 178               (message "Generating %s...\n" cusload-base-file)
 179               (with-temp-file cusload-file
 180                 (insert ";;; " cusload-base-file
 181                         " --- automatically extracted custom dependencies\n"
 182                         "\n;;; Code:\n\n")
 183                 (insert cusload-hash-table-marker)
 184                 (let ((print-readably t)
 185                       (standard-output (current-buffer)))
 186                   (princ hash-cache)
 187                   (terpri))
 188                 (insert "(autoload 'custom-add-loads \"cus-load\")\n\n")
 189                 (mapatoms
 190                  (lambda (sym)
 191                    (let ((members (get sym 'custom-group))
 192                          item where found)
 193                      (when members
 194                        (while members
 195                          (setq item (car (car members))
 196                                members (cdr members)
 197                                where (gethash item hash))
 198                          (unless (or (null where)
 199                                      (member where found))
 200                            (if found
 201                                (insert " ")
 202                              (insert "(custom-add-loads '"
 203                                      (prin1-to-string sym) " '("))
 204                            (prin1 where (current-buffer))
 205                            (push where found)))
 206                        (when found
 207                          (insert "))\n"))))))
 208                 (insert "\n;;; custom-load.el ends here\n"))
 209               (clrhash hash)))))))))
 210
 211 (defun Custom-make-one-dependency ()
 212   "Extract custom dependencies from .el files in one dir, on the command line.
 213 Like `Custom-make-dependencies' but snarfs only one command-line argument,
 214 making it useful in a chain of batch commands in a single XEmacs invocation."
 215   (let ((subdir (car command-line-args-left)))
 216     (setq command-line-args-left (cdr command-line-args-left))
 217     (Custom-make-dependencies-1 (list subdir))))
 218
 219 ;;;###autoload
 220 (defun Custom-make-dependencies (&optional subdirs outfile)
 221   "Extract custom dependencies from .el files in SUBDIRS.
 222
 223 SUBDIRS is a list of directories.  If it is nil, the command-line
 224 arguments are used.  If it is a string, only that directory is
 225 processed.
 226
 227 OUTFILE is for optionally setting where to put the output.  This
 228 is most often used when building outside of a source tree and you
 229 want the custom-loads.el to be in the build tree.  Be sure to call
 230 #'expand-file-name on OUTFILE to be safe.
 231
 232 This function is especially useful in batch mode.
 233
 234 Batch usage: xemacs -batch -l cus-dep.el -f Custom-make-dependencies DIRS"
 235   (interactive "DDirectory: ")
 236   (and (stringp subdirs)
 237        (setq subdirs (list subdirs)))
 238   (or subdirs
 239       ;; Usurp the command-line-args
 240       (setq subdirs command-line-args-left
 241             command-line-args-left nil))
 242   (Custom-make-dependencies-1 subdirs outfile))
 243
 244 (provide 'cus-dep)
 245
 246 ;;; cus-dep.el ends here