;;; package-build.el --- Tools for curating the package archive ;; Copyright (C) 2011-2012 Donald Ephraim Curtis ;; Copyright (C) 2012 Steve Purcell ;; Copyright (C) 2009 Phil Hagelberg ;; Author: Donald Ephraim Curtis ;; Created: 2011-09-30 ;; Version: 0.1 ;; Keywords: tools ;; 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 an index, which contains a list of ;; 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: ;; Since this library is not meant to be loaded by users ;; at runtime, use of cl functions should not be a problem. (require 'cl) (require 'package) (require 'lisp-mnt) (defconst pb/this-dir (file-name-directory (or load-file-name (buffer-file-name)))) (defcustom package-build-working-dir (expand-file-name "working/" pb/this-dir) "Directory in which to keep checkouts." :group 'package-build :type 'string) (defcustom package-build-archive-dir (expand-file-name "packages/" pb/this-dir) "Directory in which to keep compiled archives." :group 'package-build :type 'string) (defcustom package-build-recipes-dir (expand-file-name "recipes/" pb/this-dir) "Directory containing recipe files." :group 'package-build :type 'string) ;;; Internal Variables (defvar pb/recipe-alist nil "Internal list of package build specs. Do not use this directly. Use `package-build-recipe-alist' function.") (defvar pb/archive-alist nil "Internal list of already-built packages, in the standard package.el format. Do not use this directly. Use `package-build-archive-alist' function for access to this function") (defconst pb/default-files-spec '("*.el" "dir" "*.info") "Default value for :files attribute in recipes.") (defun pb/slurp-file (file-name) "Return the contents of FILE-NAME as a string, or nil if no such file exists." (when (file-exists-p file-name) (with-temp-buffer (insert-file-contents-literally file-name) (buffer-substring-no-properties (point-min) (point-max))))) (defun pb/string-rtrim (str) "Remove trailing whitespace from `STR'." (replace-regexp-in-string "[ \t\n]*$" "" str)) (defun pb/parse-time (str) "Parse STR as a time, and format as a YYYYMMDD.HHMM string." ;; We remove zero-padding the HH portion, as it is lost ;; when stored in the archive-contents (let* ((s (substring-no-properties str)) (time (condition-case nil (date-to-time s) ('error ;; Handle newer CVS formats like "2001/08/26 22:16:22" ;; which break date-to-time (date-to-time (replace-regexp-in-string "/" "-" s)))))) (concat (format-time-string "%Y%m%d." time) (format "%d" (or (string-to-number (format-time-string "%H%M" time)) 0))))) (defun pb/string-match-all (regex str &optional group) "Find every match for `REGEX' within `STR', returning the full match string or group `GROUP'." (let (result (pos 0) (group (or group 0))) (while (string-match regex str pos) (push (match-string group str) result) (setq pos (match-end group))) result)) (defun pb/find-parse-time (regex &optional bound) "Find REGEX in current buffer and format as a time version, optionally looking only as far as BOUND." (pb/parse-time (progn (re-search-backward regex bound) (match-string-no-properties 1)))) (defun pb/find-parse-time-latest (regex &optional bound) "Find the latest timestamp matching REGEX, optionally looking only as far as BOUND." (let* ((text (buffer-substring-no-properties (or bound (point-min)) (point))) (times (mapcar 'pb/parse-time (pb/string-match-all regex text 1)))) (car (nreverse (sort times 'string<))))) (defun pb/run-process (dir prog &rest args) "In DIR (or `default-directory' if unset) run command PROG with ARGS. Output is written to the current buffer." (let ((default-directory (or dir default-directory))) (let ((exit-code (apply 'process-file prog nil (current-buffer) t args))) (unless (zerop exit-code) (error "Program '%s' with args '%s' exited with non-zero status %d" prog args exit-code))))) (defun pb/run-process-match (regex dir prog &rest args) "Find match for REGEX when - in DIR, or `default-directory' if unset - we run PROG with ARGS." (with-temp-buffer (apply 'pb/run-process dir prog args) (goto-char (point-min)) (re-search-forward regex) (match-string-no-properties 1))) (defun pb/checkout (name config cwd) "Check out source for package NAME with CONFIG under working dir CWD. In turn, this function uses the :fetcher option in the config to choose a source-specific fetcher function, which it calls with the same arguments." (let ((repo-type (plist-get config :fetcher))) (message "Fetcher: %s" repo-type) (unless (eq 'wiki repo-type) (message "Source: %s\n" (or (plist-get config :repo) (plist-get config :url)))) (funcall (intern (format "pb/checkout-%s" repo-type)) name config cwd))) (defvar pb/last-wiki-fetch-time 0 "The time at which an emacswiki URL was last requested. This is used to avoid exceeding the rate limit of 1 request per 2 seconds; the server cuts off after 10 requests in 20 seconds.") (defvar pb/wiki-min-request-interval 2 "The shortest permissible interval between successive requests for Emacswiki URLs.") (defmacro pb/with-wiki-rate-limit (&rest body) "Rate-limit BODY code passed to this macro to match EmacsWiki's rate limiting." (let ((now (gensym)) (elapsed (gensym))) `(let* ((,now (float-time)) (,elapsed (- ,now pb/last-wiki-fetch-time))) (when (< ,elapsed pb/wiki-min-request-interval) (let ((wait (- pb/wiki-min-request-interval ,elapsed))) (message "Waiting %.2f secs before hitting Emacswiki again" wait) (sleep-for wait))) (unwind-protect (progn ,@body) (setq pb/last-wiki-fetch-time (float-time)))))) (defun pb/grab-wiki-file (filename) "Download FILENAME from emacswiki, returning its last-modified time." (let* ((download-url (format "http://www.emacswiki.org/emacs/download/%s" filename)) (wiki-url (format "http://www.emacswiki.org/emacs/%s" filename))) (pb/with-wiki-rate-limit (url-copy-file download-url filename t)) (when (zerop (nth 7 (file-attributes filename))) (error "Wiki file %s was empty - has it been removed?" filename)) ;; The Last-Modified response header for the download is actually ;; correct for the file, but we have no access to that ;; header. Instead, we must query the non-raw emacswiki page for ;; the file. ;; Since those Emacswiki lookups are time-consuming, we maintain a ;; foo.el.stamp file containing ("SHA1" . "PARSED_TIME") (let* ((new-content-hash (secure-hash 'sha1 (pb/slurp-file filename))) (stamp-file (concat filename ".stamp")) (stamp-info (pb/read-from-file stamp-file)) (prev-content-hash (car stamp-info))) (if (and prev-content-hash (string-equal new-content-hash prev-content-hash)) ;; File has not changed, so return old timestamp (progn (message "%s is unchanged" filename) (cdr stamp-info)) (message "%s has changed - checking mod time" filename) (let ((new-timestamp (with-current-buffer (pb/with-wiki-rate-limit (url-retrieve-synchronously wiki-url)) (pb/find-parse-time "Last edited \\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} [0-9]\\{2\\}:[0-9]\\{2\\} [A-Z]\\{3\\}\\)")))) (pb/dump (cons new-content-hash new-timestamp) stamp-file) new-timestamp))))) (defun pb/checkout-wiki (name config dir) "Checkout package NAME with config CONFIG from the EmacsWiki into DIR." (with-current-buffer (get-buffer-create "*package-build-checkout*") (unless (file-exists-p dir) (make-directory dir)) (let ((files (or (plist-get config :files) (list (format "%s.el" name)))) (default-directory dir)) (car (nreverse (sort (mapcar 'pb/grab-wiki-file files) 'string-lessp)))))) (defun pb/darcs-repo (dir) "Get the current darcs repo for DIR." (pb/run-process-match "Default Remote: \\(.*\\)" dir "darcs" "show" "repo")) (defun pb/checkout-darcs (name config dir) "Check package NAME with config CONFIG out of darcs into DIR." (let ((repo (plist-get config :url))) (with-current-buffer (get-buffer-create "*package-build-checkout*") (cond ((and (file-exists-p (expand-file-name "_darcs" dir)) (string-equal (pb/darcs-repo dir) repo)) (pb/princ-exists dir) (pb/run-process dir "darcs" "pull")) (t (when (file-exists-p dir) (delete-directory dir t nil)) (pb/princ-checkout repo dir) (pb/run-process nil "darcs" "get" repo dir))) (apply 'pb/run-process dir "darcs" "changes" "--max-count" "1" (pb/expand-source-file-list dir config)) (pb/find-parse-time "\\([a-zA-Z]\\{3\\} [a-zA-Z]\\{3\\} \\( \\|[0-9]\\)[0-9] [0-9]\\{2\\}:[0-9]\\{2\\}:[0-9]\\{2\\} [A-Za-z]\\{3\\} [0-9]\\{4\\}\\)")))) (defun pb/svn-repo (dir) "Get the current svn repo for DIR." (pb/run-process-match "URL: \\(.*\\)" dir "svn" "info")) (defun pb/trim (str &optional chr) "Return a copy of STR without any trailing CHR (or space if unspecified)." (if (equal (elt str (1- (length str))) (or chr ? )) (substring str 0 (1- (length str))) str)) (defun pb/princ-exists (dir) "Print a message that the contents of DIR will be updated." (message "Updating %s" dir)) (defun pb/princ-checkout (repo dir) "Print a message that REPO will be checked out into DIR." (message "Cloning %s to %s" repo dir)) (defun pb/checkout-svn (name config dir) "Check package NAME with config CONFIG out of svn into DIR." (with-current-buffer (get-buffer-create "*package-build-checkout*") (let ((repo (pb/trim (plist-get config :url) ?/)) (bound (goto-char (point-max)))) (cond ((and (file-exists-p (expand-file-name ".svn" dir)) (string-equal (pb/svn-repo dir) repo)) (pb/princ-exists dir) (pb/run-process dir "svn" "up")) (t (when (file-exists-p dir) (delete-directory dir t nil)) (pb/princ-checkout repo dir) (pb/run-process nil "svn" "checkout" repo dir))) (apply 'pb/run-process dir "svn" "info" (pb/expand-source-file-list dir config)) (or (pb/find-parse-time-latest "Last Changed Date: \\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} [0-9]\\{2\\}:[0-9]\\{2\\}:[0-9]\\{2\\}\\)" bound) (error "No valid timestamps found!"))))) (defun pb/cvs-repo (dir) "Get the current CVS root and repository for DIR. Return a cons cell whose `car' is the root and whose `cdr' is the repository." (apply 'cons (mapcar (lambda (file) (pb/string-rtrim (pb/slurp-file (expand-file-name file dir)))) '("CVS/Root" "CVS/Repository")))) (defun pb/checkout-cvs (name config dir) "Check package NAME with config CONFIG out of csv into DIR." (with-current-buffer (get-buffer-create "*package-build-checkout*") (let ((root (pb/trim (plist-get config :url) ?/)) (repo (or (plist-get config :module) (symbol-name name))) (bound (goto-char (point-max)))) (cond ((and (file-exists-p (expand-file-name "CVS" dir)) (equal (pb/cvs-repo dir) (cons root repo))) (pb/princ-exists dir) (pb/run-process dir "cvs" "update" "-dP")) (t (when (file-exists-p dir) (delete-directory dir t nil)) (pb/princ-checkout (format "%s from %s" repo root) dir) ;; CVS insists on relative paths as target directory for checkout (for ;; whatever reason), and puts "CVS" directories into every subdirectory ;; of the current working directory given in the target path. To get CVS ;; to just write to DIR, we need to execute CVS from the parent ;; directory of DIR, and specific DIR as relative path. Hence all the ;; following mucking around with paths. CVS is really horrid. (let* ((dir (directory-file-name dir)) (working-dir (file-name-directory dir)) (target-dir (file-name-nondirectory dir))) (pb/run-process working-dir "env" "TZ=UTC" "cvs" "-z3" "-d" root "checkout" "-d" target-dir repo)))) (apply 'pb/run-process dir "cvs" "log" (pb/expand-source-file-list dir config)) (or (pb/find-parse-time-latest "date: \\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} [0-9]\\{2\\}:[0-9]\\{2\\}:[0-9]\\{2\\} \\+[0-9]\\{2\\}[0-9]\\{2\\}\\)") (pb/find-parse-time-latest "date: \\([0-9]\\{4\\}/[0-9]\\{2\\}/[0-9]\\{2\\} [0-9]\\{2\\}:[0-9]\\{2\\}:[0-9]\\{2\\}\\);") (error "No valid timestamps found!")) ))) (defun pb/git-repo (dir) "Get the current git repo for DIR." (pb/run-process-match "Fetch URL: \\(.*\\)" dir "git" "remote" "show" "-n" "origin")) (defun pb/git-head-branch (dir) "Get the current git repo for DIR." (or (ignore-errors (pb/run-process-match "HEAD branch: \\(.*\\)" dir "git" "remote" "show" "origin")) "master")) (defun pb/checkout-git (name config dir) "Check package NAME with config CONFIG out of git into DIR." (let ((repo (plist-get config :url)) (commit (plist-get config :commit))) (with-current-buffer (get-buffer-create "*package-build-checkout*") (goto-char (point-max)) (cond ((and (file-exists-p (expand-file-name ".git" dir)) (string-equal (pb/git-repo dir) repo)) (pb/princ-exists dir) (pb/run-process dir "git" "remote" "update")) (t (when (file-exists-p dir) (delete-directory dir t nil)) (pb/princ-checkout repo dir) (pb/run-process nil "git" "clone" repo dir))) (pb/run-process dir "git" "reset" "--hard" (or commit (concat "origin/" (pb/git-head-branch dir)))) (apply 'pb/run-process dir "git" "log" "-n1" "--pretty=format:'\%ci'" (pb/expand-source-file-list dir config)) (pb/find-parse-time "\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} [0-9]\\{2\\}:[0-9]\\{2\\}:[0-9]\\{2\\}\\)")))) (defun pb/checkout-github (name config dir) "Check package NAME with config CONFIG out of github into DIR." (let* ((url (format "git://github.com/%s.git" (plist-get config :repo)))) (pb/checkout-git name (plist-put (copy-sequence config) :url url) dir))) (defun pb/bzr-expand-repo (repo) "Get REPO expanded name." (pb/run-process-match "\\(?:branch root\\|repository branch\\): \\(.*\\)" nil "bzr" "info" repo)) (defun pb/bzr-repo (dir) "Get the current bzr repo for DIR." (pb/run-process-match "parent branch: \\(.*\\)" dir "bzr" "info")) (defun pb/checkout-bzr (name config dir) "Check package NAME with config CONFIG out of bzr into DIR." (let ((repo (pb/bzr-expand-repo (plist-get config :url)))) (with-current-buffer (get-buffer-create "*package-build-checkout*") (goto-char (point-max)) (cond ((and (file-exists-p (expand-file-name ".bzr" dir)) (string-equal (pb/bzr-repo dir) repo)) (pb/princ-exists dir) (pb/run-process dir "bzr" "merge")) (t (when (file-exists-p dir) (delete-directory dir t nil)) (pb/princ-checkout repo dir) (pb/run-process nil "bzr" "branch" repo dir))) (apply 'pb/run-process dir "bzr" "log" "-l1" (pb/expand-source-file-list dir config)) (pb/find-parse-time "\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} [0-9]\\{2\\}:[0-9]\\{2\\}:[0-9]\\{2\\}\\)")))) (defun pb/hg-repo (dir) "Get the current hg repo for DIR." (pb/run-process-match "default = \\(.*\\)" dir "hg" "paths")) (defun pb/checkout-hg (name config dir) "Check package NAME with config CONFIG out of hg into DIR." (let ((repo (plist-get config :url))) (with-current-buffer (get-buffer-create "*package-build-checkout*") (goto-char (point-max)) (cond ((and (file-exists-p (expand-file-name ".hg" dir)) (string-equal (pb/hg-repo dir) repo)) (pb/princ-exists dir) (pb/run-process dir "hg" "pull") (pb/run-process dir "hg" "update")) (t (when (file-exists-p dir) (delete-directory dir t nil)) (pb/princ-checkout repo dir) (pb/run-process nil "hg" "clone" repo dir))) (apply 'pb/run-process dir "hg" "log" "--style" "compact" "-l1" (pb/expand-source-file-list dir config)) (pb/find-parse-time "\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} [0-9]\\{2\\}:[0-9]\\{2\\}\\)")))) (defun pb/dump (data file) "Write DATA to FILE as a pretty-printed Lisp sexp." (write-region (concat (pp-to-string data) "\n") nil file)) (defun pb/write-pkg-file (pkg-file pkg-info) "Write PKG-FILE containing PKG-INFO." (pb/dump `(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))) pkg-file)) (defun pb/read-from-file (file-name) "Read and return the Lisp data stored in FILE-NAME, or nil if no such file exists." (when (file-exists-p file-name) (car (read-from-string (pb/slurp-file file-name))))) (defun pb/create-tar (file dir &optional files) "Create a tar FILE containing the contents of DIR, or just FILES if non-nil. The file is written to `package-build-working-dir'." (let* ((default-directory package-build-working-dir)) (apply 'process-file "tar" nil (get-buffer-create "*package-build-checkout*") nil "-cvf" file "--exclude=.svn" "--exclude=CVS" "--exclude=.git*" "--exclude=_darcs" "--exclude=.bzr" "--exclude=.hg" (or (mapcar (lambda (fn) (concat dir "/" fn)) files) (list dir))))) (defun pb/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 pb/write-pkg-readme (commentary file-name) "Write COMMENTARY to the FILE-NAME-readme.txt file." (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") package-build-archive-dir)))))) (defun pb/update-or-insert-version (version) "Ensure current buffer has a \"Version: VERSION\" header." (goto-char (point-min)) (if (re-search-forward "^;;;* *Version: *" nil t) (kill-whole-line) (forward-line)) (insert (format ";; Version: %s" version)) (newline)) (defun pb/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. (pb/update-or-insert-version "0") (goto-char (point-max)) (newline) (insert ";;; " (file-name-nondirectory file-path) " ends here") (flet ((package-strip-rcs-id (str) "0")) (package-buffer-info)))))) (defun pb/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 (pb/read-from-file file-path))) (if (eq 'define-package (car package-def)) (let ((pkgfile-info (cdr package-def))) (vector (nth 0 pkgfile-info) (mapcar (lambda (elt) (list (car elt) (version-to-list (cadr elt)))) (eval (nth 3 pkgfile-info))) (nth 2 pkgfile-info) (nth 1 pkgfile-info))) (error "No define-package found in %s" file-path))))) (defun pb/merge-package-info (pkg-info name version config) "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-seq pkg-info) (vector name nil "No description available." version)))) (aset merged 0 name) (aset merged 2 (format "%s [source: %s]" (aref merged 2) (plist-get config :fetcher))) (aset merged 3 version) merged)) (defun pb/dump-archive-contents () "Dump the list of built packages back to the archive-contents file." (pb/dump (cons 1 (package-build-archive-alist)) (expand-file-name "archive-contents" package-build-archive-dir))) (defun pb/add-to-archive-contents (pkg-info type) "Add the built archive with info PKG-INFO and TYPE to `package-build-archive-alist'." (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)) (existing (assq name (package-build-archive-alist)))) (when existing (package-build-archive-alist-remove existing)) (package-build-archive-alist-add (cons name (vector (version-to-list version) requires desc type))))) (defun pb/archive-file-name (archive-entry) "Return the path of the file in which the package for ARCHIVE-ENTRY is stored." (expand-file-name (format "%s-%s.%s" (car archive-entry) (car (aref (cdr archive-entry) 0)) (if (eq 'single (aref (cdr archive-entry) 3)) "el" "tar")) package-build-archive-dir)) (defun pb/remove-archive (archive-entry) "Remove ARCHIVE-ENTRY from archive-contents, and delete associated file. Note that the working directory (if present) is not deleted by this function, since the archive list may contain another version of the same-named package which is to be kept." (print (format "Removing archive: %s" archive-entry)) (let ((archive-file (pb/archive-file-name archive-entry))) (when (file-exists-p archive-file) (delete-file archive-file))) (package-build-archive-alist-remove archive-entry) (pb/dump-archive-contents)) (defun pb/read-recipe (file-name) (let ((pkg-info (pb/read-from-file file-name))) (if (string= (symbol-name (car pkg-info)) (file-name-nondirectory file-name)) pkg-info (error "Recipe '%s' contains mismatched package name '%s'" (file-name-nondirectory file-name) (car pkg-info))))) (defun pb/read-recipes () "Return a list of data structures for all recipes in `package-build-recipes-dir'." (loop for file-name in (directory-files package-build-recipes-dir t "^[^.]") collect (pb/read-recipe file-name))) (defun pb/read-recipes-ignore-errors () "Return a list of data structures for all recipes in `package-build-recipes-dir'." (loop for file-name in (directory-files package-build-recipes-dir t "^[^.]") for pkg-info = (condition-case err (pb/read-recipe file-name) ('error (message (error-message-string err)) nil)) when pkg-info collect pkg-info)) (defun pb/expand-file-specs (dir specs &optional subdir) "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." (let ((default-directory dir) (prefix (if subdir (format "%s/" subdir) ""))) (mapcan (lambda (entry) (if (consp entry) (pb/expand-file-specs dir (cdr entry) (concat prefix (car entry))) (mapcar (lambda (f) (cons f (concat prefix (file-name-nondirectory f)))) (file-expand-wildcards entry)))) specs))) (defun pb/expand-config-file-list (dir config) "In DIR, expand the :files for CONFIG using 'pb/expand-file-specs." (let* ((patterns (or (plist-get config :files) pb/default-files-spec)) (files (pb/expand-file-specs dir patterns))) (or files (error "No matching file(s) found in %s: %s" dir patterns)))) (defun pb/expand-source-file-list (dir config) "Shorthand way to expand paths in DIR for source files listed in CONFIG." (mapcar 'car (pb/expand-config-file-list dir config))) (defun pb/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." (loop for (source-file . dest-file) in files do (pb/copy-file (expand-file-name source-file source-dir) (expand-file-name dest-file target-dir)))) (defun pb/copy-file (file newname) "Copy FILE to NEWNAME and create parent directories for NEWNAME if they don't exist." (let ((newdir (file-name-directory newname))) (unless (file-exists-p newdir) (make-directory newdir t))) (cond ((file-regular-p file) (message "%s -> %s" file newname) (copy-file file newname)) ((file-directory-p file) (message "%s => %s" file newname) (copy-directory file newname)))) (defun pb/package-name-completing-read () "Prompt for a package name, returning a symbol." (intern (completing-read "Package: " (package-build-recipe-alist)))) (defun pb/find-source-file (target files) "Search for source of TARGET in FILES." (let* ((entry (rassoc target files))) (when entry (car entry)))) (defun pb/find-package-file (name) "Return the filename of the most recently built package of NAME." (let* ((pkg-info (cdr (assoc name (package-build-archive-alist)))) (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))) ;;; Public interface ;;;###autoload (defun package-build-archive (name) "Build a package archive for package NAME." (interactive (list (pb/package-name-completing-read))) (let* ((file-name (symbol-name name)) (cfg (or (cdr (assoc name (package-build-recipe-alist))) (error "Cannot find package %s" file-name))) (pkg-cwd (file-name-as-directory (expand-file-name file-name package-build-working-dir)))) (message "\n;;; %s\n" file-name) (let* ((version (pb/checkout name cfg pkg-cwd)) (files (pb/expand-config-file-list pkg-cwd cfg)) (default-directory package-build-working-dir) (start-time (current-time))) (cond ((not version) (message "Unable to check out repository for %s" name)) ((= 1 (length files)) (let* ((pkg-source (expand-file-name (caar files) pkg-cwd)) (pkg-target (expand-file-name (concat file-name "-" version ".el") package-build-archive-dir)) (pkg-info (pb/merge-package-info (pb/get-package-info pkg-source) file-name version cfg))) (when (file-exists-p pkg-target) (delete-file pkg-target t)) (copy-file pkg-source pkg-target) (with-current-buffer (find-file pkg-target) (pb/update-or-insert-version version) (write-file pkg-target nil) (condition-case err (package-buffer-info) ('error (message "Warning: package is uninstallable - package-buffer-info reports:\n%S" err))) (kill-buffer)) (pb/write-pkg-readme (and (> (length pkg-info) 4) (aref pkg-info 4)) file-name) (pb/add-to-archive-contents pkg-info 'single))) ((< 1 (length files)) (let* ((pkg-dir (concat file-name "-" version)) (pkg-file (concat file-name "-pkg.el")) (pkg-file-source (or (pb/find-source-file pkg-file files) pkg-file)) (file-source (concat file-name ".el")) (pkg-source (or (pb/find-source-file file-source files) file-source)) (pkg-info (pb/merge-package-info (let ((default-directory pkg-cwd)) (or (pb/get-pkg-file-info pkg-file-source) ;; some packages (like magit) provide name-pkg.el.in (pb/get-pkg-file-info (concat pkg-file ".in")) (pb/get-package-info pkg-source))) file-name version cfg))) (let ((default-directory pkg-cwd)) (pb/write-pkg-readme (pb/find-package-commentary pkg-source) file-name)) (when (file-exists-p pkg-dir) (delete-directory pkg-dir t nil)) (pb/copy-package-files files pkg-cwd pkg-dir) (pb/write-pkg-file (expand-file-name pkg-file (file-name-as-directory (expand-file-name pkg-dir package-build-working-dir))) pkg-info) (pb/create-tar (expand-file-name (concat file-name "-" version ".tar") package-build-archive-dir) pkg-dir (delete-dups (append (mapcar 'cdr files) (list pkg-file)))) (delete-directory pkg-dir t nil) (pb/add-to-archive-contents pkg-info 'tar))) (t (error "Unable to find files matching recipe patterns"))) (pb/dump-archive-contents) (message "Built in %.3fs, finished at %s" (time-to-seconds (time-since start-time)) (current-time-string)) file-name))) ;;; Helpers for recipe authors (defvar package-build-minor-mode-map (let ((m (make-sparse-keymap))) (define-key m (kbd "C-c C-c") 'package-build-current-recipe) m) "Keymap for `package-build-minor-mode'.") (define-minor-mode package-build-minor-mode "Helpful functionality for building packages." nil " PBuild" package-build-minor-mode-map) ;;;###autoload (defun package-build-create-recipe (name fetcher) "Create a new recipe for package NAME using FETCHER." (interactive (list (intern (read-string "Package name: ")) (intern (let ((fetcher-types (mapcar #'symbol-name '(github git wiki bzr hg cvs svn)))) (completing-read "Fetcher: " fetcher-types nil t nil nil (car fetcher-types)))))) (let ((recipe-file (expand-file-name (symbol-name name) package-build-recipes-dir))) (when (file-exists-p recipe-file) (error "Recipe already exists")) (find-file recipe-file) (let* ((extra-params (cond ((eq 'github fetcher) '(:repo "USER/REPO")) ((eq 'wiki fetcher) '()) (t '(:url "SCM_URL_HERE")))) (template `(,name :fetcher ,fetcher ,@extra-params))) (insert (pp-to-string template)) (emacs-lisp-mode) (package-build-minor-mode) (beginning-of-buffer)))) ;;;###autoload (defun package-build-current-recipe () "Build archive for the recipe defined in the current buffer." (interactive) (unless (and (buffer-file-name) (string-equal (file-name-directory (buffer-file-name)) package-build-recipes-dir)) (error "Buffer is not visiting a recipe")) (when (buffer-modified-p) (if (y-or-n-p (format "Save file %s? " buffer-file-name)) (save-buffer) (error "Aborting"))) (package-build-reinitialize) (let ((pkg-name (intern (file-name-nondirectory (buffer-file-name))))) (package-build-archive pkg-name) (save-current-buffer (find-file-other-window (expand-file-name "archive-contents" package-build-archive-dir)) (revert-buffer t t)) (when (yes-or-no-p "Install new package? ") (package-install-file (pb/find-package-file pkg-name))))) (defun package-build-archive-ignore-errors (pkg) "Build archive for package PKG, ignoring any errors." (interactive (list (pb/package-name-completing-read))) (let* ((debug-on-error t) (debug-on-signal t) (pb/debugger-return nil) (debugger (lambda (&rest args) (setq pb/debugger-return (with-output-to-string (backtrace)))))) (condition-case err (package-build-archive pkg) ('error (message "%s" (error-message-string err)) nil)))) ;;;###autoload (defun package-build-all () "Build all packages in the `package-build-recipe-alist'." (interactive) (let ((failed (loop for pkg in (mapcar 'car (package-build-recipe-alist)) when (not (package-build-archive-ignore-errors pkg)) collect pkg))) (if (not failed) (princ "\nSuccessfully Compiled All Packages\n") (princ "\nFailed to Build the Following Packages\n") (princ (mapconcat 'symbol-name failed "\n")) (princ "\n"))) (package-build-cleanup)) (defun package-build-cleanup () "Remove previously-built packages that no longer have recipes." (interactive) (let* ((known-package-names (mapcar 'car (package-build-recipe-alist))) (stale-archives (loop for built in (package-build-archive-alist) when (not (memq (car built) known-package-names)) collect built))) (mapc 'pb/remove-archive stale-archives))) (defun package-build-recipe-alist () "Retun the list of avalailable packages." (or pb/recipe-alist (setq pb/recipe-alist (pb/read-recipes-ignore-errors)))) (defun package-build-archive-alist-remove (elt) "Remove ELT from the archive list using `remove' and return the new value." (setq pb/archive-alist (remove elt pb/archive-alist))) (defun package-build-archive-alist-add (elt) "Add ELT to the archive list if it isn't there yet and return the new value." (add-to-list 'pb/archive-alist elt)) (defun package-build-archive-alist () "Return the archive list." (or pb/archive-alist (setq pb/archive-alist (cdr (pb/read-from-file (expand-file-name "archive-contents" package-build-archive-dir)))))) (defun package-build-reinitialize () (interactive) (setq pb/recipe-alist nil pb/archive-alist nil)) ;; Utility functions (require 'json) (load (expand-file-name "json-fix" pb/this-dir)) (defun package-build-recipe-alist-as-json (fn) (interactive) (with-temp-file fn (insert (json-encode (package-build-recipe-alist))))) (defun package-build-archive-alist-as-json (fn) (interactive) (with-temp-file fn (insert (json-encode (package-build-archive-alist))))) (provide 'package-build) ;; Local Variables: ;; coding: utf-8 ;; byte-compile-warnings: (not cl-functions) ;; eval: (checkdoc-minor-mode 1) ;; End: ;;; package-build.el ends here