Permalink
Browse files

Allow customization of version parsing

- new :version-regexp key for recipes
- new custom variable `package-build-version-regexp'
- ert tests for version detection
- rename --valid-version-string to --valid-version
  • Loading branch information...
dunn committed Dec 6, 2015
1 parent ef39950 commit 1f70c83016f5d47c08dded0ffda13781c07f7706
Showing with 158 additions and 93 deletions.
  1. +10 −8 README.md
  2. +103 −85 package-build.el
  3. +45 −0 tests/version-tests.el
View
@@ -1,4 +1,4 @@
# MELPA
# MELPA
[![Build Status](https://travis-ci.org/milkypostman/melpa.png?branch=master)](https://travis-ci.org/milkypostman/melpa)
@@ -183,6 +183,7 @@ the following form (`[...]` denotes optional or conditional values),
:fetcher [git|github|gitlab|bitbucket|bzr|hg|darcs|fossil|svn|cvs|wiki]
[:url "<repo url>"]
[:repo "github-gitlab-or-bitbucket-user/repo-name"]
[:version-regexp "<regexp>"]
[:module "cvs-module"]
[:files ("<file1>" ...)])
```
@@ -230,13 +231,19 @@ the `git`-based fetchers.
specifies the branch of the git repo to use. This is like `:commit`, but
it adds the "origin/" prefix automatically.
- `:version-regexp` is a regular expression for extracting a
version-string from the repository tags. Version-strings must be
parseable by Emacs' `version-to-list` , so for an unusual tag like
"OTP-18.1.5", we add `:version "[^0-9]*\\(.*\\)"` to strip the
"OTP-" prefix.
- `:module`
specifies the module of a CVS repository to check out. Defaults to to
`package-name`. Only used with `:fetcher cvs`, and otherwise ignored.
- `:files` optional property specifying the elisp and info files used to build the
package. Automatically populated by matching all `.el`, `.info` and `dir` files in the
root of the repository and the `doc` directory. Excludes all files in the root directory
root of the repository and the `doc` directory. Excludes all files in the root directory
ending in `test.el` or `tests.el`. See the default value below,
("*.el" "*.el.in" "dir"
@@ -504,7 +511,7 @@ in your `package-archives` list.
'("melpa-stable" . "https://stable.melpa.org/packages/"))
```
An online list of available packages can be found at
An online list of available packages can be found at
[https://stable.melpa.org](https://stable.melpa.org).
### Stable Version Generation
@@ -526,8 +533,3 @@ package.
them. Any packages you already have installed from MELPA will never
get "updated" to the stable version because of the way version
numbering is handled.
View
@@ -106,10 +106,16 @@ Certain package names (e.g. \"@\") may not work properly with a BSD tar."
:type '(file :must-match t))
(defcustom package-build-write-melpa-badge-images nil
"When non-nil, write MELPA badge images alongside packages, for use on github pages etc."
"When non-nil, write MELPA badge images alongside packages, for use on GitHub pages etc."
: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)
;;; Internal Variables
(defvar package-build--recipe-alist nil
@@ -153,6 +159,15 @@ function for access to this function")
"Remove trailing whitespace from `STR'."
(replace-regexp-in-string "[ \t\n]*$" "" str))
(defun package-build--valid-version (str &optional regexp)
"Apply to STR the REGEXP if defined, \
then pass the string to `version-to-list' and return the result, \
or nil if the version cannot be parsed."
(when (and regexp (string-match regexp str))
(setq str (match-string 1 str)))
(ignore-errors (version-to-list str)))
(defun package-build--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
@@ -166,55 +181,26 @@ function for access to this function")
(concat (format-time-string "%Y%m%d." time)
(format "%d" (or (string-to-number (format-time-string "%H%M" time)) 0)))))
(defun package-build--string-match-all (regex str &rest groups)
"Find every match for `REGEX' within `STR'.
Return a list containing the full match string and match for
groups `GROUPS'. The return list is of the form
((FULL GROUP1 GROUP2 ...) ...)
where FULL is the complete regexp match and
GROUP1, GROUP2, ... are the regex groups specified by the
`GROUPS' argument. If `GROUPS' is nil then FULL and GROUP1 will
be identical."
(let (result
(pos 0)
(groups (or groups '(0))))
(while (string-match regex str pos)
(push (cons (match-string 0 str) (mapcar
(lambda (group)
(match-string group str))
groups))
result)
(setq pos (match-end 0)))
result))
(defun package-build--find-parse-time (regex &optional bound)
"Find REGEX in current buffer and format as a time version, optionally looking only as far as BOUND."
"Find REGEX in current buffer and format as a time-based version string, \
optionally looking only as far back as BOUND."
(package-build--parse-time (progn (re-search-backward regex bound)
(match-string-no-properties 1))))
(defun package-build--valid-version-string (str)
"Return true if STR is a valid version, otherwise return nil."
(ignore-errors (version-to-list str)))
(defun package-build--find-tag-version-newest (regex &optional bound &rest additional-groups)
"Find the newest version matching REGEX after point, maybe stopping at BOUND.
The first capture group 1 is examined, together with any ADDITIONAL-GROUPS."
(let* ((text (buffer-substring-no-properties
(or bound (point-min)) (point)))
(tags (cl-remove-if-not
(lambda (tag-version)
(package-build--valid-version-string (cadr tag-version)))
(apply 'package-build--string-match-all regex text 1 additional-groups))))
(car (nreverse (sort tags (lambda (v1 v2)
(version< (cadr v1) (cadr v2))))))))
(defun package-build--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 'package-build--parse-time
(mapcar 'cadr (package-build--string-match-all regex text 1)))))
(car (nreverse (sort times 'string<)))))
(match-string-no-properties 1))))
(defun package-build--find-version-newest (regex &optional bound)
"Find the newest version matching REGEX before point, optionally stopping at BOUND."
(let ((tags (split-string
(buffer-substring-no-properties
(or bound (point-min)) (point)))))
(setq tags (cl-remove-if nil (mapcar
(lambda (tag)
(when (package-build--valid-version tag regex)
(list (package-build--valid-version tag regex) tag)))
tags)))
;; Returns a list like ((0 1) ("v0.1")); the first element is used
;; for comparison and for `package-version-join', and the second
;; (the original tag) is used by git/hg/etc.
(car (nreverse (sort tags (lambda (v1 v2) (version-list-< (car v1) (car v2))))))))
(defun package-build--run-process (dir command &rest args)
"In DIR (or `default-directory' if unset) run COMMAND with ARGS.
@@ -248,8 +234,7 @@ 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.
Returns a last-modification timestamp for the :files listed in
CONFIG, if any, or `package-build-default-files-spec' otherwise."
Returns the package version as a string."
(let ((repo-type (plist-get config :fetcher)))
(package-build--message "Fetcher: %s" (symbol-name repo-type))
(unless (eq 'wiki repo-type)
@@ -421,7 +406,7 @@ A number as third arg means request confirmation if NEWNAME already exists."
(package-build--run-process nil "svn" "checkout" repo dir)))
(apply 'package-build--run-process dir "svn" "info"
(package-build--expand-source-file-list dir config))
(or (package-build--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\\}\\( [+-][0-9]\\{4\\}\\)?\\)" bound)
(or (package-build--find-parse-time "Last Changed Date: \\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} [0-9]\\{2\\}:[0-9]\\{2\\}:[0-9]\\{2\\}\\( [+-][0-9]\\{4\\}\\)?\\)" bound)
(error "No valid timestamps found!"))))))
@@ -440,7 +425,8 @@ Return a cons cell whose `car' is the root and whose `cdr' is the repository."
(with-current-buffer (get-buffer-create "*package-build-checkout*")
(let ((root (package-build--trim (plist-get config :url) ?/))
(repo (or (plist-get config :module) (symbol-name name)))
(bound (goto-char (point-max))))
(bound (goto-char (point-max)))
latest)
(cond
((and (file-exists-p (expand-file-name "CVS" dir))
(equal (package-build--cvs-repo dir) (cons root repo)))
@@ -463,11 +449,30 @@ Return a cons cell whose `car' is the root and whose `cdr' is the repository."
"-d" target-dir repo))))
(apply 'package-build--run-process dir "cvs" "log"
(package-build--expand-source-file-list dir config))
(or (package-build--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]\\{4\\}\\)?\\)" bound)
(package-build--find-parse-time-latest "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!"))
))))
;; `cvs log` does not provide a way to view the previous N
;; revisions, so instead of parsing the entire log we examine
;; the Entries file, which looks like this:
;;
;; /.cvsignore/1.2/Thu Sep 1 12:42:02 2005//
;; /CHANGES/1.1/Tue Oct 4 11:47:54 2005//
;; /GNUmakefile/1.8/Tue Oct 4 11:47:54 2005//
;; /Makefile/1.14/Tue Oct 4 11:47:54 2005//
;;
(insert-file-contents (concat dir "/CVS/Entries"))
(setq latest (car (sort
(split-string (buffer-substring-no-properties (point) (point-max)) "\n")
(lambda (x y)
(when (string-match "^\\/[^\\/]*\\/[^\\/]*\\/\\([^\\/]*\\)\\/\\/$" x)
(setq x (package-build--parse-time (match-string 1 x))))
(when (string-match "^\\/[^\\/]*\\/[^\\/]*\\/\\([^\\/]*\\)\\/\\/$" y)
(setq y (package-build--parse-time (match-string 1 y))))
(version-list-<= (package-build--valid-version y)
(package-build--valid-version x))))))
(when (string-match "^\\/[^\\/]*\\/[^\\/]*\\/\\([^\\/]*\\)\\/\\/$" latest)
(setq latest (match-string 1 latest)))
(or (package-build--parse-time latest)
(error "No valid timestamps found!"))))))
(defun package-build--git-repo (dir)
"Get the current git repo for DIR."
@@ -501,17 +506,18 @@ Return a cons cell whose `car' is the root and whose `cdr' is the repository."
(package-build--princ-checkout repo dir)
(package-build--run-process nil "git" "clone" repo dir)))
(if package-build-stable
(let* ((bound (goto-char (point-max)))
(tag-version (and (package-build--run-process dir "git" "tag")
(or (package-build--find-tag-version-newest
"^\\(?:v[.-]?\\)?\\([0-9]+[^ \t\n]*\\)$" bound)
(error
"No valid stable versions found for %s"
name)))))
;; Using reset --hard here to comply with what's used for
;; unstable, but maybe this should be a checkout?
(package-build--update-git-to-ref dir (concat "tags/" (car tag-version)))
(cadr tag-version))
(let* ( (bound (goto-char (point-max)))
(regexp (or (plist-get config :version-regexp)
package-build-version-regexp))
(tag-version (and (package-build--run-process dir "git" "tag")
(or (package-build--find-version-newest regexp bound)
(error "No valid stable versions found for %s" name)))) )
;; Using reset --hard here to comply with what's used for
;; unstable, but maybe this should be a checkout?
(package-build--update-git-to-ref dir (concat "tags/" (cadr tag-version)))
;; Return the version as a string
(package-version-join (car tag-version)))
(package-build--update-git-to-ref dir (or commit (concat "origin/" (package-build--git-head-branch dir))))
(apply 'package-build--run-process dir "git" "log" "--first-parent" "-n1" "--pretty=format:'\%ci'"
(package-build--expand-source-file-list dir config))
@@ -589,17 +595,32 @@ Return a cons cell whose `car' is the root and whose `cdr' is the repository."
(package-build--princ-checkout repo dir)
(package-build--run-process nil "hg" "clone" repo dir)))
(if package-build-stable
(let* ((bound (goto-char (point-max)))
(tag-version (and (package-build--run-process dir "hg" "tags")
(or (package-build--find-tag-version-newest
"^\\(?:v[.-]?\\)?\\([0-9]+[^ \t\n]*\\)[ \t]*[0-9]+:\\([[:xdigit:]]+\\)$"
bound
2)
(error
"No valid stable versions found for %s"
name)))))
(package-build--run-process dir "hg" "update" (nth 2 tag-version))
(cadr tag-version))
(let ( (bound (goto-char (point-max)))
(regexp (or (plist-get config :version-regexp)
package-build-version-regexp))
tag-version )
(package-build--run-process dir "hg" "tags")
;; The output of `hg tags` shows the ref of the tag as well
;; as the tag itself, e.g.:
;;
;; tip 1696:73ad80e8fea1
;; 1.2.8 1691:464af57fd2b7
;;
;; So here we remove that second column before passing the
;; buffer contents to `package-build--find-version-newest'.
;; This isn't strictly necessary for Mercurial since the
;; colon in "1691:464af57fd2b7" means that won't be parsed
;; as a valid version-string, but it's an example of how to
;; do it in case it's necessary elsewhere.
(goto-char bound)
(ignore-errors (while (re-search-forward "\\ +.*")
(replace-match "")))
(setq tag-version (or (package-build--find-version-newest regexp bound)
(error "No valid stable versions found for %s" name)))
(package-build--run-process dir "hg" "update" (cadr tag-version))
;; Return the version as a string
(package-version-join (car tag-version)))
(apply 'package-build--run-process dir "hg" "log" "--style" "compact" "-l1"
(package-build--expand-source-file-list dir config))
(package-build--find-parse-time
@@ -853,7 +874,7 @@ to build the recipe."
(car pkg-info))
(cl-assert rest)
(let* ((symbol-keys '(:fetcher))
(string-keys '(:url :repo :module :commit :branch))
(string-keys '(:url :repo :module :commit :branch :version-regexp))
(list-keys '(:files :old-names))
(all-keys (append symbol-keys string-keys list-keys)))
(dolist (thing rest)
@@ -1069,7 +1090,7 @@ and a cl struct in Emacs HEAD. This wrapper normalises the results."
(interactive (list (package-build--package-name-completing-read)))
(let* ((file-name (symbol-name name))
(rcp (or (cdr (assoc name (package-build-recipe-alist)))
(error "Cannot find package %s" file-name)))
(error "Cannot find package %s" (symbol-name name))))
(pkg-working-dir
(file-name-as-directory
(expand-file-name file-name package-build-working-dir))))
@@ -1079,10 +1100,7 @@ and a cl struct in Emacs HEAD. This wrapper normalises the results."
(make-directory package-build-archive-dir))
(package-build--message "\n;;; %s\n" file-name)
(let* ((version (package-version-join
(version-to-list
(or (package-build-checkout name rcp pkg-working-dir)
(error "No valid package version found!")))))
(let* ((version (package-build-checkout name rcp pkg-working-dir))
(default-directory package-build-working-dir)
(start-time (current-time))
(archive-entry (package-build-package (symbol-name name)
@@ -1096,7 +1114,7 @@ and a cl struct in Emacs HEAD. This wrapper normalises the results."
(package-build--message "Built in %.3fs, finished at %s"
(time-to-seconds (time-since start-time))
(current-time-string))
file-name)))
(list file-name version))))
;;;###autoload
(defun package-build-package (package-name version file-specs source-dir target-dir)
View
@@ -0,0 +1,45 @@
(require 'ert)
(require 'cl-lib)
(require 'epg)
(require 'mail-utils)
(require 'message)
(require 'mm-archive)
(require 'network-stream)
(require 'outline)
(require 'url-auth)
(require 'url-cache)
(require 'url-handlers)
(require 'url-http)
(require 'package)
(require 'package-build)
(package-initialize)
(ert-deftest persistent-versions-stable ()
(let ( (package-build-stable t)
(package-archives '(("melpa-stable" . "https://stable.melpa.org/packages/")))
(package-build--recipe-alist (package-build--read-recipes-ignore-errors)))
(package-refresh-contents)
(cl-loop for recipe in (cdr package-archive-contents)
do
(setq recipe (car recipe))
(should (equal
(version-to-list (cadr (package-build-archive recipe)))
(package-desc-version (cadr (assoc recipe package-archive-contents))))))))
(ert-deftest persistent-versions ()
(let ( (package-build-stable nil)
(package-archives '(("melpa" . "https://melpa.org/packages/")))
(package-build--recipe-alist (package-build--read-recipes-ignore-errors)))
(package-refresh-contents)
(cl-loop for recipe in (cdr package-archive-contents)
do
(setq recipe (car recipe))
(should (equal
(version-to-list (cadr (package-build-archive recipe)))
(package-desc-version (cadr (assoc recipe package-archive-contents))))))))

0 comments on commit 1f70c83

Please sign in to comment.