[shepherd] 02/02: service: Define 'spawn-shell-command' and use it to replace 'system'.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository shepherd.

commit 89dd3bb57fa3e3a23cf85385b0788046b7e45170
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Sat Mar 11 15:51:40 2023 +0100

    service: Define 'spawn-shell-command' and use it to replace 'system'.
    
    * modules/shepherd/service.scm (spawn-shell-command): New procedure.
    (make-system-constructor, make-system-destructor): Use it.
    * modules/shepherd.scm (main): Install 'spawn-shell-command' as a
    replacement for 'system'.
    
    Co-authored-by: Ulf Herrman <striness@tilde.club>.
---
 modules/shepherd.scm         |  7 +++++--
 modules/shepherd/service.scm | 15 +++++++++++++--
 2 files changed, 18 insertions(+), 4 deletions(-)

diff --git a/modules/shepherd.scm b/modules/shepherd.scm
index 2e4e8e5..0a31d6a 100644
--- a/modules/shepherd.scm
+++ b/modules/shepherd.scm
@@ -404,9 +404,11 @@ already ~a threads running, disabling 'signalfd' support")
               (with-process-monitor
                 ;; Replace the default 'system*' binding with one that
                 ;; cooperates instead of blocking on 'waitpid'.
-                (let ((real-system* system*))
+                (let ((real-system* system*)
+                      (real-system  system))
                   (set! system* (lambda command
                                   (spawn-command command)))
+                  (set! system spawn-shell-command)
 
                   ;; Restore 'system*' after fork.
                   (set! primitive-fork
@@ -415,7 +417,8 @@ already ~a threads running, disabling 'signalfd' support")
                             (let ((result (real-fork)))
                               (when (zero? result)
                                 (set! primitive-fork real-fork)
-                                (set! system* real-system*))
+                                (set! system* real-system*)
+                                (set! system real-system))
                               result)))))
 
                 (run-daemon #:socket-file socket-file
diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index 2dab0ca..4562743 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -84,6 +84,7 @@
             handle-SIGCHLD
             with-process-monitor
             spawn-command
+            spawn-shell-command
             %precious-signals
             register-services
             provided-by
@@ -1593,15 +1594,25 @@ process is still running after @var{grace-period} 
seconds, send it
                              #:grace-period grace-period)))
     #f))
 
+(define (spawn-shell-command command)
+  "Spawn @var{command} (a string) using the shell.
+
+This is similar to Guile's @code{system} procedure but does not block while
+waiting for the shell to terminate."
+  (spawn-command (list (or (getenv "SHELL") "/bin/sh")
+                       "-c" command)))
+
 ;; Produce a constructor that executes a command.
 (define (make-system-constructor . command)
   (lambda args
-    (zero? (status:exit-val (system (apply string-append command))))))
+    (zero? (status:exit-val
+            (spawn-shell-command (string-concatenate command))))))
 
 ;; Produce a destructor that executes a command.
 (define (make-system-destructor . command)
   (lambda (ignored . args)
-    (not (zero? (status:exit-val (system (apply string-append command)))))))
+    (not (zero? (status:exit-val
+                 (spawn-shell-command (string-concatenate command)))))))
 
 
 ;;;