devops: A parameter (plugin name) for devops:status, and filenames

in the lint messages, to make it easy to find the offender.

diff --git a/src/devops/build.texi b/src/devops/build.texi
index e18edb944ddb6e30c0f8801dda28e23a0ec79d98..530452d1ae188c0b16a1796daf0327ecdb23d54b 100644 (file)
--- a/src/devops/build.texi
+++ b/src/devops/build.texi
@@ -116,10 +116,13 @@ tested.  The developer also needs to know if the core has been changed
 since its last release, which plugins have changed, and what files
 changed.
 
-@deffn Procedure devops:status
+@deffn Procedure devops:status [plugin]
 Write a status report listing the commits to be released and
 warning of unclean files, lint, or other possible trouble.  The
 current working directory should be the top of the git repository.
+If @var{plugin} is not provided the statuses of all plugins (and core)
+are reported, else @var{plugin} should be a symbol or string---the
+name of a plugin.
 @end deffn
 
 With the status report well considered, the developer will create
@@ -129,8 +132,9 @@ is in use, the tag is pushed and the source is uploaded.
 @deffn Procedure devops:release [plugin]
 Warn of unclean files, lint, or other possible trouble, but tag
 @var{plugin} (or core) regardless and build a source distribution.  If
-@var{plugin} is @code{"snapshot"} create source distributions, but not
-git tags, for all changed plugins (or core).
+@var{plugin} is not provided the core is released.  If name is
+``snapshot'' source distributions are created for all changed plugins
+(or core) but no git tags.
 @end deffn
 
 @node Build Process

