1045 lines
42 KiB
EmacsLisp
1045 lines
42 KiB
EmacsLisp
;;; package-build.el --- Tools for assembling a package archive
|
|
|
|
;; Copyright (C) 2011-2020 Donald Ephraim Curtis <dcurtis@milkbox.net>
|
|
;; Copyright (C) 2012-2020 Steve Purcell <steve@sanityinc.com>
|
|
;; Copyright (C) 2016-2020 Jonas Bernoulli <jonas@bernoul.li>
|
|
;; Copyright (C) 2009 Phil Hagelberg <technomancy@gmail.com>
|
|
|
|
;; Author: Donald Ephraim Curtis <dcurtis@milkbox.net>
|
|
;; Keywords: tools
|
|
;; Package-Requires: ((cl-lib "0.5") (emacs "24.1"))
|
|
|
|
;; This file is not (yet) part of GNU Emacs.
|
|
;; However, it is distributed under the same license.
|
|
|
|
;; GNU Emacs is free software; you can redistribute it and/or modify
|
|
;; it under the terms of the GNU General Public License as published by
|
|
;; the Free Software Foundation; either version 3, or (at your option)
|
|
;; any later version.
|
|
|
|
;; GNU Emacs is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;; GNU General Public License for more details.
|
|
|
|
;; You should have received a copy of the GNU General Public License
|
|
;; along with GNU Emacs; see the file COPYING. If not, write to the
|
|
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
|
;; Boston, MA 02110-1301, USA.
|
|
|
|
;;; Commentary:
|
|
|
|
;; This file allows a curator to publish an archive of Emacs packages.
|
|
|
|
;; The archive is generated from a set of recipes which describe elisp
|
|
;; projects and repositories from which to get them. The term
|
|
;; "package" here is used to mean a specific version of a project that
|
|
;; is prepared for download and installation.
|
|
|
|
;;; Code:
|
|
|
|
(require 'cl-lib)
|
|
|
|
(require 'package)
|
|
(require 'lisp-mnt)
|
|
(require 'json)
|
|
|
|
(require 'package-recipe)
|
|
|
|
;;; Options
|
|
|
|
(defconst package-build--melpa-base
|
|
(file-name-directory
|
|
(directory-file-name
|
|
(file-name-directory (or load-file-name (buffer-file-name))))))
|
|
|
|
(defgroup package-build nil
|
|
"Facilities for building package.el-compliant packages from upstream source code."
|
|
:group 'development)
|
|
|
|
(defcustom package-build-working-dir
|
|
(expand-file-name "working/" package-build--melpa-base)
|
|
"Directory in which to keep checkouts."
|
|
:group 'package-build
|
|
:type 'string)
|
|
|
|
(defcustom package-build-archive-dir
|
|
(expand-file-name "packages/" package-build--melpa-base)
|
|
"Directory in which to keep compiled archives."
|
|
:group 'package-build
|
|
:type 'string)
|
|
|
|
(defcustom package-build-recipes-dir
|
|
(expand-file-name "recipes/" package-build--melpa-base)
|
|
"Directory containing recipe files."
|
|
:group 'package-build
|
|
:type 'string)
|
|
|
|
(defcustom package-build-verbose t
|
|
"When non-nil, then print additional progress information."
|
|
:group 'package-build
|
|
:type 'boolean)
|
|
|
|
(defcustom package-build-stable nil
|
|
"When non-nil, then try to build packages from versions-tagged code."
|
|
:group 'package-build
|
|
:type 'boolean)
|
|
|
|
(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.
|
|
|
|
On MacOS it is possible to install coreutils using Homebrew or
|
|
similar, which will provide the GNU timeout program as
|
|
\"gtimeout\"."
|
|
:group 'package-build
|
|
:type '(file :must-match t))
|
|
|
|
(defcustom package-build-timeout-secs nil
|
|
"Wait this many seconds for external processes to complete.
|
|
|
|
If an external process takes longer than specified here to
|
|
complete, then it is terminated. If nil, then no time limit is
|
|
applied. This setting requires
|
|
`package-build-timeout-executable' to be set."
|
|
:group 'package-build
|
|
:type 'number)
|
|
|
|
(defcustom package-build-tar-executable "tar"
|
|
"Path to a (preferably GNU) tar command.
|
|
Certain package names (e.g. \"@\") may not work properly with a BSD tar.
|
|
|
|
On MacOS it is possible to install coreutils using Homebrew or
|
|
similar, which will provide the GNU timeout program as
|
|
\"gtar\"."
|
|
:group 'package-build
|
|
:type '(file :must-match t))
|
|
|
|
(defcustom package-build-write-melpa-badge-images nil
|
|
"When non-nil, write MELPA badge images alongside packages.
|
|
These batches can, for example, be used on GitHub pages."
|
|
:group 'package-build
|
|
:type 'boolean)
|
|
|
|
(defcustom package-build-version-regexp "^[rRvV]?\\(.*\\)$"
|
|
"Default pattern for matching valid version-strings within repository tags.
|
|
The string in the capture group should be parsed as valid by `version-to-list'."
|
|
:group 'package-build
|
|
:type 'string)
|
|
|
|
;;; Generic Utilities
|
|
|
|
(defun package-build--message (format-string &rest args)
|
|
"Behave like `message' if `package-build-verbose' is non-nil.
|
|
Otherwise do nothing. FORMAT-STRING and ARGS are as per that function."
|
|
(when package-build-verbose
|
|
(apply 'message format-string args)))
|
|
|
|
;;; Version Handling
|
|
|
|
(defun package-build--parse-time (str &optional regexp)
|
|
"Parse STR as a time, and format as a YYYYMMDD.HHMM string.
|
|
Always use Coordinated Universal Time (UTC) for output string.
|
|
If REGEXP is provided, it is applied to STR and the function
|
|
parses the first match group instead of STR."
|
|
(unless str
|
|
(error "No valid timestamp found"))
|
|
(setq str (substring-no-properties str))
|
|
(when regexp
|
|
(if (string-match regexp str)
|
|
(setq str (match-string 1 str))
|
|
(error "No valid timestamp found")))
|
|
;; We remove zero-padding the HH portion, as it is lost
|
|
;; when stored in the archive-contents
|
|
(let ((time (date-to-time
|
|
(if (string-match "\
|
|
^\\([0-9]\\{4\\}\\)/\\([0-9]\\{2\\}\\)/\\([0-9]\\{2\\}\\) \
|
|
\\([0-9]\\{2\\}:[0-9]\\{2\\}:[0-9]\\{2\\}\\)$" str)
|
|
(concat (match-string 1 str) "-" (match-string 2 str) "-"
|
|
(match-string 3 str) " " (match-string 4 str))
|
|
str))))
|
|
(concat (format-time-string "%Y%m%d." time t)
|
|
(format "%d" (string-to-number (format-time-string "%H%M" time t))))))
|
|
|
|
(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)))
|
|
(dolist (tag tags)
|
|
(string-match (or regexp package-build-version-regexp) tag)
|
|
(let ((version (ignore-errors (version-to-list (match-string 1 tag)))))
|
|
(when (and version (version-list-<= (cdr ret) version))
|
|
(setq ret (cons tag version))))
|
|
;; 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-<'.
|
|
(string-match (or regexp package-build-version-regexp) tag)
|
|
(let* ((version-separator "_")
|
|
(version (ignore-errors (version-to-list (match-string 1 tag)))))
|
|
(when (and version (version-list-<= (cdr ret) version))
|
|
(setq ret (cons tag version)))))
|
|
(and (car ret)
|
|
(cons (car ret)
|
|
(package-version-join (cdr ret))))))
|
|
|
|
;;; Run Process
|
|
|
|
(defun package-build--run-process (directory destination command &rest args)
|
|
(with-current-buffer
|
|
(if (eq destination t)
|
|
(current-buffer)
|
|
(or destination (get-buffer-create "*package-build-checkout*")))
|
|
(let ((default-directory
|
|
(file-name-as-directory (or directory default-directory)))
|
|
(argv (nconc (unless (eq system-type 'windows-nt)
|
|
(list "env" "LC_ALL=C"))
|
|
(if (and package-build-timeout-secs package-build-timeout-executable)
|
|
(nconc (list package-build-timeout-executable
|
|
"-k" "60" (number-to-string
|
|
package-build-timeout-secs)
|
|
command)
|
|
args)
|
|
(cons command args)))))
|
|
(unless (file-directory-p default-directory)
|
|
(error "Can't run process in non-existent directory: %s" default-directory))
|
|
(let ((exit-code (apply 'process-file
|
|
(car argv) nil (current-buffer) t
|
|
(cdr argv))))
|
|
(or (zerop exit-code)
|
|
(error "Command '%s' exited with non-zero status %d: %s"
|
|
argv exit-code (buffer-string)))))))
|
|
|
|
(defun package-build--run-process-match (regexp directory command &rest args)
|
|
(with-temp-buffer
|
|
(apply 'package-build--run-process directory t command args)
|
|
(goto-char (point-min))
|
|
(re-search-forward regexp)
|
|
(match-string-no-properties 1)))
|
|
|
|
(defun package-build--process-lines (directory command &rest args)
|
|
(with-temp-buffer
|
|
(apply 'package-build--run-process directory t command args)
|
|
(split-string (buffer-string) "\n" t)))
|
|
|
|
;;; Checkout
|
|
;;;; Common
|
|
|
|
(defmethod package-build--checkout :before ((rcp package-recipe))
|
|
(package-build--message "Package: %s" (oref rcp name))
|
|
(package-build--message "Fetcher: %s"
|
|
(substring (symbol-name
|
|
(with-no-warnings
|
|
;; Use eieio-object-class once we
|
|
;; no longer support Emacs 24.3.
|
|
(object-class-fast rcp)))
|
|
8 -7))
|
|
(package-build--message "Source: %s\n" (package-recipe--upstream-url rcp)))
|
|
|
|
;;;; Git
|
|
|
|
(defmethod package-build--checkout ((rcp package-git-recipe))
|
|
(let ((dir (package-recipe--working-tree rcp))
|
|
(url (package-recipe--upstream-url rcp)))
|
|
(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"))
|
|
(t
|
|
(when (file-exists-p dir)
|
|
(delete-directory dir t))
|
|
(package-build--message "Cloning %s to %s" url dir)
|
|
(package-build--run-process nil nil "git" "clone" url dir)))
|
|
(if package-build-stable
|
|
(cl-destructuring-bind (tag . version)
|
|
(or (package-build--find-version-newest
|
|
(let ((default-directory (package-recipe--working-tree rcp)))
|
|
(process-lines "git" "tag"))
|
|
(oref rcp version-regexp))
|
|
(error "No valid stable versions found for %s" (oref rcp name)))
|
|
(package-build--checkout-1 rcp (concat "tags/" tag))
|
|
version)
|
|
(package-build--checkout-1 rcp)
|
|
(package-build--parse-time
|
|
(car (apply #'package-build--process-lines dir
|
|
"git" "log" "--first-parent" "-n1" "--pretty=format:'\%ci'"
|
|
(package-build--expand-source-file-list rcp)))
|
|
(oref rcp tag-regexp)))))
|
|
|
|
(defmethod package-build--checkout-1 ((rcp package-git-recipe) &optional rev)
|
|
(let ((dir (package-recipe--working-tree rcp)))
|
|
(unless rev
|
|
(setq rev (or (oref rcp commit)
|
|
(concat "origin/"
|
|
(or (oref rcp branch)
|
|
(ignore-errors
|
|
(package-build--run-process-match
|
|
"HEAD branch: \\(.*\\)" dir
|
|
"git" "remote" "show" "origin"))
|
|
"master")))))
|
|
(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")))
|
|
|
|
(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"))))
|
|
|
|
;;;; Hg
|
|
|
|
(defmethod package-build--checkout ((rcp package-hg-recipe))
|
|
(let ((dir (package-recipe--working-tree rcp))
|
|
(url (package-recipe--upstream-url rcp)))
|
|
(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"))
|
|
(t
|
|
(when (file-exists-p dir)
|
|
(delete-directory dir t))
|
|
(package-build--message "Cloning %s to %s" url dir)
|
|
(package-build--run-process nil nil "hg" "clone" url dir)))
|
|
(if package-build-stable
|
|
(cl-destructuring-bind (tag . version)
|
|
(or (package-build--find-version-newest
|
|
(mapcar (lambda (line)
|
|
;; Remove space and rev that follow ref.
|
|
(string-match "\\`[^ ]+" line)
|
|
(match-string 0))
|
|
(process-lines "hg" "tags"))
|
|
(oref rcp version-regexp))
|
|
(error "No valid stable versions found for %s" (oref rcp name)))
|
|
(package-build--run-process dir nil "hg" "update" tag)
|
|
version)
|
|
(package-build--parse-time
|
|
(car (apply #'package-build--process-lines dir
|
|
"hg" "log" "--style" "compact" "-l1"
|
|
(package-build--expand-source-file-list rcp)))
|
|
(oref rcp tag-regexp)))))
|
|
|
|
(defmethod package-build--used-url ((rcp package-hg-recipe))
|
|
(package-build--run-process-match "default = \\(.*\\)"
|
|
(package-recipe--working-tree rcp)
|
|
"hg" "paths"))
|
|
|
|
;;; Various Files
|
|
|
|
(defun package-build--write-pkg-file (pkg-file pkg-info)
|
|
"Write PKG-FILE containing PKG-INFO."
|
|
(with-temp-file pkg-file
|
|
(pp
|
|
`(define-package
|
|
,(aref pkg-info 0)
|
|
,(aref pkg-info 3)
|
|
,(aref pkg-info 2)
|
|
',(mapcar
|
|
(lambda (elt)
|
|
(list (car elt)
|
|
(package-version-join (cadr elt))))
|
|
(aref pkg-info 1))
|
|
;; Append our extra information
|
|
,@(cl-mapcan (lambda (entry)
|
|
(let ((value (cdr entry)))
|
|
(when (or (symbolp value) (listp value))
|
|
;; We must quote lists and symbols,
|
|
;; because Emacs 24.3 and earlier evaluate
|
|
;; the package information, which would
|
|
;; break for unquoted symbols or lists
|
|
(setq value (list 'quote value)))
|
|
(list (car entry) value)))
|
|
(when (> (length pkg-info) 4)
|
|
(aref pkg-info 4))))
|
|
(current-buffer))
|
|
(princ ";; Local Variables:\n;; no-byte-compile: t\n;; End:\n"
|
|
(current-buffer))))
|
|
|
|
(defun package-build--create-tar (file dir &optional files)
|
|
"Create a tar FILE containing the contents of DIR, or just FILES if non-nil."
|
|
(when (eq system-type 'windows-nt)
|
|
(setq file (replace-regexp-in-string "^\\([a-z]\\):" "/\\1" file)))
|
|
(apply 'process-file
|
|
package-build-tar-executable nil
|
|
(get-buffer-create "*package-build-checkout*")
|
|
nil "-cvf"
|
|
file
|
|
"--exclude=.git"
|
|
"--exclude=.hg"
|
|
(or (mapcar (lambda (fn) (concat dir "/" fn)) files) (list dir))))
|
|
|
|
(defun package-build--find-package-commentary (file-path)
|
|
"Get commentary section from FILE-PATH."
|
|
(when (file-exists-p file-path)
|
|
(with-temp-buffer
|
|
(insert-file-contents file-path)
|
|
(lm-commentary))))
|
|
|
|
(defun package-build--write-pkg-readme (target-dir commentary file-name)
|
|
"In TARGET-DIR, write COMMENTARY to a -readme.txt file prefixed with FILE-NAME."
|
|
(when commentary
|
|
(with-temp-buffer
|
|
(insert commentary)
|
|
;; Adapted from `describe-package-1'.
|
|
(goto-char (point-min))
|
|
(save-excursion
|
|
(when (re-search-forward "^;;; Commentary:\n" nil t)
|
|
(replace-match ""))
|
|
(while (re-search-forward "^\\(;+ ?\\)" nil t)
|
|
(replace-match ""))
|
|
(goto-char (point-min))
|
|
(when (re-search-forward "\\`\\( *\n\\)+" nil t)
|
|
(replace-match "")))
|
|
(delete-trailing-whitespace)
|
|
(let ((coding-system-for-write buffer-file-coding-system))
|
|
(write-region nil nil
|
|
(expand-file-name (concat file-name "-readme.txt")
|
|
target-dir))))))
|
|
|
|
;;; Entries
|
|
|
|
(defun package-build--update-or-insert-header (name value)
|
|
"Ensure current buffer has NAME header with the given VALUE.
|
|
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
|
|
still be renamed."
|
|
(goto-char (point-min))
|
|
(if (let ((case-fold-search t))
|
|
(re-search-forward (concat "^;+* *" (regexp-quote name) " *: *") nil t))
|
|
(progn
|
|
(move-beginning-of-line nil)
|
|
(search-forward "V" nil t)
|
|
(backward-char)
|
|
(insert "X-Original-")
|
|
(move-beginning-of-line nil))
|
|
;; Put the new header in a sensible place if we can
|
|
(re-search-forward "^;+* *\\(Version\\|Package-Requires\\|Keywords\\|URL\\) *:"
|
|
nil t)
|
|
(forward-line))
|
|
(insert (format ";; %s: %s" name value))
|
|
(newline))
|
|
|
|
(defun package-build--ensure-ends-here-line (file-path)
|
|
"Add a 'FILE-PATH ends here' trailing line if missing."
|
|
(save-excursion
|
|
(goto-char (point-min))
|
|
(let ((trailer (concat ";;; "
|
|
(file-name-nondirectory file-path)
|
|
" ends here")))
|
|
(unless (search-forward trailer nil t)
|
|
(goto-char (point-max))
|
|
(newline)
|
|
(insert trailer)
|
|
(newline)))))
|
|
|
|
(defun package-build--get-package-info (file-path)
|
|
"Get a vector of package info from the docstrings in FILE-PATH."
|
|
(when (file-exists-p file-path)
|
|
(ignore-errors
|
|
(with-temp-buffer
|
|
(insert-file-contents file-path)
|
|
;; next few lines are a hack for some packages that aren't
|
|
;; commented properly.
|
|
(package-build--update-or-insert-header "Package-Version" "0")
|
|
(package-build--ensure-ends-here-line file-path)
|
|
(cl-flet ((package-strip-rcs-id (str) "0"))
|
|
(package-build--package-buffer-info-vec))))))
|
|
|
|
(defun package-build--package-buffer-info-vec ()
|
|
"Return a vector of package info.
|
|
`package-buffer-info' returns a vector in older Emacs versions,
|
|
and a cl struct in Emacs HEAD. This wrapper normalises the results."
|
|
(let ((desc (package-buffer-info))
|
|
(keywords (lm-keywords-list)))
|
|
(if (fboundp 'package-desc-create)
|
|
(let ((extras (package-desc-extras desc)))
|
|
(when (and keywords (not (assq :keywords extras)))
|
|
(push (cons :keywords keywords) extras))
|
|
(vector (package-desc-name desc)
|
|
(package-desc-reqs desc)
|
|
(package-desc-summary desc)
|
|
(package-desc-version desc)
|
|
extras))
|
|
(let ((homepage (package-build--lm-homepage))
|
|
extras)
|
|
(when keywords (push (cons :keywords keywords) extras))
|
|
(when homepage (push (cons :url homepage) extras))
|
|
(vector (aref desc 0)
|
|
(aref desc 1)
|
|
(aref desc 2)
|
|
(aref desc 3)
|
|
extras)))))
|
|
|
|
(defun package-build--get-pkg-file-info (file-path)
|
|
"Get a vector of package info from \"-pkg.el\" file FILE-PATH."
|
|
(when (file-exists-p file-path)
|
|
(let ((package-def (with-temp-buffer
|
|
(insert-file-contents file-path)
|
|
(read (current-buffer)))))
|
|
(if (eq 'define-package (car package-def))
|
|
(let* ((pkgfile-info (cdr package-def))
|
|
(descr (nth 2 pkgfile-info))
|
|
(rest-plist (cl-subseq pkgfile-info (min 4 (length pkgfile-info))))
|
|
(extras (let (alist)
|
|
(while rest-plist
|
|
(unless (memq (car rest-plist) '(:kind :archive))
|
|
(let ((value (cadr rest-plist)))
|
|
(when value
|
|
(push (cons (car rest-plist)
|
|
(if (eq (car-safe value) 'quote)
|
|
(cadr value)
|
|
value))
|
|
alist))))
|
|
(setq rest-plist (cddr rest-plist)))
|
|
alist)))
|
|
(when (string-match "[\r\n]" descr)
|
|
(error "Illegal multi-line package description in %s" file-path))
|
|
(vector
|
|
(nth 0 pkgfile-info)
|
|
(mapcar
|
|
(lambda (elt)
|
|
(unless (symbolp (car elt))
|
|
(error "Invalid package name in dependency: %S" (car elt)))
|
|
(list (car elt) (version-to-list (cadr elt))))
|
|
(eval (nth 3 pkgfile-info)))
|
|
descr
|
|
(nth 1 pkgfile-info)
|
|
extras))
|
|
(error "No define-package found in %s" file-path)))))
|
|
|
|
(defun package-build--merge-package-info (pkg-info name version commit)
|
|
"Return a version of PKG-INFO updated with NAME, VERSION and info from CONFIG.
|
|
If PKG-INFO is nil, an empty one is created."
|
|
(let ((merged (or (copy-sequence pkg-info)
|
|
(vector name nil "No description available." version nil))))
|
|
(aset merged 0 name)
|
|
(aset merged 3 version)
|
|
(when commit
|
|
(aset merged 4 (cons (cons :commit commit) (elt pkg-info 4))))
|
|
merged))
|
|
|
|
(defun package-build--write-archive-entry (rcp pkg-info type)
|
|
(let ((entry (package-build--archive-entry rcp pkg-info type)))
|
|
(with-temp-file (package-build--archive-entry-file entry)
|
|
(print entry (current-buffer)))))
|
|
|
|
(defmethod package-build--get-commit ((rcp package-git-recipe))
|
|
(ignore-errors
|
|
(package-build--run-process-match
|
|
"\\(.*\\)"
|
|
(package-recipe--working-tree rcp)
|
|
"git" "rev-parse" "HEAD")))
|
|
|
|
(defmethod package-build--get-commit ((rcp package-hg-recipe))
|
|
(ignore-errors
|
|
(package-build--run-process-match
|
|
"changeset:[[:space:]]+[[:digit:]]+:\\([[:xdigit:]]+\\)"
|
|
(package-recipe--working-tree rcp)
|
|
"hg" "log" "--debug" "--limit=1")))
|
|
|
|
(defun package-build--archive-entry (rcp pkg-info type)
|
|
(let ((name (intern (aref pkg-info 0)))
|
|
(requires (aref pkg-info 1))
|
|
(desc (or (aref pkg-info 2) "No description available."))
|
|
(version (aref pkg-info 3))
|
|
(extras (and (> (length pkg-info) 4)
|
|
(aref pkg-info 4))))
|
|
(cons name
|
|
(vector (version-to-list version)
|
|
requires
|
|
desc
|
|
type
|
|
extras))))
|
|
|
|
(defun package-build--artifact-file (archive-entry)
|
|
"Return the path of the file in which the package for ARCHIVE-ENTRY is stored."
|
|
(let* ((name (car archive-entry))
|
|
(pkg-info (cdr archive-entry))
|
|
(version (package-version-join (aref pkg-info 0)))
|
|
(flavour (aref pkg-info 3)))
|
|
(expand-file-name
|
|
(format "%s-%s.%s" name version (if (eq flavour 'single) "el" "tar"))
|
|
package-build-archive-dir)))
|
|
|
|
(defun package-build--archive-entry-file (archive-entry)
|
|
"Return the path of the file in which the package for ARCHIVE-ENTRY is stored."
|
|
(let* ((name (car archive-entry))
|
|
(pkg-info (cdr archive-entry))
|
|
(version (package-version-join (aref pkg-info 0))))
|
|
(expand-file-name
|
|
(format "%s-%s.entry" name version)
|
|
package-build-archive-dir)))
|
|
|
|
;;; File Specs
|
|
|
|
(defconst package-build-default-files-spec
|
|
'("*.el" "*.el.in" "dir"
|
|
"*.info" "*.texi" "*.texinfo"
|
|
"doc/dir" "doc/*.info" "doc/*.texi" "doc/*.texinfo"
|
|
(:exclude ".dir-locals.el" "test.el" "tests.el" "*-test.el" "*-tests.el"))
|
|
"Default value for :files attribute in recipes.")
|
|
|
|
(defun package-build-expand-file-specs (dir specs &optional subdir allow-empty)
|
|
"In DIR, expand SPECS, optionally under SUBDIR.
|
|
The result is a list of (SOURCE . DEST), where SOURCE is a source
|
|
file path and DEST is the relative path to which it should be copied.
|
|
|
|
If the resulting list is empty, an error will be reported. Pass t
|
|
for ALLOW-EMPTY to prevent this error."
|
|
(let ((default-directory dir)
|
|
(prefix (if subdir (format "%s/" subdir) ""))
|
|
(lst))
|
|
(dolist (entry specs lst)
|
|
(setq lst
|
|
(if (consp entry)
|
|
(if (eq :exclude (car entry))
|
|
(cl-nset-difference lst
|
|
(package-build-expand-file-specs
|
|
dir (cdr entry) nil t)
|
|
:key 'car
|
|
:test 'equal)
|
|
(nconc lst
|
|
(package-build-expand-file-specs
|
|
dir
|
|
(cdr entry)
|
|
(concat prefix (car entry))
|
|
t)))
|
|
(nconc
|
|
lst (mapcar (lambda (f)
|
|
(let ((destname)))
|
|
(cons f
|
|
(concat prefix
|
|
(replace-regexp-in-string
|
|
"\\.el\\.in\\'"
|
|
".el"
|
|
(file-name-nondirectory f)))))
|
|
(file-expand-wildcards entry))))))
|
|
(when (and (null lst) (not allow-empty))
|
|
(error "No matching file(s) found in %s: %s" dir specs))
|
|
lst))
|
|
|
|
(defun package-build--config-file-list (rcp)
|
|
(let ((file-list (oref rcp files)))
|
|
(cond
|
|
((null file-list)
|
|
package-build-default-files-spec)
|
|
((eq :defaults (car file-list))
|
|
(append package-build-default-files-spec (cdr file-list)))
|
|
(t
|
|
file-list))))
|
|
|
|
(defun package-build--expand-source-file-list (rcp)
|
|
(mapcar 'car
|
|
(package-build-expand-file-specs
|
|
(package-recipe--working-tree rcp)
|
|
(package-build--config-file-list rcp))))
|
|
|
|
;;; Info Manuals
|
|
|
|
(defun package-build--generate-info-files (files source-dir target-dir)
|
|
"Create .info files from any .texi files listed in FILES.
|
|
|
|
The source and destination file paths are expanded in SOURCE-DIR
|
|
and TARGET-DIR respectively.
|
|
|
|
Any of the original .texi(nfo) files found in TARGET-DIR are
|
|
deleted."
|
|
(dolist (spec files)
|
|
(let* ((source-file (car spec))
|
|
(source-path (expand-file-name source-file source-dir))
|
|
(dest-file (cdr spec))
|
|
(info-path (expand-file-name
|
|
(concat (file-name-sans-extension dest-file) ".info")
|
|
target-dir)))
|
|
(when (string-match ".texi\\(nfo\\)?$" source-file)
|
|
(unless (file-exists-p info-path)
|
|
(ignore-errors
|
|
(package-build--run-process
|
|
(file-name-directory source-path) nil
|
|
"makeinfo" source-path "-o" info-path)
|
|
(package-build--message "Created %s" info-path)))
|
|
(package-build--message "Removing %s"
|
|
(expand-file-name dest-file target-dir))
|
|
(delete-file (expand-file-name dest-file target-dir))))))
|
|
|
|
(defun package-build--generate-dir-file (files target-dir)
|
|
"Create dir file from any .info files listed in FILES in TARGET-DIR."
|
|
(dolist (spec files)
|
|
(let* ((source-file (car spec))
|
|
(dest-file (cdr spec))
|
|
(info-path (expand-file-name
|
|
(concat (file-name-sans-extension dest-file) ".info")
|
|
target-dir)))
|
|
(when (and (or (string-match ".info$" source-file)
|
|
(string-match ".texi\\(nfo\\)?$" source-file))
|
|
(file-exists-p info-path))
|
|
(ignore-errors
|
|
(package-build--run-process
|
|
nil nil
|
|
"install-info"
|
|
(concat "--dir=" (expand-file-name "dir" target-dir))
|
|
info-path))))))
|
|
|
|
;;; Building Utilities
|
|
|
|
(defun package-build--copy-package-files (files source-dir target-dir)
|
|
"Copy FILES from SOURCE-DIR to TARGET-DIR.
|
|
FILES is a list of (SOURCE . DEST) relative filepath pairs."
|
|
(package-build--message
|
|
"Copying files (->) and directories (=>)\n from %s\n to %s"
|
|
source-dir target-dir)
|
|
(dolist (elt files)
|
|
(let* ((src (car elt))
|
|
(dst (cdr elt))
|
|
(src* (expand-file-name src source-dir))
|
|
(dst* (expand-file-name dst target-dir)))
|
|
(make-directory (file-name-directory dst*) t)
|
|
(cond ((file-regular-p src*)
|
|
(package-build--message
|
|
" %s %s -> %s" (if (equal src dst) " " "!") src dst)
|
|
(copy-file src* dst*))
|
|
((file-directory-p src*)
|
|
(package-build--message
|
|
" %s %s => %s" (if (equal src dst) " " "!") src dst)
|
|
(copy-directory src* dst*))))))
|
|
|
|
(defconst package-build--this-file load-file-name)
|
|
|
|
;;; Building
|
|
|
|
;;;###autoload
|
|
(defun package-build-archive (name &optional dump-archive-contents)
|
|
"Build a package archive for the package named NAME.
|
|
if DUMP-ARCHIVE-CONTENTS is non-nil, the updated archive contents
|
|
are subsequently dumped."
|
|
(interactive (list (package-recipe-read-name) t))
|
|
(let ((start-time (current-time))
|
|
(rcp (package-recipe-lookup name)))
|
|
(unless (file-exists-p package-build-archive-dir)
|
|
(package-build--message "Creating directory %s" package-build-archive-dir)
|
|
(make-directory package-build-archive-dir))
|
|
(let ((default-directory package-build-working-dir)
|
|
(version (package-build--checkout rcp)))
|
|
(package-build--package rcp version)
|
|
(when package-build-write-melpa-badge-images
|
|
(package-build--write-melpa-badge-image
|
|
name version package-build-archive-dir))
|
|
(package-build--message "Built %s in %.3fs, finished at %s"
|
|
name
|
|
(float-time (time-since start-time))
|
|
(current-time-string))
|
|
(list name version)))
|
|
(when dump-archive-contents
|
|
(package-build-dump-archive-contents)))
|
|
|
|
;;;###autoload
|
|
(defun package-build--package (rcp version)
|
|
"Create version VERSION of the package specified by RCP.
|
|
Return the archive entry for the package and store the package
|
|
in `package-build-archive-dir'."
|
|
(let* ((source-dir (package-recipe--working-tree rcp))
|
|
(file-specs (package-build--config-file-list rcp))
|
|
(files (package-build-expand-file-specs source-dir file-specs))
|
|
(commit (package-build--get-commit rcp))
|
|
(name (oref rcp name)))
|
|
(unless (equal file-specs package-build-default-files-spec)
|
|
(when (equal files (package-build-expand-file-specs
|
|
source-dir package-build-default-files-spec nil t))
|
|
(package-build--message
|
|
"Note: %s :files spec is equivalent to the default." name)))
|
|
(cond
|
|
((not version)
|
|
(error "Unable to check out repository for %s" name))
|
|
((= 1 (length files))
|
|
(package-build--build-single-file-package
|
|
rcp version commit (caar files) source-dir))
|
|
((< 1 (length files))
|
|
(package-build--build-multi-file-package
|
|
rcp version commit files source-dir))
|
|
(t (error "Unable to find files matching recipe patterns")))))
|
|
|
|
(define-obsolete-function-alias 'package-build-package 'package-build--package
|
|
"Package-Build 2.0.
|
|
|
|
The purpose of this alias is to get Cask working again.
|
|
|
|
This alias is only a temporary kludge and is going to be removed
|
|
again. It will likely be replaced by a function with the same
|
|
name but a different signature.
|
|
|
|
Do not use this alias elsewhere.")
|
|
|
|
(defun package-build--build-single-file-package (rcp version commit file source-dir)
|
|
(let* ((name (oref rcp name))
|
|
(pkg-source (expand-file-name file source-dir))
|
|
(pkg-target (expand-file-name
|
|
(concat name "-" version ".el")
|
|
package-build-archive-dir))
|
|
(pkg-info (package-build--merge-package-info
|
|
(package-build--get-package-info pkg-source)
|
|
name version commit)))
|
|
(unless (string-equal (downcase (concat name ".el"))
|
|
(downcase (file-name-nondirectory pkg-source)))
|
|
(error "Single file %s does not match package name %s"
|
|
(file-name-nondirectory pkg-source) name))
|
|
(copy-file pkg-source pkg-target t)
|
|
(let ((enable-local-variables nil)
|
|
(make-backup-files nil))
|
|
(with-current-buffer (find-file pkg-target)
|
|
(package-build--update-or-insert-header "Package-Commit" commit)
|
|
(package-build--update-or-insert-header "Package-Version" version)
|
|
(package-build--ensure-ends-here-line pkg-source)
|
|
(write-file pkg-target nil)
|
|
(condition-case err
|
|
(package-build--package-buffer-info-vec)
|
|
(error
|
|
(package-build--message "Warning: %S" err)))
|
|
(kill-buffer)))
|
|
(package-build--write-pkg-readme
|
|
package-build-archive-dir
|
|
(package-build--find-package-commentary pkg-source)
|
|
name)
|
|
(package-build--write-archive-entry rcp pkg-info 'single)))
|
|
|
|
(defun package-build--build-multi-file-package (rcp version commit files source-dir)
|
|
(let* ((name (oref rcp name))
|
|
(tmp-dir (file-name-as-directory (make-temp-file name t))))
|
|
(unwind-protect
|
|
(let* ((pkg-dir-name (concat name "-" version))
|
|
(pkg-tmp-dir (expand-file-name pkg-dir-name tmp-dir))
|
|
(pkg-file (concat name "-pkg.el"))
|
|
(pkg-file-source (or (car (rassoc pkg-file files))
|
|
pkg-file))
|
|
(file-source (concat name ".el"))
|
|
(pkg-source (or (car (rassoc file-source files))
|
|
file-source))
|
|
(pkg-info (package-build--merge-package-info
|
|
(let ((default-directory source-dir))
|
|
(or (package-build--get-pkg-file-info pkg-file-source)
|
|
;; Some packages provide NAME-pkg.el.in
|
|
(package-build--get-pkg-file-info
|
|
(expand-file-name (concat pkg-file ".in")
|
|
(file-name-directory pkg-source)))
|
|
(package-build--get-package-info pkg-source)))
|
|
name version commit)))
|
|
(package-build--copy-package-files files source-dir pkg-tmp-dir)
|
|
(package-build--write-pkg-file (expand-file-name
|
|
pkg-file
|
|
(file-name-as-directory pkg-tmp-dir))
|
|
pkg-info)
|
|
|
|
(package-build--generate-info-files files source-dir pkg-tmp-dir)
|
|
(package-build--generate-dir-file files pkg-tmp-dir)
|
|
|
|
(let ((default-directory tmp-dir))
|
|
(package-build--create-tar
|
|
(expand-file-name (concat name "-" version ".tar")
|
|
package-build-archive-dir)
|
|
pkg-dir-name))
|
|
|
|
(let ((default-directory source-dir))
|
|
(package-build--write-pkg-readme
|
|
package-build-archive-dir
|
|
(package-build--find-package-commentary pkg-source)
|
|
name))
|
|
(package-build--write-archive-entry rcp pkg-info 'tar))
|
|
(delete-directory tmp-dir t nil))))
|
|
|
|
;;;###autoload
|
|
(defun package-build-all ()
|
|
"Build a package for each of the available recipes."
|
|
(interactive)
|
|
(let* ((recipes (package-recipe-recipes))
|
|
(total (length recipes))
|
|
(success 0)
|
|
invalid failed)
|
|
(dolist (name recipes)
|
|
(let ((rcp (with-demoted-errors (package-recipe-lookup name))))
|
|
(if rcp
|
|
(if (with-demoted-errors (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")))))
|
|
(package-build-cleanup))
|
|
|
|
(defun package-build-cleanup ()
|
|
"Remove previously built packages that no longer have recipes."
|
|
(interactive)
|
|
(package-build-dump-archive-contents))
|
|
|
|
;;; Archive
|
|
|
|
(defun package-build-archive-alist ()
|
|
"Return the archive contents, without updating it first."
|
|
(let ((file (expand-file-name "archive-contents" package-build-archive-dir)))
|
|
(and (file-exists-p file)
|
|
(with-temp-buffer
|
|
(insert-file-contents file)
|
|
(cdr (read (current-buffer)))))))
|
|
|
|
(defun package-build-dump-archive-contents (&optional file pretty-print)
|
|
"Update and return the archive contents.
|
|
|
|
If non-nil, then store the archive contents in FILE instead of in
|
|
the \"archive-contents\" file inside `package-build-archive-dir'.
|
|
If PRETTY-PRINT is non-nil, then pretty-print insted of using one
|
|
line per entry."
|
|
(let (entries)
|
|
(dolist (file (directory-files package-build-archive-dir t ".*\.entry$"))
|
|
(let* ((entry (with-temp-buffer
|
|
(insert-file-contents file)
|
|
(read (current-buffer))))
|
|
(name (car entry))
|
|
(other-entry (assq name entries)))
|
|
(if (not (file-exists-p (expand-file-name (symbol-name name)
|
|
package-build-recipes-dir)))
|
|
(package-build--remove-archive-files entry)
|
|
(when other-entry
|
|
(when (version-list-< (elt (cdr entry) 0)
|
|
(elt (cdr other-entry) 0))
|
|
;; Swap so that other-entry has the smallest version.
|
|
(cl-rotatef other-entry entry))
|
|
(package-build--remove-archive-files other-entry)
|
|
(setq entries (remove other-entry entries)))
|
|
(add-to-list 'entries entry))))
|
|
(setq entries (nreverse entries))
|
|
(with-temp-file
|
|
(or file
|
|
(expand-file-name "archive-contents" package-build-archive-dir))
|
|
(let ((print-level nil)
|
|
(print-length nil))
|
|
(if pretty-print
|
|
(pp (cons 1 entries) (current-buffer))
|
|
(insert "(1")
|
|
(dolist (entry entries)
|
|
(newline)
|
|
(insert " ")
|
|
(prin1 entry (current-buffer)))
|
|
(insert ")"))))
|
|
entries))
|
|
|
|
(defalias 'package-build--archive-entries 'package-build-dump-archive-contents)
|
|
|
|
(defun package-build--remove-archive-files (archive-entry)
|
|
"Remove the entry and archive file for ARCHIVE-ENTRY."
|
|
(package-build--message "Removing archive: %s-%s"
|
|
(car archive-entry)
|
|
(package-version-join (aref (cdr archive-entry) 0)))
|
|
(let ((file (package-build--artifact-file archive-entry)))
|
|
(when (file-exists-p file)
|
|
(delete-file file)))
|
|
(let ((file (package-build--archive-entry-file archive-entry)))
|
|
(when (file-exists-p file)
|
|
(delete-file file))))
|
|
|
|
;;; Exporting Data as Json
|
|
|
|
(defun package-build-recipe-alist-as-json (file)
|
|
"Dump the recipe list to FILE as json."
|
|
(interactive)
|
|
(with-temp-file file
|
|
(insert
|
|
(json-encode
|
|
(cl-mapcan
|
|
(lambda (name)
|
|
(ignore-errors ; Silently ignore corrupted recipes.
|
|
(and (package-recipe-lookup name)
|
|
(with-temp-buffer
|
|
(insert-file-contents
|
|
(expand-file-name name package-build-recipes-dir))
|
|
(let ((exp (read (current-buffer))))
|
|
(when (plist-member (cdr exp) :files)
|
|
(plist-put (cdr exp) :files
|
|
(format "%S" (plist-get (cdr exp) :files))))
|
|
(list exp))))))
|
|
(package-recipe-recipes))))))
|
|
|
|
(defun package-build--pkg-info-for-json (info)
|
|
"Convert INFO into a data structure which will serialize to JSON in the desired shape."
|
|
(let ((ver (elt info 0))
|
|
(deps (elt info 1))
|
|
(desc (elt info 2))
|
|
(type (elt info 3))
|
|
(props (and (> (length info) 4)
|
|
(elt info 4))))
|
|
(list :ver ver
|
|
:deps (cl-mapcan (lambda (dep)
|
|
(list (intern (format ":%s" (car dep)))
|
|
(cadr dep)))
|
|
deps)
|
|
:desc desc
|
|
:type type
|
|
:props props)))
|
|
|
|
(defun package-build--archive-alist-for-json ()
|
|
"Return the archive alist in a form suitable for JSON encoding."
|
|
(cl-flet ((format-person
|
|
(person)
|
|
(let ((name (car person))
|
|
(mail (cdr person)))
|
|
(if (and name mail)
|
|
(format "%s <%s>" name mail)
|
|
(or name
|
|
(format "<%s>" mail))))))
|
|
(cl-mapcan (lambda (entry)
|
|
(list (intern (format ":%s" (car entry)))
|
|
(let* ((info (cdr entry))
|
|
(extra (aref info 4))
|
|
(maintainer (assq :maintainer extra))
|
|
(authors (assq :authors extra)))
|
|
(when maintainer
|
|
(setcdr maintainer
|
|
(format-person (cdr maintainer))))
|
|
(when authors
|
|
(if (cl-every #'listp (cdr authors))
|
|
(setcdr authors
|
|
(mapcar #'format-person (cdr authors)))
|
|
(assq-delete-all :authors extra)))
|
|
(package-build--pkg-info-for-json info))))
|
|
(package-build-archive-alist))))
|
|
|
|
(defun package-build-archive-alist-as-json (file)
|
|
"Dump the build packages list to FILE as json."
|
|
(with-temp-file file
|
|
(insert (json-encode (package-build--archive-alist-for-json)))))
|
|
|
|
;;; Backports
|
|
|
|
(defun package-build--lm-homepage (&optional file)
|
|
"Return the homepage in file FILE, or current buffer if FILE is nil.
|
|
This is a copy of `lm-homepage', which first appeared in Emacs 24.4."
|
|
(let ((page (lm-with-file file
|
|
(lm-header "\\(?:x-\\)?\\(?:homepage\\|url\\)"))))
|
|
(if (and page (string-match "^<.+>$" page))
|
|
(substring page 1 -1)
|
|
page)))
|
|
|
|
;;; _
|
|
|
|
(provide 'package-build)
|
|
|
|
;; For the time being just require all libraries that contain code
|
|
;; that was previously located in this library.
|
|
|
|
(require 'package-build-badges)
|
|
(require 'package-recipe-mode)
|
|
;; End:
|
|
;;; package-build.el ends here
|