mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-22 21:50:45 -08:00
Code Issues Projects Releases Wiki Activity

Fix upgrading, rebuilding, and logging of VC packages

Browse source 
There are a few issues addressed in this patch:

1.  Compilation (including native compilation) should happen in
directory that contains package's Lisp code.

2.  After installing a package with
`package-vc-install-from-checkout' and subsequently upgrading it
with `package-vc-upgrade' the pkg-desc for the package becomes
corrupted.  After the upgrade the pkg-desc's dir (a.k.a
`pkg-dir') points to checkout directory.  This will cause the
subsequent `package-delete' to delete the checkout directory and
leaving incorrect forwarding autoloads file in
`package-user-directory'.

3. The detection of package's Lisp directory has been not
effective for packages installed with `package-vc-install' and
not existent for packages installed with
`package-install-from-checkout'.

4. Deduction of VC backend has been not working when called from
outside of deducing context.

5. Extract maintainers and store them in a package description
file when installing a package from a checkout.

* lisp/emacs-lisp/package-vc.el (package-vc--checkout-dir): New
function to determine the real checkout of a VC
package.
(package-vc--url-scheme): Define scheme for `:url' property.
(package-vc--generate-description-file): Extract maintainers
from main package file and store them in generated description
file.
(package-vc--save-selected-packages): Refactor new helper
function out of 'package-vc--unpack' to modify
'package-vc-selected-packages'.
(package-vc--checkout-dir): Use `pcase' to extract checkout
directory from `pkg-spec'.  Detect standard lisp sub directory
if called with non-nil `lisp-dir'.
(package-vc-commit, package-vc--main-file)
(package-vc--build-documentation, package-vc-prepare-patch): Use
'package-vc--checkout-dir'.
(package-vc--unpack-1): Remove superfluous `pkg-dir' argument.
Remove elc files before compilation.  Use a `package' with
`:dir' pointing to where package code is.  When `checkout-dir'
is different than `pkg-dir' then call `package--add-info-node'
and after calling `package-activate-1' reload source files in
case when `lisp-dir' is a sub directory.  Use the right
directories in the right places.
(package-vc-install-from-checkout): Remove superfluous
`package-vc-selected-packages' binding.  Remove `pkg-dir'
argument from `package-vc--unpack-1' calls.
(package-vc--unpack): Remove `lisp-dir' variable and convert to
`let*'.  Remove superfluous Lisp code sub directory detection -
logic moved to `package-vc--checkout-dir'.  Remove `pkg-dir'
argument from `package-vc--unpack-1' call. Use
'package-vc--save-selected-packages'.
(package-vc-upgrade, package-vc-rebuild): Remove `pkg-dir'
argument from `package-vc--unpack-1' calls. Use
'package-vc--checkout-dir'.
(package-vc-log-incoming): Set `vc-deduce-backend-nonvc-modes'
to t.  Use 'package-vc--checkout-dir'.
* lisp/emacs-lisp/package.el (package--add-info-node): New
function to install info node for package.  Extracted from
`package-activate-1'.
(package-activate-1): Call `package--add-info-node'.

Co-developed-by: Philip Kaludercic <philipk@posteo.net>

