From 30f1e7c1e93dda496412f76f70b2f49b30407b11 Mon Sep 17 00:00:00 2001 From: Philip Kaludercic Date: Sun, 30 Oct 2022 11:43:11 +0100 Subject: [PATCH] Extract last source package release from local VCS data * lisp/emacs-lisp/package-vc.el (package-vc-archive-spec-alist): Unmention :release-rev (package-vc-desc->spec): Fall back on other archives if a specification is missing. (package-vc-main-file): Add new function, copying the behaviour of elpa-admin.el. (package-vc-generate-description-file): Use 'package-vc-main-file'. (package-vc-unpack): Handle special value ':last-release'. (package-vc-release-rev): Add new function using 'last-change'. (package-vc-install): Pass ':last-release' as REV instead of a release. * lisp/vc/vc-git.el (vc-git-last-change): Add Git 'last-change' implementation. * lisp/vc/vc.el (vc-default-last-change): Add default 'last-change' implementation. This attempts to replicate the behaviour of elpa-admin.el's "elpaa--get-last-release-commit". --- lisp/emacs-lisp/package-vc.el | 88 +++++++++++++++++++++++------------ lisp/vc/vc-git.el | 17 +++++++ lisp/vc/vc.el | 18 +++++++ 3 files changed, 94 insertions(+), 29 deletions(-) diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index 3816c6152d..6597989777 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -139,12 +139,6 @@ package-vc-archive-spec-alist metadata. If not given, the assumed default is the package named with \".el\" concatenated to the end. - `:release-rev' (string) - -A revision string indicating the revision used for the current -release in the package archive. If missing or nil, no release -was made. - `:vc-backend' (symbol) A symbol indicating what the VC backend to use for cloning a @@ -179,8 +173,10 @@ package-vc-desc->spec name for PKG-DESC." (alist-get (or name (package-desc-name pkg-desc)) - (alist-get (intern (package-desc-archive pkg-desc)) - package-vc-archive-spec-alist) + (if (package-desc-archive pkg-desc) + (alist-get (intern (package-desc-archive pkg-desc)) + package-vc-archive-spec-alist) + (mapcan #'append (mapcar #'cdr package-vc-archive-spec-alist))) nil nil #'string=)) (define-inline package-vc-query-spec (pkg-desc prop) @@ -258,6 +254,20 @@ package-vc-version return it finally return "0")) +(defun package-vc-main-file (pkg-desc) + "Return the main file for PKG-DESC." + (cl-assert (package-vc-p pkg-desc)) + (let ((pkg-spec (package-vc-desc->spec pkg-desc))) + (or (plist-get pkg-spec :main-file) + (expand-file-name + (format "%s.el" (package-desc-name pkg-desc)) + (file-name-concat + (or (package-desc-dir pkg-desc) + (expand-file-name + (package-desc-name pkg-desc) + package-user-dir)) + (plist-get pkg-spec :lisp-dir)))))) + (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." @@ -265,18 +275,13 @@ package-vc-generate-description-file ;; Infer the subject if missing. (unless (package-desc-summary pkg-desc) (setf (package-desc-summary pkg-desc) - (or (package-desc-summary pkg-desc) - (and-let* ((pkg (cadr (assq name package-archive-contents)))) - (package-desc-summary pkg)) - (and-let* ((pkg-spec (package-vc-desc->spec pkg-desc)) - (main-file (plist-get pkg-spec :main-file))) - (lm-summary main-file)) - (and-let* ((main-file (expand-file-name - (format "%s.el" name) - (package-desc-dir pkg-desc))) - ((file-exists-p main-file))) - (lm-summary main-file)) - package--default-summary))) + (let ((main-file (package-vc-main-file pkg-desc))) + (or (package-desc-summary pkg-desc) + (and-let* ((pkg (cadr (assq name package-archive-contents)))) + (package-desc-summary pkg)) + (and main-file (file-exists-p main-file) + (lm-summary main-file)) + package--default-summary)))) (let ((print-level nil) (print-quoted t) (print-length nil)) @@ -424,9 +429,16 @@ package-vc-unpack nil nil #'string=) :vc-backend) package-vc-default-backend))) - (unless (vc-clone url backend repo-dir (or rev branch)) + (unless (vc-clone url backend repo-dir + (or (and (not (eq rev :last-release)) rev) branch)) (error "Failed to clone %s from %s" name url)))) + ;; Check out the latest release if requested + (when (eq rev :last-release) + (if-let ((release-rev (package-vc-release-rev pkg-desc))) + (vc-retrieve-tag pkg-dir release-rev) + (message "No release revision was found, continuing..."))) + (unless (eq pkg-dir repo-dir) ;; Link from the right position in `repo-dir' to the package ;; directory in the ELPA store. @@ -466,6 +478,22 @@ package-vc--archives-initialize (unless package-vc-archive-data-alist (package-vc--download-and-read-archives))) +(defun package-vc-release-rev (pkg-desc) + "Find the latest revision that bumps the \"Version\" tag for PKG-DESC. +If no such revision can be found, return nil." + (with-current-buffer (find-file-noselect (package-vc-main-file pkg-desc)) + (vc-buffer-sync) + (save-excursion + (goto-char (point-min)) + (let ((case-fold-search t)) + (when (re-search-forward (concat (lm-get-header-re "version") ".*$") + (lm-code-start) t) + (ignore-error vc-not-supported + (vc-call-backend (vc-backend (buffer-file-name)) + 'last-change + (match-beginning 0) + (match-end 0)))))))) + ;;;###autoload (defun package-vc-install (name-or-url &optional name rev backend) "Fetch the source of NAME-OR-URL. @@ -477,9 +505,11 @@ package-vc-install metadata will be consulted for the URL. An explicit revision can be requested using REV. If the command is invoked with a prefix argument, the revision used for the last release in the package -archive is used. If a NAME-OR-URL is a URL, that is to say a -string, the VC backend used to clone the repository can be set by -BACKEND. If missing, `package-vc-guess-backend' will be used." +archive is used. This can also be reproduced by passing the +special value `:last-release' as REV. If a NAME-OR-URL is a URL, +that is to say a string, the VC backend used to clone the +repository can be set by BACKEND. If missing, +`package-vc-guess-backend' will be used." (interactive (progn ;; Initialize the package system to get the list of package @@ -490,11 +520,7 @@ package-vc-install "Fetch package source (name or URL): " packages)) (name (file-name-base input))) (list input (intern (string-remove-prefix "emacs-" name)) - (and current-prefix-arg - (or (package-vc-query-spec - (cadr (assoc input package-archive-contents #'string=)) - :release-rev) - (user-error "No release revision was found"))))))) + (and current-prefix-arg :last-release))))) (package-vc--archives-initialize) (cond ((and-let* ((stringp name-or-url) @@ -511,6 +537,10 @@ package-vc-install (setf (package-desc-kind copy) 'vc) copy) (or (package-vc-desc->spec (cadr desc)) + (and-let* ((extras (package-desc-extras (cadr desc))) + (url (alist-get :url extras)) + (backend (package-vc-guess-backend url))) + (list :vc-backend backend :url url)) (user-error "Package has no VC data")) rev))) ((user-error "Unknown package to fetch: %s" name-or-url)))) diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 6137ce75ce..cd62effd08 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -1632,6 +1632,23 @@ vc-git-annotate-extract-revision-at-line (expand-file-name fname (vc-git-root default-directory)))) revision))))) +(defun vc-git-last-change (from to) + (vc-buffer-sync) + (let ((file (file-relative-name + (buffer-file-name) + (vc-git-root (buffer-file-name)))) + (start (line-number-at-pos from t)) + (end (line-number-at-pos to t))) + (with-temp-buffer + (when (vc-git--out-ok + "blame" "--porcelain" + (format "-L%d,%d" start end) + file) + (goto-char (point-min)) + (save-match-data + (when (looking-at "\\`\\([[:alnum:]]+\\)[[:space:]]+") + (match-string 1))))))) + ;;; TAG/BRANCH SYSTEM (declare-function vc-read-revision "vc" diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index 38209ef39e..c8d28c144b 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -448,6 +448,11 @@ ;; - mergebase (rev1 &optional rev2) ;; ;; Return the common ancestor between REV1 and REV2 revisions. +;; +;; - last-change (from to) +;; +;; Return the most recent revision that made a change between FROM +;; and TO. ;; TAG/BRANCH SYSTEM ;; @@ -3584,6 +3589,19 @@ vc-clone remote directory rev))) (throw 'ok res))))))) +(declare-function log-view-current-tag "log-view" (&optional pos)) +(defun vc-default-last-change (_backend from to) + "Default `last-change' implementation. +FROM and TO are used as region markers" + (save-window-excursion + (let* ((buf (window-buffer (vc-region-history from to))) + (proc (get-buffer-process buf))) + (cl-assert (processp proc)) + (while (accept-process-output proc)) + (with-current-buffer buf + (prog1 (log-view-current-tag) + (kill-buffer)))))) + ;; These things should probably be generally available -- 2.38.0