diff --git a/tests/gpgscm/tests.scm b/tests/gpgscm/tests.scm index 6c3eb7975..ebe1be5c6 100644 --- a/tests/gpgscm/tests.scm +++ b/tests/gpgscm/tests.scm @@ -364,12 +364,19 @@ (let loop ((tmpfiles '()) (source #f) (cmds commands)) (if (null? cmds) (for-each remove-temporary-file tmpfiles) - (let ((v ((car cmds) tmpfiles source))) - (loop (car v) (cadr v) (cdr cmds)))))) + (let* ((v ((car cmds) tmpfiles source)) + (tmpfiles' (car v)) + (sink (cadr v)) + (error (caddr v))) + (if error + (begin + (for-each remove-temporary-file tmpfiles') + (throw error))) + (loop tmpfiles' sink (cdr cmds)))))) (define (tr:open pathname) (lambda (tmpfiles source) - (list tmpfiles pathname))) + (list tmpfiles pathname #f))) (define (tr:spawn input command) (lambda (tmpfiles source) @@ -381,15 +388,17 @@ ((equal? '**in** x) source) ((equal? '**out** x) t) (else x))) command))) - (call-popen cmd input) - (if (and (member '**out** command) (not (file-exists? t))) - (error (string-append (stringify cmd) " did not produce '" t "'."))) - (list (cons t tmpfiles) t)))) + (catch (list (cons t tmpfiles) t *error*) + (call-popen cmd input) + (if (and (member '**out** command) (not (file-exists? t))) + (error (string-append (stringify cmd) + " did not produce '" t "'."))) + (list (cons t tmpfiles) t #f))))) (define (tr:write-to pathname) (lambda (tmpfiles source) (rename source pathname) - (list tmpfiles pathname))) + (list tmpfiles pathname #f))) (define (tr:pipe-do . commands) (lambda (tmpfiles source) @@ -398,21 +407,22 @@ `(,@(if source `(,(pipe:open source (logior O_RDONLY O_BINARY))) '()) ,@commands ,(pipe:write-to t (logior O_WRONLY O_BINARY O_CREAT) #o600))) - (list (cons t tmpfiles) t)))) + (list (cons t tmpfiles) t #f)))) (define (tr:assert-identity reference) (lambda (tmpfiles source) (if (not (file=? source reference)) (error "mismatch")) - (list tmpfiles source))) + (list tmpfiles source #f))) (define (tr:assert-weak-identity reference) (lambda (tmpfiles source) (if (not (text-file=? source reference)) (error "mismatch")) - (list tmpfiles source))) + (list tmpfiles source #f))) (define (tr:call-with-content function . args) (lambda (tmpfiles source) - (apply function `(,(call-with-input-file source read-all) ,@args)) - (list tmpfiles source))) + (catch (list tmpfiles source *error*) + (apply function `(,(call-with-input-file source read-all) ,@args))) + (list tmpfiles source #f)))