version.lisp 5.87 KB
Newer Older
1 2 3 4 5 6 7
(in-package :asdf-tools)

;;; Extracting version information

(defparameter *version-tag-glob* "[0-9][.][0-9]*")

(defun version-from-tag (&optional commit)
8 9
  ;; run-program issue: :output :line closes the fd, which causes the program to die in error.
  (first (nth-value 1 (git `(describe --tags --match ,*version-tag-glob* ,commit) :output :lines))))
10 11 12

(defun version-from-file (&optional commit)
  (if commit
13
      (nth-value 1 (git `(show (,commit":version.lisp-expr")) :output :form))
14 15 16
      (safe-read-file-form (pn "version.lisp-expr"))))

(defun debian-version-from-file (&optional commit)
17
  (match (if commit
18 19
             ;; run-program issue: :output :line closes the fd, which causes the program to die in error.
             (first (nth-value 1 (git `(show (,commit":debian/changelog")) :output :lines)))
20 21
             (read-file-line (pn "debian/changelog")))
    ((ppcre "^[^(]*\\(([-0-9.:-]+)\\)" ver) ver)))
22

23 24 25 26 27 28 29 30
(defun parse-debian-version (&optional (debian-version (debian-version-from-file)))
  (cl-ppcre:register-groups-bind (epoch ver rel)
      ("^(?:([0-9]+):)?([0-9.]+)(?:-([0-9]+))$" debian-version)
    ;; NB: (A) we return version first, not epoch, because it's the primary result!
    ;; (B) epoch = nil is semantically same as epoch = 0
    ;; (C) rel = nil is for debian-native packages, e.g. base-passwd or cowbuilder
    (values ver epoch rel)))

31 32 33 34 35 36 37 38
(defun debian-version-string (ver epoch rel)
  (format nil "~@[~D:~]~A~@[-~A~]" epoch ver rel))

(defun debian-version-without-epoch (version-string)
  (multiple-value-bind (ver epoch rel) (parse-debian-version version-string)
    (declare (ignore epoch))
    (debian-version-string ver nil rel)))

39 40 41 42 43 44
(defparameter *version* (version-from-file))

;;; Bumping the version of ASDF

(defparameter *versioned-files*
  '(("version.lisp-expr" "\"" "\"")
45
    ("uiop/version.lisp-expr" "\"" "\"")
46 47
    ("asdf.asd" "  :version \"" "\" ;; to be automatically updated by make bump-version")
    ("header.lisp" "This is ASDF " ": Another System Definition Facility.")
48 49 50
    ("upgrade.lisp" "   (asdf-version \"" "\")")
    ("doc/asdf.texinfo" "Manual for Version @value{" "}"))) ;; NB: two occurrences with this pattern.

51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71

(defparameter *old-version* :default)
(defparameter *new-version* :default)

(defun next-version (v)
  (let ((pv (parse-version v 'error)))
    (assert (first pv))
    (assert (second pv))
    (unless (third pv) (appendf pv (list 0)))
    (unless (fourth pv) (appendf pv (list 0)))
    (incf (car (last pv)))
    (unparse-version pv)))

(defun versions-from-args (&optional v1 v2)
  (labels ((check (old new)
             (parse-version old 'error)
             (parse-version new 'error)
             (values old new)))
    (cond
      ((and v1 v2) (check v1 v2))
      (v1 (check (version-from-file) v1))
72
      ((not (eq *new-version* :default)) *new-version*) ;; Ugly passing of argument from Makefile.
73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93
      (t (let ((old (version-from-file)))
           (check old (next-version old)))))))

(deftype byte-vector () '(array (unsigned-byte 8) (*)))

(defun maybe-replace-file (file transformer
                           &key (reader 'read-file-string)
                             (writer nil) (comparator 'equalp)
                             (external-format *utf-8-external-format*))
  (format t "Transforming file ~A... " (file-namestring file))
  (let* ((old-contents (funcall reader file))
         (new-contents (funcall transformer old-contents)))
    (if (funcall comparator old-contents new-contents)
        (format t "no changes needed!~%")
        (let ((written-contents
                (if writer
                    (with-output (s ())
                      (funcall writer s new-contents))
                    new-contents)))
          (check-type written-contents (or string (byte-vector)))
          (clobber-file-with-vector file written-contents :external-format external-format)
94 95
          (format t "done.~%"))))
  (success))
96 97 98 99 100 101 102 103 104 105

(defun version-transformer (new-version file prefix suffix &optional dont-warn)
  (let* ((qprefix (cl-ppcre:quote-meta-chars prefix))
         (versionrx "([0-9]+(\\.[0-9]+)+)")
         (qsuffix (cl-ppcre:quote-meta-chars suffix))
         (regex (strcat "(" qprefix ")(" versionrx ")(" qsuffix ")"))
         (replacement
           (constantly (strcat prefix new-version suffix))))
    (lambda (text)
      (multiple-value-bind (new-text foundp)
106
          (cl-ppcre:regex-replace-all regex text replacement)
107 108 109 110 111 112 113 114
        (unless (or foundp dont-warn)
          (warn "Missing version in ~A" (file-namestring file)))
        (values new-text foundp)))))

(defun transform-file (new-version file prefix suffix)
  (maybe-replace-file (pn file) (version-transformer new-version file prefix suffix)))

(defun transform-files (new-version)
115 116
  (loop :for f :in *versioned-files* :do (apply 'transform-file new-version f))
  (success))
117 118 119 120 121 122 123 124 125

(defun test-transform-file (new-version file prefix suffix)
  (let ((lines (read-file-lines (pn file))))
    (dolist (l lines (progn (warn "Couldn't find a match in ~A" file) nil))
      (multiple-value-bind (new-text foundp)
          (funcall (version-transformer new-version file prefix suffix t) l)
        (when foundp
          (format t "Found a match:~%  ==> ~A~%Replacing with~%  ==> ~A~%~%"
                  l new-text)
126
          (return (success)))))))
127 128 129 130

(defun test-transform (new-version)
  (apply 'test-transform-file new-version (first *versioned-files*)))

131
(defun bump-version (&optional v1 v2)
132
  "bump asdf version, do not commit"
133 134
  (with-asdf-dir ()
    (multiple-value-bind (old-version new-version)
135
        (versions-from-args v1 v2)
136 137 138 139 140 141
      (format t "Bumping ASDF version from ~A to ~A~%" old-version new-version)
      (transform-files new-version)
      (println "Rebuilding ASDF with bumped version")
      (build-asdf)
      new-version)))

142
(defun bump (&optional v1 v2)
143
  "bump asdf version, then commit and tag"
144
  (let ((v (bump-version v1 v2)))
145 146 147
    (git `(commit -a -m ("Bump version to ",v)))
    (git `(tag ,v))
    v))