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

[bot] "built_in_updates" Fri Sep 2 03:56:02 UTC 2022 (#15715)

Browse source
This commit is contained in:
SpacemacsBot 2022-09-02 07:01:29 +03:00 committed by GitHub
parent ea0276309b
commit 73b3b0fed8
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
1 changed files with 109 additions and 142 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

251
core/libs/package-build.el
View file

@ -186,19 +186,27 @@ Otherwise do nothing. FORMAT-STRING and ARGS are as per that function."
(apply #'message format-string args))) (apply #'message format-string args)))
;;; Version Handling ;;; Version Handling
;;;; Public
(defun package-build-get-tag-version (rcp) (defun package-build-get-tag-version (rcp)
(pcase-let ((`(,tag . ,version) (let ((regexp (or (oref rcp version-regexp) package-build-version-regexp))
(package-build--find-version-newest (tag nil)
(package-build--list-tags rcp) (version '(0)))
(oref rcp version-regexp)))) (dolist (n (let ((default-directory (package-recipe--working-tree rcp)))
(cl-etypecase rcp
(package-git-recipe (process-lines "git" "tag" "--list"))
(package-hg-recipe (process-lines "hg" "tags" "--quiet")))))
(let ((v (ignore-errors
(version-to-list (and (string-match regexp n)
(match-string 1 n))))))
(when (and v (version-list-<= version v))
(if (cl-typep rcp 'package-git-recipe)
(setq tag (concat "refs/tags/" n))
(setq tag n))
(setq version v))))
(unless tag (unless tag
(error "No valid stable versions found for %s" (oref rcp name))) (error "No valid stable versions found for %s" (oref rcp name)))
(when (cl-typep rcp 'package-git-recipe)
(setq tag (concat "tags/" tag)))
(cons (package-build--get-commit rcp tag) (cons (package-build--get-commit rcp tag)
version))) (package-version-join version))))
(defun package-build-get-timestamp-version (rcp) (defun package-build-get-timestamp-version (rcp)
(pcase-let ((`(,hash . ,time) (package-build--get-timestamp rcp))) (pcase-let ((`(,hash . ,time) (package-build--get-timestamp rcp)))
@ -209,76 +217,47 @@ Otherwise do nothing. FORMAT-STRING and ARGS are as per that function."
(format "%d" (string-to-number (format "%d" (string-to-number
(format-time-string "%H%M" time t))))))) (format-time-string "%H%M" time t)))))))
;;;; Internal
(defun package-build--find-version-newest (tags &optional regexp)
"Find the newest version in TAGS matching REGEXP.
If optional REGEXP is nil, then `package-build-version-regexp'
is used instead."
(let ((ret '(nil 0))
(regexp (or regexp package-build-version-regexp)))
(cl-flet ((match (regexp separator tag)
(let* ((version-string (and (string-match regexp tag)
(match-string 1 tag)))
(version-separator separator)
(version (ignore-errors (version-to-list version-string))))
(when (and version (version-list-<= (cdr ret) version))
(setq ret (cons tag version))))))
(dolist (tag tags)
(match regexp "." tag)
;; Some version tags use "_" as version separator instead of
;; the default ".", e.g. "1_4_5". Check for valid versions
;; again, this time using "_" as a `version-separator'.
;; Since "_" is otherwise treated as a snapshot separator by
;; `version-regexp-alist', we don't have to worry about the
;; incorrect version list above `(1 -4 4 -4 5)' since it will
;; always be treated as smaller by `version-list-<'.
(match regexp "_" tag)))
(and (car ret)
(cons (car ret)
(package-version-join (cdr ret))))))
;;; Run Process ;;; Run Process
(defun package-build--run-process (directory destination command &rest args) (defun package-build--run-process (directory destination command &rest args)
(setq directory (file-name-as-directory (or directory default-directory))) (setq directory (file-name-as-directory (or directory default-directory)))
(with-current-buffer (let (temp-buffer)
(if (eq destination t) (unwind-protect
(current-buffer) (with-current-buffer
(or destination (get-buffer-create "*package-build-checkout*"))) (cond ((eq destination t) (current-buffer))
(unless destination (destination)
(setq default-directory directory)) ((setq temp-buffer (generate-new-buffer " *temp*"))))
(let ((default-directory directory) (unless destination
(argv (nconc (unless (eq system-type 'windows-nt) (setq default-directory directory))
(list "env" "LC_ALL=C")) (let ((default-directory directory)
(if (and package-build-timeout-secs (argv (nconc (unless (eq system-type 'windows-nt)
package-build-timeout-executable) (list "env" "LC_ALL=C"))
(nconc (list package-build-timeout-executable (if (and package-build-timeout-secs
"-k" "60" (number-to-string package-build-timeout-executable)
package-build-timeout-secs) (nconc (list package-build-timeout-executable
command) "-k" "60"
args) (number-to-string
(cons command args))))) package-build-timeout-secs)
(unless (file-directory-p default-directory) command)
(error "Can't run process in non-existent directory: %s" default-directory)) args)
(let ((exit-code (apply #'call-process (cons command args)))))
(car argv) nil (current-buffer) nil (unless (file-directory-p default-directory)
(cdr argv)))) (error "Cannot run process in non-existent directory: %s"
(unless (zerop exit-code) default-directory))
(message "\nCommand '%s' exited with non-zero exit-code: %d\n" (let ((exit-code (apply #'call-process
(mapconcat #'shell-quote-argument argv " ") (car argv) nil (current-buffer) nil
exit-code) (cdr argv))))
(message "%s" (buffer-string)) (unless (zerop exit-code)
(error "Command exited with non-zero exit-code: %d" exit-code)))))) (message "\nCommand '%s' exited with non-zero exit-code: %d\n"
(mapconcat #'shell-quote-argument argv " ")
exit-code)
(message "%s" (buffer-string))
(error "Command exited with non-zero exit-code: %d"
exit-code)))))
(when temp-buffer
(kill-buffer temp-buffer)))))
;;; Checkout ;;; Checkout
;;;; Common
(cl-defmethod package-build--checkout :before ((rcp package-recipe))
(package-build--message "Package: %s" (oref rcp name))
(package-build--message "Fetcher: %s" (package-recipe--fetcher rcp))
(package-build--message "Source: %s\n" (package-recipe--upstream-url rcp)))
;;;; Git ;;;; Git
(cl-defmethod package-build--checkout ((rcp package-git-recipe)) (cl-defmethod package-build--checkout ((rcp package-git-recipe))
@ -289,7 +268,9 @@ is used instead."
(error "Fetching using the %s protocol is not allowed" protocol)) (error "Fetching using the %s protocol is not allowed" protocol))
(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)) (let ((default-directory dir))
(string= (car (process-lines "git" "config" "remote.origin.url"))
url)))
(unless package-build--inhibit-fetch (unless package-build--inhibit-fetch
(package-build--message "Updating %s" dir) (package-build--message "Updating %s" dir)
(package-build--run-process dir nil "git" "fetch" "-f" "--all" "--tags") (package-build--run-process dir nil "git" "fetch" "-f" "--all" "--tags")
@ -318,12 +299,8 @@ is used instead."
(cl-defmethod package-build--checkout-1 ((rcp package-git-recipe) rev) (cl-defmethod package-build--checkout-1 ((rcp package-git-recipe) rev)
(unless package-build--inhibit-checkout (unless package-build--inhibit-checkout
(package-build--message "Checking out %s" rev) (package-build--message "Checking out %s" rev)
(let ((dir (package-recipe--working-tree rcp))) (package-build--run-process (package-recipe--working-tree rcp)
(package-build--run-process dir nil "git" "reset" "--hard" rev)))) 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)) (cl-defmethod package-build--get-timestamp ((rcp package-git-recipe))
(pcase-let* (pcase-let*
@ -349,10 +326,6 @@ is used instead."
(car (process-lines "git" "log" "-n1" "--first-parent" (car (process-lines "git" "log" "-n1" "--first-parent"
"--pretty=format:%cd" "--date=unix" rev))))) "--pretty=format:%cd" "--date=unix" rev)))))
(cl-defmethod package-build--used-url ((rcp package-git-recipe))
(let ((default-directory (package-recipe--working-tree rcp)))
(car (process-lines "git" "config" "remote.origin.url"))))
(cl-defmethod package-build--get-commit ((rcp package-git-recipe) &optional rev) (cl-defmethod package-build--get-commit ((rcp package-git-recipe) &optional rev)
(let ((default-directory (package-recipe--working-tree rcp))) (let ((default-directory (package-recipe--working-tree rcp)))
(car (process-lines "git" "rev-parse" (or rev "HEAD"))))) (car (process-lines "git" "rev-parse" (or rev "HEAD")))))
@ -364,7 +337,8 @@ is used instead."
(url (package-recipe--upstream-url rcp))) (url (package-recipe--upstream-url rcp)))
(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)) (let ((default-directory dir))
(string= (car (process-lines "hg" "paths" "default")) url)))
(unless package-build--inhibit-fetch (unless package-build--inhibit-fetch
(package-build--message "Updating %s" dir) (package-build--message "Updating %s" dir)
(package-build--run-process dir nil "hg" "pull") (package-build--run-process dir nil "hg" "pull")
@ -385,14 +359,6 @@ is used instead."
(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)))
(cl-defmethod package-build--list-tags ((rcp package-hg-recipe))
(let ((default-directory (package-recipe--working-tree rcp)))
(mapcar (lambda (line)
;; Remove space and rev that follow ref.
(string-match "\\`[^ ]+" line)
(match-string 0))
(process-lines "hg" "tags"))))
(cl-defmethod package-build--get-timestamp ((rcp package-hg-recipe)) (cl-defmethod package-build--get-timestamp ((rcp package-hg-recipe))
(pcase-let* (pcase-let*
((default-directory (package-recipe--working-tree rcp)) ((default-directory (package-recipe--working-tree rcp))
@ -416,16 +382,11 @@ is used instead."
"--rev" rev)) "--rev" rev))
" "))))) " ")))))
(cl-defmethod package-build--used-url ((rcp package-hg-recipe))
(let ((default-directory (package-recipe--working-tree rcp)))
(car (process-lines "hg" "paths" "default"))))
(cl-defmethod package-build--get-commit ((rcp package-hg-recipe) &optional rev) (cl-defmethod package-build--get-commit ((rcp package-hg-recipe) &optional rev)
(let ((default-directory (package-recipe--working-tree rcp))) (let ((default-directory (package-recipe--working-tree rcp)))
;; "--debug" is needed to get the full hash. ;; "--debug" is needed to get the full hash.
(car (apply #'process-lines "hg" "--debug" "id" "-i" (car (apply #'process-lines "hg" "--debug" "identify" "--id"
(and rev (list rev)))))) (and rev (list "--rev" rev))))))
;;; Generate Files ;;; Generate Files
@ -551,33 +512,29 @@ Any existing header will be preserved and given the \"X-Original-\" prefix.
If VALUE is nil, the new header will not be inserted, but any original will If VALUE is nil, the new header will not be inserted, but any original will
still be renamed." still be renamed."
(goto-char (point-min)) (goto-char (point-min))
(if (let ((case-fold-search t)) (cond
(re-search-forward (concat "^;+* *" (regexp-quote name) " *: *") nil t)) ((let ((case-fold-search t))
(progn (re-search-forward (format "^;+* *%s *: *" (regexp-quote name)) nil t))
(move-beginning-of-line nil) (move-beginning-of-line nil)
(search-forward "V" nil t) (search-forward "V" nil t)
(backward-char) (backward-char)
(insert "X-Original-") (insert "X-Original-")
(move-beginning-of-line nil)) (move-beginning-of-line nil))
;; Put the new header in a sensible place if we can (t
(re-search-forward "^;+* *\\(Version\\|Package-Requires\\|Keywords\\|URL\\) *:" ;; Put the new header in a sensible place if we can.
nil t) (re-search-forward
(forward-line)) "^;+* *\\(Version\\|Package-Requires\\|Keywords\\|URL\\) *:" nil t)
(insert (format ";; %s: %s" name value)) (forward-line)))
(newline)) (insert (format ";; %s: %s\n" name value)))
(defun package-build--ensure-ends-here-line (file) (defun package-build--ensure-ends-here-line (file)
"Add a 'FILE ends here' trailing line if missing." "Add the \"FILE ends here\" trailing line if it is missing."
(save-excursion (save-excursion
(goto-char (point-min)) (goto-char (point-min))
(let ((trailer (concat ";;; " (let ((trailer (format ";;; %s ends here" (file-name-nondirectory file))))
(file-name-nondirectory file) (unless (re-search-forward (format "^%s" (regexp-quote trailer)) nil t)
" ends here")))
(unless (search-forward trailer nil t)
(goto-char (point-max)) (goto-char (point-max))
(newline) (insert ?\n trailer ?\n)))))
(insert trailer)
(newline)))))
;;; Package Structs ;;; Package Structs
@ -740,9 +697,8 @@ order and can have the following form:
(when (and rcp spec (when (and rcp spec
(equal files (package-build--expand-files-spec-1 (equal files (package-build--expand-files-spec-1
package-build-default-files-spec))) package-build-default-files-spec)))
(package-build--message (message "Warning: %s :files spec is equivalent to the default"
"Note: %s :files spec is equivalent to the default." (oref rcp name)))
(oref rcp name)))
(unless files (unless files
(error "No matching file(s) found in %s using %s" (error "No matching file(s) found in %s using %s"
default-directory (or spec "default spec")))) default-directory (or spec "default spec"))))
@ -801,23 +757,29 @@ FILES is a list of (SOURCE . DEST) relative filepath pairs."
If DUMP-ARCHIVE-CONTENTS is non-nil, the updated archive contents If DUMP-ARCHIVE-CONTENTS is non-nil, the updated archive contents
are subsequently dumped." are subsequently dumped."
(interactive (list (package-recipe-read-name) t)) (interactive (list (package-recipe-read-name) t))
(let ((start-time (current-time)) (unless (file-exists-p package-build-archive-dir)
(rcp (package-recipe-lookup name))) (package-build--message "Creating directory %s" package-build-archive-dir)
(unless (file-exists-p package-build-archive-dir) (make-directory package-build-archive-dir))
(package-build--message "Creating directory %s" package-build-archive-dir) (let* ((start-time (current-time))
(make-directory package-build-archive-dir)) (rcp (package-recipe-lookup name))
(url (package-recipe--upstream-url rcp))
(repo (oref rcp repo))
(fetcher (package-recipe--fetcher rcp)))
(cond ((not noninteractive)
(message " • Building package %s (from %s)..." name
(if repo (format "%s:%s" fetcher repo) url)))
(package-build-verbose
(message "Package: %s" name)
(message "Fetcher: %s" fetcher)
(message "Source: %s\n" url)))
(let ((default-directory package-build-working-dir) (let ((default-directory package-build-working-dir)
(version (package-build--checkout rcp))) (version (package-build--checkout rcp)))
(package-build--package rcp version) (package-build--package rcp version)
(when package-build-write-melpa-badge-images (when dump-archive-contents
(package-build--write-melpa-badge-image (package-build-dump-archive-contents))
name version package-build-archive-dir)) (message "Built %s in %.3fs, finished at %s" name
(package-build--message "Built %s in %.3fs, finished at %s" (float-time (time-since start-time))
name (format-time-string "%FT%T%z" nil t)))))
(float-time (time-since start-time))
(format-time-string "%FT%T%z" nil t))))
(when dump-archive-contents
(package-build-dump-archive-contents)))
;;;###autoload ;;;###autoload
(defun package-build--package (rcp version) (defun package-build--package (rcp version)
@ -826,18 +788,22 @@ Return the archive entry for the package and store the package
in `package-build-archive-dir'." in `package-build-archive-dir'."
(let ((source-dir (package-recipe--working-tree rcp))) (let ((source-dir (package-recipe--working-tree rcp)))
(unwind-protect (unwind-protect
(let ((files (package-build-expand-files-spec rcp t)) (let ((name (oref rcp name))
(files (package-build-expand-files-spec rcp t))
(commit (package-build--get-commit rcp))) (commit (package-build--get-commit rcp)))
(cond (cond
((not version) ((not version)
(error "Unable to check out repository for %s" (oref rcp name))) (error "Unable to check out repository for %s" name))
((= (length files) 1) ((= (length files) 1)
(package-build--build-single-file-package (package-build--build-single-file-package
rcp version commit files source-dir)) rcp version commit files source-dir))
((> (length files) 1) ((> (length files) 1)
(package-build--build-multi-file-package (package-build--build-multi-file-package
rcp version commit files source-dir)) rcp version commit files source-dir))
(t (error "Unable to find files matching recipe patterns")))) (t (error "Unable to find files matching recipe patterns")))
(when package-build-write-melpa-badge-images
(package-build--write-melpa-badge-image
name version package-build-archive-dir)))
(cond ((cl-typep rcp 'package-git-recipe) (cond ((cl-typep rcp 'package-git-recipe)
(package-build--run-process (package-build--run-process
source-dir nil "git" "clean" "-f" "-d" "-x")) source-dir nil "git" "clean" "-f" "-d" "-x"))
@ -860,7 +826,8 @@ in `package-build-archive-dir'."
(error "Single file %s does not match package name %s" file name)) (error "Single file %s does not match package name %s" file name))
(copy-file source target t) (copy-file source target t)
(let ((enable-local-variables nil) (let ((enable-local-variables nil)
(make-backup-files nil)) (make-backup-files nil)
(before-save-hook nil))
(with-current-buffer (find-file target) (with-current-buffer (find-file target)
(package-build--update-or-insert-header "Package-Commit" commit) (package-build--update-or-insert-header "Package-Commit" commit)
(package-build--update-or-insert-header "Package-Version" version) (package-build--update-or-insert-header "Package-Version" version)