devops: Show unreleased commits instead of changed files.

diff --git a/src/devops/devops.scm b/src/devops/devops.scm
index cceddbd03067243f47c4b2e70dacd5da15379d0d..9c5c3aa9984e9bbb88bc33bfd1db3a3c2887f3a3 100644 (file)
--- 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)))))
 \f
 ;;;; 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)