TakeV
/
spacemacs
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

[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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

101
core/libs/package-build.el
View File

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

3
core/libs/package-recipe-mode.el
View File

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

16
core/libs/package-recipe.el
View File

@ -69,6 +69,12 @@
(cl-defmethod package-recipe--fetcher ((rcp package-recipe))
(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
(defclass package-git-recipe (package-recipe) ())
@ -81,6 +87,14 @@
((url-format :initform "https://gitlab.com/%s.git")
(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
(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)))
(let ((fetcher (plist-get plist :fetcher)))
(cl-assert fetcher nil ":fetcher is missing")
(if (memq fetcher '(github gitlab))
(if (memq fetcher package-recipe--forge-fetchers)
(progn
(cl-assert (plist-get plist :repo) ":repo is missing")
(cl-assert (not (plist-get plist :url)) ":url is redundant"))