From: Matt Birkholz <matt@birchwood-abbey.net>
Date: Mon, 6 Nov 2017 22:48:48 +0000 (-0700)
Subject: devops: Check plugin version numbers in NEWS and make.scm files.
X-Git-Tag: mit-scheme-pucked-9.2.12~27
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=7db22e7de0c7abebc280fcc26fc74d54a165d9c9;p=mit-scheme.git

devops: Check plugin version numbers in NEWS and make.scm files.
---

diff --git a/src/devops/devops.scm b/src/devops/devops.scm
index 207eae998..7ac58bc77 100644
--- a/src/devops/devops.scm
+++ b/src/devops/devops.scm
@@ -86,6 +86,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
      (changes-lint changes)
      (dirt-lint pdirt)
      (debian-version-lint version (debian-version dir))
+     (news-version-lint plugin version)
+     (subsystem-version-lint plugin version)
      (released-version-lint version (released-version pkg) changes)
      (if plugin-lint-hook
 	 (plugin-lint-hook plugin version changes dirt)
@@ -121,6 +123,26 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 		     " does not match."))
        '())))
 
+(define (news-version-lint plugin version)
+  (let ((nvers (read-news-version plugin version)))
+    (append
+     (if (not nvers)
+	 (list "NEWS version not found.")
+	 '())
+     (if (and nvers (not (string=? nvers (version-string version))))
+	 (list (string "NEWS version ("nvers") does not match."))
+	 '()))))
+
+(define (subsystem-version-lint plugin version)
+  (let ((svers (read-subsystem-version plugin version)))
+    (append
+     (if (not svers)
+	 (list "Subsystem version not found.")
+	 '())
+     (if (and svers (not (version=? svers version)))
+	 (list (string "Subsystem version "svers" does not match."))
+	 '()))))
+
 (define (released-version-lint version released changes)
   (cond ((eq? #f released)
 	 (list "First release!"))
@@ -179,6 +201,72 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 		  (error "could not find core version")
 		  (loop))))))))
 
+(define (make-news-pattern fullname)
+  (compile-regsexp `(seq ,fullname
+			 #\space
+			 (group version
+				(+ (alt #\. (char-in numeric))))
+			 " - "
+			 (group author (+ (char-not-in #\,)))
+			 ", "
+			 (group year (+ (char-in numeric)))
+			 "-"
+			 (group month (+ (char-in numeric)))
+			 "-"
+			 (group day (+ (char-in numeric)))
+			 (string-end))))
+
+(define (read-news-version plugin version)
+  (let* ((fullname (string (project-name)"-"(plugin-name plugin)))
+	 (file (string (plugin-directory plugin)"/NEWS")))
+    (and (file-exists? file)
+	 (let ((pattern (make-news-pattern fullname)))
+	   (call-with-input-file file
+	     (lambda (in)
+	       (let loop ()
+		 (let ((line (read-line in)))
+		   (if (eof-object? line)
+		       #f
+		       (let ((match (regsexp-match-string pattern line)))
+			 (if match
+			     (match-extract match 'version)
+			     (loop))))))))))))
+
+(define (make-subsystem-pattern plugin)
+  (compile-regsexp
+   '(seq "(add-subsystem-identification!"
+	 " \""(+ (char-not-in #\"))"\""
+	 " '"(group version (seq "("
+				 (+ (alt #\space (char-in numeric)))
+				 ")"))
+	 ")")))
+
+(define (read-subsystem-version plugin version)
+  (let* ((fullname (string (project-name)"-"(plugin-name plugin)))
+	 (file (find-plugin-make.scm plugin)))
+    (and file
+	 (let ((pattern (make-subsystem-pattern plugin)))
+	   (call-with-input-file file
+	     (lambda (in)
+	       (let loop ()
+		 (let ((line (read-line in)))
+		   (if (eof-object? line)
+		       #f
+		       (let ((match (regsexp-match-string pattern line)))
+			 (if match
+			     (call-with-input-string
+				 (match-extract match 'version)
+			       read)
+			     (loop))))))))))))
+
+(define (find-plugin-make.scm plugin)
+  (or (let ((file (string (plugin-directory plugin)"/make.scm")))
+	(and (file-exists? file)
+	     file))
+      (let ((file (string (plugin-directory plugin)"/mit-make.scm")))
+	(and (file-exists? file)
+	     file))))
+
 (define (released-version name)
   (let ((tags (sorted-tags name)))
     (and (pair? tags)