From: Matt Birkholz <matt@birchwood-abbey.net>
Date: Fri, 21 Jul 2017 01:30:11 +0000 (-0700)
Subject: devops: Show unreleased commits instead of changed files.
X-Git-Tag: mit-scheme-pucked-9.2.12~103
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=36e8496babf3c63e6dba166cdc80b9c5002b699b;p=mit-scheme.git

devops: Show unreleased commits instead of changed files.
---

diff --git a/src/devops/devops.scm b/src/devops/devops.scm
index cceddbd03..9c5c3aa99 100644
--- a/src/devops/devops.scm
+++ b/src/devops/devops.scm
@@ -34,24 +34,21 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 	  (log "No plugins defined.\n")))))
 
 (define (core-status dirt)
-  (let ((version (core-version))
-	(changed (core-changed-files)))
-    (let ((lint (core-lint version changed dirt)))
-      (if (not (null? lint))
-	  (begin
-	    (log "# "(project-name)" "version":\n")
-	    (write-lint lint)
-	    (write-changed-files changed))))))
+  (let* ((version (core-version))
+	 (lint (core-lint version (core-changes) dirt)))
+    (if (not (null? lint))
+	(begin
+	  (log "# "(project-name)" "version":\n")
+	  (write-lint lint)))))
 
 (define (plugin-status plugin dirt)
-  (let ((changed (plugin-changed-files plugin)))
-    (let ((lint (plugin-lint plugin changed dirt)))
-      (if (not (null? lint))
-	  (let ((name (plugin-name plugin))
-		(vers (plugin-version plugin)))
-	    (log "# "name" "vers":\n")
-	    (write-lint lint)
-	    (write-changed-files changed)))))))
+  (let* ((version (plugin-version plugin))
+	 (changes (plugin-changes plugin))
+	 (lint (plugin-lint plugin version changes dirt)))
+    (if (not (null? lint))
+	(begin
+	  (log "# "(plugin-name plugin)" "version":\n")
+	  (write-lint lint)))))
 
 (define (write-lint lint)
   (for-each (lambda (line)
@@ -59,38 +56,31 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 	      (newline))
 	    lint))
 
