feature/package+vc 30f1e7c1e9 05/10: Extract last source package release from local VCS data

[Philip Kaludercic]

branch: feature/package+vc
commit 30f1e7c1e93dda496412f76f70b2f49b30407b11
Author: Philip Kaludercic <philipk@posteo.net>
Commit: Philip Kaludercic <philipk@posteo.net>

    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 @@ The main file of the project, relevant to gather package
 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 @@ The optional argument NAME can be used to override the 
default
 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 @@ asynchronously."
            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 @@ The output is written out into PKG-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 @@ the `:brach' attribute in PKG-SPEC."
                                                  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 @@ the `:brach' attribute in PKG-SPEC."
   (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 @@ 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.  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 @@ BACKEND.  If missing, `package-vc-guess-backend' will be 
used."
                     "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 @@ BACKEND.  If missing, `package-vc-guess-backend' will be 
used."
          (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 @@ This requires git 1.8.4 or later, for the \"-L\" option 
of \"git log\"."
                    (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 @@ it indicates a specific revision to check out."
                            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