summaryrefslogtreecommitdiff
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/gpgme/Makefile.am3
-rw-r--r--tests/gpgme/gpgme-defs.scm48
-rw-r--r--tests/gpgme/run-tests.scm24
-rw-r--r--tests/gpgme/wrap.scm22
-rw-r--r--tests/gpgscm/ffi.c26
-rw-r--r--tests/gpgscm/main.c2
-rw-r--r--tests/gpgscm/scheme-config.h4
-rw-r--r--tests/gpgscm/scheme.c148
-rw-r--r--tests/gpgscm/tests.scm96
-rw-r--r--tests/gpgsm/Makefile.am3
-rw-r--r--tests/gpgsm/gpgsm-defs.scm2
-rw-r--r--tests/gpgsm/run-tests.scm6
-rw-r--r--tests/migrations/Makefile.am3
-rw-r--r--tests/migrations/common.scm8
-rwxr-xr-xtests/migrations/extended-pkf.scm18
-rwxr-xr-xtests/migrations/from-classic.scm47
-rw-r--r--tests/migrations/run-tests.scm3
-rw-r--r--tests/openpgp/Makefile.am34
-rw-r--r--tests/openpgp/README2
-rwxr-xr-xtests/openpgp/decrypt-unwrap-verify.scm41
-rw-r--r--tests/openpgp/defs.scm41
-rwxr-xr-xtests/openpgp/quick-key-manipulation.scm41
-rw-r--r--tests/openpgp/run-tests.scm4
-rwxr-xr-xtests/openpgp/setup.scm19
-rwxr-xr-xtests/openpgp/ssh-import.scm23
-rwxr-xr-xtests/openpgp/tofu.scm1
26 files changed, 418 insertions, 251 deletions
diff --git a/tests/gpgme/Makefile.am b/tests/gpgme/Makefile.am
index d7fd87c..0d0edc0 100644
--- a/tests/gpgme/Makefile.am
+++ b/tests/gpgme/Makefile.am
@@ -28,12 +28,9 @@ include $(top_srcdir)/am/cmacros.am
AM_CFLAGS =
-TMP ?= /tmp
-
TESTS_ENVIRONMENT = LC_ALL=C \
EXEEXT=$(EXEEXT) \
PATH=../gpgscm:$(PATH) \
- TMP=$(TMP) \
srcdir=$(abs_srcdir) \
objdir=$(abs_top_builddir) \
GPGSCM_PATH=$(abs_top_srcdir)/tests/gpgscm:$(abs_top_srcdir)/tests/openpgp:$(abs_top_srcdir)/tests/gpgme
diff --git a/tests/gpgme/gpgme-defs.scm b/tests/gpgme/gpgme-defs.scm
index c102c93..486d1a1 100644
--- a/tests/gpgme/gpgme-defs.scm
+++ b/tests/gpgme/gpgme-defs.scm
@@ -45,16 +45,30 @@
;; The tests expect the pinentry to return the passphrase "abc".
(setenv "PINENTRY_USER_DATA" "abc" #t)
-(define (create-file name content)
+(define (create-file name . lines)
(letfd ((fd (open name (logior O_WRONLY O_CREAT O_BINARY) #o600)))
- (display content (fdopen fd "wb"))))
+ (let ((port (fdopen fd "wb")))
+ (for-each (lambda (line) (display line port) (newline port)) lines))))
(define (create-gpgmehome . path)
- (create-file "gpg.conf" "no-force-v3-sigs\n")
+ ;; Support for various environments.
+ (define mode
+ (cond
+ ((equal? path '("lang" "python" "tests"))
+ (set! path '("tests" "gpg")) ;; Mostly uses files from tests/gpg.
+ 'python)
+ (else
+ 'gpg)))
+
+ (create-file
+ "gpg.conf"
+ "no-force-v3-sigs"
+ (string-append "agent-program " (tool 'gpg-agent) "|--debug-quick-random\n"))
(create-file
"gpg-agent.conf"
(string-append "pinentry-program " (tool 'pinentry)))
- (mkdir "private-keys-v1.d" "-rwx")
+
+ (start-agent)
(log "Storing private keys")
(for-each
@@ -74,6 +88,21 @@
(call-check `(,@GPG --yes --import ,(apply in-gpgme-srcdir
`(,@path ,file)))))
(list "pubdemo.asc" "secdemo.asc"))
+
+ (when (equal? mode 'python)
+ (log "Importing extra keys for Python tests")
+ (for-each
+ (lambda (file)
+ (call-check `(,@GPG --yes --import
+ ,(apply in-gpgme-srcdir
+ `("lang" "python" "tests" ,file)))))
+ (list "encrypt-only.asc" "sign-only.asc"))
+
+ (log "Marking key as trusted")
+ (pipe:do
+ (pipe:echo "A0FF4590BB6122EDEF6E3C542D727CC768697734:6:\n")
+ (pipe:spawn `(,(tool 'gpg) --import-ownertrust))))
+
(stop-agent))
;; Initialize the test environment, install appropriate configuration
@@ -142,3 +171,14 @@
(else
(expand-one (append acc (list (car v))) (cdr v))))))
values)))
+
+(define python (catch #f
+ (path-expand "python" (string-split (getenv "PATH") *pathsep*))))
+(define (run-python-tests?)
+ (and python
+ (let* ((python-version
+ (string-trim char-whitespace?
+ (call-popen `(,python -c "import sys; print('{0}.{1}'.format(sys.version_info[0], sys.version_info[1]))") "")))
+ (build-path (path-join gpgme-builddir "lang" "python"
+ (string-append "python" python-version "-gpg"))))
+ (file-exists? build-path))))
diff --git a/tests/gpgme/run-tests.scm b/tests/gpgme/run-tests.scm
index cb17977..be70f17 100644
--- a/tests/gpgme/run-tests.scm
+++ b/tests/gpgme/run-tests.scm
@@ -39,9 +39,14 @@
(let* ((runner (if (member "--parallel" *args*)
run-tests-parallel
run-tests-sequential))
+ (setup-c (make-environment-cache
+ (test::scm #f "setup.scm (tests/gpg)" (in-srcdir "setup.scm")
+ "--" "tests" "gpg")))
+ (setup-py (make-environment-cache
+ (test::scm #f "setup.scm (lang/python/tests)" (in-srcdir "setup.scm")
+ "--" "lang" "python" "tests")))
(tests (filter (lambda (arg) (not (string-prefix? arg "--"))) *args*)))
(runner
- (test::scm "setup.scm" (in-srcdir "setup.scm") "--" "tests" "gpg")
(apply
append
(map (lambda (cmpnts)
@@ -50,6 +55,7 @@
(string-suffix? name ".test"))))
(define :path car)
(define :key cadr)
+ (define :setup caddr)
(define (find-test name)
(apply path-join
`(,(if (compiled? name)
@@ -59,11 +65,13 @@
"Makefile.am"))))
(map (lambda (name)
(apply test::scm
- `(,name ,(in-srcdir "wrap.scm") --executable
- ,(find-test name)
- -- ,@(:path cmpnts))))
+ `(,(:setup cmpnts)
+ ,name ,(in-srcdir "wrap.scm") --executable
+ ,(find-test name)
+ -- ,@(:path cmpnts))))
(if (null? tests) (all-tests makefile (:key cmpnts)) tests))))
- '((("tests" "gpg") "c_tests")
- ;; XXX: Not yet.
- ;; (("lang" "python" "tests") "py_tests")
- (("lang" "qt" "tests") "TESTS"))))))
+ `((("tests" "gpg") "c_tests" ,setup-c)
+ ,@(if (run-python-tests?)
+ `((("lang" "python" "tests") "py_tests" ,setup-py))
+ '())
+ (("lang" "qt" "tests") "TESTS" ,setup-c))))))
diff --git a/tests/gpgme/wrap.scm b/tests/gpgme/wrap.scm
index e8f2b1f..eb416f4 100644
--- a/tests/gpgme/wrap.scm
+++ b/tests/gpgme/wrap.scm
@@ -39,19 +39,21 @@
(getenv "LD_LIBRARY_PATH"))
(path-join gpgme-builddir "src/.libs"))
#t)
- (call-with-fds
- `("/usr/bin/python"
- ,(in-gpgme-srcdir "lang" "python" "tests" "run-tests.py")
- --quiet
- --interpreters=/usr/bin/python
- --builddir ,(path-join gpgme-builddir "lang" "python" "tests")
- ,@what)
- STDIN_FILENO STDOUT_FILENO STDERR_FILENO))
- (if #f 77 (call-with-fds what STDIN_FILENO STDOUT_FILENO STDERR_FILENO))))
+ (if python
+ (call-with-fds
+ `(,python
+ ,(in-gpgme-srcdir "lang" "python" "tests" "run-tests.py")
+ --quiet
+ ,(string-append "--interpreters=" python)
+ --builddir ,(path-join gpgme-builddir "lang" "python" "tests")
+ ,@what)
+ STDIN_FILENO STDOUT_FILENO STDERR_FILENO)
+ 77))
+ (call-with-fds what STDIN_FILENO STDOUT_FILENO STDERR_FILENO)))
(let ((name (basename (car executable))))
(cond
- ((string=? "t-keylist" name)
+ ((string=? (qualify "t-keylist") name)
;; This test assumes that 't-import' imported a key.
(log "Importing extra key...")
(call-check `(,@GPG --yes --import ,(in-srcdir "pubkey-1.asc"))))))
diff --git a/tests/gpgscm/ffi.c b/tests/gpgscm/ffi.c
index 42facee..3af3328 100644
--- a/tests/gpgscm/ffi.c
+++ b/tests/gpgscm/ffi.c
@@ -26,6 +26,7 @@
#include <errno.h>
#include <fcntl.h>
#include <gpg-error.h>
+#include <limits.h>
#include <stdarg.h>
#include <stdlib.h>
#include <stdio.h>
@@ -341,11 +342,33 @@ do_seek (scheme *sc, pointer args)
}
static pointer
+do_get_temp_path (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+#ifdef HAVE_W32_SYSTEM
+ char buffer[MAX_PATH+1];
+#endif
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+
+#ifdef HAVE_W32_SYSTEM
+ if (GetTempPath (MAX_PATH+1, buffer) == 0)
+ FFI_RETURN_STRING (sc, "/temp");
+ FFI_RETURN_STRING (sc, buffer);
+#else
+ FFI_RETURN_STRING (sc, "/tmp");
+#endif
+}
+
+static pointer
do_mkdtemp (scheme *sc, pointer args)
{
FFI_PROLOG ();
char *template;
- char buffer[128];
+#ifdef PATH_MAX
+ char buffer[PATH_MAX];
+#else
+ char buffer[1024];
+#endif
char *name;
FFI_ARG_OR_RETURN (sc, char *, template, string, args);
FFI_ARGS_DONE_OR_RETURN (sc, args);
@@ -1347,6 +1370,7 @@ ffi_init (scheme *sc, const char *argv0, const char *scriptname,
ffi_define_function (sc, fdopen);
ffi_define_function (sc, close);
ffi_define_function (sc, seek);
+ ffi_define_function (sc, get_temp_path);
ffi_define_function_name (sc, "_mkdtemp", mkdtemp);
ffi_define_function (sc, unlink);
ffi_define_function (sc, unlink_recursively);
diff --git a/tests/gpgscm/main.c b/tests/gpgscm/main.c
index 3191e05..65929f0 100644
--- a/tests/gpgscm/main.c
+++ b/tests/gpgscm/main.c
@@ -34,7 +34,7 @@
#include "scheme.h"
#include "scheme-private.h"
#include "ffi.h"
-#include "i18n.h"
+#include "../common/i18n.h"
#include "../../common/argparse.h"
#include "../../common/init.h"
#include "../../common/logging.h"
diff --git a/tests/gpgscm/scheme-config.h b/tests/gpgscm/scheme-config.h
index 2003498..15ca969 100644
--- a/tests/gpgscm/scheme-config.h
+++ b/tests/gpgscm/scheme-config.h
@@ -30,7 +30,3 @@
#define USE_PLIST 0
#define USE_INTERFACE 1
#define SHOW_ERROR_LINE 1
-
-#if __MINGW32__
-# define USE_STRLWR 0
-#endif /* __MINGW32__ */
diff --git a/tests/gpgscm/scheme.c b/tests/gpgscm/scheme.c
index b2ff721..fbc562d 100644
--- a/tests/gpgscm/scheme.c
+++ b/tests/gpgscm/scheme.c
@@ -12,6 +12,10 @@
*
*/
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
#define _SCHEME_SOURCE
#include "scheme-private.h"
#ifndef WIN32
@@ -88,7 +92,7 @@ static int stricmp(const char *s1, const char *s2)
}
#endif /* __APPLE__ */
-#if USE_STRLWR
+#if USE_STRLWR && !defined(HAVE_STRLWR)
static const char *strlwr(char *s) {
const char *p=s;
while(*s) {
@@ -113,41 +117,29 @@ static const char *strlwr(char *s) {
-/* Support for immediate values.
- *
- * Immediate values are tagged with IMMEDIATE_TAG, which is neither
- * used in types, nor in pointer values.
- *
- * XXX: Currently, we only use this to tag pointers in vectors. */
-#define IMMEDIATE_TAG 1
-#define is_immediate(p) ((pointer) ((uintptr_t) (p) & IMMEDIATE_TAG))
-#define set_immediate(p) ((pointer) ((uintptr_t) (p) | IMMEDIATE_TAG))
-#define clr_immediate(p) ((pointer) ((uintptr_t) (p) & ~IMMEDIATE_TAG))
-
-
-
+/* All types have the LSB set. The garbage collector takes advantage
+ * of that to identify types. */
enum scheme_types {
- T_STRING=1 << 1, /* Do not use the lsb, it is used for
- * immediate values. */
- T_NUMBER=2 << 1,
- T_SYMBOL=3 << 1,
- T_PROC=4 << 1,
- T_PAIR=5 << 1,
- T_CLOSURE=6 << 1,
- T_CONTINUATION=7 << 1,
- T_FOREIGN=8 << 1,
- T_CHARACTER=9 << 1,
- T_PORT=10 << 1,
- T_VECTOR=11 << 1,
- T_MACRO=12 << 1,
- T_PROMISE=13 << 1,
- T_ENVIRONMENT=14 << 1,
- T_FOREIGN_OBJECT=15 << 1,
- T_BOOLEAN=16 << 1,
- T_NIL=17 << 1,
- T_EOF_OBJ=18 << 1,
- T_SINK=19 << 1,
- T_LAST_SYSTEM_TYPE=19 << 1
+ T_STRING = 1 << 1 | 1,
+ T_NUMBER = 2 << 1 | 1,
+ T_SYMBOL = 3 << 1 | 1,
+ T_PROC = 4 << 1 | 1,
+ T_PAIR = 5 << 1 | 1,
+ T_CLOSURE = 6 << 1 | 1,
+ T_CONTINUATION = 7 << 1 | 1,
+ T_FOREIGN = 8 << 1 | 1,
+ T_CHARACTER = 9 << 1 | 1,
+ T_PORT = 10 << 1 | 1,
+ T_VECTOR = 11 << 1 | 1,
+ T_MACRO = 12 << 1 | 1,
+ T_PROMISE = 13 << 1 | 1,
+ T_ENVIRONMENT = 14 << 1 | 1,
+ T_FOREIGN_OBJECT = 15 << 1 | 1,
+ T_BOOLEAN = 16 << 1 | 1,
+ T_NIL = 17 << 1 | 1,
+ T_EOF_OBJ = 18 << 1 | 1,
+ T_SINK = 19 << 1 | 1,
+ T_LAST_SYSTEM_TYPE = 19 << 1 | 1
};
static const char *
@@ -232,6 +224,7 @@ INTERFACE INLINE int is_vector(pointer p) { return (type(p)==T_VECTOR); }
* represent it. */
#define vector_size(len) (1 + ((len) - 1 + 2) / 3)
INTERFACE static void fill_vector(pointer vec, pointer obj);
+INTERFACE static pointer *vector_elem_slot(pointer vec, int ielem);
INTERFACE static pointer vector_elem(pointer vec, int ielem);
INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a);
INTERFACE INLINE int is_number(pointer p) { return (type(p)==T_NUMBER); }
@@ -281,7 +274,7 @@ INTERFACE INLINE int is_syntax(pointer p) { return (typeflag(p)&T_SYNTAX); }
INTERFACE INLINE int is_proc(pointer p) { return (type(p)==T_PROC); }
INTERFACE INLINE int is_foreign(pointer p) { return (type(p)==T_FOREIGN); }
INTERFACE INLINE char *syntaxname(pointer p) { return strvalue(car(p)); }
-#define procnum(p) ivalue(p)
+#define procnum(p) ivalue_unchecked(p)
static const char *procname(pointer x);
INTERFACE INLINE int is_closure(pointer p) { return (type(p)==T_CLOSURE); }
@@ -1081,39 +1074,24 @@ static pointer oblist_initial_value(scheme *sc)
/* Add a new symbol NAME at SLOT. SLOT must be obtained using
* oblist_find_by_name, and no insertion must be done between
* obtaining the SLOT and calling this function. Returns the new
- * symbol.
- *
- * If SLOT is NULL, the new symbol is be placed at the appropriate
- * place in the vector. */
+ * symbol. */
static pointer oblist_add_by_name(scheme *sc, const char *name, pointer *slot)
{
#define oblist_add_by_name_allocates 3
pointer x;
- int location;
gc_disable(sc, gc_reservations (oblist_add_by_name));
x = immutable_cons(sc, mk_string(sc, name), sc->NIL);
typeflag(x) = T_SYMBOL;
setimmutable(car(x));
-
- if (slot == NULL) {
- location = hash_fn(name, vector_length(sc->oblist));
- set_vector_elem(sc->oblist, location,
- immutable_cons(sc, x, vector_elem(sc->oblist, location)));
- } else {
- *slot = immutable_cons(sc, x, *slot);
- }
-
+ *slot = immutable_cons(sc, x, *slot);
gc_enable(sc);
return x;
}
/* Lookup the symbol NAME. Returns the symbol, or NIL if it does not
* exist. In that case, SLOT points to the point where the new symbol
- * is to be inserted.
- *
- * SLOT may be set to NULL if the new symbol should be placed at the
- * appropriate place in the vector. */
+ * is to be inserted. */
static INLINE pointer
oblist_find_by_name(scheme *sc, const char *name, pointer **slot)
{
@@ -1123,7 +1101,7 @@ oblist_find_by_name(scheme *sc, const char *name, pointer **slot)
int d;
location = hash_fn(name, vector_length(sc->oblist));
- for (*slot = NULL, x = vector_elem(sc->oblist, location);
+ for (*slot = vector_elem_slot(sc->oblist, location), x = **slot;
x != sc->NIL; *slot = &cdr(x), x = **slot) {
s = symname(car(x));
/* case-insensitive, per R5RS section 2. */
@@ -1357,20 +1335,26 @@ INTERFACE static void fill_vector(pointer vec, pointer obj) {
size_t i;
assert (is_vector (vec));
for(i = 0; i < vector_length(vec); i++) {
- vec->_object._vector._elements[i] = set_immediate(obj);
+ vec->_object._vector._elements[i] = obj;
}
}
+INTERFACE static pointer *vector_elem_slot(pointer vec, int ielem) {
+ assert (is_vector (vec));
+ assert (ielem < vector_length(vec));
+ return &vec->_object._vector._elements[ielem];
+}
+
INTERFACE static pointer vector_elem(pointer vec, int ielem) {
assert (is_vector (vec));
assert (ielem < vector_length(vec));
- return clr_immediate(vec->_object._vector._elements[ielem]);
+ return vec->_object._vector._elements[ielem];
}
INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a) {
assert (is_vector (vec));
assert (ielem < vector_length(vec));
- vec->_object._vector._elements[ielem] = set_immediate(a);
+ vec->_object._vector._elements[ielem] = a;
return a;
}
@@ -1572,7 +1556,7 @@ E2: setmark(p);
if(is_vector(p)) {
int i;
for (i = 0; i < vector_length(p); i++) {
- mark(clr_immediate(p->_object._vector._elements[i]));
+ mark(p->_object._vector._elements[i]);
}
}
#if SHOW_ERROR_LINE
@@ -1673,8 +1657,9 @@ static void gc(scheme *sc, pointer a, pointer b) {
for (i = sc->last_cell_seg; i >= 0; i--) {
p = sc->cell_seg[i] + CELL_SEGSIZE;
while (--p >= sc->cell_seg[i]) {
- if (typeflag(p) & IMMEDIATE_TAG)
- continue;
+ if ((typeflag(p) & 1) == 0)
+ /* All types have the LSB set. This is not a typeflag. */
+ continue;
if (is_mark(p)) {
clrmark(p);
} else {
@@ -2643,11 +2628,8 @@ static void new_frame_in_env(scheme *sc, pointer old_env)
/* Insert (VARIABLE, VALUE) at SSLOT. SSLOT must be obtained using
* find_slot_spec_in_env, and no insertion must be done between
- * obtaining SSLOT and the call to this function.
- *
- * If SSLOT is NULL, the new slot is put into the appropriate place in
- * the environment vector. */
-static INLINE void new_slot_spec_in_env(scheme *sc, pointer env,
+ * obtaining SSLOT and the call to this function. */
+static INLINE void new_slot_spec_in_env(scheme *sc,
pointer variable, pointer value,
pointer *sslot)
{
@@ -2655,27 +2637,14 @@ static INLINE void new_slot_spec_in_env(scheme *sc, pointer env,
pointer slot;
gc_disable(sc, gc_reservations (new_slot_spec_in_env));
slot = immutable_cons(sc, variable, value);
-
- if (sslot == NULL) {
- int location;
- assert(is_vector(car(env)));
- location = hash_fn(symname(variable), vector_length(car(env)));
-
- set_vector_elem(car(env), location,
- immutable_cons(sc, slot, vector_elem(car(env), location)));
- } else {
- *sslot = immutable_cons(sc, slot, *sslot);
- }
+ *sslot = immutable_cons(sc, slot, *sslot);
gc_enable(sc);
}
/* Find the slot in ENV under the key HDL. If ALL is given, look in
* all environments enclosing ENV. If the lookup fails, and SSLOT is
* given, the position where the new slot has to be inserted is stored
- * at SSLOT.
- *
- * SSLOT may be set to NULL if the new symbol should be placed at the
- * appropriate place in the vector. */
+ * at SSLOT. */
static pointer
find_slot_spec_in_env(scheme *sc, pointer env, pointer hdl, int all, pointer **sslot)
{
@@ -2688,13 +2657,11 @@ find_slot_spec_in_env(scheme *sc, pointer env, pointer hdl, int all, pointer **s
for (x = env; x != sc->NIL; x = cdr(x)) {
if (is_vector(car(x))) {
location = hash_fn(symname(hdl), vector_length(car(x)));
- sl = NULL;
- y = vector_elem(car(x), location);
+ sl = vector_elem_slot(car(x), location);
} else {
sl = &car(x);
- y = *sl;
}
- for ( ; y != sc->NIL; sl = &cdr(y), y = *sl) {
+ for (y = *sl ; y != sc->NIL; sl = &cdr(y), y = *sl) {
d = pointercmp(caar(y), hdl);
if (d == 0)
return car(y); /* Hit. */
@@ -2723,12 +2690,11 @@ static INLINE void new_frame_in_env(scheme *sc, pointer old_env)
/* Insert (VARIABLE, VALUE) at SSLOT. SSLOT must be obtained using
* find_slot_spec_in_env, and no insertion must be done between
* obtaining SSLOT and the call to this function. */
-static INLINE void new_slot_spec_in_env(scheme *sc, pointer env,
+static INLINE void new_slot_spec_in_env(scheme *sc,
pointer variable, pointer value,
pointer *sslot)
{
#define new_slot_spec_in_env_allocates 2
- (void) env;
assert(is_symbol(variable));
*sslot = immutable_cons(sc, immutable_cons(sc, variable, value), *sslot);
}
@@ -2779,7 +2745,7 @@ static INLINE void new_slot_in_env(scheme *sc, pointer variable, pointer value)
assert(is_symbol(variable));
slot = find_slot_spec_in_env(sc, sc->envir, variable, 0, &sslot);
assert(slot == sc->NIL);
- new_slot_spec_in_env(sc, sc->envir, variable, value, sslot);
+ new_slot_spec_in_env(sc, variable, value, sslot);
}
static INLINE void set_slot_in_env(scheme *sc, pointer slot, pointer value)
@@ -3541,7 +3507,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
if (x != sc->NIL) {
set_slot_in_env(sc, x, sc->value);
} else {
- new_slot_spec_in_env(sc, sc->envir, sc->code, sc->value, sslot);
+ new_slot_spec_in_env(sc, sc->code, sc->value, sslot);
}
s_return(sc,sc->code);
}
@@ -3863,7 +3829,7 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
if (x != sc->NIL) {
set_slot_in_env(sc, x, sc->value);
} else {
- new_slot_spec_in_env(sc, sc->envir, sc->code, sc->value, sslot);
+ new_slot_spec_in_env(sc, sc->code, sc->value, sslot);
}
s_return(sc,sc->code);
}
@@ -5818,7 +5784,7 @@ void scheme_define(scheme *sc, pointer envir, pointer symbol, pointer value) {
if (x != sc->NIL) {
set_slot_in_env(sc, x, value);
} else {
- new_slot_spec_in_env(sc, envir, symbol, value, sslot);
+ new_slot_spec_in_env(sc, symbol, value, sslot);
}
}
diff --git a/tests/gpgscm/tests.scm b/tests/gpgscm/tests.scm
index e5858d9..592b36f 100644
--- a/tests/gpgscm/tests.scm
+++ b/tests/gpgscm/tests.scm
@@ -268,14 +268,24 @@
;; Make a temporary directory. If arguments are given, they are
;; joined using path-join, and must end in a component ending in
;; "XXXXXX". If no arguments are given, a suitable location and
-;; generic name is used.
+;; generic name is used. Returns an absolute path.
(define (mkdtemp . components)
- (_mkdtemp (if (null? components)
- (path-join (getenv "TMP")
- (string-append "gpgscm-" (get-isotime) "-"
- (basename-suffix *scriptname* ".scm")
- "-XXXXXX"))
- (apply path-join components))))
+ (canonical-path (_mkdtemp (if (null? components)
+ (path-join
+ (get-temp-path)
+ (string-append "gpgscm-" (get-isotime) "-"
+ (basename-suffix *scriptname* ".scm")
+ "-XXXXXX"))
+ (apply path-join components)))))
+
+;; Make a temporary directory and remove it at interpreter shutdown.
+;; Note that there are macros that limit the lifetime of temporary
+;; directories and files to a lexical scope. Use those if possible.
+;; Otherwise this works like mkdtemp.
+(define (mkdtemp-autoremove . components)
+ (let ((dir (apply mkdtemp components)))
+ (atexit (lambda () (unlink-recursively dir)))
+ dir))
(define-macro (with-temporary-working-directory . expressions)
(let ((tmp-sym (gensym)))
@@ -552,18 +562,20 @@
;; A single test.
(define test
(package
- (define (scm name path . args)
+ (define (scm setup name path . args)
;; Start the process.
(define (spawn-scm args' in out err)
(spawn-process-fd `(,*argv0* ,@(verbosity (*verbose*))
,(locate-test path)
+ ,@(if setup (force setup) '())
,@args' ,@args) in out err))
(new name #f spawn-scm #f #f CLOSED_FD))
- (define (binary name path . args)
+ (define (binary setup name path . args)
;; Start the process.
(define (spawn-binary args' in out err)
- (spawn-process-fd `(,path ,@args' ,@args) in out err))
+ (spawn-process-fd `(,path ,@(if setup (force setup) '()) ,@args' ,@args)
+ in out err))
(new name #f spawn-binary #f #f CLOSED_FD))
(define (new name directory spawn pid retcode logfd)
@@ -614,41 +626,41 @@
;; 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')))))))
+(define (run-tests-parallel tests)
+ (let loop ((pool (test-pool::new '())) (tests' tests))
+ (if (null? tests')
+ (let ((results (pool::wait)))
+ (for-each (lambda (t) (t::report)) (reverse results::procs))
+ (exit (results::report)))
+ (let* ((wd (mkdtemp-autoremove))
+ (test (car tests'))
+ (test' (test::set-directory wd)))
+ (loop (pool::add (test'::run-async))
+ (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')))))))
+(define (run-tests-sequential tests)
+ (let loop ((pool (test-pool::new '())) (tests' tests))
+ (if (null? tests')
+ (let ((results (pool::wait)))
+ (exit (results::report)))
+ (let* ((wd (mkdtemp-autoremove))
+ (test (car tests'))
+ (test' (test::set-directory wd)))
+ (loop (pool::add (test'::run-sync))
+ (cdr tests'))))))
+
+;; Helper to create environment caches from test functions. SETUP
+;; must be a test implementing the producer side cache protocol.
+;; Returns a promise containing the arguments that must be passed to a
+;; test implementing the consumer side of the cache protocol.
+(define (make-environment-cache setup)
+ (delay (with-temporary-working-directory
+ (let ((tarball (make-temporary-file "environment-cache")))
+ (atexit (lambda () (remove-temporary-file tarball)))
+ (setup::run-sync '--create-tarball tarball)
+ `(--unpack-tarball ,tarball)))))
;; Command line flag handling. Returns the elements following KEY in
;; ARGUMENTS up to the next argument, or #f if KEY is not in
diff --git a/tests/gpgsm/Makefile.am b/tests/gpgsm/Makefile.am
index aad328b..28db501 100644
--- a/tests/gpgsm/Makefile.am
+++ b/tests/gpgsm/Makefile.am
@@ -28,12 +28,9 @@ include $(top_srcdir)/am/cmacros.am
AM_CFLAGS =
-TMP ?= /tmp
-
TESTS_ENVIRONMENT = LC_ALL=C \
EXEEXT=$(EXEEXT) \
PATH=../gpgscm:$(PATH) \
- TMP=$(TMP) \
srcdir=$(abs_srcdir) \
objdir=$(abs_top_builddir) \
GPGSCM_PATH=$(abs_top_srcdir)/tests/gpgscm:$(abs_top_srcdir)/tests/openpgp:$(abs_top_srcdir)/tests/gpgsm
diff --git a/tests/gpgsm/gpgsm-defs.scm b/tests/gpgsm/gpgsm-defs.scm
index aa5af3d..5f9be7f 100644
--- a/tests/gpgsm/gpgsm-defs.scm
+++ b/tests/gpgsm/gpgsm-defs.scm
@@ -73,6 +73,7 @@
"faked-system-time 1008241200")
(create-file "gpg-agent.conf"
(string-append "pinentry-program " (tool 'pinentry)))
+ (start-agent)
(create-file
"trustlist.txt"
"32100C27173EF6E9C4E9A25D3D69F86D37A4F939"
@@ -80,7 +81,6 @@
"3CF405464F66ED4A7DF45BBDD1E4282E33BDB76E S")
(log "Storing private keys")
- (mkdir "private-keys-v1.d" "-rwx")
(for-each
(lambda (name)
(file-copy (in-srcdir name)
diff --git a/tests/gpgsm/run-tests.scm b/tests/gpgsm/run-tests.scm
index dfd5b02..e444245 100644
--- a/tests/gpgsm/run-tests.scm
+++ b/tests/gpgsm/run-tests.scm
@@ -20,13 +20,13 @@
(if (string=? "" (getenv "srcdir"))
(begin
(echo "Environment variable 'srcdir' not set. Please point it to"
- "tests/openpgp.")
+ "tests/gpgsm.")
(exit 2)))
(let* ((tests (filter (lambda (arg) (not (string-prefix? arg "--"))) *args*))
+ (setup (make-environment-cache (test::scm #f "setup.scm" "setup.scm")))
(runner (if (and (member "--parallel" *args*)
(> (length tests) 1))
run-tests-parallel
run-tests-sequential)))
- (runner (test::scm "setup.scm" "setup.scm")
- (map (lambda (t) (test::scm t t)) tests)))
+ (runner (map (lambda (t) (test::scm setup t t)) tests)))
diff --git a/tests/migrations/Makefile.am b/tests/migrations/Makefile.am
index d0cd9ee..0895aff 100644
--- a/tests/migrations/Makefile.am
+++ b/tests/migrations/Makefile.am
@@ -28,12 +28,9 @@ include $(top_srcdir)/am/cmacros.am
AM_CFLAGS =
-TMP ?= /tmp
-
TESTS_ENVIRONMENT = GPG_AGENT_INFO= LC_ALL=C \
EXEEXT=$(EXEEXT) \
PATH=../gpgscm:$(PATH) \
- TMP=$(TMP) \
srcdir=$(abs_srcdir) \
objdir=$(abs_top_builddir) \
GPGSCM_PATH=$(abs_top_srcdir)/tests/gpgscm:$(abs_top_srcdir)/tests/migrations
diff --git a/tests/migrations/common.scm b/tests/migrations/common.scm
index 30ac62b..fa8f129 100644
--- a/tests/migrations/common.scm
+++ b/tests/migrations/common.scm
@@ -26,6 +26,7 @@
(string-append executable (getenv "EXEEXT")))
;; We may not use a relative name for gpg-agent.
+(define gpgconf (path-join (getenv "objdir") "tools" (qualify "gpgconf")))
(define GPG-AGENT (path-join (getenv "objdir") "agent" (qualify "gpg-agent")))
(define GPG `(,(path-join (getenv "objdir") "g10" (qualify "gpg"))
--no-permission-warning --no-greeting
@@ -51,4 +52,9 @@
(info message)
(untar-armored src-tarball)
(setenv "GNUPGHOME" (getcwd) #t)
- (test (getcwd))))
+
+ (catch (log "Warning: Creating socket directory failed:" (car *error*))
+ (call-popen `(,gpgconf --create-socketdir) ""))
+ (test (getcwd))
+ (catch (log "Warning: Removing socket directory failed.")
+ (call-popen `(,gpgconf --remove-socketdir) ""))))
diff --git a/tests/migrations/extended-pkf.scm b/tests/migrations/extended-pkf.scm
index bf2c49e..1317cd4 100755
--- a/tests/migrations/extended-pkf.scm
+++ b/tests/migrations/extended-pkf.scm
@@ -22,15 +22,6 @@
(catch (skip "gpgtar not built")
(call-check `(,GPGTAR --help)))
-(define src-tarball (in-srcdir "extended-pkf.tar.asc"))
-
-(define (setup)
- (untar-armored src-tarball)
- (setenv "GNUPGHOME" (getcwd) #t))
-
-(define (trigger-migration)
- (call-check `(,@GPG --list-secret-keys)))
-
(define (assert-keys-usable)
(for-each
(lambda (keyid)
@@ -38,9 +29,10 @@
(call-check `(,@GPG --list-secret-keys ,keyid))))
'("C40FDECF" "ECABF51D")))
-(info "Testing the extended private key format ...")
-(with-temporary-working-directory
- (setup)
- (assert-keys-usable))
+(run-test
+ "Testing the extended private key format ..."
+ (in-srcdir "extended-pkf.tar.asc")
+ (lambda (gpghome)
+ (assert-keys-usable)))
;; XXX try changing a key, and check that the format is not changed.
diff --git a/tests/migrations/from-classic.scm b/tests/migrations/from-classic.scm
index d540470..ace458e 100755
--- a/tests/migrations/from-classic.scm
+++ b/tests/migrations/from-classic.scm
@@ -22,12 +22,6 @@
(catch (skip "gpgtar not built")
(call-check `(,GPGTAR --help)))
-(define src-tarball (in-srcdir "from-classic.tar.asc"))
-
-(define (setup)
- (untar-armored src-tarball)
- (setenv "GNUPGHOME" (getcwd) #t))
-
(define (trigger-migration)
(call-check `(,@GPG --list-secret-keys)))
@@ -41,24 +35,27 @@
(call-check `(,@GPG --list-secret-keys ,keyid))))
'("D74C5F22" "C40FDECF" "ECABF51D")))
-(info "Testing a clean migration ...")
-(with-temporary-working-directory
- (setup)
- (trigger-migration)
- (assert-migrated))
-
-(info "Testing a migration with existing private-keys-v1.d ...")
-(with-temporary-working-directory
- (setup)
- (mkdir "private-keys-v1.d" "-rwx")
- (trigger-migration)
- (assert-migrated))
-
-(info "Testing a migration with existing but weird private-keys-v1.d ...")
-(with-temporary-working-directory
- (setup)
- (mkdir "private-keys-v1.d" "")
- (trigger-migration)
- (assert-migrated))
+(run-test
+ "Testing a clean migration ..."
+ (in-srcdir "from-classic.tar.asc")
+ (lambda (gpghome)
+ (trigger-migration)
+ (assert-migrated)))
+
+(run-test
+ "Testing a migration with existing private-keys-v1.d ..."
+ (in-srcdir "from-classic.tar.asc")
+ (lambda (gpghome)
+ (mkdir "private-keys-v1.d" "-rwx")
+ (trigger-migration)
+ (assert-migrated)))
+
+(run-test
+ "Testing a migration with existing but weird private-keys-v1.d ..."
+ (in-srcdir "from-classic.tar.asc")
+ (lambda (gpghome)
+ (mkdir "private-keys-v1.d" "")
+ (trigger-migration)
+ (assert-migrated)))
;; XXX Check a case where the migration fails.
diff --git a/tests/migrations/run-tests.scm b/tests/migrations/run-tests.scm
index 069af5b..b4ad260 100644
--- a/tests/migrations/run-tests.scm
+++ b/tests/migrations/run-tests.scm
@@ -22,5 +22,4 @@
(> (length tests) 1))
run-tests-parallel
run-tests-sequential)))
- (runner (test::scm "setup.scm" "setup.scm")
- (map (lambda (t) (test::scm t t)) tests)))
+ (runner (map (lambda (t) (test::scm #f t t)) tests)))
diff --git a/tests/openpgp/Makefile.am b/tests/openpgp/Makefile.am
index afac58f..40f947b 100644
--- a/tests/openpgp/Makefile.am
+++ b/tests/openpgp/Makefile.am
@@ -33,12 +33,9 @@ noinst_PROGRAMS = fake-pinentry
fake_pinentry_SOURCES = fake-pinentry.c
-TMP ?= /tmp
-
TESTS_ENVIRONMENT = LC_ALL=C \
EXEEXT=$(EXEEXT) \
PATH=../gpgscm:$(PATH) \
- TMP=$(TMP) \
srcdir=$(abs_srcdir) \
objdir=$(abs_top_builddir) \
GPGSCM_PATH=$(abs_top_srcdir)/tests/gpgscm:$(abs_top_srcdir)/tests/openpgp
@@ -51,6 +48,7 @@ XTESTS = \
decrypt-multifile.scm \
decrypt-dsa.scm \
decrypt-session-key.scm \
+ decrypt-unwrap-verify.scm \
sigs.scm \
sigs-dsa.scm \
encrypt.scm \
@@ -221,10 +219,34 @@ sample_keys = samplekeys/README \
samplekeys/authenticate-only.pub.asc \
samplekeys/authenticate-only.sec.asc
-sample_msgs = samplemsgs/issue2419.asc \
- samplemsgs/clearsig-1-key-1.asc \
+sample_msgs = samplemsgs/clearsig-1-key-1.asc \
+ samplemsgs/clearsig-2-keys-1.asc \
+ samplemsgs/clearsig-2-keys-2.asc \
+ samplemsgs/enc-1-key-1.asc \
+ samplemsgs/enc-1-key-2.asc \
+ samplemsgs/enc-2-keys-1.asc \
+ samplemsgs/enc-2-keys-2.asc \
+ samplemsgs/enc-2-keys-hh-1.asc \
+ samplemsgs/enc-2-keys-hr-1.asc \
+ samplemsgs/enc-2-keys-rh-1.asc \
+ samplemsgs/encsig-2-2-keys-3.asc \
+ samplemsgs/encsig-2-2-keys-4.asc \
+ samplemsgs/encsig-2-keys-1.asc \
+ samplemsgs/encsig-2-keys-2.asc \
+ samplemsgs/encsig-2-keys-3.asc \
+ samplemsgs/encsig-2-keys-4.asc \
+ samplemsgs/encz0-1-key-1.asc \
+ samplemsgs/encz0-1-key-2.asc \
+ samplemsgs/issue2419.asc \
+ samplemsgs/revoke-2D727CC768697734.asc \
+ samplemsgs/sig-1-key-1.asc \
+ samplemsgs/sig-1-key-2.asc \
+ samplemsgs/sig-2-keys-1.asc \
+ samplemsgs/sig-2-keys-2.asc \
samplemsgs/signed-1-key-1.asc \
- samplemsgs/revoke-2D727CC768697734.asc
+ samplemsgs/signed-1-key-2.asc \
+ samplemsgs/signed-2-keys-1.asc \
+ samplemsgs/signed-2-keys-2.asc
EXTRA_DIST = defs.scm $(XTESTS) $(TEST_FILES) \
mkdemodirs signdemokey $(priv_keys) $(sample_keys) \
diff --git a/tests/openpgp/README b/tests/openpgp/README
index eba77b1..b9d5607 100644
--- a/tests/openpgp/README
+++ b/tests/openpgp/README
@@ -30,7 +30,7 @@ This is a bit tricky because one needs to manually set some
environment variables. We should make that easier. See discussion
below. From your build directory, do:
- obj $ TMP=/tmp srcdir=<path to>/tests/openpgp \
+ obj $ srcdir=<path to>/tests/openpgp \
GPGSCM_PATH=<path to>/tests/gpgscm:<path to>/tests/openpgp \
$(pwd)/tests/gpgscm/gpgscm [gpgscm args] \
run-tests.scm [test suite runner args]
diff --git a/tests/openpgp/decrypt-unwrap-verify.scm b/tests/openpgp/decrypt-unwrap-verify.scm
new file mode 100755
index 0000000..97a72e4
--- /dev/null
+++ b/tests/openpgp/decrypt-unwrap-verify.scm
@@ -0,0 +1,41 @@
+#!/usr/bin/env gpgscm
+
+;; Copyright (C) 2017 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"))
+(setup-legacy-environment)
+
+(lettmp (steve's-key)
+ (call-check `(,@gpg --output ,steve's-key --export "1D777619BE310D79"))
+
+ (for-each-p
+ "Checking unwrapping the encryption."
+ (lambda (name)
+ ;; First, unwrap the encrypted message using Steve's secret key.
+ (lettmp (unwrapped)
+ (tr:do
+ (tr:open (in-srcdir "samplemsgs" (string-append name ".asc")))
+ (tr:gpg "" `(--yes --decrypt --unwrap))
+ (tr:write-to unwrapped))
+
+ ;; Then, verify the signature with a clean working directory
+ ;; containing only Steve's public key.
+ (with-ephemeral-home-directory
+ (call-check `(,@gpg --import ,steve's-key))
+ (call-check `(,@gpg --verify ,unwrapped)))))
+ '("encsig-2-keys-3" "encsig-2-keys-4")))
diff --git a/tests/openpgp/defs.scm b/tests/openpgp/defs.scm
index a06a570..e8d06c0 100644
--- a/tests/openpgp/defs.scm
+++ b/tests/openpgp/defs.scm
@@ -140,10 +140,16 @@
(define valgrind
'("/usr/bin/valgrind" --leak-check=full --error-exitcode=154))
+(unless installed?
+ (setenv "GNUPG_BUILDDIR" (getenv "objdir") #t))
+
(define (gpg-conf . args)
(gpg-conf' "" args))
(define (gpg-conf' input args)
- (let ((s (call-popen `(,(tool-hardcoded 'gpgconf) ,@args) input)))
+ (let ((s (call-popen `(,(tool-hardcoded 'gpgconf)
+ ,@(if installed? '()
+ (list '--build-prefix (getenv "objdir")))
+ ,@args) input)))
(map (lambda (line) (map percent-decode (string-split line #\:)))
(string-split-newlines s))))
(define :gc:c:name car)
@@ -180,13 +186,7 @@
(gpg-conf' (string-append key ":16:")
`(--change-options ,component)))))
-
-(unless installed?
- (setenv "GNUPG_BUILDDIR" (getenv "objdir") #t))
-(define gpg-components (apply gpg-conf
- `(,@(if installed? '()
- (list '--build-prefix (getenv "objdir")))
- --list-components)))
+(define gpg-components (apply gpg-conf '(--list-components)))
(define (tool which)
(case which
@@ -278,6 +278,15 @@
;; GnuPG helper.
;;
+;; Evaluate a sequence of expressions with the given home directory.
+(define-macro (with-home-directory gnupghome . expressions)
+ (let ((original-home-directory (gensym)))
+ `(let ((,original-home-directory (getenv "GNUPGHOME")))
+ (dynamic-wind
+ (lambda () (setenv "GNUPGHOME" ,gnupghome #t))
+ (lambda () ,@expressions)
+ (lambda () (setenv "GNUPGHOME" ,original-home-directory #t))))))
+
;; Evaluate a sequence of expressions with an ephemeral home
;; directory.
(define-macro (with-ephemeral-home-directory . expressions)
@@ -364,7 +373,6 @@
(define (create-legacy-gpghome)
(create-sample-files)
- (mkdir "private-keys-v1.d" "-rwx")
(log "Storing private keys")
(for-each
@@ -434,7 +442,10 @@
;; Create the socket dir and start the agent.
(define (start-agent)
(log "Starting gpg-agent...")
- (atexit stop-agent)
+ (let ((gnupghome (getenv "GNUPGHOME")))
+ (atexit (lambda ()
+ (with-home-directory gnupghome
+ (stop-agent)))))
(catch (log "Warning: Creating socket directory failed:" (car *error*))
(call-popen `(,(tool 'gpgconf) --create-socketdir) ""))
(call-check `(,(tool 'gpg-connect-agent) --verbose
@@ -442,10 +453,12 @@
"|--debug-quick-random")
/bye)))
-;; Stop the agent and remove the socket dir.
+;; Stop the agent and other daemons and remove the socket dir.
(define (stop-agent)
(log "Stopping gpg-agent...")
+ (call-check `(,(tool 'gpgconf) --kill all))
(catch (log "Warning: Removing socket directory failed.")
- (call-popen `(,(tool 'gpgconf) --remove-socketdir) ""))
- (call-check `(,(tool 'gpg-connect-agent) --verbose --no-autostart
- killagent /bye)))
+ (call-popen `(,(tool 'gpgconf) --remove-socketdir) "")))
+
+
+;; end
diff --git a/tests/openpgp/quick-key-manipulation.scm b/tests/openpgp/quick-key-manipulation.scm
index 7ede5e9..85e56ca 100755
--- a/tests/openpgp/quick-key-manipulation.scm
+++ b/tests/openpgp/quick-key-manipulation.scm
@@ -21,10 +21,6 @@
(load (with-path "time.scm"))
(setup-environment)
- ;; XXX because of --always-trust, the trustdb is not created.
- ;; Therefore, we redefine GPG without --always-trust.
-(define GPG `(,(tool 'gpg) --no-permission-warning))
-
(define (exact id)
(string-append "=" id))
@@ -37,6 +33,7 @@
(define alpha "Alpha <alpha@invalid.example.net>")
(define bravo "Bravo <bravo@invalid.example.net>")
+(define charlie "Charlie <charlie@invalid.example.net>")
(define (key-data key)
(filter (lambda (x) (or (string=? (car x) "pub")
@@ -76,9 +73,30 @@
(assert (= 2 (count-uids-of-secret-key alpha)))
(assert (= 2 (count-uids-of-secret-key bravo)))
+(info "Checking that we can mark an user ID as primary.")
+(call-check `(,@gpg --quick-set-primary-uid ,(exact alpha) ,alpha))
+(call-check `(,@gpg --quick-set-primary-uid ,(exact alpha) ,bravo))
+;; XXX I don't know how to verify this. The keylisting does not seem
+;; to indicate the primary UID.
+
+(info "Checking that we get an error making non-existant user ID the primary one.")
+(catch '()
+ (call-check `(,@GPG --quick-set-primary-uid ,(exact alpha) ,charlie))
+ (error "Expected an error, but get none."))
+
(info "Checking that we can revoke a user ID...")
(call-check `(,@GPG --quick-revoke-uid ,(exact bravo) ,alpha))
+(info "Checking that we get an error revoking a non-existant user ID.")
+(catch '()
+ (call-check `(,@GPG --quick-revoke-uid ,(exact bravo) ,charlie))
+ (error "Expected an error, but get none."))
+
+(info "Checking that we get an error revoking the last valid user ID.")
+(catch '()
+ (call-check `(,@GPG --quick-revoke-uid ,(exact bravo) ,bravo))
+ (error "Expected an error, but get none."))
+
(assert (= 1 (count-uids-of-secret-key bravo)))
(info "Checking that we can change the expiration time.")
@@ -123,8 +141,13 @@
(default default never)
(rsa "sign auth encr" "seconds=600") ;; GPGME uses this
(rsa "auth,encr" "2") ;; "without a letter, days is assumed"
- (rsa "sign" "2105-01-01") ;; "last year GnuPG can represent is 2105"
- (rsa "sign" "21050101T115500") ;; "last year GnuPG can represent is 2105"
+ ;; Sadly, the timestamp is truncated by the use of time_t on
+ ;; systems where time_t is a signed 32 bit value.
+ (rsa "sign" "2038-01-01") ;; unix millennium
+ (rsa "sign" "20380101T115500") ;; unix millennium
+ ;; Once fixed, we can use later timestamps:
+ ;; (rsa "sign" "2105-01-01") ;; "last year GnuPG can represent is 2105"
+ ;; (rsa "sign" "21050101T115500") ;; "last year GnuPG can represent is 2105"
(rsa sign "2d")
(rsa1024 sign "2w")
(rsa2048 encr "2m")
@@ -155,7 +178,8 @@
(lambda (subkey)
(assert (= 1 (:alg subkey)))
(assert (string-contains? (:cap subkey) "s"))
- (assert (time-matches? 4260207600 ;; 2105-01-01
+ (assert (time-matches? 2145916800 ;; 2038-01-01
+ ;; 4260207600 ;; 2105-01-01
(string->number (:expire subkey))
;; This is off by 12h, but I guess it just
;; choses the middle of the day.
@@ -163,7 +187,8 @@
(lambda (subkey)
(assert (= 1 (:alg subkey)))
(assert (string-contains? (:cap subkey) "s"))
- (assert (time-matches? 4260254100 ;; UTC 2105-01-01 11:55:00
+ (assert (time-matches? 2145959700 ;; UTC 2038-01-01 11:55:00
+ ;; 4260254100 ;; UTC 2105-01-01 11:55:00
(string->number (:expire subkey))
(minutes->seconds 5))))
(lambda (subkey)
diff --git a/tests/openpgp/run-tests.scm b/tests/openpgp/run-tests.scm
index 546d7d4..139f618 100644
--- a/tests/openpgp/run-tests.scm
+++ b/tests/openpgp/run-tests.scm
@@ -27,9 +27,9 @@
(setenv "objdir" (getcwd) #f)
(let* ((tests (filter (lambda (arg) (not (string-prefix? arg "--"))) *args*))
+ (setup (make-environment-cache (test::scm #f "setup.scm" "setup.scm")))
(runner (if (and (member "--parallel" *args*)
(> (length tests) 1))
run-tests-parallel
run-tests-sequential)))
- (runner (test::scm "setup.scm" "setup.scm")
- (map (lambda (t) (test::scm t t)) tests)))
+ (runner (map (lambda (t) (test::scm setup t t)) tests))))
diff --git a/tests/openpgp/setup.scm b/tests/openpgp/setup.scm
index d13799d..4b3bfcb 100755
--- a/tests/openpgp/setup.scm
+++ b/tests/openpgp/setup.scm
@@ -22,9 +22,28 @@
(unless (member "--create-tarball" *args*)
(fail "Usage: setup.scm --create-tarball <file>"))
+(when (> (*verbose*) 0)
+ (define (pad symbol length)
+ (let loop ((cs (string->list (symbol->string symbol)))
+ (result (make-string length #\space))
+ (i 0))
+ (if (null? cs)
+ result
+ (begin
+ (string-set! result i (car cs))
+ (loop (cdr cs) result (+ 1 i))))))
+ (log " I am going to use these tools:\n"
+ "==============================")
+ (for-each
+ (lambda (t)
+ (log (pad t 25) (tool t)))
+ '(gpgconf gpg gpg-agent scdaemon gpgsm dirmngr gpg-connect-agent
+ gpg-preset-passphrase gpgtar pinentry)))
+
(with-ephemeral-home-directory
(chdir (getenv "GNUPGHOME"))
(create-gpghome)
+ (start-agent)
(create-legacy-gpghome)
(stop-agent)
(call-check `(,(tool 'gpgtar) --create --output ,(cadr *args*) ".")))
diff --git a/tests/openpgp/ssh-import.scm b/tests/openpgp/ssh-import.scm
index 7a4364c..d210056 100755
--- a/tests/openpgp/ssh-import.scm
+++ b/tests/openpgp/ssh-import.scm
@@ -36,8 +36,13 @@
(catch (skip "ssh-keygen not found")
(set! ssh-keygen (path-expand "ssh-keygen" path)))
+(define ssh-version-string
+ (:stderr (call-with-io `(,ssh "-V") "")))
+
+(log "Using" ssh "version:" ssh-version-string)
+
(define ssh-version
- (let ((tmp (:stderr (call-with-io `(,ssh "-V") "")))
+ (let ((tmp ssh-version-string)
(prefix "OpenSSH_"))
(unless (string-prefix? tmp prefix)
(skip "This doesn't look like OpenSSH:" tmp))
@@ -45,14 +50,22 @@
(+ 3 (string-length prefix))))))
(define (ssh-supports? algorithm)
+ ;; We exploit ssh-keygen as an oracle to test what algorithms ssh
+ ;; supports.
(cond
((equal? algorithm "ed25519")
+ ;; Unfortunately, our oracle does not work for ed25519 because
+ ;; this is a specific curve and not a family, so the key size
+ ;; parameter is ignored.
(>= ssh-version 6.5))
(else
- (not (string-contains? (:stderr (call-with-io `(,ssh-keygen
- -t ,algorithm
- -b "1009") ""))
- "unknown key type")))))
+ ;; We call ssh-keygen with the algorithm to test, specify an
+ ;; invalid key size, and observe the error message.
+ (let ((output (:stderr (call-with-io `(,ssh-keygen
+ -t ,algorithm
+ -b "1009") ""))))
+ (log "(ssh-supports?" algorithm "), ssh algorithm oracle replied:" output)
+ (not (string-contains? output "unknown key type"))))))
(define keys
'(("dsa" "9a:e1:f1:5f:46:ea:a5:06:e1:e2:f8:38:8e:06:54:58")
diff --git a/tests/openpgp/tofu.scm b/tests/openpgp/tofu.scm
index f4eab41..aeeef07 100755
--- a/tests/openpgp/tofu.scm
+++ b/tests/openpgp/tofu.scm
@@ -120,6 +120,7 @@
(checktrust "1C005AF3" "f" '--tofu-default-policy=good)
(checktrust "1C005AF3" "-" '--tofu-default-policy=unknown)
(checktrust "1C005AF3" "n" '--tofu-default-policy=bad)
+(checktrust "1C005AF3" "q" '--tofu-default-policy=ask)
;; Change the policy to something other than auto and make sure the
;; policy and the trust are correct.
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-28 17:08:26 +0000