[bot] "built_in_updates" Wed Nov 16 15:46:08 UTC 2022

This commit is contained in:
SpacemacsBot 2022-11-16 15:46:08 +00:00 committed by Maxi Wolff
parent 2f190e5ae7
commit 85a386632a
2 changed files with 148 additions and 120 deletions

View File

@ -12,7 +12,7 @@
;; Homepage: https://github.com/melpa/package-build
;; Keywords: maint tools
;; Package-Version: 3.1-git
;; Package-Version: 3.2-git
;; Package-Requires: ((emacs "25.1"))
;; SPDX-License-Identifier: GPL-3.0-or-later
@ -116,6 +116,14 @@ of the recipe."
:set-after '(package-build-stable)
:type 'function)
(defcustom package-build-predicate-function nil
"Predicate used by `package-build-all' to determine which packages to build.
If non-nil, this function is called with the recipe object as
argument, and must return non-nil if the package is to be build.
If nil (the default), then all packages are build."
:group 'package-build
:type '(choice (const :tag "build all") function))
(defcustom package-build-timeout-executable "timeout"
"Path to a GNU coreutils \"timeout\" command if available.
This must be a version which supports the \"-k\" option.
@ -165,11 +173,8 @@ disallowed."
:group 'package-build
:type '(repeat string))
(defvar package-build-use-hg-purge
"Whether `package-build--package' runs \"hg purge\" in mercurial repos."
(let ((value (ignore-errors
(car (process-lines "hg" "config" "extensions.purge")))))
(and value (not (string-prefix-p "!" value)))))
(defvar package-build-use-git-remote-hg nil
"Whether to use `git-remote-hg' remote helper for mercurial repos.")
(defvar package-build--inhibit-fetch nil
"Whether to inhibit fetching. Useful for testing purposes.")
@ -186,6 +191,7 @@ Otherwise do nothing. FORMAT-STRING and ARGS are as per that function."
(apply #'message format-string args)))
;;; Version Handling
;;;; Release
(defun package-build-get-tag-version (rcp)
(let ((regexp (or (oref rcp version-regexp) package-build-version-regexp))
@ -208,6 +214,18 @@ Otherwise do nothing. FORMAT-STRING and ARGS are as per that function."
(cons (package-build--get-commit rcp tag)
(package-version-join version))))
(cl-defmethod package-build--get-commit ((rcp package-git-recipe) &optional rev)
(let ((default-directory (package-recipe--working-tree rcp)))
(car (process-lines "git" "rev-parse" (or rev "HEAD")))))
(cl-defmethod package-build--get-commit ((rcp package-hg-recipe) &optional rev)
(let ((default-directory (package-recipe--working-tree rcp)))
;; "--debug" is needed to get the full hash.
(car (apply #'process-lines "hg" "--debug" "identify" "--id"
(and rev (list "--rev" rev))))))
;;;; Snapshot
(defun package-build-get-timestamp-version (rcp)
(pcase-let ((`(,hash . ,time) (package-build--get-timestamp rcp)))
(cons hash
@ -217,6 +235,38 @@ Otherwise do nothing. FORMAT-STRING and ARGS are as per that function."
(format "%d" (string-to-number
(format-time-string "%H%M" time t)))))))
(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-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))))
;;; Run Process
(defun package-build--run-process (directory destination command &rest args)
@ -258,7 +308,6 @@ Otherwise do nothing. FORMAT-STRING and ARGS are as per that function."
(kill-buffer temp-buffer)))))
;;; Checkout
;;;; Git
(cl-defmethod package-build--checkout ((rcp package-git-recipe))
(let ((dir (package-recipe--working-tree rcp))
@ -296,42 +345,6 @@ Otherwise do nothing. FORMAT-STRING and ARGS are as per that function."
(package-build--checkout-1 rcp rev)
version)))
(cl-defmethod package-build--checkout-1 ((rcp package-git-recipe) rev)
(unless package-build--inhibit-checkout
(package-build--message "Checking out %s" rev)
(package-build--run-process (package-recipe--working-tree rcp)
nil "git" "reset" "--hard" rev)))
(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)))
(string-to-number
(car (process-lines "git" "log" "-n1" "--first-parent"
"--pretty=format:%cd" "--date=unix" rev)))))
(cl-defmethod package-build--get-commit ((rcp package-git-recipe) &optional rev)
(let ((default-directory (package-recipe--working-tree rcp)))
(car (process-lines "git" "rev-parse" (or rev "HEAD")))))
;;;; Hg
(cl-defmethod package-build--checkout ((rcp package-hg-recipe))
(let ((dir (package-recipe--working-tree rcp))
(url (package-recipe--upstream-url rcp)))
@ -353,41 +366,18 @@ Otherwise do nothing. FORMAT-STRING and ARGS are as per that function."
(package-build--checkout-1 rcp rev)
version)))
(cl-defmethod package-build--checkout-1 ((rcp package-git-recipe) rev)
(unless package-build--inhibit-checkout
(package-build--message "Checking out %s" rev)
(package-build--run-process (package-recipe--working-tree rcp)
nil "git" "reset" "--hard" rev)))
(cl-defmethod package-build--checkout-1 ((rcp package-hg-recipe) 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)))
(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)))
(string-to-number
(car (split-string
(car (process-lines "hg" "log" "--limit" "1"
"--template" "{date|hgdate}\n"
"--rev" rev))
" ")))))
(cl-defmethod package-build--get-commit ((rcp package-hg-recipe) &optional rev)
(let ((default-directory (package-recipe--working-tree rcp)))
;; "--debug" is needed to get the full hash.
(car (apply #'process-lines "hg" "--debug" "identify" "--id"
(and rev (list "--rev" rev))))))
;;; Generate Files
(defun package-build--write-pkg-file (desc dir)
@ -807,8 +797,7 @@ in `package-build-archive-dir'."
(cond ((cl-typep rcp 'package-git-recipe)
(package-build--run-process
source-dir nil "git" "clean" "-f" "-d" "-x"))
((and (cl-typep rcp 'package-hg-recipe)
package-build-use-hg-purge)
((cl-typep rcp 'package-hg-recipe)
(package-build--run-process source-dir nil "hg" "purge"))))))
(defun package-build--build-single-file-package (rcp version commit files source-dir)
@ -858,34 +847,61 @@ in `package-build-archive-dir'."
(package-build--write-archive-entry desc))
(delete-directory tmp-dir t nil))))
(cl-defmethod package-build--get-commit-time ((rcp package-git-recipe) rev)
(let ((default-directory (package-recipe--working-tree rcp)))
(string-to-number
(car (process-lines "git" "log" "-n1" "--first-parent"
"--pretty=format:%cd" "--date=unix" rev)))))
(cl-defmethod package-build--get-commit-time ((rcp package-hg-recipe) rev)
(let ((default-directory (package-recipe--working-tree rcp)))
(string-to-number
(car (split-string
(car (process-lines "hg" "log" "--limit" "1"
"--template" "{date|hgdate}\n"
"--rev" rev))
" ")))))
;;;###autoload
(defun package-build-all ()
"Build a package for each of the available recipes."
"Build a package for each of the available recipes.
If `package-build-predicate-function' is non-nil, then only
packages for which that returns non-nil are build."
(interactive)
(let* ((recipes (package-recipe-recipes))
(let* ((start (current-time))
(recipes (package-recipe-recipes))
(total (length recipes))
(success 0)
invalid failed)
skipped invalid failed)
(dolist (name recipes)
(let ((rcp (with-demoted-errors "Build error: %S"
(let ((rcp (with-demoted-errors "Recipe error: %S"
(package-recipe-lookup name))))
(if rcp
(if (with-demoted-errors "Build error: %S"
(package-build-archive name) t)
(cl-incf success)
(push name failed))
(push name invalid))))
(if (not (or invalid failed))
(message "Successfully built all %s packages" total)
(message "Successfully built %i of %s packages" success total)
(when invalid
(message "Did not built packages for %i invalid recipes:\n%s"
(length invalid)
(mapconcat (lambda (n) (concat " " n)) invalid "\n")))
(when failed
(message "Building %i packages failed:\n%s"
(length failed)
(mapconcat (lambda (n) (concat " " n)) failed "\n")))))
(cond ((not rcp)
(push name invalid))
((and package-build-predicate-function
(not (funcall package-build-predicate-function rcp)))
(push name skipped))
((with-demoted-errors "Build error: %S"
(package-build-archive name) t)
(cl-incf success))
((push name failed)))))
(let ((duration (/ (float-time (time-subtract (current-time) start)) 60)))
(if (not (or skipped invalid failed))
(message "Successfully built all %s packages (%.0fm)" total duration)
(message "Successfully built %i of %s packages (%.0fm)"
success total duration)
(when skipped
(message "Skipped %i packages:\n%s"
(length skipped)
(mapconcat (lambda (n) (concat " " n)) (nreverse skipped) "\n")))
(when invalid
(message "Did not built packages for %i invalid recipes:\n%s"
(length invalid)
(mapconcat (lambda (n) (concat " " n)) (nreverse invalid) "\n")))
(when failed
(message "Building %i packages failed:\n%s"
(length failed)
(mapconcat (lambda (n) (concat " " n)) (nreverse failed) "\n"))))))
(package-build-cleanup))
(defun package-build-cleanup ()

View File

@ -30,6 +30,7 @@
(require 'eieio)
(require 'url-parse)
(defvar package-build-use-git-remote-hg)
(defvar package-build-recipes-dir)
(defvar package-build-working-dir)
@ -50,31 +51,6 @@
(old-names :initarg :old-names :initform nil))
:abstract t)
(cl-defmethod package-recipe--working-tree ((rcp package-recipe))
(file-name-as-directory
(expand-file-name (oref rcp name) package-build-working-dir)))
(cl-defmethod package-recipe--upstream-url ((rcp package-recipe))
(or (oref rcp url)
(format (oref rcp url-format)
(oref rcp repo))))
(cl-defmethod package-recipe--upstream-protocol ((rcp package-recipe))
(let ((url (package-recipe--upstream-url rcp)))
(cond ((string-match "\\`\\([a-z]+\\)://" url)
(match-string 1 url))
((string-match "\\`[^:/ ]+:" url) "ssh")
(t "file"))))
(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) ())
@ -99,6 +75,40 @@
(defclass package-hg-recipe (package-recipe) ())
(defclass package-git-remote-hg-recipe (package-git-recipe) ())
;;; Methods
(cl-defmethod package-recipe--working-tree ((rcp package-recipe))
(file-name-as-directory
(expand-file-name (oref rcp name) package-build-working-dir)))
(cl-defmethod package-recipe--upstream-url ((rcp package-recipe))
(or (oref rcp url)
(format (oref rcp url-format)
(oref rcp repo))))
(cl-defmethod package-recipe--upstream-url ((rcp package-git-remote-hg-recipe))
(concat "hg::" (oref rcp url)))
(cl-defmethod package-recipe--upstream-protocol ((rcp package-recipe))
(let ((url (package-recipe--upstream-url rcp)))
(cond ((string-match "\\`\\([a-z]+\\)://" url)
(match-string 1 url))
((string-match "\\`[^:/ ]+:" url) "ssh")
(t "file"))))
(cl-defmethod package-recipe--fetcher ((rcp package-recipe))
(substring (symbol-name (eieio-object-class rcp)) 8 -7))
;;; Constants
(defconst package-recipe--forge-fetchers
'(github gitlab codeberg sourcehut))
(defconst package-recipe--fetchers
(append '(git hg) package-recipe--forge-fetchers))
;;; Interface
(defun package-recipe-recipes ()
@ -127,6 +137,8 @@ file is invalid, then raise an error."
(unless (eq key :fetcher)
(push val args)
(push key args)))
(when (and package-build-use-git-remote-hg (eq fetcher 'hg))
(setq fetcher 'git-remote-hg))
(apply (intern (format "package-%s-recipe" fetcher))
name :name name args))
(error "No such recipe: %s" name))))