[git] GnuPG - branch, master, updated. gnupg-2.1.13-30-g0340fcd
by Justus Winter
cvs at cvs.gnupg.org
Tue Jun 21 16:22:30 CEST 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 0340fcdac864109e3dd6edee759efc96e4d3f84e (commit)
via 65081c31e7536d8fb5effcc2c9aeeffc120c9a69 (commit)
via 5fbbc4b334a73150e709a4802cac99abd8ada61d (commit)
via d99949fc8cf541018267964629992d55c97ca9ab (commit)
via 616582071a2c76c4fb529d4da549aa95ee5d78d6 (commit)
from c19b2061274cd50838e62a2acbdc7e7d24888e7e (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 0340fcdac864109e3dd6edee759efc96e4d3f84e
Author: Justus Winter <justus at g10code.com>
Date: Tue Jun 21 13:20:29 2016 +0200
tests/openpgp: Port the remaining tests to Scheme.
* tests/openpgp/Makefile.am (TESTS): Add new tests.
* tests/openpgp/defs.scm (gpg-with-colons): New function.
(get-config): Use new function.
* tests/openpgp/export.scm: New file.
* tests/openpgp/tofu.scm: Likewise.
Signed-off-by: Justus Winter <justus at g10code.com>
diff --git a/tests/openpgp/Makefile.am b/tests/openpgp/Makefile.am
index 921619f..5c4c370 100644
--- a/tests/openpgp/Makefile.am
+++ b/tests/openpgp/Makefile.am
@@ -40,12 +40,6 @@ TESTS_ENVIRONMENT = GNUPGHOME=$(abs_builddir) GPG_AGENT_INFO= LC_ALL=C \
objdir=$(abs_top_builddir) \
GPGSCM_PATH=$(top_srcdir)/tests/gpgscm:$(top_srcdir)/tests/openpgp
-if SQLITE3
-sqlite3_dependent_tests = tofu.test
-else
-sqlite3_dependent_tests =
-endif
-
# Note: setup.scm needs to be the first test to run and finish.scm
# the last one
TESTS = setup.scm \
@@ -79,11 +73,11 @@ TESTS = setup.scm \
import.scm \
ecc.scm \
4gb-packet.scm \
- $(sqlite3_dependent_tests) \
+ tofu.scm \
gpgtar.scm \
use-exact-key.scm \
default-key.scm \
- export.test \
+ export.scm \
finish.scm
diff --git a/tests/openpgp/defs.scm b/tests/openpgp/defs.scm
index 6fdb955..4257b28 100644
--- a/tests/openpgp/defs.scm
+++ b/tests/openpgp/defs.scm
@@ -82,12 +82,13 @@
(define (pipe:gpg args)
(pipe:spawn `(, at GPG --output - , at args -)))
+(define (gpg-with-colons args)
+ (let ((s (call-popen `(, at GPG --with-colons , at args) "")))
+ (map (lambda (line) (string-split line #\:))
+ (string-split s #\newline))))
+
(define (get-config what)
- (let* ((config-string
- (call-popen `(, at GPG --with-colons --list-config ,what) ""))
- (config (string-splitn
- (string-rtrim char-whitespace? config-string) #\: 2)))
- (string-split (caddr config) #\;)))
+ (string-split (caddar (gpg-with-colons `(--list-config ,what))) #\;))
(define all-pubkey-algos (get-config "pubkeyname"))
(define all-hash-algos (get-config "digestname"))
diff --git a/tests/openpgp/export.scm b/tests/openpgp/export.scm
new file mode 100755
index 0000000..8291705
--- /dev/null
+++ b/tests/openpgp/export.scm
@@ -0,0 +1,99 @@
+#!/usr/bin/env gpgscm
+
+;; 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/>.
+
+(load (with-path "defs.scm"))
+
+(define (check-for predicate lines message)
+ (unless (any predicate lines)
+ (error message)))
+
+(define (check-exported-key dump keyid)
+ (check-for (lambda (l)
+ (and (string-prefix? l " keyid: ")
+ (string-suffix? l keyid))) dump
+ "Keyid not found")
+ (check-for (lambda (l) (string-prefix? l ":user ID packet:")) dump
+ "User ID packet not found")
+ (check-for (lambda (l)
+ (and (string-prefix? l ":signature packet:")
+ (string-contains? l "keyid")
+ (string-suffix? l keyid))) dump
+ "Signature packet not found"))
+
+(define (check-exported-public-key packet-dump keyid)
+ (let ((dump (string-split packet-dump #\newline)))
+ (check-for (lambda (l) (string-prefix? l ":public key packet:")) dump
+ "Public key packet not found")
+ (check-exported-key dump keyid)))
+
+(define (check-exported-private-key packet-dump keyid)
+ (let ((dump (string-split packet-dump #\newline)))
+ (check-for (lambda (l) (string-prefix? l ":secret key packet:")) dump
+ "Secret key packet not found")
+ (check-exported-key dump keyid)))
+
+(lettmp
+ ;; Prepare two temporary files for communication with the fake
+ ;; pinentry program.
+ (logfile ppfile)
+
+ (define (prepare-passphrases . passphrases)
+ (call-with-output-file ppfile
+ (lambda (port)
+ (for-each (lambda (passphrase)
+ (display passphrase port)
+ (display #\newline port)) passphrases))))
+
+ (define CONFIRM "fake-entry being started to CONFIRM the weak phrase")
+
+ (define (assert-passphrases-consumed)
+ (call-with-input-file ppfile
+ (lambda (port)
+ (unless
+ (eof-object? (peek-char port))
+ (error (string-append
+ "Expected all passphrases to be consumed, but found: "
+ (read-all port)))))))
+
+ (setenv "PINENTRY_USER_DATA"
+ (string-append "--logfile=" logfile " --passphrasefile=" ppfile) #t)
+
+ (for-each-p
+ "Checking key export"
+ (lambda (keyid)
+ (tr:do
+ (tr:pipe-do
+ (pipe:gpg `(--export ,keyid))
+ (pipe:gpg '(--list-packets)))
+ (tr:call-with-content check-exported-public-key keyid))
+
+ (if (string=? "D74C5F22" keyid)
+ ;; Key D74C5F22 is protected by a passphrase. Prepare this
+ ;; one. Currently, GnuPG does not ask for an export passphrase
+ ;; in this case.
+ (prepare-passphrases usrpass1))
+
+ (tr:do
+ (tr:pipe-do
+ (pipe:gpg `(--export-secret-keys ,keyid))
+ (pipe:gpg '(--list-packets)))
+ (tr:call-with-content check-exported-private-key keyid))
+
+ (assert-passphrases-consumed))
+ '("D74C5F22" "C40FDECF" "ECABF51D")))
diff --git a/tests/openpgp/tofu.scm b/tests/openpgp/tofu.scm
new file mode 100755
index 0000000..24fa9df
--- /dev/null
+++ b/tests/openpgp/tofu.scm
@@ -0,0 +1,165 @@
+#!/usr/bin/env gpgscm
+
+;; 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/>.
+
+(load (with-path "defs.scm"))
+
+(define GPG `(,(tool 'gpg) --no-permission-warning)) ;; w/o --always-trust
+(define GNUPGHOME (getenv "GNUPGHOME"))
+(if (string=? "" GNUPGHOME)
+ (error "GNUPGHOME not set"))
+
+(catch (skip "Tofu not supported")
+ (call-check `(, at GPG --trust-model=tofu --list-config)))
+
+(define KEYS '("2183839A" "BC15C85A" "EE37CF96"))
+
+;; Import the test keys.
+(call-check `(, at GPG --import ,(in-srcdir "tofu-keys.asc")))
+
+;; Make sure the keys are imported.
+(for-each (lambda (keyid)
+ (catch (error "Missing key" keyid)
+ (call-check `(, at GPG --list-keys ,keyid))))
+ KEYS)
+
+;; Get tofu policy for KEYID. Any remaining arguments are simply
+;; passed to GPG.
+;;
+;; This function only supports keys with a single user id.
+(define (getpolicy keyid format . args)
+ (let ((policy
+ (list-ref (assoc "uid" (gpg-with-colons
+ `(--tofu-db-format ,format
+ --trust-model=tofu
+ , at args
+ --list-keys ,keyid))) 17)))
+ (unless (member policy '("auto" "good" "unknown" "bad" "ask"))
+ (error "Bad policy:" policy))
+ policy))
+
+;; Check that KEYID's tofu policy matches EXPECTED-POLICY. Any
+;; remaining arguments are simply passed to GPG.
+;;
+;; This function only supports keys with a single user id.
+(define (checkpolicy keyid format expected-policy . args)
+ (let ((policy (apply getpolicy `(,keyid ,format , at args))))
+ (unless (string=? policy expected-policy)
+ (error keyid ": Expected policy to be" expected-policy
+ "but got" policy))))
+
+;; Get the trust level for KEYID. Any remaining arguments are simply
+;; passed to GPG.
+;;
+;; This function only supports keys with a single user id.
+(define (gettrust keyid format . args)
+ (let ((trust
+ (list-ref (assoc "pub" (gpg-with-colons
+ `(--tofu-db-format ,format
+ --trust-model=tofu
+ , at args
+ --list-keys ,keyid))) 1)))
+ (unless (and (= 1 (string-length trust))
+ (member (string-ref trust 0) (string->list "oidreqnmfuws-")))
+ (error "Bad trust value:" trust))
+ trust))
+
+;; Check that KEYID's trust level matches EXPECTED-TRUST. Any
+;; remaining arguments are simply passed to GPG.
+;;
+;; This function only supports keys with a single user id.
+(define (checktrust keyid format expected-trust . args)
+ (let ((trust (apply gettrust `(,keyid ,format , at args))))
+ (unless (string=? trust expected-trust)
+ (error keyid ": Expected trust to be" expected-trust
+ "but got" trust))))
+
+;; Set key KEYID's policy to POLICY. Any remaining arguments are
+;; passed as options to gpg.
+(define (setpolicy keyid format policy . args)
+ (call-check `(, at GPG --tofu-db-format ,format
+ --trust-model=tofu , at args
+ --tofu-policy ,policy ,keyid)))
+
+(for-each-p
+ "Testing tofu db formats"
+ (lambda (format)
+ ;; Carefully remove the TOFU db.
+ (catch '() (unlink (string-append GNUPGHOME "/tofu.db")))
+ (catch '() (unlink-recursively (string-append GNUPGHOME "/tofu.d")))
+
+ ;; Verify a message. There should be no conflict and the trust
+ ;; policy should be set to auto.
+ (call-check `(, at GPG --tofu-db-format ,format --trust-model=tofu
+ --verify ,(in-srcdir "tofu-2183839A-1.txt")))
+
+ (checkpolicy "2183839A" format "auto")
+ ;; Check default trust.
+ (checktrust "2183839A" format "m")
+
+ ;; Trust should be derived lazily. Thus, if the policy is set to
+ ;; auto and we change --tofu-default-policy, then the trust should
+ ;; change as well. Try it.
+ (checktrust "2183839A" format "f" '--tofu-default-policy=good)
+ (checktrust "2183839A" format "-" '--tofu-default-policy=unknown)
+ (checktrust "2183839A" format "n" '--tofu-default-policy=bad)
+
+ ;; Change the policy to something other than auto and make sure the
+ ;; policy and the trust are correct.
+ (for-each-p
+ ""
+ (lambda (policy)
+ (let ((expected-trust
+ (cond
+ ((string=? "good" policy) "f")
+ ((string=? "unknown" policy) "-")
+ (else "n"))))
+ (setpolicy "2183839A" format policy)
+
+ ;; Since we have a fixed policy, the trust level shouldn't
+ ;; change if we change the default policy.
+ (for-each-p
+ ""
+ (lambda (default-policy)
+ (checkpolicy "2183839A" format policy
+ '--tofu-default-policy default-policy)
+ (checktrust "2183839A" format expected-trust
+ '--tofu-default-policy default-policy))
+ '("auto" "good" "unknown" "bad" "ask"))))
+ '("good" "unknown" "bad"))
+
+ ;; BC15C85A conflicts with 2183839A. On conflict, this will set
+ ;; BC15C85A to ask. If 2183839A is auto (it's not, it's bad), then
+ ;; it will be set to ask.
+ (call-check `(, at GPG --tofu-db-format ,format --trust-model=tofu
+ --verify ,(in-srcdir "tofu-BC15C85A-1.txt")))
+ (checkpolicy "BC15C85A" format "ask")
+ (checkpolicy "2183839A" format "bad")
+
+ ;; EE37CF96 conflicts with 2183839A and BC15C85A. We change
+ ;; BC15C85A's policy to auto and leave 2183839A's policy at bad.
+ ;; This conflict should cause BC15C85A's policy to be changed to
+ ;; ask (since it is auto), but not affect 2183839A's policy.
+ (setpolicy "BC15C85A" format "auto")
+ (checkpolicy "BC15C85A" format "auto")
+ (call-check `(, at GPG --tofu-db-format ,format --trust-model=tofu
+ --verify ,(in-srcdir "tofu-EE37CF96-1.txt")))
+ (checkpolicy "BC15C85A" format "ask")
+ (checkpolicy "2183839A" format "bad")
+ (checkpolicy "EE37CF96" format "ask"))
+ '("split" "flat"))
commit 65081c31e7536d8fb5effcc2c9aeeffc120c9a69
Author: Justus Winter <justus at g10code.com>
Date: Tue Jun 21 12:21:10 2016 +0200
gpgscm: Improve test framework.
* tests/gpgscm/lib.scm (echo): Move...
* tests/gpgscm/tests.scm (echo): ... here.
(info, error, skip): And use echo here.
(file-exists?): New function.
(tr:spawn): Check that source exists and if the sink has been created.
(tr:call-with-content): Hand in optional arguments.
Signed-off-by: Justus Winter <justus at g10code.com>
diff --git a/tests/gpgscm/lib.scm b/tests/gpgscm/lib.scm
index 48f53ea..e23977a 100644
--- a/tests/gpgscm/lib.scm
+++ b/tests/gpgscm/lib.scm
@@ -120,10 +120,6 @@
(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
diff --git a/tests/gpgscm/tests.scm b/tests/gpgscm/tests.scm
index 7e20c34..6d70dca 100644
--- a/tests/gpgscm/tests.scm
+++ b/tests/gpgscm/tests.scm
@@ -30,17 +30,20 @@
(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)
@@ -136,6 +139,9 @@
;;
;; File management.
;;
+(define (file-exists? name)
+ (call-with-input-file name (lambda (port) #t)))
+
(define (file=? a b)
(file-equal a b #t))
@@ -361,6 +367,8 @@
(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
@@ -368,6 +376,8 @@
((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)
@@ -396,7 +406,7 @@
(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) , at args))
(list tmpfiles source)))
commit 5fbbc4b334a73150e709a4802cac99abd8ada61d
Author: Justus Winter <justus at g10code.com>
Date: Tue Jun 21 12:12:56 2016 +0200
gpgscm: Use native string searching functions.
* tests/gpgscm/ffi-private.h: Handle character arguments.
* tests/gpgscm/ffi.c (do_string_index): New function.
(do_string_rindex): Likewise.
(do_string_contains): Likewise.
(ffi_init): Define new functions.
* tests/gpgscm/ffi.scm (ffi-define): New macro.
* tests/gpgscm/lib.scm (string-index): Use native function,
demonstrate behavior.
(string-rindex): Likewise.
(string-contains?): Likewise.
Demonstrate behavior of various other functions.
(read-all): Rework so that it can handle large files.
Signed-off-by: Justus Winter <justus at g10code.com>
diff --git a/tests/gpgscm/ffi-private.h b/tests/gpgscm/ffi-private.h
index 5467dac..849d1b7 100644
--- a/tests/gpgscm/ffi-private.h
+++ b/tests/gpgscm/ffi-private.h
@@ -33,6 +33,7 @@ int ffi_bool_value (scheme *sc, pointer p);
#define CONVERSION_number(SC, X) (SC)->vptr->ivalue (X)
#define CONVERSION_string(SC, X) (SC)->vptr->string_value (X)
+#define CONVERSION_character(SC, X) (SC)->vptr->charvalue (X)
#define CONVERSION_list(SC, X) (X)
#define CONVERSION_bool(SC, X) ffi_bool_value ((SC), (X))
#define CONVERSION_path(SC, X) (((SC)->vptr->is_string (X) \
@@ -41,6 +42,7 @@ int ffi_bool_value (scheme *sc, pointer p);
#define IS_A_number(SC, X) (SC)->vptr->is_number (X)
#define IS_A_string(SC, X) (SC)->vptr->is_string (X)
+#define IS_A_character(SC, X) (SC)->vptr->is_character (X)
#define IS_A_list(SC, X) (SC)->vptr->is_list ((SC), X)
#define IS_A_bool(SC, X) ((X) == (SC)->F || (X) == (SC)->T)
#define IS_A_path(SC, X) ((SC)->vptr->is_string (X) \
diff --git a/tests/gpgscm/ffi.c b/tests/gpgscm/ffi.c
index babf1e1..fe418fc 100644
--- a/tests/gpgscm/ffi.c
+++ b/tests/gpgscm/ffi.c
@@ -939,6 +939,72 @@ do_splice (scheme *sc, pointer args)
FFI_RETURN (sc);
}
+static pointer
+do_string_index (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ char *haystack;
+ char needle;
+ ssize_t offset = 0;
+ char *position;
+ FFI_ARG_OR_RETURN (sc, char *, haystack, string, args);
+ FFI_ARG_OR_RETURN (sc, char, needle, character, args);
+ if (args != sc->NIL)
+ {
+ FFI_ARG_OR_RETURN (sc, ssize_t, offset, number, args);
+ if (offset < 0)
+ return ffi_sprintf (sc, "offset must be positive");
+ if (offset > strlen (haystack))
+ return ffi_sprintf (sc, "offset exceeds haystack");
+ }
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+
+ position = strchr (haystack+offset, needle);
+ if (position)
+ FFI_RETURN_INT (sc, position - haystack);
+ else
+ FFI_RETURN_POINTER (sc, sc->F);
+}
+
+static pointer
+do_string_rindex (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ char *haystack;
+ char needle;
+ ssize_t offset = 0;
+ char *position;
+ FFI_ARG_OR_RETURN (sc, char *, haystack, string, args);
+ FFI_ARG_OR_RETURN (sc, char, needle, character, args);
+ if (args != sc->NIL)
+ {
+ FFI_ARG_OR_RETURN (sc, ssize_t, offset, number, args);
+ if (offset < 0)
+ return ffi_sprintf (sc, "offset must be positive");
+ if (offset > strlen (haystack))
+ return ffi_sprintf (sc, "offset exceeds haystack");
+ }
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+
+ position = strrchr (haystack+offset, needle);
+ if (position)
+ FFI_RETURN_INT (sc, position - haystack);
+ else
+ FFI_RETURN_POINTER (sc, sc->F);
+}
+
+static pointer
+do_string_contains (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ char *haystack;
+ char *needle;
+ FFI_ARG_OR_RETURN (sc, char *, haystack, string, args);
+ FFI_ARG_OR_RETURN (sc, char *, needle, string, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ FFI_RETURN_POINTER (sc, strstr (haystack, needle) ? sc->T : sc->F);
+}
+
gpg_error_t
ffi_list2argv (scheme *sc, pointer list, char ***argv, size_t *len)
@@ -1134,6 +1200,9 @@ ffi_init (scheme *sc, const char *argv0, int argc, const char **argv)
/* Test helper functions. */
ffi_define_function (sc, file_equal);
ffi_define_function (sc, splice);
+ ffi_define_function (sc, string_index);
+ ffi_define_function (sc, string_rindex);
+ ffi_define_function_name (sc, "string-contains?", string_contains);
/* User interface. */
ffi_define_function (sc, flush_stdio);
diff --git a/tests/gpgscm/ffi.scm b/tests/gpgscm/ffi.scm
index d0b8a99..7c2f93a 100644
--- a/tests/gpgscm/ffi.scm
+++ b/tests/gpgscm/ffi.scm
@@ -38,3 +38,7 @@
(write (cons (string->symbol name) args) args')
(throw (string-append
(get-output-string args') ": " message))))
+
+;; Pseudo-definitions for foreign functions. Evaluates to no code,
+;; but serves as documentation.
+(macro (ffi-define form))
diff --git a/tests/gpgscm/lib.scm b/tests/gpgscm/lib.scm
index 871cc8f..48f53ea 100644
--- a/tests/gpgscm/lib.scm
+++ b/tests/gpgscm/lib.scm
@@ -55,48 +55,50 @@
(string-length s)))))
(assert (string-suffix? "Scheme" "eme"))
-;; Locate the first occurrence of needle in haystack.
-(define (string-index haystack needle)
- (define (index i haystack needle)
- (if (= (length haystack) 0)
- #f
- (if (char=? (car haystack) needle)
- i
- (index (+ i 1) (cdr haystack) needle))))
- (index 0 (string->list haystack) needle))
-
-;; Locate the last occurrence of needle in haystack.
-(define (string-rindex haystack needle)
- (let ((rindex (string-index (list->string (reverse (string->list haystack)))
- needle)))
- (if rindex (- (string-length haystack) rindex 1) #f)))
+;; 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)
- (define (split acc haystack delimiter n)
- (if (= (string-length haystack) 0)
- (reverse acc)
- (let ((i (string-index haystack delimiter)))
- (if (not (or (eq? i #f) (= 0 n)))
- (split (cons (substring haystack 0 i) acc)
- (substring haystack (+ i 1) (string-length haystack))
- delimiter (- n 1))
- (split (cons haystack acc) "" delimiter 0)
- ))))
- (split '() 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. For example (string-ltrim char-whitespace? " foo") =>
-;; "foo".
+;; 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.
@@ -105,20 +107,18 @@
(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 ")))
-(define (string-contains? s contained)
- (let loop ((offset 0))
- (if (<= (+ offset (string-length contained)) (string-length s))
- (if (string=? (substring s offset (+ offset (string-length contained)))
- contained)
- #t
- (loop (+ 1 offset)))
- #f)))
+;; 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)
@@ -154,10 +154,10 @@
;; Read everything from port P.
(define (read-all . p)
- (list->string
- (let f ()
- (let ((c (apply peek-char p)))
- (cond
- ((eof-object? c) '())
- (else (apply read-char p)
- (cons c (f))))))))
+ (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))))))
commit d99949fc8cf541018267964629992d55c97ca9ab
Author: Justus Winter <justus at g10code.com>
Date: Tue Jun 21 16:09:49 2016 +0200
gpgscm: Improve error reporting.
* tests/gpgscm/scheme.c (type_to_string): New function.
(Eval_Cycle): Include actual type in error message.
Signed-off-by: Justus Winter <justus at g10code.com>
diff --git a/tests/gpgscm/scheme.c b/tests/gpgscm/scheme.c
index 22b726f..3c7910c 100644
--- a/tests/gpgscm/scheme.c
+++ b/tests/gpgscm/scheme.c
@@ -129,6 +129,30 @@ enum scheme_types {
T_LAST_SYSTEM_TYPE=15
};
+static const char *
+type_to_string (enum scheme_types typ)
+{
+ switch (typ)
+ {
+ case T_STRING: return "string";
+ case T_NUMBER: return "number";
+ case T_SYMBOL: return "symbol";
+ case T_PROC: return "proc";
+ case T_PAIR: return "pair";
+ case T_CLOSURE: return "closure";
+ case T_CONTINUATION: return "configuration";
+ case T_FOREIGN: return "foreign";
+ case T_CHARACTER: return "character";
+ case T_PORT: return "port";
+ case T_VECTOR: return "vector";
+ case T_MACRO: return "macro";
+ case T_PROMISE: return "promise";
+ case T_ENVIRONMENT: return "environment";
+ case T_FOREIGN_OBJECT: return "foreign object";
+ }
+ assert (! "not reached");
+}
+
/* ADJ is enough slack to align cells in a TYPE_BITS-bit boundary */
#define ADJ 32
#define TYPE_BITS 5
@@ -4509,10 +4533,11 @@ static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) {
} while(i<n);
if(i<n) {
ok=0;
- snprintf(msg, STRBUFFSIZE, "%s: argument %d must be: %s",
+ snprintf(msg, STRBUFFSIZE, "%s: argument %d must be: %s, got: %s",
pcd->name,
i+1,
- tests[j].kind);
+ tests[j].kind,
+ type_to_string(type(car(arglist))));
}
}
}
commit 616582071a2c76c4fb529d4da549aa95ee5d78d6
Author: Justus Winter <justus at g10code.com>
Date: Tue Jun 21 12:19:07 2016 +0200
gpgscm: Make memory allocation failures fatal.
* tests/gpgscm/scheme.c (Eval_Cycle): Exit if we run out of memory.
Signed-off-by: Justus Winter <justus at g10code.com>
diff --git a/tests/gpgscm/scheme.c b/tests/gpgscm/scheme.c
index ff595fa..22b726f 100644
--- a/tests/gpgscm/scheme.c
+++ b/tests/gpgscm/scheme.c
@@ -4529,7 +4529,7 @@ static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) {
}
if(sc->no_memory) {
fprintf(stderr,"No memory!\n");
- return;
+ exit(1);
}
}
}
-----------------------------------------------------------------------
Summary of changes:
tests/gpgscm/ffi-private.h | 2 +
tests/gpgscm/ffi.c | 69 +++++++++++++++++++
tests/gpgscm/ffi.scm | 4 ++
tests/gpgscm/lib.scm | 90 ++++++++++++-------------
tests/gpgscm/scheme.c | 31 ++++++++-
tests/gpgscm/tests.scm | 28 +++++---
tests/openpgp/Makefile.am | 10 +--
tests/openpgp/defs.scm | 11 +--
tests/openpgp/export.scm | 99 +++++++++++++++++++++++++++
tests/openpgp/tofu.scm | 165 +++++++++++++++++++++++++++++++++++++++++++++
10 files changed, 437 insertions(+), 72 deletions(-)
create mode 100755 tests/openpgp/export.scm
create mode 100755 tests/openpgp/tofu.scm
hooks/post-receive
--
The GNU Privacy Guard
http://git.gnupg.org
More information about the Gnupg-commits
mailing list