[shepherd] 02/07: Move 'report-error' to (shepherd support).

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository shepherd.

commit aa3e14163de22fd67becd9628ccfde4892a74cd0
Author: Ludovic Courtès <address@hidden>
Date:   Fri Jan 22 22:56:11 2016 +0100

    Move 'report-error' to (shepherd support).
    
    * modules/herd.scm (program-name): Remove.
    (report-error): Remove.
    (main): Parametrize 'program-name'.
    * modules/reboot.scm (program-name): Remove.
    (main): Parametrize 'program-name'.
    * modules/halt.scm (program-name): Remove.
    (main): Parametrize 'program-name'.
    * modules/shepherd.scm (program-name): Remove.
    * modules/shepherd/support.scm (display-version): #:program-name
    defaults to (program-name).
    (program-name): New variable.
    (report-error): New macro, moved from herd.scm.
---
 modules/halt.scm             |   54 ++++++++++++++---------------
 modules/herd.scm             |   76 +++++++++++++++++-------------------------
 modules/reboot.scm           |   54 ++++++++++++++---------------
 modules/shepherd.scm         |    7 +---
 modules/shepherd/support.scm |   20 ++++++++++-
 5 files changed, 104 insertions(+), 107 deletions(-)

diff --git a/modules/halt.scm b/modules/halt.scm
index 96da176..7b938bb 100644
--- a/modules/halt.scm
+++ b/modules/halt.scm
@@ -22,10 +22,7 @@
   #:use-module (shepherd comm)
   #:use-module (oop goops)
   #:use-module (ice-9 rdelim)
-  #:export (program-name
-            main))
-
-(define program-name "halt")
+  #:export (main))
 
 
 
