base: Add %program-name parameter object.

.dir-locals.el

@@ -11,4 +11,6 @@
  (scheme-mode
   .
   ((indent-tabs-mode . nil)
+   (eval . (put 'test-error 'scheme-indent-function 1))
+   (eval . (put 'make-parameter 'scheme-indent-function 1))
    (eval . (put 'with-database 'scheme-indent-function 1)))))

bin/cuirass.in

@@ -28,8 +28,8 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
              (cuirass ui)
              (ice-9 getopt-long))
 
-(define* (show-help prog)
-  (simple-format #t "Usage: ~a [OPTIONS] [CACHEDIR]" prog)
+(define* (show-help)
+  (simple-format #t "Usage: ~a [OPTIONS] [CACHEDIR]" (%program-name))
   (display "
 Run Guix job from a git repository cloned in CACHEDIR.
 
@@ -113,19 +113,20 @@ DIR if required."
 ;;;
 
 (define* (main #:optional (args (command-line)))
-  (let ((opts     (getopt-long args %options))
-        (progname "cuirass"))
-    (cond
-     ((option-ref opts 'help #f)
-      (show-help progname)
-      (exit 0))
-     ((option-ref opts 'version #f)
-      (show-version progname)
-      (exit 0))
-     (else
-      (parameterize ((%package-database
-                      (option-ref opts 'database (%package-database))))
+  (let ((opts (getopt-long args %options)))
+    (parameterize
+        ((%program-name     (car args))
+         (%package-database (option-ref opts 'database (%package-database))))
+      (cond
+       ((option-ref opts 'help #f)
+        (show-help)
+        (exit 0))
+       ((option-ref opts 'version #f)
+        (show-version)
+        (exit 0))
+       (else
         (let* ((specfile (option-ref opts 'file "tests/hello-subset.scm"))
+               (interval (option-ref opts 'interval "60"))
                (specs    (primitive-load specfile))
                (args     (option-ref opts '() #f))
                (cachedir (if (null? args)
@@ -148,4 +149,4 @@ DIR if required."
                      (lambda ()
                        ((guix-variable 'store 'close-connection) store)))))
                specs)
-              (sleep (string->number (option-ref opts 'interval "60")))))))))))
+              (sleep (string->number interval))))))))))

src/cuirass/base.scm

@@ -1,6 +1,7 @@
 ;;;; base.scm - Cuirass base module
 ;;;
 ;;; Copyright © 2012, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
 ;;;
 ;;; This file is part of Cuirass.
 ;;;
@@ -20,9 +21,23 @@
 (define-module (cuirass base)
   #:use-module (ice-9 format)
   #:use-module (srfi srfi-19)
-  #:export (guix-variable
-            with-directory-excursion
-            call-with-time-display))
+  #:export (;; Procedures.
+            guix-variable
+            call-with-time-display
+            ;; Parameters.
+            %program-name
+            ;; Macros.
+            with-directory-excursion))
+
+(define %program-name
+  ;; Similar in spirit to Gnulib 'progname' module.
+  (make-parameter ""
+    (λ (val)
+      (cond ((not (string? val))
+             (scm-error 'wrong-type-arg
+                        "%program-name" "Not a string: ~S" (list #f) #f))
+            ((string-rindex val #\/) => (λ (idx) (substring val (1+ idx))))
+            (else val)))))
 
 (define (guix-variable module name)
   "Dynamically link variable NAME under Guix module MODULE and return it.

src/cuirass/ui.scm

@@ -18,13 +18,15 @@
 ;;; along with Cuirass.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (cuirass ui)
+  #:use-module (cuirass base)
   #:use-module (cuirass config)
   #:export (show-version
             show-package-information))
 
-(define (show-version prog)
+(define (show-version)
   "Display version information for COMMAND."
-  (simple-format #t "~a (~a) ~a~%" prog %package-name %package-version)
+  (simple-format #t "~a (~a) ~a~%"
+                 (%program-name) %package-name %package-version)
   (display "Copyright (C) 2016 the Cuirass authors
 License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html>
 This is free software: you are free to change and redistribute it.

tests/base.scm

@@ -19,3 +19,7 @@
 
 (use-modules (cuirass base)
              (srfi srfi-64))
+
+(test-error "invalid program name"
+  'wrong-type-arg
+  (%program-name #f))