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...
1 parent ef39950 commit 1f70c83016f5d47c08dded0ffda13781c07f7706 @dunn dunn committed Dec 6, 2015
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)
@@ -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.