@@ -33,29 +30,30 @@
 (define (main . args)
   (false-if-exception (setlocale LC_ALL ""))
 
-  (let ((socket-file %system-socket-file)
-       (command-args '()))
-    (process-args program-name args
-                 ""
-                 "Halt or power off the system."
-                 not ;; Fail on unknown args.
-                 (make <option>
-                   #:long "socket" #:short #\s
-                   #:takes-arg? #t #:optional-arg? #f #:arg-name "FILE"
-                   #:description "send commands to FILE"
-                   #:action (lambda (file)
-                              (set! socket-file file))))
+  (parameterize ((program-name "halt"))
+    (let ((socket-file %system-socket-file)
+          (command-args '()))
+      (process-args (program-name) args
+                    ""
+                    "Halt or power off the system."
+                    not ;; Fail on unknown args.
+                    (make <option>
+                      #:long "socket" #:short #\s
+                      #:takes-arg? #t #:optional-arg? #f #:arg-name "FILE"
+                      #:description "send commands to FILE"
+                      #:action (lambda (file)
+                                 (set! socket-file file))))
 
-    (set! command-args (reverse command-args))
-    (with-system-error-handling
-     (let ((sock (open-connection socket-file)))
-       ;; Send the command without further ado.
-       (write-command (dmd-command 'power-off 'dmd) sock)
+      (set! command-args (reverse command-args))
+      (with-system-error-handling
+       (let ((sock (open-connection socket-file)))
+         ;; Send the command without further ado.
+         (write-command (dmd-command 'power-off 'dmd) sock)
 
-       ;; Receive output.
-       (setvbuf sock _IOLBF)
-       (let loop ((line (read-line sock)))
-         (unless (eof-object? line)
-           (display line)
-           (newline)
-           (loop (read-line sock))))))))
+         ;; Receive output.
+         (setvbuf sock _IOLBF)
+         (let loop ((line (read-line sock)))
+           (unless (eof-object? line)
+             (display line)
+             (newline)
+             (loop (read-line sock)))))))))
diff --git a/modules/herd.scm b/modules/herd.scm
index 574dbb9..13f531c 100644
--- a/modules/herd.scm
+++ b/modules/herd.scm
@@ -26,22 +26,7 @@
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
-  #:export (program-name
-            main))
-
-(define program-name "herd")
-
-(define-syntax report-error
-  (lambda (s)
-    "Report an error to stderr."
-    (syntax-case s ()
-      ((_ (p message) args ...)
-       (string? (syntax->datum #'message))
-
-       (with-syntax ((message (string-append
-                               "~a: " (syntax->datum #'message) "~%")))
-         #'(format (current-error-port) message
-                   program-name args ...))))))
+  #:export (main))
 
 
 (define-syntax alist-let*
@@ -121,7 +106,7 @@ the daemon via SOCKET-FILE."
      ;; human-readable way.
      (match (read sock)
        (('reply ('version 0 _ ...)                ;no errors
-                ('result result) (error #f)
+                ('result result) ('error #f)
                 ('messages messages))
         ;; First, display raw messages coming from the daemon.  Since they are
         ;; not translated in the user's locale, they should be avoided!
@@ -181,34 +166,35 @@ talking to shepherd"))
 (define (main . args)
   (false-if-exception (setlocale LC_ALL ""))
 
-  (let ((socket-file default-socket-file)
-       (command-args '()))
-    (process-args program-name args
-                 "ACTION SERVICE [ARG...]"
-                 (string-append
-                  "Apply ACTION (start, stop, status, etc.) on SERVICE"
-                  " with the ARGs.")
-                 (lambda (arg)
-                   ;; Collect unknown args.
-                   (set! command-args (cons arg command-args)))
-                 (make <option>
-                   #:long "socket" #:short #\s
-                   #:takes-arg? #t #:optional-arg? #f #:arg-name "FILE"
-                   #:description "send commands to FILE"
-                   #:action (lambda (file)
-                              (set! socket-file file))))
-
-    (match (reverse command-args)
-      (((and action (or "status" "detailed-status"))) ;one argument
-       (run-command socket-file (string->symbol action) 'dmd '()))
-      ((action service args ...)
-       (run-command socket-file
-                    (string->symbol action)
-                    (string->symbol service) args))
-      (_
-       (format (current-error-port)
-               (l10n "Usage: herd ACTION [SERVICE [OPTIONS...]]~%"))
-       (exit 1)))))
+  (parameterize ((program-name "herd"))
+    (let ((socket-file default-socket-file)
+          (command-args '()))
+      (process-args (program-name) args
+                    "ACTION SERVICE [ARG...]"
+                    (string-append
+                     "Apply ACTION (start, stop, status, etc.) on SERVICE"
+                     " with the ARGs.")
+                    (lambda (arg)
+                      ;; Collect unknown args.
+                      (set! command-args (cons arg command-args)))
+                    (make <option>
+                      #:long "socket" #:short #\s
+                      #:takes-arg? #t #:optional-arg? #f #:arg-name "FILE"
+                      #:description "send commands to FILE"
+                      #:action (lambda (file)
+                                 (set! socket-file file))))
+
+      (match (reverse command-args)
+        (((and action (or "status" "detailed-status"))) ;one argument
+         (run-command socket-file (string->symbol action) 'dmd '()))
+        ((action service args ...)
+         (run-command socket-file
+                      (string->symbol action)
+                      (string->symbol service) args))
+        (_
+         (format (current-error-port)
+                 (l10n "Usage: herd ACTION [SERVICE [OPTIONS...]]~%"))
+         (exit 1))))))
 
 ;; Local Variables:
 ;; eval: (put 'alist-let* 'scheme-indent-function 2)
diff --git a/modules/reboot.scm b/modules/reboot.scm
index d92f2de..589f386 100644
--- a/modules/reboot.scm
+++ b/modules/reboot.scm
@@ -22,10 +22,7 @@
   #:use-module (shepherd comm)
   #:use-module (oop goops)
   #:use-module (ice-9 rdelim)
-  #:export (program-name
-            main))
-
-(define program-name "reboot")
+  #:export (main))
 
 
 
@@ -33,29 +30,30 @@
 (define (main . args)
   (false-if-exception (setlocale LC_ALL ""))
 
-  (let ((socket-file %system-socket-file)
-       (command-args '()))
-    (process-args program-name args
-                 ""
-                 "Reboot the system."
-                 not ;; Fail on unknown args.
-                 (make <option>
-                   #:long "socket" #:short #\s
-                   #:takes-arg? #t #:optional-arg? #f #:arg-name "FILE"
-                   #:description "send commands to FILE"
-                   #:action (lambda (file)
-                              (set! socket-file file))))
+  (parameterize ((program-name "reboot"))
+    (let ((socket-file %system-socket-file)
+          (command-args '()))
+      (process-args (program-name) args
+                    ""
+                    "Reboot the system."
+                    not ;; Fail on unknown args.
+                    (make <option>
+                      #:long "socket" #:short #\s
+                      #:takes-arg? #t #:optional-arg? #f #:arg-name "FILE"
+                      #:description "send commands to FILE"
+                      #:action (lambda (file)
+                                 (set! socket-file file))))
 
-    (set! command-args (reverse command-args))
-    (with-system-error-handling
-     (let ((sock (open-connection socket-file)))
-       ;; Send the command without further ado.
-       (write-command (dmd-command 'stop 'dmd) sock)
+      (set! command-args (reverse command-args))
+      (with-system-error-handling
+       (let ((sock (open-connection socket-file)))
+         ;; Send the command without further ado.
+         (write-command (dmd-command 'stop 'dmd) sock)
 
-       ;; Receive output.
-       (setvbuf sock _IOLBF)
-       (let loop ((line (read-line sock)))
-         (unless (eof-object? line)
-           (display line)
-           (newline)
-           (loop (read-line sock))))))))
+         ;; Receive output.
+         (setvbuf sock _IOLBF)
+         (let loop ((line (read-line sock)))
+           (unless (eof-object? line)
+             (display line)
+             (newline)
+             (loop (read-line sock)))))))))
diff --git a/modules/shepherd.scm b/modules/shepherd.scm
index 9ad3d09..b033872 100644
--- a/modules/shepherd.scm
+++ b/modules/shepherd.scm
@@ -32,10 +32,7 @@
   #:use-module (shepherd runlevel)
   #:use-module (shepherd args)
   #:use-module (shepherd comm)
-  #:export (program-name
-            main))
-
-(define program-name "shepherd")
+  #:export (main))
 
 
 
@@ -60,7 +57,7 @@
         (secure      #t)
         (logfile     default-logfile))
     ;; Process command line arguments.
-    (process-args program-name args
+    (process-args (program-name) args
                  ""
                  "This is a service manager for Unix and GNU."
                  not ;; Fail on unknown args.
diff --git a/modules/shepherd/support.scm b/modules/shepherd/support.scm
index 2439085..99a76bf 100644
--- a/modules/shepherd/support.scm
+++ b/modules/shepherd/support.scm
@@ -36,6 +36,8 @@
             l10n
             local-output
             display-version
+            program-name
+            report-error
 
             user-homedir
             default-logfile
@@ -183,13 +185,29 @@ output port, and PROC's result is returned."
     (format #t (gettext format-string) args ...)
     (newline)))
 
-(define* (display-version #:optional (program-name "dmd"))
+(define* (display-version #:optional (program-name (program-name)))
   (local-output "~a (~a) ~a" program-name package-name Version)
   (local-output (l10n "Copyright (C) 2016 the Shepherd 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.
 There is NO WARRANTY, to the extent permitted by law.")))
 
+(define program-name
+  ;; Name of the program currently executing.
+  (make-parameter "shepherd"))
+
+(define-syntax report-error
+  (lambda (s)
+    "Report the given error message to stderr in standard GNU error format."
+    (syntax-case s ()
+      ((_ (p message) args ...)
+       (string? (syntax->datum #'message))
+
+       (with-syntax ((message (string-append
+                               "~a: " (syntax->datum #'message) "~%")))
+         #'(format (current-error-port) message
+                   (program-name) args ...))))))
+
 
 
 ;; Home directory of the user.