(Bug#79188)
This commit is contained in:
Przemysław Kryger 2025-09-26 14:00:54 +01:00 • committed by Philip Kaludercic
parent 8a0217ebbc
commit 573acd97e5
No known key found for this signature in database
2 changed files with 225 additions and 119 deletions
Download patch file Download diff file Expand all files Collapse all files

273
lisp/emacs-lisp/package-vc.el
View file

@ -31,8 +31,7 @@
;; aren't interested in activating a package, you can use ;; aren't interested in activating a package, you can use
;; `package-vc-checkout' instead, which will prompt you for a target ;; `package-vc-checkout' instead, which will prompt you for a target
;; directory. If you wish to reuse an existing checkout, the command ;; directory. If you wish to reuse an existing checkout, the command
;; `package-vc-install-from-checkout' will create a symbolic link and ;; `package-vc-install-from-checkout' will prepare the package.
;; prepare the package.
;; ;;
;; If you make local changes that you wish to share with an upstream ;; If you make local changes that you wish to share with an upstream
;; maintainer, the command `package-vc-prepare-patch' can prepare ;; maintainer, the command `package-vc-prepare-patch' can prepare
@ -85,6 +84,12 @@ the `clone' VC function."
(defvar package-vc-selected-packages) ; pacify byte-compiler (defvar package-vc-selected-packages) ; pacify byte-compiler
(defconst package-vc--url-scheme
(if (memq system-type '(ms-dos windows-nt cygwin))
"file:///"
"file://")
"Scheme for `:url' property in package spec.")
;;;###autoload ;;;###autoload
(defun package-vc-install-selected-packages () (defun package-vc-install-selected-packages ()
"Ensure packages specified in `package-vc-selected-packages' are installed." "Ensure packages specified in `package-vc-selected-packages' are installed."
@ -173,6 +178,47 @@ name for PKG-DESC."
(mapcar #'cdr package-vc--archive-spec-alists)))) (mapcar #'cdr package-vc--archive-spec-alists))))
'() nil #'string=)) '() nil #'string=))
(defun package-vc--checkout-dir (pkg-desc &optional lisp-dir)
"Return the directory of the actual VC checkout for PKG-DESC.
For most packages this is the same as `package-desc-dir', unless the
package has been installed via `package-vc-install-from-checkout'. In
that case the package redirects to the actual VC checkout. If the
optional LISP-DIR argument is non-nil, then check if a related package
specification has a `:lisp-dir' field to indicate that Lisp files are
located in a sub directory of the checkout, or the checkout has a sub
directory named \"lisp\" or \"src\" that contains .el files and return
that instead."
(let* ((pkg-spec (package-vc--desc->spec pkg-desc))
(pkg-dir (pcase (plist-get pkg-spec :url)
((rx (literal package-vc--url-scheme)
(let checkout-dir (+ any)))
checkout-dir)
(_ (package-desc-dir pkg-desc)))))
(expand-file-name
(or (and lisp-dir
(or (plist-get pkg-spec :lisp-dir)
;; When nothing is specified about a `lisp-dir', then
;; should heuristically check if there is a
;; sub-directory with lisp files. These are
;; conventionally just called "lisp" or "src". If
;; this directory exists and contains non-zero number
;; of lisp files, we will use that instead of
;; `pkg-dir'.
(catch 'done
(dolist (name '("lisp" "src"))
(when-let* ((dir (expand-file-name name pkg-dir))
((file-directory-p dir))
((directory-files
dir nil "\\`[^.].+\\.el\\'" t 1)))
;; We won't use `dir', since dir is an absolute
;; path and we don't want `lisp-dir' to depend
;; on the current location of the package
;; installation, ie. to break if moved around
;; the file system or between installations.
(throw 'done name))))))
".")
pkg-dir)))
(defun package-vc--read-archive-data (archive) (defun package-vc--read-archive-data (archive)
"Update `package-vc--archive-spec-alists' for ARCHIVE. "Update `package-vc--archive-spec-alists' for ARCHIVE.
This function is meant to be used as a hook for `package-read-archive-hook'." This function is meant to be used as a hook for `package-read-archive-hook'."
@ -219,9 +265,7 @@ asynchronously."
;; FIXME: vc should be extended to allow querying the commit of a ;; FIXME: vc should be extended to allow querying the commit of a
;; directory (as is possible when dealing with git repositories). ;; directory (as is possible when dealing with git repositories).
;; This should be a fallback option. ;; This should be a fallback option.
(cl-loop with dir = (let ((pkg-spec (package-vc--desc->spec pkg-desc))) (cl-loop with dir = (package-vc--checkout-dir pkg-desc 'lisp-dir)
(or (plist-get pkg-spec :lisp-dir)
(package-desc-dir pkg-desc)))
for file in (directory-files dir t "\\.el\\'" t) for file in (directory-files dir t "\\.el\\'" t)
when (vc-working-revision file) return it when (vc-working-revision file) return it
finally return "unknown")) finally return "unknown"))
@ -243,10 +287,7 @@ asynchronously."
(cl-assert (package-vc-p pkg-desc)) (cl-assert (package-vc-p pkg-desc))
(let* ((pkg-spec (package-vc--desc->spec pkg-desc)) (let* ((pkg-spec (package-vc--desc->spec pkg-desc))
(name (symbol-name (package-desc-name pkg-desc))) (name (symbol-name (package-desc-name pkg-desc)))
(directory (expand-file-name (directory (package-vc--checkout-dir pkg-desc 'lisp-dir))
(or (plist-get pkg-spec :lisp-dir) ".")
(or (package-desc-dir pkg-desc)
(expand-file-name name package-user-dir))))
(file (expand-file-name (file (expand-file-name
(or (plist-get pkg-spec :main-file) (or (plist-get pkg-spec :main-file)
(concat name ".el")) (concat name ".el"))
@ -272,7 +313,9 @@ asynchronously."
(defun package-vc--generate-description-file (pkg-desc pkg-file) (defun package-vc--generate-description-file (pkg-desc pkg-file)
"Generate a package description file for PKG-DESC and write it to PKG-FILE." "Generate a package description file for PKG-DESC and write it to PKG-FILE."
(let ((name (package-desc-name pkg-desc))) (let ((name (package-desc-name pkg-desc))
(main-file (let ((file (package-vc--main-file pkg-desc)))
(and (file-exists-p file) file))))
(when (equal (package-desc-summary pkg-desc) package--default-summary) (when (equal (package-desc-summary pkg-desc) package--default-summary)
;; We unset the package description if it is just the default ;; We unset the package description if it is just the default
;; summary, so that the following heuristic can take effect. ;; summary, so that the following heuristic can take effect.
@ -280,13 +323,12 @@ asynchronously."
;; Infer the package description if missing. ;; Infer the package description if missing.
(unless (package-desc-summary pkg-desc) (unless (package-desc-summary pkg-desc)
(setf (package-desc-summary pkg-desc) (setf (package-desc-summary pkg-desc)
(let ((main-file (package-vc--main-file pkg-desc)))
(or (package-desc-summary pkg-desc) (or (package-desc-summary pkg-desc)
(and-let* ((pkg (cadr (assq name package-archive-contents)))) (and-let* ((pkg (cadr (assq name package-archive-contents))))
(package-desc-summary pkg)) (package-desc-summary pkg))
(and main-file (file-exists-p main-file) (and main-file
(lm-summary main-file)) (lm-summary main-file))
package--default-summary)))) package--default-summary)))
(let ((print-level nil) (let ((print-level nil)
(print-quoted t) (print-quoted t)
(print-length nil)) (print-length nil))
@ -316,6 +358,16 @@ asynchronously."
(let ((extras (copy-alist (package-desc-extras pkg-desc)))) (let ((extras (copy-alist (package-desc-extras pkg-desc))))
(setf (alist-get :commit extras) (setf (alist-get :commit extras)
(package-vc-commit pkg-desc)) (package-vc-commit pkg-desc))
(when-let* (((null (alist-get :maintainer extras)))
(main-file)
(maintainers (lm-maintainers main-file)))
;; Like in `pakcage-buffer-info', for backward
;; compatibility, use a single cons-cell if there's
;; only one maintainer.
(setf (alist-get :maintainer extras)
(if (cdr maintainers)
maintainers
(car maintainers))))
extras) extras)
))) )))
"\n") "\n")
@ -361,7 +413,8 @@ to `package-vc-install' directly."
"Process :make and :shell-command in PKG-SPEC. "Process :make and :shell-command in PKG-SPEC.
PKG-DESC is the package descriptor for the package that is being PKG-DESC is the package descriptor for the package that is being
prepared." prepared."
(let ((target (plist-get pkg-spec :make)) (let ((default-directory (package-vc--checkout-dir pkg-desc))
(target (plist-get pkg-spec :make))
(cmd (plist-get pkg-spec :shell-command)) (cmd (plist-get pkg-spec :shell-command))
(buf (format " *package-vc make %s*" (package-desc-name pkg-desc))) (buf (format " *package-vc make %s*" (package-desc-name pkg-desc)))
(makexe (or package-vc-make-program (makexe (or package-vc-make-program
@ -381,7 +434,7 @@ prepared."
FILE can be an Org file, indicated by its \".org\" extension, FILE can be an Org file, indicated by its \".org\" extension,
otherwise it's assumed to be an Info file." otherwise it's assumed to be an Info file."
(let* ((pkg-name (package-desc-name pkg-desc)) (let* ((pkg-name (package-desc-name pkg-desc))
(default-directory (package-desc-dir pkg-desc)) (default-directory (package-vc--checkout-dir pkg-desc))
(docs-directory (file-name-directory (expand-file-name file))) (docs-directory (file-name-directory (expand-file-name file)))
(output (expand-file-name (format "%s.info" (file-name-base file)))) (output (expand-file-name (format "%s.info" (file-name-base file))))
(log-buffer (get-buffer-create (format " *package-vc doc: %s*" pkg-name))) (log-buffer (get-buffer-create (format " *package-vc doc: %s*" pkg-name)))
@ -467,15 +520,25 @@ this function successfully installs all given dependencies)."
(mapc #'package-install-from-archive to-install) (mapc #'package-install-from-archive to-install)
missing)) missing))
(defun package-vc--unpack-1 (pkg-desc pkg-dir) (defun package-vc--unpack-1 (pkg-desc)
"Prepare PKG-DESC that is already checked-out in PKG-DIR. "Prepare PKG-DESC that is already checked-out.
This includes downloading missing dependencies, generating When there's a relevant pkg-spec it is used for checkout directory.
autoloads, generating a package description file (used to Otherwise `dir' slot of PKG-SPEC is used. This includes downloading
identify a package as a VC package later on), building missing dependencies, generating autoloads, generating a package
documentation and marking the package as installed." description file (used to identify a package as a VC package later on),
(let* ((pkg-spec (package-vc--desc->spec pkg-desc)) building documentation and marking the package as installed."
(lisp-dir (plist-get pkg-spec :lisp-dir)) (let* (;; Main package directory, under `package-user-dir'. This is
(lisp-path (expand-file-name (or lisp-dir ".") pkg-dir)) ;; the same `checkout-dir' when package has been installed with
;; `package-vc-install'.
(pkg-dir (package-desc-dir pkg-desc))
(pkg-spec (package-vc--desc->spec pkg-desc))
;; Directory where the package repository has been checked out.
;; This is the `dir' argument of
;; `package-vc-install-from-checkout'.
(checkout-dir (package-vc--checkout-dir pkg-desc))
;; Directory where package's Lisp code resides. It may be
;; equal to `checkout-dir' or be a subdirectory of it.
(lisp-dir (package-vc--checkout-dir pkg-desc 'lisp-dir))
missing) missing)
;; In case the package was installed directly from source, the ;; In case the package was installed directly from source, the
@ -487,13 +550,13 @@ documentation and marking the package as installed."
(lambda (ignore) (lambda (ignore)
(wildcard-to-regexp (wildcard-to-regexp
(if (string-match-p "\\`/" ignore) (if (string-match-p "\\`/" ignore)
(concat pkg-dir ignore) (concat checkout-dir ignore)
(concat "*/" ignore)))) (concat "*/" ignore))))
(plist-get pkg-spec :ignored-files) (plist-get pkg-spec :ignored-files)
"\\|") "\\|")
regexp-unmatchable)) regexp-unmatchable))
(deps '())) (deps '()))
(dolist (file (directory-files lisp-path t "\\.el\\'" t)) (dolist (file (directory-files lisp-dir t "\\.el\\'" t))
(unless (string-match-p ignored-files file) (unless (string-match-p ignored-files file)
(with-temp-buffer (with-temp-buffer
(insert-file-contents file) (insert-file-contents file)
@ -512,27 +575,47 @@ documentation and marking the package as installed."
missing) missing)
missing))) missing)))
(let ((default-directory (file-name-as-directory pkg-dir))
(pkg-file (expand-file-name (package--description-file pkg-dir) pkg-dir)))
;; Generate autoloads ;; Generate autoloads
(let* ((name (package-desc-name pkg-desc)) (let* ((name (package-desc-name pkg-desc))
(auto-name (format "%s-autoloads.el" name))) (auto-name (format "%s-autoloads.el" name)))
(package-generate-autoloads name lisp-path) (package-generate-autoloads name lisp-dir)
(when lisp-dir ;; There are two cases when we wish to "indirect" the loading of
;; autoload files:
;;
;; 1. a package specification has a `:lisp-dir' entry listing
;; indicting that the actual Lisp code is located in a
;; subdirectory of the checkout,
;;
;; 2. the package has been installed using
;; `package-vc-install-from-checkout' and we want to load the
;; other directory instead -- which is outside of the checkout.
;; We can therefore take file inequality as a sign that we have to
;; set up an indirection.
(unless (file-equal-p lisp-dir pkg-dir)
(write-region (write-region
(with-temp-buffer (concat
(insert ";; Autoload indirection for package-vc\n\n") ";; Autoload indirection for package-vc\n\n"
(prin1 `(load (expand-file-name (prin1-to-string
,(expand-file-name auto-name lisp-dir) ;; The indirection is just a single load statement to the
;; actual file (we don't want to use symbolic links due to
;; portability reasons). Detecting which of the two cases
;; mentioned above we are setting up can be done by checking
;; if the directory with the lisp code is a subdirectory of
;; the package directory.
`(load ,(if (file-in-directory-p lisp-dir pkg-dir)
`(expand-file-name
,(file-relative-name
(expand-file-name auto-name lisp-dir)
pkg-dir)
(or (and load-file-name (or (and load-file-name
(file-name-directory load-file-name)) (file-name-directory load-file-name))
(car load-path)))) (car load-path)))
(current-buffer)) (expand-file-name auto-name lisp-dir)))))
(buffer-string))
nil (expand-file-name auto-name pkg-dir)))) nil (expand-file-name auto-name pkg-dir))))
;; Generate package file ;; Generate package file
(package-vc--generate-description-file pkg-desc pkg-file) (let ((pkg-file (expand-file-name (package--description-file pkg-dir) pkg-dir)))
(package-vc--generate-description-file pkg-desc pkg-file))
;; Process :make and :shell-command arguments before building documentation ;; Process :make and :shell-command arguments before building documentation
(when (or (eq package-vc-allow-build-commands t) (when (or (eq package-vc-allow-build-commands t)
@ -543,28 +626,60 @@ documentation and marking the package as installed."
;; Detect a manual ;; Detect a manual
(when (executable-find "install-info") (when (executable-find "install-info")
(dolist (doc-file (ensure-list (plist-get pkg-spec :doc))) (dolist (doc-file (ensure-list (plist-get pkg-spec :doc)))
(package-vc--build-documentation pkg-desc doc-file)))) (package-vc--build-documentation pkg-desc doc-file)))
;; Remove any previous instance of PKG-DESC from `package-alist' ;; Remove any previous instance of PKG-DESC from `package-alist'
(let ((pkgs (assq (package-desc-name pkg-desc) package-alist))) (let ((pkgs (assq (package-desc-name pkg-desc) package-alist)))
(when pkgs (when pkgs
(setf (cdr pkgs) (seq-remove #'package-vc-p (cdr pkgs))))) (setf (cdr pkgs) (seq-remove #'package-vc-p (cdr pkgs)))))
;; Remove all compiled files to allow for macros to be used from
;; source files, regardless of order of source files compilation and
;; load ordering. As a side effect there are no compiled files for
;; source files that no longer exist.
(dolist (elc-file (directory-files-recursively
lisp-dir
(rx string-start
(not ".") (zero-or-more any) ".elc"
string-end)
nil
(lambda (dir)
(and (file-accessible-directory-p dir)
(not (string-prefix-p "." dir))))))
(delete-file elc-file))
;; Update package-alist. ;; Update package-alist.
(let ((new-desc (package-load-descriptor pkg-dir))) (let* ((new-desc (package-load-descriptor pkg-dir))
(compile-desc (package-desc-create :name (package-desc-name new-desc)
:dir lisp-dir)))
;; Activation has to be done before compilation, so that if we're ;; Activation has to be done before compilation, so that if we're
;; upgrading and macros have changed we load the new definitions ;; upgrading and macros have changed we load the new definitions
;; before compiling. ;; before compiling.
(when (package-activate-1 new-desc :reload :deps) (when (package-activate-1 new-desc :reload :deps)
;; `package-activate-1' will reload all necessary package files
;; as long as their stems are relative to of `pkg-dir'. If
;; that's not the case (for example for packages with different
;; `checkout-dir' or with source files in a sub directory of
;; `pkg-dir'), we want to reload package files from the
;; `lisp-dir' before compilation.
(unless (file-equal-p lisp-dir pkg-dir)
(package--reload-previously-loaded compile-desc))
;; `package-activate-1' will add info node as long as dir file
;; exists in `pkg-dir'. We need to manually add it when
;; `checkout-dir' is in different location.
(unless (file-equal-p checkout-dir pkg-dir)
(package--add-info-node checkout-dir))
;; FIXME: Compilation should be done as a separate, optional, step. ;; FIXME: Compilation should be done as a separate, optional, step.
;; E.g. for multi-package installs, we should first install all packages ;; E.g. for multi-package installs, we should first install all packages
;; and then compile them. ;; and then compile them.
(package--compile new-desc) (package--compile compile-desc)
(when package-native-compile (when package-native-compile
(package--native-compile-async new-desc)) (package--native-compile-async compile-desc))
;; After compilation, load again any files loaded by ;; After compilation, load again any files loaded by
;; `activate-1', so that we use the byte-compiled definitions. ;; `package-activate-1', so that we use the byte-compiled
(package--reload-previously-loaded new-desc))) ;; definitions. This time we'll use `compile-desc' straight
;; away.
(package--reload-previously-loaded compile-desc)))
;; Mark package as selected ;; Mark package as selected
(let ((name (package-desc-name pkg-desc))) (let ((name (package-desc-name pkg-desc)))
@ -634,6 +749,14 @@ This list is used by `package-vc--unpack' to better check if the
user is fetching code from a repository that does not contain any user is fetching code from a repository that does not contain any
Emacs Lisp files.") Emacs Lisp files.")
(defun package-vc--save-selected-packages (name pkg-spec)
"Save the package specification PKG-SPEC for a package NAME."
(customize-save-variable
'package-vc-selected-packages
(cons (cons name pkg-spec)
(seq-remove (lambda (spec) (string= name (car spec)))
package-vc-selected-packages))))
(defun package-vc--unpack (pkg-desc pkg-spec &optional rev) (defun package-vc--unpack (pkg-desc pkg-spec &optional rev)
"Install the package described by PKG-DESC. "Install the package described by PKG-DESC.
PKG-SPEC is a package specification, a property list describing PKG-SPEC is a package specification, a property list describing
@ -644,8 +767,7 @@ checkout. This overrides the `:branch' attribute in PKG-SPEC."
(let ((copy (copy-package-desc pkg-desc))) (let ((copy (copy-package-desc pkg-desc)))
(setf (package-desc-kind copy) 'vc (setf (package-desc-kind copy) 'vc
pkg-desc copy))) pkg-desc copy)))
(pcase-let* (((map :lisp-dir) pkg-spec) (let* ((name (package-desc-name pkg-desc))
(name (package-desc-name pkg-desc))
(dirname (package-desc-full-name pkg-desc)) (dirname (package-desc-full-name pkg-desc))
(pkg-dir (file-name-as-directory (expand-file-name dirname package-user-dir)))) (pkg-dir (file-name-as-directory (expand-file-name dirname package-user-dir))))
(when (string-empty-p name) (when (string-empty-p name)
@ -668,33 +790,11 @@ abort installation?" name))
(delete-directory pkg-dir t) (delete-directory pkg-dir t)
(user-error "Installation aborted"))) (user-error "Installation aborted")))
;; When nothing is specified about a `lisp-dir', then should
;; heuristically check if there is a sub-directory with lisp
;; files. These are conventionally just called "lisp" or "src".
;; If this directory exists and contains non-zero number of lisp
;; files, we will use that instead of `pkg-dir'.
(catch 'done
(dolist (name '("lisp" "src"))
(when-let* (((null lisp-dir))
(dir (expand-file-name name pkg-dir))
((file-directory-p dir))
((directory-files dir nil "\\`[^.].+\\.el\\'" t 1)))
;; We won't use `dir', since dir is an absolute path and we
;; don't want `lisp-dir' to depend on the current location of
;; the package installation, ie. to break if moved around the
;; file system or between installations.
(throw 'done (setq lisp-dir name)))))
;; Ensure we have a copy of the package specification ;; Ensure we have a copy of the package specification
(unless (seq-some (lambda (alist) (equal (alist-get name (cdr alist)) pkg-spec)) (when (null (package-vc--desc->spec pkg-desc name))
package-vc--archive-spec-alists) (package-vc--save-selected-packages name pkg-spec))
(customize-save-variable
'package-vc-selected-packages
(cons (cons name pkg-spec)
(seq-remove (lambda (spec) (string= name (car spec)))
package-vc-selected-packages))))
(package-vc--unpack-1 pkg-desc pkg-dir))) (package-vc--unpack-1 pkg-desc)))
(defun package-vc--read-package-name (prompt &optional allow-url installed) (defun package-vc--read-package-name (prompt &optional allow-url installed)
"Query the user for a VC package and return a name with PROMPT. "Query the user for a VC package and return a name with PROMPT.
@ -762,7 +862,7 @@ with the remote repository state."
;; ;;
;; If there is a better way to do this, it should be done. ;; If there is a better way to do this, it should be done.
(cl-assert (package-vc-p pkg-desc)) (cl-assert (package-vc-p pkg-desc))
(letrec ((pkg-dir (package-desc-dir pkg-desc)) (letrec ((checkout-dir (package-vc--checkout-dir pkg-desc))
(vc-flags) (vc-flags)
(vc-filter-command-function (vc-filter-command-function
(lambda (command file-or-list flags) (lambda (command file-or-list flags)
@ -770,18 +870,19 @@ with the remote repository state."
(list command file-or-list flags))) (list command file-or-list flags)))
(post-upgrade (post-upgrade
(lambda (_command _file-or-list flags) (lambda (_command _file-or-list flags)
(when (and (file-equal-p pkg-dir default-directory) (when (and (file-equal-p checkout-dir default-directory)
(eq flags vc-flags)) (eq flags vc-flags))
(unwind-protect (unwind-protect
(with-demoted-errors "Failed to activate: %S" (with-demoted-errors "Failed to activate: %S"
(package-vc--unpack-1 pkg-desc pkg-dir)) (package-vc--unpack-1 pkg-desc))
(remove-hook 'vc-post-command-functions post-upgrade)))))) (remove-hook 'vc-post-command-functions post-upgrade))))))
(add-hook 'vc-post-command-functions post-upgrade) (add-hook 'vc-post-command-functions post-upgrade)
(with-demoted-errors "Failed to fetch: %S" (with-demoted-errors "Failed to fetch: %S"
(require 'vc-dir) (require 'vc-dir)
(with-current-buffer (vc-dir-prepare-status-buffer (with-current-buffer (vc-dir-prepare-status-buffer
(format " *package-vc-dir: %s*" pkg-dir) (format " *package-vc-dir: %s*" checkout-dir)
pkg-dir (vc-responsible-backend pkg-dir)) checkout-dir
(vc-responsible-backend checkout-dir))
(vc-pull))))) (vc-pull)))))
(defun package-vc--archives-initialize () (defun package-vc--archives-initialize ()
@ -946,21 +1047,22 @@ interactively), DIR must be an absolute file name."
(package-vc--archives-initialize) (package-vc--archives-initialize)
(let* ((dir (if interactive dir (expand-file-name dir))) ;avoid double expansion (let* ((dir (if interactive dir (expand-file-name dir))) ;avoid double expansion
(name (or name (file-name-base (directory-file-name dir)))) (name (or name (file-name-base (directory-file-name dir))))
(pkg-dir (file-name-concat package-user-dir name)) (pkg-dir (file-name-concat package-user-dir name)))
(package-vc-selected-packages
(cons (list name :lisp-dir dir)
package-vc-selected-packages)))
(when (file-exists-p pkg-dir) (when (file-exists-p pkg-dir)
(if (yes-or-no-p (format "Overwrite previous checkout for package `%s'?" name)) (if (yes-or-no-p (format "Overwrite previous checkout for package `%s'?" name))
(package--delete-directory pkg-dir) (package--delete-directory pkg-dir)
(error "There already exists a checkout for %s" name))) (error "There already exists a checkout for %s" name)))
(make-directory pkg-dir t) (make-directory pkg-dir t)
;; We store a custom package specification so that it is available
;; for `package-vc--unpack-1' as well as `package-vc--checkout-dir'
;; can later retrieve the actual checkout.
(package-vc--save-selected-packages
name (list :url (concat package-vc--url-scheme dir)))
(package-vc--unpack-1 (package-vc--unpack-1
(package-desc-create (package-desc-create
:name (intern name) :name (intern name)
:dir pkg-dir :dir pkg-dir
:kind 'vc) :kind 'vc))))
(file-name-as-directory pkg-dir))))
;;;###autoload ;;;###autoload
(defun package-vc-rebuild (pkg-desc) (defun package-vc-rebuild (pkg-desc)
@ -972,7 +1074,7 @@ command does not fetch new revisions from a remote server. That
is the responsibility of `package-vc-upgrade'. Interactively, is the responsibility of `package-vc-upgrade'. Interactively,
prompt for the name of the package to rebuild." prompt for the name of the package to rebuild."
(interactive (list (package-vc--read-package-desc "Rebuild package: " t))) (interactive (list (package-vc--read-package-desc "Rebuild package: " t)))
(package-vc--unpack-1 pkg-desc (package-desc-dir pkg-desc))) (package-vc--unpack-1 pkg-desc))
;;;###autoload ;;;###autoload
(defun package-vc-prepare-patch (pkg-desc subject revisions) (defun package-vc-prepare-patch (pkg-desc subject revisions)
@ -992,7 +1094,7 @@ See also `vc-prepare-patch'."
(and (not vc-prepare-patches-separately) (and (not vc-prepare-patches-separately)
(read-string "Subject: " "[PATCH] " nil nil t)) (read-string "Subject: " "[PATCH] " nil nil t))
(vc-prepare-patch-prompt-revisions))) (vc-prepare-patch-prompt-revisions)))
(let ((default-directory (package-desc-dir pkg-desc))) (let ((default-directory (package-vc--checkout-dir pkg-desc)))
(vc-prepare-patch (package-maintainers pkg-desc t) (vc-prepare-patch (package-maintainers pkg-desc t)
subject revisions))) subject revisions)))
@ -1000,7 +1102,8 @@ See also `vc-prepare-patch'."
"Call `vc-log-incoming' for the package PKG-DESC." "Call `vc-log-incoming' for the package PKG-DESC."
(interactive (interactive
(list (package-vc--read-package-desc "Incoming log for package: " t))) (list (package-vc--read-package-desc "Incoming log for package: " t)))
(let ((default-directory (package-desc-dir pkg-desc))) (let ((default-directory (package-vc--checkout-dir pkg-desc))
(vc-deduce-backend-nonvc-modes t))
(call-interactively #'vc-log-incoming))) (call-interactively #'vc-log-incoming)))
(provide 'package-vc) (provide 'package-vc)

15
lisp/emacs-lisp/package.el
View file

@ -905,6 +905,14 @@ sexps)."
(mapc (lambda (c) (load (car c) nil t)) (mapc (lambda (c) (load (car c) nil t))
(sort result (lambda (x y) (< (cdr x) (cdr y)))))))) (sort result (lambda (x y) (< (cdr x) (cdr y))))))))
(defun package--add-info-node (pkg-dir)
"Add info node located in PKG-DIR."
(when (file-exists-p (expand-file-name "dir" pkg-dir))
;; FIXME: not the friendliest, but simple.
(require 'info)
(info-initialize)
(add-to-list 'Info-directory-list pkg-dir)))
(defun package-activate-1 (pkg-desc &optional reload deps) (defun package-activate-1 (pkg-desc &optional reload deps)
"Activate package given by PKG-DESC, even if it was already active. "Activate package given by PKG-DESC, even if it was already active.
If DEPS is non-nil, also activate its dependencies (unless they If DEPS is non-nil, also activate its dependencies (unless they
@ -936,12 +944,7 @@ correspond to previously loaded files."
The following files have already been loaded: %S"))) The following files have already been loaded: %S")))
(with-demoted-errors "Error loading autoloads: %s" (with-demoted-errors "Error loading autoloads: %s"
(load (package--autoloads-file-name pkg-desc) nil t))) (load (package--autoloads-file-name pkg-desc) nil t)))
;; Add info node. (package--add-info-node pkg-dir)
(when (file-exists-p (expand-file-name "dir" pkg-dir))
;; FIXME: not the friendliest, but simple.
(require 'info)
(info-initialize)
(add-to-list 'Info-directory-list pkg-dir))
(push name package-activated-list) (push name package-activated-list)
;; Don't return nil. ;; Don't return nil.
t))) t)))