[bot] "built_in_updates" Sat Aug 27 08:46:27 UTC 2022

This commit is contained in:
SpacemacsBot 2022-08-27 08:46:27 +00:00 committed by Maxi Wolff
parent d6c3482663
commit 1ed08595bf
3 changed files with 72 additions and 48 deletions

View file

@ -171,6 +171,12 @@ disallowed."
(car (process-lines "hg" "config" "extensions.purge"))))) (car (process-lines "hg" "config" "extensions.purge")))))
(and value (not (string-prefix-p "!" value))))) (and value (not (string-prefix-p "!" value)))))
(defvar package-build--inhibit-fetch nil
"Whether to inhibit fetching. Useful for testing purposes.")
(defvar package-build--inhibit-checkout nil
"Whether to inhibit checkout. Useful for testing purposes.")
;;; Generic Utilities ;;; Generic Utilities
(defun package-build--message (format-string &rest args) (defun package-build--message (format-string &rest args)
@ -195,13 +201,8 @@ Otherwise do nothing. FORMAT-STRING and ARGS are as per that function."
version))) version)))
(defun package-build-get-timestamp-version (rcp) (defun package-build-get-timestamp-version (rcp)
(let* ((rev (and (cl-typep rcp 'package-git-recipe) (pcase-let ((`(,hash . ,time) (package-build--get-timestamp rcp)))
(or (oref rcp commit) (cons hash
(when-let ((branch (oref rcp branch)))
(concat "origin/" branch))
"origin/HEAD")))
(time (package-build--get-timestamp rcp rev)))
(cons (package-build--get-commit rcp rev)
;; We remove zero-padding of the HH portion, as ;; We remove zero-padding of the HH portion, as
;; that is lost when stored in archive-contents. ;; that is lost when stored in archive-contents.
(concat (format-time-string "%Y%m%d." time t) (concat (format-time-string "%Y%m%d." time t)
@ -278,10 +279,6 @@ is used instead."
(package-build--message "Fetcher: %s" (package-recipe--fetcher rcp)) (package-build--message "Fetcher: %s" (package-recipe--fetcher rcp))
(package-build--message "Source: %s\n" (package-recipe--upstream-url rcp))) (package-build--message "Source: %s\n" (package-recipe--upstream-url rcp)))
(cl-defmethod package-build--checkout-1 :before ((_rcp package-recipe) rev)
(when rev
(package-build--message "Checking out %s" rev)))
;;;; Git ;;;; Git
(cl-defmethod package-build--checkout ((rcp package-git-recipe)) (cl-defmethod package-build--checkout ((rcp package-git-recipe))
@ -293,13 +290,14 @@ is used instead."
(cond (cond
((and (file-exists-p (expand-file-name ".git" dir)) ((and (file-exists-p (expand-file-name ".git" dir))
(string-equal (package-build--used-url rcp) url)) (string-equal (package-build--used-url rcp) url))
(package-build--message "Updating %s" dir) (unless package-build--inhibit-fetch
(package-build--run-process dir nil "git" "fetch" "-f" "--all" "--tags") (package-build--message "Updating %s" dir)
;; We might later checkout "origin/HEAD". Sadly "git fetch" (package-build--run-process dir nil "git" "fetch" "-f" "--all" "--tags")
;; cannot be told to keep it up-to-date, so we have to make ;; We might later checkout "origin/HEAD". Sadly "git fetch"
;; a second request. ;; cannot be told to keep it up-to-date, so we have to make
(package-build--run-process dir nil "git" "remote" "set-head" ;; a second request.
"origin" "--auto")) (package-build--run-process dir nil "git" "remote" "set-head"
"origin" "--auto")))
(t (t
(when (file-exists-p dir) (when (file-exists-p dir)
(delete-directory dir t)) (delete-directory dir t))
@ -318,25 +316,32 @@ is used instead."
version))) version)))
(cl-defmethod package-build--checkout-1 ((rcp package-git-recipe) rev) (cl-defmethod package-build--checkout-1 ((rcp package-git-recipe) rev)
(let ((dir (package-recipe--working-tree rcp))) (unless package-build--inhibit-checkout
(package-build--run-process dir nil "git" "reset" "--hard" rev) (package-build--message "Checking out %s" rev)
(package-build--run-process dir nil "git" "submodule" "sync" "--recursive") (let ((dir (package-recipe--working-tree rcp)))
(package-build--run-process dir nil "git" "submodule" "update" (package-build--run-process dir nil "git" "reset" "--hard" rev))))
"--init" "--recursive")))
(cl-defmethod package-build--list-tags ((rcp package-git-recipe)) (cl-defmethod package-build--list-tags ((rcp package-git-recipe))
(let ((default-directory (package-recipe--working-tree rcp))) (let ((default-directory (package-recipe--working-tree rcp)))
(process-lines "git" "tag"))) (process-lines "git" "tag")))
(cl-defmethod package-build--get-timestamp ((rcp package-git-recipe) rev) (cl-defmethod package-build--get-timestamp ((rcp package-git-recipe))
(let ((default-directory (package-recipe--working-tree rcp))) (pcase-let*
;; `package-build-expand-files-spec' expects REV to be checked out. ((default-directory (package-recipe--working-tree rcp))
(package-build--checkout-1 rcp rev) (commit (oref rcp commit))
(string-to-number (branch (oref rcp branch))
(car (apply #'process-lines (branch (and branch (concat "origin/" branch)))
"git" "log" "-n1" "--first-parent" (rev (or commit branch "origin/HEAD"))
"--pretty=format:%cd" "--date=unix" ;; `package-build-expand-files-spec' expects REV to be checked out.
rev "--" (mapcar #'car (package-build-expand-files-spec rcp))))))) (_ (package-build--checkout-1 rcp rev))
(`(,hash ,time)
(split-string
(car (apply #'process-lines
"git" "log" "-n1" "--first-parent"
"--pretty=format:%H %cd" "--date=unix" rev
"--" (mapcar #'car (package-build-expand-files-spec rcp))))
" ")))
(cons hash (string-to-number time))))
(cl-defmethod package-build--get-commit-time ((rcp package-git-recipe) rev) (cl-defmethod package-build--get-commit-time ((rcp package-git-recipe) rev)
(let ((default-directory (package-recipe--working-tree rcp))) (let ((default-directory (package-recipe--working-tree rcp)))
@ -360,9 +365,10 @@ is used instead."
(cond (cond
((and (file-exists-p (expand-file-name ".hg" dir)) ((and (file-exists-p (expand-file-name ".hg" dir))
(string-equal (package-build--used-url rcp) url)) (string-equal (package-build--used-url rcp) url))
(package-build--message "Updating %s" dir) (unless package-build--inhibit-fetch
(package-build--run-process dir nil "hg" "pull") (package-build--message "Updating %s" dir)
(package-build--run-process dir nil "hg" "update")) (package-build--run-process dir nil "hg" "pull")
(package-build--run-process dir nil "hg" "update")))
(t (t
(when (file-exists-p dir) (when (file-exists-p dir)
(delete-directory dir t)) (delete-directory dir t))
@ -374,7 +380,8 @@ is used instead."
version))) version)))
(cl-defmethod package-build--checkout-1 ((rcp package-hg-recipe) rev) (cl-defmethod package-build--checkout-1 ((rcp package-hg-recipe) rev)
(when rev (when (and (not package-build--inhibit-checkout) rev)
(package-build--message "Checking out %s" rev)
(package-build--run-process (package-recipe--working-tree rcp) (package-build--run-process (package-recipe--working-tree rcp)
nil "hg" "update" rev))) nil "hg" "update" rev)))
@ -386,15 +393,19 @@ is used instead."
(match-string 0)) (match-string 0))
(process-lines "hg" "tags")))) (process-lines "hg" "tags"))))
(cl-defmethod package-build--get-timestamp ((rcp package-hg-recipe) rev) (cl-defmethod package-build--get-timestamp ((rcp package-hg-recipe))
(let ((default-directory (package-recipe--working-tree rcp))) (pcase-let*
(string-to-number ((default-directory (package-recipe--working-tree rcp))
(car (split-string ; "hgdate" is "<unix-date> <timezone>" (rev nil) ; TODO Respect commit and branch properties.
(car (apply #'process-lines (`(,hash ,time ,_timezone)
"hg" "log" "--limit" "1" "--template" "{date|hgdate}\n" (split-string
`(,@(and rev (list "--rev" rev)) (car (apply #'process-lines
,@(mapcar #'car (package-build-expand-files-spec rcp))))) "hg" "log" "--limit" "1"
" "))))) "--template" "{node} {date|hgdate}\n"
`(,@(and rev (list "--rev" rev))
,@(mapcar #'car (package-build-expand-files-spec rcp)))))
" ")))
(cons hash (string-to-number time))))
(cl-defmethod package-build--get-commit-time ((rcp package-hg-recipe) rev) (cl-defmethod package-build--get-commit-time ((rcp package-hg-recipe) rev)
(let ((default-directory (package-recipe--working-tree rcp))) (let ((default-directory (package-recipe--working-tree rcp)))

View file

@ -51,8 +51,7 @@
"Create a new recipe for the package named NAME using FETCHER." "Create a new recipe for the package named NAME using FETCHER."
(interactive (interactive
(list (read-string "Package name: ") (list (read-string "Package name: ")
(intern (completing-read "Fetcher: " (intern (completing-read "Fetcher: " package-recipe--fetchers
(list "git" "github" "gitlab" "hg")
nil t nil nil "github")))) nil t nil nil "github"))))
(let ((recipe-file (expand-file-name name package-build-recipes-dir))) (let ((recipe-file (expand-file-name name package-build-recipes-dir)))
(when (file-exists-p recipe-file) (when (file-exists-p recipe-file)

View file

@ -69,6 +69,12 @@
(cl-defmethod package-recipe--fetcher ((rcp package-recipe)) (cl-defmethod package-recipe--fetcher ((rcp package-recipe))
(substring (symbol-name (eieio-object-class rcp)) 8 -7)) (substring (symbol-name (eieio-object-class rcp)) 8 -7))
(defconst package-recipe--forge-fetchers
'(github gitlab codeberg sourcehut))
(defconst package-recipe--fetchers
(append '(git hg) package-recipe--forge-fetchers))
;;;; Git ;;;; Git
(defclass package-git-recipe (package-recipe) ()) (defclass package-git-recipe (package-recipe) ())
@ -81,6 +87,14 @@
((url-format :initform "https://gitlab.com/%s.git") ((url-format :initform "https://gitlab.com/%s.git")
(repopage-format :initform "https://gitlab.com/%s"))) (repopage-format :initform "https://gitlab.com/%s")))
(defclass package-codeberg-recipe (package-git-recipe)
((url-format :initform "https://codeberg.org/%s.git")
(repopage-format :initform "https://codeberg.org/%s")))
(defclass package-sourcehut-recipe (package-git-recipe)
((url-format :initform "https://git.sr.ht/~%s")
(repopage-format :initform "https://git.sr.ht/~%s")))
;;;; Mercurial ;;;; Mercurial
(defclass package-hg-recipe (package-recipe) ()) (defclass package-hg-recipe (package-recipe) ())
@ -137,7 +151,7 @@ file is invalid, then raise an error."
(cl-assert (memq thing all-keys) nil "Unknown keyword %S" thing))) (cl-assert (memq thing all-keys) nil "Unknown keyword %S" thing)))
(let ((fetcher (plist-get plist :fetcher))) (let ((fetcher (plist-get plist :fetcher)))
(cl-assert fetcher nil ":fetcher is missing") (cl-assert fetcher nil ":fetcher is missing")
(if (memq fetcher '(github gitlab)) (if (memq fetcher package-recipe--forge-fetchers)
(progn (progn
(cl-assert (plist-get plist :repo) ":repo is missing") (cl-assert (plist-get plist :repo) ":repo is missing")
(cl-assert (not (plist-get plist :url)) ":url is redundant")) (cl-assert (not (plist-get plist :url)) ":url is redundant"))