gpgscm: Handle exceptions in the transformation monad.
authorJustus Winter <justus@g10code.com>
Thu, 23 Jun 2016 15:18:13 +0000 (17:18 +0200)
committerJustus Winter <justus@g10code.com>
Thu, 23 Jun 2016 15:18:13 +0000 (17:18 +0200)
* tests/gpgscm/tests.scm (pipe:do): Raise errors.
(tr:spawn): Catch and return errors.
(tr:call-with-content): Likewise.
(tr:{open,write-to,pipe-do,assert-identity,assert-weak-identity}):
Adapt.

Signed-off-by: Justus Winter <justus@g10code.com>
tests/gpgscm/tests.scm

index 6c3eb79..ebe1be5 100644 (file)
   (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)
                        ((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)
         `(,@(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)))