civodul pushed a commit to branch master
in repository shepherd.
commit 89dd3bb57fa3e3a23cf85385b0788046b7e45170
Author: Ludovic Courtès <[email protected]>
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 <[email protected]>.
---
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)))))))
;;;