-(define (write-changed-files changed)
-  (if (pair? changed)
-      (begin
-	(log "Changed files:\n")
-	(for-each (lambda (filename)
-		    (log "  "filename"\n"))
-		  changed))))
-
 (define core-lint-hook #f)
 (define plugin-lint-hook #f)
 
-(define (core-lint version changed dirt)
-  (let ((dversion (debian-version "."))
-	(released (released-version (project-name))))
+(define (core-lint version changes dirt)
+  (let ((dirt (core-dirt dirt)))
     (append
-     (dirt->core-lint dirt)
-     (debian-version-lint version dversion)
-     (released-version-lint version released changed)
+     (changes-lint changes)
+     (dirt-lint dirt)
+     (debian-version-lint version (debian-version "."))
+     (released-version-lint version (released-version (project-name)) changes)
      (if core-lint-hook
-	 (core-lint-hook)
+	 (core-lint-hook version changes dirt)
 	 '()))))
 
-(define (plugin-lint plugin changed dirt)
-  (let ((version (plugin-version plugin))
-	(dversion (debian-version (plugin-directory plugin)))
-	(released (released-version (plugin-package plugin))))
+(define (plugin-lint plugin version changes dirt)
+  (let ((pdirt (plugin-dirt plugin dirt))
+	(pkg (plugin-package plugin))
+	(dir (plugin-directory plugin)))
     (append
-     (dirt->plugin-lint plugin dirt)
-     (debian-version-lint version dversion)
-     (released-version-lint version released changed)
+     (changes-lint changes)
+     (dirt-lint pdirt)
+     (debian-version-lint version (debian-version dir))
+     (released-version-lint version (released-version pkg) changes)
      (if plugin-lint-hook
-	 (plugin-lint-hook plugin changed dirt)
+	 (plugin-lint-hook plugin version changes dirt)
 	 '()))))
 
 (define (debian-version dir)
@@ -125,33 +115,31 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 	(else
 	 '())))
 
-(define (dirt->core-lint dirt)
-  (let ((lint
-	 (let ((ps (plugins)))
-	   (filter (lambda (line)
-		     (let ((length (string-length line)))
-		       (not (any (lambda (p)
-				   (plugin-dirt? p line length))
-				 ps))))
-		   dirt))))
-    (if (not (null? lint))
-	(cons "Uncommitted changes:" lint)
-	lint)))
-
-(define (dirt->plugin-lint plugin dirt)
-  (let ((lint
-	 (filter (lambda (line)
-		   (plugin-dirt? plugin line (string-length line)))
-		 dirt)))
-    (if (not (null? lint))
-	(cons "Uncommitted changes:" lint)
-	lint)))
+(define (dirt-lint dirt)
+  (if (pair? dirt)
+      (cons "Uncommitted files:" dirt)
+      '()))
+
+(define (changes-lint changes)
+  (if (pair? changes)
+      (cons "Unreleased commits:" changes)
+      '()))
+
+(define (core-dirt dirt)
+  (filter (lambda (line)
+	    (not (any (lambda (plugin) (plugin-dirt? plugin line)) (plugins))))
+	  dirt))
 
-(define (plugin-dirt? plugin line line-len)
+(define (plugin-dirt plugin dirt)
+  (filter (lambda (line)
+	    (plugin-dirt? plugin line))
+	  dirt))
+
+(define (plugin-dirt? plugin line)
   (let* ((dir (plugin-directory plugin))
 	 (dir-len (string-length dir))
 	 (dir-end (fix:+ 3 dir-len)))
-    (and (fix:> line-len dir-end)
+    (and (fix:> (string-length line) dir-end)
 	 (string=? dir (substring line 3 dir-end))
 	 (char=? #\/ (string-ref line dir-end)))))
 
@@ -176,7 +164,25 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
     (and (pair? tags)
 	 (caar tags))))
 
-(define (core-changed-files)
+(define (core-changes)
+  (let ((start-hash (released-hash (project-name))))
+    (append-map!
+     (lambda (hash)
+       (let* ((lines (shell-lines "git log --oneline --name-status -1 "hash))
+	      (files (filter (let ((excludes (plugin-dir-prefixes)))
+			       (lambda (line)
+				 (let* ((i (string-find-next-char line #\tab))
+					(name (substring line (fix:1+ i))))
+				   (not (any (lambda (exclude)
+					       (string-prefix? exclude name))
+					     excludes)))))
+			     (cdr lines))))
+	 (if (null? files)
+	     '()
+	     (cons (car lines) files))))
+     (shell-lines "git log --format=%H "start-hash"..HEAD"))))
+
+#;(define (core-changed-files)
   (let ((hash (released-hash (project-name))))
     (and hash
 	 (let ((excluded-dirs (map plugin-directory (plugins))))
@@ -187,6 +193,9 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 			excluded-dirs)))
 	    (shell-lines "git diff --name-only "hash))))))
 
+(define (plugin-dir-prefixes)
+  (map (lambda (p) (string-append (plugin-directory p) "/")) (plugins)))
+
 (define (released-hash name)
   (let* ((tags (sorted-tags name))
 	 (last-tag (and (pair? tags)
@@ -212,7 +221,14 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 		  (error "no AC_INIT:" (plugin-name plugin))
 		  (loop))))))))
 
-(define (plugin-changed-files plugin)
+(define (plugin-changes plugin)
+  (let ((hash (released-hash (plugin-package plugin))))
+    (if hash
+	(shell-lines "git log --oneline --name-status "hash".."
+		     " -- "(plugin-directory plugin)"/")
+	'())))
+
+#;(define (plugin-changed-files plugin)
   (let ((hash (released-hash (plugin-package plugin))))
     (and hash
 	 (let ((dir (plugin-directory plugin)))
@@ -223,142 +239,135 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 ;;;; Release
 
 (define (devops:release #!optional plugin)
-
-  (define (dirt)
-    (shell-lines "git status --porcelain --untracked-files=no"))
-
-  (cond ((default-object? plugin)
-	 (release-core (dirt) #f))
-	((or (equal? "snapshot" plugin)
-	     (eq? 'snapshot plugin))
-	 (let ((d (dirt)))
-	   (snapshot-core d)
-	   (for-each (lambda (p) (snapshot-plugin p d))
-		     (plugins))))
-	((or (string? plugin) (symbol? plugin))
-	 (let* ((name (string plugin))
-		(p (find (lambda (p) (string=? name (plugin-name p)))
-			 (plugins))))
-	   (release-plugin p (dirt) #f)))
-	(else
-	 (error "Plugin must be a string or symbol."))))
-
-(define (release-core dirt snap?)
-  (let ((changed (core-changed-files)))
-    (if (and (null? changed) (not snap?))
-	(error "no changed files"))
-    (let* ((version (core-version))
-	   (project (project-name))
-	   (pkgvers (string project"-"version))
-	   ;;(topdir (car (shell-lines "/bin/pwd")))
-	   (lint (core-lint version changed dirt)))
-      (log "# "pkgvers":\n")
-      (write-lint lint)
-      (write-changed-files changed)
-      (run "mkdir devops/"pkgvers)
-      (if snap?
-	  (run "git archive --prefix="project"/ HEAD"
-	       " | ( cd devops/"pkgvers" && tar xf - )")
-	  (let ((hash (car (shell-lines "git log --format=%H -1 HEAD")))
-		(datime
-		 (universal-time->local-time-string (get-universal-time))))
-	    (run "git tag -s -m \""datime" "hash"\" "pkgvers)
-	    (run "git archive --prefix="project"/ "pkgvers
-		 " | ( cd devops/"pkgvers" && tar xf - )")))
-      (run "cd devops/"pkgvers" && "project"/dist/make-src-files standard")
-      (run "mv devops/"pkgvers"/"pkgvers".tar.gz devops/")
-      (run "rm -rf devops/"pkgvers)
-      (run "cd devops/ && tar xzf "pkgvers".tar.gz")
-      (run "cd devops/ && dpkg-source --build "pkgvers)
-      (run "chmod 444 devops/"project"_"version".dsc")
-      (run "chmod 444 devops/"project"_"version".tar.xz")
-      (run "rm -rf devops/"pkgvers))))
-
-(define (release-plugin plugin dirt snap?)
-  (let ((changed (plugin-changed-files plugin))
-	(pkgvers (plugin-package/version plugin))
-	(dir (plugin-directory plugin)))
-    (if (and (null? changed) (not snap?))
-	(error "no changed files"))
-    (let ((lint (plugin-lint plugin changed dirt))
-	  (logfile (string "devops/"pkgvers"-src.log")))
-      (log "# "pkgvers":\n")
-      (write-lint lint)
-      (write-changed-files changed)
-      (with-output-log
-       logfile
-       (lambda ()
-	 (if snap?
-	     (run "git archive --prefix="pkgvers"/ HEAD -- "dir
-		  " | ( cd devops && tar xf - )")
-	     (let ((hash (car (shell-lines "git log --format=%H -1 HEAD")))
-		   (datime
-		    (universal-time->local-time-string (get-universal-time))))
-	       (run "git tag -s -m \""datime" "hash"\" "pkgvers)
-	       (run "git archive --prefix="pkgvers"/ "pkgvers" -- "dir
-		    " | ( cd devops && tar xf - )")))
-	 (run "cd devops/"pkgvers"/"dir" && ./autogen.sh")
-	 (run "cd devops/"pkgvers"/"dir" && ./configure")
-	 (run "cd devops/"pkgvers"/"dir" && make dist")
-	 (run "mv devops/"pkgvers"/"dir"/"pkgvers".tar.gz devops/")
-	 (run "chmod 444 devops/"pkgvers".tar.gz")
-	 (run "rm -rf devops/"pkgvers)
-	 (let ((name (plugin-package plugin))
-	       (vers (plugin-version plugin)))
-	   (run "cd devops/ && tar xzf "pkgvers".tar.gz")
-	   (run "cd devops/ && dpkg-source --build "pkgvers)
-	   (run "chmod 444 devops/"name"_"vers".dsc")
-	   (run "chmod 444 devops/"name"_"vers".tar.xz")
-	   (run "rm -rf devops/"pkgvers))))
-      (delete-file logfile))))
+  (let ((dirt (shell-lines "git status --porcelain --untracked-files=no")))
+    (cond ((default-object? plugin)
+	   (release-core dirt #f))
+	  ((or (equal? "snapshot" plugin)
+	       (eq? 'snapshot plugin))
+	   (snapshot-core dirt)
+	   (for-each (lambda (p) (snapshot-plugin p dirt))
+		     (plugins)))
+	  ((or (string? plugin) (symbol? plugin))
+	   (let* ((name (string plugin))
+		  (p (find (lambda (p) (string=? name (plugin-name p)))
+			   (plugins))))
+	     (release-plugin p dirt #f)))
+	  (else
+	   (error "Plugin must be a string or symbol.")))))
+
+(define (release-core version changes dirt snap?)
+  (if (and (null? changes) (not snap?))
+      (error "no unreleased commits"))
+  (let* ((version (core-version))
+	 (project (project-name))
+	 (pkgvers (string project"-"version))
+	 (logfile (string "devops/"pkgvers"-src.log")))
+    (log "# "pkgvers":\n")
+    (write-lint (core-lint version changes dirt))
+    (with-output-log
+     logfile
+     (lambda ()
+       (run "mkdir devops/"pkgvers)
+       (if snap?
+	   (run "git archive --prefix="project"/ HEAD"
+		" | ( cd devops/"pkgvers" && tar xf - )")
+	   (let ((hash (car (shell-lines "git log --format=%H -1 HEAD")))
+		 (datime
+		  (universal-time->local-time-string (get-universal-time))))
+	     (run "git tag -s -m \""datime" "hash"\" "pkgvers)
+	     (run "git archive --prefix="project"/ "pkgvers
+		  " | ( cd devops/"pkgvers" && tar xf - )")))
+       (run "cd devops/"pkgvers" && "project"/dist/make-src-files standard")
+       (run "mv devops/"pkgvers"/"pkgvers".tar.gz devops/")
+       (run "rm -rf devops/"pkgvers)
+       (run "cd devops/ && tar xzf "pkgvers".tar.gz")
+       (run "cd devops/ && dpkg-source --build "pkgvers)
+       (run "chmod 444 devops/"project"_"version".dsc")
+       (run "chmod 444 devops/"project"_"version".tar.xz")
+       (run "rm -rf devops/"pkgvers)))
+    (delete-file logfile)))
+
+(define (release-plugin plugin version changes dirt snap?)
+  (if (and (null? changes) (not snap?))
+      (error "no unreleased commits"))
+  (let* ((pkg (plugin-package plugin))
+	 (pkgvers (string pkg"-"version))
+	 (logfile (string "devops/"pkgvers"-src.log"))
+	 (dir (plugin-directory plugin)))
+    (log "# "pkgvers":\n")
+    (write-lint (plugin-lint plugin version changes dirt))
+    (with-output-log
+     logfile
+     (lambda ()
+       (if snap?
+	   (run "git archive --prefix="pkgvers"/ HEAD -- "dir
+		" | ( cd devops && tar xf - )")
+	   (let ((hash (car (shell-lines "git log --format=%H -1 HEAD")))
+		 (datime
+		  (universal-time->local-time-string (get-universal-time))))
+	     (run "git tag -s -m \""datime" "hash"\" "pkgvers)
+	     (run "git archive --prefix="pkgvers"/ "pkgvers" -- "dir
+		  " | ( cd devops && tar xf - )")))
+       (run "cd devops/"pkgvers"/"dir" && ./autogen.sh")
+       (run "cd devops/"pkgvers"/"dir" && ./configure")
+       (run "cd devops/"pkgvers"/"dir" && make dist")
+       (run "mv devops/"pkgvers"/"dir"/"pkgvers".tar.gz devops/")
+       (run "chmod 444 devops/"pkgvers".tar.gz")
+       (run "rm -rf devops/"pkgvers)
+       (run "cd devops/ && tar xzf "pkgvers".tar.gz")
+       (run "cd devops/ && dpkg-source --build "pkgvers)
+       (run "chmod 444 devops/"pkg"_"version".dsc")
+       (run "chmod 444 devops/"pkg"_"version".tar.xz")
+       (run "rm -rf devops/"pkgvers)))
+    (delete-file logfile)))
 
 (define (snapshot-core dirt)
-  (let ((changed (or (core-changed-files) '()))
-	(version (core-version))
-	(released (released-version (project-name))))
-    (let ((new (->version version))
-	  (source-filename
-	   (string "devops/"(project-name)"-"version".tar.gz")))
-      (define (found) (log "# "source-filename":\nAlready done.\n"))
-      (cond ((and (null? changed)
-		  (version=? new released))
-	     (if (file-exists? source-filename)
-		 (found)
-		 (release-core dirt #t)))
-	    ((and (pair? changed)
-		  (version>? new released))
-	     ;; Clobber!
-	     (release-core dirt #t))
-	    ((null? changed)
-	     (if (file-exists? source-filename)
-		 (found)
-		 (release-core dirt #t)))
-	    (else
-	     (error "version has not incremented:" version))))))
+  (let* ((changes (or (core-changes) '()))
+	 (version (core-version))
+	 (released (released-version (project-name)))
+	 (new (->version version))
+	 (source-filename
+	  (string "devops/"(project-name)"-"version".tar.gz")))
+    (define (found) (log "# "source-filename":\nAlready done.\n"))
+    (cond ((and (null? changes)
+		(version=? new released))
+	   (if (file-exists? source-filename)
+	       (found)
+	       (release-core version changes dirt #t)))
+	  ((and (pair? changes)
+		(version>? new released))
+	   ;; Clobber!
+	   (release-core version changes dirt #t))
+	  ((null? changes)
+	   (if (file-exists? source-filename)
+	       (found)
+	       (release-core version changes dirt #t)))
+	  (else
+	   (error "version has not incremented:" version)))))
 
 (define (snapshot-plugin plugin dirt)
-  (let ((changed (or (plugin-changed-files plugin) '()))
-	(version (plugin-version plugin))
-	(released (released-version (plugin-package plugin))))
-    (let ((new (->version version))
-	  (source-filename
-	   (string "devops/"(plugin-package plugin)"-"version".tar.gz")))
-      (define (found) (log "# "source-filename":\nAlready done.\n"))
-      (cond ((and (null? changed)
-		  (version=? new released))
-	     (if (file-exists? source-filename)
-		 (found)
-		 (release-plugin plugin dirt #t)))
-	    ((and (pair? changed)
-		  (version>? new released))
-	     ;; Clobber!
-	     (release-plugin plugin dirt #t))
-	    ((null? changed)
-	     (if (file-exists? source-filename)
-		 (found)
-		 (release-plugin plugin dirt #t)))
-	    (else
-	     (error "version has not incremented:" version))))))
+  (let* ((changes (plugin-changes plugin))
+	 (version (plugin-version plugin))
+	 (released (released-version (plugin-package plugin)))
+	 (new (->version version))
+	 (source-filename
+	  (string "devops/"(plugin-package plugin)"-"version".tar.gz")))
+    (define (found) (log "# "source-filename":\nAlready done.\n"))
+    (cond ((and (null? changes)
+		(version=? new released))
+	   (if (file-exists? source-filename)
+	       (found)
+	       (release-plugin plugin version changes dirt #t)))
+	  ((and (pair? changes)
+		(version>? new released))
+	   ;; Clobber!
+	   (release-plugin plugin version changes dirt #t))
+	  ((null? changes)
+	   (if (file-exists? source-filename)
+	       (found)
+	       (release-plugin plugin version changes dirt #t)))
+	  (else
+	   (error "version has not incremented:" version)))))
 
 ;;;; Build Status
 
@@ -366,7 +375,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
   (let ((srcs (available-sources "devops"))
 	(hosts (hosts)))
     (if (null? hosts)
-	(error "No build hosts defined.")
+	(error "no build hosts defined")
 	(if (default-object? hostname)
 	    (for-each (lambda (host) (write-host-status host srcs))
 		      hosts)
@@ -603,9 +612,6 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 (define (plugin-package plugin)
   (string (project-name)"-"(plugin-name plugin)))
 
-(define (plugin-package/version plugin)
-  (string (plugin-package plugin)"-"(plugin-version plugin)))
-
 (define (plugin name directory)
   (let ((duplicate (find (lambda (p) (string=? name (plugin-name p)))
 			 plugin-list)))
@@ -687,7 +693,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
   (sort (let ((pattern (compile-regsexp
 			`(seq ,package-name #\-
 			      (group version
-				     (+ (alt #\. (char-in ,char-set:numeric))))
+				     (+ (alt #\. (char-in numeric))))
 			      (string-end)))))
 	  (append-map!
 	   (lambda (line)