diff --git a/src/devops/devops.scm b/src/devops/devops.scm
index 7b826997815ddd600d43a57fb28ae149aeb830bd..3c7662dd48beda60ebff66c9ced51e6d0a4e0c31 100644 (file)
--- a/src/devops/devops.scm
+++ b/src/devops/devops.scm
@@ -27,19 +27,24 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 (define (devops:main)
   (let* ((cmdl (command-line))
         (arg1 (and (pair? cmdl) (car cmdl))))
-    (cond ((equal? arg1 "status") (devops:status))
+    (cond ((equal? arg1 "status") (apply devops:status (cdr cmdl)))
          ((equal? arg1 "release") (apply devops:release (cdr cmdl)))
          ((equal? arg1 "build") (apply devops:build (cdr cmdl)))
          (else (error "Unknown developer operation:" cmdl)))))
 
-(define (devops:status)
-  (let ((dirt (shell-lines "git status --porcelain --untracked-files=no")))
+(define (devops:status #!optional name)
+  (if (default-object? name)
+      (status)
+      (plugin-status (->plugin name) (dirt))))
+
+(define (dirt)
+  (shell-lines "git status --porcelain --untracked-files=no"))
+
+(define (status)
+  (let ((dirt (dirt)))
     (if (file-exists? "src/runtime/version.scm")
        (core-status dirt))
-    (let ((ps (plugins)))
-      (if (pair? ps)
-         (for-each (lambda (p) (plugin-status p dirt)) ps)
-         (log "No plugins defined.\n")))))
+    (for-each (lambda (p) (plugin-status p dirt)) plugin-list)))
 
 (define (core-status dirt)
   (let* ((version (core-version))
@@ -70,8 +75,10 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 (define (core-lint version changes dirt)
   (let ((dirt (core-dirt dirt)))
     (append
-     (debian-version-lint version (debian-version "."))
-     (released-version-lint version (released-version (project-name)) changes)
+     (debian-version-lint version "src/runtime/version.scm"
+                         (debian-version ".") "debian/changelog")
+     (released-version-lint version (released-version (project-name))
+                           changes "src/runtime/version.scm")
      (if core-lint-hook
         (core-lint-hook version changes dirt)
         '())
@@ -83,10 +90,12 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
        (pkg (plugin-package plugin))
        (dir (plugin-directory plugin)))
     (append
-     (debian-version-lint version (debian-version dir))
+     (debian-version-lint version (string dir"/configure.ac")
+                         (debian-version dir) (string dir"/debian/changelog"))
      (news-version-lint plugin version)
      (subsystem-version-lint plugin version)
-     (released-version-lint version (released-version pkg) changes)
+     (released-version-lint version (released-version pkg) changes
+                           (string (plugin-directory plugin)"/configure.ac"))
      (if plugin-lint-hook
         (plugin-lint-hook plugin version changes dirt)
         '())
@@ -109,17 +118,18 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
     (and match
         (->version (match-extract match 'version)))))
 
-(define (debian-version-lint version dversion)
+(define (debian-version-lint version filename dversion dfilename)
   (append
    (if (not version)
-       (list "Package version not found.")
+       (list (string filename": Warning: package version not found."))
        '())
    (if (not dversion)
-       (list "Debian version not found.")
+       (list (string dfilename": Warning: Debian version not found."))
        '())
    (if (and version dversion
            (not (version=? version dversion)))
-       (list (string "Debian version ("(version-string dversion)")"
+       (list (string dfilename": Warning: Debian version"
+                    " ("(version-string dversion)")"
                     " does not match."))
        '())))
 
@@ -128,31 +138,34 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
     (if nvers
        (if (string=? nvers (version-string version))
            '()
-           (list (string "NEWS version ("nvers") does not match.")))
-       (list "NEWS version not found."))))
+           (list (string (plugin-directory plugin)"/NEWS:"
+                         " Warning: version ("nvers") does not match.")))
+       (list (string (plugin-directory plugin)"/NEWS:"
+                     " Warning: version not found.")))))
 
 (define (subsystem-version-lint plugin version)
   (let ((svers (read-subsystem-version plugin)))
     (if svers
        (if (version=? svers version)
            '()
-           (list (string "Subsystem version "svers" does not match.")
-                 (string "  (See "(plugin-directory plugin)"/make.scm.)")))
-       (list "Subsystem version not found."
-             (string "  (See "(plugin-directory plugin)"/make.scm.)")))))
+           (list (string (plugin-directory plugin)"/make.scm:"
+                         " Warning: subsystem version "svers
+                         " does not match.")))
+       (list (string (plugin-directory plugin)"/make.scm:"
+                     " Warning: subsystem version not found.")))))
 
-(define (released-version-lint version released changes)
+(define (released-version-lint version released changes filename)
   (cond ((eq? #f released)
         (list "First release!"))
        ((and (pair? changes)
              (not (version>? version released)))
-        (list "Version is out-of-date."))
+        (list (string filename": Warning: version is out-of-date.")))
        (else
         '())))
 
 (define (dirt-lint dirt)
   (if (pair? dirt)
-      (cons "Uncommitted files:" dirt)
+      (cons "Warning: uncommitted files:" dirt)
       '()))
 
 (define (changes-lint changes)
@@ -162,7 +175,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
 (define (core-dirt dirt)
   (filter (lambda (line)
-           (not (any (lambda (plugin) (plugin-dirt? plugin line)) (plugins))))
+           (not (any (lambda (plugin) (plugin-dirt? plugin line))
+                     plugin-list)))
          dirt))
 
 (define (plugin-dirt plugin dirt)
@@ -293,7 +307,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 #;(define (core-changed-files)
   (let ((hash (released-hash (project-name))))
     (and hash
-        (let ((excluded-dirs (map plugin-directory (plugins))))
+        (let ((excluded-dirs (map plugin-directory plugin-list)))
           (filter
            (lambda (filename)
              (not (any (lambda (excluded-dir)
@@ -302,7 +316,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
            (shell-lines "git diff --name-only "hash))))))
 
 (define (plugin-dir-prefixes)
-  (map (lambda (p) (string-append (plugin-directory p) "/")) (plugins)))
+  (map (lambda (p) (string-append (plugin-directory p) "/"))
+       plugin-list))
 
 (define (released-hash name)
   (let* ((tags (sorted-tags name))
@@ -338,7 +353,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 (define (plugin-changes plugin)
   (let ((hash (released-hash (plugin-package plugin))))
     (and hash
-        (shell-lines "git log --oneline --name-status "hash".."
+        (shell-lines "git log --no-merges --oneline --name-status "hash".."
                      " -- "(plugin-directory plugin)"/"))))
 
 #;(define (plugin-changed-files plugin)
@@ -359,11 +374,9 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
               (eq? 'snapshot plugin))
           (snapshot-core dirt)
           (for-each (lambda (p) (snapshot-plugin p dirt))
-                    (plugins)))
+                    plugin-list))
          ((or (string? plugin) (symbol? plugin))
-          (let* ((name (string plugin))
-                 (p (find (lambda (p) (string=? name (plugin-name p)))
-                          (plugins))))
+          (let ((p (->plugin plugin)))
             (release-plugin p (plugin-version p) (plugin-changes p) dirt #f)))
          (else
           (error "Plugin must be a string or symbol.")))))
@@ -731,10 +744,14 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
                 (list (make-plugin name directory))))
   unspecific)
 
-(define (plugins) (list-copy plugin-list))
-
 (define plugin-list '())
 
+(define (->plugin name)
+  (let ((n (string name)))
+    (or (find (lambda (p) (string=? n (plugin-name p)))
+             plugin-list)
+       (error "no such plugin:" name))))
+
 (define-record-type <plugin>
     (make-plugin name directory)
     plugin?