No OneTemporary
Actions

Size

17 KB

Subscribers

None

View Options

	diff --git a/tests/gpgscm/lib.scm b/tests/gpgscm/lib.scm
	index 48f53ea2f..e23977a5e 100644
	--- a/tests/gpgscm/lib.scm
	+++ b/tests/gpgscm/lib.scm
	@@ -1,163 +1,159 @@
	;; Additional library functions for TinySCHEME.
	;;
	;; Copyright (C) 2016 g10 Code GmbH
	;;
	;; This file is part of GnuPG.
	;;
	;; GnuPG is free software; you can redistribute it and/or modify
	;; it under the terms of the GNU General Public License as published by
	;; the Free Software Foundation; either version 3 of the License, or
	;; (at your option) any later version.
	;;
	;; GnuPG is distributed in the hope that it will be useful,
	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	;; GNU General Public License for more details.
	;;
	;; You should have received a copy of the GNU General Public License
	;; along with this program; if not, see <http://www.gnu.org/licenses/>.

	(macro (assert form)
	`(if (not ,(cadr form))
	(begin
	(display (list "Assertion failed:" (quote ,(cadr form))))
	(newline)
	(exit 1))))
	(assert #t)

	(define (filter pred lst)
	(cond ((null? lst) '())
	((pred (car lst))
	(cons (car lst) (filter pred (cdr lst))))
	(else (filter pred (cdr lst)))))

	(define (any p l)
	(cond ((null? l) #f)
	((p (car l)) #t)
	(else (any p (cdr l)))))

	(define (all p l)
	(cond ((null? l) #t)
	((not (p (car l))) #f)
	(else (all p (cdr l)))))

	;; Is PREFIX a prefix of S?
	(define (string-prefix? s prefix)
	(and (>= (string-length s) (string-length prefix))
	(string=? prefix (substring s 0 (string-length prefix)))))
	(assert (string-prefix? "Scheme" "Sch"))

	;; Is SUFFIX a suffix of S?
	(define (string-suffix? s suffix)
	(and (>= (string-length s) (string-length suffix))
	(string=? suffix (substring s (- (string-length s)
	(string-length suffix))
	(string-length s)))))
	(assert (string-suffix? "Scheme" "eme"))

	;; Locate the first occurrence of needle in haystack starting at offset.
	(ffi-define (string-index haystack needle [offset]))
	(assert (= 2 (string-index "Hallo" #\l)))
	(assert (= 3 (string-index "Hallo" #\l 3)))
	(assert (equal? #f (string-index "Hallo" #\.)))

	;; Locate the last occurrence of needle in haystack starting at offset.
	(ffi-define (string-rindex haystack needle [offset]))
	(assert (= 3 (string-rindex "Hallo" #\l)))
	(assert (equal? #f (string-rindex "Hallo" #\a 2)))
	(assert (equal? #f (string-rindex "Hallo" #\.)))

	;; Split haystack at delimiter at most n times.
	(define (string-splitn haystack delimiter n)
	(let ((length (string-length haystack)))
	(define (split acc delimiter offset n)
	(if (>= offset length)
	(reverse acc)
	(let ((i (string-index haystack delimiter offset)))
	(if (or (eq? i #f) (= 0 n))
	(reverse (cons (substring haystack offset length) acc))
	(split (cons (substring haystack offset i) acc)
	delimiter (+ i 1) (- n 1))))))
	(split '() delimiter 0 n)))
	(assert (= 2 (length (string-splitn "foo:bar:baz" #\: 1))))
	(assert (string=? "foo" (car (string-splitn "foo:bar:baz" #\: 1))))
	(assert (string=? "bar:baz" (cadr (string-splitn "foo:bar:baz" #\: 1))))

	;; Split haystack at delimiter.
	(define (string-split haystack delimiter)
	(string-splitn haystack delimiter -1))
	(assert (= 3 (length (string-split "foo:bar:baz" #\:))))
	(assert (string=? "foo" (car (string-split "foo:bar:baz" #\:))))
	(assert (string=? "bar" (cadr (string-split "foo:bar:baz" #\:))))
	(assert (string=? "baz" (caddr (string-split "foo:bar:baz" #\:))))

	;; Trim the prefix of S containing only characters that make PREDICATE
	;; true.
	(define (string-ltrim predicate s)
	(let loop ((s' (string->list s)))
	(if (predicate (car s'))
	(loop (cdr s'))
	(list->string s'))))
	(assert (string=? "foo" (string-ltrim char-whitespace? " foo")))

	;; Trim the suffix of S containing only characters that make PREDICATE
	;; true.
	(define (string-rtrim predicate s)
	(let loop ((s' (reverse (string->list s))))
	(if (predicate (car s'))
	(loop (cdr s'))
	(list->string (reverse s')))))
	(assert (string=? "foo" (string-rtrim char-whitespace? "foo ")))

	;; Trim both the prefix and suffix of S containing only characters
	;; that make PREDICATE true.
	(define (string-trim predicate s)
	(string-ltrim predicate (string-rtrim predicate s)))
	(assert (string=? "foo" (string-trim char-whitespace? " foo ")))

	;; Check if needle is contained in haystack.
	(ffi-define (string-contains? haystack needle))
	(assert (string-contains? "Hallo" "llo"))
	(assert (not (string-contains? "Hallo" "olla")))

	-(define (echo . msg)
	- (for-each (lambda (x) (display x) (display " ")) msg)
	- (newline))
	-
	;; Read a word from port P.
	(define (read-word . p)
	(list->string
	(let f ()
	(let ((c (apply peek-char p)))
	(cond
	((eof-object? c) '())
	((char-alphabetic? c)
	(apply read-char p)
	(cons c (f)))
	(else
	(apply read-char p)
	'()))))))

	;; Read a line from port P.
	(define (read-line . p)
	(list->string
	(let f ()
	(let ((c (apply peek-char p)))
	(cond
	((eof-object? c) '())
	((char=? c #\newline)
	(apply read-char p)
	'())
	(else
	(apply read-char p)
	(cons c (f))))))))

	;; Read everything from port P.
	(define (read-all . p)
	(let loop ((acc (open-output-string)))
	(let ((c (apply peek-char p)))
	(cond
	((eof-object? c) (get-output-string acc))
	(else
	(write-char (apply read-char p) acc)
	(loop acc))))))
	diff --git a/tests/gpgscm/tests.scm b/tests/gpgscm/tests.scm
	index 7e20c3407..6d70dca5c 100644
	--- a/tests/gpgscm/tests.scm
	+++ b/tests/gpgscm/tests.scm
	@@ -1,402 +1,412 @@
	;; Common definitions for writing tests.
	;;
	;; Copyright (C) 2016 g10 Code GmbH
	;;
	;; This file is part of GnuPG.
	;;
	;; GnuPG is free software; you can redistribute it and/or modify
	;; it under the terms of the GNU General Public License as published by
	;; the Free Software Foundation; either version 3 of the License, or
	;; (at your option) any later version.
	;;
	;; GnuPG is distributed in the hope that it will be useful,
	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	;; GNU General Public License for more details.
	;;
	;; You should have received a copy of the GNU General Public License
	;; along with this program; if not, see <http://www.gnu.org/licenses/>.

	;; Trace displays and returns the given value. A debugging aid.
	(define (trace x)
	(display x)
	(newline)
	x)

	;; Stringification.
	(define (stringify expression)
	(let ((p (open-output-string)))
	(write expression p)
	(get-output-string p)))

	;; Reporting.
	-(define (info msg)
	- (display msg)
	- (newline)
	+(define (echo . msg)
	+ (for-each (lambda (x) (display x) (display " ")) msg)
	+ (newline))
	+
	+(define (info . msg)
	+ (apply echo msg)
	(flush-stdio))

	-(define (error msg)
	- (info msg)
	+(define (error . msg)
	+ (apply info msg)
	(exit 1))

	-(define (skip msg)
	- (info msg)
	+(define (skip . msg)
	+ (apply info msg)
	(exit 77))

	(define (make-counter)
	(let ((c 0))
	(lambda ()
	(let ((r c))
	(set! c (+ 1 c))
	r))))

	(define progress-nesting 0)

	(define (call-with-progress msg what)
	(set! progress-nesting (+ 1 progress-nesting))
	(if (= 1 progress-nesting)
	(begin
	(info msg)
	(display " > ")
	(flush-stdio)
	(what (lambda (item)
	(display item)
	(display " ")
	(flush-stdio)))
	(info "< "))
	(begin
	(what (lambda (item) (display ".") (flush-stdio)))
	(display " ")
	(flush-stdio)))
	(set! progress-nesting (- progress-nesting 1)))

	(define (for-each-p msg proc lst)
	(for-each-p' msg proc (lambda (x) x) lst))

	(define (for-each-p' msg proc fmt lst)
	(call-with-progress
	msg
	(lambda (progress)
	(for-each (lambda (a)
	(progress (fmt a))
	(proc a))
	lst))))

	;; Process management.
	(define CLOSED_FD -1)
	(define (call-with-fds what infd outfd errfd)
	(wait-process (stringify what) (spawn-process-fd what infd outfd errfd) #t))
	(define (call what)
	(call-with-fds what
	CLOSED_FD
	(if (< verbose 0) STDOUT_FILENO CLOSED_FD)
	(if (< verbose 0) STDERR_FILENO CLOSED_FD)))
	(define (call-check what)
	(if (not (= 0 (call what)))
	(throw (list what "failed"))))

	;; Accessor functions for the results of 'spawn-process'.
	(define :stdin car)
	(define :stdout cadr)
	(define :stderr caddr)
	(define :pid cadddr)

	(define (call-with-io what in)
	(let ((h (spawn-process what 0)))
	(es-write (:stdin h) in)
	(es-fclose (:stdin h))
	(let* ((out (es-read-all (:stdout h)))
	(err (es-read-all (:stderr h)))
	(result (wait-process (car what) (:pid h) #t)))
	(es-fclose (:stdout h))
	(es-fclose (:stderr h))
	(list result out err))))

	;; Accessor function for the results of 'call-with-io'. ':stdout' and
	;; ':stderr' can also be used.
	(define :retcode car)

	(define (call-popen command input-string)
	(let ((result (call-with-io command input-string)))
	(if (= 0 (:retcode result))
	(:stdout result)
	(throw (:stderr result)))))

	;;
	;; estream helpers.
	;;

	(define (es-read-all stream)
	(let loop
	((acc ""))
	(if (es-feof stream)
	acc
	(loop (string-append acc (es-read stream 4096))))))

	;;
	;; File management.
	;;
	+(define (file-exists? name)
	+ (call-with-input-file name (lambda (port) #t)))
	+
	(define (file=? a b)
	(file-equal a b #t))

	(define (text-file=? a b)
	(file-equal a b #f))

	(define (file-copy from to)
	(catch '() (unlink to))
	(letfd ((source (open from (logior O_RDONLY O_BINARY)))
	(sink (open to (logior O_WRONLY O_CREAT O_BINARY) #o600)))
	(splice source sink)))

	(define (text-file-copy from to)
	(catch '() (unlink to))
	(letfd ((source (open from O_RDONLY))
	(sink (open to (logior O_WRONLY O_CREAT) #o600)))
	(splice source sink)))

	(define (canonical-path path)
	(if (char=? #\/ (string-ref path 0))
	path
	(string-append (getcwd) "/" path)))

	(define (in-srcdir what)
	(canonical-path (string-append (getenv "srcdir") "/" what)))

	(define (with-path name)
	(let loop ((path (string-split (getenv "GPGSCM_PATH") #\:)))
	(if (null? path)
	name
	(let* ((qualified-name (string-append (car path) "/" name))
	(file-exists (call-with-input-file qualified-name
	(lambda (x) #t))))
	(if file-exists
	qualified-name
	(loop (cdr path)))))))

	(define (basename path)
	(let ((i (string-index path #\/)))
	(if (equal? i #f)
	path
	(basename (substring path (+ 1 i) (string-length path))))))

	;; Helper for (pipe).
	(define :read-end car)
	(define :write-end cadr)

	;; let-like macro that manages file descriptors.
	;;
	;; (letfd <bindings> <body>)
	;;
	;; Bind all variables given in <bindings> and initialize each of them
	;; to the given initial value, and close them after evaluting <body>.
	(macro (letfd form)
	(let ((result-sym (gensym)))
	`((lambda (,(caaadr form))
	(let ((,result-sym
	,(if (= 1 (length (cadr form)))
	`(begin ,@(cddr form))
	`(letfd ,(cdadr form) ,@(cddr form)))))
	(close ,(caaadr form))
	,result-sym)) ,@(cdaadr form))))

	(macro (with-working-directory form)
	(let ((result-sym (gensym)) (cwd-sym (gensym)))
	`(let* ((,cwd-sym (getcwd))
	(_ (if ,(cadr form) (chdir ,(cadr form))))
	(,result-sym (begin ,@(cddr form))))
	(chdir ,cwd-sym)
	,result-sym)))

	(macro (with-temporary-working-directory form)
	(let ((result-sym (gensym)) (cwd-sym (gensym)) (tmp-sym (gensym)))
	`(let* ((,cwd-sym (getcwd))
	(,tmp-sym (mkdtemp "gpgscm-XXXXXX"))
	(_ (chdir ,tmp-sym))
	(,result-sym (begin ,@(cdr form))))
	(chdir ,cwd-sym)
	(unlink-recursively ,tmp-sym)
	,result-sym)))

	(define (make-temporary-file . args)
	(canonical-path (string-append (mkdtemp "gpgscm-XXXXXX")
	"/"
	(if (null? args) "a" (car args)))))

	(define (remove-temporary-file filename)
	(catch '()
	(unlink filename))
	(let ((dirname (substring filename 0 (string-rindex filename #\/))))
	(catch (echo "removing temporary directory" dirname "failed")
	(rmdir dirname))))

	;; let-like macro that manages temporary files.
	;;
	;; (lettmp <bindings> <body>)
	;;
	;; Bind all variables given in <bindings>, initialize each of them to
	;; a string representing an unique path in the filesystem, and delete
	;; them after evaluting <body>.
	(macro (lettmp form)
	(let ((result-sym (gensym)))
	`((lambda (,(caadr form))
	(let ((,result-sym
	,(if (= 1 (length (cadr form)))
	`(begin ,@(cddr form))
	`(lettmp ,(cdadr form) ,@(cddr form)))))
	(remove-temporary-file ,(caadr form))
	,result-sym)) (make-temporary-file ,(symbol->string (caadr form))))))

	(define (check-execution source transformer)
	(lettmp (sink)
	(transformer source sink)))

	(define (check-identity source transformer)
	(lettmp (sink)
	(transformer source sink)
	(if (not (file=? source sink))
	(error "mismatch"))))

	;;
	;; Monadic pipe support.
	;;

	(define pipeM
	(package
	(define (new procs source sink producer)
	(package
	(define (dump)
	(write (list procs source sink producer))
	(newline))
	(define (add-proc command pid)
	(new (cons (list command pid) procs) source sink producer))
	(define (commands)
	(map car procs))
	(define (pids)
	(map cadr procs))
	(define (set-source source')
	(new procs source' sink producer))
	(define (set-sink sink')
	(new procs source sink' producer))
	(define (set-producer producer')
	(if producer
	(throw "producer already set"))
	(new procs source sink producer'))))))


	(define (pipe:do . commands)
	(let loop ((M (pipeM::new '() CLOSED_FD CLOSED_FD #f)) (cmds commands))
	(if (null? cmds)
	(begin
	(if M::producer (M::producer))
	(if (not (null? M::procs))
	(let* ((retcodes (wait-processes (map stringify (M::commands))
	(M::pids) #t))
	(results (map (lambda (p r) (append p (list r)))
	M::procs retcodes))
	(failed (filter (lambda (x) (not (= 0 (caddr x))))
	results)))
	(if (not (null? failed))
	(throw failed))))) ; xxx nicer reporting
	(if (and (= 2 (length cmds)) (number? (cadr cmds)))
	;; hack: if it's an fd, use it as sink
	(let ((M' ((car cmds) (M::set-sink (cadr cmds)))))
	(if (> M::source 2) (close M::source))
	(if (> (cadr cmds) 2) (close (cadr cmds)))
	(loop M' '()))
	(let ((M' ((car cmds) M)))
	(if (> M::source 2) (close M::source))
	(loop M' (cdr cmds)))))))

	(define (pipe:open pathname flags)
	(lambda (M)
	(M::set-source (open pathname flags))))

	(define (pipe:defer producer)
	(lambda (M)
	(let* ((p (outbound-pipe))
	(M' (M::set-source (:read-end p))))
	(M'::set-producer (lambda ()
	(producer (:write-end p))
	(close (:write-end p)))))))
	(define (pipe:echo data)
	(pipe:defer (lambda (sink) (display data (fdopen sink "wb")))))

	(define (pipe:spawn command)
	(lambda (M)
	(define (do-spawn M new-source)
	(let ((pid (spawn-process-fd command M::source M::sink
	(if (> verbose 0)
	STDERR_FILENO CLOSED_FD)))
	(M' (M::set-source new-source)))
	(M'::add-proc command pid)))
	(if (= CLOSED_FD M::sink)
	(let* ((p (pipe))
	(M' (do-spawn (M::set-sink (:write-end p)) (:read-end p))))
	(close (:write-end p))
	(M'::set-sink CLOSED_FD))
	(do-spawn M CLOSED_FD))))

	(define (pipe:splice sink)
	(lambda (M)
	(splice M::source sink)
	(M::set-source CLOSED_FD)))

	(define (pipe:write-to pathname flags mode)
	(open pathname flags mode))

	;;
	;; Monadic transformer support.
	;;

	(define (tr:do . commands)
	(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))))))

	(define (tr:open pathname)
	(lambda (tmpfiles source)
	(list tmpfiles pathname)))

	(define (tr:spawn input command)
	(lambda (tmpfiles source)
	+ (if (and (member 'in command) (not source))
	+ (error (string-append (stringify cmd) " needs an input")))
	(let* ((t (make-temporary-file))
	(cmd (map (lambda (x)
	(cond
	((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))))

	(define (tr:write-to pathname)
	(lambda (tmpfiles source)
	(rename source pathname)
	(list tmpfiles pathname)))

	(define (tr:pipe-do . commands)
	(lambda (tmpfiles source)
	(let ((t (make-temporary-file)))
	(apply pipe:do
	`(,@(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))))

	(define (tr:assert-identity reference)
	(lambda (tmpfiles source)
	(if (not (file=? source reference))
	(error "mismatch"))
	(list tmpfiles source)))

	(define (tr:assert-weak-identity reference)
	(lambda (tmpfiles source)
	(if (not (text-file=? source reference))
	(error "mismatch"))
	(list tmpfiles source)))

	-(define (tr:call-with-content function)
	+(define (tr:call-with-content function . args)
	(lambda (tmpfiles source)
	- (function (call-with-input-file source read-all))
	+ (apply function `(,(call-with-input-file source read-all) ,@args))
	(list tmpfiles source)))

File Metadata

Mime Type: text/x-diff
Expires: Thu, Jul 17, 1:08 AM (1 d, 18 h)
Storage Engine: local-disk
Storage Format: Raw Data
Storage Handle: c7/52/1d357725e18ed29a8d63b4f0ac5d

No OneTemporaryActions

View Options

File Metadata

Event Timeline

No OneTemporary
Actions