diff options
Diffstat (limited to 'lisp/emacs-lisp/package.el')
| -rw-r--r-- | lisp/emacs-lisp/package.el | 1088 |
1 files changed, 519 insertions, 569 deletions
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 41b635bbe30..e5833703ad5 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -140,7 +140,6 @@ ;; installing it ;; - Interface with desktop.el so that restarting after an install ;; works properly -;; - Implement M-x package-upgrade, to upgrade any/all existing packages ;; - Use hierarchical layout. PKG/etc PKG/lisp PKG/info ;; ... except maybe lisp? ;; - It may be nice to have a macro that expands to the package's @@ -159,17 +158,12 @@ ;; - Allow optional package dependencies ;; then if we require 'bbdb', bbdb-specific lisp in lisp/bbdb ;; and just don't compile to add to load path ...? -;; - Have a list of archive URLs? [ maybe there's no point ] -;; - David Kastrup pointed out on the xemacs list that for GPL it -;; is friendlier to ship the source tree. We could "support" that -;; by just having a "src" subdir in the package. This isn't ideal -;; but it probably is not worth trying to support random source -;; tree layouts, build schemes, etc. ;; - Our treatment of the info path is somewhat bogus -;; - perhaps have an "unstable" tree in ELPA as well as a stable one ;;; Code: +(eval-when-compile (require 'cl-lib)) + (require 'tabulated-list) (defgroup package nil @@ -198,8 +192,7 @@ versions of all packages not specified by other elements. For an element (NAME VERSION), NAME is a package name (a symbol). VERSION should be t, a string, or nil. -If VERSION is t, all versions are loaded, though obsolete ones - will be put in `package-obsolete-alist' and not activated. +If VERSION is t, the most recent version is activated. If VERSION is a string, only that version is ever loaded. Any other version, even if newer, is silently ignored. Hence, the package is \"held\" at that version. @@ -262,11 +255,8 @@ Lower version numbers than this will probably be understood as well.") ;; We don't prime the cache since it tends to get out of date. (defvar package-archive-contents nil "Cache of the contents of the Emacs Lisp Package Archive. -This is an alist mapping package names (symbols) to package -descriptor vectors. These are like the vectors for `package-alist' -but have extra entries: one which is 'tar for tar packages and -'single for single-file packages, and one which is the name of -the archive from which it came.") +This is an alist mapping package names (symbols) to +`package-desc' structures.") (put 'package-archive-contents 'risky-local-variable t) (defcustom package-user-dir (locate-user-emacs-file "elpa") @@ -297,35 +287,92 @@ contrast, `package-user-dir' contains packages for personal use." :group 'package :version "24.1") -;; The value is precomputed in finder-inf.el, but don't load that -;; until it's needed (i.e. when `package-initialize' is called). +(defvar package--default-summary "No description available.") + +(cl-defstruct (package-desc + ;; Rename the default constructor from `make-package-desc'. + (:constructor package-desc-create) + ;; Has the same interface as the old `define-package', + ;; which is still used in the "foo-pkg.el" files. Extra + ;; options can be supported by adding additional keys. + (:constructor + package-desc-from-define + (name-string version-string &optional summary requirements + &key kind archive + &aux + (name (intern name-string)) + (version (version-to-list version-string)) + (reqs (mapcar #'(lambda (elt) + (list (car elt) + (version-to-list (cadr elt)))) + (if (eq 'quote (car requirements)) + (nth 1 requirements) + requirements)))))) + "Structure containing information about an individual package. + +Slots: + +`name' Name of the package, as a symbol. + +`version' Version of the package, as a version list. + +`summary' Short description of the package, typically taken from +the first line of the file. + +`reqs' Requirements of the package. A list of (PACKAGE +VERSION-LIST) naming the dependent package and the minimum +required version. + +`kind' The distribution format of the package. Currently, it is +either `single' or `tar'. + +`archive' The name of the archive (as a string) whence this +package came. + +`dir' The directory where the package is installed (if installed)." + name + version + (summary package--default-summary) + reqs + kind + archive + dir) + +;; Pseudo fields. +(defun package-desc-full-name (pkg-desc) + (format "%s-%s" + (package-desc-name pkg-desc) + (package-version-join (package-desc-version pkg-desc)))) + +(defun package-desc-suffix (pkg-desc) + (pcase (package-desc-kind pkg-desc) + (`single ".el") + (`tar ".tar") + (kind (error "Unknown package kind: %s" kind)))) + +;; Package descriptor format used in finder-inf.el and package--builtins. +(cl-defstruct (package--bi-desc + (:constructor package-make-builtin (version summary)) + (:type vector)) + version + reqs + summary) + (defvar package--builtins nil "Alist of built-in packages. The actual value is initialized by loading the library `finder-inf'; this is not done until it is needed, e.g. by the function `package-built-in-p'. -Each element has the form (PKG . DESC), where PKG is a package -name (a symbol) and DESC is a vector that describes the package. -The vector DESC has the form [VERSION-LIST REQS DOCSTRING]. - VERSION-LIST is a version list. - REQS is a list of packages required by the package, each - requirement having the form (NAME VL), where NAME is a string - and VL is a version list. - DOCSTRING is a brief description of the package.") +Each element has the form (PKG . PACKAGE-BI-DESC), where PKG is a package +name (a symbol) and DESC is a `package--bi-desc' structure.") (put 'package--builtins 'risky-local-variable t) (defvar package-alist nil "Alist of all packages available for activation. -Each element has the form (PKG . DESC), where PKG is a package -name (a symbol) and DESC is a vector that describes the package. - -The vector DESC has the form [VERSION-LIST REQS DOCSTRING]. - VERSION-LIST is a version list. - REQS is a list of packages required by the package, each - requirement having the form (NAME VL) where NAME is a string - and VL is a version list. - DOCSTRING is a brief description of the package. +Each element has the form (PKG . DESCS), where PKG is a package +name (a symbol) and DESCS is a non-empty list of `package-desc' structure, +sorted by decreasing versions. This variable is set automatically by `package-load-descriptor', called via `package-initialize'. To change which packages are @@ -333,15 +380,10 @@ loaded and/or activated, customize `package-load-list'.") (put 'package-alist 'risky-local-variable t) (defvar package-activated-list nil + ;; FIXME: This should implicitly include all builtin packages. "List of the names of currently activated packages.") (put 'package-activated-list 'risky-local-variable t) -(defvar package-obsolete-alist nil - "Representation of obsolete packages. -Like `package-alist', but maps package name to a second alist. -The inner alist is keyed by version.") -(put 'package-obsolete-alist 'risky-local-variable t) - (defun package-version-join (vlist) "Return the version string corresponding to the list VLIST. This is, approximately, the inverse of `version-to-list'. @@ -371,23 +413,18 @@ This is, approximately, the inverse of `version-to-list'. (pop str-list)) (apply 'concat (nreverse str-list))))) -(defun package-strip-version (dirname) - "Strip the version from a combined package name and version. -E.g., if given \"quux-23.0\", will return \"quux\"" - (if (string-match (concat "\\`" package-subdirectory-regexp "\\'") dirname) - (match-string 1 dirname))) - -(defun package-load-descriptor (dir package) - "Load the description file in directory DIR for package PACKAGE. -Here, PACKAGE is a string of the form NAME-VERSION, where NAME is -the package name and VERSION is its version." - (let* ((pkg-dir (expand-file-name package dir)) - (pkg-file (expand-file-name - (concat (package-strip-version package) "-pkg") - pkg-dir))) - (when (and (file-directory-p pkg-dir) - (file-exists-p (concat pkg-file ".el"))) - (load pkg-file nil t)))) +(defun package-load-descriptor (pkg-dir) + "Load the description file in directory PKG-DIR." + (let ((pkg-file (expand-file-name (package--description-file pkg-dir) + pkg-dir))) + (when (file-exists-p pkg-file) + (with-temp-buffer + (insert-file-contents pkg-file) + (goto-char (point-min)) + (let ((pkg-desc (package-process-define-package + (read (current-buffer)) pkg-file))) + (setf (package-desc-dir pkg-desc) pkg-dir) + pkg-desc))))) (defun package-load-all-descriptors () "Load descriptors for installed Emacs Lisp packages. @@ -397,76 +434,35 @@ controls which package subdirectories may be loaded. In each valid package subdirectory, this function loads the description file containing a call to `define-package', which -updates `package-alist' and `package-obsolete-alist'." - (let ((regexp (concat "\\`" package-subdirectory-regexp "\\'"))) - (dolist (dir (cons package-user-dir package-directory-list)) - (when (file-directory-p dir) - (dolist (subdir (directory-files dir)) - (when (string-match regexp subdir) - (package-maybe-load-descriptor (match-string 1 subdir) - (match-string 2 subdir) - dir))))))) - -(defun package-maybe-load-descriptor (name version dir) - "Maybe load a specific package from directory DIR. -NAME and VERSION are the package's name and version strings. -This function checks `package-load-list', before actually loading -the package by calling `package-load-descriptor'." - (let ((force (assq (intern name) package-load-list)) - (subdir (concat name "-" version))) - (and (file-directory-p (expand-file-name subdir dir)) - ;; Check `package-load-list': - (cond ((null force) - (memq 'all package-load-list)) - ((null (setq force (cadr force))) - nil) ; disabled - ((eq force t) - t) - ((stringp force) ; held - (version-list-= (version-to-list version) - (version-to-list force))) - (t - (error "Invalid element in `package-load-list'"))) - ;; Actually load the descriptor: - (package-load-descriptor dir subdir)))) - -(defsubst package-desc-vers (desc) - "Extract version from a package description vector." - (aref desc 0)) - -(defsubst package-desc-reqs (desc) - "Extract requirements from a package description vector." - (aref desc 1)) - -(defsubst package-desc-doc (desc) - "Extract doc string from a package description vector." - (aref desc 2)) - -(defsubst package-desc-kind (desc) - "Extract the kind of download from an archive package description vector." - (aref desc 3)) - -(defun package--dir (name version) - "Return the directory where a package is installed, or nil if none. -NAME and VERSION are both strings." - (let* ((subdir (concat name "-" version)) - (dir-list (cons package-user-dir package-directory-list)) - pkg-dir) - (while dir-list - (let ((subdir-full (expand-file-name subdir (car dir-list)))) - (if (file-directory-p subdir-full) - (setq pkg-dir subdir-full - dir-list nil) - (setq dir-list (cdr dir-list))))) - pkg-dir)) - -(defun package-activate-1 (package pkg-vec) - (let* ((name (symbol-name package)) - (version-str (package-version-join (package-desc-vers pkg-vec))) - (pkg-dir (package--dir name version-str))) +updates `package-alist'." + (dolist (dir (cons package-user-dir package-directory-list)) + (when (file-directory-p dir) + (dolist (subdir (directory-files dir)) + (let ((pkg-dir (expand-file-name subdir dir))) + (when (file-directory-p pkg-dir) + (package-load-descriptor pkg-dir))))))) + +(defun package-disabled-p (pkg-name version) + "Return whether PKG-NAME at VERSION can be activated. +The decision is made according to `package-load-list'. +Return nil if the package can be activated. +Return t if the package is completely disabled. +Return the max version (as a string) if the package is held at a lower version." + (let ((force (assq pkg-name package-load-list))) + (cond ((null force) (not (memq 'all package-load-list))) + ((null (setq force (cadr force))) t) ; disabled + ((eq force t) nil) + ((stringp force) ; held + (unless (version-list-= version (version-to-list force)) + force)) + (t (error "Invalid element in `package-load-list'"))))) + +(defun package-activate-1 (pkg-desc) + (let* ((name (package-desc-name pkg-desc)) + (pkg-dir (package-desc-dir pkg-desc))) (unless pkg-dir - (error "Internal error: unable to find directory for `%s-%s'" - name version-str)) + (error "Internal error: unable to find directory for `%s'" + (package-desc-full-name pkg-desc))) ;; Add info node. (when (file-exists-p (expand-file-name "dir" pkg-dir)) ;; FIXME: not the friendliest, but simple. @@ -475,8 +471,8 @@ NAME and VERSION are both strings." (push pkg-dir Info-directory-list)) ;; Add to load path, add autoloads, and activate the package. (push pkg-dir load-path) - (load (expand-file-name (concat name "-autoloads") pkg-dir) nil t) - (push package package-activated-list) + (load (expand-file-name (format "%s-autoloads" name) pkg-dir) nil t) + (push name package-activated-list) ;; Don't return nil. t)) @@ -484,66 +480,60 @@ NAME and VERSION are both strings." "Return true if PACKAGE is built-in to Emacs. Optional arg MIN-VERSION, if non-nil, should be a version list specifying the minimum acceptable version." - (require 'finder-inf nil t) ; For `package--builtins'. - (if (eq package 'emacs) - (version-list-<= min-version (version-to-list emacs-version)) - (let ((elt (assq package package--builtins))) - (and elt (version-list-<= min-version - (package-desc-vers (cdr elt))))))) + (let ((bi (assq package package--builtin-versions))) + (cond + (bi (version-list-<= min-version (cdr bi))) + (min-version nil) + (t + (require 'finder-inf nil t) ; For `package--builtins'. + (assq package package--builtins))))) + +(defun package--from-builtin (bi-desc) + (package-desc-create :name (pop bi-desc) + :version (package--bi-desc-version bi-desc) + :summary (package--bi-desc-summary bi-desc))) ;; This function goes ahead and activates a newer version of a package ;; if an older one was already activated. This is not ideal; we'd at ;; least need to check to see if the package has actually been loaded, ;; and not merely activated. -(defun package-activate (package min-version) - "Activate package PACKAGE, of version MIN-VERSION or newer. -MIN-VERSION should be a version list. -If PACKAGE has any dependencies, recursively activate them. -Return nil if the package could not be activated." - (let ((pkg-vec (cdr (assq package package-alist))) - available-version found) +(defun package-activate (package &optional force) + "Activate package PACKAGE. +If FORCE is true, (re-)activate it if it's already activated." + (let ((pkg-descs (cdr (assq package package-alist)))) ;; Check if PACKAGE is available in `package-alist'. - (when pkg-vec - (setq available-version (package-desc-vers pkg-vec) - found (version-list-<= min-version available-version))) + (while + (when pkg-descs + (let ((available-version (package-desc-version (car pkg-descs)))) + (or (package-disabled-p package available-version) + ;; Prefer a builtin package. + (package-built-in-p package available-version)))) + (setq pkg-descs (cdr pkg-descs))) (cond ;; If no such package is found, maybe it's built-in. - ((null found) - (package-built-in-p package min-version)) + ((null pkg-descs) + (package-built-in-p package)) ;; If the package is already activated, just return t. - ((memq package package-activated-list) + ((and (memq package package-activated-list) (not force)) t) ;; Otherwise, proceed with activation. (t - (let ((fail (catch 'dep-failure - ;; Activate its dependencies recursively. - (dolist (req (package-desc-reqs pkg-vec)) - (unless (package-activate (car req) (cadr req)) - (throw 'dep-failure req)))))) + (let* ((pkg-vec (car pkg-descs)) + (fail (catch 'dep-failure + ;; Activate its dependencies recursively. + (dolist (req (package-desc-reqs pkg-vec)) + (unless (package-activate (car req) (cadr req)) + (throw 'dep-failure req)))))) (if fail (warn "Unable to activate package `%s'. Required package `%s-%s' is unavailable" package (car fail) (package-version-join (cadr fail))) ;; If all goes well, activate the package itself. - (package-activate-1 package pkg-vec))))))) - -(defun package-mark-obsolete (package pkg-vec) - "Put package on the obsolete list, if not already there." - (let ((elt (assq package package-obsolete-alist))) - (if elt - ;; If this obsolete version does not exist in the list, update - ;; it the list. - (unless (assoc (package-desc-vers pkg-vec) (cdr elt)) - (setcdr elt (cons (cons (package-desc-vers pkg-vec) pkg-vec) - (cdr elt)))) - ;; Make a new association. - (push (cons package (list (cons (package-desc-vers pkg-vec) - pkg-vec))) - package-obsolete-alist)))) - -(defun define-package (name-string version-string - &optional docstring requirements - &rest _extra-properties) + (package-activate-1 pkg-vec))))))) + +(defun define-package (_name-string _version-string + &optional _docstring _requirements + &rest _extra-properties) "Define a new package. NAME-STRING is the name of the package, as a string. VERSION-STRING is the version of the package, as a string. @@ -553,35 +543,30 @@ REQUIREMENTS is a list of dependencies on other packages. where OTHER-VERSION is a string. EXTRA-PROPERTIES is currently unused." - (let* ((name (intern name-string)) - (version (version-to-list version-string)) - (new-pkg-desc - (cons name - (vector version - (mapcar - (lambda (elt) - (list (car elt) - (version-to-list (car (cdr elt))))) - requirements) - docstring))) - (old-pkg (assq name package-alist))) - (cond - ;; If there's no old package, just add this to `package-alist'. - ((null old-pkg) - (push new-pkg-desc package-alist)) - ((version-list-< (package-desc-vers (cdr old-pkg)) version) - ;; Remove the old package and declare it obsolete. - (package-mark-obsolete name (cdr old-pkg)) - (setq package-alist (cons new-pkg-desc - (delq old-pkg package-alist)))) - ;; You can have two packages with the same version, e.g. one in - ;; the system package directory and one in your private - ;; directory. We just let the first one win. - ((not (version-list-= (package-desc-vers (cdr old-pkg)) version)) - ;; The package is born obsolete. - (package-mark-obsolete name (cdr new-pkg-desc)))))) - -;; From Emacs 22. + ;; FIXME: Placeholder! Should we keep it? + (error "Don't call me!")) + +(defun package-process-define-package (exp origin) + (unless (eq (car-safe exp) 'define-package) + (error "Can't find define-package in %s" origin)) + (let* ((new-pkg-desc (apply #'package-desc-from-define (cdr exp))) + (name (package-desc-name new-pkg-desc)) + (version (package-desc-version new-pkg-desc)) + (old-pkgs (assq name package-alist))) + (if (null old-pkgs) + ;; If there's no old package, just add this to `package-alist'. + (push (list name new-pkg-desc) package-alist) + ;; If there is, insert the new package at the right place in the list. + (while old-pkgs + (cond + ((null (cdr old-pkgs)) (push new-pkg-desc (cdr old-pkgs))) + ((version-list-< (package-desc-version (cadr old-pkgs)) version) + (push new-pkg-desc (cdr old-pkgs)) + (setq old-pkgs nil))) + (setq old-pkgs (cdr old-pkgs)))) + new-pkg-desc)) + +;; From Emacs 22, but changed so it adds to load-path. (defun package-autoload-ensure-default-file (file) "Make sure that the autoload file FILE exists and if not create it." (unless (file-exists-p file) @@ -603,14 +588,15 @@ EXTRA-PROPERTIES is currently unused." (defun package-generate-autoloads (name pkg-dir) (require 'autoload) ;Load before we let-bind generated-autoload-file! - (let* ((auto-name (concat name "-autoloads.el")) + (let* ((auto-name (format "%s-autoloads.el" name)) ;;(ignore-name (concat name "-pkg.el")) (generated-autoload-file (expand-file-name auto-name pkg-dir)) (version-control 'never)) (package-autoload-ensure-default-file generated-autoload-file) (update-directory-autoloads pkg-dir) (let ((buf (find-buffer-visiting generated-autoload-file))) - (when buf (kill-buffer buf))))) + (when buf (kill-buffer buf))) + auto-name)) (defvar tar-parse-info) (declare-function tar-untar-buffer "tar-mode" ()) @@ -636,66 +622,79 @@ untar into a directory named DIR; otherwise, signal an error." (error "Package does not untar cleanly into directory %s/" dir))))) (tar-untar-buffer)) -(defun package-unpack (package version) - (let* ((name (symbol-name package)) - (dirname (concat name "-" version)) +(defun package-generate-description-file (pkg-desc pkg-dir) + "Create the foo-pkg.el file for single-file packages." + (let* ((name (package-desc-name pkg-desc)) + (pkg-file (expand-file-name (package--description-file pkg-dir) + pkg-dir))) + (let ((print-level nil) + (print-quoted t) + (print-length nil)) + (write-region + (concat + (prin1-to-string + (list 'define-package + (symbol-name name) + (package-version-join (package-desc-version pkg-desc)) + (package-desc-summary pkg-desc) + (let ((requires (package-desc-reqs pkg-desc))) + (list 'quote + ;; Turn version lists into string form. + (mapcar + (lambda (elt) + (list (car elt) + (package-version-join (cadr elt)))) + requires))))) + "\n") + nil + pkg-file)))) + +(defun package-unpack (pkg-desc) + "Install the contents of the current buffer as a package." + (let* ((name (package-desc-name pkg-desc)) + (dirname (package-desc-full-name pkg-desc)) (pkg-dir (expand-file-name dirname package-user-dir))) - (make-directory package-user-dir t) - ;; FIXME: should we delete PKG-DIR if it exists? - (let* ((default-directory (file-name-as-directory package-user-dir))) - (package-untar-buffer dirname) - (package--make-autoloads-and-compile name pkg-dir)))) - -(defun package--make-autoloads-and-compile (name pkg-dir) - "Generate autoloads and do byte-compilation for package named NAME. -PKG-DIR is the name of the package directory." - (package-generate-autoloads name pkg-dir) - (let ((load-path (cons pkg-dir load-path))) - ;; We must load the autoloads file before byte compiling, in - ;; case there are magic cookies to set up non-trivial paths. - (load (expand-file-name (concat name "-autoloads") pkg-dir) nil t) - (byte-recompile-directory pkg-dir 0 t))) + (pcase (package-desc-kind pkg-desc) + (`tar + (make-directory package-user-dir t) + ;; FIXME: should we delete PKG-DIR if it exists? + (let* ((default-directory (file-name-as-directory package-user-dir))) + (package-untar-buffer dirname))) + (`single + (let ((el-file (expand-file-name (format "%s.el" name) pkg-dir))) + (make-directory pkg-dir t) + (package--write-file-no-coding el-file))) + (kind (error "Unknown package kind: %S" kind))) + (package--make-autoloads-and-stuff pkg-desc pkg-dir) + ;; Update package-alist. + (let ((new-desc (package-load-descriptor pkg-dir))) + ;; FIXME: Check that `new-desc' matches `desc'! + ;; FIXME: Compilation should be done as a separate, optional, step. + ;; E.g. for multi-package installs, we should first install all packages + ;; and then compile them. + (package--compile new-desc)) + ;; Try to activate it. + (package-activate name 'force) + pkg-dir)) + +(defun package--make-autoloads-and-stuff (pkg-desc pkg-dir) + "Generate autoloads, description file, etc.. for PKG-DESC installed at PKG-DIR." + (package-generate-autoloads (package-desc-name pkg-desc) pkg-dir) + (let ((desc-file (package--description-file pkg-dir))) + (unless (file-exists-p desc-file) + (package-generate-description-file pkg-desc pkg-dir))) + ;; FIXME: Create foo.info and dir file from foo.texi? + ) + +(defun package--compile (pkg-desc) + "Byte-compile installed package PKG-DESC." + (package-activate-1 pkg-desc) + (byte-recompile-directory (package-desc-dir pkg-desc) 0 t)) (defun package--write-file-no-coding (file-name) (let ((buffer-file-coding-system 'no-conversion)) (write-region (point-min) (point-max) file-name))) -(defun package-unpack-single (file-name version desc requires) - "Install the contents of the current buffer as a package." - ;; Special case "package". - (if (string= file-name "package") - (package--write-file-no-coding - (expand-file-name (concat file-name ".el") package-user-dir)) - (let* ((pkg-dir (expand-file-name (concat file-name "-" - (package-version-join - (version-to-list version))) - package-user-dir)) - (el-file (expand-file-name (concat file-name ".el") pkg-dir)) - (pkg-file (expand-file-name (concat file-name "-pkg.el") pkg-dir))) - (make-directory pkg-dir t) - (package--write-file-no-coding el-file) - (let ((print-level nil) - (print-length nil)) - (write-region - (concat - (prin1-to-string - (list 'define-package - file-name - version - desc - (list 'quote - ;; Turn version lists into string form. - (mapcar - (lambda (elt) - (list (car elt) - (package-version-join (cadr elt)))) - requires)))) - "\n") - nil - pkg-file - nil nil nil 'excl)) - (package--make-autoloads-and-compile file-name pkg-dir)))) - (defmacro package--with-work-buffer (location file &rest body) "Run BODY in a buffer containing the contents of FILE at LOCATION. LOCATION is the base location of a package archive, and should be @@ -705,6 +704,7 @@ FILE is the name of a file relative to that base location. This macro retrieves FILE from LOCATION into a temporary buffer, and evaluates BODY while that buffer is current. This work buffer is killed afterwards. Return the last value in BODY." + (declare (indent 2) (debug t)) `(let* ((http (string-match "\\`https?:" ,location)) (buffer (if http @@ -735,23 +735,15 @@ It will move point to somewhere in the headers." (let ((response (url-http-parse-response))) (when (or (< response 200) (>= response 300)) (error "Error during download request:%s" - (buffer-substring-no-properties (point) (progn - (end-of-line) - (point))))))) - -(defun package-download-single (name version desc requires) - "Download and install a single-file package." - (let ((location (package-archive-base name)) - (file (concat (symbol-name name) "-" version ".el"))) - (package--with-work-buffer location file - (package-unpack-single (symbol-name name) version desc requires)))) + (buffer-substring-no-properties (point) (line-end-position)))))) -(defun package-download-tar (name version) +(defun package-install-from-archive (pkg-desc) "Download and install a tar package." - (let ((location (package-archive-base name)) - (file (concat (symbol-name name) "-" version ".tar"))) + (let ((location (package-archive-base pkg-desc)) + (file (concat (package-desc-full-name pkg-desc) + (package-desc-suffix pkg-desc)))) (package--with-work-buffer location file - (package-unpack name version)))) + (package-unpack pkg-desc)))) (defvar package--initialized nil) @@ -759,12 +751,13 @@ It will move point to somewhere in the headers." "Return true if PACKAGE, of MIN-VERSION or newer, is installed. MIN-VERSION should be a version list." (unless package--initialized (error "package.el is not yet initialized!")) - (let ((pkg-desc (assq package package-alist))) - (if pkg-desc - (version-list-<= min-version - (package-desc-vers (cdr pkg-desc))) - ;; Also check built-in packages. - (package-built-in-p package min-version)))) + (or + (let ((pkg-descs (cdr (assq package package-alist)))) + (and pkg-descs + (version-list-<= min-version + (package-desc-version (car pkg-descs))))) + ;; Also check built-in packages. + (package-built-in-p package min-version))) (defun package-compute-transaction (package-list requirements) "Return a list of packages to be installed, including PACKAGE-LIST. @@ -785,37 +778,33 @@ not included in this list." (unless (package-installed-p next-pkg next-version) ;; A package is required, but not installed. It might also be ;; blocked via `package-load-list'. - (let ((pkg-desc (assq next-pkg package-archive-contents)) - hold) - (when (setq hold (assq next-pkg package-load-list)) - (setq hold (cadr hold)) - (cond ((eq hold t)) - ((eq hold nil) - (error "Required package '%s' is disabled" - (symbol-name next-pkg))) - ((null (stringp hold)) - (error "Invalid element in `package-load-list'")) - ((version-list-< (version-to-list hold) next-version) - (error "Package `%s' held at version %s, \ + (let ((pkg-desc (cdr (assq next-pkg package-archive-contents))) + ;; FIXME: package-disabled-p needs to use a <= test! + (disabled (package-disabled-p next-pkg next-version))) + (when disabled + (if (stringp disabled) + (error "Package `%s' held at version %s, \ but version %s required" - (symbol-name next-pkg) hold - (package-version-join next-version))))) + (symbol-name next-pkg) disabled + (package-version-join next-version)) + (error "Required package '%s' is disabled" + (symbol-name next-pkg)))) (unless pkg-desc (error "Package `%s-%s' is unavailable" (symbol-name next-pkg) (package-version-join next-version))) (unless (version-list-<= next-version - (package-desc-vers (cdr pkg-desc))) + (package-desc-version pkg-desc)) (error "Need package `%s-%s', but only %s is available" (symbol-name next-pkg) (package-version-join next-version) - (package-version-join (package-desc-vers (cdr pkg-desc))))) + (package-version-join (package-desc-version pkg-desc)))) ;; Move to front, so it gets installed early enough (bug#14082). (setq package-list (cons next-pkg (delq next-pkg package-list))) (setq package-list (package-compute-transaction package-list (package-desc-reqs - (cdr pkg-desc)))))))) + pkg-desc))))))) package-list) (defun package-read-from-string (str) @@ -860,35 +849,58 @@ If successful, set the variable `package-archive-contents'. If the archive version is too new, signal an error." ;; Version 1 of 'archive-contents' is identical to our internal ;; representation. - (let* ((dir (concat "archives/" archive)) - (contents-file (concat dir "/archive-contents")) - contents) - (when (setq contents (package--read-archive-file contents-file)) + (let* ((contents-file (format "archives/%s/archive-contents" archive)) + (contents (package--read-archive-file contents-file))) + (when contents (dolist (package contents) (package--add-to-archive-contents package archive))))) +;; Package descriptor objects used inside the "archive-contents" file. +;; Changing this defstruct implies changing the format of the +;; "archive-contents" files. +(cl-defstruct (package--ac-desc + (:constructor package-make-ac-desc (version reqs summary kind)) + (:copier nil) + (:type vector)) + version reqs summary kind) + (defun package--add-to-archive-contents (package archive) "Add the PACKAGE from the given ARCHIVE if necessary. -Also, add the originating archive to the end of the package vector." - (let* ((name (car package)) - (version (package-desc-vers (cdr package))) - (entry (cons name - (vconcat (cdr package) (vector archive)))) +PACKAGE should have the form (NAME . PACKAGE--AC-DESC). +Also, add the originating archive to the `package-desc' structure." + (let* ((name (car package)) + (version (package--ac-desc-version (cdr package))) + (pkg-desc + (package-desc-create + :name name + :version version + :reqs (package--ac-desc-reqs (cdr package)) + :summary (package--ac-desc-summary (cdr package)) + :kind (package--ac-desc-kind (cdr package)) + :archive archive)) + (entry (cons name pkg-desc)) (existing-package (assq name package-archive-contents)) (pinned-to-archive (assoc name package-pinned-packages))) - (cond ((and pinned-to-archive - ;; If pinned to another archive, skip entirely. - (not (equal (cdr pinned-to-archive) archive))) - nil) - ((not existing-package) - (add-to-list 'package-archive-contents entry)) - ((version-list-< (package-desc-vers (cdr existing-package)) - version) - ;; Replace the entry with this one. - (setq package-archive-contents - (cons entry - (delq existing-package - package-archive-contents))))))) + (cond + ;; Skip entirely if pinned to another archive or if no more recent + ;; than what we already have installed. + ((or (and pinned-to-archive + (not (equal (cdr pinned-to-archive) archive))) + (let ((bi (assq name package--builtin-versions))) + (and bi (version-list-<= version (cdr bi)))) + (let ((ins (cdr (assq name package-alist)))) + (and ins (version-list-<= version + (package-desc-version (car ins)))))) + nil) + ((not existing-package) + (push entry package-archive-contents)) + ((version-list-< (package-desc-version (cdr existing-package)) + version) + ;; Replace the entry with this one. + (setq package-archive-contents + (cons entry + (delq existing-package + package-archive-contents))))))) (defun package-download-transaction (package-list) "Download and install all the packages in PACKAGE-LIST. @@ -896,35 +908,16 @@ PACKAGE-LIST should be a list of package names (symbols). This function assumes that all package requirements in PACKAGE-LIST are satisfied, i.e. that PACKAGE-LIST is computed using `package-compute-transaction'." + ;; FIXME: make package-list a list of pkg-desc. (dolist (elt package-list) - (let* ((desc (cdr (assq elt package-archive-contents))) - ;; As an exception, if package is "held" in - ;; `package-load-list', download the held version. - (hold (cadr (assq elt package-load-list))) - (v-string (or (and (stringp hold) hold) - (package-version-join (package-desc-vers desc)))) - (kind (package-desc-kind desc))) - (cond - ((eq kind 'tar) - (package-download-tar elt v-string)) - ((eq kind 'single) - (package-download-single elt v-string - (package-desc-doc desc) - (package-desc-reqs desc))) - (t - (error "Unknown package kind: %s" (symbol-name kind)))) - ;; If package A depends on package B, then A may `require' B - ;; during byte compilation. So we need to activate B before - ;; unpacking A. - (package-maybe-load-descriptor (symbol-name elt) v-string - package-user-dir) - (package-activate elt (version-to-list v-string))))) + (let ((desc (cdr (assq elt package-archive-contents)))) + (package-install-from-archive desc)))) ;;;###autoload -(defun package-install (name) - "Install the package named NAME. -NAME should be the name of one of the available packages in an -archive in `package-archives'. Interactively, prompt for NAME." +(defun package-install (pkg-desc) + "Install the package PKG-DESC. +PKG-DESC should be one of the available packages in an +archive in `package-archives'. Interactively, prompt for its name." (interactive (progn ;; Initialize the package system to get the list of package @@ -933,20 +926,22 @@ archive in `package-archives'. Interactively, prompt for NAME." (package-initialize t)) (unless package-archive-contents (package-refresh-contents)) - (list (intern (completing-read - "Install package: " - (mapcar (lambda (elt) - (cons (symbol-name (car elt)) - nil)) - package-archive-contents) - nil t))))) - (let ((pkg-desc (assq name package-archive-contents))) - (unless pkg-desc - (error "Package `%s' is not available for installation" - (symbol-name name))) - (package-download-transaction - (package-compute-transaction (list name) - (package-desc-reqs (cdr pkg-desc)))))) + (let* ((name (intern (completing-read + "Install package: " + (mapcar (lambda (elt) + (cons (symbol-name (car elt)) + nil)) + package-archive-contents) + nil t))) + (pkg-desc (cdr (assq name package-archive-contents)))) + (unless pkg-desc + (error "Package `%s' is not available for installation" + name)) + (list pkg-desc)))) + (package-download-transaction + ;; FIXME: Use (list pkg-desc) instead of just the name. + (package-compute-transaction (list (package-desc-name pkg-desc)) + (package-desc-reqs pkg-desc)))) (defun package-strip-rcs-id (str) "Strip RCS version ID from the version string STR. @@ -961,17 +956,7 @@ Otherwise return nil." (error nil)))) (defun package-buffer-info () - "Return a vector describing the package in the current buffer. -The vector has the form - - [FILENAME REQUIRES DESCRIPTION VERSION COMMENTARY] - -FILENAME is the file name, a string, sans the \".el\" extension. -REQUIRES is a list of requirements, each requirement having the - form (NAME VER); NAME is a string and VER is a version list. -DESCRIPTION is the package description, a string. -VERSION is the version, a string. -COMMENTARY is the commentary section, a string, or nil if none. + "Return a `package-desc' describing the package in the current buffer. If the buffer does not contain a conforming package, signal an error. If there is a package, narrow the buffer to the file's @@ -990,104 +975,64 @@ boundaries." (require 'lisp-mnt) ;; Use some headers we've invented to drive the process. (let* ((requires-str (lm-header "package-requires")) - (requires (if requires-str - (package-read-from-string requires-str))) ;; Prefer Package-Version; if defined, the package author ;; probably wants us to use it. Otherwise try Version. (pkg-version (or (package-strip-rcs-id (lm-header "package-version")) - (package-strip-rcs-id (lm-header "version")))) - (commentary (lm-commentary))) + (package-strip-rcs-id (lm-header "version"))))) (unless pkg-version (error "Package lacks a \"Version\" or \"Package-Version\" header")) - ;; Turn string version numbers into list form. - (setq requires - (mapcar - (lambda (elt) - (list (car elt) - (version-to-list (car (cdr elt))))) - requires)) - (vector file-name requires desc pkg-version commentary)))) - -(defun package-tar-file-info (file) + (package-desc-from-define + file-name pkg-version desc + (if requires-str (package-read-from-string requires-str)) + :kind 'single)))) + +(declare-function tar-get-file-descriptor "tar-mode" (file)) +(declare-function tar--extract "tar-mode" (descriptor)) + +(defun package-tar-file-info () "Find package information for a tar file. -FILE is the name of the tar file to examine. -The return result is a vector like `package-buffer-info'." - (let ((default-directory (file-name-directory file)) - (file (file-name-nondirectory file))) - (unless (string-match (concat "\\`" package-subdirectory-regexp "\\.tar\\'") - file) - (error "Invalid package name `%s'" file)) - (let* ((pkg-name (match-string-no-properties 1 file)) - (pkg-version (match-string-no-properties 2 file)) - ;; Extract the package descriptor. - (pkg-def-contents (shell-command-to-string - ;; Requires GNU tar. - (concat "tar -xOf " file " " - - pkg-name "-" pkg-version "/" - pkg-name "-pkg.el"))) - (pkg-def-parsed (package-read-from-string pkg-def-contents))) - (unless (eq (car pkg-def-parsed) 'define-package) - (error "No `define-package' sexp is present in `%s-pkg.el'" pkg-name)) - (let ((name-str (nth 1 pkg-def-parsed)) - (version-string (nth 2 pkg-def-parsed)) - (docstring (nth 3 pkg-def-parsed)) - (requires (nth 4 pkg-def-parsed)) - (readme (shell-command-to-string - ;; Requires GNU tar. - (concat "tar -xOf " file " " - pkg-name "-" pkg-version "/README")))) - (unless (equal pkg-version version-string) - (error "Package has inconsistent versions")) - (unless (equal pkg-name name-str) - (error "Package has inconsistent names")) - ;; Kind of a hack. - (if (string-match ": Not found in archive" readme) - (setq readme nil)) - ;; Turn string version numbers into list form. - (if (eq (car requires) 'quote) - (setq requires (car (cdr requires)))) - (setq requires - (mapcar (lambda (elt) - (list (car elt) - (version-to-list (cadr elt)))) - requires)) - (vector pkg-name requires docstring version-string readme))))) +The return result is a `package-desc'." + (cl-assert (derived-mode-p 'tar-mode)) + (let* ((dir-name (file-name-directory + (tar-header-name (car tar-parse-info)))) + (desc-file (package--description-file dir-name)) + (tar-desc (tar-get-file-descriptor (concat dir-name desc-file)))) + (unless tar-desc + (error "No package descriptor file found")) + (with-current-buffer (tar--extract tar-desc) + (goto-char (point-min)) + (unwind-protect + (let* ((pkg-def-parsed (read (current-buffer))) + (pkg-desc + (if (not (eq (car pkg-def-parsed) 'define-package)) + (error "Can't find define-package in %s" + (tar-header-name tar-desc)) + (apply #'package-desc-from-define + (append (cdr pkg-def-parsed)))))) + (setf (package-desc-kind pkg-desc) 'tar) + pkg-desc) + (kill-buffer (current-buffer)))))) + ;;;###autoload -(defun package-install-from-buffer (pkg-info type) +(defun package-install-from-buffer () "Install a package from the current buffer. -When called interactively, the current buffer is assumed to be a -single .el file that follows the packaging guidelines; see info -node `(elisp)Packaging'. - -When called from Lisp, PKG-INFO is a vector describing the -information, of the type returned by `package-buffer-info'; and -TYPE is the package type (either `single' or `tar')." - (interactive (list (package-buffer-info) 'single)) - (save-excursion - (save-restriction - (let* ((file-name (aref pkg-info 0)) - (requires (aref pkg-info 1)) - (desc (if (string= (aref pkg-info 2) "") - "No description available." - (aref pkg-info 2))) - (pkg-version (aref pkg-info 3))) - ;; Download and install the dependencies. - (let ((transaction (package-compute-transaction nil requires))) - (package-download-transaction transaction)) - ;; Install the package itself. - (cond - ((eq type 'single) - (package-unpack-single file-name pkg-version desc requires)) - ((eq type 'tar) - (package-unpack (intern file-name) pkg-version)) - (t - (error "Unknown type: %s" (symbol-name type)))) - ;; Try to activate it. - (package-initialize))))) +The current buffer is assumed to be a single .el or .tar file that follows the +packaging guidelines; see info node `(elisp)Packaging'. +Downloads and installs required packages as needed." + (interactive) + (let ((pkg-desc (if (derived-mode-p 'tar-mode) + (package-tar-file-info) + (package-buffer-info)))) + ;; Download and install the dependencies. + (let* ((requires (package-desc-reqs pkg-desc)) + (transaction (package-compute-transaction nil requires))) + (package-download-transaction transaction)) + ;; Install the package itself. + (package-unpack pkg-desc) + pkg-desc)) ;;;###autoload (defun package-install-file (file) @@ -1096,37 +1041,32 @@ The file can either be a tar file or an Emacs Lisp file." (interactive "fPackage file name: ") (with-temp-buffer (insert-file-contents-literally file) - (cond - ((string-match "\\.el$" file) - (package-install-from-buffer (package-buffer-info) 'single)) - ((string-match "\\.tar$" file) - (package-install-from-buffer (package-tar-file-info file) 'tar)) - (t (error "Unrecognized extension `%s'" (file-name-extension file)))))) - -(defun package-delete (name version) - (let ((dir (package--dir name version))) + (when (string-match "\\.tar\\'" file) (tar-mode)) + (package-install-from-buffer))) + +(defun package-delete (pkg-desc) + (let ((dir (package-desc-dir pkg-desc))) (if (string-equal (file-name-directory dir) (file-name-as-directory (expand-file-name package-user-dir))) (progn (delete-directory dir t t) - (message "Package `%s-%s' deleted." name version)) + (message "Package `%s' deleted." (package-desc-full-name pkg-desc))) ;; Don't delete "system" packages - (error "Package `%s-%s' is a system package, not deleting" - name version)))) + (error "Package `%s' is a system package, not deleting" + (package-desc-full-name pkg-desc))))) -(defun package-archive-base (name) +(defun package-archive-base (desc) "Return the archive containing the package NAME." - (let ((desc (cdr (assq (intern-soft name) package-archive-contents)))) - (cdr (assoc (aref desc (- (length desc) 1)) package-archives)))) + (cdr (assoc (package-desc-archive desc) package-archives))) (defun package--download-one-archive (archive file) "Retrieve an archive file FILE from ARCHIVE, and cache it. ARCHIVE should be a cons cell of the form (NAME . LOCATION), similar to an entry in `package-alist'. Save the cached copy to \"archives/NAME/archive-contents\" in `package-user-dir'." - (let* ((dir (expand-file-name "archives" package-user-dir)) - (dir (expand-file-name (car archive) dir))) + (let* ((dir (expand-file-name (format "archives/%s" (car archive)) + package-user-dir))) (package--with-work-buffer (cdr archive) file ;; Read the retrieved buffer to make sure it is valid (e.g. it ;; may fetch a URL redirect page). @@ -1157,13 +1097,12 @@ makes them available for download." The variable `package-load-list' controls which packages to load. If optional arg NO-ACTIVATE is non-nil, don't activate packages." (interactive) - (setq package-alist nil - package-obsolete-alist nil) + (setq package-alist nil) (package-load-all-descriptors) (package-read-all-archive-contents) (unless no-activate (dolist (elt package-alist) - (package-activate (car elt) (package-desc-vers (cdr elt))))) + (package-activate (car elt)))) (setq package--initialized t)) @@ -1192,7 +1131,7 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." "Describe package: ") packages nil t nil nil guess)) (list (if (equal val "") guess (intern val))))) - (if (or (null package) (not (symbolp package))) + (if (not (and package (symbolp package))) (message "No package specified") (help-setup-xref (list #'describe-package package) (called-interactively-p 'interactive)) @@ -1209,23 +1148,23 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (princ " is ") (cond ;; Loaded packages are in `package-alist'. - ((setq desc (cdr (assq package package-alist))) - (setq version (package-version-join (package-desc-vers desc))) - (if (setq pkg-dir (package--dir package-name version)) + ((setq desc (cadr (assq package package-alist))) + (setq version (package-version-join (package-desc-version desc))) + (if (setq pkg-dir (package-desc-dir desc)) (insert "an installed package.\n\n") ;; This normally does not happen. (insert "a deleted package.\n\n"))) ;; Available packages are in `package-archive-contents'. ((setq desc (cdr (assq package package-archive-contents))) - (setq version (package-version-join (package-desc-vers desc)) - archive (aref desc (- (length desc) 1)) + (setq version (package-version-join (package-desc-version desc)) + archive (package-desc-archive desc) installable t) (if built-in (insert "a built-in package.\n\n") (insert "an uninstalled package.\n\n"))) (built-in - (setq desc (cdr built-in) - version (package-version-join (package-desc-vers desc))) + (setq desc (package--from-builtin built-in) + version (package-version-join (package-desc-version desc))) (insert "a built-in package.\n\n")) (t (insert "an orphan package.\n\n"))) @@ -1246,7 +1185,8 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (insert "'."))) (installable (if built-in - (insert (propertize "Built-in." 'font-lock-face 'font-lock-builtin-face) + (insert (propertize "Built-in." + 'font-lock-face 'font-lock-builtin-face) " Alternate version available") (insert "Available")) (insert " from " archive) @@ -1258,10 +1198,11 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." :foreground "black") 'link))) (insert-text-button button-text 'face button-face 'follow-link t - 'package-symbol package + 'package-desc desc 'action 'package-install-button-action))) (built-in - (insert (propertize "Built-in." 'font-lock-face 'font-lock-builtin-face))) + (insert (propertize "Built-in." + 'font-lock-face 'font-lock-builtin-face))) (t (insert "Deleted."))) (insert "\n") (and version (> (length version) 0) @@ -1286,7 +1227,7 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (help-insert-xref-button text 'help-package name)) (insert "\n"))) (insert " " (propertize "Summary" 'font-lock-face 'bold) - ": " (if desc (package-desc-doc desc)) "\n\n") + ": " (if desc (package-desc-summary desc)) "\n\n") (if built-in ;; For built-in packages, insert the commentary. @@ -1306,7 +1247,7 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." ;; For elpa packages, try downloading the commentary. If that ;; fails, try an existing readme file in `package-user-dir'. (cond ((condition-case nil - (package--with-work-buffer (package-archive-base package) + (package--with-work-buffer (package-archive-base desc) (concat package-name "-readme.txt") (setq buffer-file-name (expand-file-name readme package-user-dir)) @@ -1321,9 +1262,10 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (goto-char (point-max)))))))) (defun package-install-button-action (button) - (let ((package (button-get button 'package-symbol))) - (when (y-or-n-p (format "Install package `%s'? " package)) - (package-install package) + (let ((pkg-desc (button-get button 'package-desc))) + (when (y-or-n-p (format "Install package `%s'? " + (package-desc-full-name pkg-desc))) + (package-install pkg-desc) (revert-buffer nil t) (goto-char (point-min))))) @@ -1412,89 +1354,97 @@ Letters do not insert themselves; instead, they are commands. (setq tabulated-list-sort-key (cons "Status" nil)) (tabulated-list-init-header)) -(defmacro package--push (package desc status listname) +(defmacro package--push (pkg-desc status listname) "Convenience macro for `package-menu--generate'. If the alist stored in the symbol LISTNAME lacks an entry for a -package PACKAGE with descriptor DESC, add one. The alist is -keyed with cons cells (PACKAGE . VERSION-LIST), where PACKAGE is -a symbol and VERSION-LIST is a version list." - `(let* ((version (package-desc-vers ,desc)) - (key (cons ,package version))) - (unless (assoc key ,listname) - (push (list key ,status (package-desc-doc ,desc)) ,listname)))) +package PKG-DESC, add one. The alist is keyed with PKG-DESC." + `(unless (assoc ,pkg-desc ,listname) + ;; FIXME: Should we move status into pkg-desc? + (push (cons ,pkg-desc ,status) ,listname))) + +(defvar package-list-unversioned nil + "If non-nil include packages that don't have a version in `list-package'.") (defun package-menu--generate (remember-pos packages) "Populate the Package Menu. If REMEMBER-POS is non-nil, keep point on the same entry. PACKAGES should be t, which means to display all known packages, or a list of package names (symbols) to display." - ;; Construct list of ((PACKAGE . VERSION) STATUS DESCRIPTION). + ;; Construct list of (PKG-DESC . STATUS). (let (info-list name) ;; Installed packages: (dolist (elt package-alist) (setq name (car elt)) (when (or (eq packages t) (memq name packages)) - (package--push name (cdr elt) - (if (stringp (cadr (assq name package-load-list))) - "held" "installed") - info-list))) + (let* ((lle (assq name package-load-list)) + (held (cadr lle)) + (hv (if (stringp held) (version-to-list held)))) + (dolist (pkg (cdr elt)) + (let ((version (package-desc-version pkg))) + (package--push pkg + (cond + ((and lle (null held)) "disabled") + (hv + (cond + ((version-list-= version hv) "held") + ((version-list-< version hv) "obsolete") + (t "disabled"))) + ((package-built-in-p name version) "obsolete") + ((eq pkg (cadr elt)) "installed") + (t "obsolete")) + info-list)))))) ;; Built-in packages: (dolist (elt package--builtins) (setq name (car elt)) (when (and (not (eq name 'emacs)) ; Hide the `emacs' package. + (or package-list-unversioned + (package--bi-desc-version (cdr elt))) (or (eq packages t) (memq name packages))) - (package--push name (cdr elt) "built-in" info-list))) + (package--push (package--from-builtin elt) "built-in" info-list))) ;; Available and disabled packages: (dolist (elt package-archive-contents) (setq name (car elt)) (when (or (eq packages t) (memq name packages)) (let ((hold (assq name package-load-list))) - (package--push name (cdr elt) + (package--push (cdr elt) (cond ((and hold (null (cadr hold))) "disabled") ((memq name package-menu--new-package-list) "new") (t "available")) info-list)))) - ;; Obsolete packages: - (dolist (elt package-obsolete-alist) - (dolist (inner-elt (cdr elt)) - (when (or (eq packages t) (memq (car elt) packages)) - (package--push (car elt) (cdr inner-elt) "obsolete" info-list)))) - ;; Print the result. (setq tabulated-list-entries (mapcar 'package-menu--print-info info-list)) (tabulated-list-print remember-pos))) (defun package-menu--print-info (pkg) "Return a package entry suitable for `tabulated-list-entries'. -PKG has the form ((PACKAGE . VERSION) STATUS DOC). -Return (KEY [NAME VERSION STATUS DOC]), where KEY is the -identifier (NAME . VERSION-LIST)." - (let* ((package (caar pkg)) - (version (cdr (car pkg))) - (status (nth 1 pkg)) - (doc (or (nth 2 pkg) "")) - (face (cond - ((string= status "built-in") 'font-lock-builtin-face) - ((string= status "available") 'default) - ((string= status "new") 'bold) - ((string= status "held") 'font-lock-constant-face) - ((string= status "disabled") 'font-lock-warning-face) - ((string= status "installed") 'font-lock-comment-face) - (t 'font-lock-warning-face)))) ; obsolete. - (list (cons package version) - (vector (list (symbol-name package) +PKG has the form (PKG-DESC . STATUS). +Return (PKG-DESC [NAME VERSION STATUS DOC])." + (let* ((pkg-desc (car pkg)) + (status (cdr pkg)) + (face (pcase status + (`"built-in" 'font-lock-builtin-face) + (`"available" 'default) + (`"new" 'bold) + (`"held" 'font-lock-constant-face) + (`"disabled" 'font-lock-warning-face) + (`"installed" 'font-lock-comment-face) + (_ 'font-lock-warning-face)))) ; obsolete. + (list pkg-desc + (vector (list (symbol-name (package-desc-name pkg-desc)) 'face 'link 'follow-link t - 'package-symbol package + 'package-desc pkg-desc 'action 'package-menu-describe-package) - (propertize (package-version-join version) + (propertize (package-version-join + (package-desc-version pkg-desc)) 'font-lock-face face) (propertize status 'font-lock-face face) - (propertize doc 'font-lock-face face))))) + (propertize (package-desc-summary pkg-desc) + 'font-lock-face face))))) (defun package-menu-refresh () "Download the Emacs Lisp package archive. @@ -1510,10 +1460,11 @@ This fetches the contents of each archive specified in "Describe the current package. If optional arg BUTTON is non-nil, describe its associated package." (interactive) - (let ((package (if button (button-get button 'package-symbol) - (car (tabulated-list-get-id))))) - (if package - (describe-package package)))) + (let ((pkg-desc (if button (button-get button 'package-desc) + (tabulated-list-get-id)))) + (if pkg-desc + ;; FIXME: We could actually describe this particular pkg-desc. + (describe-package (package-desc-name pkg-desc))))) ;; fixme numeric argument (defun package-menu-mark-delete (&optional _num) @@ -1560,8 +1511,8 @@ If optional arg BUTTON is non-nil, describe its associated package." 'package-menu-view-commentary 'package-menu-describe-package "24.1") (defun package-menu-get-status () - (let* ((pkg (tabulated-list-get-id)) - (entry (and pkg (assq pkg tabulated-list-entries)))) + (let* ((id (tabulated-list-get-id)) + (entry (and id (assq id tabulated-list-entries)))) (if entry (aref (cadr entry) 2) ""))) @@ -1570,18 +1521,20 @@ If optional arg BUTTON is non-nil, describe its associated package." (let (installed available upgrades) ;; Build list of installed/available packages in this buffer. (dolist (entry tabulated-list-entries) - ;; ENTRY is ((NAME . VERSION) [NAME VERSION STATUS DOC]) - (let ((pkg (car entry)) + ;; ENTRY is (PKG-DESC [NAME VERSION STATUS DOC]) + (let ((pkg-desc (car entry)) (status (aref (cadr entry) 2))) (cond ((equal status "installed") - (push pkg installed)) + (push pkg-desc installed)) ((member status '("available" "new")) - (push pkg available))))) - ;; Loop through list of installed packages, finding upgrades - (dolist (pkg installed) - (let ((avail-pkg (assq (car pkg) available))) + (push (cons (package-desc-name pkg-desc) pkg-desc) + available))))) + ;; Loop through list of installed packages, finding upgrades. + (dolist (pkg-desc installed) + (let ((avail-pkg (assq (package-desc-name pkg-desc) available))) (and avail-pkg - (version-list-< (cdr pkg) (cdr avail-pkg)) + (version-list-< (package-desc-version pkg-desc) + (package-desc-version (cdr avail-pkg))) (push avail-pkg upgrades)))) upgrades)) @@ -1601,11 +1554,11 @@ call will upgrade the package." (save-excursion (goto-char (point-min)) (while (not (eobp)) - (let* ((pkg (tabulated-list-get-id)) - (upgrade (assq (car pkg) upgrades))) + (let* ((pkg-desc (tabulated-list-get-id)) + (upgrade (cdr (assq (package-desc-name pkg-desc) upgrades)))) (cond ((null upgrade) (forward-line 1)) - ((equal pkg upgrade) + ((equal pkg-desc upgrade) (package-menu-mark-install)) (t (package-menu-mark-delete)))))) @@ -1621,30 +1574,30 @@ Optional argument NOQUERY non-nil means do not ask the user to confirm." (interactive) (unless (derived-mode-p 'package-menu-mode) (error "The current buffer is not in Package Menu mode")) - (let (install-list delete-list cmd id) + (let (install-list delete-list cmd pkg-desc) (save-excursion (goto-char (point-min)) (while (not (eobp)) (setq cmd (char-after)) (unless (eq cmd ?\s) - ;; This is the key (PACKAGE . VERSION-LIST). - (setq id (tabulated-list-get-id)) + ;; This is the key PKG-DESC. + (setq pkg-desc (tabulated-list-get-id)) (cond ((eq cmd ?D) - (push (cons (symbol-name (car id)) - (package-version-join (cdr id))) - delete-list)) + (push pkg-desc delete-list)) ((eq cmd ?I) - (push (car id) install-list)))) + (push pkg-desc install-list)))) (forward-line))) (when install-list (if (or noquery (yes-or-no-p - (if (= (length install-list) 1) - (format "Install package `%s'? " (car install-list)) - (format "Install these %d packages (%s)? " - (length install-list) - (mapconcat 'symbol-name install-list ", "))))) + (if (= (length install-list) 1) + (format "Install package `%s'? " + (package-desc-full-name (car install-list))) + (format "Install these %d packages (%s)? " + (length install-list) + (mapconcat #'package-desc-full-name + install-list ", "))))) (mapc 'package-install install-list))) ;; Delete packages, prompting if necessary. (when delete-list @@ -1652,18 +1605,15 @@ Optional argument NOQUERY non-nil means do not ask the user to confirm." noquery (yes-or-no-p (if (= (length delete-list) 1) - (format "Delete package `%s-%s'? " - (caar delete-list) - (cdr (car delete-list))) + (format "Delete package `%s'? " + (package-desc-full-name (car delete-list))) (format "Delete these %d packages (%s)? " (length delete-list) - (mapconcat (lambda (elt) - (concat (car elt) "-" (cdr elt))) - delete-list - ", "))))) + (mapconcat #'package-desc-full-name + delete-list ", "))))) (dolist (elt delete-list) (condition-case-unless-debug err - (package-delete (car elt) (cdr elt)) + (package-delete elt) (error (message (cadr err))))) (error "Aborted"))) ;; If we deleted anything, regenerate `package-alist'. This is done @@ -1708,8 +1658,8 @@ Optional argument NOQUERY non-nil means do not ask the user to confirm." (string< dA dB)))) (defun package-menu--name-predicate (A B) - (string< (symbol-name (caar A)) - (symbol-name (caar B)))) + (string< (symbol-name (package-desc-name (car A))) + (symbol-name (package-desc-name (car B))))) ;;;###autoload (defun list-packages (&optional no-fetch) |