xemacs-beta: lisp/packages.el comparison

comparison lisp/packages.el @ 428:3ecd8885ac67 r21-2-22

Import from CVS: tag r21-2-22

author	cvs
date	Mon, 13 Aug 2007 11:28:15 +0200
parents
children	abe6d1db359e

comparison

equal deleted inserted replaced

-:0a0253eac470
+:3ecd8885ac67
+;;; packages.el --- Low level support for XEmacs packages
+;; Copyright (C) 1997 Free Software Foundation, Inc.
+;; Author: Steven L Baur <steve@xemacs.org>
+;; Maintainer: Steven L Baur <steve@xemacs.org>
+;; Keywords: internal, lisp, dumped
+;; This file is part of XEmacs.
+;; XEmacs 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.
+;; XEmacs 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 XEmacs; see the file COPYING.  If not, write to the Free
+;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+;; 02111-1307, USA.
+;;; Synched up with: Not in FSF
+;;; Commentary:
+;; This file is dumped with XEmacs.
+;; This file provides low level facilities for XEmacs startup --
+;; particularly regarding the package setup.  This code has to run in
+;; what we call "bare temacs" -- i.e. XEmacs without the usual Lisp
+;; environment.  Pay special attention:
+;; - not to use the `lambda' macro.  Use #'(lambda ...) instead.
+;;   (this goes for any package loaded before `subr.el'.)
+;;
+;; - not to use macros, because they are not yet available (and this
+;;   file must be loadable uncompiled.)  This rules out CL-style
+;;   macros like `when', for instance.
+;;
+;; - not to use `defcustom'.  If you must add user-customizable
+;;   variables here, use `defvar', and add the variable to
+;;   `cus-start.el'.
+;; Because of all this, make sure that the stuff you put here really
+;; belongs here.
+;; This file requires find-paths.el.
+;;; Code:
+;;; Package versioning
+(defvar packages-package-list nil
+"Database of loaded packages and version numbers")
+(defvar packages-hierarchy-depth 1
+"Depth of package hierarchies.")
+(defvar packages-load-path-depth 1
+"Depth of load-path search in package hierarchies.")
+(defvar packages-data-path-depth 1
+"Depth of data-path search in package hierarchies.")
+(defvar early-packages nil
+"Packages early in the load path.")
+(defvar early-package-load-path nil
+"Load path for packages early in the load path.")
+(defvar late-packages nil
+"Packages late in the load path.")
+(defvar late-package-load-path nil
+"Load path for packages late in the load path.")
+(defvar last-packages nil
+"Packages last in the load path.")
+(defvar last-package-load-path nil
+"Load path for packages last in the load path.")
+(defun packages-compute-package-locations (user-init-directory)
+"Compute locations of the various package directories.
+This is a list each of whose elements describes one directory.
+A directory description is a three-element list.
+The first element is either an absolute path or a subdirectory
+in the XEmacs hierarchy.
+The second component is one of the symbols EARLY, LATE, LAST,
+depending on the load-path segment the hierarchy is supposed to
+show up in.
+The third component is a thunk which, if it returns NIL, causes
+the directory to be ignored."
+(list
+(list (paths-construct-path (list user-init-directory "mule-packages"))
+	 'early #'(lambda () (featurep 'mule)))
+(list (paths-construct-path (list user-init-directory "xemacs-packages"))
+	 'early #'(lambda () t))
+(list "site-packages"     'late  #'(lambda () t))
+(list "infodock-packages" 'late  #'(lambda () (featurep 'infodock)))
+(list "mule-packages"     'late  #'(lambda () (featurep 'mule)))
+(list "xemacs-packages"   'late  #'(lambda () t))))
+(defun package-get-key-1 (info key)
+"Locate keyword `key' in list."
+(cond ((null info)
+	 nil)
+	((eq (car info) key)
+	 (nth 1 info))
+	(t (package-get-key-1 (cddr info) key))))
+(defun package-get-key (name key)
+"Get info `key' from package `name'."
+(let ((info (assq name packages-package-list)))
+(when info
+(package-get-key-1 (cdr info) key))))
+(defun package-provide (name &rest attributes)
+(let ((info (if (and attributes (floatp (car attributes)))
+		  (list :version (car attributes))
+		attributes)))
+(setq packages-package-list
+	  (cons (cons name info) (remassq name packages-package-list)))))
+(defun package-require (name version)
+(let ((pkg (assq name packages-package-list)))
+(cond ((null pkg)
+	   (error "Package %s has not been loaded into this XEmacsen"
+		  name))
+	  ((< (package-get-key name :version) version)
+	   (error "Need version %g of package %s, got version %g"
+		  version name (cdr pkg)))
+	  (t t))))
+(defun package-delete-name (name)
+(let (pkg)
+;; Delete ALL versions of package.
+;; This is pretty memory-intensive, as we use copy-alist when deleting
+;; package entries, to prevent side-effects in functions that call this
+;; one.
+(while (setq pkg (assq name packages-package-list))
+(setq packages-package-list (delete pkg (copy-alist
+					       packages-package-list)))
+)
+))
+;;; Build time stuff
+(defvar autoload-file-name "auto-autoloads.el"
+"Filename that autoloads are expected to be found in.")
+(defvar packages-hardcoded-lisp
+'(
+;; Nothing at this time
+)
+"Lisp packages that are always dumped with XEmacs.
+This includes every package that is loaded directly by a package listed
+in dumped-lisp.el and is not itself listed.")
+(defvar packages-useful-lisp
+'("bytecomp"
+"byte-optimize"
+"shadow"
+"cl-macs")
+"Lisp packages that need early byte compilation.")
+(defvar packages-unbytecompiled-lisp
+'("paths.el"
+"dumped-lisp.el"
+"dumped-pkg-lisp.el"
+"version.el"
+"very-early-lisp.el")
+"Lisp packages that should not be byte compiled.")
+;; Copied from help.el, could possibly move it to here permanently.
+;; Unlike the FSF version, our `locate-library' uses the `locate-file'
+;; primitive, which should make it lightning-fast.
+(defun locate-library (library &optional nosuffix path interactive-call)
+"Show the precise file name of Emacs library LIBRARY.
+This command searches the directories in `load-path' like `M-x load-library'
+to find the file that `M-x load-library RET LIBRARY RET' would load.
+Optional second arg NOSUFFIX non-nil means don't add suffixes `.elc' or `.el'
+to the specified name LIBRARY.
+If the optional third arg PATH is specified, that list of directories
+is used instead of `load-path'."
+(interactive (list (read-string "Locate library: ")
+nil nil
+t))
+(let ((result
+	 (locate-file
+	  library
+	  (or path load-path)
+	  (cond ((or (rassq 'jka-compr-handler file-name-handler-alist)
+		     (and (boundp 'find-file-hooks)
+			  (member 'crypt-find-file-hook find-file-hooks)))
+		 ;; Compression involved.
+		 (if nosuffix
+		     '("" ".gz" ".Z")
+		   '(".elc" ".elc.gz" "elc.Z" ".el" ".el.gz" ".el.Z" "" ".gz" ".Z")))
+		(t
+		 ;; No compression.
+		 (if nosuffix
+		     ""
+		   '(".elc" ".el" "")))))))
+(and interactive-call
+	 (if result
+	     (message "Library is file %s" result)
+	   (message "No library %s in search path" library)))
+result))
+(defun packages-add-suffix (str)
+(if (null (string-match "\\.el\\'" str))
+(concat str ".elc")
+str))
+(defun packages-list-autoloads-path ()
+"List autoloads from precomputed load-path."
+(let ((path load-path)
+	autoloads)
+(while path
+(if (file-exists-p (concat (car path)
+				 autoload-file-name))
+	  (setq autoloads (cons (concat (car path)
+					autoload-file-name)
+				autoloads)))
+(setq path (cdr path)))
+autoloads))
+(defun packages-list-autoloads (source-directory)
+"List autoload files in (what will be) the normal lisp search path.
+This function is used during build to find where the global symbol files so
+they can be perused for their useful information."
+(let ((files (directory-files (file-name-as-directory source-directory)
+				t ".*"))
+	file autolist)
+;; (print (prin1-to-string source-directory))
+;; (print (prin1-to-string files))
+(while (setq file (car-safe files))
+(if (and (file-directory-p file)
+	       (file-exists-p (concat (file-name-as-directory file)
+				      autoload-file-name)))
+	  (setq autolist (cons (concat (file-name-as-directory file)
+				       autoload-file-name)
+			       autolist)))
+(setq files (cdr files)))
+autolist))
+;; The following function cannot be called from a bare temacs
+(defun packages-new-autoloads ()
+"Return autoloads files that have been added or modified since XEmacs dump."
+(require 'loadhist)
+(let ((me (concat invocation-directory invocation-name))
+	(path load-path)
+	result dir)
+(while path
+(setq dir (file-truename (car path)))
+(let ((autoload-file (file-name-sans-extension (concat
+						      dir
+						      autoload-file-name))))
+	;; Check for:
+	;; 1.  An auto-autoload file that hasn't provided a feature (because
+	;;     it has been installed since XEmacs was dumped).
+	;; 2.  auto-autoload.el being newer than the executable
+	;; 3.  auto-autoload.elc being newer than the executable (the .el
+	;;     could be missing or compressed)
+	(when (or (and (null (file-provides autoload-file))
+		       (or (file-exists-p (concat autoload-file ".elc"))
+			   (file-exists-p (concat autoload-file ".el"))))
+		  (and (file-newer-than-file-p (concat autoload-file ".el") me)
+		       (setq autoload-file (concat autoload-file ".el")))
+		  (and (file-newer-than-file-p (concat autoload-file
+						       ".elc")
+					       me)
+		       (setq autoload-file (concat autoload-file ".elc"))))
+	  (push autoload-file result)))
+(setq path (cdr path)))
+result))
+;; The following function cannot be called from a bare temacs
+(defun packages-reload-autoloads ()
+"Reload new or updated auto-autoloads files.
+This is an extremely dangerous function to call after the user-init-files
+is run.  Don't call it or you'll be sorry."
+(let ((autoload-list (packages-new-autoloads)))
+(while autoload-list
+(let* ((autoload-file (car autoload-list))
+	     (feature (car-safe (file-provides autoload-file))))
+	(when feature
+	  ;; (message "(unload-feature %S)" feature)
+	  (unload-feature feature))
+	(condition-case nil
+	    (load autoload-file)
+	  (t nil)))
+(setq autoload-list (cdr autoload-list)))))
+;; Data-directory is really a list now.  Provide something to search it for
+;; directories.
+(defun locate-data-directory-list (name &optional dir-list)
+"Locate the matching list of directories in a search path DIR-LIST.
+If no DIR-LIST is supplied, it defaults to `data-directory-list'."
+(unless dir-list
+(setq dir-list data-directory-list))
+(let (found found-dir found-dir-list)
+(while dir-list
+(setq found (file-name-as-directory (concat (car dir-list) name))
+	    found-dir (file-directory-p found))
+(and found-dir
+	   (setq found-dir-list (cons found found-dir-list)))
+(setq dir-list (cdr dir-list)))
+(nreverse found-dir-list)))
+;; Data-directory is really a list now.  Provide something to search it for
+;; a directory.
+(defun locate-data-directory (name &optional dir-list)
+"Locate a directory in a search path DIR-LIST (a list of directories).
+If no DIR-LIST is supplied, it defaults to `data-directory-list'."
+(unless dir-list
+(setq dir-list data-directory-list))
+(let (found found-dir)
+(while (and (null found-dir) dir-list)
+(setq found (file-name-as-directory (concat (car dir-list) name))
+	    found-dir (file-directory-p found))
+(or found-dir
+	  (setq found nil))
+(setq dir-list (cdr dir-list)))
+found))
+;; Data-directory is really a list now.  Provide something to search it for
+;; files.
+(defun locate-data-file (name &optional dir-list)
+"Locate a file in a search path DIR-LIST (a list of directories).
+If no DIR-LIST is supplied, it defaults to `data-directory-list'.
+This function is basically a wrapper over `locate-file'."
+(locate-file name (or dir-list data-directory-list)))
+;; Path setup
+(defun packages-find-package-directories (roots base)
+"Find a set of package directories."
+;; make sure paths-find-version-directory and paths-find-site-directory
+;; don't both pick up version-independent directories ...
+(let ((version-directory (paths-find-version-directory roots base nil nil t))
+	(site-directory (paths-find-site-directory roots base)))
+(paths-uniq-append
+(and version-directory (list version-directory))
+(and site-directory (list site-directory)))))
+(defvar packages-special-base-regexp "^\\(etc\\|info\\|lisp\\|lib-src\\|bin\\|pkginfo\\)$"
+"Special subdirectories of packages.")
+(defvar packages-no-package-hierarchy-regexp
+(concat "\\(" paths-version-control-filename-regexp "\\)"
+	  "\\|"
+	  "\\(" packages-special-base-regexp "\\)")
+"Directories which can't be the roots of package hierarchies.")
+(defun packages-find-packages-in-directories (directories)
+"Find all packages underneath directories in DIRECTORIES."
+(paths-find-recursive-path directories
+			     packages-hierarchy-depth
+			     packages-no-package-hierarchy-regexp))
+(defun packages-split-path (path)
+"Split PATH at \"\", return pair with two components.
+The second component is shared with PATH."
+(let ((reverse-tail '())
+	(rest path))
+(while (and rest (null (string-equal "" (car rest))))
+(setq reverse-tail (cons (car rest) reverse-tail))
+(setq rest (cdr rest)))
+(if (null rest)
+	(cons path nil)
+(cons (nreverse reverse-tail) (cdr rest)))))
+(defun packages-split-package-path (package-path)
+"Split up PACKAGE-PATH into early, late and last components.
+The separation is by \"\" components.
+This returns (LIST EARLY-PACKAGES LATE-PACKAGES LAST-PACKAGES)."
+;; When in doubt, it's late
+(let* ((stuff (packages-split-path package-path))
+	 (early (and (cdr stuff) (car stuff)))
+	 (late+last (or (cdr stuff) (car stuff)))
+	 (stuff (packages-split-path late+last))
+	 (late (car stuff))
+	 (last (cdr stuff)))
+(list (packages-find-packages-in-directories early)
+	  (packages-find-packages-in-directories late)
+	  (packages-find-packages-in-directories last))))
+(defun packages-deconstruct (list consumer)
+"Deconstruct LIST and feed it to CONSUMER."
+(apply consumer list))
+(defun packages-find-packages-by-name (roots name)
+"Find a package hierarchy by its name."
+(packages-find-packages-in-directories
+(if (and (file-name-absolute-p name)
+	    (file-name-directory (expand-file-name name)))
+(list (file-name-as-directory (expand-file-name name)))
+(packages-find-package-directories roots name))))
+(defun packages-find-packages-at-time
+(roots package-locations time &optional default)
+"Find packages at given time.
+For the format of PACKAGE-LOCATIONS, see the global variable of the same name.
+TIME is either 'EARLY, 'LATE, or 'LAST.
+DEFAULT is a default list of packages."
+(or default
+(let ((packages '()))
+	(while package-locations
+	  (packages-deconstruct
+	   (car package-locations)
+	   #'(lambda (name a-time thunk)
+	       (if (and (eq time a-time)
+			(funcall thunk))
+		   (setq packages
+			 (nconc packages
+				(packages-find-packages-by-name roots name))))))
+	  (setq package-locations (cdr package-locations)))
+	packages)))
+(defun packages-find-packages (roots package-locations)
+"Find the packages."
+(let ((envvar-value (getenv "EMACSPACKAGEPATH")))
+(if envvar-value
+	(packages-split-package-path (paths-decode-directory-path envvar-value))
+(packages-deconstruct
+(packages-split-package-path configure-package-path)
+#'(lambda (configure-early-packages
+		  configure-late-packages
+		  configure-last-packages)
+	   (list (packages-find-packages-at-time roots package-locations 'early
+						 configure-early-packages)
+		 (packages-find-packages-at-time roots package-locations 'late
+						 configure-late-packages)
+		 (packages-find-packages-at-time roots package-locations 'last
+						 configure-last-packages)))))))
+(defun packages-find-package-library-path (packages suffixes)
+"Construct a path into a component of the packages hierarchy.
+PACKAGES is a list of package directories.
+SUFFIXES is a list of names of package subdirectories to look for."
+(let ((directories
+	 (apply
+	  #'nconc
+	  (mapcar #'(lambda (package)
+		      (mapcar #'(lambda (suffix)
+				  (file-name-as-directory (concat package suffix)))
+			      suffixes))
+		  packages))))
+(paths-directories-which-exist directories)))
+(defun packages-find-package-load-path (packages)
+"Construct the load-path component for packages.
+PACKAGES is a list of package directories."
+(paths-find-recursive-load-path
+(packages-find-package-library-path packages
+				       '("lisp"))
+packages-load-path-depth))
+(defun packages-find-package-exec-path (packages)
+"Construct the exec-path component for packages.
+PACKAGES is a list of package directories."
+(packages-find-package-library-path packages
+				      (list (paths-construct-path
+					     (list "bin" system-configuration))
+					    "lib-src")))
+(defun packages-find-package-info-path (packages)
+"Construct the info-path component for packages.
+PACKAGES is a list of package directories."
+(packages-find-package-library-path packages '("info")))
+(defun packages-find-package-data-path (packages)
+"Construct the data-path component for packages.
+PACKAGES is a list of package directories."
+(paths-find-recursive-load-path
+(packages-find-package-library-path packages
+				       '("etc"))
+packages-data-path-depth))
+;; Loading package initialization files
+(defun packages-load-package-lisps (package-load-path base)
+"Load all Lisp files of a certain name along a load path.
+BASE is the base name of the files."
+(mapcar #'(lambda (dir)
+	    (let ((file-name (expand-file-name base dir)))
+	      (condition-case error
+		  (load file-name t t)
+		(error
+		 (warn (format "Autoload error in: %s:\n\t%s"
+			       file-name
+			       (with-output-to-string
+				 (display-error error nil))))))))
+	package-load-path))
+(defun packages-load-package-auto-autoloads (package-load-path)
+"Load auto-autoload files along a load path."
+(packages-load-package-lisps package-load-path
+			       (file-name-sans-extension autoload-file-name)))
+(defun packages-handle-package-dumped-lisps (handle package-load-path)
+"Load dumped-lisp.el files along a load path.
+Call HANDLE on each file off definitions of PACKAGE-LISP there."
+(mapcar #'(lambda (dir)
+	    (let ((file-name (expand-file-name "dumped-lisp.el" dir)))
+	      (if (file-exists-p file-name)
+		  (let (package-lisp
+			;; 20.4 packages could set this
+			preloaded-file-list)
+		    (load file-name)
+		    ;; dumped-lisp.el could have set this ...
+		    (if package-lisp
+			(mapcar #'(lambda (base)
+				  (funcall handle base))
+			      package-lisp))))))
+	package-load-path))
+(defun packages-load-package-dumped-lisps (package-load-path)
+"Load dumped-lisp.el files along a load path.
+Also load files off PACKAGE-LISP definitions there"
+(packages-handle-package-dumped-lisps #'load package-load-path))
+(defun packages-collect-package-dumped-lisps (package-load-path)
+"Load dumped-lisp.el files along a load path.
+Return list of files off PACKAGE-LISP definitions there"
+(let ((*files* '()))
+(packages-handle-package-dumped-lisps
+#'(lambda (file)
+	 (setq *files* (cons file *files*)))
+package-load-path)
+(reverse *files*)))
+(provide 'packages)
+;;; packages.el ends here

Mercurial > hg > xemacs-beta

comparison lisp/packages.el @ 428:3ecd8885ac67 r21-2-22