[Pkg-gnupg-commit] [gnupg2] 47/160: gpgscm: Handle exceptions in the transformation monad.

[Daniel Kahn Gillmor]

This is an automated email from the git hooks/post-receive script.

dkg pushed a commit to branch upstream
in repository gnupg2.

commit 145910afc077e7a5df6cc8b10e180dfa6ce38cc3
Author: Justus Winter <justus at g10code.com>
Date:   Thu Jun 23 17:18:13 2016 +0200

    gpgscm: Handle exceptions in the transformation monad.
    
    * 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 at g10code.com>
---
 tests/gpgscm/tests.scm | 36 +++++++++++++++++++++++-------------
 1 file changed, 23 insertions(+), 13 deletions(-)

diff --git a/tests/gpgscm/tests.scm b/tests/gpgscm/tests.scm
index 6c3eb79..ebe1be5 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))) '())
 	  , at 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) , at args))
-    (list tmpfiles source)))
+    (catch (list tmpfiles source *error*)
+	   (apply function `(,(call-with-input-file source read-all) , at args)))
+    (list tmpfiles source #f)))

-- 
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-gnupg/gnupg2.git