procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Extract package-fetch and related functionality

Browse source 
Note that the "package kind" was renamed from "source" to "vc".

* package-vc.el: (package-vc-commit): Copy from package.el
(package-vc-version): Add new function
(package-vc-generate-description-file): Add new function.
(package-vc-unpack): Add new function.
(package-vc-fetch): Copy from package.el
(package-checkout): Add alias for package-vc-fetch
* package.el (package-devel-dir): Remove option.  The checkouts are
stored in package-user-dir
(package-desc): Handle (vc . VERS) version strings
(package-desc-full-name): Return the plain name for vc packages
(package-devel-commit): Move function to package-vc
(package-load-descriptor): Refactor according to other changes
(package-load-all-descriptors): Remove package-devel-dir
(package-unpack): Remove vc package handling
(package-generate-description-file): Remove special handling for vc
packages
(package-install-from-archive): Remove special handling for vc
packages
(package-fetch): Move function to package-vc
(package-desc-status): Use "vc" instead of "source"
(package--remove-hidden): Use "vc" instead of "source"
(package-menu--print-info-simple): Refactor according to other changes
This commit is contained in:
Philip Kaludercic 2022-07-31 21:32:38 +02:00
parent 1180332941
commit f3e7820b48
2 changed files with 294 additions and 192 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

216
lisp/emacs-lisp/package-vc.el Normal file
View file

@ -0,0 +1,216 @@
;;; package-vc.el --- Manage packages from VC checkouts -*- lexical-binding: t; -*-
;; Copyright (C) 2022 Free Software Foundation, Inc.
;; Author: Philip Kaludercic <philipk@posteo.net>
;; Keywords: tools
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; While packages managed by package.el use tarballs for distributing
;; the source code, this extension allows for packages to be fetched
;; and updated directly from a version control system.
;;; Code:
(require 'package)
(require 'lisp-mnt)
(require 'vc)
(defgroup package-vc nil
"Manage packages from VC checkouts."
:group 'package
:version "29.1")
(declare-function vc-clone "vc" (backend remote &optional directory))
(defun package-vc-commit (pkg)
"Extract the commit of a development package PKG."
(cl-assert (eq (package-desc-kind pkg) 'vc))
;; FIXME: vc should be extended to allow querying the commit of a
;; directory (as is possible when dealing with git repositores).
;; This should be a fallback option.
(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"))
(defun package-vc-version (pkg)
"Extract the commit of a development package PKG."
(cl-assert (eq (package-desc-kind pkg) 'vc))
(cl-loop with dir = (package-desc-dir pkg) ;FIXME: dir is nil
for file in (sort (directory-files dir t "\\.el\\'")
(lambda (s1 s2)
(< (length s1) (length s2))))
when (with-temp-buffer
(insert-file-contents file)
(package-strip-rcs-id
(or (lm-header "package-version")
(lm-header "version"))))
return it
finally return "0"))
(defun package-vc-generate-description-file (pkg-desc pkg-file)
"Generate a package description file for PKG-DESC.
The output is written out into PKG-FILE."
(let* ((name (package-desc-name pkg-desc)))
(let ((print-level nil)
(print-quoted t)
(print-length nil))
(write-region
(concat
";;; Generated package description from "
(replace-regexp-in-string
"-pkg\\.el\\'" ".el"
(file-name-nondirectory pkg-file))
" -*- no-byte-compile: t -*-\n"
(prin1-to-string
(nconc
(list 'define-package
(symbol-name name)
(cons 'vc (package-vc-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))))
(package--alist-to-plist-args
(package-desc-extras pkg-desc))))
"\n")
nil pkg-file nil 'silent))))
(defun package-vc-unpack (pkg-desc)
"Install the package described by PKG-DESC."
(let* ((name (package-desc-name pkg-desc))
(dirname (package-desc-full-name pkg-desc))
(pkg-dir (expand-file-name dirname package-user-dir)))
(setf (package-desc-dir pkg-desc) pkg-dir)
(when (file-exists-p pkg-dir)
(if (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"))))
(make-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)))))
(package-vc-generate-description-file
pkg-desc (file-name-concat pkg-dir (package--description-file pkg-dir)))
;; Update package-alist.
(let ((new-desc (package-load-descriptor pkg-dir)))
;; Activation has to be done before compilation, so that if we're
;; upgrading and macros have changed we load the new definitions
;; before compiling.
(when (package-activate-1 new-desc :reload :deps)
;; 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)
(when package-native-compile
(package--native-compile-async new-desc))
;; After compilation, load again any files loaded by
;; `activate-1', so that we use the byte-compiled definitions.
(package--reload-previously-loaded new-desc)))))
(defun package-vc-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-vc-unpack
(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 'vc
: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 'vc
: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
(defalias 'package-checkout #'package-vc-fetch)
(provide 'package-vc)
;;; package-vc.el ends here

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

@ -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."
(if (eq (package-desc-kind pkg-desc) 'vc)
(symbol-name (package-desc-name pkg-desc))
(format "%s-%s"
(package-desc-name pkg-desc)
(if (eq (package-desc-kind pkg-desc) 'source)
"devel"
(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)
(unless (equal (package-desc-full-name new-desc)
(package-desc-full-name pkg-desc))
(eq (package-desc-kind pkg-desc) 'source))
(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,8 +2040,6 @@ 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))))
@ -2140,7 +2079,7 @@ if all the in-between dependencies are also in PACKAGE-LIST."
;; 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)))))))))))
(setf (package-desc-signed (car pkg-descs)) t))))))))))
;;;###autoload
(defun package-installed-p (package &optional min-version)
@ -2234,61 +2173,6 @@ to install it but still mark it as selected."
(message "Package `%s' installed." name))
(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."
@ -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)