cgit.sxemacs.org Git - sxemacs/blob - lisp/packages.el

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