[elpa] elpa-admin 2658af9 345/357: * admin/archive-contents.el: Add preliminary code to fetch upstream updates

[Stefan Monnier]

branch: elpa-admin
commit 2658af9f1dd97c22b63b7d05a5d22809a6d42fb4
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    * admin/archive-contents.el: Add preliminary code to fetch upstream updates
    
    (archive--branch, archive--urtb, archive--fetch, archive--push)
    (archive--batch-fetch-and, batch-fetch-and-show, batch-fetch-and-push):
    New functions.
    
    * GNUmakefile: Add corresponding rules.
---
 GNUmakefile               | 18 ++++++++++
 admin/archive-contents.el | 86 +++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 104 insertions(+)

diff --git a/GNUmakefile b/GNUmakefile
index 6d4e5ce..24446b9 100644
--- a/GNUmakefile
+++ b/GNUmakefile
@@ -219,6 +219,24 @@ $(1): $(filter $(1)/%, $(elcs))
 endef
 $(foreach pkg, $(pkgs), $(eval $(call RULE-singlepkg, $(pkg))))
 
+##### Fetching updates from upstream
+
+.PHONY: fetch/%
+fetch/%:
+       $(EMACS) -l admin/archive-contents.el -f batch-fetch-and-show "$*"
+
+.PHONY: fetch-all
+fetch-all:
+       $(EMACS) -l admin/archive-contents.el -f batch-fetch-and-show "-"
+
+.PHONY: sync/%
+sync/%:
+       $(EMACS) -l admin/archive-contents.el -f batch-fetch-and-push "$*"
+
+.PHONY: sync-all
+sync-all:
+       $(EMACS) -l admin/archive-contents.el -f batch-fetch-and-push "-"
+
 
 
 ############### Rules to prepare the externals ################################
diff --git a/admin/archive-contents.el b/admin/archive-contents.el
index 48a996d..f085bf6 100644
--- a/admin/archive-contents.el
+++ b/admin/archive-contents.el
@@ -211,6 +211,17 @@ commit which modified the \"Version:\" pseudo header."
                dir pkgname 'dont-rename)))
         (archive--message "%s: %S" pkgname pkgdesc)
         (archive--update-archive-contents pkgdesc destdir)
+        (when (and nil revision-function) ;FIXME: Circumstantial evidence.
+          ;; Various problems:
+          ;; - If "make build/foo" is used by the developers in order to test
+          ;;   the build of their package, they'll end up with those spurious
+          ;;   tags which may end up spreading to unintended places.
+          ;; - The tags created in elpa.gnu.org won't spread to nongnu.git
+          ;;   because that account can't push to git.sv.gnu.org anyway.
+          (let ((default-directory (archive--dirname dir)))
+            (archive--call nil "git" "tag" "-f"
+                           (format "%s-release/%s-%s"
+                                   archive--name pkgname vers))))
         ;; FIXME: Send email announcement!
         (let ((link (expand-file-name (format "%s.tar" pkgname) destdir)))
           (when (file-exists-p link) (delete-file link))
@@ -1160,5 +1171,80 @@ If WITH-CORE is non-nil, it means we manage :core 
packages as well."
                          ""))
       (save-buffer))))
 
+;;; Fetch updates from upstream
+
+(defun archive--branch (pkg-spec)
+  (or (plist-get (cdr pkg-spec) :branch) "master"))
+
+(defun archive--urtb (pkg-spec)
+  "Return our upstream remote tracking branch for PKG-SPEC."
+  (format "refs/remotes/upstream/%s/%s" (car pkg-spec)
+          (archive--branch pkg-spec)))
+
+(defun archive--fetch (pkg-spec &optional k)
+  (let* ((pkg (car pkg-spec))
+         (url (plist-get (cdr pkg-spec) :external))
+         (branch (archive--branch pkg-spec))
+         (default-directory (archive--dirname pkg "packages"))
+         (urtb (archive--urtb pkg-spec))
+         (refspec (format "refs/heads/%s:%s"
+                          branch urtb)))
+    (if (not url)
+        (message "Missing upstream URL in externals-list for %s" pkg)
+      (message "Fetching updates for %s..." pkg)
+      (with-temp-buffer
+        (cond
+         ((not (equal 0 (archive--call t "git" "fetch" "--no-tags"
+                                       url refspec)))
+          (message "Fetch error for %s:\n%s" pkg (buffer-string)))
+         ((not (equal 0 (archive--call t "git" "log"
+                                       (format "origin/externals/%s...%s"
+                                               pkg urtb))))
+          (message "Log error for %s:\n%s" pkg (buffer-string)))
+         ((eq (point-min) (point-max))
+          (message "No pending upstream changes for %s" pkg))
+         (t (message "%s" (buffer-string))
+            (when k (funcall k pkg-spec))))))))
+
+(defun archive--push (pkg-spec)
+  (let* ((pkg (car pkg-spec))
+         (url (plist-get (cdr pkg-spec) :external))
+         (branch (archive--branch pkg-spec))
+         (urtb (archive--urtb pkg-spec)))
+    ;; FIXME: Arrange to merge if it's not a fast-forward.
+    (with-temp-buffer
+      (cond
+       ((zerop (archive--call t "git" "merge-base" "--is-ancestor"
+                              urtb (format "externals/%s" pkg)))
+        (message "Nothing to push for %s" pkg))
+       ((not (zerop (archive--call t "git" "merge-base" "--is-ancestor"
+                                   (format "externals/%s" pkg) urtb)))
+        (message "Can't push %s: not a fast-forward" pkg))
+       ((not (equal 0 (archive--call t "git" "push" "origin"
+                                     (format "%s:externals/%s" urtb pkg))))
+        (message "Fetch error for %s:\n%s" pkg (buffer-string)))
+       (t
+        (message "Pushed %s successfully:\n%s" pkg (buffer-string))
+        (let ((default-directory (expand-file-name "../../")))
+          (archive--external-package-sync pkg)))))))
+
+(defun archive--batch-fetch-and (k)
+  (let ((specs (archive--form-from-file-contents "externals-list"))
+        (pkgs command-line-args-left))
+    (setq command-line-args-left nil)
+    (if (equal pkgs '("-")) (setq pkgs (mapcar #'car specs)))
+    (dolist (pkg pkgs)
+      (let* ((pkg-spec (assoc pkg specs)))
+        (if (not pkg-spec) (message "Unknown package: %s" pkg)
+          (unless (file-directory-p (expand-file-name pkg "packages"))
+            (archive--external-package-sync pkg))
+          (archive--fetch pkg-spec k))))))
+
+(defun batch-fetch-and-show (&rest _)
+  (archive--batch-fetch-and #'ignore))
+
+(defun batch-fetch-and-push (&rest _)
+  (archive--batch-fetch-and #'archive--push))
+
 (provide 'archive-contents)
 ;;; archive-contents.el ends here