[git] GnuPG - branch, master, updated. gnupg-2.1.16-95-g429891a
by Justus Winter
cvs at cvs.gnupg.org
Tue Dec 13 15:41:38 CET 2016
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "The GNU Privacy Guard".
The branch, master has been updated
via 429891a704057437517cb0b45d11392b40fa1ee8 (commit)
via d43dabf4607d3bcfc217eb9aea34d093f5aa698f (commit)
via 1a176b92a8aad42056ed2c4e1f49a5feb40770cf (commit)
via fe36e63763c9c595bb057ac50160d2aff7c7a63f (commit)
via e3876f16eb237bdeb9f79aca2e7db5e9e2d86686 (commit)
from ab3cdeb4414fecb7ebf4cf93e20c2c70a18c52e6 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 429891a704057437517cb0b45d11392b40fa1ee8
Author: Justus Winter <justus at g10code.com>
Date: Thu Nov 17 13:12:38 2016 +0100
gpgscm: Print failed and skipped tests.
* tests/gpgscm/tests.scm (test-pool::report): Print failed and skipped
tests at the end.
Signed-off-by: Justus Winter <justus at g10code.com>
diff --git a/tests/gpgscm/tests.scm b/tests/gpgscm/tests.scm
index b5df9b7..7b8d489 100644
--- a/tests/gpgscm/tests.scm
+++ b/tests/gpgscm/tests.scm
@@ -538,11 +538,19 @@
(= 99 p::retcode))))
procs))
(define (report)
- (echo (length procs) "tests run,"
- (length (passed)) "succeeded,"
- (length (failed)) "failed,"
- (length (skipped)) "skipped.")
- (length (failed)))))))
+ (define (print-tests tests message)
+ (unless (null? tests)
+ (apply echo (cons message
+ (map (lambda (t) t::name) tests)))))
+
+ (let ((failed' (failed)) (skipped' (skipped)))
+ (echo (length procs) "tests run,"
+ (length (passed)) "succeeded,"
+ (length failed') "failed,"
+ (length skipped') "skipped.")
+ (print-tests failed' "Failed tests:")
+ (print-tests skipped' "Skipped tests:")
+ (length failed')))))))
(define (verbosity n)
(if (= 0 n) '() (cons '--verbose (verbosity (- n 1)))))
commit d43dabf4607d3bcfc217eb9aea34d093f5aa698f
Author: Justus Winter <justus at g10code.com>
Date: Thu Nov 17 11:06:42 2016 +0100
gpgscm: Generalize the test runner.
* tests/gpgscm/tests.scm (test::scm) Add explicit name argument.
(test::binary): Likewise. Also, add missing unquote.
* tests/openpgp/run-tests.scm: Adapt accordingly.
Signed-off-by: Justus Winter <justus at g10code.com>
diff --git a/tests/gpgscm/tests.scm b/tests/gpgscm/tests.scm
index dd4c69f..b5df9b7 100644
--- a/tests/gpgscm/tests.scm
+++ b/tests/gpgscm/tests.scm
@@ -553,18 +553,19 @@
;; A single test.
(define test
(package
- (define (scm path . args)
+ (define (scm name path . args)
;; Start the process.
- (define (spawn-scm args in out err)
+ (define (spawn-scm args' in out err)
(spawn-process-fd `(,*argv0* ,@(verbosity (*verbose*))
- ,(locate-test path) , at args) in out err))
- (new (basename path) #f spawn-scm #f #f CLOSED_FD))
+ ,(locate-test path)
+ , at args' , at args) in out err))
+ (new name #f spawn-scm #f #f CLOSED_FD))
- (define (binary path . args)
+ (define (binary name path . args)
;; Start the process.
- (define (spawn-binary args in out err)
- (spawn-process-fd `(path , at args) in out err))
- (new (basename path) #f spawn-binary #f #f CLOSED_FD))
+ (define (spawn-binary args' in out err)
+ (spawn-process-fd `(,path , at args' , at args) in out err))
+ (new name #f spawn-binary #f #f CLOSED_FD))
(define (new name directory spawn pid retcode logfd)
(package
diff --git a/tests/openpgp/run-tests.scm b/tests/openpgp/run-tests.scm
index a7c282e..4146411 100644
--- a/tests/openpgp/run-tests.scm
+++ b/tests/openpgp/run-tests.scm
@@ -30,4 +30,5 @@
run-tests-parallel
run-tests-sequential))
(tests (filter (lambda (arg) (not (string-prefix? arg "--"))) *args*)))
- (runner (test::scm "setup.scm") (map test::scm tests)))
+ (runner (test::scm "setup.scm" "setup.scm")
+ (map (lambda (t) (test::scm t t)) tests)))
commit 1a176b92a8aad42056ed2c4e1f49a5feb40770cf
Author: Justus Winter <justus at g10code.com>
Date: Wed Nov 16 12:32:17 2016 +0100
gpgscm: Move the test runner to the Scheme library.
* tests/openpgp/run-tests.scm: Move most of the code...
* tests/gpgscm/tests.scm: ... here.
Signed-off-by: Justus Winter <justus at g10code.com>
diff --git a/tests/gpgscm/tests.scm b/tests/gpgscm/tests.scm
index d360272..dd4c69f 100644
--- a/tests/gpgscm/tests.scm
+++ b/tests/gpgscm/tests.scm
@@ -498,3 +498,154 @@
;; Spawn an os shell.
(define (interactive-shell)
(call-with-fds `(,(getenv "SHELL") -i) 0 1 2))
+
+;;
+;; The main test framework.
+;;
+
+;; A pool of tests.
+(define test-pool
+ (package
+ (define (new procs)
+ (package
+ (define (add test)
+ (new (cons test procs)))
+ (define (wait)
+ (let ((unfinished (filter (lambda (t) (not t::retcode)) procs)))
+ (if (null? unfinished)
+ (package)
+ (let* ((names (map (lambda (t) t::name) unfinished))
+ (pids (map (lambda (t) t::pid) unfinished))
+ (results
+ (map (lambda (pid retcode) (list pid retcode))
+ pids
+ (wait-processes (map stringify names) pids #t))))
+ (new
+ (map (lambda (t)
+ (if t::retcode
+ t
+ (t::set-retcode (cadr (assoc t::pid results)))))
+ procs))))))
+ (define (passed)
+ (filter (lambda (p) (= 0 p::retcode)) procs))
+ (define (skipped)
+ (filter (lambda (p) (= 77 p::retcode)) procs))
+ (define (hard-errored)
+ (filter (lambda (p) (= 99 p::retcode)) procs))
+ (define (failed)
+ (filter (lambda (p)
+ (not (or (= 0 p::retcode) (= 77 p::retcode)
+ (= 99 p::retcode))))
+ procs))
+ (define (report)
+ (echo (length procs) "tests run,"
+ (length (passed)) "succeeded,"
+ (length (failed)) "failed,"
+ (length (skipped)) "skipped.")
+ (length (failed)))))))
+
+(define (verbosity n)
+ (if (= 0 n) '() (cons '--verbose (verbosity (- n 1)))))
+
+(define (locate-test path)
+ (if (absolute-path? path) path (in-srcdir path)))
+
+;; A single test.
+(define test
+ (package
+ (define (scm path . args)
+ ;; Start the process.
+ (define (spawn-scm args in out err)
+ (spawn-process-fd `(,*argv0* ,@(verbosity (*verbose*))
+ ,(locate-test path) , at args) in out err))
+ (new (basename path) #f spawn-scm #f #f CLOSED_FD))
+
+ (define (binary path . args)
+ ;; Start the process.
+ (define (spawn-binary args in out err)
+ (spawn-process-fd `(path , at args) in out err))
+ (new (basename path) #f spawn-binary #f #f CLOSED_FD))
+
+ (define (new name directory spawn pid retcode logfd)
+ (package
+ (define (set-directory x)
+ (new name x spawn pid retcode logfd))
+ (define (set-retcode x)
+ (new name directory spawn pid x logfd))
+ (define (set-pid x)
+ (new name directory spawn x retcode logfd))
+ (define (set-logfd x)
+ (new name directory spawn pid retcode x))
+ (define (open-log-file)
+ (let ((filename (string-append (basename name) ".log")))
+ (catch '() (unlink filename))
+ (open filename (logior O_RDWR O_BINARY O_CREAT) #o600)))
+ (define (run-sync . args)
+ (letfd ((log (open-log-file)))
+ (with-working-directory directory
+ (let* ((p (inbound-pipe))
+ (pid (spawn args 0 (:write-end p) (:write-end p))))
+ (close (:write-end p))
+ (splice (:read-end p) STDERR_FILENO log)
+ (close (:read-end p))
+ (let ((t' (set-retcode (wait-process name pid #t))))
+ (t'::report)
+ t')))))
+ (define (run-sync-quiet . args)
+ (with-working-directory directory
+ (set-retcode
+ (wait-process
+ name (spawn args CLOSED_FD CLOSED_FD CLOSED_FD) #t))))
+ (define (run-async . args)
+ (let ((log (open-log-file)))
+ (with-working-directory directory
+ (new name directory spawn
+ (spawn args CLOSED_FD log log)
+ retcode log))))
+ (define (status)
+ (let ((t (assoc retcode '((0 "PASS") (77 "SKIP") (99 "ERROR")))))
+ (if (not t) "FAIL" (cadr t))))
+ (define (report)
+ (unless (= logfd CLOSED_FD)
+ (seek logfd 0 SEEK_SET)
+ (splice logfd STDERR_FILENO)
+ (close logfd))
+ (echo (string-append (status retcode) ":") name))))))
+
+;; Run the setup target to create an environment, then run all given
+;; tests in parallel.
+(define (run-tests-parallel setup tests)
+ (lettmp (gpghome-tar)
+ (setup::run-sync '--create-tarball gpghome-tar)
+ (let loop ((pool (test-pool::new '())) (tests' tests))
+ (if (null? tests')
+ (let ((results (pool::wait)))
+ (for-each (lambda (t)
+ (catch (echo "Removing" t::directory "failed:" *error*)
+ (unlink-recursively t::directory))
+ (t::report)) (reverse results::procs))
+ (exit (results::report)))
+ (let* ((wd (mkdtemp))
+ (test (car tests'))
+ (test' (test::set-directory wd)))
+ (loop (pool::add (test'::run-async '--unpack-tarball gpghome-tar))
+ (cdr tests')))))))
+
+;; Run the setup target to create an environment, then run all given
+;; tests in sequence.
+(define (run-tests-sequential setup tests)
+ (lettmp (gpghome-tar)
+ (setup::run-sync '--create-tarball gpghome-tar)
+ (let loop ((pool (test-pool::new '())) (tests' tests))
+ (if (null? tests')
+ (let ((results (pool::wait)))
+ (for-each (lambda (t)
+ (catch (echo "Removing" t::directory "failed:" *error*)
+ (unlink-recursively t::directory)))
+ results::procs)
+ (exit (results::report)))
+ (let* ((wd (mkdtemp))
+ (test (car tests'))
+ (test' (test::set-directory wd)))
+ (loop (pool::add (test'::run-sync '--unpack-tarball gpghome-tar))
+ (cdr tests')))))))
diff --git a/tests/openpgp/run-tests.scm b/tests/openpgp/run-tests.scm
index cea50db..a7c282e 100644
--- a/tests/openpgp/run-tests.scm
+++ b/tests/openpgp/run-tests.scm
@@ -26,147 +26,6 @@
;; Set objdir so that the tests can locate built programs.
(setenv "objdir" (getcwd) #f)
-(define test-pool
- (package
- (define (new procs)
- (package
- (define (add test)
- (new (cons test procs)))
- (define (wait)
- (let ((unfinished (filter (lambda (t) (not t::retcode)) procs)))
- (if (null? unfinished)
- (package)
- (let* ((names (map (lambda (t) t::name) unfinished))
- (pids (map (lambda (t) t::pid) unfinished))
- (results
- (map (lambda (pid retcode) (list pid retcode))
- pids
- (wait-processes (map stringify names) pids #t))))
- (new
- (map (lambda (t)
- (if t::retcode
- t
- (t::set-retcode (cadr (assoc t::pid results)))))
- procs))))))
- (define (passed)
- (filter (lambda (p) (= 0 p::retcode)) procs))
- (define (skipped)
- (filter (lambda (p) (= 77 p::retcode)) procs))
- (define (hard-errored)
- (filter (lambda (p) (= 99 p::retcode)) procs))
- (define (failed)
- (filter (lambda (p)
- (not (or (= 0 p::retcode) (= 77 p::retcode)
- (= 99 p::retcode))))
- procs))
- (define (report)
- (echo (length procs) "tests run,"
- (length (passed)) "succeeded,"
- (length (failed)) "failed,"
- (length (skipped)) "skipped.")
- (length (failed)))))))
-
-(define (verbosity n)
- (if (= 0 n) '() (cons '--verbose (verbosity (- n 1)))))
-
-(define (locate-test path)
- (if (absolute-path? path) path (in-srcdir path)))
-
-(define test
- (package
- (define (scm path . args)
- ;; Start the process.
- (define (spawn-scm args in out err)
- (spawn-process-fd `(,*argv0* ,@(verbosity (*verbose*))
- ,(locate-test path) , at args) in out err))
- (new (basename path) #f spawn-scm #f #f CLOSED_FD))
-
- (define (binary path . args)
- ;; Start the process.
- (define (spawn-binary args in out err)
- (spawn-process-fd `(path , at args) in out err))
- (new (basename path) #f spawn-binary #f #f CLOSED_FD))
-
- (define (new name directory spawn pid retcode logfd)
- (package
- (define (set-directory x)
- (new name x spawn pid retcode logfd))
- (define (set-retcode x)
- (new name directory spawn pid x logfd))
- (define (set-pid x)
- (new name directory spawn x retcode logfd))
- (define (set-logfd x)
- (new name directory spawn pid retcode x))
- (define (open-log-file)
- (let ((filename (string-append (basename name) ".log")))
- (catch '() (unlink filename))
- (open filename (logior O_RDWR O_BINARY O_CREAT) #o600)))
- (define (run-sync . args)
- (letfd ((log (open-log-file)))
- (with-working-directory directory
- (let* ((p (inbound-pipe))
- (pid (spawn args 0 (:write-end p) (:write-end p))))
- (close (:write-end p))
- (splice (:read-end p) STDERR_FILENO log)
- (close (:read-end p))
- (let ((t' (set-retcode (wait-process name pid #t))))
- (t'::report)
- t')))))
- (define (run-sync-quiet . args)
- (with-working-directory directory
- (set-retcode
- (wait-process
- name (spawn args CLOSED_FD CLOSED_FD CLOSED_FD) #t))))
- (define (run-async . args)
- (let ((log (open-log-file)))
- (with-working-directory directory
- (new name directory spawn
- (spawn args CLOSED_FD log log)
- retcode log))))
- (define (status)
- (let ((t (assoc retcode '((0 "PASS") (77 "SKIP") (99 "ERROR")))))
- (if (not t) "FAIL" (cadr t))))
- (define (report)
- (unless (= logfd CLOSED_FD)
- (seek logfd 0 SEEK_SET)
- (splice logfd STDERR_FILENO)
- (close logfd))
- (echo (string-append (status retcode) ":") name))))))
-
-(define (run-tests-parallel setup tests)
- (lettmp (gpghome-tar)
- (setup::run-sync '--create-tarball gpghome-tar)
- (let loop ((pool (test-pool::new '())) (tests' tests))
- (if (null? tests')
- (let ((results (pool::wait)))
- (for-each (lambda (t)
- (catch (echo "Removing" t::directory "failed:" *error*)
- (unlink-recursively t::directory))
- (t::report)) (reverse results::procs))
- (exit (results::report)))
- (let* ((wd (mkdtemp))
- (test (car tests'))
- (test' (test::set-directory wd)))
- (loop (pool::add (test'::run-async '--unpack-tarball gpghome-tar))
- (cdr tests')))))))
-
-(define (run-tests-sequential setup tests)
- (lettmp (gpghome-tar)
- (setup::run-sync '--create-tarball gpghome-tar)
- (let loop ((pool (test-pool::new '())) (tests' tests))
- (if (null? tests')
- (let ((results (pool::wait)))
- (for-each (lambda (t)
- (catch (echo "Removing" t::directory "failed:" *error*)
- (unlink-recursively t::directory)))
- results::procs)
- (exit (results::report)))
- (let* ((wd (mkdtemp))
- (test (car tests'))
- (test' (test::set-directory wd)))
- (loop (pool::add (test'::run-sync '--unpack-tarball gpghome-tar))
- (cdr tests')))))))
-
(let* ((runner (if (member "--parallel" *args*)
run-tests-parallel
run-tests-sequential))
commit fe36e63763c9c595bb057ac50160d2aff7c7a63f
Author: Justus Winter <justus at g10code.com>
Date: Wed Nov 16 09:19:33 2016 +0100
tests: Refactor test runner.
* tests/openpgp/run-tests.scm (locate-test): New function.
(test): Factor-out the code starting the child process.
(test::binary): New function.
Signed-off-by: Justus Winter <justus at g10code.com>
diff --git a/tests/openpgp/run-tests.scm b/tests/openpgp/run-tests.scm
index 90879a6..cea50db 100644
--- a/tests/openpgp/run-tests.scm
+++ b/tests/openpgp/run-tests.scm
@@ -36,12 +36,12 @@
(let ((unfinished (filter (lambda (t) (not t::retcode)) procs)))
(if (null? unfinished)
(package)
- (let* ((commands (map (lambda (t) t::command) unfinished))
+ (let* ((names (map (lambda (t) t::name) unfinished))
(pids (map (lambda (t) t::pid) unfinished))
(results
(map (lambda (pid retcode) (list pid retcode))
pids
- (wait-processes (map stringify commands) pids #t))))
+ (wait-processes (map stringify names) pids #t))))
(new
(map (lambda (t)
(if t::retcode
@@ -69,31 +69,43 @@
(define (verbosity n)
(if (= 0 n) '() (cons '--verbose (verbosity (- n 1)))))
+(define (locate-test path)
+ (if (absolute-path? path) path (in-srcdir path)))
+
(define test
(package
- (define (scm name . args)
- (new name #f `(,*argv0* ,@(verbosity (*verbose*)) , at args
- ,(in-srcdir name)) #f #f CLOSED_FD))
- (define (new name directory command pid retcode logfd)
+ (define (scm path . args)
+ ;; Start the process.
+ (define (spawn-scm args in out err)
+ (spawn-process-fd `(,*argv0* ,@(verbosity (*verbose*))
+ ,(locate-test path) , at args) in out err))
+ (new (basename path) #f spawn-scm #f #f CLOSED_FD))
+
+ (define (binary path . args)
+ ;; Start the process.
+ (define (spawn-binary args in out err)
+ (spawn-process-fd `(path , at args) in out err))
+ (new (basename path) #f spawn-binary #f #f CLOSED_FD))
+
+ (define (new name directory spawn pid retcode logfd)
(package
(define (set-directory x)
- (new name x command pid retcode logfd))
+ (new name x spawn pid retcode logfd))
(define (set-retcode x)
- (new name directory command pid x logfd))
+ (new name directory spawn pid x logfd))
(define (set-pid x)
- (new name directory command x retcode logfd))
+ (new name directory spawn x retcode logfd))
(define (set-logfd x)
- (new name directory command pid retcode x))
+ (new name directory spawn pid retcode x))
(define (open-log-file)
- (let ((filename (string-append name ".log")))
+ (let ((filename (string-append (basename name) ".log")))
(catch '() (unlink filename))
(open filename (logior O_RDWR O_BINARY O_CREAT) #o600)))
(define (run-sync . args)
(letfd ((log (open-log-file)))
(with-working-directory directory
(let* ((p (inbound-pipe))
- (pid (spawn-process-fd (append command args) 0
- (:write-end p) (:write-end p))))
+ (pid (spawn args 0 (:write-end p) (:write-end p))))
(close (:write-end p))
(splice (:read-end p) STDERR_FILENO log)
(close (:read-end p))
@@ -104,13 +116,12 @@
(with-working-directory directory
(set-retcode
(wait-process
- name (spawn-process-fd (append command args)
- CLOSED_FD CLOSED_FD CLOSED_FD) #t))))
+ name (spawn args CLOSED_FD CLOSED_FD CLOSED_FD) #t))))
(define (run-async . args)
(let ((log (open-log-file)))
(with-working-directory directory
- (new name directory command
- (spawn-process-fd (append command args) CLOSED_FD log log)
+ (new name directory spawn
+ (spawn args CLOSED_FD log log)
retcode log))))
(define (status)
(let ((t (assoc retcode '((0 "PASS") (77 "SKIP") (99 "ERROR")))))
commit e3876f16eb237bdeb9f79aca2e7db5e9e2d86686
Author: Justus Winter <justus at g10code.com>
Date: Wed Nov 16 12:02:03 2016 +0100
gpgscm: Improve library functions.
* tests/gpgscm/tests.scm (absolute-path?): New function.
(canonical-path): Use the new function.
* tests/gpgscm/lib.scm (string-split-pln): New function.
(string-indexp, string-splitp): Likewise.
(string-splitn): Express using the above function.
(string-ltrim, string-rtrim): Fix corner case.
(list->string-reversed): New function.
(read-line): Fix performance.
Signed-off-by: Justus Winter <justus at g10code.com>
diff --git a/tests/gpgscm/lib.scm b/tests/gpgscm/lib.scm
index 4e19eae..fabbef8 100644
--- a/tests/gpgscm/lib.scm
+++ b/tests/gpgscm/lib.scm
@@ -86,18 +86,47 @@
(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)
+;; Split HAYSTACK at each character that makes PREDICATE true at most
+;; N times.
+(define (string-split-pln haystack predicate lookahead n)
(let ((length (string-length haystack)))
- (define (split acc delimiter offset n)
+ (define (split acc offset n)
(if (>= offset length)
(reverse acc)
- (let ((i (string-index haystack delimiter offset)))
+ (let ((i (lookahead haystack 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)))
+ (+ i 1) (- n 1))))))
+ (split '() 0 n)))
+
+(define (string-indexp haystack offset predicate)
+ (cond
+ ((= (string-length haystack) offset)
+ #f)
+ ((predicate (string-ref haystack offset))
+ offset)
+ (else
+ (string-indexp haystack (+ 1 offset) predicate))))
+
+;; Split HAYSTACK at each character that makes PREDICATE true at most
+;; N times.
+(define (string-splitp haystack predicate n)
+ (string-split-pln haystack predicate
+ (lambda (haystack offset)
+ (string-indexp haystack offset predicate))
+ n))
+(assert (equal? '("a" "b") (string-splitp "a b" char-whitespace? -1)))
+(assert (equal? '("a" "b") (string-splitp "a\tb" char-whitespace? -1)))
+(assert (equal? '("a" "" "b") (string-splitp "a \tb" char-whitespace? -1)))
+
+;; Split haystack at delimiter at most n times.
+(define (string-splitn haystack delimiter n)
+ (string-split-pln haystack
+ (lambda (c) (char=? c delimiter))
+ (lambda (haystack offset)
+ (string-index haystack delimiter offset))
+ 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))))
@@ -122,25 +151,32 @@
;; 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'))))
+ (if (string=? s "")
+ ""
+ (let loop ((s' (string->list s)))
+ (if (predicate (car s'))
+ (loop (cdr s'))
+ (list->string s')))))
+(assert (string=? "" (string-ltrim char-whitespace? "")))
(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')))))
+ (if (string=? s "")
+ ""
+ (let loop ((s' (reverse (string->list s))))
+ (if (predicate (car s'))
+ (loop (cdr s'))
+ (list->string (reverse s'))))))
+(assert (string=? "" (string-rtrim char-whitespace? "")))
(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=? "" (string-trim char-whitespace? "")))
(assert (string=? "foo" (string-trim char-whitespace? " foo ")))
;; Check if needle is contained in haystack.
@@ -162,19 +198,34 @@
(apply read-char p)
'()))))))
+(define (list->string-reversed lst)
+ (let* ((len (length lst))
+ (str (make-string len)))
+ (let loop ((i (- len 1))
+ (l lst))
+ (if (< i 0)
+ (begin
+ (assert (null? l))
+ str)
+ (begin
+ (string-set! str i (car l))
+ (loop (- i 1) (cdr l)))))))
+
;; 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))))))))
+ (let loop ((acc '()))
+ (let ((c (apply peek-char p)))
+ (cond
+ ((eof-object? c)
+ (if (null? acc)
+ c ;; #eof
+ (list->string-reversed acc)))
+ ((char=? c #\newline)
+ (apply read-char p)
+ (list->string-reversed acc))
+ (else
+ (apply read-char p)
+ (loop (cons c acc)))))))
;; Read everything from port P.
(define (read-all . p)
diff --git a/tests/gpgscm/tests.scm b/tests/gpgscm/tests.scm
index bec1922..d360272 100644
--- a/tests/gpgscm/tests.scm
+++ b/tests/gpgscm/tests.scm
@@ -186,16 +186,19 @@
(assert (string=? (path-join "foo" "bar" "baz") "foo/bar/baz"))
(assert (string=? (path-join "" "bar" "baz") "bar/baz"))
+;; Is PATH an absolute path?
+(define (absolute-path? path)
+ (or (char=? #\/ (string-ref path 0))
+ (and *win32* (char=? #\\ (string-ref path 0)))
+ (and *win32*
+ (char-alphabetic? (string-ref path 0))
+ (char=? #\: (string-ref path 1))
+ (or (char=? #\/ (string-ref path 2))
+ (char=? #\\ (string-ref path 2))))))
+
+;; Make PATH absolute.
(define (canonical-path path)
- (if (or (char=? #\/ (string-ref path 0))
- (and *win32* (char=? #\\ (string-ref path 0)))
- (and *win32*
- (char-alphabetic? (string-ref path 0))
- (char=? #\: (string-ref path 1))
- (or (char=? #\/ (string-ref path 2))
- (char=? #\\ (string-ref path 2)))))
- path
- (path-join (getcwd) path)))
+ (if (absolute-path? path) path (path-join (getcwd) path)))
(define (in-srcdir . names)
(canonical-path (apply path-join (cons (getenv "srcdir") names))))
-----------------------------------------------------------------------
Summary of changes:
tests/gpgscm/lib.scm | 101 ++++++++++++++++++------
tests/gpgscm/tests.scm | 181 +++++++++++++++++++++++++++++++++++++++++---
tests/openpgp/run-tests.scm | 133 +-------------------------------
3 files changed, 250 insertions(+), 165 deletions(-)
hooks/post-receive
--
The GNU Privacy Guard
http://git.gnupg.org
More information about the Gnupg-commits
mailing list