Extract package-fetch and related functionality
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
parent
1180332941
commit
f3e7820b48
2 changed files with 294 additions and 192 deletions
216
lisp/emacs-lisp/package-vc.el
Normal file
216
lisp/emacs-lisp/package-vc.el
Normal 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
|
||||
|
|
@ -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)
|
||||
|
|
@ -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)
|
||||
|
|
@ -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.
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue