security-and-privacy/gnupg
security-and-privacy
/
gnupg
mirror of git://git.gnupg.org/gnupg.git
1
0
Fork 0
Code Activity

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@g10code.com>
This commit is contained in:
Justus Winter 2016-06-23 17:18:13 +02:00
parent 1e822654c1
commit 145910afc0
1 changed files with 23 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
tests/gpgscm/tests.scm
View File

@ -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)))