git.chise.org Git - chise/xemacs-chise.git.1/blob - lisp/packages.el

   1 ;;; packages.el --- Low level support for XEmacs packages
   2
   3 ;; Copyright (C) 1997 Free Software Foundation, Inc.
   4
   5 ;; Author: Steven L Baur <steve@altair.xemacs.org>
   6 ;; Maintainer: Steven L Baur <steve@altair.xemacs.org>
   7 ;; Keywords: internal, lisp, dumped
   8
   9 ;; This file is part of XEmacs.
  10
  11 ;; XEmacs is free software; you can redistribute it and/or modify it
  12 ;; under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; XEmacs is distributed in the hope that it will be useful, but
  17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  23 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  24 ;; 02111-1307, USA.
  25
  26 ;;; Synched up with: Not in FSF
  27
  28 ;;; Commentary:
  29
  30 ;; This file is dumped with XEmacs.
  31
  32 ;; This file provides low level facilities for XEmacs startup --
  33 ;; particularly regarding the package setup.  This code has to run in
  34 ;; what we call "bare temacs" -- i.e. XEmacs without the usual Lisp
  35 ;; environment.  Pay special attention:
  36
  37 ;; - not to use the `lambda' macro.  Use #'(lambda ...) instead.
  38 ;;   (this goes for any package loaded before `subr.el'.)
  39 ;;
  40 ;; - not to use macros, because they are not yet available (and this
  41 ;;   file must be loadable uncompiled.)  This rules out CL-style
  42 ;;   macros like `when', for instance.
  43 ;;
  44 ;; - not to use `defcustom'.  If you must add user-customizable
  45 ;;   variables here, use `defvar', and add the variable to
  46 ;;   `cus-start.el'.
  47
  48 ;; Because of all this, make sure that the stuff you put here really
  49 ;; belongs here.
  50
  51 ;; This file requires find-paths.el.
  52 \f
  53 ;;; Code:
  54
  55 ;;; Package versioning
  56
  57 (defvar packages-package-list nil
  58   "database of loaded packages and version numbers")
  59
  60 (defvar packages-hierarchy-depth 1
  61   "Depth of package hierarchies.")
  62
  63 (defvar packages-load-path-depth 1
  64   "Depth of load-path search in package hierarchies.")
  65
  66 (defvar early-packages nil
  67   "Packages early in the load path.")
  68
  69 (defvar early-package-load-path nil
  70   "Load path for packages early in the load path.")
  71
  72 (defvar late-packages nil
  73   "Packages late in the load path.")
  74
  75 (defvar late-package-load-path nil
  76   "Load path for packages late in the load path.")
  77
  78 (defvar last-packages nil
  79   "Packages last in the load path.")
  80
  81 (defvar last-package-load-path nil
  82   "Load path for packages last in the load path.")
  83
  84 (defvar package-locations
  85   (list
  86    (list (paths-construct-path '("~" ".xemacs"))
  87                              'early #'(lambda () t))
  88    (list "site-packages"     'late  #'(lambda () t))
  89    (list "infodock-packages" 'late  #'(lambda () (featurep 'infodock)))
  90    (list "mule-packages"     'late  #'(lambda () (featurep 'mule)))
  91    (list "xemacs-packages"   'late  #'(lambda () t))
  92    (list "packages"          'late  #'(lambda () t)))
  93   "Locations of the various package directories.
  94 This is a list each of whose elements describes one directory.
  95 A directory description is a three-element list.
  96 The first element is either an absolute path or a subdirectory
  97 in the XEmacs hierarchy.
  98 The second component is one of the symbols EARLY, LATE, LAST,
  99 depending on the load-path segment the hierarchy is supposed to
 100 show up in.
 101 The third component is a thunk which, if it returns NIL, causes
 102 the directory to be ignored.")
 103
 104 (defun package-get-key-1 (info key)
 105   "Locate keyword `key' in list."
 106   (cond ((null info)
 107          nil)
 108         ((eq (car info) key)
 109          (nth 1 info))
 110         (t (package-get-key-1 (cddr info) key))))
 111
 112 (defun package-get-key (name key)
 113   "Get info `key' from package `name'."
 114   (let ((info (assq name packages-package-list)))
 115     (when info
 116       (package-get-key-1 (cdr info) key))))
 117
 118 (defun package-provide (name &rest attributes)
 119   (let ((info (if (and attributes (floatp (car attributes)))
 120                   (list :version (car attributes))
 121                 attributes)))
 122     (remassq name packages-package-list)
 123     (setq packages-package-list
 124           (cons (cons name info) packages-package-list))))
 125
 126 (defun package-require (name version)
 127   (let ((pkg (assq name packages-package-list)))
 128     (cond ((null pkg)
 129            (error "Package %s has not been loaded into this XEmacsen"
 130                   name))
 131           ((< (package-get-key name :version) version)
 132            (error "Need version %g of package %s, got version %g"
 133                   version name (cdr pkg)))
 134           (t t))))
 135
 136 ;;; Build time stuff
 137
 138 (defvar autoload-file-name "auto-autoloads.el"
 139   "Filename that autoloads are expected to be found in.")
 140
 141 (defvar packages-hardcoded-lisp
 142   '(
 143     ;; Nothing at this time
 144     )
 145   "Lisp packages that are always dumped with XEmacs.
 146 This includes every package that is loaded directly by a package listed
 147 in dumped-lisp.el and is not itself listed.")
 148
 149 (defvar packages-useful-lisp
 150   '("bytecomp"
 151     "byte-optimize"
 152     "shadow"
 153     "cl-macs")
 154   "Lisp packages that need early byte compilation.")
 155
 156 (defvar packages-unbytecompiled-lisp
 157   '("paths.el"
 158     "dumped-lisp.el"
 159     "dumped-pkg-lisp.el"
 160     "version.el"
 161     "very-early-lisp.el"
 162     "Installation.el")
 163   "Lisp packages that should not be byte compiled.")
 164
 165
 166 ;; Copied from help.el, could possibly move it to here permanently.
 167 ;; Unlike the FSF version, our `locate-library' uses the `locate-file'
 168 ;; primitive, which should make it lightning-fast.
 169
 170 (defun locate-library (library &optional nosuffix path interactive-call)
 171   "Show the precise file name of Emacs library LIBRARY.
 172 This command searches the directories in `load-path' like `M-x load-library'
 173 to find the file that `M-x load-library RET LIBRARY RET' would load.
 174 Optional second arg NOSUFFIX non-nil means don't add suffixes `.elc' or `.el'
 175 to the specified name LIBRARY.
 176
 177 If the optional third arg PATH is specified, that list of directories
 178 is used instead of `load-path'."
 179   (interactive (list (read-string "Locate library: ")
 180                      nil nil
 181                      t))
 182   (let ((result
 183          (locate-file
 184           library
 185           (or path load-path)
 186           (cond ((or (rassq 'jka-compr-handler file-name-handler-alist)
 187                      (and (boundp 'find-file-hooks)
 188                           (member 'crypt-find-file-hook find-file-hooks)))
 189                  ;; Compression involved.
 190                  (if nosuffix
 191                      ":.gz:.Z"
 192                    ".elc:.elc.gz:elc.Z:.el:.el.gz:.el.Z::.gz:.Z"))
 193                 (t
 194                  ;; No compression.
 195                  (if nosuffix
 196                      ""
 197                    ".elc:.el:")))
 198           4)))
 199     (and interactive-call
 200          (if result
 201              (message "Library is file %s" result)
 202            (message "No library %s in search path" library)))
 203     result))
 204
 205 (defun packages-add-suffix (str)
 206   (if (null (string-match "\\.el\\'" str))
 207       (concat str ".elc")
 208     str))
 209
 210 (defun packages-list-autoloads-path ()
 211   "List autoloads from precomputed load-path."
 212   (let ((path load-path)
 213         autoloads)
 214     (while path
 215       (if (file-exists-p (concat (car path)
 216                                  autoload-file-name))
 217           (setq autoloads (cons (concat (car path)
 218                                         autoload-file-name)
 219                                 autoloads)))
 220       (setq path (cdr path)))
 221     autoloads))
 222
 223 (defun packages-list-autoloads ()
 224   "List autoload files in (what will be) the normal lisp search path.
 225 This function is used during build to find where the global symbol files so
 226 they can be perused for their useful information."
 227   ;; Source directory may not be initialized yet.
 228   ;; (print (prin1-to-string load-path))
 229   (if (null source-directory)
 230       (setq source-directory (car load-path)))
 231   (let ((files (directory-files (file-name-as-directory source-directory)
 232                                 t ".*"))
 233         file autolist)
 234     ;; (print (prin1-to-string source-directory))
 235     ;; (print (prin1-to-string files))
 236     (while (setq file (car-safe files))
 237       (if (and (file-directory-p file)
 238                (file-exists-p (concat (file-name-as-directory file)
 239                                       autoload-file-name)))
 240           (setq autolist (cons (concat (file-name-as-directory file)
 241                                        autoload-file-name)
 242                                autolist)))
 243       (setq files (cdr files)))
 244     autolist))
 245
 246 ;; The following function cannot be called from a bare temacs
 247 (defun packages-new-autoloads ()
 248   "Return autoloads files that have been added or modified since XEmacs dump."
 249   (require 'loadhist)
 250   (let ((me (concat invocation-directory invocation-name))
 251         (path load-path)
 252         result dir)
 253     (while path
 254       (setq dir (file-truename (car path)))
 255       (let ((autoload-file (file-name-sans-extension (concat
 256                                                       dir
 257                                                       autoload-file-name))))
 258         ;; Check for:
 259         ;; 1.  An auto-autoload file that hasn't provided a feature (because
 260         ;;     it has been installed since XEmacs was dumped).
 261         ;; 2.  auto-autoload.el being newer than the executable
 262         ;; 3.  auto-autoload.elc being newer than the executable (the .el
 263         ;;     could be missing or compressed)
 264         (when (or (and (null (file-provides autoload-file))
 265                        (or (file-exists-p (concat autoload-file ".elc"))
 266                            (file-exists-p (concat autoload-file ".el"))))
 267                   (and (file-newer-than-file-p (concat autoload-file ".el") me)
 268                        (setq autoload-file (concat autoload-file ".el")))
 269                   (and (file-newer-than-file-p (concat autoload-file
 270                                                        ".elc")
 271                                                me)
 272                        (setq autoload-file (concat autoload-file ".elc"))))
 273           (push autoload-file result)))
 274       (setq path (cdr path)))
 275     result))
 276
 277 ;; The following function cannot be called from a bare temacs
 278 (defun packages-reload-autoloads ()
 279   "Reload new or updated auto-autoloads files.
 280 This is an extremely dangerous function to call after the user-init-files
 281 is run.  Don't call it or you'll be sorry."
 282   (let ((autoload-list (packages-new-autoloads)))
 283     (while autoload-list
 284       (let* ((autoload-file (car autoload-list))
 285              (feature (car-safe (file-provides autoload-file))))
 286         (when feature
 287           ;; (message "(unload-feature %S)" feature)
 288           (unload-feature feature))
 289         (condition-case nil
 290             (load autoload-file)
 291           (t nil)))
 292       (setq autoload-list (cdr autoload-list)))))
 293
 294 ;; Data-directory is really a list now.  Provide something to search it for
 295 ;; directories.
 296
 297 (defun locate-data-directory (name &optional dir-list)
 298   "Locate a directory in a search path DIR-LIST (a list of directories).
 299 If no DIR-LIST is supplied, it defaults to `data-directory-list'."
 300   (unless dir-list
 301     (setq dir-list data-directory-list))
 302   (let (found found-dir)
 303     (while (and (null found-dir) dir-list)
 304       (setq found (file-name-as-directory (concat (car dir-list) name))
 305             found-dir (file-directory-p found))
 306       (or found-dir
 307           (setq found nil))
 308       (setq dir-list (cdr dir-list)))
 309     found))
 310
 311 ;; Data-directory is really a list now.  Provide something to search it for
 312 ;; files.
 313
 314 (defun locate-data-file (name &optional dir-list)
 315   "Locate a file in a search path DIR-LIST (a list of directories).
 316 If no DIR-LIST is supplied, it defaults to `data-directory-list'.
 317 This function is basically a wrapper over `locate-file'."
 318   (unless dir-list
 319     (setq dir-list data-directory-list))
 320   (locate-file name dir-list))
 321
 322 ;; Path setup
 323
 324 (defun packages-find-package-directories (roots base)
 325   "Find a set of package directories."
 326   ;; make sure paths-find-version-directory and paths-find-site-directory
 327   ;; don't both pick up version-independent directories ...
 328   (let ((version-directory (paths-find-version-directory roots base nil nil t))
 329         (site-directory (paths-find-site-directory roots base)))
 330     (paths-uniq-append
 331      (and version-directory (list version-directory))
 332      (and site-directory (list site-directory)))))
 333
 334 (defvar packages-special-base-regexp "^\\(etc\\|info\\|lisp\\|lib-src\\|bin\\)$"
 335   "Special subdirectories of packages.")
 336
 337 (defvar packages-no-package-hierarchy-regexp
 338   (concat "\\(" paths-version-control-filename-regexp "\\)"
 339           "\\|"
 340           "\\(" packages-special-base-regexp "\\)")
 341   "Directories which can't be the roots of package hierarchies.")
 342
 343 (defun packages-find-packages-in-directories (directories)
 344   "Find all packages underneath directories in DIRECTORIES."
 345   (paths-find-recursive-path directories
 346                              packages-hierarchy-depth
 347                              packages-no-package-hierarchy-regexp))
 348
 349 (defun packages-split-path (path)
 350   "Split PATH at \"\", return pair with two components.
 351 The second component is shared with PATH."
 352   (let ((reverse-tail '())
 353         (rest path))
 354     (while (and rest (null (string-equal "" (car rest))))
 355       (setq reverse-tail (cons (car rest) reverse-tail))
 356       (setq rest (cdr rest)))
 357     (if (null rest)
 358         (cons path nil)
 359       (cons (nreverse reverse-tail) (cdr rest)))))
 360
 361 (defun packages-split-package-path (package-path)
 362   "Split up PACKAGE-PATH into early, late and last components.
 363 The separation is by \"\" components.
 364 This returns (LIST EARLY-PACKAGES LATE-PACKAGES LAST-PACKAGES)."
 365   ;; When in doubt, it's late
 366   (let* ((stuff (packages-split-path package-path))
 367          (early (and (cdr stuff) (car stuff)))
 368          (late+last (or (cdr stuff) (car stuff)))
 369          (stuff (packages-split-path late+last))
 370          (late (car stuff))
 371          (last (cdr stuff)))
 372     (list (packages-find-packages-in-directories early)
 373           (packages-find-packages-in-directories late)
 374           (packages-find-packages-in-directories last))))
 375
 376 (defun packages-deconstruct (list consumer)
 377   "Deconstruct LIST and feed it to CONSUMER."
 378   (apply consumer list))
 379
 380 (defun packages-find-packages-by-name (roots name)
 381   "Find a package hierarchy by its name."
 382   (packages-find-packages-in-directories
 383    (if (and (file-name-absolute-p name)
 384             (file-name-directory (expand-file-name name)))
 385        (list (file-name-as-directory (expand-file-name name)))
 386     (packages-find-package-directories roots name))))
 387
 388 (defun packages-find-packages-at-time
 389   (roots package-locations time &optional default)
 390   "Find packages at given time.
 391 For the format of PACKAGE-LOCATIONS, see the global variable of the same name.
 392 TIME is either 'EARLY, 'LATE, or 'LAST.
 393 DEFAULT is a default list of packages."
 394   (or default
 395       (let ((packages '()))
 396         (while package-locations
 397           (packages-deconstruct
 398            (car package-locations)
 399            #'(lambda (name a-time thunk)
 400                (if (and (eq time a-time)
 401                         (funcall thunk))
 402                    (setq packages
 403                          (nconc packages
 404                                 (packages-find-packages-by-name roots name))))))
 405           (setq package-locations (cdr package-locations)))
 406         packages)))
 407
 408 (defun packages-find-packages (roots)
 409   "Find the packages."
 410   (let ((envvar-value (getenv "EMACSPACKAGEPATH")))
 411     (if envvar-value
 412         (packages-split-package-path (paths-decode-directory-path envvar-value))
 413       (packages-deconstruct
 414        (packages-split-package-path configure-package-path)
 415        #'(lambda (configure-early-packages
 416                   configure-late-packages
 417                   configure-last-packages)
 418            (list (packages-find-packages-at-time roots package-locations 'early
 419                                                  configure-early-packages)
 420                  (packages-find-packages-at-time roots package-locations 'late
 421                                                  configure-late-packages)
 422                  (packages-find-packages-at-time roots package-locations 'last
 423                                                  configure-last-packages)))))))
 424
 425 (defun packages-find-package-library-path (packages suffixes)
 426   "Construct a path into a component of the packages hierarchy.
 427 PACKAGES is a list of package directories.
 428 SUFFIXES is a list of names of package subdirectories to look for."
 429   (let ((directories
 430          (apply
 431           #'append
 432           (mapcar #'(lambda (package)
 433                       (mapcar #'(lambda (suffix)
 434                                   (file-name-as-directory (concat package suffix)))
 435                               suffixes))
 436                   packages))))
 437     (paths-directories-which-exist directories)))
 438
 439 (defun packages-find-package-load-path (packages)
 440   "Construct the load-path component for packages.
 441 PACKAGES is a list of package directories."
 442   (paths-find-recursive-load-path
 443    (packages-find-package-library-path packages
 444                                        '("lisp"))
 445    packages-load-path-depth))
 446
 447 (defun packages-find-package-exec-path (packages)
 448   (packages-find-package-library-path packages
 449                                       (list (paths-construct-path
 450                                              (list "bin" system-configuration))
 451                                             "lib-src")))
 452
 453 (defun packages-find-package-info-path (packages)
 454   (packages-find-package-library-path packages '("info")))
 455
 456 (defun packages-find-package-data-path (packages)
 457   (packages-find-package-library-path packages '("etc")))
 458
 459 ;; Loading package initialization files
 460
 461 (defun packages-load-package-lisps (package-load-path base)
 462   "Load all Lisp files of a certain name along a load path.
 463 BASE is the base name of the files."
 464   (mapc #'(lambda (dir)
 465             (let ((file-name (expand-file-name base dir)))
 466               (condition-case error
 467                   (load file-name t t)
 468                 (error
 469                  (warn (format "Autoload error in: %s:\n\t%s"
 470                                file-name
 471                                (with-output-to-string
 472                                  (display-error error nil))))))))
 473         package-load-path))
 474
 475 (defun packages-load-package-auto-autoloads (package-load-path)
 476   "Load auto-autoload files along a load path."
 477   (packages-load-package-lisps package-load-path
 478                                (file-name-sans-extension autoload-file-name)))
 479
 480 (defun packages-handle-package-dumped-lisps (handle package-load-path)
 481   "Load dumped-lisp.el files along a load path.
 482 Call HANDLE on each file off definitions of PACKAGE-LISP there."
 483   (mapc #'(lambda (dir)
 484             (let ((file-name (expand-file-name "dumped-lisp.el" dir)))
 485               (if (file-exists-p file-name)
 486                   (let (package-lisp
 487                         ;; 20.4 packages could set this
 488                         preloaded-file-list)
 489                     (load file-name)
 490                     ;; dumped-lisp.el could have set this ...
 491                     (if package-lisp
 492                         (mapc #'(lambda (base)
 493                                   (funcall handle base))
 494                               package-lisp))))))
 495         package-load-path))
 496
 497 (defun packages-load-package-dumped-lisps (package-load-path)
 498   "Load dumped-lisp.el files along a load path.
 499 Also load files off PACKAGE-LISP definitions there"
 500   (packages-handle-package-dumped-lisps #'load package-load-path))
 501
 502 (defun packages-collect-package-dumped-lisps (package-load-path)
 503   "Load dumped-lisp.el files along a load path.
 504 Return list of files off PACKAGE-LISP definitions there"
 505   (let ((*files* '()))
 506     (packages-handle-package-dumped-lisps
 507      #'(lambda (file)
 508          (setq *files* (cons file *files*)))
 509      package-load-path)
 510     (reverse *files*)))
 511
 512 (provide 'packages)
 513
 514 ;;; packages.el ends here