From: Matt Birkholz <matt@birchwood-abbey.net>
Date: Fri, 21 Jul 2017 05:23:00 +0000 (-0700)
Subject: devops: changes should be #f initially.  Use empty tag message.
X-Git-Tag: mit-scheme-pucked-9.2.12~101
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=2faa691ea7e4a26ecccd21217587c81ba7805f97;p=mit-scheme.git

devops: changes should be #f initially.  Use empty tag message.
---

diff --git a/src/devops/devops.scm b/src/devops/devops.scm
index d91b52df5..02f45aa79 100644
--- a/src/devops/devops.scm
+++ b/src/devops/devops.scm
@@ -35,7 +35,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
 (define (core-status dirt)
   (let* ((version (core-version))
-	 (lint (core-lint version (core-changes) dirt)))
+	 (lint (core-lint version (or (core-changes) '()) dirt)))
     (if (not (null? lint))
 	(begin
 	  (log "# "(project-name)" "(version-string version)":\n")
@@ -116,7 +116,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 (define (released-version-lint version released changes)
   (cond ((eq? #f released)
 	 (list "First release!"))
-	((and (not (null? changes))
+	((and (pair? changes)
 	      (not (version>? version released)))
 	 (list "Version is out-of-date."))
 	(else
@@ -178,21 +178,24 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
 (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"))))
+    (and start-hash
+	 (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))))
@@ -241,10 +244,9 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
 (define (plugin-changes plugin)
   (let ((hash (released-hash (plugin-package plugin))))
-    (if hash
-	(shell-lines "git log --oneline --name-status "hash".."
-		     " -- "(plugin-directory plugin)"/")
-	'())))
+    (and hash
+	 (shell-lines "git log --oneline --name-status "hash".."
+		      " -- "(plugin-directory plugin)"/"))))
 
 #;(define (plugin-changed-files plugin)
   (let ((hash (released-hash (plugin-package plugin))))
@@ -259,7 +261,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 (define (devops:release #!optional plugin)
   (let ((dirt (shell-lines "git status --porcelain --untracked-files=no")))
     (cond ((default-object? plugin)
-	   (release-core dirt #f))
+	   (release-core (core-version) (core-changes) dirt #f))
 	  ((or (equal? "snapshot" plugin)
 	       (eq? 'snapshot plugin))
 	   (snapshot-core dirt)
@@ -269,7 +271,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 	   (let* ((name (string plugin))
 		  (p (find (lambda (p) (string=? name (plugin-name p)))
 			   (plugins))))
-	     (release-plugin p dirt #f)))
+	     (release-plugin p (plugin-version p) (plugin-changes p) dirt #f)))
 	  (else
 	   (error "Plugin must be a string or symbol.")))))
 
@@ -289,10 +291,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
        (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)
+	   (begin
+	     (run "git tag -s -m \"\" "pkgvers)
 	     (run "git archive --prefix="project"/ "pkgvers
 		  " | ( cd devops/"pkgvers" && tar xf - )")))
        (run "cd devops/"pkgvers" && "project"/dist/make-src-files standard")
@@ -321,10 +321,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
        (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)
+	   (begin
+	     (run "git tag -s -m \"\" "pkgvers)
 	     (run "git archive --prefix="pkgvers"/ "pkgvers" -- "dir
 		  " | ( cd devops && tar xf - )")))
        (run "cd devops/"pkgvers"/"dir" && ./autogen.sh")
@@ -364,7 +362,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 	   (error "version has not incremented:" version)))))
 
 (define (snapshot-plugin plugin dirt)
-  (let* ((changes (plugin-changes plugin))
+  (let* ((changes (or (plugin-changes plugin) '()))
 	 (version (plugin-version plugin))
 	 (released (released-version (plugin-package plugin)))
 	 (vers (version-string version))