civodul pushed a commit to branch master in repository shepherd. commit 9161450cb800f09ba617f456df9d2ec55ebf242b Author: Ludovic Courtès <l...@gnu.org> Date: Sun Oct 16 15:31:23 2016 +0200
service: Protect against wrong number of arguments to 'enable' etc. Fixes <http://bugs.gnu.org/24684>. Reported by Caleb Ristvedt <caleb.ristv...@cune.org>. * modules/shepherd/service.scm (action)[default-action]: Add 'enable', 'disable', and 'doc'. Move 'catch' form around the 'cond' expression. (action) <symbol>: Invoke the other 'action' method. * tests/basic.sh: Add test. --- modules/shepherd/service.scm | 50 +++++++++++++++++++++--------------------- tests/basic.sh | 7 ++++++ 2 files changed, 32 insertions(+), 25 deletions(-) diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm index d3fb348..675639e 100644 --- a/modules/shepherd/service.scm +++ b/modules/shepherd/service.scm @@ -402,6 +402,12 @@ wire." ;; Return the service itself. It is automatically converted to an sexp ;; via 'result->sexp' and sent to the client. obj) + ((enable) + (enable obj)) + ((disable) + (disable obj)) + ((doc) + (apply doc obj args)) (else ;; FIXME: Unknown service. (raise (condition (&unknown-action-error @@ -416,21 +422,23 @@ wire." ;; information. ;; FIXME: Why should the user-implementations not be allowed to be ;; called this way? - (cond ((eq? proc default-action) - (apply default-action (slot-ref obj 'running) args)) - ((not (running? obj)) - (local-output "Service ~a is not running." (canonical-name obj)) - #f) - (else - (catch #t - (lambda () - (apply proc (slot-ref obj 'running) args)) - (lambda (key . args) - ;; Special case: 'root' may quit. - (and (eq? root-service obj) - (eq? key 'quit) - (apply quit args)) - (report-exception the-action obj key args))))))) + (catch #t + (lambda () + (cond ((eq? proc default-action) + (apply default-action (slot-ref obj 'running) args)) + ((not (running? obj)) + (local-output "Service ~a is not running." (canonical-name obj)) + #f) + (else + (apply proc (slot-ref obj 'running) args)))) + (lambda (key . args) + ;; Special case: 'root' may quit. + (and (eq? root-service obj) + (eq? key 'quit) + (apply quit args)) + (if (eq? key 'srfi-34) + (apply throw key args) ;handled by callers + (report-exception the-action obj key args)))))) ;; Display documentation about the service. (define-method (doc (obj <service>) . args) @@ -567,16 +575,8 @@ results." (defines-action? unknown 'action)) (apply action unknown 'action the-action args) (raise (condition (&missing-service-error (name obj)))))) - (map (lambda (s) - (apply (case the-action - ((enable) enable) - ((disable) disable) - ((doc) doc) - (else - (lambda (s . further-args) - (apply action s the-action further-args)))) - s - args)) + (map (lambda (service) + (apply action service the-action args)) which-services)))) ;; EINTR-safe versions of 'system' and 'system*'. diff --git a/tests/basic.sh b/tests/basic.sh index 18884b9..f706ec9 100644 --- a/tests/basic.sh +++ b/tests/basic.sh @@ -94,6 +94,9 @@ then false; else true; fi $herd enable test-2 $herd start test-2 +# This used to crash shepherd: <http://bugs.gnu.org/24684>. +$herd enable test-2 with extra arguments + $herd status test-2 | grep started for action in status start stop @@ -119,6 +122,10 @@ $herd doc root action status if $herd doc root action an-action-that-does-not-exist then false; else true; fi +# Make sure the error message is correct. +$herd doc root action an-action-that-does-not-exist 2>&1 | \ + grep "does not have an action 'an-action-that-does-not-exist'" + # Loading nonexistent file. if $herd load root /does/not/exist.scm; then false; else true; fi