diff --git a/Makefile.am b/Makefile.am
index 7d023c1af..e1f9a2748 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -1,143 +1,157 @@
# Makefile.am - main makefile for GnuPG
# Copyright (C) 2001, 2004, 2010 Free Software Foundation, Inc.
#
# 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 .
## Process this file with automake to produce Makefile.in
ACLOCAL_AMFLAGS = -I m4
AM_DISTCHECK_CONFIGURE_FLAGS = --enable-gnupg-builddir-envvar \
--enable-symcryptrun --enable-g13 \
--enable-gpg2-is-gpg --enable-gpgtar --enable-wks-tools --disable-ntbtls
GITLOG_TO_CHANGELOG=gitlog-to-changelog
EXTRA_DIST = build-aux/config.rpath build-aux/potomo autogen.sh autogen.rc \
ChangeLog-2011 po/ChangeLog-2011 build-aux/ChangeLog-2011 \
VERSION README.GIT build-aux/gitlog-to-changelog \
COPYING.CC0 COPYING.other \
build-aux/git-log-fix build-aux/git-log-footer \
build-aux/getswdb.sh \
build-aux/speedo.mk \
build-aux/speedo/zlib.pc \
build-aux/speedo/w32/inst-options.ini \
build-aux/speedo/w32/inst.nsi \
build-aux/speedo/w32/pkg-copyright.txt \
build-aux/speedo/w32/g4wihelp.c \
build-aux/speedo/w32/pango.modules \
build-aux/speedo/w32/gdk-pixbuf-loaders.cache \
build-aux/speedo/w32/exdll.h \
build-aux/speedo/w32/README.txt \
build-aux/speedo/w32/gnupg-logo-150x57.bmp \
build-aux/speedo/w32/gnupg-logo-164x314.bmp \
build-aux/speedo/patches/atk-1.32.0.patch \
build-aux/speedo/patches/libiconv-1.14.patch \
build-aux/speedo/patches/pango-1.29.4.patch \
build-aux/speedo/patches/sqlite.patch
DISTCLEANFILES = g10defs.h
if BUILD_GPG
gpg = g10
else
gpg =
endif
if BUILD_GPGSM
sm = sm
else
sm =
endif
if BUILD_AGENT
agent = agent
else
agent =
endif
if BUILD_SCDAEMON
scd = scd
else
scd =
endif
if BUILD_G13
g13 = g13
else
g13 =
endif
if BUILD_DIRMNGR
dirmngr = dirmngr
else
dirmngr =
endif
if BUILD_DOC
doc = doc
else
doc =
endif
SUBDIRS = m4 common kbx \
${gpg} ${sm} ${agent} ${scd} ${g13} ${dirmngr} \
tools po ${doc} tests
dist_doc_DATA = README
dist-hook: gen-ChangeLog
distcheck-hook:
set -e; ( \
pref="#+macro: gnupg21_" ;\
reldate="$$(date -u +%Y-%m-%d)" ;\
echo "$${pref}ver $(PACKAGE_VERSION)" ;\
echo "$${pref}date $${reldate}" ;\
list='$(DIST_ARCHIVES)'; for i in $$list; do \
case "$$i" in *.tar.bz2) \
echo "$${pref}size $$(wc -c <$$i|awk '{print int($$1/1024)}')k" ;\
echo "$${pref}sha1 $$(sha1sum <$$i|cut -d' ' -f1)" ;\
echo "$${pref}sha2 $$(sha256sum <$$i|cut -d' ' -f1)" ;;\
esac;\
done ) | tee $(distdir).swdb
if HAVE_W32_SYSTEM
install-data-hook:
set -e; \
for i in $$($(top_srcdir)/build-aux/potomo \
--get-linguas $(top_srcdir)/po) ; do \
$(MKDIR_P) "$(DESTDIR)$(localedir)/$$i/LC_MESSAGES" || true; \
rm -f "$(DESTDIR)$(localedir)/$$i/LC_MESSAGES/gnupg2.mo" \
2>/dev/null || true; \
$(top_srcdir)/build-aux/potomo $(top_srcdir)/po/$$i.po \
"$(DESTDIR)$(localedir)/$$i/LC_MESSAGES/gnupg2.mo" ; \
done
endif
gen_start_date = 2011-12-01T06:00:00
.PHONY: gen-ChangeLog
gen-ChangeLog:
if test -e $(top_srcdir)/.git; then \
(cd $(top_srcdir) && \
$(GITLOG_TO_CHANGELOG) --append-dot --tear-off \
--amend=build-aux/git-log-fix \
--since=$(gen_start_date) ) > $(distdir)/cl-t; \
cat $(top_srcdir)/build-aux/git-log-footer >> $(distdir)/cl-t; \
rm -f $(distdir)/ChangeLog; \
mv $(distdir)/cl-t $(distdir)/ChangeLog; \
fi
stowinstall:
$(MAKE) $(AM_MAKEFLAGS) install prefix=/usr/local/stow/gnupg
+
+TESTS_ENVIRONMENT = \
+ LC_ALL=C \
+ EXEEXT=$(EXEEXT) \
+ PATH=$(abs_top_builddir)/tests/gpgscm:$(PATH) \
+ abs_top_srcdir=$(abs_top_srcdir) \
+ objdir=$(abs_top_builddir) \
+ GPGSCM_PATH=$(abs_top_srcdir)/tests/gpgscm
+
+.PHONY: check-all
+check-all:
+ $(TESTS_ENVIRONMENT) \
+ $(abs_top_builddir)/tests/gpgscm/gpgscm \
+ $(abs_srcdir)/tests/run-tests.scm $(TESTFLAGS) $(TESTS)
diff --git a/agent/Makefile.am b/agent/Makefile.am
index 668de2a29..ce29462b2 100644
--- a/agent/Makefile.am
+++ b/agent/Makefile.am
@@ -1,109 +1,109 @@
# Copyright (C) 2001, 2003, 2004, 2005 Free Software Foundation, Inc.
#
# 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 .
## Process this file with automake to produce Makefile.in
bin_PROGRAMS = gpg-agent
libexec_PROGRAMS = gpg-protect-tool
if !HAVE_W32CE_SYSTEM
# fixme: Do no use simple-pwquery for preset-passphrase.
libexec_PROGRAMS += gpg-preset-passphrase
endif
noinst_PROGRAMS = $(TESTS)
-EXTRA_DIST = ChangeLog-2011 gpg-agent-w32info.rc
+EXTRA_DIST = ChangeLog-2011 gpg-agent-w32info.rc all-tests.scm
AM_CPPFLAGS =
include $(top_srcdir)/am/cmacros.am
if HAVE_W32_SYSTEM
resource_objs += gpg-agent-w32info.o
endif
AM_CFLAGS = $(LIBGCRYPT_CFLAGS) $(GPG_ERROR_CFLAGS)
gpg_agent_SOURCES = \
gpg-agent.c agent.h \
command.c command-ssh.c \
call-pinentry.c \
cache.c \
trans.c \
findkey.c \
pksign.c \
pkdecrypt.c \
genkey.c \
protect.c \
trustlist.c \
divert-scd.c \
cvt-openpgp.c cvt-openpgp.h \
call-scd.c \
learncard.c
common_libs = $(libcommon)
commonpth_libs = $(libcommonpth)
if HAVE_W32CE_SYSTEM
pwquery_libs =
else
pwquery_libs = ../common/libsimple-pwquery.a
endif
gpg_agent_CFLAGS = $(AM_CFLAGS) $(LIBASSUAN_CFLAGS) $(NPTH_CFLAGS) \
$(INCICONV)
gpg_agent_LDADD = $(commonpth_libs) \
$(LIBGCRYPT_LIBS) $(LIBASSUAN_LIBS) $(NPTH_LIBS) \
$(GPG_ERROR_LIBS) $(LIBINTL) $(NETLIBS) $(LIBICONV) \
$(resource_objs)
gpg_agent_LDFLAGS = $(extra_bin_ldflags)
gpg_agent_DEPENDENCIES = $(resource_objs)
gpg_protect_tool_SOURCES = \
protect-tool.c \
protect.c cvt-openpgp.c
gpg_protect_tool_CFLAGS = $(AM_CFLAGS) $(LIBASSUAN_CFLAGS) \
$(INCICONV)
gpg_protect_tool_LDADD = $(common_libs) $(LIBGCRYPT_LIBS) $(LIBASSUAN_LIBS) \
$(GPG_ERROR_LIBS) $(LIBINTL) $(NETLIBS) $(LIBICONV)
gpg_preset_passphrase_SOURCES = \
preset-passphrase.c
# Needs $(NETLIBS) for libsimple-pwquery.la.
gpg_preset_passphrase_LDADD = \
$(pwquery_libs) $(common_libs) $(LIBASSUAN_LIBS) \
$(LIBGCRYPT_LIBS) $(GPG_ERROR_LIBS) $(LIBINTL) $(NETLIBS) $(LIBICONV)
# Make sure that all libs are build before we use them. This is
# important for things like make -j2.
$(PROGRAMS): $(common_libs) $(commonpth_libs) $(pwquery_libs)
#
# Module tests
#
TESTS = t-protect
t_common_ldadd = $(common_libs) $(LIBGCRYPT_LIBS) $(GPG_ERROR_LIBS) \
$(LIBINTL) $(LIBICONV) $(NETLIBS)
t_protect_SOURCES = t-protect.c protect.c
t_protect_LDADD = $(t_common_ldadd)
diff --git a/tests/migrations/run-tests.scm b/agent/all-tests.scm
similarity index 54%
copy from tests/migrations/run-tests.scm
copy to agent/all-tests.scm
index 1e4bb704b..6449ebb97 100644
--- a/tests/migrations/run-tests.scm
+++ b/agent/all-tests.scm
@@ -1,28 +1,35 @@
-;; Test-suite runner.
-;;
-;; Copyright (C) 2016 g10 Code GmbH
+;; 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 .
-(let* ((tests (filter (lambda (arg) (not (string-prefix? arg "--"))) *args*))
- (runner (if (and (member "--parallel" *args*)
- (> (length tests) 1))
- run-tests-parallel
- run-tests-sequential)))
- (runner (map (lambda (name)
- (test::scm #f
- (path-join "tests" "migrations" name)
- (in-srcdir "tests" "migrations" name))) tests)))
+(export all-tests
+ ;; Parse the Makefile.am to find all tests.
+
+ (load (with-path "makefile.scm"))
+
+ (define (expander filename port key)
+ (parse-makefile port key))
+
+ (define (parse filename key)
+ (parse-makefile-expand filename expander key))
+
+ (map (lambda (name)
+ (test::binary #f
+ (path-join "agent" name)
+ (path-join (getenv "objdir") "agent" name)))
+ (parse-makefile-expand (in-srcdir "agent" "Makefile.am")
+ (lambda (filename port key) (parse-makefile port key))
+ "TESTS")))
diff --git a/common/Makefile.am b/common/Makefile.am
index 68b87104a..83d82ac1f 100644
--- a/common/Makefile.am
+++ b/common/Makefile.am
@@ -1,226 +1,227 @@
# Makefile for common gnupg modules
# Copyright (C) 2001, 2003, 2007, 2010 Free Software Foundation, Inc.
#
# 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 .
## Process this file with automake to produce Makefile.in
EXTRA_DIST = mkstrtable.awk exaudit.awk exstatus.awk ChangeLog-2011 \
audit-events.h status-codes.h ChangeLog.jnlib \
- ChangeLog-2011.include w32info-rc.h.in gnupg.ico
+ ChangeLog-2011.include w32info-rc.h.in gnupg.ico \
+ all-tests.scm
noinst_LIBRARIES = libcommon.a libcommonpth.a libgpgrl.a
if !HAVE_W32CE_SYSTEM
noinst_LIBRARIES += libsimple-pwquery.a
endif
noinst_PROGRAMS = $(module_tests) $(module_maint_tests)
TESTS = $(module_tests)
BUILT_SOURCES = audit-events.h status-codes.h
MAINTAINERCLEANFILES = audit-events.h status-codes.h
AM_CPPFLAGS =
AM_CFLAGS = $(LIBGCRYPT_CFLAGS) $(LIBASSUAN_CFLAGS) $(KSBA_CFLAGS)
include $(top_srcdir)/am/cmacros.am
common_sources = \
common-defs.h \
util.h utilproto.h fwddecl.h i18n.c i18n.h \
types.h host2net.h dynload.h w32help.h \
mapstrings.c stringhelp.c stringhelp.h \
strlist.c strlist.h \
utf8conv.c utf8conv.h \
argparse.c argparse.h \
logging.c logging.h \
dotlock.c dotlock.h \
mischelp.c mischelp.h \
status.c status.h\
shareddefs.h \
openpgpdefs.h \
gc-opt-flags.h \
keyserver.h \
sexp-parse.h \
tlv.c tlv.h \
init.c init.h \
sexputil.c \
sysutils.c sysutils.h \
homedir.c \
gettime.c gettime.h \
yesno.c \
b64enc.c b64dec.c zb32.c zb32.h \
convert.c \
percent.c \
mbox-util.c mbox-util.h \
miscellaneous.c \
xasprintf.c \
xreadline.c \
membuf.c membuf.h \
ccparray.c ccparray.h \
iobuf.c iobuf.h \
ttyio.c ttyio.h \
asshelp.c asshelp2.c asshelp.h \
exechelp.h \
signal.c \
audit.c audit.h \
localename.c \
session-env.c session-env.h \
userids.c userids.h \
openpgp-oid.c \
ssh-utils.c ssh-utils.h \
agent-opt.c \
helpfile.c \
mkdir_p.c mkdir_p.h \
strlist.c strlist.h \
exectool.c exectool.h \
server-help.c server-help.h \
name-value.c name-value.h \
recsel.c recsel.h \
ksba-io-support.c ksba-io-support.h
if HAVE_W32_SYSTEM
common_sources += w32-reg.c
endif
# To make the code easier to read we have split home some code into
# separate source files.
if HAVE_W32_SYSTEM
if HAVE_W32CE_SYSTEM
common_sources += exechelp-w32ce.c
else
common_sources += exechelp-w32.c
endif
else
common_sources += exechelp-posix.c
endif
# Sources only useful without NPTH.
without_npth_sources = \
get-passphrase.c get-passphrase.h
# Sources only useful with NPTH.
with_npth_sources = \
call-gpg.c call-gpg.h
libcommon_a_SOURCES = $(common_sources) $(without_npth_sources)
libcommon_a_CFLAGS = $(AM_CFLAGS) $(LIBASSUAN_CFLAGS) -DWITHOUT_NPTH=1
libcommonpth_a_SOURCES = $(common_sources) $(with_npth_sources)
libcommonpth_a_CFLAGS = $(AM_CFLAGS) $(LIBASSUAN_CFLAGS) $(NPTH_CFLAGS)
if !HAVE_W32CE_SYSTEM
libsimple_pwquery_a_SOURCES = \
simple-pwquery.c simple-pwquery.h asshelp.c asshelp.h
libsimple_pwquery_a_CFLAGS = $(AM_CFLAGS) $(LIBASSUAN_CFLAGS)
endif
libgpgrl_a_SOURCES = \
gpgrlhelp.c
if MAINTAINER_MODE
# Note: Due to the dependency on Makefile, the file will always be
# rebuilt, so we allow this only in maintainer mode.
# Create the audit-events.h include file from audit.h
# Note: We create the target file in the source directory because it
# is a distributed built source. If we would not do that we may end
# up with two files and then it is not clear which version of the
# files will be picked up.
audit-events.h: Makefile.am mkstrtable.awk exaudit.awk audit.h
$(AWK) -f $(srcdir)/exaudit.awk $(srcdir)/audit.h \
| $(AWK) -f $(srcdir)/mkstrtable.awk -v textidx=3 -v nogettext=1 \
-v namespace=eventstr_ > $(srcdir)/audit-events.h
# Create the status-codes.h include file from status.h
status-codes.h: Makefile.am mkstrtable.awk exstatus.awk status.h
$(AWK) -f $(srcdir)/exstatus.awk $(srcdir)/status.h \
| $(AWK) -f $(srcdir)/mkstrtable.awk -v textidx=3 -v nogettext=1 \
-v namespace=statusstr_ > $(srcdir)/status-codes.h
endif
#
# Module tests
#
module_tests = t-stringhelp t-timestuff \
t-convert t-percent t-gettime t-sysutils t-sexputil \
t-session-env t-openpgp-oid t-ssh-utils \
t-mapstrings t-zb32 t-mbox-util t-iobuf t-strlist \
t-name-value t-ccparray t-recsel
if !HAVE_W32CE_SYSTEM
module_tests += t-exechelp t-exectool
endif
if HAVE_W32_SYSTEM
module_tests += t-w32-reg
endif
if MAINTAINER_MODE
module_maint_tests = t-helpfile t-b64
else
module_maint_tests =
endif
t_extra_src = t-support.h
t_common_cflags = $(KSBA_CFLAGS) $(LIBGCRYPT_CFLAGS) \
$(LIBASSUAN_CFLAGS) $(GPG_ERROR_CFLAGS) $(INCICONV)
t_common_ldadd = libcommon.a \
$(LIBGCRYPT_LIBS) $(LIBASSUAN_LIBS) $(GPG_ERROR_LIBS) \
$(LIBINTL) $(LIBICONV)
# Common tests
t_stringhelp_SOURCES = t-stringhelp.c $(t_extra_src)
t_stringhelp_LDADD = $(t_common_ldadd)
t_timestuff_SOURCES = t-timestuff.c $(t_extra_src)
t_timestuff_LDADD = $(t_common_ldadd)
t_convert_LDADD = $(t_common_ldadd)
t_percent_LDADD = $(t_common_ldadd)
t_gettime_LDADD = $(t_common_ldadd)
t_sysutils_LDADD = $(t_common_ldadd)
t_helpfile_LDADD = $(t_common_ldadd)
t_sexputil_LDADD = $(t_common_ldadd)
t_b64_LDADD = $(t_common_ldadd)
t_exechelp_LDADD = $(t_common_ldadd)
t_exectool_LDADD = $(t_common_ldadd)
t_session_env_LDADD = $(t_common_ldadd)
t_openpgp_oid_LDADD = $(t_common_ldadd)
t_ssh_utils_LDADD = $(t_common_ldadd)
t_mapstrings_LDADD = $(t_common_ldadd)
t_zb32_SOURCES = t-zb32.c $(t_extra_src)
t_zb32_LDADD = $(t_common_ldadd)
t_mbox_util_LDADD = $(t_common_ldadd)
t_iobuf_LDADD = $(t_common_ldadd)
t_strlist_LDADD = $(t_common_ldadd)
t_name_value_LDADD = $(t_common_ldadd)
t_ccparray_LDADD = $(t_common_ldadd)
t_recsel_LDADD = $(t_common_ldadd)
# System specific test
if HAVE_W32_SYSTEM
t_w32_reg_SOURCES = t-w32-reg.c $(t_extra_src)
t_w32_reg_LDADD = $(t_common_ldadd)
endif
# All programs should depend on the created libs.
$(PROGRAMS) : libcommon.a libcommonpth.a
diff --git a/common/all-tests.scm b/common/all-tests.scm
new file mode 100644
index 000000000..54f1153a5
--- /dev/null
+++ b/common/all-tests.scm
@@ -0,0 +1,45 @@
+;; 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 .
+
+(export all-tests
+ ;; XXX: Currently, the makefile parser does not understand this
+ ;; Makefile.am, so we hardcode the list of tests here.
+ (map (lambda (name)
+ (test::binary #f
+ (path-join "common" name)
+ (path-join (getenv "objdir") "common" name)))
+ (list "t-stringhelp"
+ "t-timestuff"
+ "t-convert"
+ "t-percent"
+ "t-gettime"
+ "t-sysutils"
+ "t-sexputil"
+ "t-session-env"
+ "t-openpgp-oid"
+ "t-ssh-utils"
+ "t-mapstrings"
+ "t-zb32"
+ "t-mbox-util"
+ "t-iobuf"
+ "t-strlist"
+ "t-name-value"
+ "t-ccparray"
+ "t-recsel"
+ "t-exechelp"
+ "t-exectool"
+ )))
diff --git a/g10/Makefile.am b/g10/Makefile.am
index e6a173da8..330d6c51e 100644
--- a/g10/Makefile.am
+++ b/g10/Makefile.am
@@ -1,255 +1,256 @@
# Copyright (C) 1998, 1999, 2000, 2001, 2002,
# 2003, 2006, 2010 Free Software Foundation, Inc.
#
# 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 .
## Process this file with automake to produce Makefile.in
EXTRA_DIST = distsigkey.gpg \
ChangeLog-2011 gpg-w32info.rc \
gpg.w32-manifest.in test.c t-keydb-keyring.kbx \
- t-keydb-get-keyblock.gpg t-stutter-data.asc
+ t-keydb-get-keyblock.gpg t-stutter-data.asc \
+ all-tests.scm
AM_CPPFLAGS =
include $(top_srcdir)/am/cmacros.am
AM_CFLAGS = $(SQLITE3_CFLAGS) $(LIBGCRYPT_CFLAGS) \
$(LIBASSUAN_CFLAGS) $(GPG_ERROR_CFLAGS)
needed_libs = ../kbx/libkeybox.a $(libcommon)
# Because there are no program specific transform macros we need to
# work around that to allow installing gpg as gpg2.
gpg2_hack_list = gpg gpgv
if USE_GPG2_HACK
gpg2_hack_uninst = gpg2 gpgv2
use_gpg2_hack = yes
else
gpg2_hack_uninst = $(gpg2_hack_list)
use_gpg2_hack = no
endif
# NB: We use noinst_ for gpg and gpgv so that we can install them with
# the install-hook target under the name gpg2/gpgv2.
noinst_PROGRAMS = gpg
if !HAVE_W32CE_SYSTEM
noinst_PROGRAMS += gpgv
endif
if MAINTAINER_MODE
noinst_PROGRAMS += gpgcompose
endif
noinst_PROGRAMS += $(module_tests)
TESTS = $(module_tests)
TESTS_ENVIRONMENT = \
abs_top_srcdir=$(abs_top_srcdir)
if ENABLE_BZIP2_SUPPORT
bzip2_source = compress-bz2.c
else
bzip2_source =
endif
if ENABLE_CARD_SUPPORT
card_source = card-util.c
else
card_source =
endif
if NO_TRUST_MODELS
trust_source =
else
trust_source = trustdb.c trustdb.h tdbdump.c tdbio.c tdbio.h
endif
if USE_TOFU
tofu_source = tofu.h tofu.c gpgsql.c gpgsql.h sqrtu32.c sqrtu32.h
else
tofu_source =
endif
if HAVE_W32_SYSTEM
resource_objs += gpg-w32info.o
gpg-w32info.o : gpg.w32-manifest
endif
common_source = \
gpg.h \
dek.h \
build-packet.c \
compress.c \
$(bzip2_source) \
filter.h \
free-packet.c \
getkey.c \
keydb.c keydb.h \
keyring.c keyring.h \
seskey.c \
kbnode.c \
main.h \
mainproc.c \
armor.c \
mdfilter.c \
textfilter.c \
progress.c \
misc.c \
rmd160.c rmd160.h \
options.h \
openfile.c \
keyid.c \
packet.h \
parse-packet.c \
cpr.c \
plaintext.c \
sig-check.c \
keylist.c \
pkglue.c pkglue.h \
ecdh.c
gpg_sources = server.c \
$(common_source) \
pkclist.c \
skclist.c \
pubkey-enc.c \
passphrase.c \
decrypt.c \
decrypt-data.c \
cipher.c \
encrypt.c \
sign.c \
verify.c \
revoke.c \
dearmor.c \
import.c \
export.c \
migrate.c \
delkey.c \
keygen.c \
helptext.c \
keyserver.c \
keyserver-internal.h \
call-dirmngr.c call-dirmngr.h \
photoid.c photoid.h \
call-agent.c call-agent.h \
trust.c $(trust_source) $(tofu_source) \
$(card_source) \
exec.c exec.h
gpg_SOURCES = gpg.c \
keyedit.c \
$(gpg_sources)
gpgcompose_SOURCES = gpgcompose.c $(gpg_sources)
gpgv_SOURCES = gpgv.c \
$(common_source) \
verify.c
#gpgd_SOURCES = gpgd.c \
# ks-proto.h \
# ks-proto.c \
# ks-db.c \
# ks-db.h \
# $(common_source)
LDADD = $(needed_libs) ../common/libgpgrl.a \
$(ZLIBS) $(LIBINTL) $(CAPLIBS) $(NETLIBS)
gpg_LDADD = $(LDADD) $(SQLITE3_LIBS) $(LIBGCRYPT_LIBS) $(LIBREADLINE) \
$(LIBASSUAN_LIBS) $(GPG_ERROR_LIBS) \
$(LIBICONV) $(resource_objs) $(extra_sys_libs)
gpg_LDFLAGS = $(extra_bin_ldflags)
gpgv_LDADD = $(LDADD) $(LIBGCRYPT_LIBS) \
$(GPG_ERROR_LIBS) \
$(LIBICONV) $(resource_objs) $(extra_sys_libs)
gpgv_LDFLAGS = $(extra_bin_ldflags)
gpgcompose_LDADD = $(LDADD) $(SQLITE3_LIBS) $(LIBGCRYPT_LIBS) $(LIBREADLINE) \
$(LIBASSUAN_LIBS) $(GPG_ERROR_LIBS) \
$(LIBICONV) $(resource_objs) $(extra_sys_libs)
gpgcompose_LDFLAGS = $(extra_bin_ldflags)
t_common_ldadd =
module_tests = t-rmd160 t-keydb t-keydb-get-keyblock t-stutter
t_rmd160_SOURCES = t-rmd160.c rmd160.c
t_rmd160_LDADD = $(t_common_ldadd)
t_keydb_SOURCES = t-keydb.c test-stubs.c $(common_source)
t_keydb_LDADD = $(LDADD) $(LIBGCRYPT_LIBS) $(GPG_ERROR_LIBS) \
$(LIBICONV) $(t_common_ldadd)
t_keydb_get_keyblock_SOURCES = t-keydb-get-keyblock.c test-stubs.c \
$(common_source)
t_keydb_get_keyblock_LDADD = $(LDADD) $(LIBGCRYPT_LIBS) $(GPG_ERROR_LIBS) \
$(LIBICONV) $(t_common_ldadd)
t_stutter_SOURCES = t-stutter.c test-stubs.c \
$(common_source)
t_stutter_LDADD = $(LDADD) $(LIBGCRYPT_LIBS) $(GPG_ERROR_LIBS) \
$(LIBICONV) $(t_common_ldadd)
$(PROGRAMS): $(needed_libs) ../common/libgpgrl.a
# NB: To install gpg and gpgv we use this -hook. This code has to
# duplicate most of the automake generated install-binPROGRAMS target
# so that directories are created and the transform feature works.
install-exec-hook:
@echo "running install-exec-hook"; \
echo " $(MKDIR_P) '$(DESTDIR)$(bindir)'"; \
$(MKDIR_P) "$(DESTDIR)$(bindir)"; \
for p in $(gpg2_hack_list); do \
echo "$$p$(EXEEXT) $$p$(EXEEXT)"; done | \
sed 's/$(EXEEXT)$$//' | \
while read p p1; do if test -f $$p \
; then echo "$$p"; echo "$$p"; else :; fi; \
done | \
sed -e 'p;s,.*/,,;n;h' \
-e 's|.*|.|' \
-e 'p;x;s,.*/,,;s/$(EXEEXT)$$//;$(transform);s/$$/$(EXEEXT)/' | \
sed 'N;N;N;s,\n, ,g' | \
$(AWK) 'BEGIN { files["."] = ""; dirs["."] = 1 } \
{ d=$$3; if (dirs[d] != 1) { print "d", d; dirs[d] = 1 } \
if ($$2 == $$4) files[d] = files[d] " " $$1; \
else { print "f", $$3 "/" $$4, $$1; } } \
END { for (d in files) print "f", d, files[d] }' | \
while read type dir files; do \
for f in $$files; do \
if test $(use_gpg2_hack) = yes ; \
then f2=`echo "$${f}" | sed 's/$(EXEEXT)$$//'`2$(EXEEXT); \
else f2="$${f}" ;\
fi ; \
echo "$(INSTALL_PROGRAM_ENV) $(INSTALL_PROGRAM) \
$${f} '$(DESTDIR)$(bindir)/$${f2}'"; \
$(INSTALL_PROGRAM_ENV) $(INSTALL_PROGRAM) \
$${f} "$(DESTDIR)$(bindir)/$${f2}"; \
done; \
done
install-data-local:
$(mkinstalldirs) $(DESTDIR)$(pkgdatadir)
$(INSTALL_DATA) $(srcdir)/distsigkey.gpg \
$(DESTDIR)$(pkgdatadir)/distsigkey.gpg
# NB: For uninstalling gpg and gpgv we use -local because there is
# no need for a specific order the targets need to be run.
uninstall-local:
-@rm $(DESTDIR)$(pkgdatadir)/distsigkey.gpg
-@files=`for p in $(gpg2_hack_uninst); do echo "$$p"; done | \
sed -e 'h;s,^.*/,,;s/$(EXEEXT)$$//;$(transform)' \
-e 's/$$/$(EXEEXT)/' \
`; \
echo " ( cd '$(DESTDIR)$(bindir)' && rm -f" $$files ")"; \
cd "$(DESTDIR)$(bindir)" && rm -f $$files
diff --git a/tests/migrations/run-tests.scm b/g10/all-tests.scm
similarity index 54%
copy from tests/migrations/run-tests.scm
copy to g10/all-tests.scm
index 1e4bb704b..982220b28 100644
--- a/tests/migrations/run-tests.scm
+++ b/g10/all-tests.scm
@@ -1,28 +1,35 @@
-;; Test-suite runner.
-;;
-;; Copyright (C) 2016 g10 Code GmbH
+;; 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 .
-(let* ((tests (filter (lambda (arg) (not (string-prefix? arg "--"))) *args*))
- (runner (if (and (member "--parallel" *args*)
- (> (length tests) 1))
- run-tests-parallel
- run-tests-sequential)))
- (runner (map (lambda (name)
- (test::scm #f
- (path-join "tests" "migrations" name)
- (in-srcdir "tests" "migrations" name))) tests)))
+(export all-tests
+ ;; Parse the Makefile.am to find all tests.
+
+ (load (with-path "makefile.scm"))
+
+ (define (expander filename port key)
+ (parse-makefile port key))
+
+ (define (parse filename key)
+ (parse-makefile-expand filename expander key))
+
+ (map (lambda (name)
+ (test::binary #f
+ (path-join "g10" name)
+ (path-join (getenv "objdir") "g10" name)))
+ (parse-makefile-expand (in-srcdir "g10" "Makefile.am")
+ (lambda (filename port key) (parse-makefile port key))
+ "module_tests")))
diff --git a/g13/Makefile.am b/g13/Makefile.am
index dfacc993b..1aac1b379 100644
--- a/g13/Makefile.am
+++ b/g13/Makefile.am
@@ -1,79 +1,79 @@
# g13/Makefile.am
# Copyright (C) 2009 Free Software Foundation, Inc.
#
# 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 .
## Process this file with automake to produce Makefile.in
-EXTRA_DIST = ChangeLog-2011
+EXTRA_DIST = ChangeLog-2011 all-tests.scm
bin_PROGRAMS = g13
sbin_PROGRAMS = g13-syshelp
noinst_PROGRAMS = $(module_tests)
TESTS = $(module_tests)
AM_CPPFLAGS =
include $(top_srcdir)/am/cmacros.am
AM_CFLAGS = $(LIBGCRYPT_CFLAGS) $(LIBASSUAN_CFLAGS) $(NPTH_CFLAGS)
g13_SOURCES = \
g13.c g13.h \
g13-common.c g13-common.h \
keyblob.c keyblob.h \
g13tuple.c g13tuple.h \
server.c server.h \
create.c create.h \
mount.c mount.h \
suspend.c suspend.h \
mountinfo.c mountinfo.h \
call-syshelp.c call-syshelp.h \
runner.c runner.h \
backend.c backend.h \
be-encfs.c be-encfs.h \
be-truecrypt.c be-truecrypt.h \
be-dmcrypt.c be-dmcrypt.h
g13_LDADD = $(libcommonpth) \
$(LIBGCRYPT_LIBS) $(LIBASSUAN_LIBS) $(NPTH_LIBS) \
$(GPG_ERROR_LIBS) $(LIBINTL) $(LIBICONV)
g13_syshelp_SOURCES = \
g13-syshelp.c g13-syshelp.h \
g13-common.c g13-common.h \
keyblob.c keyblob.h \
g13tuple.c g13tuple.h \
sh-cmd.c \
sh-blockdev.c \
sh-dmcrypt.c
g13_syshelp_LDADD = $(libcommon) \
$(LIBGCRYPT_LIBS) $(LIBASSUAN_LIBS) \
$(GPG_ERROR_LIBS) $(LIBINTL) $(LIBICONV)
module_tests = t-g13tuple
t_common_ldadd = $(libcommon) $(LIBGCRYPT_LIBS) \
$(LIBASSUAN_LIBS) $(LIBICONV)
t_g13tuple_SOURCES = t-g13tuple.c g13tuple.c
t_g13tuple_LDADD = $(t_common_ldadd)
$(PROGRAMS) : $(libcommon) $(libcommonpth)
diff --git a/tests/migrations/run-tests.scm b/g13/all-tests.scm
similarity index 54%
copy from tests/migrations/run-tests.scm
copy to g13/all-tests.scm
index 1e4bb704b..69b1f24d4 100644
--- a/tests/migrations/run-tests.scm
+++ b/g13/all-tests.scm
@@ -1,28 +1,35 @@
-;; Test-suite runner.
-;;
-;; Copyright (C) 2016 g10 Code GmbH
+;; 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 .
-(let* ((tests (filter (lambda (arg) (not (string-prefix? arg "--"))) *args*))
- (runner (if (and (member "--parallel" *args*)
- (> (length tests) 1))
- run-tests-parallel
- run-tests-sequential)))
- (runner (map (lambda (name)
- (test::scm #f
- (path-join "tests" "migrations" name)
- (in-srcdir "tests" "migrations" name))) tests)))
+(export all-tests
+ ;; Parse the Makefile.am to find all tests.
+
+ (load (with-path "makefile.scm"))
+
+ (define (expander filename port key)
+ (parse-makefile port key))
+
+ (define (parse filename key)
+ (parse-makefile-expand filename expander key))
+
+ (map (lambda (name)
+ (test::binary #f
+ (path-join "g13" name)
+ (path-join (getenv "objdir") "g13" name)))
+ (parse-makefile-expand (in-srcdir "g13" "Makefile.am")
+ (lambda (filename port key) (parse-makefile port key))
+ "module_tests")))
diff --git a/tests/Makefile.am b/tests/Makefile.am
index bb75c97be..b9be6aaa6 100644
--- a/tests/Makefile.am
+++ b/tests/Makefile.am
@@ -1,76 +1,77 @@
# Makefile.am -tests makefile for libxtime
# Copyright (C) 2002 Free Software Foundation, Inc.
#
# 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 .
## Process this file with automake to produce Makefile.in
SUBDIRS = gpgscm openpgp migrations gpgsm gpgme pkits .
GPGSM = ../sm/gpgsm
# Note that we need to use /bin/pwd so that we don't get into trouble
# if the shell used for inittests would uses an internal version of
# pwd which handles symlinks differently.
TESTS_ENVIRONMENT = GNUPGHOME=`/bin/pwd` GPG_AGENT_INFO= LC_ALL=C \
GPGSM=$(GPGSM) $(srcdir)/runtest
testscripts = sm-sign+verify sm-verify
EXTRA_DIST = runtest inittests $(testscripts) ChangeLog-2011 \
text-1.txt text-2.txt text-3.txt \
text-1.osig.pem text-1.dsig.pem text-1.osig-bad.pem \
text-2.osig.pem text-2.osig-bad.pem \
fake-pinentries/README.txt \
fake-pinentries/fake-pinentry.php \
fake-pinentries/fake-pinentry.pl \
fake-pinentries/fake-pinentry.py \
fake-pinentries/fake-pinentry.sh \
samplekeys/steed-self-signing-nonthority.pem \
samplekeys/68A638998DFABAC510EA645CE34F9686B2EDF7EA.key \
samplekeys/32100C27173EF6E9C4E9A25D3D69F86D37A4F939.key \
samplekeys/cert_g10code_pete1.pem \
samplekeys/cert_g10code_test1.pem \
- samplekeys/cert_g10code_theo1.pem
+ samplekeys/cert_g10code_theo1.pem \
+ run-tests.scm
# We used to run $(testscripts) here but these asschk scripts are not
# completely reliable in all environments and thus we better disable
# them. The tests are anyway way too minimal. We will eventually
# write new tests based on gpg-connect-agent which has a full fledged
# script language and thus makes it far easier to write tests than to
# use that low-level asschk stuff.
TESTS =
CLEANFILES = inittests.stamp x y y z out err \
*.lock .\#lk*
DISTCLEANFILES = pubring.kbx~ random_seed
if !HAVE_W32_SYSTEM
noinst_PROGRAMS = asschk
endif
asschk_SOURCES = asschk.c
all-local: inittests.stamp
clean-local:
srcdir=$(srcdir) $(TESTS_ENVIRONMENT) $(srcdir)/inittests --clean
inittests.stamp: inittests
srcdir=$(srcdir) $(TESTS_ENVIRONMENT) $(srcdir)/inittests
echo timestamp >./inittests.stamp
diff --git a/tests/gpgme/Makefile.am b/tests/gpgme/Makefile.am
index 37485e741..f1c19eb16 100644
--- a/tests/gpgme/Makefile.am
+++ b/tests/gpgme/Makefile.am
@@ -1,57 +1,57 @@
# Makefile.am - For tests/gpgme
# 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 .
# Process this file with automake to create Makefile.in
# Programs required before we can run these tests.
required_pgms = ../../g10/gpg$(EXEEXT) ../../agent/gpg-agent$(EXEEXT) \
../../tools/gpg-connect-agent$(EXEEXT) \
../gpgscm/gpgscm$(EXEEXT)
AM_CPPFLAGS = -I$(top_srcdir)/common
include $(top_srcdir)/am/cmacros.am
AM_CFLAGS =
TESTS_ENVIRONMENT = LC_ALL=C \
EXEEXT=$(EXEEXT) \
PATH=../gpgscm:$(PATH) \
abs_top_srcdir=$(abs_top_srcdir) \
objdir=$(abs_top_builddir) \
GPGSCM_PATH=$(abs_top_srcdir)/tests/gpgscm
# XXX: Currently, one cannot override automake's 'check' target. As a
# workaround, we avoid defining 'TESTS', thus automake will not emit
# the 'check' target. For extra robustness, we merely define a
# dependency on 'xcheck', so this hack should also work even if
# automake would emit the 'check' target, as adding dependencies to
# targets is okay.
check: xcheck
.PHONY: xcheck
xcheck:
$(TESTS_ENVIRONMENT) $(abs_top_builddir)/tests/gpgscm/gpgscm \
- $(abs_srcdir)/run-tests.scm $(TESTFLAGS) $(XTESTS)
+ $(abs_srcdir)/run-tests.scm $(TESTFLAGS) $(TESTS)
-EXTRA_DIST = gpgme-defs.scm run-tests.scm setup.scm wrap.scm
+EXTRA_DIST = gpgme-defs.scm run-tests.scm setup.scm wrap.scm all-tests.scm
CLEANFILES = *.log report.xml
# We need to depend on a couple of programs so that the tests don't
# start before all programs are built.
all-local: $(required_pgms)
diff --git a/tests/gpgme/all-tests.scm b/tests/gpgme/all-tests.scm
new file mode 100644
index 000000000..f72f8af97
--- /dev/null
+++ b/tests/gpgme/all-tests.scm
@@ -0,0 +1,86 @@
+;; 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 .
+
+(export all-tests
+ ;; Parse GPGME's makefiles to find all tests.
+
+ (load (in-srcdir "tests" "gpgme" "gpgme-defs.scm"))
+ (load (with-path "makefile.scm"))
+
+ (define (expander filename port key)
+ ;;(interactive-repl (current-environment))
+ (cond
+ ((string=? key "tests_unix")
+ (if *win32*
+ (parse-makefile port key) ;; Use win32 definition.
+ (begin
+ (parse-makefile port key) ;; Skip win32 definition.
+ (parse-makefile port key))))
+ (else
+ (parse-makefile port key))))
+
+ (define (parse filename key)
+ (parse-makefile-expand filename expander key))
+
+ (define setup-c
+ (make-environment-cache
+ (test::scm
+ #f
+ (path-join "tests" "gpgme" "setup.scm" "tests" "gpg")
+ (in-srcdir "tests" "gpgme" "setup.scm")
+ "--" "tests" "gpg")))
+ (define setup-py
+ (make-environment-cache
+ (test::scm
+ #f
+ (path-join "tests" "gpgme" "setup.scm" "lang" "python" "tests")
+ (in-srcdir "tests" "gpgme" "setup.scm")
+ "--" "lang" "python" "tests")))
+
+ (define (compiled? name)
+ (not (or (string-suffix? name ".py")
+ (string-suffix? name ".test"))))
+ (define :path car)
+ (define :key cadr)
+ (define :setup caddr)
+
+ (if (have-gpgme?)
+ (apply append
+ (map (lambda (cmpnts)
+ (define (find-test name)
+ (apply path-join
+ `(,(if (compiled? name)
+ gpgme-builddir
+ gpgme-srcdir) ,@(:path cmpnts) ,(qualify name))))
+ (let ((makefile (apply path-join `(,gpgme-srcdir ,@(:path cmpnts)
+ "Makefile.am"))))
+ (map (lambda (name)
+ (apply test::scm
+ `(,(:setup cmpnts)
+ ,(apply path-join
+ `("tests" "gpgme" ,@(:path cmpnts) ,name))
+ ,(in-srcdir "tests" "gpgme" "wrap.scm")
+ --executable
+ ,(find-test name)
+ -- ,@(:path cmpnts))))
+ (parse makefile (:key cmpnts)))))
+ `((("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/gpgme-defs.scm b/tests/gpgme/gpgme-defs.scm
index be6b0f191..e24db254e 100644
--- a/tests/gpgme/gpgme-defs.scm
+++ b/tests/gpgme/gpgme-defs.scm
@@ -1,123 +1,128 @@
#!/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 .
(load (in-srcdir "tests" "openpgp" "defs.scm"))
(define gpgme-srcdir (getenv "XTEST_GPGME_SRCDIR"))
-(when (string=? "" gpgme-srcdir)
- (info
- "SKIP: Environment variable 'XTEST_GPGME_SRCDIR' not set. Please"
- "point it to a recent GPGME source tree to run the GPGME test suite.")
- (exit 0))
(define (in-gpgme-srcdir . names)
(canonical-path (apply path-join (cons gpgme-srcdir names))))
(define gpgme-builddir (getenv "XTEST_GPGME_BUILDDIR"))
-(when (string=? "" gpgme-builddir)
+
+(define (have-gpgme?)
+ (cond
+ ((string=? "" gpgme-srcdir)
+ (info
+ "SKIP: Environment variable 'XTEST_GPGME_SRCDIR' not set. Please"
+ "point it to a recent GPGME source tree to run the GPGME test suite.")
+ #f)
+ ((string=? "" gpgme-builddir)
(info
"SKIP: Environment variable 'XTEST_GPGME_BUILDDIR' not set. Please"
"point it to a recent GPGME build tree to run the GPGME test suite.")
- (exit 0))
+ #f)
+ (else
+ #t)))
;; Make sure that GPGME picks up our gpgconf. This makes GPGME use
;; and thus executes the tests with GnuPG components from the build
;; tree.
(setenv "PATH" (string-append (path-join (getenv "GNUPG_BUILDDIR") "tools")
(string *pathsep*) (getenv "PATH")) #t)
;; The tests expect the pinentry to return the passphrase "abc".
(setenv "PINENTRY_USER_DATA" "abc" #t)
(define (create-gpgmehome . path)
;; 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)))
(start-agent)
(log "Storing private keys")
(for-each
(lambda (name)
(file-copy (apply in-gpgme-srcdir `(,@path ,name))
(path-join "private-keys-v1.d"
(string-append name ".key"))))
'("13CD0F3BDF24BE53FE192D62F18737256FF6E4FD"
"76F7E2B35832976B50A27A282D9B87E44577EB66"
"A0747D5F9425E6664F4FFBEED20FBCA79FDED2BD"
"13CBE3758AFE42B5E5E2AE4CED27AFA455E3F87F"
"7A030357C0F253A5BBCD282FFC4E521B37558F5C"))
(log "Importing public demo and test keys")
(for-each
(lambda (file)
(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
;; and start the agent, with the keys from the legacy test suite.
(define (setup-gpgme-environment . path)
(if (member "--unpack-tarball" *args*)
(begin
(call-check `(,(tool 'gpgtar) --extract --directory=. ,(cadr *args*)))
(start-agent))
(apply create-gpgme-gpghome path)))
(define python
(let loop ((pythons (list "python" "python2" "python3")))
(if (null? pythons)
#f
(catch (loop (cdr pythons))
(unless (file-exists? (path-join gpgme-builddir "lang" "python"
(string-append (car pythons) "-gpg")))
(throw "next please"))
(path-expand (car pythons) (string-split (getenv "PATH") *pathsep*))))))
(define (run-python-tests?)
(not (not python)))
diff --git a/tests/gpgme/run-tests.scm b/tests/gpgme/run-tests.scm
index df5f5482b..e81c9e904 100644
--- a/tests/gpgme/run-tests.scm
+++ b/tests/gpgme/run-tests.scm
@@ -1,86 +1,20 @@
#!/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 .
-(load (in-srcdir "tests" "gpgme" "gpgme-defs.scm"))
-
-(info "Running GPGME's test suite...")
-
-(define (gpgme-makefile-expand filename port key)
- ;;(interactive-repl (current-environment))
- (cond
- ((string=? key "tests_unix")
- (if *win32*
- (parse-makefile port key) ;; Use win32 definition.
- (begin
- (parse-makefile port key) ;; Skip win32 definition.
- (parse-makefile port key))))
- (else
- (parse-makefile port key))))
-
-(define (all-tests filename key)
- (parse-makefile-expand filename gpgme-makefile-expand key))
-
-(let* ((runner (if (member "--parallel" *args*)
- run-tests-parallel
- run-tests-sequential))
- (setup-c (make-environment-cache
- (test::scm
- #f
- (path-join "tests" "gpgme" "setup.scm" "tests" "gpg")
- (in-srcdir "tests" "gpgme" "setup.scm")
- "--" "tests" "gpg")))
- (setup-py (make-environment-cache
- (test::scm
- #f
- (path-join "tests" "gpgme" "setup.scm" "lang" "python" "tests")
- (in-srcdir "tests" "gpgme" "setup.scm")
- "--" "lang" "python" "tests")))
- (tests (filter (lambda (arg) (not (string-prefix? arg "--"))) *args*)))
- (runner
- (apply
- append
- (map (lambda (cmpnts)
- (define (compiled? name)
- (not (or (string-suffix? name ".py")
- (string-suffix? name ".test"))))
- (define :path car)
- (define :key cadr)
- (define :setup caddr)
- (define (find-test name)
- (apply path-join
- `(,(if (compiled? name)
- gpgme-builddir
- gpgme-srcdir) ,@(:path cmpnts) ,(qualify name))))
- (let ((makefile (apply path-join `(,gpgme-srcdir ,@(:path cmpnts)
- "Makefile.am"))))
- (map (lambda (name)
- (apply test::scm
- `(,(:setup cmpnts)
- ,(apply path-join
- `("tests" "gpgme" ,@(:path cmpnts) ,name))
- ,(in-srcdir "tests" "gpgme" "wrap.scm")
- --executable
- ,(find-test name)
- -- ,@(:path cmpnts))))
- (if (null? tests) (all-tests makefile (:key cmpnts)) tests))))
- `((("tests" "gpg") "c_tests" ,setup-c)
- ,@(if (run-python-tests?)
- `((("lang" "python" "tests") "py_tests" ,setup-py))
- '())
- (("lang" "qt" "tests") "TESTS" ,setup-c))))))
+(run-tests (load-tests "tests" "gpgme"))
diff --git a/tests/gpgscm/init.scm b/tests/gpgscm/init.scm
index af386201e..3769ed00d 100644
--- a/tests/gpgscm/init.scm
+++ b/tests/gpgscm/init.scm
@@ -1,818 +1,823 @@
; Initialization file for TinySCHEME 1.41
; Per R5RS, up to four deep compositions should be defined
(define (caar x) (car (car x)))
(define (cadr x) (car (cdr x)))
(define (cdar x) (cdr (car x)))
(define (cddr x) (cdr (cdr x)))
(define (caaar x) (car (car (car x))))
(define (caadr x) (car (car (cdr x))))
(define (cadar x) (car (cdr (car x))))
(define (caddr x) (car (cdr (cdr x))))
(define (cdaar x) (cdr (car (car x))))
(define (cdadr x) (cdr (car (cdr x))))
(define (cddar x) (cdr (cdr (car x))))
(define (cdddr x) (cdr (cdr (cdr x))))
(define (caaaar x) (car (car (car (car x)))))
(define (caaadr x) (car (car (car (cdr x)))))
(define (caadar x) (car (car (cdr (car x)))))
(define (caaddr x) (car (car (cdr (cdr x)))))
(define (cadaar x) (car (cdr (car (car x)))))
(define (cadadr x) (car (cdr (car (cdr x)))))
(define (caddar x) (car (cdr (cdr (car x)))))
(define (cadddr x) (car (cdr (cdr (cdr x)))))
(define (cdaaar x) (cdr (car (car (car x)))))
(define (cdaadr x) (cdr (car (car (cdr x)))))
(define (cdadar x) (cdr (car (cdr (car x)))))
(define (cdaddr x) (cdr (car (cdr (cdr x)))))
(define (cddaar x) (cdr (cdr (car (car x)))))
(define (cddadr x) (cdr (cdr (car (cdr x)))))
(define (cdddar x) (cdr (cdr (cdr (car x)))))
(define (cddddr x) (cdr (cdr (cdr (cdr x)))))
;;;; Utility to ease macro creation
(define (macro-expand form)
((eval (get-closure-code (eval (car form)))) form))
(define (macro-expand-all form)
(if (macro? form)
(macro-expand-all (macro-expand form))
form))
(define *compile-hook* macro-expand-all)
(macro (unless form)
`(if (not ,(cadr form)) (begin ,@(cddr form))))
(macro (when form)
`(if ,(cadr form) (begin ,@(cddr form))))
; DEFINE-MACRO Contributed by Andy Gaynor
(macro (define-macro dform)
(if (symbol? (cadr dform))
`(macro ,@(cdr dform))
(let ((form (gensym)))
`(macro (,(caadr dform) ,form)
(apply (lambda ,(cdadr dform) ,@(cddr dform)) (cdr ,form))))))
; Utilities for math. Notice that inexact->exact is primitive,
; but exact->inexact is not.
(define exact? integer?)
(define (inexact? x) (and (real? x) (not (integer? x))))
(define (even? n) (= (remainder n 2) 0))
(define (odd? n) (not (= (remainder n 2) 0)))
(define (zero? n) (= n 0))
(define (positive? n) (> n 0))
(define (negative? n) (< n 0))
(define complex? number?)
(define rational? real?)
(define (abs n) (if (>= n 0) n (- n)))
(define (exact->inexact n) (* n 1.0))
(define (<> n1 n2) (not (= n1 n2)))
; min and max must return inexact if any arg is inexact; use (+ n 0.0)
(define (max . lst)
(foldr (lambda (a b)
(if (> a b)
(if (exact? b) a (+ a 0.0))
(if (exact? a) b (+ b 0.0))))
(car lst) (cdr lst)))
(define (min . lst)
(foldr (lambda (a b)
(if (< a b)
(if (exact? b) a (+ a 0.0))
(if (exact? a) b (+ b 0.0))))
(car lst) (cdr lst)))
(define (succ x) (+ x 1))
(define (pred x) (- x 1))
(define gcd
(lambda a
(if (null? a)
0
(let ((aa (abs (car a)))
(bb (abs (cadr a))))
(if (= bb 0)
aa
(gcd bb (remainder aa bb)))))))
(define lcm
(lambda a
(if (null? a)
1
(let ((aa (abs (car a)))
(bb (abs (cadr a))))
(if (or (= aa 0) (= bb 0))
0
(abs (* (quotient aa (gcd aa bb)) bb)))))))
(define (string . charlist)
(list->string charlist))
(define (list->string charlist)
(let* ((len (length charlist))
(newstr (make-string len))
(fill-string!
(lambda (str i len charlist)
(if (= i len)
str
(begin (string-set! str i (car charlist))
(fill-string! str (+ i 1) len (cdr charlist)))))))
(fill-string! newstr 0 len charlist)))
(define (string-fill! s e)
(let ((n (string-length s)))
(let loop ((i 0))
(if (= i n)
s
(begin (string-set! s i e) (loop (succ i)))))))
(define (string->list s)
(let loop ((n (pred (string-length s))) (l '()))
(if (= n -1)
l
(loop (pred n) (cons (string-ref s n) l)))))
(define (string-copy str)
(string-append str))
(define (string->anyatom str pred)
(let* ((a (string->atom str)))
(if (pred a) a
(error "string->xxx: not a xxx" a))))
(define (string->number str . base)
(let ((n (string->atom str (if (null? base) 10 (car base)))))
(if (number? n) n #f)))
(define (anyatom->string n pred)
(if (pred n)
(atom->string n)
(error "xxx->string: not a xxx" n)))
(define (number->string n . base)
(atom->string n (if (null? base) 10 (car base))))
(define (char-cmp? cmp a b)
(cmp (char->integer a) (char->integer b)))
(define (char-ci-cmp? cmp a b)
(cmp (char->integer (char-downcase a)) (char->integer (char-downcase b))))
(define (char=? a b) (char-cmp? = a b))
(define (char? a b) (char-cmp? > a b))
(define (char<=? a b) (char-cmp? <= a b))
(define (char>=? a b) (char-cmp? >= a b))
(define (char-ci=? a b) (char-ci-cmp? = a b))
(define (char-ci? a b) (char-ci-cmp? > a b))
(define (char-ci<=? a b) (char-ci-cmp? <= a b))
(define (char-ci>=? a b) (char-ci-cmp? >= a b))
; Note the trick of returning (cmp x y)
(define (string-cmp? chcmp cmp a b)
(let ((na (string-length a)) (nb (string-length b)))
(let loop ((i 0))
(cond
((= i na)
(if (= i nb) (cmp 0 0) (cmp 0 1)))
((= i nb)
(cmp 1 0))
((chcmp = (string-ref a i) (string-ref b i))
(loop (succ i)))
(else
(chcmp cmp (string-ref a i) (string-ref b i)))))))
(define (string=? a b) (string-cmp? char-cmp? = a b))
(define (string? a b) (string-cmp? char-cmp? > a b))
(define (string<=? a b) (string-cmp? char-cmp? <= a b))
(define (string>=? a b) (string-cmp? char-cmp? >= a b))
(define (string-ci=? a b) (string-cmp? char-ci-cmp? = a b))
(define (string-ci? a b) (string-cmp? char-ci-cmp? > a b))
(define (string-ci<=? a b) (string-cmp? char-ci-cmp? <= a b))
(define (string-ci>=? a b) (string-cmp? char-ci-cmp? >= a b))
(define (list . x) x)
(define (foldr f x lst)
(if (null? lst)
x
(foldr f (f x (car lst)) (cdr lst))))
(define (unzip1-with-cdr . lists)
(unzip1-with-cdr-iterative lists '() '()))
(define (unzip1-with-cdr-iterative lists cars cdrs)
(if (null? lists)
(cons cars cdrs)
(let ((car1 (caar lists))
(cdr1 (cdar lists)))
(unzip1-with-cdr-iterative
(cdr lists)
(append cars (list car1))
(append cdrs (list cdr1))))))
(define (map proc . lists)
(if (null? lists)
(apply proc)
(if (null? (car lists))
'()
(let* ((unz (apply unzip1-with-cdr lists))
(cars (car unz))
(cdrs (cdr unz)))
(cons (apply proc cars) (apply map (cons proc cdrs)))))))
(define (for-each proc . lists)
(if (null? lists)
(apply proc)
(if (null? (car lists))
#t
(let* ((unz (apply unzip1-with-cdr lists))
(cars (car unz))
(cdrs (cdr unz)))
(apply proc cars) (apply map (cons proc cdrs))))))
(define (list-tail x k)
(if (zero? k)
x
(list-tail (cdr x) (- k 1))))
(define (list-ref x k)
(car (list-tail x k)))
(define (last-pair x)
(if (pair? (cdr x))
(last-pair (cdr x))
x))
(define (head stream) (car stream))
(define (tail stream) (force (cdr stream)))
(define (vector-equal? x y)
(and (vector? x) (vector? y) (= (vector-length x) (vector-length y))
(let ((n (vector-length x)))
(let loop ((i 0))
(if (= i n)
#t
(and (equal? (vector-ref x i) (vector-ref y i))
(loop (succ i))))))))
(define (list->vector x)
(apply vector x))
(define (vector-fill! v e)
(let ((n (vector-length v)))
(let loop ((i 0))
(if (= i n)
v
(begin (vector-set! v i e) (loop (succ i)))))))
(define (vector->list v)
(let loop ((n (pred (vector-length v))) (l '()))
(if (= n -1)
l
(loop (pred n) (cons (vector-ref v n) l)))))
;; The following quasiquote macro is due to Eric S. Tiedemann.
;; Copyright 1988 by Eric S. Tiedemann; all rights reserved.
;;
;; Subsequently modified to handle vectors: D. Souflis
(macro
quasiquote
(lambda (l)
(define (mcons f l r)
(if (and (pair? r)
(eq? (car r) 'quote)
(eq? (car (cdr r)) (cdr f))
(pair? l)
(eq? (car l) 'quote)
(eq? (car (cdr l)) (car f)))
(if (or (procedure? f) (number? f) (string? f))
f
(list 'quote f))
(if (eqv? l vector)
(apply l (eval r))
(list 'cons l r)
)))
(define (mappend f l r)
(if (or (null? (cdr f))
(and (pair? r)
(eq? (car r) 'quote)
(eq? (car (cdr r)) '())))
l
(list 'append l r)))
(define (foo level form)
(cond ((not (pair? form))
(if (or (procedure? form) (number? form) (string? form))
form
(list 'quote form))
)
((eq? 'quasiquote (car form))
(mcons form ''quasiquote (foo (+ level 1) (cdr form))))
(#t (if (zero? level)
(cond ((eq? (car form) 'unquote) (car (cdr form)))
((eq? (car form) 'unquote-splicing)
(error "Unquote-splicing wasn't in a list:"
form))
((and (pair? (car form))
(eq? (car (car form)) 'unquote-splicing))
(mappend form (car (cdr (car form)))
(foo level (cdr form))))
(#t (mcons form (foo level (car form))
(foo level (cdr form)))))
(cond ((eq? (car form) 'unquote)
(mcons form ''unquote (foo (- level 1)
(cdr form))))
((eq? (car form) 'unquote-splicing)
(mcons form ''unquote-splicing
(foo (- level 1) (cdr form))))
(#t (mcons form (foo level (car form))
(foo level (cdr form)))))))))
(foo 0 (car (cdr l)))))
;;;;;Helper for the dynamic-wind definition. By Tom Breton (Tehom)
(define (shared-tail x y)
(let ((len-x (length x))
(len-y (length y)))
(define (shared-tail-helper x y)
(if
(eq? x y)
x
(shared-tail-helper (cdr x) (cdr y))))
(cond
((> len-x len-y)
(shared-tail-helper
(list-tail x (- len-x len-y))
y))
((< len-x len-y)
(shared-tail-helper
x
(list-tail y (- len-y len-x))))
(#t (shared-tail-helper x y)))))
;;;;;Dynamic-wind by Tom Breton (Tehom)
;;Guarded because we must only eval this once, because doing so
;;redefines call/cc in terms of old call/cc
(unless (defined? 'dynamic-wind)
(let
;;These functions are defined in the context of a private list of
;;pairs of before/after procs.
( (*active-windings* '())
;;We'll define some functions into the larger environment, so
;;we need to know it.
(outer-env (current-environment)))
;;Poor-man's structure operations
(define before-func car)
(define after-func cdr)
(define make-winding cons)
;;Manage active windings
(define (activate-winding! new)
((before-func new))
(set! *active-windings* (cons new *active-windings*)))
(define (deactivate-top-winding!)
(let ((old-top (car *active-windings*)))
;;Remove it from the list first so it's not active during its
;;own exit.
(set! *active-windings* (cdr *active-windings*))
((after-func old-top))))
(define (set-active-windings! new-ws)
(unless (eq? new-ws *active-windings*)
(let ((shared (shared-tail new-ws *active-windings*)))
;;Define the looping functions.
;;Exit the old list. Do deeper ones last. Don't do
;;any shared ones.
(define (pop-many)
(unless (eq? *active-windings* shared)
(deactivate-top-winding!)
(pop-many)))
;;Enter the new list. Do deeper ones first so that the
;;deeper windings will already be active. Don't do any
;;shared ones.
(define (push-many new-ws)
(unless (eq? new-ws shared)
(push-many (cdr new-ws))
(activate-winding! (car new-ws))))
;;Do it.
(pop-many)
(push-many new-ws))))
;;The definitions themselves.
(eval
`(define call-with-current-continuation
;;It internally uses the built-in call/cc, so capture it.
,(let ((old-c/cc call-with-current-continuation))
(lambda (func)
;;Use old call/cc to get the continuation.
(old-c/cc
(lambda (continuation)
;;Call func with not the continuation itself
;;but a procedure that adjusts the active
;;windings to what they were when we made
;;this, and only then calls the
;;continuation.
(func
(let ((current-ws *active-windings*))
(lambda (x)
(set-active-windings! current-ws)
(continuation x)))))))))
outer-env)
;;We can't just say "define (dynamic-wind before thunk after)"
;;because the lambda it's defined to lives in this environment,
;;not in the global environment.
(eval
`(define dynamic-wind
,(lambda (before thunk after)
;;Make a new winding
(activate-winding! (make-winding before after))
(let ((result (thunk)))
;;Get rid of the new winding.
(deactivate-top-winding!)
;;The return value is that of thunk.
result)))
outer-env)))
(define call/cc call-with-current-continuation)
;;;;; atom? and equal? written by a.k
;;;; atom?
(define (atom? x)
(not (pair? x)))
;;;; equal?
(define (equal? x y)
(cond
((pair? x)
(and (pair? y)
(equal? (car x) (car y))
(equal? (cdr x) (cdr y))))
((vector? x)
(and (vector? y) (vector-equal? x y)))
((string? x)
(and (string? y) (string=? x y)))
(else (eqv? x y))))
;;;; (do ((var init inc) ...) (endtest result ...) body ...)
;;
(macro do
(lambda (do-macro)
(apply (lambda (do vars endtest . body)
(let ((do-loop (gensym)))
`(letrec ((,do-loop
(lambda ,(map (lambda (x)
(if (pair? x) (car x) x))
`,vars)
(if ,(car endtest)
(begin ,@(cdr endtest))
(begin
,@body
(,do-loop
,@(map (lambda (x)
(cond
((not (pair? x)) x)
((< (length x) 3) (car x))
(else (car (cdr (cdr x))))))
`,vars)))))))
(,do-loop
,@(map (lambda (x)
(if (and (pair? x) (cdr x))
(car (cdr x))
'()))
`,vars)))))
do-macro)))
;;;; generic-member
(define (generic-member cmp obj lst)
(cond
((null? lst) #f)
((cmp obj (car lst)) lst)
(else (generic-member cmp obj (cdr lst)))))
(define (memq obj lst)
(generic-member eq? obj lst))
(define (memv obj lst)
(generic-member eqv? obj lst))
(define (member obj lst)
(generic-member equal? obj lst))
;;;; generic-assoc
(define (generic-assoc cmp obj alst)
(cond
((null? alst) #f)
((cmp obj (caar alst)) (car alst))
(else (generic-assoc cmp obj (cdr alst)))))
(define (assq obj alst)
(generic-assoc eq? obj alst))
(define (assv obj alst)
(generic-assoc eqv? obj alst))
(define (assoc obj alst)
(generic-assoc equal? obj alst))
(define (acons x y z) (cons (cons x y) z))
;;;; Handy for imperative programs
;;;; Used as: (define-with-return (foo x y) .... (return z) ...)
(macro (define-with-return form)
`(define ,(cadr form)
(call/cc (lambda (return) ,@(cddr form)))))
;; Print the given history.
(define (vm-history-print history)
(let loop ((n 0) (skip 0) (frames history))
(cond
((null? frames)
#t)
((> skip 0)
(loop 0 (- skip 1) (cdr frames)))
(else
(let ((f (car frames)))
(display n)
(display ": ")
(let ((tag (get-tag f)))
(when (and (pair? tag) (string? (car tag)) (number? (cdr tag)))
(display (basename (car tag)))
(display ":")
(display (+ 1 (cdr tag)))
(display ": ")))
(write f))
(newline)
(loop (+ n 1) skip (cdr frames))))))
;;;; Simple exception handling
;
; Exceptions are caught as follows:
;
; (catch (do-something to-recover and-return meaningful-value)
; (if-something goes-wrong)
; (with-these calls))
;
; "Catch" establishes a scope spanning multiple call-frames until
; another "catch" is encountered. Within the recovery expression
; the thrown exception is bound to *error*. Errors can be rethrown
; using (rethrow *error*).
;
; Finalization can be expressed using "finally":
;
; (finally (finalize-something called-purely-for side-effects)
; (whether-or-not something goes-wrong)
; (with-these calls))
;
; The final expression is executed purely for its side-effects,
; both when the function exits successfully, and when an exception
; is thrown.
;
; Exceptions are thrown with:
;
; (throw "message")
;
; If used outside a (catch ...), reverts to (error "message")
(define *handlers* (list))
(define (push-handler proc)
(set! *handlers* (cons proc *handlers*)))
(define (pop-handler)
(let ((h (car *handlers*)))
(set! *handlers* (cdr *handlers*))
h))
(define (more-handlers?)
(pair? *handlers*))
;; This throws an exception.
(define (throw message . args)
(throw' message args (cdr (*vm-history*))))
;; This is used by the vm to throw exceptions.
(define (throw' message args history)
(cond
((more-handlers?)
((pop-handler) message args history))
((and args (list? args) (= 2 (length args))
(equal? *interpreter-exit* (car args)))
(*run-atexit-handlers*)
(quit (cadr args)))
(else
(display message)
(when (and args (not (null? args)))
(display ": ")
(if (string? (car args))
(begin (display (car args))
(unless (null? (cdr args))
(newline)
(write (cdr args))))
(write args)))
(newline)
(vm-history-print history)
(quit 1))))
;; Convenience function to rethrow the error.
(define (rethrow e)
(apply throw' e))
(macro (catch form)
(let ((label (gensym)))
`(call/cc (lambda (**exit**)
(push-handler (lambda *error* (**exit** ,(cadr form))))
(let ((,label (begin ,@(cddr form))))
(pop-handler)
,label)))))
(define-macro (finally final-expression . expressions)
(let ((result (gensym)))
`(let ((,result (catch (begin ,final-expression (rethrow *error*))
,@expressions)))
,final-expression
,result)))
;; Make the vm use throw'.
(define *error-hook* throw')
;; High-level mechanism to terminate the process is to throw an error
;; of the form (*interpreter-exit* status). This gives automatic
;; resource management a chance to clean up.
(define *interpreter-exit* (gensym))
;; Terminate the process returning STATUS to the parent.
(define (exit status)
(throw "interpreter exit" *interpreter-exit* status))
;; A list of functions run at interpreter shutdown.
(define *atexit-handlers* (list))
;; Execute all these functions.
(define (*run-atexit-handlers*)
(unless (null? *atexit-handlers*)
(let ((proc (car *atexit-handlers*)))
;; Drop proc from the list so that it will not get
;; executed again even if it raises an exception.
(set! *atexit-handlers* (cdr *atexit-handlers*))
(proc)
(*run-atexit-handlers*))))
;; Register a function to be run at interpreter shutdown.
(define (atexit proc)
(set! *atexit-handlers* (cons proc *atexit-handlers*)))
;;;;; Definition of MAKE-ENVIRONMENT, to be used with two-argument EVAL
(macro (make-environment form)
`(apply (lambda ()
,@(cdr form)
(current-environment))))
(define-macro (eval-polymorphic x . envl)
(display envl)
(let* ((env (if (null? envl) (current-environment) (eval (car envl))))
(xval (eval x env)))
(if (closure? xval)
(make-closure (get-closure-code xval) env)
xval)))
; Redefine this if you install another package infrastructure
; Also redefine 'package'
(define *colon-hook* eval)
(macro (package form)
`(apply (lambda ()
,@(cdr form)
(current-environment))))
+(define-macro (export name . expressions)
+ `(define ,name
+ (begin
+ ,@expressions)))
+
;;;;; I/O
(define (input-output-port? p)
(and (input-port? p) (output-port? p)))
(define (close-port p)
(cond
((input-output-port? p) (close-input-port p) (close-output-port p))
((input-port? p) (close-input-port p))
((output-port? p) (close-output-port p))
(else (throw "Not a port" p))))
(define (call-with-input-file s p)
(let ((inport (open-input-file s)))
(if (eq? inport #f)
#f
(let ((res (p inport)))
(close-input-port inport)
res))))
(define (call-with-output-file s p)
(let ((outport (open-output-file s)))
(if (eq? outport #f)
#f
(let ((res (p outport)))
(close-output-port outport)
res))))
(define (with-input-from-file s p)
(let ((inport (open-input-file s)))
(if (eq? inport #f)
#f
(let ((prev-inport (current-input-port)))
(set-input-port inport)
(let ((res (p)))
(close-input-port inport)
(set-input-port prev-inport)
res)))))
(define (with-output-to-file s p)
(let ((outport (open-output-file s)))
(if (eq? outport #f)
#f
(let ((prev-outport (current-output-port)))
(set-output-port outport)
(let ((res (p)))
(close-output-port outport)
(set-output-port prev-outport)
res)))))
(define (with-input-output-from-to-files si so p)
(let ((inport (open-input-file si))
(outport (open-input-file so)))
(if (not (and inport outport))
(begin
(close-input-port inport)
(close-output-port outport)
#f)
(let ((prev-inport (current-input-port))
(prev-outport (current-output-port)))
(set-input-port inport)
(set-output-port outport)
(let ((res (p)))
(close-input-port inport)
(close-output-port outport)
(set-input-port prev-inport)
(set-output-port prev-outport)
res)))))
; Random number generator (maximum cycle)
(define *seed* 1)
(define (random-next)
(let* ((a 16807) (m 2147483647) (q (quotient m a)) (r (modulo m a)))
(set! *seed*
(- (* a (- *seed*
(* (quotient *seed* q) q)))
(* (quotient *seed* q) r)))
(if (< *seed* 0) (set! *seed* (+ *seed* m)))
*seed*))
;; SRFI-0
;; COND-EXPAND
;; Implemented as a macro
(define *features* '(srfi-0 tinyscheme))
(define-macro (cond-expand . cond-action-list)
(cond-expand-runtime cond-action-list))
(define (cond-expand-runtime cond-action-list)
(if (null? cond-action-list)
#t
(if (cond-eval (caar cond-action-list))
`(begin ,@(cdar cond-action-list))
(cond-expand-runtime (cdr cond-action-list)))))
(define (cond-eval-and cond-list)
(foldr (lambda (x y) (and (cond-eval x) (cond-eval y))) #t cond-list))
(define (cond-eval-or cond-list)
(foldr (lambda (x y) (or (cond-eval x) (cond-eval y))) #f cond-list))
(define (cond-eval condition)
(cond
((symbol? condition)
(if (member condition *features*) #t #f))
((eq? condition #t) #t)
((eq? condition #f) #f)
(else (case (car condition)
((and) (cond-eval-and (cdr condition)))
((or) (cond-eval-or (cdr condition)))
((not) (if (not (null? (cddr condition)))
(error "cond-expand : 'not' takes 1 argument")
(not (cond-eval (cadr condition)))))
(else (error "cond-expand : unknown operator" (car condition)))))))
(gc-verbose #f)
diff --git a/tests/gpgscm/tests.scm b/tests/gpgscm/tests.scm
index 490f95a36..eee8ce56f 100644
--- a/tests/gpgscm/tests.scm
+++ b/tests/gpgscm/tests.scm
@@ -1,776 +1,790 @@
;; Common definitions for writing tests.
;;
;; Copyright (C) 2016 g10 Code GmbH
;;
;; This file is part of GnuPG.
;;
;; GnuPG is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3 of the License, or
;; (at your option) any later version.
;;
;; GnuPG is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, see .
;; Reporting.
(define (echo . msg)
(for-each (lambda (x) (display x) (display " ")) msg)
(newline))
(define (info . msg)
(apply echo msg)
(flush-stdio))
(define (log . msg)
(if (> (*verbose*) 0)
(apply info msg)))
(define (fail . msg)
(apply info msg)
(exit 1))
(define (skip . msg)
(apply info msg)
(exit 77))
(define (make-counter)
(let ((c 0))
(lambda ()
(let ((r c))
(set! c (+ 1 c))
r))))
(define *progress-nesting* 0)
(define (call-with-progress msg what)
(set! *progress-nesting* (+ 1 *progress-nesting*))
(if (= 1 *progress-nesting*)
(begin
(info msg)
(display " > ")
(flush-stdio)
(what (lambda (item)
(display item)
(display " ")
(flush-stdio)))
(info "< "))
(begin
(what (lambda (item) (display ".") (flush-stdio)))
(display " ")
(flush-stdio)))
(set! *progress-nesting* (- *progress-nesting* 1)))
(define (for-each-p msg proc lst . lsts)
(apply for-each-p' `(,msg ,proc ,(lambda (x . xs) x) ,lst ,@lsts)))
(define (for-each-p' msg proc fmt lst . lsts)
(call-with-progress
msg
(lambda (progress)
(apply for-each
`(,(lambda args
(progress (apply fmt args))
(apply proc args))
,lst ,@lsts)))))
;; Process management.
(define CLOSED_FD -1)
(define (call-with-fds what infd outfd errfd)
(wait-process (stringify what) (spawn-process-fd what infd outfd errfd) #t))
(define (call what)
(call-with-fds what
CLOSED_FD
(if (< (*verbose*) 0) STDOUT_FILENO CLOSED_FD)
(if (< (*verbose*) 0) STDERR_FILENO CLOSED_FD)))
;; Accessor functions for the results of 'spawn-process'.
(define :stdin car)
(define :stdout cadr)
(define :stderr caddr)
(define :pid cadddr)
(define (call-with-io what in)
(let ((h (spawn-process what 0)))
(es-write (:stdin h) in)
(es-fclose (:stdin h))
(let* ((out (es-read-all (:stdout h)))
(err (es-read-all (:stderr h)))
(result (wait-process (car what) (:pid h) #t)))
(es-fclose (:stdout h))
(es-fclose (:stderr h))
(if (> (*verbose*) 2)
(info "Child" (:pid h) "returned:"
`((command ,(stringify what))
(status ,result)
(stdout ,out)
(stderr ,err))))
(list result out err))))
;; Accessor function for the results of 'call-with-io'. ':stdout' and
;; ':stderr' can also be used.
(define :retcode car)
(define (call-check what)
(let ((result (call-with-io what "")))
(if (= 0 (:retcode result))
(:stdout result)
(throw (string-append (stringify what) " failed")
(:stderr result)))))
(define (call-popen command input-string)
(let ((result (call-with-io command input-string)))
(if (= 0 (:retcode result))
(:stdout result)
(throw (:stderr result)))))
;;
;; estream helpers.
;;
(define (es-read-all stream)
(let loop
((acc ""))
(if (es-feof stream)
acc
(loop (string-append acc (es-read stream 4096))))))
;;
;; File management.
;;
(define (file-exists? name)
(call-with-input-file name (lambda (port) #t)))
(define (file=? a b)
(file-equal a b #t))
(define (text-file=? a b)
(file-equal a b #f))
(define (file-copy from to)
(catch '() (unlink to))
(letfd ((source (open from (logior O_RDONLY O_BINARY)))
(sink (open to (logior O_WRONLY O_CREAT O_BINARY) #o600)))
(splice source sink)))
(define (text-file-copy from to)
(catch '() (unlink to))
(letfd ((source (open from O_RDONLY))
(sink (open to (logior O_WRONLY O_CREAT) #o600)))
(splice source sink)))
(define (path-join . components)
(let loop ((acc #f) (rest (filter (lambda (s)
(not (string=? "" s))) components)))
(if (null? rest)
acc
(loop (if (string? acc)
(string-append acc "/" (car rest))
(car rest))
(cdr rest)))))
(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 (absolute-path? path) path (path-join (getcwd) path)))
(define (in-srcdir . names)
(canonical-path (apply path-join (cons (getenv "abs_top_srcdir") names))))
;; Try to find NAME in PATHS. Returns the full path name on success,
;; or raises an error.
(define (path-expand name paths)
(let loop ((path paths))
(if (null? path)
(throw "Could not find" name "in" paths)
(let* ((qualified-name (path-join (car path) name))
(file-exists (call-with-input-file qualified-name
(lambda (x) #t))))
(if file-exists
qualified-name
(loop (cdr path)))))))
;; Expand NAME using the gpgscm load path. Use like this:
;; (load (with-path "library.scm"))
(define (with-path name)
(catch name
(path-expand name (string-split (getenv "GPGSCM_PATH") *pathsep*))))
(define (basename path)
(let ((i (string-index path #\/)))
(if (equal? i #f)
path
(basename (substring path (+ 1 i) (string-length path))))))
(define (basename-suffix path suffix)
(basename
(if (string-suffix? path suffix)
(substring path 0 (- (string-length path) (string-length suffix)))
path)))
(define (dirname path)
(let ((i (string-rindex path #\/)))
(if i (substring path 0 i) ".")))
+(assert (string=? "foo/bar" (dirname "foo/bar/baz")))
;; Helper for (pipe).
(define :read-end car)
(define :write-end cadr)
;; let-like macro that manages file descriptors.
;;
;; (letfd )
;;
;; Bind all variables given in and initialize each of them
;; to the given initial value, and close them after evaluating .
(define-macro (letfd bindings . body)
(let bind ((bindings' bindings))
(if (null? bindings')
`(begin ,@body)
(let* ((binding (car bindings'))
(name (car binding))
(initializer (cadr binding)))
`(let ((,name ,initializer))
(finally (close ,name)
,(bind (cdr bindings'))))))))
(define-macro (with-working-directory new-directory . expressions)
(let ((new-dir (gensym))
(old-dir (gensym)))
`(let* ((,new-dir ,new-directory)
(,old-dir (getcwd)))
(dynamic-wind
(lambda () (if ,new-dir (chdir ,new-dir)))
(lambda () ,@expressions)
(lambda () (chdir ,old-dir))))))
;; 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. Returns an absolute path.
(define (mkdtemp . 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)))
`(let* ((,tmp-sym (mkdtemp)))
(finally (unlink-recursively ,tmp-sym)
(with-working-directory ,tmp-sym
,@expressions)))))
(define (make-temporary-file . args)
(canonical-path (path-join
(mkdtemp)
(if (null? args) "a" (car args)))))
(define (remove-temporary-file filename)
(catch '()
(unlink filename))
(let ((dirname (substring filename 0 (string-rindex filename #\/))))
(catch (echo "removing temporary directory" dirname "failed")
(rmdir dirname))))
;; let-like macro that manages temporary files.
;;
;; (lettmp )
;;
;; Bind all variables given in , initialize each of them to
;; a string representing an unique path in the filesystem, and delete
;; them after evaluating .
(define-macro (lettmp bindings . body)
(let bind ((bindings' bindings))
(if (null? bindings')
`(begin ,@body)
(let ((name (car bindings'))
(rest (cdr bindings')))
`(let ((,name (make-temporary-file ,(symbol->string name))))
(finally (remove-temporary-file ,name)
,(bind rest)))))))
(define (check-execution source transformer)
(lettmp (sink)
(transformer source sink)))
(define (check-identity source transformer)
(lettmp (sink)
(transformer source sink)
(if (not (file=? source sink))
(fail "mismatch"))))
;;
;; Monadic pipe support.
;;
(define pipeM
(package
(define (new procs source sink producer)
(package
(define (dump)
(write (list procs source sink producer))
(newline))
(define (add-proc command pid)
(new (cons (list command pid) procs) source sink producer))
(define (commands)
(map car procs))
(define (pids)
(map cadr procs))
(define (set-source source')
(new procs source' sink producer))
(define (set-sink sink')
(new procs source sink' producer))
(define (set-producer producer')
(if producer
(throw "producer already set"))
(new procs source sink producer'))))))
(define (pipe:do . commands)
(let loop ((M (pipeM::new '() CLOSED_FD CLOSED_FD #f)) (cmds commands))
(if (null? cmds)
(begin
(if M::producer (M::producer))
(if (not (null? M::procs))
(let* ((retcodes (wait-processes (map stringify (M::commands))
(M::pids) #t))
(results (map (lambda (p r) (append p (list r)))
M::procs retcodes))
(failed (filter (lambda (x) (not (= 0 (caddr x))))
results)))
(if (not (null? failed))
(throw failed))))) ; xxx nicer reporting
(if (and (= 2 (length cmds)) (number? (cadr cmds)))
;; hack: if it's an fd, use it as sink
(let ((M' ((car cmds) (M::set-sink (cadr cmds)))))
(if (> M::source 2) (close M::source))
(if (> (cadr cmds) 2) (close (cadr cmds)))
(loop M' '()))
(let ((M' ((car cmds) M)))
(if (> M::source 2) (close M::source))
(loop M' (cdr cmds)))))))
(define (pipe:open pathname flags)
(lambda (M)
(M::set-source (open pathname flags))))
(define (pipe:defer producer)
(lambda (M)
(let* ((p (outbound-pipe))
(M' (M::set-source (:read-end p))))
(M'::set-producer (lambda ()
(producer (:write-end p))
(close (:write-end p)))))))
(define (pipe:echo data)
(pipe:defer (lambda (sink) (display data (fdopen sink "wb")))))
(define (pipe:spawn command)
(lambda (M)
(define (do-spawn M new-source)
(let ((pid (spawn-process-fd command M::source M::sink
(if (> (*verbose*) 0)
STDERR_FILENO CLOSED_FD)))
(M' (M::set-source new-source)))
(M'::add-proc command pid)))
(if (= CLOSED_FD M::sink)
(let* ((p (pipe))
(M' (do-spawn (M::set-sink (:write-end p)) (:read-end p))))
(close (:write-end p))
(M'::set-sink CLOSED_FD))
(do-spawn M CLOSED_FD))))
(define (pipe:splice sink)
(lambda (M)
(splice M::source sink)
(M::set-source CLOSED_FD)))
(define (pipe:write-to pathname flags mode)
(open pathname flags mode))
;;
;; Monadic transformer support.
;;
(define (tr:do . commands)
(let loop ((tmpfiles '()) (source #f) (cmds commands))
(if (null? cmds)
(for-each remove-temporary-file tmpfiles)
(let* ((v ((car cmds) tmpfiles source))
(tmpfiles' (car v))
(sink (cadr v))
(error (caddr v)))
(if error
(begin
(for-each remove-temporary-file tmpfiles')
(apply throw error)))
(loop tmpfiles' sink (cdr cmds))))))
(define (tr:open pathname)
(lambda (tmpfiles source)
(list tmpfiles pathname #f)))
(define (tr:spawn input command)
(lambda (tmpfiles source)
(if (and (member '**in** command) (not source))
(fail (string-append (stringify cmd) " needs an input")))
(let* ((t (make-temporary-file))
(cmd (map (lambda (x)
(cond
((equal? '**in** x) source)
((equal? '**out** x) t)
(else x))) command)))
(catch (list (cons t tmpfiles) t *error*)
(call-popen cmd input)
(if (and (member '**out** command) (not (file-exists? t)))
(fail (string-append (stringify cmd)
" did not produce '" t "'.")))
(list (cons t tmpfiles) t #f)))))
(define (tr:write-to pathname)
(lambda (tmpfiles source)
(rename source pathname)
(list tmpfiles pathname #f)))
(define (tr:pipe-do . commands)
(lambda (tmpfiles source)
(let ((t (make-temporary-file)))
(apply pipe:do
`(,@(if source `(,(pipe:open source (logior O_RDONLY O_BINARY))) '())
,@commands
,(pipe:write-to t (logior O_WRONLY O_BINARY O_CREAT) #o600)))
(list (cons t tmpfiles) t #f))))
(define (tr:assert-identity reference)
(lambda (tmpfiles source)
(if (not (file=? source reference))
(fail "mismatch"))
(list tmpfiles source #f)))
(define (tr:assert-weak-identity reference)
(lambda (tmpfiles source)
(if (not (text-file=? source reference))
(fail "mismatch"))
(list tmpfiles source #f)))
(define (tr:call-with-content function . args)
(lambda (tmpfiles source)
(catch (list tmpfiles source *error*)
(apply function `(,(call-with-input-file source read-all) ,@args)))
(list tmpfiles source #f)))
;;
;; Developing and debugging tests.
;;
;; 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)
(set! procs (cons test procs))
(current-environment))
(define (pid->test pid)
(let ((t (filter (lambda (x) (= pid x::pid)) procs)))
(if (null? t) #f (car t))))
(define (wait)
(let ((unfinished (filter (lambda (t) (not t::retcode)) procs)))
(if (null? unfinished)
(current-environment)
(let ((names (map (lambda (t) t::name) unfinished))
(pids (map (lambda (t) t::pid) unfinished)))
(for-each
(lambda (test retcode)
(test::set-end-time!)
(test:::set! 'retcode retcode))
(map pid->test pids)
(wait-processes (map stringify names) pids #t)))))
(current-environment))
(define (filter-tests status)
(filter (lambda (p) (eq? status (p::status))) procs))
(define (report)
(define (print-tests tests message)
(unless (null? tests)
(apply echo (cons message
(map (lambda (t) t::name) tests)))))
(let ((failed (filter-tests 'FAIL))
(xfailed (filter-tests 'XFAIL))
(xpassed (filter-tests 'XPASS))
(skipped (filter-tests 'SKIP)))
(echo (length procs) "tests run,"
(length (filter-tests 'PASS)) "succeeded,"
(length failed) "failed,"
(length xfailed) "failed expectedly,"
(length xpassed) "succeeded unexpectedly,"
(length skipped) "skipped.")
(print-tests failed "Failed tests:")
(print-tests xfailed "Expectedly failed tests:")
(print-tests xpassed "Unexpectedly passed tests:")
(print-tests skipped "Skipped tests:")
(+ (length failed) (length xpassed))))
(define (xml)
(xx::document
(xx::tag 'testsuites
`((xmlns:xsi "http://www.w3.org/2001/XMLSchema-instance")
("xsi:noNamespaceSchemaLocation"
"https://windyroad.com.au/dl/Open%20Source/JUnit.xsd"))
(map (lambda (t) (t::xml)) procs))))))))
(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
(begin
;; Private definitions.
(define (isotime->junit t)
"[0-9]{4}-[0-9]{2}-[0-9]{2}T[0-9]{2}:[0-9]{2}:[0-9]{2}"
"20170418T145809"
(string-append (substring t 0 4)
"-"
(substring t 4 6)
"-"
(substring t 6 11)
":"
(substring t 11 13)
":"
(substring t 13 15)))
;; If a tests name ends with a bang (!), it is expected to fail.
(define (expect-failure? name)
(string-suffix? name "!"))
;; Strips the bang (if any).
(define (test-name name)
(if (expect-failure? name)
(substring name 0 (- (string-length name) 1))
name))
(package
(define (scm setup name path . args)
;; Start the process.
(define (spawn-scm args' in out err)
(spawn-process-fd `(,*argv0* ,@(verbosity (*verbose*))
,(locate-test (test-name path))
,@(if setup (force setup) '())
,@args' ,@args) in out err))
(new name #f spawn-scm #f #f CLOSED_FD (expect-failure? name)))
(define (binary setup name path . args)
;; Start the process.
(define (spawn-binary args' in out err)
(spawn-process-fd `(,(test-name path)
,@(if setup (force setup) '()) ,@args' ,@args)
in out err))
(new name #f spawn-binary #f #f CLOSED_FD (expect-failure? name)))
(define (new name directory spawn pid retcode logfd expect-failure)
(package
;; XXX: OO glue.
(define self (current-environment))
(define (:set! key value)
(eval `(set! ,key ,value) (current-environment))
(current-environment))
;; The log is written here.
(define log-file-name #f)
;; Record time stamps.
(define timestamp #f)
(define start-time 0)
(define end-time 0)
(define (set-start-time!)
(set! timestamp (isotime->junit (get-isotime)))
(set! start-time (get-time)))
(define (set-end-time!)
(set! end-time (get-time)))
(define (open-log-file)
(unless log-file-name
(set! log-file-name (string-append (basename name) ".log")))
(catch '() (unlink log-file-name))
(open log-file-name (logior O_RDWR O_BINARY O_CREAT) #o600))
(define (run-sync . args)
(set-start-time!)
(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))
(set! pid pid')
(set! retcode (wait-process name pid' #t)))))
(report)
(current-environment))
(define (run-sync-quiet . args)
(set-start-time!)
(with-working-directory directory
(set! pid (spawn args CLOSED_FD CLOSED_FD CLOSED_FD)))
(set! retcode (wait-process name pid #t))
(set-end-time!)
(current-environment))
(define (run-async . args)
(set-start-time!)
(let ((log (open-log-file)))
(with-working-directory directory
(set! pid (spawn args CLOSED_FD log log)))
(set! logfd log))
(current-environment))
(define (status)
(let* ((t' (assoc retcode '((0 PASS) (77 SKIP) (99 ERROR))))
(t (if (not t') 'FAIL (cadr t'))))
(if expect-failure
(case t ((PASS) 'XPASS) ((FAIL) 'XFAIL) (else t))
t)))
(define (status-string)
(cadr (assoc (status) '((PASS "PASS")
(SKIP "SKIP")
(ERROR "ERROR")
(FAIL "FAIL")
(XPASS "XPASS")
(XFAIL "XFAIL")))))
(define (report)
(unless (= logfd CLOSED_FD)
(seek logfd 0 SEEK_SET)
(splice logfd STDERR_FILENO)
(close logfd))
(echo (string-append (status-string) ":") name))
(define (xml)
(xx::tag
'testsuite
`((name ,name)
(time ,(- end-time start-time))
(package ,(dirname name))
(id 0)
(timestamp ,timestamp)
(hostname "unknown")
(tests 1)
(failures ,(if (eq? FAIL (status)) 1 0))
(errors ,(if (eq? ERROR (status)) 1 0)))
(list
(xx::tag 'properties)
(xx::tag 'testcase
`((name ,(basename name))
(classname ,(string-translate (dirname name) "/" "."))
(time ,(- end-time start-time)))
`(,@(case (status)
((PASS XFAIL) '())
((SKIP) (list (xx::tag 'skipped)))
((ERROR) (list
(xx::tag 'error '((message "Unknown error.")))))
(else
(list (xx::tag 'failure '((message "Unknown error."))))))))
(xx::tag 'system-out '()
(list (xx::textnode (read-all (open-input-file log-file-name)))))
(xx::tag 'system-err '() (list (xx::textnode "")))))))))))
;; Run the setup target to create an environment, then run all given
;; tests in parallel.
(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))
((results::xml) (open-output-file "report.xml"))
(exit (results::report)))
(let ((wd (mkdtemp-autoremove))
(test (car tests')))
(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 tests)
(let loop ((pool (test-pool::new '())) (tests' tests))
(if (null? tests')
(let ((results (pool::wait)))
((results::xml) (open-output-file "report.xml"))
(exit (results::report)))
(let ((wd (mkdtemp-autoremove))
(test (car tests')))
(test:::set! 'directory wd)
(loop (pool::add (test::run-sync))
(cdr tests'))))))
+;; Run tests either in sequence or in parallel, depending on the
+;; number of tests and the command line flags.
+(define (run-tests tests)
+ (if (and (flag "--parallel" *args*)
+ (> (length tests) 1))
+ (run-tests-parallel tests)
+ (run-tests-sequential tests)))
+
+;; Load all tests from the given path.
+(define (load-tests . path)
+ (load (apply in-srcdir `(,@path "all-tests.scm")))
+ all-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
;; ARGUMENTS.
(define (flag key arguments)
(cond
((null? arguments)
#f)
((string=? key (car arguments))
(let loop ((acc '())
(args (cdr arguments)))
(if (or (null? args) (string-prefix? (car args) "--"))
(reverse acc)
(loop (cons (car args) acc) (cdr args)))))
((string=? "--" (car arguments))
#f)
(else
(flag key (cdr arguments)))))
(assert (equal? (flag "--xxx" '("--yyy")) #f))
(assert (equal? (flag "--xxx" '("--xxx")) '()))
(assert (equal? (flag "--xxx" '("--xxx" "yyy")) '("yyy")))
(assert (equal? (flag "--xxx" '("--xxx" "yyy" "zzz")) '("yyy" "zzz")))
(assert (equal? (flag "--xxx" '("--xxx" "yyy" "zzz" "--")) '("yyy" "zzz")))
(assert (equal? (flag "--xxx" '("--xxx" "yyy" "--" "zzz")) '("yyy")))
(assert (equal? (flag "--" '("--" "xxx" "yyy" "--" "zzz")) '("xxx" "yyy")))
diff --git a/tests/gpgsm/Makefile.am b/tests/gpgsm/Makefile.am
index 892d3bc8b..e54db7842 100644
--- a/tests/gpgsm/Makefile.am
+++ b/tests/gpgsm/Makefile.am
@@ -1,75 +1,75 @@
# Makefile.am - For tests/gpgme
# 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 .
# Process this file with automake to create Makefile.in
# Programs required before we can run these tests.
required_pgms = ../../g10/gpg$(EXEEXT) ../../agent/gpg-agent$(EXEEXT) \
../../tools/gpg-connect-agent$(EXEEXT) \
../gpgscm/gpgscm$(EXEEXT)
AM_CPPFLAGS = -I$(top_srcdir)/common
include $(top_srcdir)/am/cmacros.am
AM_CFLAGS =
TESTS_ENVIRONMENT = LC_ALL=C \
EXEEXT=$(EXEEXT) \
PATH=../gpgscm:$(PATH) \
abs_top_srcdir=$(abs_top_srcdir) \
objdir=$(abs_top_builddir) \
GPGSCM_PATH=$(abs_top_srcdir)/tests/gpgscm
XTESTS = \
import.scm \
encrypt.scm \
verify.scm \
decrypt.scm \
sign.scm \
export.scm
# XXX: Currently, one cannot override automake's 'check' target. As a
# workaround, we avoid defining 'TESTS', thus automake will not emit
# the 'check' target. For extra robustness, we merely define a
# dependency on 'xcheck', so this hack should also work even if
# automake would emit the 'check' target, as adding dependencies to
# targets is okay.
check: xcheck
.PHONY: xcheck
xcheck:
$(TESTS_ENVIRONMENT) $(abs_top_builddir)/tests/gpgscm/gpgscm \
- $(abs_srcdir)/run-tests.scm $(TESTFLAGS) $(XTESTS)
+ $(abs_srcdir)/run-tests.scm $(TESTFLAGS) $(TESTS)
KEYS = 32100C27173EF6E9C4E9A25D3D69F86D37A4F939
CERTS = cert_g10code_test1.der \
cert_dfn_pca01.der \
cert_dfn_pca15.der
TEST_FILES = plain-1.cms.asc \
plain-2.cms.asc \
plain-3.cms.asc \
plain-large.cms.asc
EXTRA_DIST = $(XTESTS) $(KEYS) $(CERTS) $(TEST_FILES) \
- gpgsm-defs.scm run-tests.scm setup.scm
+ gpgsm-defs.scm run-tests.scm setup.scm all-tests.scm
CLEANFILES = *.log report.xml
# We need to depend on a couple of programs so that the tests don't
# start before all programs are built.
all-local: $(required_pgms)
diff --git a/tests/gpgsm/all-tests.scm b/tests/gpgsm/all-tests.scm
new file mode 100644
index 000000000..1baa92468
--- /dev/null
+++ b/tests/gpgsm/all-tests.scm
@@ -0,0 +1,43 @@
+;; 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 .
+
+(export all-tests
+ ;; Parse the Makefile.am to find all tests.
+
+ (load (with-path "makefile.scm"))
+
+ (define (expander filename port key)
+ (parse-makefile port key))
+
+ (define (parse filename key)
+ (parse-makefile-expand filename expander key))
+
+ (define setup
+ (make-environment-cache
+ (test::scm
+ #f
+ (path-join "tests" "gpgsm" "setup.scm")
+ (in-srcdir "tests" "gpgsm" "setup.scm")
+ "--" "tests" "gpg")))
+
+ (map (lambda (name)
+ (test::scm setup
+ (path-join "tests" "gpgsm" name)
+ (in-srcdir "tests" "gpgsm" name)))
+ (parse-makefile-expand (in-srcdir "tests" "gpgsm" "Makefile.am")
+ (lambda (filename port key) (parse-makefile port key))
+ "XTESTS")))
diff --git a/tests/gpgsm/run-tests.scm b/tests/gpgsm/run-tests.scm
index bf129a1cb..6b460b165 100644
--- a/tests/gpgsm/run-tests.scm
+++ b/tests/gpgsm/run-tests.scm
@@ -1,38 +1,39 @@
;; Test-suite runner.
;;
;; 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 .
(if (string=? "" (getenv "abs_top_srcdir"))
(begin
(echo "Environment variable 'abs_top_srcdir' not set. Please point it to"
"tests/gpgsm.")
(exit 2)))
-(let* ((tests (filter (lambda (arg) (not (string-prefix? arg "--"))) *args*))
- (setup (make-environment-cache (test::scm
- #f
- (path-join "tests" "gpgsm" "setup.scm")
- (in-srcdir "tests" "gpgsm" "setup.scm"))))
- (runner (if (and (member "--parallel" *args*)
- (> (length tests) 1))
- run-tests-parallel
- run-tests-sequential)))
- (runner (map (lambda (name)
- (test::scm setup
- (path-join "tests" "gpgsm" name)
- (in-srcdir "tests" "gpgsm" name))) tests)))
+(define tests (filter (lambda (arg) (not (string-prefix? arg "--"))) *args*))
+
+(define setup
+ (make-environment-cache (test::scm
+ #f
+ (path-join "tests" "gpgsm" "setup.scm")
+ (in-srcdir "tests" "gpgsm" "setup.scm"))))
+
+(run-tests (if (null? tests)
+ (load-tests "tests" "gpgsm")
+ (map (lambda (name)
+ (test::scm setup
+ (path-join "tests" "gpgsm" name)
+ (in-srcdir "tests" "gpgsm" name))) tests)))
diff --git a/tests/migrations/Makefile.am b/tests/migrations/Makefile.am
index 398b15c80..d90c9c7f9 100644
--- a/tests/migrations/Makefile.am
+++ b/tests/migrations/Makefile.am
@@ -1,65 +1,66 @@
# Makefile.am - For tests/openpgp
# 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 .
# Process this file with automake to create Makefile.in
# Programs required before we can run these tests.
required_pgms = ../../g10/gpg$(EXEEXT) ../../agent/gpg-agent$(EXEEXT) \
../../tools/gpgtar$(EXEEXT) \
../gpgscm/gpgscm$(EXEEXT)
AM_CPPFLAGS = -I$(top_srcdir)/common
include $(top_srcdir)/am/cmacros.am
AM_CFLAGS =
TESTS_ENVIRONMENT = GPG_AGENT_INFO= LC_ALL=C \
EXEEXT=$(EXEEXT) \
PATH=../gpgscm:$(PATH) \
abs_top_srcdir=$(abs_top_srcdir) \
objdir=$(abs_top_builddir) \
GPGSCM_PATH=$(abs_top_srcdir)/tests/gpgscm
XTESTS = from-classic.scm \
extended-pkf.scm \
issue2276.scm
TEST_FILES = from-classic.tar.asc \
extended-pkf.tar.asc \
issue2276.tar.asc
# XXX: Currently, one cannot override automake's 'check' target. As a
# workaround, we avoid defining 'TESTS', thus automake will not emit
# the 'check' target. For extra robustness, we merely define a
# dependency on 'xcheck', so this hack should also work even if
# automake would emit the 'check' target, as adding dependencies to
# targets is okay.
check: xcheck
.PHONY: xcheck
xcheck:
$(TESTS_ENVIRONMENT) $(abs_top_builddir)/tests/gpgscm/gpgscm \
- $(abs_srcdir)/run-tests.scm $(TESTFLAGS) $(XTESTS)
+ $(abs_srcdir)/run-tests.scm $(TESTFLAGS) $(TESTS)
-EXTRA_DIST = common.scm run-tests.scm setup.scm $(XTESTS) $(TEST_FILES)
+EXTRA_DIST = common.scm run-tests.scm setup.scm all-tests.scm \
+ $(XTESTS) $(TEST_FILES)
CLEANFILES = *.log report.xml
# We need to depend on a couple of programs so that the tests don't
# start before all programs are built.
all-local: $(required_pgms)
diff --git a/tests/migrations/run-tests.scm b/tests/migrations/all-tests.scm
similarity index 54%
copy from tests/migrations/run-tests.scm
copy to tests/migrations/all-tests.scm
index 1e4bb704b..421f69679 100644
--- a/tests/migrations/run-tests.scm
+++ b/tests/migrations/all-tests.scm
@@ -1,28 +1,35 @@
-;; Test-suite runner.
-;;
-;; Copyright (C) 2016 g10 Code GmbH
+;; 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 .
-(let* ((tests (filter (lambda (arg) (not (string-prefix? arg "--"))) *args*))
- (runner (if (and (member "--parallel" *args*)
- (> (length tests) 1))
- run-tests-parallel
- run-tests-sequential)))
- (runner (map (lambda (name)
- (test::scm #f
- (path-join "tests" "migrations" name)
- (in-srcdir "tests" "migrations" name))) tests)))
+(export all-tests
+ ;; Parse the Makefile.am to find all tests.
+
+ (load (with-path "makefile.scm"))
+
+ (define (expander filename port key)
+ (parse-makefile port key))
+
+ (define (parse filename key)
+ (parse-makefile-expand filename expander key))
+
+ (map (lambda (name)
+ (test::scm #f
+ (path-join "tests" "migrations" name)
+ (in-srcdir "tests" "migrations" name)))
+ (parse-makefile-expand (in-srcdir "tests" "migrations" "Makefile.am")
+ (lambda (filename port key) (parse-makefile port key))
+ "XTESTS")))
diff --git a/tests/migrations/run-tests.scm b/tests/migrations/run-tests.scm
index 1e4bb704b..f44334c7d 100644
--- a/tests/migrations/run-tests.scm
+++ b/tests/migrations/run-tests.scm
@@ -1,28 +1,27 @@
;; Test-suite runner.
;;
;; 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 .
-(let* ((tests (filter (lambda (arg) (not (string-prefix? arg "--"))) *args*))
- (runner (if (and (member "--parallel" *args*)
- (> (length tests) 1))
- run-tests-parallel
- run-tests-sequential)))
- (runner (map (lambda (name)
- (test::scm #f
- (path-join "tests" "migrations" name)
- (in-srcdir "tests" "migrations" name))) tests)))
+(define tests (filter (lambda (arg) (not (string-prefix? arg "--"))) *args*))
+
+(run-tests (if (null? tests)
+ (load-tests "tests" "migrations")
+ (map (lambda (name)
+ (test::scm #f
+ (path-join "tests" "migrations" name)
+ (in-srcdir "tests" "migrations" name))) tests)))
diff --git a/tests/openpgp/Makefile.am b/tests/openpgp/Makefile.am
index d99c3d9c5..bf9673f74 100644
--- a/tests/openpgp/Makefile.am
+++ b/tests/openpgp/Makefile.am
@@ -1,269 +1,269 @@
# Makefile.am - For tests/openpgp
# Copyright (C) 1998, 1999, 2000, 2001, 2003,
# 2010 Free Software Foundation, Inc.
#
# 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 .
# Process this file with automake to create Makefile.in
# Programs required before we can run these tests.
required_pgms = ../../g10/gpg$(EXEEXT) ../../agent/gpg-agent$(EXEEXT) \
../../tools/gpg-connect-agent$(EXEEXT) \
../gpgscm/gpgscm$(EXEEXT)
AM_CPPFLAGS = -I$(top_srcdir)/common
include $(top_srcdir)/am/cmacros.am
AM_CFLAGS =
noinst_PROGRAMS = fake-pinentry
fake_pinentry_SOURCES = fake-pinentry.c
TESTS_ENVIRONMENT = LC_ALL=C \
EXEEXT=$(EXEEXT) \
PATH=../gpgscm:$(PATH) \
abs_top_srcdir=$(abs_top_srcdir) \
objdir=$(abs_top_builddir) \
GPGSCM_PATH=$(abs_top_srcdir)/tests/gpgscm
XTESTS = \
version.scm \
enarmor.scm \
mds.scm \
decrypt.scm \
decrypt-multifile.scm \
decrypt-dsa.scm \
decrypt-session-key.scm \
decrypt-unwrap-verify.scm \
sigs.scm \
sigs-dsa.scm \
encrypt.scm \
encrypt-multifile.scm \
encrypt-dsa.scm \
compression.scm \
seat.scm \
clearsig.scm \
encryptp.scm \
detach.scm \
detachm.scm \
armsigs.scm \
armencrypt.scm \
armencryptp.scm \
signencrypt.scm \
signencrypt-dsa.scm \
armsignencrypt.scm \
armdetach.scm \
armdetachm.scm \
genkey1024.scm \
conventional.scm \
conventional-mdc.scm \
multisig.scm \
verify.scm \
verify-multifile.scm \
gpgv-forged-keyring.scm \
armor.scm \
import.scm \
import-revocation-certificate.scm \
ecc.scm \
4gb-packet.scm \
tofu.scm \
gpgtar.scm \
use-exact-key.scm \
default-key.scm \
export.scm \
ssh-import.scm \
ssh-export.scm \
quick-key-manipulation.scm \
key-selection.scm \
delete-keys.scm \
gpgconf.scm \
issue2015.scm \
issue2346.scm \
issue2417.scm \
issue2419.scm \
issue2929.scm \
issue2941.scm
# XXX: Currently, one cannot override automake's 'check' target. As a
# workaround, we avoid defining 'TESTS', thus automake will not emit
# the 'check' target. For extra robustness, we merely define a
# dependency on 'xcheck', so this hack should also work even if
# automake would emit the 'check' target, as adding dependencies to
# targets is okay.
check: xcheck
.PHONY: xcheck
xcheck:
$(TESTS_ENVIRONMENT) $(abs_top_builddir)/tests/gpgscm/gpgscm \
- $(abs_srcdir)/run-tests.scm $(TESTFLAGS) $(XTESTS)
+ $(abs_srcdir)/run-tests.scm $(TESTFLAGS) $(TESTS)
TEST_FILES = pubring.asc secring.asc plain-1o.asc plain-2o.asc plain-3o.asc \
plain-1.asc plain-2.asc plain-3.asc plain-1-pgp.asc \
plain-largeo.asc plain-large.asc \
pubring.pkr.asc secring.skr.asc secdemo.asc pubdemo.asc \
bug537-test.data.asc bug894-test.asc \
bug1223-good.asc bug1223-bogus.asc 4gb-packet.asc \
tofu/conflicting/1C005AF3.gpg \
tofu/conflicting/1C005AF3-secret.gpg \
tofu/conflicting/1C005AF3-1.txt \
tofu/conflicting/1C005AF3-2.txt \
tofu/conflicting/1C005AF3-3.txt \
tofu/conflicting/1C005AF3-4.txt \
tofu/conflicting/1C005AF3-5.txt \
tofu/conflicting/B662E42F.gpg \
tofu/conflicting/B662E42F-secret.gpg \
tofu/conflicting/B662E42F-1.txt \
tofu/conflicting/B662E42F-2.txt \
tofu/conflicting/B662E42F-3.txt \
tofu/conflicting/B662E42F-4.txt \
tofu/conflicting/B662E42F-5.txt \
tofu/conflicting/BE04EB2B.gpg \
tofu/conflicting/BE04EB2B-secret.gpg \
tofu/conflicting/BE04EB2B-1.txt \
tofu/conflicting/BE04EB2B-2.txt \
tofu/conflicting/BE04EB2B-3.txt \
tofu/conflicting/BE04EB2B-4.txt \
tofu/conflicting/BE04EB2B-5.txt \
tofu/cross-sigs/EC38277E-secret.gpg \
tofu/cross-sigs/EC38277E-1.gpg \
tofu/cross-sigs/EC38277E-1.txt \
tofu/cross-sigs/EC38277E-2.gpg \
tofu/cross-sigs/EC38277E-2.txt \
tofu/cross-sigs/EC38277E-3.txt \
tofu/cross-sigs/871C2247-secret.gpg \
tofu/cross-sigs/871C2247-1.gpg \
tofu/cross-sigs/871C2247-1.txt \
tofu/cross-sigs/871C2247-2.gpg \
tofu/cross-sigs/871C2247-2.txt \
tofu/cross-sigs/871C2247-3.gpg \
tofu/cross-sigs/871C2247-3.txt \
tofu/cross-sigs/871C2247-4.gpg \
tofu/cross-sigs/README \
key-selection/0.asc \
key-selection/1.asc \
key-selection/2.asc \
key-selection/3.asc \
key-selection/4.asc
data_files = data-500 data-9000 data-32000 data-80000 plain-large
priv_keys = privkeys/50B2D4FA4122C212611048BC5FC31BD44393626E.asc \
privkeys/7E201E28B6FEB2927B321F443205F4724EBE637E.asc \
privkeys/13FDB8809B17C5547779F9D205C45F47CE0217CE.asc \
privkeys/343D8AF79796EE107D645A2787A9D9252F924E6F.asc \
privkeys/8B5ABF3EF9EB8D96B91A0B8C2C4401C91C834C34.asc \
privkeys/0D6F6AD4C4C803B25470F9104E9F4E6A4CA64255.asc \
privkeys/FD692BD59D6640A84C8422573D469F84F3B98E53.asc \
privkeys/76F7E2B35832976B50A27A282D9B87E44577EB66.asc \
privkeys/A0747D5F9425E6664F4FFBEED20FBCA79FDED2BD.asc \
privkeys/0DD40284FF992CD24DC4AAC367037E066FCEE26A.asc \
privkeys/2BC997C0B8691D41D29A4EC81CCBCF08454E4961.asc \
privkeys/3C9D5ECA70130C2DBB1FC6AC0076BEEEC197716F.asc \
privkeys/449E644892C951A37525654730DD32C202079926.asc \
privkeys/58FFE844087634E62440224908BDE44BEA7EB730.asc \
privkeys/4DF9172D6FF428C97A0E9AA96F03E8BCE3B2F188.asc \
privkeys/9D7CD8F53F2F14C3E2177D1E9D1D11F39513A4A4.asc \
privkeys/6E6B7ED0BD4425018FFC54F3921D5467A3AE00EB.asc \
privkeys/C905D0AB6AE9655C5A35975939997BBF3325D6DD.asc \
privkeys/B2BAA7144303DF19BB6FDE23781DD3FDD97918D4.asc \
privkeys/CF60965BF51F67CF80DECE853E0D2D343468571D.asc \
privkeys/DF00E361D34F80868D06879AC21D7A7D4E4FAD76.asc \
privkeys/00FE67F28A52A8AA08FFAED20AF832DA916D1985.asc \
privkeys/1DF48228FEFF3EC2481B106E0ACA8C465C662CC5.asc \
privkeys/A2832820DC9F40751BDCD375BB0945BA33EC6B4C.asc \
privkeys/ADE710D74409777B7729A7653373D820F67892E0.asc \
privkeys/CEFC51AF91F68A2904FBFF62C4F075A4785B803F.asc \
privkeys/1E28F20E41B54C2D1234D896096495FF57E08D18.asc \
privkeys/EB33B687EB8581AB64D04852A54453E85F3DF62D.asc \
privkeys/C6A6390E9388CDBAD71EAEA698233FE5E04F001E.asc \
privkeys/D69102E0F5AC6B6DB8E4D16DA8E18CF46D88CAE3.asc
sample_keys = samplekeys/README \
samplekeys/ecc-sample-1-pub.asc \
samplekeys/ecc-sample-2-pub.asc \
samplekeys/ecc-sample-3-pub.asc \
samplekeys/ecc-sample-1-sec.asc \
samplekeys/ecc-sample-2-sec.asc \
samplekeys/ecc-sample-3-sec.asc \
samplekeys/eddsa-sample-1-pub.asc \
samplekeys/eddsa-sample-1-sec.asc \
samplekeys/dda252ebb8ebe1af-1.asc \
samplekeys/dda252ebb8ebe1af-2.asc \
samplekeys/whats-new-in-2.1.asc \
samplekeys/e2e-p256-1-clr.asc \
samplekeys/e2e-p256-1-prt.asc \
samplekeys/E657FB607BB4F21C90BB6651BC067AF28BC90111.asc \
samplekeys/rsa-rsa-sample-1.asc \
samplekeys/ed25519-cv25519-sample-1.asc \
samplekeys/silent-running.asc \
samplekeys/ssh-dsa.key \
samplekeys/ssh-ecdsa.key \
samplekeys/ssh-ed25519.key \
samplekeys/ssh-rsa.key \
samplekeys/issue2346.gpg \
samplekeys/authenticate-only.pub.asc \
samplekeys/authenticate-only.sec.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/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) \
$(sample_msgs) ChangeLog-2011 run-tests.scm \
- setup.scm shell.scm
+ setup.scm shell.scm all-tests.scm
CLEANFILES = prepared.stamp x y yy z out err $(data_files) \
plain-1 plain-2 plain-3 trustdb.gpg *.lock .\#lk* \
*.log gpg_dearmor gpg.conf gpg-agent.conf S.gpg-agent \
pubring.gpg pubring.gpg~ pubring.kbx pubring.kbx~ \
secring.gpg pubring.pkr secring.skr \
gnupg-test.stop random_seed gpg-agent.log tofu.db \
passphrases sshcontrol S.gpg-agent.ssh report.xml
clean-local:
-rm -rf private-keys-v1.d openpgp-revocs.d tofu.d gpgtar.d
# We need to depend on a couple of programs so that the tests don't
# start before all programs are built.
all-local: $(required_pgms)
diff --git a/tests/openpgp/README b/tests/openpgp/README
index b9d560797..42e78ae2d 100644
--- a/tests/openpgp/README
+++ b/tests/openpgp/README
@@ -1,217 +1,217 @@
# Emacs, this is an -*- org -*- file.
* How to run the test suite
From your build directory, run
obj $ make -C tests/openpgp check
to run all tests or
- obj $ make -C tests/openpgp check XTESTS=your-test.scm
+ obj $ make -C tests/openpgp check TESTS=your-test.scm
to run a specific test (or any number of tests separated by spaces).
If you want to debug a test, add verbose=1 to see messages printed by
spawned programs to their standard error stream, verbose=2 to see what
programs are executed, or verbose=3 to see even more program output
and exit codes.
** Passing options to the test driver
You can set TESTFLAGS to pass flags to 'run-tests.scm'. For example,
to speed up the test suite when bisecting, do
obj $ make -C tests/openpgp check TESTFLAGS=--parallel
See below for the arguments supported by the driver.
** Calling the test driver directly
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 $ srcdir=/tests/openpgp \
GPGSCM_PATH=/tests/gpgscm:/tests/openpgp \
$(pwd)/tests/gpgscm/gpgscm [gpgscm args] \
run-tests.scm [test suite runner args]
*** Arguments supported by the test suite runner
The test suite runner supports two modes of operation, '--sequential'
and '--parallel'. By default the tests are run in sequential order,
each one in a clean environment.
You can specify the tests to run as positional arguments relative to
srcdir (e.g. just 'version.scm'). Note that you do not have to
specify setup.scm and finish.scm, they are executed implicitly.
The test suite runner can be executed in any location that the current
user can write to. It will create temporary files and directories,
but will in general clean up all of them.
*** Discussion of the various environment variables
**** srcdir
Must be set to the source of the openpgp test suite. Used to locate
data files.
**** GPGSCM_PATH
Used to locate the Scheme library as well as code used by the test
suite.
**** BIN_PREFIX
The test suite does not hardcode any paths to tools. If set it is
used to locate the tools to test, otherwise the test suite assumes to
be run from the build directory.
**** MKTDATA and GPG_PRESET_PASSPHRASE
These two tools are not installed by 'make install', hence we need to
explicitly override their position. In fact, the location of any tool
used by the test suite can be overridden this way. See defs.scm.
**** argv[0]
run-tests.scm depends on being able to re-exec gpgscm. It uses
argv[0] for that. Therefore you must use an absolute path to invoke
gpgscm.
* How to write tests
gpgscm provides a number of functions to aid you in writing tests, as
well as bindings to process management abstractions provided by GnuPG.
For the Scheme environment provided by TinySCHEME, see the TinySCHEME
manual that is included in tests/gpgscm/Manual.txt.
For a quick start, please have a look at various tests that are
already implemented, e.g. 'encrypt.scm'.
** The test framework
The functions info, error, and skip display their first argument and
flush the output buffers. error and skip will also terminate the
process, signaling that the test failed or should be skipped.
(for-each-p msg proc list) will display msg, and call proc with each
element of list while displaying the progress appropriately.
for-each-p' is similar, but accepts another callback before the 'list'
argument to format each item. for-each-p can be safely nested, and
the inner progress indicator will be abbreviated using '.'.
** Debugging tests
Say you are working on a new test called 'your-test.scm', you can run
it on its own using
- obj $ make -C tests/openpgp check XTESTS=your-test.scm
+ obj $ make -C tests/openpgp check TESTS=your-test.scm
but something isn't working as expected. There are several little
gadgets that might help. The first one is 'trace', a function that
prints the value given to it and evaluates to it. E.g.
(trace (+ 2 3))
prints '5' and evaluates to 5. Also, there is an 'assert' macro that
aborts the execution if its argument does not evaluate to a trueish
value. Feel free to express invariants with it.
You can also get an interactive repl by dropping
(interactive-repl (current-environment))
anywhere you like. Or, if you want to examine the environment from an
operating system shell, use
(interactive-shell)
** Interfacing with gpg
defs.scm defines several convenience functions. Say you want to parse
the colon output from gpg, there is gpg-with-colons that splits the
result at newlines and colons, so you can use the result like this:
(define (fpr some-key)
(list-ref (assoc "fpr" (gpg-with-colons
`(--with-fingerprint
--list-secret-keys ,some-key)))
9))
Or if you want to count all non-revoked uids for a given key, do
(define (count-uids-of-secret-key some-key)
(length (filter (lambda (x) (and (string=? "uid" (car x))
(string=? "u" (cadr x))))
(gpg-with-colons
`(--with-fingerprint
--list-secret-keys ,some-key)))))
** Temporary files
(lettmp ) will create and delete temporary files that
you can use in . (with-temporary-working-directory ) will
create a temporary director, change to that, and clean it up after
executing ).
make-temporary-file will create a temporary file. You can optionally
provide an argument to that function that will serve as tag so you can
distinguish the files for debugging. remove-temporary-file will
delete a file created using make-temporary-file.
** Monadic transformer and pipe support
Tests often perform sequential transformations on files, or connect
processes using pipes. To aid you in this, the test framework
provides two monadic data structures.
(Currently, the implementation mashes the 'bind' operation together
with the application of the monad. Also, there is no 'return'
operation. I guess all of that could be implemented on top of
call/cc, but it isn't at the moment.)
*** pipe
The pipe monad constructs pipe lines. It consists of a function
pipe:do that binds the functions together and manages the execution of
the child processes, a family of functions that act as sources, a
function to spawn processes, and a family of functions acting as
sinks.
Sources are pipe:open, pipe:defer, pipe:echo. To spawn a process use
pipe:spawn, or the convenience function pipe:gpg. To sink the data
use pipe:splice, or pipe:write-to.
Example:
(pipe:do
(pipe:echo "3\n1\n2\n")
(pipe:spawn '("/usr/bin/sort"))
(pipe:write-to "sorted" (logior O_WRONLY O_CREAT) #o600))
Caveats: Due to the single-threaded nature of gpgscm you cannot use
both a source and sink that is implemented in Scheme. pipe:defer and
pipe:echo are executing in gpgscm, and so does pipe:splice.
*** tr
The transformer monad describes sequential file transformations.
There is one source function, tr:open. To describe a transformation
using some process, use tr:spawn, tr:gpg, or tr:pipe-do. There are
several sinks, although sink is not quite the right term, because the
data is not consumed, and hence one can use them at any position. The
"sinks" are tr:write-to, tr:call-with-content, tr:assert-identity, and
tr:assert-weak-identity.
A somewhat contrived example demonstrating many functions is:
(tr:do
(tr:pipe-do
(pipe:echo "3\n1\n2\n")
(pipe:spawn '("/usr/bin/sort")))
(tr:write-to "reference")
(tr:call-with-content
(lambda (c)
(echo "currently, c contains" (string-length c) "bytes")))
(tr:spawn "" '("/usr/bin/gcc" -x c "-E" -o **out** **in**))
(tr:pipe-do
(pipe:spawn '("/bin/grep" -v "#")))
(tr:assert-identity "reference"))
Caveats: As a convenience, gpgscm allows one to specify command line
arguments as Scheme symbols. Scheme symbols, however, are
case-insensitive, and get converted to lower case. Therefore, the -E
argument must be given as a string in the example above. Similarly,
you need to quote numerical values.
** Process management
If you just need to execute a single command, there is (call-with-fds
cmdline infd outfd errfd) which executes cmdline with the given file
descriptors bound to it, and waits for its completion returning the
status code. There is (call cmdline) which is similar, but calls the
command with a closed stdin, connecting stdout and stderr to stderr if
gpgscm is executed with --verbose. (call-check cmdline) raises an
exception if the command does not return 0.
(call-popen cmdline input) calls a command, writes input to its stdin,
and returns any output from stdout, or raises an exception containing
stderr on failure.
* Sample messages
diff --git a/tests/openpgp/all-tests.scm b/tests/openpgp/all-tests.scm
new file mode 100644
index 000000000..4b14c4e04
--- /dev/null
+++ b/tests/openpgp/all-tests.scm
@@ -0,0 +1,43 @@
+;; 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 .
+
+(export all-tests
+ ;; Parse the Makefile.am to find all tests.
+
+ (load (with-path "makefile.scm"))
+
+ (define (expander filename port key)
+ (parse-makefile port key))
+
+ (define (parse filename key)
+ (parse-makefile-expand filename expander key))
+
+ (define setup
+ (make-environment-cache
+ (test::scm
+ #f
+ (path-join "tests" "openpgp" "setup.scm")
+ (in-srcdir "tests" "openpgp" "setup.scm")
+ "--" "tests" "gpg")))
+
+ (map (lambda (name)
+ (test::scm setup
+ (path-join "tests" "openpgp" name)
+ (in-srcdir "tests" "openpgp" name)))
+ (parse-makefile-expand (in-srcdir "tests" "openpgp" "Makefile.am")
+ (lambda (filename port key) (parse-makefile port key))
+ "XTESTS")))
diff --git a/tests/openpgp/run-tests.scm b/tests/openpgp/run-tests.scm
index d443d1fb8..d4914bda7 100644
--- a/tests/openpgp/run-tests.scm
+++ b/tests/openpgp/run-tests.scm
@@ -1,41 +1,42 @@
;; Test-suite runner.
;;
;; 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 .
(if (string=? "" (getenv "abs_top_srcdir"))
(begin
(echo "Environment variable 'abs_top_srcdir' not set. Please point it to"
"tests/openpgp.")
(exit 2)))
;; Set objdir so that the tests can locate built programs.
(setenv "objdir" (getcwd) #f)
-(let* ((tests (filter (lambda (arg) (not (string-prefix? arg "--"))) *args*))
- (setup (make-environment-cache (test::scm
- #f
- (path-join "tests" "openpgp" "setup.scm")
- (in-srcdir "tests" "openpgp" "setup.scm"))))
- (runner (if (and (member "--parallel" *args*)
- (> (length tests) 1))
- run-tests-parallel
- run-tests-sequential)))
- (runner (map (lambda (name)
- (test::scm setup
- (path-join "tests" "openpgp" name)
- (in-srcdir "tests" "openpgp" name))) tests)))
+(define setup
+ (make-environment-cache (test::scm
+ #f
+ (path-join "tests" "openpgp" "setup.scm")
+ (in-srcdir "tests" "openpgp" "setup.scm"))))
+
+(define tests (filter (lambda (arg) (not (string-prefix? arg "--"))) *args*))
+
+(run-tests (if (null? tests)
+ (load-tests "tests" "openpgp")
+ (map (lambda (name)
+ (test::scm setup
+ (path-join "tests" "openpgp" name)
+ (in-srcdir "tests" "openpgp" name))) tests)))
diff --git a/tests/run-tests.scm b/tests/run-tests.scm
new file mode 100644
index 000000000..d3ebba07e
--- /dev/null
+++ b/tests/run-tests.scm
@@ -0,0 +1,44 @@
+#!/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 .
+
+(info "Running all tests...")
+
+(define (load-tests-with-log . path)
+ (map (lambda (test)
+ (test:::set! 'log-file-name
+ (apply path-join `(,@path
+ ,(string-append (basename test::name)
+ ".log")))))
+ (apply load-tests path)))
+
+(let ((prefix (flag "--prefix" *args*))
+ (all-tests (append
+ (load-tests-with-log "common")
+ (load-tests-with-log "g10")
+ (load-tests-with-log "g13")
+ (load-tests-with-log "agent")
+ (load-tests-with-log "tests" "openpgp")
+ (load-tests-with-log "tests" "migrations")
+ (load-tests-with-log "tests" "gpgsm")
+ (load-tests-with-log "tests" "gpgme"))))
+ (run-tests (if prefix
+ (filter
+ (lambda (t) (string-prefix? t::name (apply path-join prefix)))
+ all-tests)
+ all-tests)))