diff options
Diffstat (limited to 'lisp/emacs-lisp/package.el')
| -rw-r--r-- | lisp/emacs-lisp/package.el | 270 |
1 files changed, 78 insertions, 192 deletions
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 858214611f6..a5821486405 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -304,17 +304,6 @@ packages in `package-directory-list'." :group 'applications :version "24.1") -(defcustom package-devel-dir (expand-file-name "devel" package-user-dir) - "Directory containing the user's Emacs Lisp package checkouts. -The directory name should be absolute. -Apart from this directory, Emacs also looks for system-wide -packages in `package-directory-list'." - :type 'directory - :initialize #'custom-initialize-delay - :set-after '(package-user-dir) - :risky t - :version "29.1") - ;;;###autoload (defcustom package-directory-list ;; Defaults are subdirs named "elpa" in the site-lisp dirs. @@ -472,14 +461,18 @@ synchronously." &rest rest-plist &aux (name (intern name-string)) - (version (and version-string (version-to-list version-string))) + (version (if (eq (car-safe version-string) 'vc) + (version-to-list (cdr version-string)) + (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))) - (kind (plist-get rest-plist :kind)) + (kind (if (eq (car-safe version-string) 'vc) + 'vc + (plist-get rest-plist :kind))) (archive (plist-get rest-plist :archive)) (extras (let (alist) (while rest-plist @@ -571,10 +564,10 @@ This is, approximately, the inverse of `version-to-list'. (defun package-desc-full-name (pkg-desc) "Return full name of package-desc object PKG-DESC. This is the name of the package with its version appended." - (format "%s-%s" - (package-desc-name pkg-desc) - (if (eq (package-desc-kind pkg-desc) 'source) - "devel" + (if (eq (package-desc-kind pkg-desc) 'vc) + (symbol-name (package-desc-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) @@ -654,6 +647,8 @@ loaded and/or activated, customize `package-load-list'.") ;; `package-load-all-descriptors', which ultimately populates the ;; `package-alist' variable. +(declare-function package-vc-version "package-vc" (pkg)) + (defun package-process-define-package (exp) "Process define-package expression EXP and push it to `package-alist'. EXP should be a form read from a foo-pkg.el file. @@ -682,15 +677,7 @@ are sorted with the highest version first." nil))) new-pkg-desc))) -(declare-function vc-working-revision "vc" (file &optional backend)) -(defun package-devel-commit (pkg) - "Extract the commit of a development package PKG." - (cl-assert (eq (package-desc-kind pkg) 'source)) - (require 'vc) - (cl-loop with dir = (package-desc-dir pkg) - for file in (directory-files dir t "\\.el\\'" t) - when (vc-working-revision file) return it - finally return "unknown")) +(declare-function package-vc-commit "package-vc" (pkg)) (defun package-load-descriptor (pkg-dir) "Load the package description file in directory PKG-DIR. @@ -707,13 +694,9 @@ return it." (read (current-buffer))) (error "Can't find define-package in %s" pkg-file)))) (setf (package-desc-dir pkg-desc) pkg-dir) - (when (file-exists-p (expand-file-name - (symbol-name (package-desc-name pkg-desc)) - package-devel-dir)) - ;; XXX: This check seems dirty, there should be a better - ;; way to deduce if a package is in the devel directory. - (setf (package-desc-kind pkg-desc) 'source) - (push (cons :commit (package-devel-commit pkg-desc)) + (when (eq (package-desc-kind pkg-desc) 'vc) + (require 'package-vc) + (push (cons :commit (package-vc-commit pkg-desc)) (package-desc-extras pkg-desc))) (if (file-exists-p signed-file) (setf (package-desc-signed pkg-desc) t)) @@ -728,9 +711,7 @@ 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'." - (dolist (dir (cl-list* package-user-dir - package-devel-dir - package-directory-list)) + (dolist (dir (cons package-user-dir package-directory-list)) (when (file-directory-p dir) (dolist (pkg-dir (directory-files dir t "^[^.]" t)) (when (file-directory-p pkg-dir) @@ -964,51 +945,12 @@ untar into a directory named DIR; otherwise, signal an error." (apply #'nconc (mapcar (lambda (pair) (list (car pair) (cdr pair))) alist)))) -(declare-function vc-clone "vc" (backend remote &optional directory)) - (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))) (pcase (package-desc-kind pkg-desc) - ('source - (setq pkg-dir (expand-file-name (symbol-name name) package-devel-dir)) - (when (file-exists-p pkg-dir) - (if (and (called-interactively-p 'interactive) - (yes-or-no-p "Overwrite previous checkout?")) - (delete-directory pkg-dir t) - (error "There already exists a checkout for %s" name))) - (pcase-let* ((attr (package-desc-extras pkg-desc)) - (`(,backend ,repo ,dir ,branch) - (or (alist-get :upstream attr) - (error "Source package has no repository")))) - (require 'vc) - (make-directory (file-name-directory (file-name-directory pkg-dir)) t) - (unless (setf (car (alist-get :upstream attr)) - (vc-clone backend repo pkg-dir)) - (error "Failed to clone %s from %s" name repo)) - (when-let ((rev (or (alist-get :rev attr) branch))) - (vc-retrieve-tag pkg-dir rev)) - (when dir (setq pkg-dir (file-name-concat pkg-dir dir))) - ;; In case the package was installed directly from source, the - ;; dependency list wasn't know beforehand, and they might have - ;; to be installed explicitly. - (let (deps) - (dolist (file (directory-files pkg-dir t "\\.el\\'" t)) - (with-temp-buffer - (insert-file-contents file) - (when-let* ((require-lines (lm-header-multiline "package-requires"))) - (thread-last - (mapconcat #'identity require-lines " ") - package-read-from-string - package--prepare-dependencies - (nconc deps) - (setq deps))))) - (dolist (dep deps) - (cl-callf version-to-list (cadr dep))) - (package-download-transaction - (package-compute-transaction nil (delete-dups deps)))))) ('dir (make-directory pkg-dir t) (let ((file-list @@ -1035,9 +977,8 @@ untar into a directory named DIR; otherwise, signal an error." (package--make-autoloads-and-stuff pkg-desc pkg-dir) ;; Update package-alist. (let ((new-desc (package-load-descriptor pkg-dir))) - (unless (or (equal (package-desc-full-name new-desc) - (package-desc-full-name pkg-desc)) - (eq (package-desc-kind pkg-desc) 'source)) + (unless (equal (package-desc-full-name new-desc) + (package-desc-full-name pkg-desc)) (error "The retrieved package (`%s') doesn't match what the archive offered (`%s')" (package-desc-full-name new-desc) (package-desc-full-name pkg-desc))) ;; Activation has to be done before compilation, so that if we're @@ -1071,8 +1012,7 @@ untar into a directory named DIR; otherwise, signal an error." (nconc (list 'define-package (symbol-name name) - (and (not (eq (package-desc-kind pkg-desc) 'source)) - (package-version-join (package-desc-version pkg-desc))) + (package-version-join (package-desc-version pkg-desc)) (package-desc-summary pkg-desc) (let ((requires (package-desc-reqs pkg-desc))) (list 'quote @@ -1087,6 +1027,7 @@ untar into a directory named DIR; otherwise, signal an error." "\n") nil pkg-file nil 'silent)))) + ;;;; Autoload (declare-function autoload-rubric "autoload" (file &optional type feature)) @@ -2099,48 +2040,46 @@ if all the in-between dependencies are also in PACKAGE-LIST." ;; This won't happen, unless the archive is doing something wrong. (when (eq (package-desc-kind pkg-desc) 'dir) (error "Can't install directory package from archive")) - (if (eq (package-desc-kind pkg-desc) 'source) - (package-unpack pkg-desc) - (let* ((location (package-archive-base pkg-desc)) - (file (concat (package-desc-full-name pkg-desc) - (package-desc-suffix pkg-desc)))) - (package--with-response-buffer location :file file - (if (or (not (package-check-signature)) - (member (package-desc-archive pkg-desc) - package-unsigned-archives)) - ;; If we don't care about the signature, unpack and we're - ;; done. - (let ((save-silently t)) - (package-unpack pkg-desc)) - ;; If we care, check it and *then* write the file. - (let ((content (buffer-string))) - (package--check-signature - location file content nil - ;; This function will be called after signature checking. - (lambda (&optional good-sigs) - ;; Signature checked, unpack now. - (with-temp-buffer ;FIXME: Just use the previous current-buffer. - (set-buffer-multibyte nil) - (cl-assert (not (multibyte-string-p content))) - (insert content) - (let ((save-silently t)) - (package-unpack pkg-desc))) - ;; Here the package has been installed successfully, mark it as - ;; signed if appropriate. - (when good-sigs - ;; Write out good signatures into NAME-VERSION.signed file. - (write-region (mapconcat #'epg-signature-to-string good-sigs "\n") - nil - (expand-file-name - (concat (package-desc-full-name pkg-desc) ".signed") - package-user-dir) - nil 'silent) - ;; Update the old pkg-desc which will be shown on the description buffer. - (setf (package-desc-signed pkg-desc) t) - ;; Update the new (activated) pkg-desc as well. - (when-let* ((pkg-descs (cdr (assq (package-desc-name pkg-desc) - package-alist)))) - (setf (package-desc-signed (car pkg-descs)) t))))))))))) + (let* ((location (package-archive-base pkg-desc)) + (file (concat (package-desc-full-name pkg-desc) + (package-desc-suffix pkg-desc)))) + (package--with-response-buffer location :file file + (if (or (not (package-check-signature)) + (member (package-desc-archive pkg-desc) + package-unsigned-archives)) + ;; If we don't care about the signature, unpack and we're + ;; done. + (let ((save-silently t)) + (package-unpack pkg-desc)) + ;; If we care, check it and *then* write the file. + (let ((content (buffer-string))) + (package--check-signature + location file content nil + ;; This function will be called after signature checking. + (lambda (&optional good-sigs) + ;; Signature checked, unpack now. + (with-temp-buffer ;FIXME: Just use the previous current-buffer. + (set-buffer-multibyte nil) + (cl-assert (not (multibyte-string-p content))) + (insert content) + (let ((save-silently t)) + (package-unpack pkg-desc))) + ;; Here the package has been installed successfully, mark it as + ;; signed if appropriate. + (when good-sigs + ;; Write out good signatures into NAME-VERSION.signed file. + (write-region (mapconcat #'epg-signature-to-string good-sigs "\n") + nil + (expand-file-name + (concat (package-desc-full-name pkg-desc) ".signed") + package-user-dir) + nil 'silent) + ;; Update the old pkg-desc which will be shown on the description buffer. + (setf (package-desc-signed pkg-desc) t) + ;; Update the new (activated) pkg-desc as well. + (when-let* ((pkg-descs (cdr (assq (package-desc-name pkg-desc) + package-alist)))) + (setf (package-desc-signed (car pkg-descs)) t)))))))))) ;;;###autoload (defun package-installed-p (package &optional min-version) @@ -2235,61 +2174,6 @@ to install it but still mark it as selected." (message "`%s' is already installed" name)))) ;;;###autoload -(defun package-fetch (name-or-url &optional name rev) - "Fetch the source of NAME-OR-URL. -If NAME-OR-URL is a URL, then the package will be downloaded from -the repository indicated by the URL. The function will try to -guess the name of the package using `file-name-base'. This can -be overridden by manually passing the optional NAME. Otherwise -NAME-OR-URL is taken to be a package name, and the package -metadata will be consulted for the URL. An explicit revision can -be requested using REV." - (interactive - (progn - ;; Initialize the package system to get the list of package - ;; symbols for completion. - (package--archives-initialize) - (let* ((input (completing-read - "Fetch package source (name or URL): " - package-archive-contents)) - (name (file-name-base input))) - (list input (intern (string-remove-prefix "emacs-" name)))))) - (package--archives-initialize) - (package-install - (cond - ((and (stringp name-or-url) - (url-type (url-generic-parse-url name-or-url))) - (package-desc-create - :name (or name (intern (file-name-base name-or-url))) - :kind 'source - :extras `((:upstream . ,(list nil name-or-url nil nil)) - (:rev . ,rev)))) - ((when-let* ((desc (cadr (assoc name-or-url package-archive-contents - #'string=))) - (spec (or (alist-get :vc (package-desc-extras desc)) - (user-error "Package has no VC header")))) - (unless (string-match - (rx bos - (group (+ alnum)) - (+ blank) (group (+ (not blank))) - (? (+ blank) (group (+ (not blank))) - (? (+ blank) (group (+ (not blank))))) - eos) - spec) - (user-error "Invalid repository specification %S" spec)) - (package-desc-create - :name (if (stringp name-or-url) - (intern name-or-url) - name-or-url) - :kind 'source - :extras `((:upstream . ,(list (intern (match-string 1 spec)) - (match-string 2 spec) - (match-string 3 spec) - (match-string 4 spec))) - (:rev . ,rev))))) - ((user-error "Unknown package to fetch: %s" name-or-url))))) - -;;;###autoload (defun package-update (name) "Update package NAME if a newer version exists." (interactive @@ -3188,7 +3072,7 @@ of these dependencies, similar to the list returned by (signed (or (not package-list-unsigned) (package-desc-signed pkg-desc)))) (cond - ((eq (package-desc-kind pkg-desc) 'source) "source") + ((eq (package-desc-kind pkg-desc) 'vc) "source") ((eq dir 'builtin) "built-in") ((and lle (null held)) "disabled") ((stringp held) @@ -3279,7 +3163,7 @@ to their archives." (let ((ins-version (package-desc-version installed))) (cl-remove-if (lambda (p) (or (version-list-= (package-desc-version p) ins-version) - (eq (package-desc-kind installed) 'source))) + (eq (package-desc-kind installed) 'vc))) filtered-by-priority)))))))) (defcustom package-hidden-regexps nil @@ -3536,8 +3420,10 @@ Return (PKG-DESC [NAME VERSION STATUS DOC])." package-desc ,pkg action package-menu-describe-package) ,(propertize - (if (eq (package-desc-kind pkg) 'source) - (package-devel-commit pkg) + (if (eq (package-desc-kind pkg) 'vc) + (progn + (require 'package-vc) + (package-vc-commit pkg)) (package-version-join (package-desc-version pkg))) 'font-lock-face face) @@ -4334,22 +4220,22 @@ Unlike other filters, this leaves the marks intact." (while (not (eobp)) (setq mark (char-after)) (unless (eq mark ?\s) - (setq pkg-id (tabulated-list-get-id)) + (setq pkg-id (tabulated-list-get-id)) (setq entry (package-menu--print-info-simple pkg-id)) - (push entry found-entries) - ;; remember the mark - (push (cons pkg-id mark) marks)) + (push entry found-entries) + ;; remember the mark + (push (cons pkg-id mark) marks)) (forward-line)) (if found-entries (progn (setq tabulated-list-entries found-entries) (package-menu--display t nil) - ;; redo the marks, but we must remember the marks!! - (goto-char (point-min)) - (while (not (eobp)) - (setq mark (cdr (assq (tabulated-list-get-id) marks))) - (tabulated-list-put-tag (char-to-string mark) t))) - (user-error "No packages found"))))) + ;; redo the marks, but we must remember the marks!! + (goto-char (point-min)) + (while (not (eobp)) + (setq mark (cdr (assq (tabulated-list-get-id) marks))) + (tabulated-list-put-tag (char-to-string mark) t))) + (user-error "No packages found"))))) (defun package-menu-filter-upgradable () "Filter \"*Packages*\" buffer to show only upgradable packages." @@ -4555,7 +4441,7 @@ DESC must be a `package-desc' object." (unless url (user-error "No website for %s" (package-desc-name desc))) (if secondary - (funcall browse-url-secondary-browser-function url) + (funcall browse-url-secondary-browser-function url) (browse-url url)))) ;; TODO: Allow attaching a patch to send directly to the maintainer. |