diff options
Diffstat (limited to 'tests')
135 files changed, 14904 insertions, 472 deletions
diff --git a/tests/Makefile.am b/tests/Makefile.am index 307d82952..f349763a6 100644 --- a/tests/Makefile.am +++ b/tests/Makefile.am @@ -25,7 +25,7 @@ else openpgp = endif -SUBDIRS = ${openpgp} . pkits +SUBDIRS = gpgscm ${openpgp} . migrations pkits GPGSM = ../sm/gpgsm @@ -48,12 +48,12 @@ EXTRA_DIST = runtest inittests $(testscripts) ChangeLog-2011 \ samplekeys/cert_g10code_test1.pem \ samplekeys/cert_g10code_theo1.pem -# We used to run $(testscripts) here but these asschk scripts ares not -# completely reliable in all enviromnets and thus we better disable -# them. The tests are anyway way to minimal. We will eventually +# We used to run $(testscripts) here but these asschk scripts are not +# completely reliable in all enviroments 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 the low--level asschk stuff. +# use that low-level asschk stuff. TESTS = CLEANFILES = inittests.stamp x y y z out err \ diff --git a/tests/gpgscm/LICENSE.TinySCHEME b/tests/gpgscm/LICENSE.TinySCHEME new file mode 100644 index 000000000..23a7e85a5 --- /dev/null +++ b/tests/gpgscm/LICENSE.TinySCHEME @@ -0,0 +1,31 @@ + LICENSE TERMS + +Copyright (c) 2000, Dimitrios Souflis +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in the +documentation and/or other materials provided with the distribution. + +Neither the name of Dimitrios Souflis nor the names of the +contributors may be used to endorse or promote products derived from +this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR +CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/tests/gpgscm/Makefile.am b/tests/gpgscm/Makefile.am new file mode 100644 index 000000000..e57a4bbe4 --- /dev/null +++ b/tests/gpgscm/Makefile.am @@ -0,0 +1,59 @@ +# TinyScheme-based test driver. +# +# Copyright (C) 2016 g10 Code GmbH +# +# This file is part of GnuPG. +# +# GnuPG is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# GnuPG is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, see <http://www.gnu.org/licenses/>. + +EXTRA_DIST = \ + LICENSE.TinySCHEME \ + Manual.txt \ + ffi.scm \ + init.scm \ + lib.scm \ + repl.scm \ + t-child.scm \ + tests.scm + +AM_CPPFLAGS = -I$(top_srcdir)/common +include $(top_srcdir)/am/cmacros.am + +AM_CFLAGS = + +CLEANFILES = + +bin_PROGRAMS = gpgscm +noinst_PROGRAMS = t-child + +common_libs = ../$(libcommon) +commonpth_libs = ../$(libcommonpth) + +gpgscm_CFLAGS = -imacros scheme-config.h \ + $(LIBGCRYPT_CFLAGS) $(LIBASSUAN_CFLAGS) $(GPG_ERROR_CFLAGS) +gpgscm_SOURCES = main.c private.h ffi.c ffi.h ffi-private.h \ + scheme-config.h opdefines.h scheme.c scheme.h scheme-private.h +gpgscm_LDADD = $(LDADD) $(common_libs) \ + $(NETLIBS) $(LIBICONV) $(LIBREADLINE) \ + $(LIBGCRYPT_LIBS) $(GPG_ERROR_LIBS) + +t_child_SOURCES = t-child.c + +# Make sure that all libs are build before we use them. This is +# important for things like make -j2. +$(PROGRAMS): $(common_libs) + +check-local: gpgscm$(EXEEXT) t-child$(EXEEXT) + EXEEXT=$(EXEEXT) GPGSCM_PATH=$(srcdir) \ + ./gpgscm$(EXEEXT) $(srcdir)/t-child.scm diff --git a/tests/gpgscm/Manual.txt b/tests/gpgscm/Manual.txt new file mode 100644 index 000000000..9fd294fc0 --- /dev/null +++ b/tests/gpgscm/Manual.txt @@ -0,0 +1,444 @@ + + + TinySCHEME Version 1.41 + + "Safe if used as prescribed" + -- Philip K. Dick, "Ubik" + +This software is open source, covered by a BSD-style license. +Please read accompanying file COPYING. +------------------------------------------------------------------------------- + + This Scheme interpreter is based on MiniSCHEME version 0.85k4 + (see miniscm.tar.gz in the Scheme Repository) + Original credits in file MiniSCHEMETribute.txt. + + D. Souflis ([email protected]) + +------------------------------------------------------------------------------- + What is TinyScheme? + ------------------- + + TinyScheme is a lightweight Scheme interpreter that implements as large + a subset of R5RS as was possible without getting very large and + complicated. It is meant to be used as an embedded scripting interpreter + for other programs. As such, it does not offer IDEs or extensive toolkits + although it does sport a small top-level loop, included conditionally. + A lot of functionality in TinyScheme is included conditionally, to allow + developers freedom in balancing features and footprint. + + As an embedded interpreter, it allows multiple interpreter states to + coexist in the same program, without any interference between them. + Programmatically, foreign functions in C can be added and values + can be defined in the Scheme environment. Being a quite small program, + it is easy to comprehend, get to grips with, and use. + + Known bugs + ---------- + + TinyScheme is known to misbehave when memory is exhausted. + + + Things that keep missing, or that need fixing + --------------------------------------------- + + There are no hygienic macros. No rational or + complex numbers. No unwind-protect and call-with-values. + + Maybe (a subset of) SLIB will work with TinySCHEME... + + Decent debugging facilities are missing. Only tracing is supported + natively. + + + Scheme Reference + ---------------- + + If something seems to be missing, please refer to the code and + "init.scm", since some are library functions. Refer to the MiniSCHEME + readme as a last resort. + + Environments + (interaction-environment) + See R5RS. In TinySCHEME, immutable list of association lists. + + (current-environment) + The environment in effect at the time of the call. An example of its + use and its utility can be found in the sample code that implements + packages in "init.scm": + + (macro (package form) + `(apply (lambda () + ,@(cdr form) + (current-environment)))) + + The environment containing the (local) definitions inside the closure + is returned as an immutable value. + + (defined? <symbol>) (defined? <symbol> <environment>) + Checks whether the given symbol is defined in the current (or given) + environment. + + Symbols + (gensym) + Returns a new interned symbol each time. Will probably move to the + library when string->symbol is implemented. + + Directives + (gc) + Performs garbage collection immediatelly. + + (gc-verbose) (gc-verbose <bool>) + The argument (defaulting to #t) controls whether GC produces + visible outcome. + + (quit) (quit <num>) + Stops the interpreter and sets the 'retcode' internal field (defaults + to 0). When standalone, 'retcode' is returned as exit code to the OS. + + (tracing <num>) + 1, turns on tracing. 0 turns it off. (Only when USE_TRACING is 1). + + Mathematical functions + Since rationals and complexes are absent, the respective functions + are also missing. + Supported: exp, log, sin, cos, tan, asin, acos, atan, floor, ceiling, + trunc, round and also sqrt and expt when USE_MATH=1. + Number-theoretical quotient, remainder and modulo, gcd, lcm. + Library: exact?, inexact?, odd?, even?, zero?, positive?, negative?, + exact->inexact. inexact->exact is a core function. + + Type predicates + boolean?,eof-object?,symbol?,number?,string?,integer?,real?,list?,null?, + char?,port?,input-port?,output-port?,procedure?,pair?,environment?', + vector?. Also closure?, macro?. + + Types + Types supported: + + Numbers (integers and reals) + Symbols + Pairs + Strings + Characters + Ports + Eof object + Environments + Vectors + + Literals + String literals can contain escaped quotes \" as usual, but also + \n, \r, \t, \xDD (hex representations) and \DDD (octal representations). + Note also that it is possible to include literal newlines in string + literals, e.g. + + (define s "String with newline here + and here + that can function like a HERE-string") + + Character literals contain #\space and #\newline and are supplemented + with #\return and #\tab, with obvious meanings. Hex character + representations are allowed (e.g. #\x20 is #\space). + When USE_ASCII_NAMES is defined, various control characters can be + referred to by their ASCII name. + 0 #\nul 17 #\dc1 + 1 #\soh 18 #\dc2 + 2 #\stx 19 #\dc3 + 3 #\etx 20 #\dc4 + 4 #\eot 21 #\nak + 5 #\enq 22 #\syn + 6 #\ack 23 #\etv + 7 #\bel 24 #\can + 8 #\bs 25 #\em + 9 #\ht 26 #\sub + 10 #\lf 27 #\esc + 11 #\vt 28 #\fs + 12 #\ff 29 #\gs + 13 #\cr 30 #\rs + 14 #\so 31 #\us + 15 #\si + 16 #\dle 127 #\del + + Numeric literals support #x #o #b and #d. Flonums are currently read only + in decimal notation. Full grammar will be supported soon. + + Quote, quasiquote etc. + As usual. + + Immutable values + Immutable pairs cannot be modified by set-car! and set-cdr!. + Immutable strings cannot be modified via string-set! + + I/O + As per R5RS, plus String Ports (see below). + current-input-port, current-output-port, + close-input-port, close-output-port, input-port?, output-port?, + open-input-file, open-output-file. + read, write, display, newline, write-char, read-char, peek-char. + char-ready? returns #t only for string ports, because there is no + portable way in stdio to determine if a character is available. + Also open-input-output-file, set-input-port, set-output-port (not R5RS) + Library: call-with-input-file, call-with-output-file, + with-input-from-file, with-output-from-file and + with-input-output-from-to-files, close-port and input-output-port? + (not R5RS). + String Ports: open-input-string, open-output-string, get-output-string, + open-input-output-string. Strings can be used with I/O routines. + + Vectors + make-vector, vector, vector-length, vector-ref, vector-set!, list->vector, + vector-fill!, vector->list, vector-equal? (auxiliary function, not R5RS) + + Strings + string, make-string, list->string, string-length, string-ref, string-set!, + substring, string->list, string-fill!, string-append, string-copy. + string=?, string<?, string>?, string>?, string<=?, string>=?. + (No string-ci*? yet). string->number, number->string. Also atom->string, + string->atom (not R5RS). + + Symbols + symbol->string, string->symbol + + Characters + integer->char, char->integer. + char=?, char<?, char>?, char<=?, char>=?. + (No char-ci*?) + + Pairs & Lists + cons, car, cdr, list, length, map, for-each, foldr, list-tail, + list-ref, last-pair, reverse, append. + Also member, memq, memv, based on generic-member, assoc, assq, assv + based on generic-assoc. + + Streams + head, tail, cons-stream + + Control features + Apart from procedure?, also macro? and closure? + map, for-each, force, delay, call-with-current-continuation (or call/cc), + eval, apply. 'Forcing' a value that is not a promise produces the value. + There is no call-with-values, values, nor dynamic-wind. Dynamic-wind in + the presence of continuations would require support from the abstract + machine itself. + + Property lists + TinyScheme inherited from MiniScheme property lists for symbols. + put, get. + + Dynamically-loaded extensions + (load-extension <filename without extension>) + Loads a DLL declaring foreign procedures. On Unix/Linux, one can make use + of the ld.so.conf file or the LD_RUN_PATH system variable in order to place + the library in a directory other than the current one. Please refer to the + appropriate 'man' page. + + Esoteric procedures + (oblist) + Returns the oblist, an immutable list of all the symbols. + + (macro-expand <form>) + Returns the expanded form of the macro call denoted by the argument + + (define-with-return (<procname> <args>...) <body>) + Like plain 'define', but makes the continuation available as 'return' + inside the procedure. Handy for imperative programs. + + (new-segment <num>) + Allocates more memory segments. + + defined? + See "Environments" + + (get-closure-code <closure>) + Gets the code as scheme data. + + (make-closure <code> <environment>) + Makes a new closure in the given environment. + + Obsolete procedures + (print-width <object>) + + Programmer's Reference + ---------------------- + + The interpreter state is initialized with "scheme_init". + Custom memory allocation routines can be installed with an alternate + initialization function: "scheme_init_custom_alloc". + Files can be loaded with "scheme_load_file". Strings containing Scheme + code can be loaded with "scheme_load_string". It is a good idea to + "scheme_load" init.scm before anything else. + + External data for keeping external state (of use to foreign functions) + can be installed with "scheme_set_external_data". + Foreign functions are installed with "assign_foreign". Additional + definitions can be added to the interpreter state, with "scheme_define" + (this is the way HTTP header data and HTML form data are passed to the + Scheme script in the Altera SQL Server). If you wish to define the + foreign function in a specific environment (to enhance modularity), + use "assign_foreign_env". + + The procedure "scheme_apply0" has been added with persistent scripts in + mind. Persistent scripts are loaded once, and every time they are needed + to produce HTTP output, appropriate data are passed through global + definitions and function "main" is called to do the job. One could + add easily "scheme_apply1" etc. + + The interpreter state should be deinitialized with "scheme_deinit". + + DLLs containing foreign functions should define a function named + init_<base-name>. E.g. foo.dll should define init_foo, and bar.so + should define init_bar. This function should assign_foreign any foreign + function contained in the DLL. + + The first dynamically loaded extension available for TinyScheme is + a regular expression library. Although it's by no means an + established standard, this library is supposed to be installed in + a directory mirroring its name under the TinyScheme location. + + + Foreign Functions + ----------------- + + The user can add foreign functions in C. For example, a function + that squares its argument: + + pointer square(scheme *sc, pointer args) { + if(args!=sc->NIL) { + if(sc->isnumber(sc->pair_car(args))) { + double v=sc->rvalue(sc->pair_car(args)); + return sc->mk_real(sc,v*v); + } + } + return sc->NIL; + } + + Foreign functions are now defined as closures: + + sc->interface->scheme_define( + sc, + sc->global_env, + sc->interface->mk_symbol(sc,"square"), + sc->interface->mk_foreign_func(sc, square)); + + + Foreign functions can use the external data in the "scheme" struct + to implement any kind of external state. + + External data are set with the following function: + void scheme_set_external_data(scheme *sc, void *p); + + As of v.1.17, the canonical way for a foreign function in a DLL to + manipulate Scheme data is using the function pointers in sc->interface. + + Standalone + ---------- + + Usage: tinyscheme -? + or: tinyscheme [<file1> <file2> ...] + followed by + -1 <file> [<arg1> <arg2> ...] + -c <Scheme commands> [<arg1> <arg2> ...] + assuming that the executable is named tinyscheme. + + Use - in the place of a filename to denote stdin. + The -1 flag is meant for #! usage in shell scripts. If you specify + #! /somewhere/tinyscheme -1 + then tinyscheme will be called to process the file. For example, the + following script echoes the Scheme list of its arguments. + + #! /somewhere/tinyscheme -1 + (display *args*) + + The -c flag permits execution of arbitrary Scheme code. + + + Error Handling + -------------- + + Errors are recovered from without damage. The user can install his + own handler for system errors, by defining *error-hook*. Defining + to '() gives the default behavior, which is equivalent to "error". + USE_ERROR_HOOK must be defined. + + A simple exception handling mechanism can be found in "init.scm". + A new syntactic form is introduced: + + (catch <expr returned exceptionally> + <expr1> <expr2> ... <exprN>) + + "Catch" establishes a scope spanning multiple call-frames + until another "catch" is encountered. + + Exceptions are thrown with: + + (throw "message") + + If used outside a (catch ...), reverts to (error "message"). + + Example of use: + + (define (foo x) (write x) (newline) (/ x 0)) + + (catch (begin (display "Error!\n") 0) + (write "Before foo ... ") + (foo 5) + (write "After foo")) + + The exception mechanism can be used even by system errors, by + + (define *error-hook* throw) + + which makes use of the error hook described above. + + If necessary, the user can devise his own exception mechanism with + tagged exceptions etc. + + + Reader extensions + ----------------- + + When encountering an unknown character after '#', the user-specified + procedure *sharp-hook* (if any), is called to read the expression. + This can be used to extend the reader to handle user-defined constants + or whatever. It should be a procedure without arguments, reading from + the current input port (which will be the load-port). + + + Colon Qualifiers - Packages + --------------------------- + + When USE_COLON_HOOK=1: + The lexer now recognizes the construction <qualifier>::<symbol> and + transforms it in the following manner (T is the transformation function): + + T(<qualifier>::<symbol>) = (*colon-hook* 'T(<symbol>) <qualifier>) + + where <qualifier> is a symbol not containing any double-colons. + + As the definition is recursive, qualifiers can be nested. + The user can define his own *colon-hook*, to handle qualified names. + By default, "init.scm" defines *colon-hook* as EVAL. Consequently, + the qualifier must denote a Scheme environment, such as one returned + by (interaction-environment). "Init.scm" defines a new syntantic form, + PACKAGE, as a simple example. It is used like this: + + (define toto + (package + (define foo 1) + (define bar +))) + + foo ==> Error, "foo" undefined + (eval 'foo) ==> Error, "foo" undefined + (eval 'foo toto) ==> 1 + toto::foo ==> 1 + ((eval 'bar toto) 2 (eval 'foo toto)) ==> 3 + (toto::bar 2 toto::foo) ==> 3 + (eval (bar 2 foo) toto) ==> 3 + + If the user installs another package infrastructure, he must define + a new 'package' procedure or macro to retain compatibility with supplied + code. + + Note: Older versions used ':' as a qualifier. Unfortunately, the use + of ':' as a pseudo-qualifier in existing code (i.e. SLIB) essentially + precludes its use as a real qualifier. diff --git a/tests/gpgscm/ffi-private.h b/tests/gpgscm/ffi-private.h new file mode 100644 index 000000000..87f491f9f --- /dev/null +++ b/tests/gpgscm/ffi-private.h @@ -0,0 +1,148 @@ +/* FFI interface for TinySCHEME. + * + * Copyright (C) 2016 g10 code GmbH + * + * This file is part of GnuPG. + * + * GnuPG is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 3 of the License, or + * (at your option) any later version. + * + * GnuPG is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, see <http://www.gnu.org/licenses/>. + */ + +#ifndef GPGSCM_FFI_PRIVATE_H +#define GPGSCM_FFI_PRIVATE_H + +#include <gpg-error.h> +#include "scheme.h" +#include "scheme-private.h" + +#define FFI_PROLOG() \ + unsigned int ffi_arg_index GPGRT_ATTR_UNUSED = 1; \ + int err GPGRT_ATTR_UNUSED = 0 \ + +int ffi_bool_value (scheme *sc, pointer p); + +#define CONVERSION_number(SC, X) (SC)->vptr->ivalue (X) +#define CONVERSION_string(SC, X) (SC)->vptr->string_value (X) +#define CONVERSION_character(SC, X) (SC)->vptr->charvalue (X) +#define CONVERSION_list(SC, X) (X) +#define CONVERSION_bool(SC, X) ffi_bool_value ((SC), (X)) +#define CONVERSION_path(SC, X) (((SC)->vptr->is_string (X) \ + ? (SC)->vptr->string_value \ + : (SC)->vptr->symname) (X)) + +#define IS_A_number(SC, X) (SC)->vptr->is_number (X) +#define IS_A_string(SC, X) (SC)->vptr->is_string (X) +#define IS_A_character(SC, X) (SC)->vptr->is_character (X) +#define IS_A_list(SC, X) (SC)->vptr->is_list ((SC), X) +#define IS_A_bool(SC, X) ((X) == (SC)->F || (X) == (SC)->T) +#define IS_A_path(SC, X) ((SC)->vptr->is_string (X) \ + || (SC)->vptr->is_symbol (X)) + +#define FFI_ARG_OR_RETURN(SC, CTYPE, TARGET, WANT, ARGS) \ + do { \ + if ((ARGS) == (SC)->NIL) \ + return (SC)->vptr->mk_string ((SC), \ + "too few arguments: want " \ + #TARGET "("#WANT"/"#CTYPE")\n"); \ + if (! IS_A_##WANT ((SC), pair_car (ARGS))) { \ + char ffi_error_message[256]; \ + snprintf (ffi_error_message, sizeof ffi_error_message, \ + "argument %d must be: " #WANT "\n", ffi_arg_index); \ + return (SC)->vptr->mk_string ((SC), ffi_error_message); \ + } \ + TARGET = CONVERSION_##WANT (SC, pair_car (ARGS)); \ + ARGS = pair_cdr (ARGS); \ + ffi_arg_index += 1; \ + } while (0) + +#define FFI_ARGS_DONE_OR_RETURN(SC, ARGS) \ + do { \ + if ((ARGS) != (SC)->NIL) \ + return (SC)->vptr->mk_string ((SC), "too many arguments"); \ + } while (0) + +#define FFI_RETURN_ERR(SC, ERR) \ + return _cons ((SC), mk_integer ((SC), (ERR)), (SC)->NIL, 1) + +#define FFI_RETURN(SC) FFI_RETURN_ERR (SC, err) + +#define FFI_RETURN_POINTER(SC, X) \ + return _cons ((SC), mk_integer ((SC), err), \ + _cons ((SC), (X), (SC)->NIL, 1), 1) +#define FFI_RETURN_INT(SC, X) \ + FFI_RETURN_POINTER ((SC), mk_integer ((SC), (X))) +#define FFI_RETURN_STRING(SC, X) \ + FFI_RETURN_POINTER ((SC), mk_string ((SC), (X))) + +char *ffi_schemify_name (const char *s, int macro); + +void ffi_scheme_eval (scheme *sc, const char *format, ...) + GPGRT_ATTR_PRINTF (2, 3); +pointer ffi_sprintf (scheme *sc, const char *format, ...) + GPGRT_ATTR_PRINTF (2, 3); + +#define ffi_define_function_name(SC, NAME, F) \ + do { \ + char *_fname = ffi_schemify_name ("_" #F, 0); \ + scheme_define ((SC), \ + (SC)->global_env, \ + mk_symbol ((SC), _fname), \ + mk_foreign_func ((SC), (do_##F))); \ + ffi_scheme_eval ((SC), \ + "(define (%s . a) (ffi-apply \"%s\" %s a))", \ + (NAME), (NAME), _fname); \ + free (_fname); \ + } while (0) + +#define ffi_define_function(SC, F) \ + do { \ + char *_name = ffi_schemify_name (#F, 0); \ + ffi_define_function_name ((SC), _name, F); \ + free (_name); \ + } while (0) + +#define ffi_define_constant(SC, C) \ + do { \ + char *_name = ffi_schemify_name (#C, 1); \ + scheme_define ((SC), \ + (SC)->global_env, \ + mk_symbol ((SC), _name), \ + mk_integer ((SC), (C))); \ + free (_name); \ + } while (0) + +#define ffi_define(SC, SYM, EXP) \ + scheme_define ((SC), (SC)->global_env, mk_symbol ((SC), (SYM)), EXP) + +#define ffi_define_variable_pointer(SC, C, P) \ + do { \ + char *_name = ffi_schemify_name (#C, 0); \ + scheme_define ((SC), \ + (SC)->global_env, \ + mk_symbol ((SC), _name), \ + (P)); \ + free (_name); \ + } while (0) + +#define ffi_define_variable_integer(SC, C) \ + ffi_define_variable_pointer ((SC), C, (SC)->vptr->mk_integer ((SC), C)) + +#define ffi_define_variable_string(SC, C) \ + ffi_define_variable_pointer ((SC), C, (SC)->vptr->mk_string ((SC), C ?: "")) + +gpg_error_t ffi_list2argv (scheme *sc, pointer list, + char ***argv, size_t *len); +gpg_error_t ffi_list2intv (scheme *sc, pointer list, + int **intv, size_t *len); + +#endif /* GPGSCM_FFI_PRIVATE_H */ diff --git a/tests/gpgscm/ffi.c b/tests/gpgscm/ffi.c new file mode 100644 index 000000000..21beb7609 --- /dev/null +++ b/tests/gpgscm/ffi.c @@ -0,0 +1,1283 @@ +/* FFI interface for TinySCHEME. + * + * Copyright (C) 2016 g10 code GmbH + * + * This file is part of GnuPG. + * + * GnuPG is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 3 of the License, or + * (at your option) any later version. + * + * GnuPG is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, see <http://www.gnu.org/licenses/>. + */ + +#include <config.h> + +#include <assert.h> +#include <ctype.h> +#include <dirent.h> +#include <errno.h> +#include <fcntl.h> +#include <glob.h> +#include <gpg-error.h> +#include <stdarg.h> +#include <stdlib.h> +#include <stdio.h> +#include <string.h> +#include <sys/types.h> +#include <sys/stat.h> +#include <unistd.h> + +#if HAVE_LIBREADLINE +#include <readline/readline.h> +#include <readline/history.h> +#endif + +#include "../../common/util.h" +#include "../../common/exechelp.h" +#include "../../common/sysutils.h" + +#include "private.h" +#include "ffi.h" +#include "ffi-private.h" + + + +int +ffi_bool_value (scheme *sc, pointer p) +{ + return ! (p == sc->F); +} + + + +static pointer +do_logand (scheme *sc, pointer args) +{ + FFI_PROLOG (); + unsigned int v, acc = ~0; + while (args != sc->NIL) + { + FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args); + acc &= v; + } + FFI_RETURN_INT (sc, acc); +} + +static pointer +do_logior (scheme *sc, pointer args) +{ + FFI_PROLOG (); + unsigned int v, acc = 0; + while (args != sc->NIL) + { + FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args); + acc |= v; + } + FFI_RETURN_INT (sc, acc); +} + +static pointer +do_logxor (scheme *sc, pointer args) +{ + FFI_PROLOG (); + unsigned int v, acc = 0; + while (args != sc->NIL) + { + FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args); + acc ^= v; + } + FFI_RETURN_INT (sc, acc); +} + +static pointer +do_lognot (scheme *sc, pointer args) +{ + FFI_PROLOG (); + unsigned int v; + FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + FFI_RETURN_INT (sc, ~v); +} + +/* User interface. */ + +static pointer +do_flush_stdio (scheme *sc, pointer args) +{ + FFI_PROLOG (); + FFI_ARGS_DONE_OR_RETURN (sc, args); + fflush (stdout); + fflush (stderr); + FFI_RETURN (sc); +} + + +int use_libreadline; + +/* Read a string, and return a pointer to it. Returns NULL on EOF. */ +char * +rl_gets (const char *prompt) +{ + static char *line = NULL; + char *p; + xfree (line); + +#if HAVE_LIBREADLINE + { + line = readline (prompt); + if (line && *line) + add_history (line); + } +#else + { + size_t max_size = 0xff; + printf ("%s", prompt); + fflush (stdout); + line = xtrymalloc (max_size); + if (line != NULL) + fgets (line, max_size, stdin); + } +#endif + + /* Strip trailing whitespace. */ + if (line && strlen (line) > 0) + for (p = &line[strlen (line) - 1]; isspace (*p); p--) + *p = 0; + + return line; +} + +static pointer +do_prompt (scheme *sc, pointer args) +{ + FFI_PROLOG (); + const char *prompt; + const char *line; + FFI_ARG_OR_RETURN (sc, const char *, prompt, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + line = rl_gets (prompt); + if (! line) + FFI_RETURN_POINTER (sc, sc->EOF_OBJ); + + FFI_RETURN_STRING (sc, line); +} + +static pointer +do_sleep (scheme *sc, pointer args) +{ + FFI_PROLOG (); + unsigned int seconds; + FFI_ARG_OR_RETURN (sc, unsigned int, seconds, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + sleep (seconds); + FFI_RETURN (sc); +} + +static pointer +do_usleep (scheme *sc, pointer args) +{ + FFI_PROLOG (); + useconds_t microseconds; + FFI_ARG_OR_RETURN (sc, useconds_t, microseconds, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + usleep (microseconds); + FFI_RETURN (sc); +} + +static pointer +do_chdir (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *name; + FFI_ARG_OR_RETURN (sc, char *, name, path, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + if (chdir (name)) + FFI_RETURN_ERR (sc, errno); + FFI_RETURN (sc); +} + +static pointer +do_strerror (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int error; + FFI_ARG_OR_RETURN (sc, int, error, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + FFI_RETURN_STRING (sc, gpg_strerror (error)); +} + +static pointer +do_getenv (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *name; + char *value; + FFI_ARG_OR_RETURN (sc, char *, name, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + value = getenv (name); + FFI_RETURN_STRING (sc, value ? value : ""); +} + +static pointer +do_setenv (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *name; + char *value; + int overwrite; + FFI_ARG_OR_RETURN (sc, char *, name, string, args); + FFI_ARG_OR_RETURN (sc, char *, value, string, args); + FFI_ARG_OR_RETURN (sc, int, overwrite, bool, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + FFI_RETURN_ERR (sc, gnupg_setenv (name, value, overwrite)); +} + +static pointer +do_exit (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int retcode; + FFI_ARG_OR_RETURN (sc, int, retcode, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + exit (retcode); +} + +/* XXX: use gnupgs variant b/c mode as string */ +static pointer +do_open (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int fd; + char *pathname; + int flags; + mode_t mode = 0; + FFI_ARG_OR_RETURN (sc, char *, pathname, path, args); + FFI_ARG_OR_RETURN (sc, int, flags, number, args); + if (args != sc->NIL) + FFI_ARG_OR_RETURN (sc, mode_t, mode, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + fd = open (pathname, flags, mode); + if (fd == -1) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + FFI_RETURN_INT (sc, fd); +} + +static pointer +do_fdopen (scheme *sc, pointer args) +{ + FFI_PROLOG (); + FILE *stream; + int fd; + char *mode; + int kind; + FFI_ARG_OR_RETURN (sc, int, fd, number, args); + FFI_ARG_OR_RETURN (sc, char *, mode, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + stream = fdopen (fd, mode); + if (stream == NULL) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + + if (setvbuf (stream, NULL, _IONBF, 0) != 0) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + + kind = 0; + if (strchr (mode, 'r')) + kind |= port_input; + if (strchr (mode, 'w')) + kind |= port_output; + + FFI_RETURN_POINTER (sc, sc->vptr->mk_port_from_file (sc, stream, kind)); +} + +static pointer +do_close (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int fd; + FFI_ARG_OR_RETURN (sc, int, fd, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + FFI_RETURN_ERR (sc, close (fd) == 0 ? 0 : gpg_error_from_syserror ()); +} + +static pointer +do_mkdtemp (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *template; + char buffer[128]; + char *name; + FFI_ARG_OR_RETURN (sc, char *, template, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + if (strlen (template) > sizeof buffer - 1) + FFI_RETURN_ERR (sc, EINVAL); + strncpy (buffer, template, sizeof buffer); + + name = gnupg_mkdtemp (buffer); + if (name == NULL) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + FFI_RETURN_STRING (sc, name); +} + +static pointer +do_unlink (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *name; + FFI_ARG_OR_RETURN (sc, char *, name, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + if (unlink (name) == -1) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + FFI_RETURN (sc); +} + +static gpg_error_t +unlink_recursively (const char *name) +{ + gpg_error_t err = 0; + struct stat st; + + if (stat (name, &st) == -1) + return gpg_error_from_syserror (); + + if (S_ISDIR (st.st_mode)) + { + DIR *dir; + struct dirent *dent; + + dir = opendir (name); + if (dir == NULL) + return gpg_error_from_syserror (); + + while ((dent = readdir (dir))) + { + char *child; + + if (strcmp (dent->d_name, ".") == 0 + || strcmp (dent->d_name, "..") == 0) + continue; + + child = xtryasprintf ("%s/%s", name, dent->d_name); + if (child == NULL) + { + err = gpg_error_from_syserror (); + goto leave; + } + + err = unlink_recursively (child); + xfree (child); + if (err == gpg_error_from_errno (ENOENT)) + err = 0; + if (err) + goto leave; + } + + leave: + closedir (dir); + if (! err) + rmdir (name); + return err; + } + else + if (unlink (name) == -1) + return gpg_error_from_syserror (); + return 0; +} + +static pointer +do_unlink_recursively (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *name; + FFI_ARG_OR_RETURN (sc, char *, name, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + err = unlink_recursively (name); + FFI_RETURN (sc); +} + +static pointer +do_rename (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *old; + char *new; + FFI_ARG_OR_RETURN (sc, char *, old, string, args); + FFI_ARG_OR_RETURN (sc, char *, new, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + if (rename (old, new) == -1) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + FFI_RETURN (sc); +} + +static pointer +do_getcwd (scheme *sc, pointer args) +{ + FFI_PROLOG (); + pointer result; + char *cwd; + FFI_ARGS_DONE_OR_RETURN (sc, args); + cwd = gnupg_getcwd (); + if (cwd == NULL) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + result = sc->vptr->mk_string (sc, cwd); + xfree (cwd); + FFI_RETURN_POINTER (sc, result); +} + +static pointer +do_mkdir (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *name; + char *mode; + FFI_ARG_OR_RETURN (sc, char *, name, string, args); + FFI_ARG_OR_RETURN (sc, char *, mode, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + if (gnupg_mkdir (name, mode) == -1) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + FFI_RETURN (sc); +} + +static pointer +do_rmdir (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *name; + FFI_ARG_OR_RETURN (sc, char *, name, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + if (rmdir (name) == -1) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + FFI_RETURN (sc); +} + + + +/* estream functions. */ + +struct es_object_box +{ + estream_t stream; + int closed; +}; + +static void +es_object_finalize (scheme *sc, void *data) +{ + struct es_object_box *box = data; + (void) sc; + + if (! box->closed) + es_fclose (box->stream); + xfree (box); +} + +static void +es_object_to_string (scheme *sc, char *out, size_t size, void *data) +{ + struct es_object_box *box = data; + (void) sc; + + snprintf (out, size, "#estream %p", box->stream); +} + +static struct foreign_object_vtable es_object_vtable = + { + es_object_finalize, + es_object_to_string, + }; + +static pointer +es_wrap (scheme *sc, estream_t stream) +{ + struct es_object_box *box = xmalloc (sizeof *box); + if (box == NULL) + return sc->NIL; + + box->stream = stream; + box->closed = 0; + return sc->vptr->mk_foreign_object (sc, &es_object_vtable, box); +} + +static struct es_object_box * +es_unwrap (scheme *sc, pointer object) +{ + (void) sc; + + if (! is_foreign_object (object)) + return NULL; + + if (sc->vptr->get_foreign_object_vtable (object) != &es_object_vtable) + return NULL; + + return sc->vptr->get_foreign_object_data (object); +} + +#define CONVERSION_estream(SC, X) es_unwrap (SC, X) +#define IS_A_estream(SC, X) es_unwrap (SC, X) + +static pointer +do_es_fclose (scheme *sc, pointer args) +{ + FFI_PROLOG (); + struct es_object_box *box; + FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + err = es_fclose (box->stream); + if (! err) + box->closed = 1; + FFI_RETURN (sc); +} + +static pointer +do_es_read (scheme *sc, pointer args) +{ + FFI_PROLOG (); + struct es_object_box *box; + size_t bytes_to_read; + + pointer result; + void *buffer; + size_t bytes_read; + + FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args); + FFI_ARG_OR_RETURN (sc, size_t, bytes_to_read, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + buffer = xtrymalloc (bytes_to_read); + if (buffer == NULL) + FFI_RETURN_ERR (sc, ENOMEM); + + err = es_read (box->stream, buffer, bytes_to_read, &bytes_read); + if (err) + FFI_RETURN_ERR (sc, err); + + result = sc->vptr->mk_counted_string (sc, buffer, bytes_read); + xfree (buffer); + FFI_RETURN_POINTER (sc, result); +} + +static pointer +do_es_feof (scheme *sc, pointer args) +{ + FFI_PROLOG (); + struct es_object_box *box; + FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + FFI_RETURN_POINTER (sc, es_feof (box->stream) ? sc->T : sc->F); +} + +static pointer +do_es_write (scheme *sc, pointer args) +{ + FFI_PROLOG (); + struct es_object_box *box; + const char *buffer; + size_t bytes_to_write, bytes_written; + + FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args); + /* XXX how to get the length of the string buffer? scheme strings + may contain \0. */ + FFI_ARG_OR_RETURN (sc, const char *, buffer, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + bytes_to_write = strlen (buffer); + while (bytes_to_write > 0) + { + err = es_write (box->stream, buffer, bytes_to_write, &bytes_written); + if (err) + break; + bytes_to_write -= bytes_written; + buffer += bytes_written; + } + + FFI_RETURN (sc); +} + + + +/* Process handling. */ + +static pointer +do_spawn_process (scheme *sc, pointer args) +{ + FFI_PROLOG (); + pointer arguments; + char **argv; + size_t len; + unsigned int flags; + + estream_t infp; + estream_t outfp; + estream_t errfp; + pid_t pid; + + FFI_ARG_OR_RETURN (sc, pointer, arguments, list, args); + FFI_ARG_OR_RETURN (sc, unsigned int, flags, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + err = ffi_list2argv (sc, arguments, &argv, &len); + if (err == gpg_error (GPG_ERR_INV_VALUE)) + return ffi_sprintf (sc, "%luth element of first argument is " + "neither string nor symbol", + (unsigned long) len); + if (err) + FFI_RETURN_ERR (sc, err); + + if (verbose > 1) + { + char **p; + fprintf (stderr, "Executing:"); + for (p = argv; *p; p++) + fprintf (stderr, " '%s'", *p); + fprintf (stderr, "\n"); + } + + err = gnupg_spawn_process (argv[0], (const char **) &argv[1], + GPG_ERR_SOURCE_DEFAULT, + NULL, + flags, + &infp, &outfp, &errfp, &pid); + xfree (argv); +#define IMC(A, B) \ + _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1) +#define IMS(A, B) \ + _cons (sc, es_wrap (sc, (A)), (B), 1) + FFI_RETURN_POINTER (sc, IMS (infp, + IMS (outfp, + IMS (errfp, + IMC (pid, sc->NIL))))); +#undef IMS +#undef IMC +} + +static pointer +do_spawn_process_fd (scheme *sc, pointer args) +{ + FFI_PROLOG (); + pointer arguments; + char **argv; + size_t len; + int infd, outfd, errfd; + + pid_t pid; + + FFI_ARG_OR_RETURN (sc, pointer, arguments, list, args); + FFI_ARG_OR_RETURN (sc, int, infd, number, args); + FFI_ARG_OR_RETURN (sc, int, outfd, number, args); + FFI_ARG_OR_RETURN (sc, int, errfd, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + err = ffi_list2argv (sc, arguments, &argv, &len); + if (err == gpg_error (GPG_ERR_INV_VALUE)) + return ffi_sprintf (sc, "%luth element of first argument is " + "neither string nor symbol", + (unsigned long) len); + if (err) + FFI_RETURN_ERR (sc, err); + + if (verbose > 1) + { + char **p; + fprintf (stderr, "Executing:"); + for (p = argv; *p; p++) + fprintf (stderr, " '%s'", *p); + fprintf (stderr, "\n"); + } + + err = gnupg_spawn_process_fd (argv[0], (const char **) &argv[1], + infd, outfd, errfd, &pid); + xfree (argv); + FFI_RETURN_INT (sc, pid); +} + +static pointer +do_wait_process (scheme *sc, pointer args) +{ + FFI_PROLOG (); + const char *name; + pid_t pid; + int hang; + + int retcode; + + FFI_ARG_OR_RETURN (sc, const char *, name, string, args); + FFI_ARG_OR_RETURN (sc, pid_t, pid, number, args); + FFI_ARG_OR_RETURN (sc, int, hang, bool, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + err = gnupg_wait_process (name, pid, hang, &retcode); + if (err == GPG_ERR_GENERAL) + err = 0; /* Let the return code speak for itself. */ + + FFI_RETURN_INT (sc, retcode); +} + + +static pointer +do_wait_processes (scheme *sc, pointer args) +{ + FFI_PROLOG (); + pointer list_names; + char **names; + pointer list_pids; + size_t i, count; + pid_t *pids; + int hang; + int *retcodes; + pointer retcodes_list = sc->NIL; + + FFI_ARG_OR_RETURN (sc, pointer, list_names, list, args); + FFI_ARG_OR_RETURN (sc, pointer, list_pids, list, args); + FFI_ARG_OR_RETURN (sc, int, hang, bool, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + if (sc->vptr->list_length (sc, list_names) + != sc->vptr->list_length (sc, list_pids)) + return + sc->vptr->mk_string (sc, "length of first two arguments must match"); + + err = ffi_list2argv (sc, list_names, &names, &count); + if (err == gpg_error (GPG_ERR_INV_VALUE)) + return ffi_sprintf (sc, "%luth element of first argument is " + "neither string nor symbol", + (unsigned long) count); + if (err) + FFI_RETURN_ERR (sc, err); + + err = ffi_list2intv (sc, list_pids, (int **) &pids, &count); + if (err == gpg_error (GPG_ERR_INV_VALUE)) + return ffi_sprintf (sc, "%luth element of second argument is " + "neither string nor symbol", + (unsigned long) count); + if (err) + FFI_RETURN_ERR (sc, err); + + retcodes = xtrycalloc (sizeof *retcodes, count); + if (retcodes == NULL) + { + xfree (names); + xfree (pids); + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + } + + err = gnupg_wait_processes ((const char **) names, pids, count, hang, + retcodes); + if (err == GPG_ERR_GENERAL) + err = 0; /* Let the return codes speak. */ + + for (i = 0; i < count; i++) + retcodes_list = + (sc->vptr->cons) (sc, + sc->vptr->mk_integer (sc, + (long) retcodes[count-1-i]), + retcodes_list); + + xfree (names); + xfree (pids); + xfree (retcodes); + FFI_RETURN_POINTER (sc, retcodes_list); +} + + +static pointer +do_pipe (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int filedes[2]; + FFI_ARGS_DONE_OR_RETURN (sc, args); + err = gnupg_create_pipe (filedes); +#define IMC(A, B) \ + _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1) + FFI_RETURN_POINTER (sc, IMC (filedes[0], + IMC (filedes[1], sc->NIL))); +#undef IMC +} + +static pointer +do_inbound_pipe (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int filedes[2]; + FFI_ARGS_DONE_OR_RETURN (sc, args); + err = gnupg_create_inbound_pipe (filedes, NULL, 0); +#define IMC(A, B) \ + _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1) + FFI_RETURN_POINTER (sc, IMC (filedes[0], + IMC (filedes[1], sc->NIL))); +#undef IMC +} + +static pointer +do_outbound_pipe (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int filedes[2]; + FFI_ARGS_DONE_OR_RETURN (sc, args); + err = gnupg_create_outbound_pipe (filedes, NULL, 0); +#define IMC(A, B) \ + _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1) + FFI_RETURN_POINTER (sc, IMC (filedes[0], + IMC (filedes[1], sc->NIL))); +#undef IMC +} + + + +/* Test helper functions. */ +static pointer +do_file_equal (scheme *sc, pointer args) +{ + FFI_PROLOG (); + pointer result = sc->F; + char *a_name, *b_name; + int binary; + const char *mode; + FILE *a_stream = NULL, *b_stream = NULL; + struct stat a_stat, b_stat; +#define BUFFER_SIZE 1024 + char a_buf[BUFFER_SIZE], b_buf[BUFFER_SIZE]; +#undef BUFFER_SIZE + size_t chunk; + + FFI_ARG_OR_RETURN (sc, char *, a_name, string, args); + FFI_ARG_OR_RETURN (sc, char *, b_name, string, args); + FFI_ARG_OR_RETURN (sc, int, binary, bool, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + mode = binary ? "rb" : "r"; + a_stream = fopen (a_name, mode); + if (a_stream == NULL) + goto errout; + + b_stream = fopen (b_name, mode); + if (b_stream == NULL) + goto errout; + + if (fstat (fileno (a_stream), &a_stat) < 0) + goto errout; + + if (fstat (fileno (b_stream), &b_stat) < 0) + goto errout; + + if (binary && a_stat.st_size != b_stat.st_size) + { + if (verbose) + fprintf (stderr, "Files %s and %s differ in size %lu != %lu\n", + a_name, b_name, (unsigned long) a_stat.st_size, + (unsigned long) b_stat.st_size); + + goto out; + } + + while (! feof (a_stream)) + { + chunk = sizeof a_buf; + + chunk = fread (a_buf, 1, chunk, a_stream); + if (chunk == 0 && ferror (a_stream)) + goto errout; /* some error */ + + if (fread (b_buf, 1, chunk, b_stream) < chunk) + { + if (feof (b_stream)) + goto out; /* short read */ + goto errout; /* some error */ + } + + if (chunk > 0 && memcmp (a_buf, b_buf, chunk) != 0) + goto out; + } + + fread (b_buf, 1, 1, b_stream); + if (! feof (b_stream)) + goto out; /* b is longer */ + + /* They match. */ + result = sc->T; + + out: + if (a_stream) + fclose (a_stream); + if (b_stream) + fclose (b_stream); + FFI_RETURN_POINTER (sc, result); + errout: + err = gpg_error_from_syserror (); + goto out; +} + +static pointer +do_splice (scheme *sc, pointer args) +{ + FFI_PROLOG (); + int source; + int sink; + ssize_t len = -1; + char buffer[1024]; + ssize_t bytes_read; + FFI_ARG_OR_RETURN (sc, int, source, number, args); + FFI_ARG_OR_RETURN (sc, int, sink, number, args); + if (args != sc->NIL) + FFI_ARG_OR_RETURN (sc, ssize_t, len, number, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + while (len == -1 || len > 0) + { + size_t want = sizeof buffer; + if (len > 0 && (ssize_t) want > len) + want = (size_t) len; + + bytes_read = read (source, buffer, want); + if (bytes_read == 0) + break; + if (bytes_read < 0) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + if (write (sink, buffer, bytes_read) != bytes_read) + FFI_RETURN_ERR (sc, gpg_error_from_syserror ()); + if (len != -1) + len -= bytes_read; + } + FFI_RETURN (sc); +} + +static pointer +do_string_index (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *haystack; + char needle; + ssize_t offset = 0; + char *position; + FFI_ARG_OR_RETURN (sc, char *, haystack, string, args); + FFI_ARG_OR_RETURN (sc, char, needle, character, args); + if (args != sc->NIL) + { + FFI_ARG_OR_RETURN (sc, ssize_t, offset, number, args); + if (offset < 0) + return ffi_sprintf (sc, "offset must be positive"); + if (offset > strlen (haystack)) + return ffi_sprintf (sc, "offset exceeds haystack"); + } + FFI_ARGS_DONE_OR_RETURN (sc, args); + + position = strchr (haystack+offset, needle); + if (position) + FFI_RETURN_INT (sc, position - haystack); + else + FFI_RETURN_POINTER (sc, sc->F); +} + +static pointer +do_string_rindex (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *haystack; + char needle; + ssize_t offset = 0; + char *position; + FFI_ARG_OR_RETURN (sc, char *, haystack, string, args); + FFI_ARG_OR_RETURN (sc, char, needle, character, args); + if (args != sc->NIL) + { + FFI_ARG_OR_RETURN (sc, ssize_t, offset, number, args); + if (offset < 0) + return ffi_sprintf (sc, "offset must be positive"); + if (offset > strlen (haystack)) + return ffi_sprintf (sc, "offset exceeds haystack"); + } + FFI_ARGS_DONE_OR_RETURN (sc, args); + + position = strrchr (haystack+offset, needle); + if (position) + FFI_RETURN_INT (sc, position - haystack); + else + FFI_RETURN_POINTER (sc, sc->F); +} + +static pointer +do_string_contains (scheme *sc, pointer args) +{ + FFI_PROLOG (); + char *haystack; + char *needle; + FFI_ARG_OR_RETURN (sc, char *, haystack, string, args); + FFI_ARG_OR_RETURN (sc, char *, needle, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + FFI_RETURN_POINTER (sc, strstr (haystack, needle) ? sc->T : sc->F); +} + +static pointer +do_glob (scheme *sc, pointer args) +{ + FFI_PROLOG (); + pointer result = sc->NIL; + size_t i; + char *pattern; + glob_t pglob; + FFI_ARG_OR_RETURN (sc, char *, pattern, string, args); + FFI_ARGS_DONE_OR_RETURN (sc, args); + + switch (glob (pattern, 0, NULL, &pglob)) + { + case 0: + for (i = 0; i < pglob.gl_pathc; i++) + result = + (sc->vptr->cons) (sc, + sc->vptr->mk_string (sc, pglob.gl_pathv[i]), + result); + globfree (&pglob); + break; + + case GLOB_NOMATCH: + /* Return the empty list. */ + break; + + case GLOB_NOSPACE: + return ffi_sprintf (sc, "out of memory"); + case GLOB_ABORTED: + return ffi_sprintf (sc, "read error"); + default: + assert (! "not reached"); + } + FFI_RETURN_POINTER (sc, result); +} + + +gpg_error_t +ffi_list2argv (scheme *sc, pointer list, char ***argv, size_t *len) +{ + int i; + + *len = sc->vptr->list_length (sc, list); + *argv = xtrycalloc (*len + 1, sizeof **argv); + if (*argv == NULL) + return gpg_error_from_syserror (); + + for (i = 0; sc->vptr->is_pair (list); list = sc->vptr->pair_cdr (list)) + { + if (sc->vptr->is_string (sc->vptr->pair_car (list))) + (*argv)[i++] = sc->vptr->string_value (sc->vptr->pair_car (list)); + else if (sc->vptr->is_symbol (sc->vptr->pair_car (list))) + (*argv)[i++] = sc->vptr->symname (sc->vptr->pair_car (list)); + else + { + xfree (*argv); + *argv = NULL; + *len = i; + return gpg_error (GPG_ERR_INV_VALUE); + } + } + (*argv)[i] = NULL; + return 0; +} + +gpg_error_t +ffi_list2intv (scheme *sc, pointer list, int **intv, size_t *len) +{ + int i; + + *len = sc->vptr->list_length (sc, list); + *intv = xtrycalloc (*len, sizeof **intv); + if (*intv == NULL) + return gpg_error_from_syserror (); + + for (i = 0; sc->vptr->is_pair (list); list = sc->vptr->pair_cdr (list)) + { + if (sc->vptr->is_number (sc->vptr->pair_car (list))) + (*intv)[i++] = sc->vptr->ivalue (sc->vptr->pair_car (list)); + else + { + xfree (*intv); + *intv = NULL; + *len = i; + return gpg_error (GPG_ERR_INV_VALUE); + } + } + + return 0; +} + + +char * +ffi_schemify_name (const char *s, int macro) +{ + char *n = strdup (s), *p; + if (n == NULL) + return s; + for (p = n; *p; p++) + { + *p = (char) tolower (*p); + /* We convert _ to - in identifiers. We allow, however, for + function names to start with a leading _. The functions in + this namespace are not yet finalized and might change or + vanish without warning. Use them with care. */ + if (! macro + && p != n + && *p == '_') + *p = '-'; + } + return n; +} + +pointer +ffi_sprintf (scheme *sc, const char *format, ...) +{ + pointer result; + va_list listp; + char *expression; + int size, written; + + va_start (listp, format); + size = vsnprintf (NULL, 0, format, listp); + va_end (listp); + + expression = xtrymalloc (size + 1); + if (expression == NULL) + return NULL; + + va_start (listp, format); + written = vsnprintf (expression, size + 1, format, listp); + va_end (listp); + + assert (size == written); + + result = sc->vptr->mk_string (sc, expression); + xfree (expression); + return result; +} + +void +ffi_scheme_eval (scheme *sc, const char *format, ...) +{ + va_list listp; + char *expression; + int size, written; + + va_start (listp, format); + size = vsnprintf (NULL, 0, format, listp); + va_end (listp); + + expression = xtrymalloc (size + 1); + if (expression == NULL) + return; + + va_start (listp, format); + written = vsnprintf (expression, size + 1, format, listp); + va_end (listp); + + assert (size == written); + + sc->vptr->load_string (sc, expression); + xfree (expression); +} + +gpg_error_t +ffi_init (scheme *sc, const char *argv0, int argc, const char **argv) +{ + int i; + pointer args = sc->NIL; + + /* bitwise arithmetic */ + ffi_define_function (sc, logand); + ffi_define_function (sc, logior); + ffi_define_function (sc, logxor); + ffi_define_function (sc, lognot); + + /* libc. */ + ffi_define_constant (sc, O_RDONLY); + ffi_define_constant (sc, O_WRONLY); + ffi_define_constant (sc, O_RDWR); + ffi_define_constant (sc, O_CREAT); + ffi_define_constant (sc, O_APPEND); +#ifndef O_BINARY +# define O_BINARY 0 +#endif +#ifndef O_TEXT +# define O_TEXT 0 +#endif + ffi_define_constant (sc, O_BINARY); + ffi_define_constant (sc, O_TEXT); + ffi_define_constant (sc, STDIN_FILENO); + ffi_define_constant (sc, STDOUT_FILENO); + ffi_define_constant (sc, STDERR_FILENO); + + ffi_define_function (sc, sleep); + ffi_define_function (sc, usleep); + ffi_define_function (sc, chdir); + ffi_define_function (sc, strerror); + ffi_define_function (sc, getenv); + ffi_define_function (sc, setenv); + ffi_define_function (sc, exit); + ffi_define_function (sc, open); + ffi_define_function (sc, fdopen); + ffi_define_function (sc, close); + ffi_define_function (sc, mkdtemp); + ffi_define_function (sc, unlink); + ffi_define_function (sc, unlink_recursively); + ffi_define_function (sc, rename); + ffi_define_function (sc, getcwd); + ffi_define_function (sc, mkdir); + ffi_define_function (sc, rmdir); + + /* Process management. */ + ffi_define_function (sc, spawn_process); + ffi_define_function (sc, spawn_process_fd); + ffi_define_function (sc, wait_process); + ffi_define_function (sc, wait_processes); + ffi_define_function (sc, pipe); + ffi_define_function (sc, inbound_pipe); + ffi_define_function (sc, outbound_pipe); + + /* estream functions. */ + ffi_define_function_name (sc, "es-fclose", es_fclose); + ffi_define_function_name (sc, "es-read", es_read); + ffi_define_function_name (sc, "es-feof", es_feof); + ffi_define_function_name (sc, "es-write", es_write); + + /* Test helper functions. */ + ffi_define_function (sc, file_equal); + ffi_define_function (sc, splice); + ffi_define_function (sc, string_index); + ffi_define_function (sc, string_rindex); + ffi_define_function_name (sc, "string-contains?", string_contains); + ffi_define_function (sc, glob); + + /* User interface. */ + ffi_define_function (sc, flush_stdio); + ffi_define_function (sc, prompt); + + /* Configuration. */ + ffi_define (sc, "*verbose*", sc->vptr->mk_integer (sc, verbose)); + + ffi_define (sc, "*argv0*", sc->vptr->mk_string (sc, argv0)); + for (i = argc - 1; i >= 0; i--) + { + pointer value = sc->vptr->mk_string (sc, argv[i]); + args = (sc->vptr->cons) (sc, value, args); + } + ffi_define (sc, "*args*", args); + +#if _WIN32 + ffi_define (sc, "*pathsep*", sc->vptr->mk_character (sc, ';')); +#else + ffi_define (sc, "*pathsep*", sc->vptr->mk_character (sc, ':')); +#endif + + ffi_define (sc, "*stdin*", + sc->vptr->mk_port_from_file (sc, stdin, port_input)); + ffi_define (sc, "*stdout*", + sc->vptr->mk_port_from_file (sc, stdout, port_output)); + ffi_define (sc, "*stderr*", + sc->vptr->mk_port_from_file (sc, stderr, port_output)); + + return 0; +} diff --git a/tests/gpgscm/ffi.h b/tests/gpgscm/ffi.h new file mode 100644 index 000000000..02dd99d59 --- /dev/null +++ b/tests/gpgscm/ffi.h @@ -0,0 +1,30 @@ +/* FFI interface for TinySCHEME. + * + * Copyright (C) 2016 g10 code GmbH + * + * This file is part of GnuPG. + * + * GnuPG is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 3 of the License, or + * (at your option) any later version. + * + * GnuPG is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, see <http://www.gnu.org/licenses/>. + */ + +#ifndef GPGSCM_FFI_H +#define GPGSCM_FFI_H + +#include <gpg-error.h> +#include "scheme.h" + +gpg_error_t ffi_init (scheme *sc, const char *argv0, + int argc, const char **argv); + +#endif /* GPGSCM_FFI_H */ diff --git a/tests/gpgscm/ffi.scm b/tests/gpgscm/ffi.scm new file mode 100644 index 000000000..7c2f93aba --- /dev/null +++ b/tests/gpgscm/ffi.scm @@ -0,0 +1,44 @@ +;; FFI interface for TinySCHEME. +;; +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +;; Foreign function wrapper. Expects F to return a list with the +;; first element being the `error_t' value returned by the foreign +;; function. The error is thrown, or the cdr of the result is +;; returned. +(define (ffi-apply name f args) + (let ((result (apply f args))) + (cond + ((string? result) + (ffi-fail name args result)) + ((not (= (car result) 0)) + (ffi-fail name args (strerror (car result)))) + ((and (= (car result) 0) (pair? (cdr result))) (cadr result)) + ((= (car result) 0) '()) + (else + (throw (list "Result violates FFI calling convention: " result)))))) + +(define (ffi-fail name args message) + (let ((args' (open-output-string))) + (write (cons (string->symbol name) args) args') + (throw (string-append + (get-output-string args') ": " message)))) + +;; Pseudo-definitions for foreign functions. Evaluates to no code, +;; but serves as documentation. +(macro (ffi-define form)) diff --git a/tests/gpgscm/init.scm b/tests/gpgscm/init.scm new file mode 100644 index 000000000..0889366af --- /dev/null +++ b/tests/gpgscm/init.scm @@ -0,0 +1,723 @@ +; 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>=? 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)) +(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>=? 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 (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))))) + +;;;; 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*. +; +; 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*)) + +(define (throw . x) + (if (more-handlers?) + (apply (pop-handler) x) + (apply error x))) + +(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 (*error-hook* . args) + (throw args)) + + +;;;;; 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)))) + +;;;;; 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/lib.scm b/tests/gpgscm/lib.scm new file mode 100644 index 000000000..e23977a5e --- /dev/null +++ b/tests/gpgscm/lib.scm @@ -0,0 +1,159 @@ +;; Additional library functions for TinySCHEME. +;; +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +(macro (assert form) + `(if (not ,(cadr form)) + (begin + (display (list "Assertion failed:" (quote ,(cadr form)))) + (newline) + (exit 1)))) +(assert #t) + +(define (filter pred lst) + (cond ((null? lst) '()) + ((pred (car lst)) + (cons (car lst) (filter pred (cdr lst)))) + (else (filter pred (cdr lst))))) + +(define (any p l) + (cond ((null? l) #f) + ((p (car l)) #t) + (else (any p (cdr l))))) + +(define (all p l) + (cond ((null? l) #t) + ((not (p (car l))) #f) + (else (all p (cdr l))))) + +;; Is PREFIX a prefix of S? +(define (string-prefix? s prefix) + (and (>= (string-length s) (string-length prefix)) + (string=? prefix (substring s 0 (string-length prefix))))) +(assert (string-prefix? "Scheme" "Sch")) + +;; Is SUFFIX a suffix of S? +(define (string-suffix? s suffix) + (and (>= (string-length s) (string-length suffix)) + (string=? suffix (substring s (- (string-length s) + (string-length suffix)) + (string-length s))))) +(assert (string-suffix? "Scheme" "eme")) + +;; Locate the first occurrence of needle in haystack starting at offset. +(ffi-define (string-index haystack needle [offset])) +(assert (= 2 (string-index "Hallo" #\l))) +(assert (= 3 (string-index "Hallo" #\l 3))) +(assert (equal? #f (string-index "Hallo" #\.))) + +;; Locate the last occurrence of needle in haystack starting at offset. +(ffi-define (string-rindex haystack needle [offset])) +(assert (= 3 (string-rindex "Hallo" #\l))) +(assert (equal? #f (string-rindex "Hallo" #\a 2))) +(assert (equal? #f (string-rindex "Hallo" #\.))) + +;; Split haystack at delimiter at most n times. +(define (string-splitn haystack delimiter n) + (let ((length (string-length haystack))) + (define (split acc delimiter offset n) + (if (>= offset length) + (reverse acc) + (let ((i (string-index haystack delimiter offset))) + (if (or (eq? i #f) (= 0 n)) + (reverse (cons (substring haystack offset length) acc)) + (split (cons (substring haystack offset i) acc) + delimiter (+ i 1) (- n 1)))))) + (split '() delimiter 0 n))) +(assert (= 2 (length (string-splitn "foo:bar:baz" #\: 1)))) +(assert (string=? "foo" (car (string-splitn "foo:bar:baz" #\: 1)))) +(assert (string=? "bar:baz" (cadr (string-splitn "foo:bar:baz" #\: 1)))) + +;; Split haystack at delimiter. +(define (string-split haystack delimiter) + (string-splitn haystack delimiter -1)) +(assert (= 3 (length (string-split "foo:bar:baz" #\:)))) +(assert (string=? "foo" (car (string-split "foo:bar:baz" #\:)))) +(assert (string=? "bar" (cadr (string-split "foo:bar:baz" #\:)))) +(assert (string=? "baz" (caddr (string-split "foo:bar:baz" #\:)))) + +;; Trim the prefix of S containing only characters that make PREDICATE +;; true. +(define (string-ltrim predicate s) + (let loop ((s' (string->list s))) + (if (predicate (car s')) + (loop (cdr s')) + (list->string s')))) +(assert (string=? "foo" (string-ltrim char-whitespace? " foo"))) + +;; Trim the suffix of S containing only characters that make PREDICATE +;; true. +(define (string-rtrim predicate s) + (let loop ((s' (reverse (string->list s)))) + (if (predicate (car s')) + (loop (cdr s')) + (list->string (reverse s'))))) +(assert (string=? "foo" (string-rtrim char-whitespace? "foo "))) + +;; Trim both the prefix and suffix of S containing only characters +;; that make PREDICATE true. +(define (string-trim predicate s) + (string-ltrim predicate (string-rtrim predicate s))) +(assert (string=? "foo" (string-trim char-whitespace? " foo "))) + +;; Check if needle is contained in haystack. +(ffi-define (string-contains? haystack needle)) +(assert (string-contains? "Hallo" "llo")) +(assert (not (string-contains? "Hallo" "olla"))) + +;; Read a word from port P. +(define (read-word . p) + (list->string + (let f () + (let ((c (apply peek-char p))) + (cond + ((eof-object? c) '()) + ((char-alphabetic? c) + (apply read-char p) + (cons c (f))) + (else + (apply read-char p) + '())))))) + +;; Read a line from port P. +(define (read-line . p) + (list->string + (let f () + (let ((c (apply peek-char p))) + (cond + ((eof-object? c) '()) + ((char=? c #\newline) + (apply read-char p) + '()) + (else + (apply read-char p) + (cons c (f)))))))) + +;; Read everything from port P. +(define (read-all . p) + (let loop ((acc (open-output-string))) + (let ((c (apply peek-char p))) + (cond + ((eof-object? c) (get-output-string acc)) + (else + (write-char (apply read-char p) acc) + (loop acc)))))) diff --git a/tests/gpgscm/main.c b/tests/gpgscm/main.c new file mode 100644 index 000000000..5b3792eac --- /dev/null +++ b/tests/gpgscm/main.c @@ -0,0 +1,288 @@ +/* TinyScheme-based test driver. + * + * Copyright (C) 2016 g10 code GmbH + * + * This file is part of GnuPG. + * + * GnuPG is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 3 of the License, or + * (at your option) any later version. + * + * GnuPG is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, see <http://www.gnu.org/licenses/>. + */ + +#include <config.h> + +#include <assert.h> +#include <ctype.h> +#include <errno.h> +#include <gcrypt.h> +#include <gpg-error.h> +#include <stdio.h> +#include <stdlib.h> +#include <string.h> +#include <unistd.h> + +#include "private.h" +#include "scheme.h" +#include "ffi.h" +#include "i18n.h" +#include "../../common/argparse.h" +#include "../../common/init.h" +#include "../../common/logging.h" +#include "../../common/strlist.h" +#include "../../common/sysutils.h" +#include "../../common/util.h" + +/* The TinyScheme banner. Unfortunately, it isn't in the header + file. */ +#define ts_banner "TinyScheme 1.41" + +int verbose; + + + +/* Constants to identify the commands and options. */ +enum cmd_and_opt_values + { + aNull = 0, + oVerbose = 'v', + }; + +/* The list of commands and options. */ +static ARGPARSE_OPTS opts[] = + { + ARGPARSE_s_n (oVerbose, "verbose", N_("verbose")), + ARGPARSE_end (), + }; + +char *scmpath = ""; +size_t scmpath_len = 0; + +/* Command line parsing. */ +static void +parse_arguments (ARGPARSE_ARGS *pargs, ARGPARSE_OPTS *popts) +{ + int no_more_options = 0; + + while (!no_more_options && optfile_parse (NULL, NULL, NULL, pargs, popts)) + { + switch (pargs->r_opt) + { + case oVerbose: + verbose++; + break; + + default: + pargs->err = 2; + break; + } + } +} + +/* Print usage information and and provide strings for help. */ +static const char * +my_strusage( int level ) +{ + const char *p; + + switch (level) + { + case 11: p = "gpgscm (@GNUPG@)"; + break; + case 13: p = VERSION; break; + case 17: p = PRINTABLE_OS_NAME; break; + case 19: p = _("Please report bugs to <@EMAIL@>.\n"); break; + + case 1: + case 40: + p = _("Usage: gpgscm [options] [file] (-h for help)"); + break; + case 41: + p = _("Syntax: gpgscm [options] [file]\n" + "Execute the given Scheme program, or spawn interactive shell.\n"); + break; + + default: p = NULL; break; + } + return p; +} + + +/* Load the Scheme program from FILE_NAME. If FILE_NAME is not an + absolute path, and LOOKUP_IN_PATH is given, then it is qualified + with the values in scmpath until the file is found. */ +static gpg_error_t +load (scheme *sc, char *file_name, + int lookup_in_cwd, int lookup_in_path) +{ + gpg_error_t err = 0; + size_t n; + const char *directory; + char *qualified_name = file_name; + int use_path; + FILE *h = NULL; + + use_path = + lookup_in_path && ! (file_name[0] == '/' || scmpath_len == 0); + + if (file_name[0] == '/' || lookup_in_cwd || scmpath_len == 0) + { + h = fopen (file_name, "r"); + if (! h) + err = gpg_error_from_syserror (); + } + + if (h == NULL && use_path) + for (directory = scmpath, n = scmpath_len; n; + directory += strlen (directory) + 1, n--) + { + if (asprintf (&qualified_name, "%s/%s", directory, file_name) < 0) + return gpg_error_from_syserror (); + + h = fopen (qualified_name, "r"); + if (h) + break; + + if (n > 1) + { + free (qualified_name); + continue; /* Try again! */ + } + + err = gpg_error_from_syserror (); + } + + if (h == NULL) + { + /* Failed and no more elements in scmpath to try. */ + fprintf (stderr, "Could not read %s: %s.\n", + qualified_name, gpg_strerror (err)); + if (lookup_in_path) + fprintf (stderr, + "Consider using GPGSCM_PATH to specify the location " + "of the Scheme library.\n"); + return err; + } + if (verbose > 1) + fprintf (stderr, "Loading %s...\n", qualified_name); + scheme_load_named_file (sc, h, qualified_name); + fclose (h); + + if (file_name != qualified_name) + free (qualified_name); + return 0; +} + + + +int +main (int argc, char **argv) +{ + gpg_error_t err; + char *argv0; + ARGPARSE_ARGS pargs; + scheme *sc; + char *p; +#if _WIN32 + char pathsep = ';'; +#else + char pathsep = ':'; +#endif + char *script = NULL; + + /* Save argv[0] so that we can re-exec. */ + argv0 = argv[0]; + + /* Parse path. */ + if (getenv ("GPGSCM_PATH")) + scmpath = getenv ("GPGSCM_PATH"); + + p = scmpath = strdup (scmpath); + if (p == NULL) + return 2; + + if (*p) + scmpath_len++; + for (; *p; p++) + if (*p == pathsep) + *p = 0, scmpath_len++; + + set_strusage (my_strusage); + log_set_prefix ("gpgscm", 1); + + /* Make sure that our subsystems are ready. */ + i18n_init (); + init_common_subsystems (&argc, &argv); + + if (!gcry_check_version (GCRYPT_VERSION)) + { + fputs ("libgcrypt version mismatch\n", stderr); + exit (2); + } + + /* Parse the command line. */ + pargs.argc = &argc; + pargs.argv = &argv; + pargs.flags = 0; + parse_arguments (&pargs, opts); + + if (log_get_errorcount (0)) + exit (2); + + sc = scheme_init_new_custom_alloc (gcry_malloc, gcry_free); + if (! sc) { + fprintf (stderr, "Could not initialize TinyScheme!\n"); + return 2; + } + scheme_set_input_port_file (sc, stdin); + scheme_set_output_port_file (sc, stderr); + + if (argc) + { + script = argv[0]; + argc--, argv++; + } + + err = load (sc, "init.scm", 0, 1); + if (! err) + err = load (sc, "ffi.scm", 0, 1); + if (! err) + err = ffi_init (sc, argv0, argc, (const char **) argv); + if (! err) + err = load (sc, "lib.scm", 0, 1); + if (! err) + err = load (sc, "repl.scm", 0, 1); + if (! err) + err = load (sc, "tests.scm", 0, 1); + if (err) + { + fprintf (stderr, "Error initializing gpgscm: %s.\n", + gpg_strerror (err)); + exit (2); + } + + if (script == NULL) + { + /* Interactive shell. */ + fprintf (stderr, "gpgscm/"ts_banner".\n"); + scheme_load_string (sc, "(interactive-repl)"); + } + else + { + err = load (sc, script, 1, 1); + if (err) + log_fatal ("%s: %s", script, gpg_strerror (err)); + } + + scheme_deinit (sc); + xfree (sc); + return EXIT_SUCCESS; +} diff --git a/tests/gpgscm/opdefines.h b/tests/gpgscm/opdefines.h new file mode 100644 index 000000000..ceb4d0e39 --- /dev/null +++ b/tests/gpgscm/opdefines.h @@ -0,0 +1,195 @@ + _OP_DEF(opexe_0, "load", 1, 1, TST_STRING, OP_LOAD ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_T0LVL ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_T1LVL ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_READ_INTERNAL ) + _OP_DEF(opexe_0, "gensym", 0, 0, 0, OP_GENSYM ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_VALUEPRINT ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_EVAL ) +#if USE_TRACING + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_REAL_EVAL ) +#endif + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_E0ARGS ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_E1ARGS ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_APPLY ) +#if USE_TRACING + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_REAL_APPLY ) + _OP_DEF(opexe_0, "tracing", 1, 1, TST_NATURAL, OP_TRACING ) +#endif + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_DOMACRO ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LAMBDA ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LAMBDA1 ) + _OP_DEF(opexe_0, "make-closure", 1, 2, TST_PAIR TST_ENVIRONMENT, OP_MKCLOSURE ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_QUOTE ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_DEF0 ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_DEF1 ) + _OP_DEF(opexe_0, "defined?", 1, 2, TST_SYMBOL TST_ENVIRONMENT, OP_DEFP ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_BEGIN ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_IF0 ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_IF1 ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_SET0 ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_SET1 ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET0 ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET1 ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET2 ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET0AST ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET1AST ) + _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET2AST ) + _OP_DEF(opexe_1, 0, 0, 0, 0, OP_LET0REC ) + _OP_DEF(opexe_1, 0, 0, 0, 0, OP_LET1REC ) + _OP_DEF(opexe_1, 0, 0, 0, 0, OP_LET2REC ) + _OP_DEF(opexe_1, 0, 0, 0, 0, OP_COND0 ) + _OP_DEF(opexe_1, 0, 0, 0, 0, OP_COND1 ) + _OP_DEF(opexe_1, 0, 0, 0, 0, OP_DELAY ) + _OP_DEF(opexe_1, 0, 0, 0, 0, OP_AND0 ) + _OP_DEF(opexe_1, 0, 0, 0, 0, OP_AND1 ) + _OP_DEF(opexe_1, 0, 0, 0, 0, OP_OR0 ) + _OP_DEF(opexe_1, 0, 0, 0, 0, OP_OR1 ) + _OP_DEF(opexe_1, 0, 0, 0, 0, OP_C0STREAM ) + _OP_DEF(opexe_1, 0, 0, 0, 0, OP_C1STREAM ) + _OP_DEF(opexe_1, 0, 0, 0, 0, OP_MACRO0 ) + _OP_DEF(opexe_1, 0, 0, 0, 0, OP_MACRO1 ) + _OP_DEF(opexe_1, 0, 0, 0, 0, OP_CASE0 ) + _OP_DEF(opexe_1, 0, 0, 0, 0, OP_CASE1 ) + _OP_DEF(opexe_1, 0, 0, 0, 0, OP_CASE2 ) + _OP_DEF(opexe_1, "eval", 1, 2, TST_ANY TST_ENVIRONMENT, OP_PEVAL ) + _OP_DEF(opexe_1, "apply", 1, INF_ARG, TST_NONE, OP_PAPPLY ) + _OP_DEF(opexe_1, "call-with-current-continuation", 1, 1, TST_NONE, OP_CONTINUATION ) +#if USE_MATH + _OP_DEF(opexe_2, "inexact->exact", 1, 1, TST_NUMBER, OP_INEX2EX ) + _OP_DEF(opexe_2, "exp", 1, 1, TST_NUMBER, OP_EXP ) + _OP_DEF(opexe_2, "log", 1, 1, TST_NUMBER, OP_LOG ) + _OP_DEF(opexe_2, "sin", 1, 1, TST_NUMBER, OP_SIN ) + _OP_DEF(opexe_2, "cos", 1, 1, TST_NUMBER, OP_COS ) + _OP_DEF(opexe_2, "tan", 1, 1, TST_NUMBER, OP_TAN ) + _OP_DEF(opexe_2, "asin", 1, 1, TST_NUMBER, OP_ASIN ) + _OP_DEF(opexe_2, "acos", 1, 1, TST_NUMBER, OP_ACOS ) + _OP_DEF(opexe_2, "atan", 1, 2, TST_NUMBER, OP_ATAN ) + _OP_DEF(opexe_2, "sqrt", 1, 1, TST_NUMBER, OP_SQRT ) + _OP_DEF(opexe_2, "expt", 2, 2, TST_NUMBER, OP_EXPT ) + _OP_DEF(opexe_2, "floor", 1, 1, TST_NUMBER, OP_FLOOR ) + _OP_DEF(opexe_2, "ceiling", 1, 1, TST_NUMBER, OP_CEILING ) + _OP_DEF(opexe_2, "truncate", 1, 1, TST_NUMBER, OP_TRUNCATE ) + _OP_DEF(opexe_2, "round", 1, 1, TST_NUMBER, OP_ROUND ) +#endif + _OP_DEF(opexe_2, "+", 0, INF_ARG, TST_NUMBER, OP_ADD ) + _OP_DEF(opexe_2, "-", 1, INF_ARG, TST_NUMBER, OP_SUB ) + _OP_DEF(opexe_2, "*", 0, INF_ARG, TST_NUMBER, OP_MUL ) + _OP_DEF(opexe_2, "/", 1, INF_ARG, TST_NUMBER, OP_DIV ) + _OP_DEF(opexe_2, "quotient", 1, INF_ARG, TST_INTEGER, OP_INTDIV ) + _OP_DEF(opexe_2, "remainder", 2, 2, TST_INTEGER, OP_REM ) + _OP_DEF(opexe_2, "modulo", 2, 2, TST_INTEGER, OP_MOD ) + _OP_DEF(opexe_2, "car", 1, 1, TST_PAIR, OP_CAR ) + _OP_DEF(opexe_2, "cdr", 1, 1, TST_PAIR, OP_CDR ) + _OP_DEF(opexe_2, "cons", 2, 2, TST_NONE, OP_CONS ) + _OP_DEF(opexe_2, "set-car!", 2, 2, TST_PAIR TST_ANY, OP_SETCAR ) + _OP_DEF(opexe_2, "set-cdr!", 2, 2, TST_PAIR TST_ANY, OP_SETCDR ) + _OP_DEF(opexe_2, "char->integer", 1, 1, TST_CHAR, OP_CHAR2INT ) + _OP_DEF(opexe_2, "integer->char", 1, 1, TST_NATURAL, OP_INT2CHAR ) + _OP_DEF(opexe_2, "char-upcase", 1, 1, TST_CHAR, OP_CHARUPCASE ) + _OP_DEF(opexe_2, "char-downcase", 1, 1, TST_CHAR, OP_CHARDNCASE ) + _OP_DEF(opexe_2, "symbol->string", 1, 1, TST_SYMBOL, OP_SYM2STR ) + _OP_DEF(opexe_2, "atom->string", 1, 2, TST_ANY TST_NATURAL, OP_ATOM2STR ) + _OP_DEF(opexe_2, "string->symbol", 1, 1, TST_STRING, OP_STR2SYM ) + _OP_DEF(opexe_2, "string->atom", 1, 2, TST_STRING TST_NATURAL, OP_STR2ATOM ) + _OP_DEF(opexe_2, "make-string", 1, 2, TST_NATURAL TST_CHAR, OP_MKSTRING ) + _OP_DEF(opexe_2, "string-length", 1, 1, TST_STRING, OP_STRLEN ) + _OP_DEF(opexe_2, "string-ref", 2, 2, TST_STRING TST_NATURAL, OP_STRREF ) + _OP_DEF(opexe_2, "string-set!", 3, 3, TST_STRING TST_NATURAL TST_CHAR, OP_STRSET ) + _OP_DEF(opexe_2, "string-append", 0, INF_ARG, TST_STRING, OP_STRAPPEND ) + _OP_DEF(opexe_2, "substring", 2, 3, TST_STRING TST_NATURAL, OP_SUBSTR ) + _OP_DEF(opexe_2, "vector", 0, INF_ARG, TST_NONE, OP_VECTOR ) + _OP_DEF(opexe_2, "make-vector", 1, 2, TST_NATURAL TST_ANY, OP_MKVECTOR ) + _OP_DEF(opexe_2, "vector-length", 1, 1, TST_VECTOR, OP_VECLEN ) + _OP_DEF(opexe_2, "vector-ref", 2, 2, TST_VECTOR TST_NATURAL, OP_VECREF ) + _OP_DEF(opexe_2, "vector-set!", 3, 3, TST_VECTOR TST_NATURAL TST_ANY, OP_VECSET ) + _OP_DEF(opexe_3, "not", 1, 1, TST_NONE, OP_NOT ) + _OP_DEF(opexe_3, "boolean?", 1, 1, TST_NONE, OP_BOOLP ) + _OP_DEF(opexe_3, "eof-object?", 1, 1, TST_NONE, OP_EOFOBJP ) + _OP_DEF(opexe_3, "null?", 1, 1, TST_NONE, OP_NULLP ) + _OP_DEF(opexe_3, "=", 2, INF_ARG, TST_NUMBER, OP_NUMEQ ) + _OP_DEF(opexe_3, "<", 2, INF_ARG, TST_NUMBER, OP_LESS ) + _OP_DEF(opexe_3, ">", 2, INF_ARG, TST_NUMBER, OP_GRE ) + _OP_DEF(opexe_3, "<=", 2, INF_ARG, TST_NUMBER, OP_LEQ ) + _OP_DEF(opexe_3, ">=", 2, INF_ARG, TST_NUMBER, OP_GEQ ) + _OP_DEF(opexe_3, "symbol?", 1, 1, TST_ANY, OP_SYMBOLP ) + _OP_DEF(opexe_3, "number?", 1, 1, TST_ANY, OP_NUMBERP ) + _OP_DEF(opexe_3, "string?", 1, 1, TST_ANY, OP_STRINGP ) + _OP_DEF(opexe_3, "integer?", 1, 1, TST_ANY, OP_INTEGERP ) + _OP_DEF(opexe_3, "real?", 1, 1, TST_ANY, OP_REALP ) + _OP_DEF(opexe_3, "char?", 1, 1, TST_ANY, OP_CHARP ) +#if USE_CHAR_CLASSIFIERS + _OP_DEF(opexe_3, "char-alphabetic?", 1, 1, TST_CHAR, OP_CHARAP ) + _OP_DEF(opexe_3, "char-numeric?", 1, 1, TST_CHAR, OP_CHARNP ) + _OP_DEF(opexe_3, "char-whitespace?", 1, 1, TST_CHAR, OP_CHARWP ) + _OP_DEF(opexe_3, "char-upper-case?", 1, 1, TST_CHAR, OP_CHARUP ) + _OP_DEF(opexe_3, "char-lower-case?", 1, 1, TST_CHAR, OP_CHARLP ) +#endif + _OP_DEF(opexe_3, "port?", 1, 1, TST_ANY, OP_PORTP ) + _OP_DEF(opexe_3, "input-port?", 1, 1, TST_ANY, OP_INPORTP ) + _OP_DEF(opexe_3, "output-port?", 1, 1, TST_ANY, OP_OUTPORTP ) + _OP_DEF(opexe_3, "procedure?", 1, 1, TST_ANY, OP_PROCP ) + _OP_DEF(opexe_3, "pair?", 1, 1, TST_ANY, OP_PAIRP ) + _OP_DEF(opexe_3, "list?", 1, 1, TST_ANY, OP_LISTP ) + _OP_DEF(opexe_3, "environment?", 1, 1, TST_ANY, OP_ENVP ) + _OP_DEF(opexe_3, "vector?", 1, 1, TST_ANY, OP_VECTORP ) + _OP_DEF(opexe_3, "eq?", 2, 2, TST_ANY, OP_EQ ) + _OP_DEF(opexe_3, "eqv?", 2, 2, TST_ANY, OP_EQV ) + _OP_DEF(opexe_4, "force", 1, 1, TST_ANY, OP_FORCE ) + _OP_DEF(opexe_4, 0, 0, 0, 0, OP_SAVE_FORCED ) + _OP_DEF(opexe_4, "write", 1, 2, TST_ANY TST_OUTPORT, OP_WRITE ) + _OP_DEF(opexe_4, "write-char", 1, 2, TST_CHAR TST_OUTPORT, OP_WRITE_CHAR ) + _OP_DEF(opexe_4, "display", 1, 2, TST_ANY TST_OUTPORT, OP_DISPLAY ) + _OP_DEF(opexe_4, "newline", 0, 1, TST_OUTPORT, OP_NEWLINE ) + _OP_DEF(opexe_4, "error", 1, INF_ARG, TST_NONE, OP_ERR0 ) + _OP_DEF(opexe_4, 0, 0, 0, 0, OP_ERR1 ) + _OP_DEF(opexe_4, "reverse", 1, 1, TST_LIST, OP_REVERSE ) + _OP_DEF(opexe_4, "list*", 1, INF_ARG, TST_NONE, OP_LIST_STAR ) + _OP_DEF(opexe_4, "append", 0, INF_ARG, TST_NONE, OP_APPEND ) +#if USE_PLIST + _OP_DEF(opexe_4, "put", 3, 3, TST_NONE, OP_PUT ) + _OP_DEF(opexe_4, "get", 2, 2, TST_NONE, OP_GET ) +#endif + _OP_DEF(opexe_4, "quit", 0, 1, TST_NUMBER, OP_QUIT ) + _OP_DEF(opexe_4, "gc", 0, 0, 0, OP_GC ) + _OP_DEF(opexe_4, "gc-verbose", 0, 1, TST_NONE, OP_GCVERB ) + _OP_DEF(opexe_4, "new-segment", 0, 1, TST_NUMBER, OP_NEWSEGMENT ) + _OP_DEF(opexe_4, "oblist", 0, 0, 0, OP_OBLIST ) + _OP_DEF(opexe_4, "current-input-port", 0, 0, 0, OP_CURR_INPORT ) + _OP_DEF(opexe_4, "current-output-port", 0, 0, 0, OP_CURR_OUTPORT ) + _OP_DEF(opexe_4, "open-input-file", 1, 1, TST_STRING, OP_OPEN_INFILE ) + _OP_DEF(opexe_4, "open-output-file", 1, 1, TST_STRING, OP_OPEN_OUTFILE ) + _OP_DEF(opexe_4, "open-input-output-file", 1, 1, TST_STRING, OP_OPEN_INOUTFILE ) +#if USE_STRING_PORTS + _OP_DEF(opexe_4, "open-input-string", 1, 1, TST_STRING, OP_OPEN_INSTRING ) + _OP_DEF(opexe_4, "open-input-output-string", 1, 1, TST_STRING, OP_OPEN_INOUTSTRING ) + _OP_DEF(opexe_4, "open-output-string", 0, 1, TST_STRING, OP_OPEN_OUTSTRING ) + _OP_DEF(opexe_4, "get-output-string", 1, 1, TST_OUTPORT, OP_GET_OUTSTRING ) +#endif + _OP_DEF(opexe_4, "close-input-port", 1, 1, TST_INPORT, OP_CLOSE_INPORT ) + _OP_DEF(opexe_4, "close-output-port", 1, 1, TST_OUTPORT, OP_CLOSE_OUTPORT ) + _OP_DEF(opexe_4, "interaction-environment", 0, 0, 0, OP_INT_ENV ) + _OP_DEF(opexe_4, "current-environment", 0, 0, 0, OP_CURR_ENV ) + _OP_DEF(opexe_5, "read", 0, 1, TST_INPORT, OP_READ ) + _OP_DEF(opexe_5, "read-char", 0, 1, TST_INPORT, OP_READ_CHAR ) + _OP_DEF(opexe_5, "peek-char", 0, 1, TST_INPORT, OP_PEEK_CHAR ) + _OP_DEF(opexe_5, "char-ready?", 0, 1, TST_INPORT, OP_CHAR_READY ) + _OP_DEF(opexe_5, "set-input-port", 1, 1, TST_INPORT, OP_SET_INPORT ) + _OP_DEF(opexe_5, "set-output-port", 1, 1, TST_OUTPORT, OP_SET_OUTPORT ) + _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDSEXPR ) + _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDLIST ) + _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDDOT ) + _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDQUOTE ) + _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDQQUOTE ) + _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDQQUOTEVEC ) + _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDUNQUOTE ) + _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDUQTSP ) + _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDVEC ) + _OP_DEF(opexe_5, 0, 0, 0, 0, OP_P0LIST ) + _OP_DEF(opexe_5, 0, 0, 0, 0, OP_P1LIST ) + _OP_DEF(opexe_5, 0, 0, 0, 0, OP_PVECFROM ) + _OP_DEF(opexe_6, "length", 1, 1, TST_LIST, OP_LIST_LENGTH ) + _OP_DEF(opexe_6, "assq", 2, 2, TST_NONE, OP_ASSQ ) + _OP_DEF(opexe_6, "get-closure-code", 1, 1, TST_NONE, OP_GET_CLOSURE ) + _OP_DEF(opexe_6, "closure?", 1, 1, TST_NONE, OP_CLOSUREP ) + _OP_DEF(opexe_6, "macro?", 1, 1, TST_NONE, OP_MACROP ) +#undef _OP_DEF diff --git a/tests/gpgscm/private.h b/tests/gpgscm/private.h new file mode 100644 index 000000000..efa0cb026 --- /dev/null +++ b/tests/gpgscm/private.h @@ -0,0 +1,26 @@ +/* TinyScheme-based test driver. + * + * Copyright (C) 2016 g10 code GmbH + * + * This file is part of GnuPG. + * + * GnuPG is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 3 of the License, or + * (at your option) any later version. + * + * GnuPG is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, see <http://www.gnu.org/licenses/>. + */ + +#ifndef __GPGSCM_PRIVATE_H__ +#define __GPGSCM_PRIVATE_H__ + +extern int verbose; + +#endif /* __GPGSCM_PRIVATE_H__ */ diff --git a/tests/gpgscm/repl.scm b/tests/gpgscm/repl.scm new file mode 100644 index 000000000..896554faf --- /dev/null +++ b/tests/gpgscm/repl.scm @@ -0,0 +1,50 @@ +;; A read-evaluate-print-loop for gpgscm. +;; +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +;; Interactive repl using 'prompt' function. P must be a function +;; that given the current entered prefix returns the prompt to +;; display. +(define (repl p) + (let ((repl-environment (make-environment))) + (call/cc + (lambda (exit) + (let loop ((prefix "")) + (let ((line (prompt (p prefix)))) + (if (and (not (eof-object? line)) (= 0 (string-length line))) + (exit (loop prefix))) + (if (not (eof-object? line)) + (let* ((next (string-append prefix line)) + (c (catch (begin (echo "Parse error:" *error*) + (loop prefix)) + (read (open-input-string next))))) + (if (not (eof-object? c)) + (begin + (catch (echo "Error:" *error*) + (echo " ===>" (eval c repl-environment))) + (exit (loop "")))) + (exit (loop next)))))))))) + +(define (prompt-append-prefix prompt prefix) + (string-append prompt (if (> (string-length prefix) 0) + (string-append prefix "...") + "> "))) + +;; Default repl run by main.c. +(define (interactive-repl) + (repl (lambda (p) (prompt-append-prefix "gpgscm " p)))) diff --git a/tests/gpgscm/scheme-config.h b/tests/gpgscm/scheme-config.h new file mode 100644 index 000000000..fe3d746dd --- /dev/null +++ b/tests/gpgscm/scheme-config.h @@ -0,0 +1,36 @@ +/* TinyScheme configuration. + * + * Copyright (C) 2016 g10 code GmbH + * + * This file is part of GnuPG. + * + * GnuPG is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 3 of the License, or + * (at your option) any later version. + * + * GnuPG is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, see <http://www.gnu.org/licenses/>. + */ + +#define STANDALONE 0 +#define USE_MATH 0 +#define USE_CHAR_CLASSIFIERS 1 +#define USE_ASCII_NAMES 1 +#define USE_STRING_PORTS 1 +#define USE_ERROR_HOOK 1 +#define USE_TRACING 1 +#define USE_COLON_HOOK 1 +#define USE_DL 0 +#define USE_PLIST 0 +#define USE_INTERFACE 1 +#define SHOW_ERROR_LINE 1 + +#if __MINGW32__ +# define USE_STRLWR 0 +#endif /* __MINGW32__ */ diff --git a/tests/gpgscm/scheme-private.h b/tests/gpgscm/scheme-private.h new file mode 100644 index 000000000..9eafe766d --- /dev/null +++ b/tests/gpgscm/scheme-private.h @@ -0,0 +1,228 @@ +/* scheme-private.h */ + +#ifndef _SCHEME_PRIVATE_H +#define _SCHEME_PRIVATE_H + +#include "scheme.h" +/*------------------ Ugly internals -----------------------------------*/ +/*------------------ Of interest only to FFI users --------------------*/ + +#ifdef __cplusplus +extern "C" { +#endif + +enum scheme_port_kind { + port_free=0, + port_file=1, + port_string=2, + port_srfi6=4, + port_input=16, + port_output=32, + port_saw_EOF=64 +}; + +typedef struct port { + unsigned char kind; + union { + struct { + FILE *file; + int closeit; +#if SHOW_ERROR_LINE + int curr_line; + char *filename; +#endif + } stdio; + struct { + char *start; + char *past_the_end; + char *curr; + } string; + } rep; +} port; + +/* cell structure */ +struct cell { + unsigned int _flag; + union { + struct { + char *_svalue; + int _length; + } _string; + num _number; + port *_port; + foreign_func _ff; + struct { + struct cell *_car; + struct cell *_cdr; + } _cons; + struct { + char *_data; + const foreign_object_vtable *_vtable; + } _foreign_object; + } _object; +}; + +struct scheme { +/* arrays for segments */ +func_alloc malloc; +func_dealloc free; + +/* return code */ +int retcode; +int tracing; + + +#ifndef CELL_SEGSIZE +#define CELL_SEGSIZE 5000 /* # of cells in one segment */ +#endif +#ifndef CELL_NSEGMENT +#define CELL_NSEGMENT 10 /* # of segments for cells */ +#endif +char *alloc_seg[CELL_NSEGMENT]; +pointer cell_seg[CELL_NSEGMENT]; +int last_cell_seg; + +/* We use 4 registers. */ +pointer args; /* register for arguments of function */ +pointer envir; /* stack register for current environment */ +pointer code; /* register for current code */ +pointer dump; /* stack register for next evaluation */ + +int interactive_repl; /* are we in an interactive REPL? */ + +struct cell _sink; +pointer sink; /* when mem. alloc. fails */ +struct cell _NIL; +pointer NIL; /* special cell representing empty cell */ +struct cell _HASHT; +pointer T; /* special cell representing #t */ +struct cell _HASHF; +pointer F; /* special cell representing #f */ +struct cell _EOF_OBJ; +pointer EOF_OBJ; /* special cell representing end-of-file object */ +pointer oblist; /* pointer to symbol table */ +pointer global_env; /* pointer to global environment */ +pointer c_nest; /* stack for nested calls from C */ + +/* global pointers to special symbols */ +pointer LAMBDA; /* pointer to syntax lambda */ +pointer QUOTE; /* pointer to syntax quote */ + +pointer QQUOTE; /* pointer to symbol quasiquote */ +pointer UNQUOTE; /* pointer to symbol unquote */ +pointer UNQUOTESP; /* pointer to symbol unquote-splicing */ +pointer FEED_TO; /* => */ +pointer COLON_HOOK; /* *colon-hook* */ +pointer ERROR_HOOK; /* *error-hook* */ +pointer SHARP_HOOK; /* *sharp-hook* */ +pointer COMPILE_HOOK; /* *compile-hook* */ + +pointer free_cell; /* pointer to top of free cells */ +long fcells; /* # of free cells */ + +pointer inport; +pointer outport; +pointer save_inport; +pointer loadport; + +#ifndef MAXFIL +#define MAXFIL 64 +#endif +port load_stack[MAXFIL]; /* Stack of open files for port -1 (LOADing) */ +int nesting_stack[MAXFIL]; +int file_i; +int nesting; + +char gc_verbose; /* if gc_verbose is not zero, print gc status */ +char no_memory; /* Whether mem. alloc. has failed */ + +#ifndef LINESIZE +#define LINESIZE 1024 +#endif +char linebuff[LINESIZE]; +#ifndef STRBUFFSIZE +#define STRBUFFSIZE 256 +#endif +char *strbuff; +size_t strbuff_size; +FILE *tmpfp; +int tok; +int print_flag; +pointer value; +int op; + +void *ext_data; /* For the benefit of foreign functions */ +long gensym_cnt; + +struct scheme_interface *vptr; +void *dump_base; /* pointer to base of allocated dump stack */ +int dump_size; /* number of frames allocated for dump stack */ +}; + +/* operator code */ +enum scheme_opcodes { +#define _OP_DEF(A,B,C,D,E,OP) OP, +#include "opdefines.h" + OP_MAXDEFINED +}; + + +#define cons(sc,a,b) _cons(sc,a,b,0) +#define immutable_cons(sc,a,b) _cons(sc,a,b,1) + +int is_string(pointer p); +char *string_value(pointer p); +int is_number(pointer p); +num nvalue(pointer p); +long ivalue(pointer p); +double rvalue(pointer p); +int is_integer(pointer p); +int is_real(pointer p); +int is_character(pointer p); +long charvalue(pointer p); +int is_vector(pointer p); + +int is_port(pointer p); + +int is_pair(pointer p); +pointer pair_car(pointer p); +pointer pair_cdr(pointer p); +pointer set_car(pointer p, pointer q); +pointer set_cdr(pointer p, pointer q); + +int is_symbol(pointer p); +char *symname(pointer p); +int hasprop(pointer p); + +int is_syntax(pointer p); +int is_proc(pointer p); +int is_foreign(pointer p); +char *syntaxname(pointer p); +int is_closure(pointer p); +#ifdef USE_MACRO +int is_macro(pointer p); +#endif +pointer closure_code(pointer p); +pointer closure_env(pointer p); + +int is_continuation(pointer p); +int is_promise(pointer p); +int is_environment(pointer p); +int is_immutable(pointer p); +void setimmutable(pointer p); + +int is_foreign_object(pointer p); +const foreign_object_vtable *get_foreign_object_vtable(pointer p); +void *get_foreign_object_data(pointer p); + +#ifdef __cplusplus +} +#endif + +#endif + +/* +Local variables: +c-file-style: "k&r" +End: +*/ diff --git a/tests/gpgscm/scheme.c b/tests/gpgscm/scheme.c new file mode 100644 index 000000000..0a7620521 --- /dev/null +++ b/tests/gpgscm/scheme.c @@ -0,0 +1,5169 @@ +/* T I N Y S C H E M E 1 . 4 1 + * Dimitrios Souflis ([email protected]) + * Based on MiniScheme (original credits follow) + * (MINISCM) coded by Atsushi Moriwaki (11/5/1989) + * (MINISCM) E-MAIL : [email protected] + * (MINISCM) This version has been modified by R.C. Secrist. + * (MINISCM) + * (MINISCM) Mini-Scheme is now maintained by Akira KIDA. + * (MINISCM) + * (MINISCM) This is a revised and modified version by Akira KIDA. + * (MINISCM) current version is 0.85k4 (15 May 1994) + * + */ + +#define _SCHEME_SOURCE +#include "scheme-private.h" +#ifndef WIN32 +# include <unistd.h> +#endif +#ifdef WIN32 +#define snprintf _snprintf +#endif +#if USE_DL +# include "dynload.h" +#endif +#if USE_MATH +# include <math.h> +#endif + +#include <assert.h> +#include <limits.h> +#include <float.h> +#include <ctype.h> + +#if USE_STRCASECMP +#include <strings.h> +# ifndef __APPLE__ +# define stricmp strcasecmp +# endif +#endif + +/* Used for documentation purposes, to signal functions in 'interface' */ +#define INTERFACE + +#define TOK_EOF (-1) +#define TOK_LPAREN 0 +#define TOK_RPAREN 1 +#define TOK_DOT 2 +#define TOK_ATOM 3 +#define TOK_QUOTE 4 +#define TOK_COMMENT 5 +#define TOK_DQUOTE 6 +#define TOK_BQUOTE 7 +#define TOK_COMMA 8 +#define TOK_ATMARK 9 +#define TOK_SHARP 10 +#define TOK_SHARP_CONST 11 +#define TOK_VEC 12 + +#define BACKQUOTE '`' +#define DELIMITERS "()\";\f\t\v\n\r " + +/* + * Basic memory allocation units + */ + +#define banner "TinyScheme 1.41" + +#include <string.h> +#include <stddef.h> +#include <stdlib.h> + +#ifdef __APPLE__ +static int stricmp(const char *s1, const char *s2) +{ + unsigned char c1, c2; + do { + c1 = tolower(*s1); + c2 = tolower(*s2); + if (c1 < c2) + return -1; + else if (c1 > c2) + return 1; + s1++, s2++; + } while (c1 != 0); + return 0; +} +#endif /* __APPLE__ */ + +#if USE_STRLWR +static const char *strlwr(char *s) { + const char *p=s; + while(*s) { + *s=tolower(*s); + s++; + } + return p; +} +#endif + +#ifndef prompt +# define prompt "ts> " +#endif + +#ifndef InitFile +# define InitFile "init.scm" +#endif + +#ifndef FIRST_CELLSEGS +# define FIRST_CELLSEGS 3 +#endif + +enum scheme_types { + T_STRING=1, + T_NUMBER=2, + T_SYMBOL=3, + T_PROC=4, + T_PAIR=5, + T_CLOSURE=6, + T_CONTINUATION=7, + T_FOREIGN=8, + T_CHARACTER=9, + T_PORT=10, + T_VECTOR=11, + T_MACRO=12, + T_PROMISE=13, + T_ENVIRONMENT=14, + T_FOREIGN_OBJECT=15, + T_BOOLEAN=16, + T_NIL=17, + T_EOF_OBJ=18, + T_SINK=19, + T_LAST_SYSTEM_TYPE=19 +}; + +static const char * +type_to_string (enum scheme_types typ) +{ + switch (typ) + { + case T_STRING: return "string"; + case T_NUMBER: return "number"; + case T_SYMBOL: return "symbol"; + case T_PROC: return "proc"; + case T_PAIR: return "pair"; + case T_CLOSURE: return "closure"; + case T_CONTINUATION: return "configuration"; + case T_FOREIGN: return "foreign"; + case T_CHARACTER: return "character"; + case T_PORT: return "port"; + case T_VECTOR: return "vector"; + case T_MACRO: return "macro"; + case T_PROMISE: return "promise"; + case T_ENVIRONMENT: return "environment"; + case T_FOREIGN_OBJECT: return "foreign object"; + case T_BOOLEAN: return "boolean"; + case T_NIL: return "nil"; + case T_EOF_OBJ: return "eof object"; + case T_SINK: return "sink"; + } + assert (! "not reached"); +} + +/* ADJ is enough slack to align cells in a TYPE_BITS-bit boundary */ +#define ADJ 32 +#define TYPE_BITS 5 +#define T_MASKTYPE 31 /* 0000000000011111 */ +#define T_SYNTAX 4096 /* 0001000000000000 */ +#define T_IMMUTABLE 8192 /* 0010000000000000 */ +#define T_ATOM 16384 /* 0100000000000000 */ /* only for gc */ +#define CLRATOM 49151 /* 1011111111111111 */ /* only for gc */ +#define MARK 32768 /* 1000000000000000 */ +#define UNMARK 32767 /* 0111111111111111 */ + + +static num num_add(num a, num b); +static num num_mul(num a, num b); +static num num_div(num a, num b); +static num num_intdiv(num a, num b); +static num num_sub(num a, num b); +static num num_rem(num a, num b); +static num num_mod(num a, num b); +static int num_eq(num a, num b); +static int num_gt(num a, num b); +static int num_ge(num a, num b); +static int num_lt(num a, num b); +static int num_le(num a, num b); + +#if USE_MATH +static double round_per_R5RS(double x); +#endif +static int is_zero_double(double x); +static INLINE int num_is_integer(pointer p) { + return ((p)->_object._number.is_fixnum); +} + +static num num_zero; +static num num_one; + +/* macros for cell operations */ +#define typeflag(p) ((p)->_flag) +#define type(p) (typeflag(p)&T_MASKTYPE) + +INTERFACE INLINE int is_string(pointer p) { return (type(p)==T_STRING); } +#define strvalue(p) ((p)->_object._string._svalue) +#define strlength(p) ((p)->_object._string._length) + +INTERFACE static int is_list(scheme *sc, pointer p); +INTERFACE INLINE int is_vector(pointer p) { return (type(p)==T_VECTOR); } +INTERFACE static void fill_vector(pointer vec, pointer obj); +INTERFACE static pointer vector_elem(pointer vec, int ielem); +INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a); +INTERFACE INLINE int is_number(pointer p) { return (type(p)==T_NUMBER); } +INTERFACE INLINE int is_integer(pointer p) { + if (!is_number(p)) + return 0; + if (num_is_integer(p) || (double)ivalue(p) == rvalue(p)) + return 1; + return 0; +} + +INTERFACE INLINE int is_real(pointer p) { + return is_number(p) && (!(p)->_object._number.is_fixnum); +} + +INTERFACE INLINE int is_character(pointer p) { return (type(p)==T_CHARACTER); } +INTERFACE INLINE char *string_value(pointer p) { return strvalue(p); } +INLINE num nvalue(pointer p) { return ((p)->_object._number); } +INTERFACE long ivalue(pointer p) { return (num_is_integer(p)?(p)->_object._number.value.ivalue:(long)(p)->_object._number.value.rvalue); } +INTERFACE double rvalue(pointer p) { return (!num_is_integer(p)?(p)->_object._number.value.rvalue:(double)(p)->_object._number.value.ivalue); } +#define ivalue_unchecked(p) ((p)->_object._number.value.ivalue) +#define rvalue_unchecked(p) ((p)->_object._number.value.rvalue) +#define set_num_integer(p) (p)->_object._number.is_fixnum=1; +#define set_num_real(p) (p)->_object._number.is_fixnum=0; +INTERFACE long charvalue(pointer p) { return ivalue_unchecked(p); } + +INTERFACE INLINE int is_port(pointer p) { return (type(p)==T_PORT); } +INTERFACE INLINE int is_inport(pointer p) { return is_port(p) && p->_object._port->kind & port_input; } +INTERFACE INLINE int is_outport(pointer p) { return is_port(p) && p->_object._port->kind & port_output; } + +INTERFACE INLINE int is_pair(pointer p) { return (type(p)==T_PAIR); } +#define car(p) ((p)->_object._cons._car) +#define cdr(p) ((p)->_object._cons._cdr) +INTERFACE pointer pair_car(pointer p) { return car(p); } +INTERFACE pointer pair_cdr(pointer p) { return cdr(p); } +INTERFACE pointer set_car(pointer p, pointer q) { return car(p)=q; } +INTERFACE pointer set_cdr(pointer p, pointer q) { return cdr(p)=q; } + +INTERFACE INLINE int is_symbol(pointer p) { return (type(p)==T_SYMBOL); } +INTERFACE INLINE char *symname(pointer p) { return strvalue(car(p)); } +#if USE_PLIST +SCHEME_EXPORT INLINE int hasprop(pointer p) { return (typeflag(p)&T_SYMBOL); } +#define symprop(p) cdr(p) +#endif + +INTERFACE INLINE int is_syntax(pointer p) { return (typeflag(p)&T_SYNTAX); } +INTERFACE INLINE int is_proc(pointer p) { return (type(p)==T_PROC); } +INTERFACE INLINE int is_foreign(pointer p) { return (type(p)==T_FOREIGN); } +INTERFACE INLINE char *syntaxname(pointer p) { return strvalue(car(p)); } +#define procnum(p) ivalue(p) +static const char *procname(pointer x); + +INTERFACE INLINE int is_closure(pointer p) { return (type(p)==T_CLOSURE); } +INTERFACE INLINE int is_macro(pointer p) { return (type(p)==T_MACRO); } +INTERFACE INLINE pointer closure_code(pointer p) { return car(p); } +INTERFACE INLINE pointer closure_env(pointer p) { return cdr(p); } + +INTERFACE INLINE int is_continuation(pointer p) { return (type(p)==T_CONTINUATION); } +#define cont_dump(p) cdr(p) + +INTERFACE INLINE int is_foreign_object(pointer p) { return (type(p)==T_FOREIGN_OBJECT); } +INTERFACE const foreign_object_vtable *get_foreign_object_vtable(pointer p) { + return p->_object._foreign_object._vtable; +} +INTERFACE void *get_foreign_object_data(pointer p) { + return p->_object._foreign_object._data; +} + +/* To do: promise should be forced ONCE only */ +INTERFACE INLINE int is_promise(pointer p) { return (type(p)==T_PROMISE); } + +INTERFACE INLINE int is_environment(pointer p) { return (type(p)==T_ENVIRONMENT); } +#define setenvironment(p) typeflag(p) = T_ENVIRONMENT + +#define is_atom(p) (typeflag(p)&T_ATOM) +#define setatom(p) typeflag(p) |= T_ATOM +#define clratom(p) typeflag(p) &= CLRATOM + +#define is_mark(p) (typeflag(p)&MARK) +#define setmark(p) typeflag(p) |= MARK +#define clrmark(p) typeflag(p) &= UNMARK + +INTERFACE INLINE int is_immutable(pointer p) { return (typeflag(p)&T_IMMUTABLE); } +/*#define setimmutable(p) typeflag(p) |= T_IMMUTABLE*/ +INTERFACE INLINE void setimmutable(pointer p) { typeflag(p) |= T_IMMUTABLE; } + +#define caar(p) car(car(p)) +#define cadr(p) car(cdr(p)) +#define cdar(p) cdr(car(p)) +#define cddr(p) cdr(cdr(p)) +#define cadar(p) car(cdr(car(p))) +#define caddr(p) car(cdr(cdr(p))) +#define cdaar(p) cdr(car(car(p))) +#define cadaar(p) car(cdr(car(car(p)))) +#define cadddr(p) car(cdr(cdr(cdr(p)))) +#define cddddr(p) cdr(cdr(cdr(cdr(p)))) + +#if USE_CHAR_CLASSIFIERS +static INLINE int Cisalpha(int c) { return isascii(c) && isalpha(c); } +static INLINE int Cisdigit(int c) { return isascii(c) && isdigit(c); } +static INLINE int Cisspace(int c) { return isascii(c) && isspace(c); } +static INLINE int Cisupper(int c) { return isascii(c) && isupper(c); } +static INLINE int Cislower(int c) { return isascii(c) && islower(c); } +#endif + +#if USE_ASCII_NAMES +static const char *charnames[32]={ + "nul", + "soh", + "stx", + "etx", + "eot", + "enq", + "ack", + "bel", + "bs", + "ht", + "lf", + "vt", + "ff", + "cr", + "so", + "si", + "dle", + "dc1", + "dc2", + "dc3", + "dc4", + "nak", + "syn", + "etb", + "can", + "em", + "sub", + "esc", + "fs", + "gs", + "rs", + "us" +}; + +static int is_ascii_name(const char *name, int *pc) { + int i; + for(i=0; i<32; i++) { + if(stricmp(name,charnames[i])==0) { + *pc=i; + return 1; + } + } + if(stricmp(name,"del")==0) { + *pc=127; + return 1; + } + return 0; +} + +#endif + +static int file_push(scheme *sc, const char *fname); +static void file_pop(scheme *sc); +static int file_interactive(scheme *sc); +static INLINE int is_one_of(char *s, int c); +static int alloc_cellseg(scheme *sc, int n); +static long binary_decode(const char *s); +static INLINE pointer get_cell(scheme *sc, pointer a, pointer b); +static pointer _get_cell(scheme *sc, pointer a, pointer b); +static pointer reserve_cells(scheme *sc, int n); +static pointer get_consecutive_cells(scheme *sc, int n); +static pointer find_consecutive_cells(scheme *sc, int n); +static void finalize_cell(scheme *sc, pointer a); +static int count_consecutive_cells(pointer x, int needed); +static pointer find_slot_in_env(scheme *sc, pointer env, pointer sym, int all); +static pointer mk_number(scheme *sc, num n); +static char *store_string(scheme *sc, int len, const char *str, char fill); +static pointer mk_vector(scheme *sc, int len); +static pointer mk_atom(scheme *sc, char *q); +static pointer mk_sharp_const(scheme *sc, char *name); +static pointer mk_port(scheme *sc, port *p); +static pointer port_from_filename(scheme *sc, const char *fn, int prop); +static pointer port_from_file(scheme *sc, FILE *, int prop); +static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop); +static port *port_rep_from_filename(scheme *sc, const char *fn, int prop); +static port *port_rep_from_file(scheme *sc, FILE *, int prop); +static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop); +static void port_close(scheme *sc, pointer p, int flag); +static void mark(pointer a); +static void gc(scheme *sc, pointer a, pointer b); +static int basic_inchar(port *pt); +static int inchar(scheme *sc); +static void backchar(scheme *sc, int c); +static char *readstr_upto(scheme *sc, char *delim); +static pointer readstrexp(scheme *sc); +static INLINE int skipspace(scheme *sc); +static int token(scheme *sc); +static void printslashstring(scheme *sc, char *s, int len); +static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen); +static void printatom(scheme *sc, pointer l, int f); +static pointer mk_proc(scheme *sc, enum scheme_opcodes op); +static pointer mk_closure(scheme *sc, pointer c, pointer e); +static pointer mk_continuation(scheme *sc, pointer d); +static pointer reverse(scheme *sc, pointer a); +static pointer reverse_in_place(scheme *sc, pointer term, pointer list); +static pointer revappend(scheme *sc, pointer a, pointer b); +static void dump_stack_mark(scheme *); +static pointer opexe_0(scheme *sc, enum scheme_opcodes op); +static pointer opexe_1(scheme *sc, enum scheme_opcodes op); +static pointer opexe_2(scheme *sc, enum scheme_opcodes op); +static pointer opexe_3(scheme *sc, enum scheme_opcodes op); +static pointer opexe_4(scheme *sc, enum scheme_opcodes op); +static pointer opexe_5(scheme *sc, enum scheme_opcodes op); +static pointer opexe_6(scheme *sc, enum scheme_opcodes op); +static void Eval_Cycle(scheme *sc, enum scheme_opcodes op); +static void assign_syntax(scheme *sc, char *name); +static int syntaxnum(pointer p); +static void assign_proc(scheme *sc, enum scheme_opcodes, char *name); + +#define num_ivalue(n) (n.is_fixnum?(n).value.ivalue:(long)(n).value.rvalue) +#define num_rvalue(n) (!n.is_fixnum?(n).value.rvalue:(double)(n).value.ivalue) + +static num num_add(num a, num b) { + num ret; + ret.is_fixnum=a.is_fixnum && b.is_fixnum; + if(ret.is_fixnum) { + ret.value.ivalue= a.value.ivalue+b.value.ivalue; + } else { + ret.value.rvalue=num_rvalue(a)+num_rvalue(b); + } + return ret; +} + +static num num_mul(num a, num b) { + num ret; + ret.is_fixnum=a.is_fixnum && b.is_fixnum; + if(ret.is_fixnum) { + ret.value.ivalue= a.value.ivalue*b.value.ivalue; + } else { + ret.value.rvalue=num_rvalue(a)*num_rvalue(b); + } + return ret; +} + +static num num_div(num a, num b) { + num ret; + ret.is_fixnum=a.is_fixnum && b.is_fixnum && a.value.ivalue%b.value.ivalue==0; + if(ret.is_fixnum) { + ret.value.ivalue= a.value.ivalue/b.value.ivalue; + } else { + ret.value.rvalue=num_rvalue(a)/num_rvalue(b); + } + return ret; +} + +static num num_intdiv(num a, num b) { + num ret; + ret.is_fixnum=a.is_fixnum && b.is_fixnum; + if(ret.is_fixnum) { + ret.value.ivalue= a.value.ivalue/b.value.ivalue; + } else { + ret.value.rvalue=num_rvalue(a)/num_rvalue(b); + } + return ret; +} + +static num num_sub(num a, num b) { + num ret; + ret.is_fixnum=a.is_fixnum && b.is_fixnum; + if(ret.is_fixnum) { + ret.value.ivalue= a.value.ivalue-b.value.ivalue; + } else { + ret.value.rvalue=num_rvalue(a)-num_rvalue(b); + } + return ret; +} + +static num num_rem(num a, num b) { + num ret; + long e1, e2, res; + ret.is_fixnum=a.is_fixnum && b.is_fixnum; + e1=num_ivalue(a); + e2=num_ivalue(b); + res=e1%e2; + /* remainder should have same sign as second operand */ + if (res > 0) { + if (e1 < 0) { + res -= labs(e2); + } + } else if (res < 0) { + if (e1 > 0) { + res += labs(e2); + } + } + ret.value.ivalue=res; + return ret; +} + +static num num_mod(num a, num b) { + num ret; + long e1, e2, res; + ret.is_fixnum=a.is_fixnum && b.is_fixnum; + e1=num_ivalue(a); + e2=num_ivalue(b); + res=e1%e2; + /* modulo should have same sign as second operand */ + if (res * e2 < 0) { + res += e2; + } + ret.value.ivalue=res; + return ret; +} + +static int num_eq(num a, num b) { + int ret; + int is_fixnum=a.is_fixnum && b.is_fixnum; + if(is_fixnum) { + ret= a.value.ivalue==b.value.ivalue; + } else { + ret=num_rvalue(a)==num_rvalue(b); + } + return ret; +} + + +static int num_gt(num a, num b) { + int ret; + int is_fixnum=a.is_fixnum && b.is_fixnum; + if(is_fixnum) { + ret= a.value.ivalue>b.value.ivalue; + } else { + ret=num_rvalue(a)>num_rvalue(b); + } + return ret; +} + +static int num_ge(num a, num b) { + return !num_lt(a,b); +} + +static int num_lt(num a, num b) { + int ret; + int is_fixnum=a.is_fixnum && b.is_fixnum; + if(is_fixnum) { + ret= a.value.ivalue<b.value.ivalue; + } else { + ret=num_rvalue(a)<num_rvalue(b); + } + return ret; +} + +static int num_le(num a, num b) { + return !num_gt(a,b); +} + +#if USE_MATH +/* Round to nearest. Round to even if midway */ +static double round_per_R5RS(double x) { + double fl=floor(x); + double ce=ceil(x); + double dfl=x-fl; + double dce=ce-x; + if(dfl>dce) { + return ce; + } else if(dfl<dce) { + return fl; + } else { + if(fmod(fl,2.0)==0.0) { /* I imagine this holds */ + return fl; + } else { + return ce; + } + } +} +#endif + +static int is_zero_double(double x) { + return x<DBL_MIN && x>-DBL_MIN; +} + +static long binary_decode(const char *s) { + long x=0; + + while(*s!=0 && (*s=='1' || *s=='0')) { + x<<=1; + x+=*s-'0'; + s++; + } + + return x; +} + +/* allocate new cell segment */ +static int alloc_cellseg(scheme *sc, int n) { + pointer newp; + pointer last; + pointer p; + char *cp; + long i; + int k; + int adj=ADJ; + + if(adj<sizeof(struct cell)) { + adj=sizeof(struct cell); + } + + for (k = 0; k < n; k++) { + if (sc->last_cell_seg >= CELL_NSEGMENT - 1) + return k; + cp = (char*) sc->malloc(CELL_SEGSIZE * sizeof(struct cell)+adj); + if (cp == 0) + return k; + i = ++sc->last_cell_seg ; + sc->alloc_seg[i] = cp; + /* adjust in TYPE_BITS-bit boundary */ + if(((unsigned long)cp)%adj!=0) { + cp=(char*)(adj*((unsigned long)cp/adj+1)); + } + /* insert new segment in address order */ + newp=(pointer)cp; + sc->cell_seg[i] = newp; + while (i > 0 && sc->cell_seg[i - 1] > sc->cell_seg[i]) { + p = sc->cell_seg[i]; + sc->cell_seg[i] = sc->cell_seg[i - 1]; + sc->cell_seg[--i] = p; + } + sc->fcells += CELL_SEGSIZE; + last = newp + CELL_SEGSIZE - 1; + for (p = newp; p <= last; p++) { + typeflag(p) = 0; + cdr(p) = p + 1; + car(p) = sc->NIL; + } + /* insert new cells in address order on free list */ + if (sc->free_cell == sc->NIL || p < sc->free_cell) { + cdr(last) = sc->free_cell; + sc->free_cell = newp; + } else { + p = sc->free_cell; + while (cdr(p) != sc->NIL && newp > cdr(p)) + p = cdr(p); + cdr(last) = cdr(p); + cdr(p) = newp; + } + } + return n; +} + +static INLINE pointer get_cell_x(scheme *sc, pointer a, pointer b) { + if (sc->free_cell != sc->NIL) { + pointer x = sc->free_cell; + sc->free_cell = cdr(x); + --sc->fcells; + return (x); + } + return _get_cell (sc, a, b); +} + + +/* get new cell. parameter a, b is marked by gc. */ +static pointer _get_cell(scheme *sc, pointer a, pointer b) { + pointer x; + + if(sc->no_memory) { + return sc->sink; + } + + if (sc->free_cell == sc->NIL) { + const int min_to_be_recovered = sc->last_cell_seg*8; + gc(sc,a, b); + if (sc->fcells < min_to_be_recovered + || sc->free_cell == sc->NIL) { + /* if only a few recovered, get more to avoid fruitless gc's */ + if (!alloc_cellseg(sc,1) && sc->free_cell == sc->NIL) { + sc->no_memory=1; + return sc->sink; + } + } + } + x = sc->free_cell; + sc->free_cell = cdr(x); + --sc->fcells; + return (x); +} + +/* make sure that there is a given number of cells free */ +static pointer reserve_cells(scheme *sc, int n) { + if(sc->no_memory) { + return sc->NIL; + } + + /* Are there enough cells available? */ + if (sc->fcells < n) { + /* If not, try gc'ing some */ + gc(sc, sc->NIL, sc->NIL); + if (sc->fcells < n) { + /* If there still aren't, try getting more heap */ + if (!alloc_cellseg(sc,1)) { + sc->no_memory=1; + return sc->NIL; + } + } + if (sc->fcells < n) { + /* If all fail, report failure */ + sc->no_memory=1; + return sc->NIL; + } + } + return (sc->T); +} + +static pointer get_consecutive_cells(scheme *sc, int n) { + pointer x; + + if(sc->no_memory) { return sc->sink; } + + /* Are there any cells available? */ + x=find_consecutive_cells(sc,n); + if (x != sc->NIL) { return x; } + + /* If not, try gc'ing some */ + gc(sc, sc->NIL, sc->NIL); + x=find_consecutive_cells(sc,n); + if (x != sc->NIL) { return x; } + + /* If there still aren't, try getting more heap */ + if (!alloc_cellseg(sc,1)) + { + sc->no_memory=1; + return sc->sink; + } + + x=find_consecutive_cells(sc,n); + if (x != sc->NIL) { return x; } + + /* If all fail, report failure */ + sc->no_memory=1; + return sc->sink; +} + +static int count_consecutive_cells(pointer x, int needed) { + int n=1; + while(cdr(x)==x+1) { + x=cdr(x); + n++; + if(n>needed) return n; + } + return n; +} + +static pointer find_consecutive_cells(scheme *sc, int n) { + pointer *pp; + int cnt; + + pp=&sc->free_cell; + while(*pp!=sc->NIL) { + cnt=count_consecutive_cells(*pp,n); + if(cnt>=n) { + pointer x=*pp; + *pp=cdr(*pp+n-1); + sc->fcells -= n; + return x; + } + pp=&cdr(*pp+cnt-1); + } + return sc->NIL; +} + +/* To retain recent allocs before interpreter knows about them - + Tehom */ + +static void push_recent_alloc(scheme *sc, pointer recent, pointer extra) +{ + pointer holder = get_cell_x(sc, recent, extra); + typeflag(holder) = T_PAIR | T_IMMUTABLE; + car(holder) = recent; + cdr(holder) = car(sc->sink); + car(sc->sink) = holder; +} + + +static pointer get_cell(scheme *sc, pointer a, pointer b) +{ + pointer cell = get_cell_x(sc, a, b); + /* For right now, include "a" and "b" in "cell" so that gc doesn't + think they are garbage. */ + /* Tentatively record it as a pair so gc understands it. */ + typeflag(cell) = T_PAIR; + car(cell) = a; + cdr(cell) = b; + push_recent_alloc(sc, cell, sc->NIL); + return cell; +} + +static pointer get_vector_object(scheme *sc, int len, pointer init) +{ + pointer cells = get_consecutive_cells(sc,len/2+len%2+1); + if(sc->no_memory) { return sc->sink; } + /* Record it as a vector so that gc understands it. */ + typeflag(cells) = (T_VECTOR | T_ATOM); + ivalue_unchecked(cells)=len; + set_num_integer(cells); + fill_vector(cells,init); + push_recent_alloc(sc, cells, sc->NIL); + return cells; +} + +static INLINE void ok_to_freely_gc(scheme *sc) +{ + car(sc->sink) = sc->NIL; +} + + +#if defined TSGRIND +static void check_cell_alloced(pointer p, int expect_alloced) +{ + /* Can't use putstr(sc,str) because callers have no access to + sc. */ + if(typeflag(p) & !expect_alloced) + { + fprintf(stderr,"Cell is already allocated!\n"); + } + if(!(typeflag(p)) & expect_alloced) + { + fprintf(stderr,"Cell is not allocated!\n"); + } + +} +static void check_range_alloced(pointer p, int n, int expect_alloced) +{ + int i; + for(i = 0;i<n;i++) + { (void)check_cell_alloced(p+i,expect_alloced); } +} + +#endif + +/* Medium level cell allocation */ + +/* get new cons cell */ +pointer _cons(scheme *sc, pointer a, pointer b, int immutable) { + pointer x = get_cell(sc,a, b); + + typeflag(x) = T_PAIR; + if(immutable) { + setimmutable(x); + } + car(x) = a; + cdr(x) = b; + return (x); +} + +/* ========== oblist implementation ========== */ + +#ifndef USE_OBJECT_LIST + +static int hash_fn(const char *key, int table_size); + +static pointer oblist_initial_value(scheme *sc) +{ + return mk_vector(sc, 461); /* probably should be bigger */ +} + +/* returns the new symbol */ +static pointer oblist_add_by_name(scheme *sc, const char *name) +{ + pointer x; + int location; + + x = immutable_cons(sc, mk_string(sc, name), sc->NIL); + typeflag(x) = T_SYMBOL; + setimmutable(car(x)); + + location = hash_fn(name, ivalue_unchecked(sc->oblist)); + set_vector_elem(sc->oblist, location, + immutable_cons(sc, x, vector_elem(sc->oblist, location))); + return x; +} + +static INLINE pointer oblist_find_by_name(scheme *sc, const char *name) +{ + int location; + pointer x; + char *s; + + location = hash_fn(name, ivalue_unchecked(sc->oblist)); + for (x = vector_elem(sc->oblist, location); x != sc->NIL; x = cdr(x)) { + s = symname(car(x)); + /* case-insensitive, per R5RS section 2. */ + if(stricmp(name, s) == 0) { + return car(x); + } + } + return sc->NIL; +} + +static pointer oblist_all_symbols(scheme *sc) +{ + int i; + pointer x; + pointer ob_list = sc->NIL; + + for (i = 0; i < ivalue_unchecked(sc->oblist); i++) { + for (x = vector_elem(sc->oblist, i); x != sc->NIL; x = cdr(x)) { + ob_list = cons(sc, x, ob_list); + } + } + return ob_list; +} + +#else + +static pointer oblist_initial_value(scheme *sc) +{ + return sc->NIL; +} + +static INLINE pointer oblist_find_by_name(scheme *sc, const char *name) +{ + pointer x; + char *s; + + for (x = sc->oblist; x != sc->NIL; x = cdr(x)) { + s = symname(car(x)); + /* case-insensitive, per R5RS section 2. */ + if(stricmp(name, s) == 0) { + return car(x); + } + } + return sc->NIL; +} + +/* returns the new symbol */ +static pointer oblist_add_by_name(scheme *sc, const char *name) +{ + pointer x; + + x = immutable_cons(sc, mk_string(sc, name), sc->NIL); + typeflag(x) = T_SYMBOL; + setimmutable(car(x)); + sc->oblist = immutable_cons(sc, x, sc->oblist); + return x; +} +static pointer oblist_all_symbols(scheme *sc) +{ + return sc->oblist; +} + +#endif + +static pointer mk_port(scheme *sc, port *p) { + pointer x = get_cell(sc, sc->NIL, sc->NIL); + + typeflag(x) = T_PORT|T_ATOM; + x->_object._port=p; + return (x); +} + +pointer mk_foreign_func(scheme *sc, foreign_func f) { + pointer x = get_cell(sc, sc->NIL, sc->NIL); + + typeflag(x) = (T_FOREIGN | T_ATOM); + x->_object._ff=f; + return (x); +} + +pointer mk_foreign_object(scheme *sc, const foreign_object_vtable *vtable, void *data) { + pointer x = get_cell(sc, sc->NIL, sc->NIL); + + typeflag(x) = (T_FOREIGN_OBJECT | T_ATOM); + x->_object._foreign_object._vtable=vtable; + x->_object._foreign_object._data = data; + return (x); +} + +INTERFACE pointer mk_character(scheme *sc, int c) { + pointer x = get_cell(sc,sc->NIL, sc->NIL); + + typeflag(x) = (T_CHARACTER | T_ATOM); + ivalue_unchecked(x)= c; + set_num_integer(x); + return (x); +} + +/* get number atom (integer) */ +INTERFACE pointer mk_integer(scheme *sc, long n) { + pointer x = get_cell(sc,sc->NIL, sc->NIL); + + typeflag(x) = (T_NUMBER | T_ATOM); + ivalue_unchecked(x)= n; + set_num_integer(x); + return (x); +} + +INTERFACE pointer mk_real(scheme *sc, double n) { + pointer x = get_cell(sc,sc->NIL, sc->NIL); + + typeflag(x) = (T_NUMBER | T_ATOM); + rvalue_unchecked(x)= n; + set_num_real(x); + return (x); +} + +static pointer mk_number(scheme *sc, num n) { + if(n.is_fixnum) { + return mk_integer(sc,n.value.ivalue); + } else { + return mk_real(sc,n.value.rvalue); + } +} + +/* allocate name to string area */ +static char *store_string(scheme *sc, int len_str, const char *str, char fill) { + char *q; + + q=(char*)sc->malloc(len_str+1); + if(q==0) { + sc->no_memory=1; + return sc->strbuff; + } + if(str!=0) { + memcpy (q, str, len_str); + q[len_str]=0; + } else { + memset(q, fill, len_str); + q[len_str]=0; + } + return (q); +} + +/* get new string */ +INTERFACE pointer mk_string(scheme *sc, const char *str) { + return mk_counted_string(sc,str,strlen(str)); +} + +INTERFACE pointer mk_counted_string(scheme *sc, const char *str, int len) { + pointer x = get_cell(sc, sc->NIL, sc->NIL); + typeflag(x) = (T_STRING | T_ATOM); + strvalue(x) = store_string(sc,len,str,0); + strlength(x) = len; + return (x); +} + +INTERFACE pointer mk_empty_string(scheme *sc, int len, char fill) { + pointer x = get_cell(sc, sc->NIL, sc->NIL); + typeflag(x) = (T_STRING | T_ATOM); + strvalue(x) = store_string(sc,len,0,fill); + strlength(x) = len; + return (x); +} + +INTERFACE static pointer mk_vector(scheme *sc, int len) +{ return get_vector_object(sc,len,sc->NIL); } + +INTERFACE static void fill_vector(pointer vec, pointer obj) { + int i; + int n = ivalue(vec)/2+ivalue(vec)%2; + for(i=0; i < n; i++) { + typeflag(vec+1+i) = T_PAIR; + setimmutable(vec+1+i); + car(vec+1+i)=obj; + cdr(vec+1+i)=obj; + } +} + +INTERFACE static pointer vector_elem(pointer vec, int ielem) { + int n=ielem/2; + if(ielem%2==0) { + return car(vec+1+n); + } else { + return cdr(vec+1+n); + } +} + +INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a) { + int n=ielem/2; + if(ielem%2==0) { + return car(vec+1+n)=a; + } else { + return cdr(vec+1+n)=a; + } +} + +/* get new symbol */ +INTERFACE pointer mk_symbol(scheme *sc, const char *name) { + pointer x; + + /* first check oblist */ + x = oblist_find_by_name(sc, name); + if (x != sc->NIL) { + return (x); + } else { + x = oblist_add_by_name(sc, name); + return (x); + } +} + +INTERFACE pointer gensym(scheme *sc) { + pointer x; + char name[40]; + + for(; sc->gensym_cnt<LONG_MAX; sc->gensym_cnt++) { + snprintf(name,40,"gensym-%ld",sc->gensym_cnt); + + /* first check oblist */ + x = oblist_find_by_name(sc, name); + + if (x != sc->NIL) { + continue; + } else { + x = oblist_add_by_name(sc, name); + return (x); + } + } + + return sc->NIL; +} + +/* double the size of the string buffer */ +static int expand_strbuff(scheme *sc) { + size_t new_size = sc->strbuff_size * 2; + char *new_buffer = sc->malloc(new_size); + if (new_buffer == 0) { + sc->no_memory = 1; + return 1; + } + memcpy(new_buffer, sc->strbuff, sc->strbuff_size); + sc->free(sc->strbuff); + sc->strbuff = new_buffer; + sc->strbuff_size = new_size; + return 0; +} + +/* make symbol or number atom from string */ +static pointer mk_atom(scheme *sc, char *q) { + char c, *p; + int has_dec_point=0; + int has_fp_exp = 0; + +#if USE_COLON_HOOK + if((p=strstr(q,"::"))!=0) { + *p=0; + return cons(sc, sc->COLON_HOOK, + cons(sc, + cons(sc, + sc->QUOTE, + cons(sc, mk_atom(sc,p+2), sc->NIL)), + cons(sc, mk_symbol(sc,strlwr(q)), sc->NIL))); + } +#endif + + p = q; + c = *p++; + if ((c == '+') || (c == '-')) { + c = *p++; + if (c == '.') { + has_dec_point=1; + c = *p++; + } + if (!isdigit(c)) { + return (mk_symbol(sc, strlwr(q))); + } + } else if (c == '.') { + has_dec_point=1; + c = *p++; + if (!isdigit(c)) { + return (mk_symbol(sc, strlwr(q))); + } + } else if (!isdigit(c)) { + return (mk_symbol(sc, strlwr(q))); + } + + for ( ; (c = *p) != 0; ++p) { + if (!isdigit(c)) { + if(c=='.') { + if(!has_dec_point) { + has_dec_point=1; + continue; + } + } + else if ((c == 'e') || (c == 'E')) { + if(!has_fp_exp) { + has_dec_point = 1; /* decimal point illegal + from now on */ + p++; + if ((*p == '-') || (*p == '+') || isdigit(*p)) { + continue; + } + } + } + return (mk_symbol(sc, strlwr(q))); + } + } + if(has_dec_point) { + return mk_real(sc,atof(q)); + } + return (mk_integer(sc, atol(q))); +} + +/* make constant */ +static pointer mk_sharp_const(scheme *sc, char *name) { + long x; + char tmp[STRBUFFSIZE]; + + if (!strcmp(name, "t")) + return (sc->T); + else if (!strcmp(name, "f")) + return (sc->F); + else if (*name == 'o') {/* #o (octal) */ + snprintf(tmp, STRBUFFSIZE, "0%s", name+1); + sscanf(tmp, "%lo", (long unsigned *)&x); + return (mk_integer(sc, x)); + } else if (*name == 'd') { /* #d (decimal) */ + sscanf(name+1, "%ld", (long int *)&x); + return (mk_integer(sc, x)); + } else if (*name == 'x') { /* #x (hex) */ + snprintf(tmp, STRBUFFSIZE, "0x%s", name+1); + sscanf(tmp, "%lx", (long unsigned *)&x); + return (mk_integer(sc, x)); + } else if (*name == 'b') { /* #b (binary) */ + x = binary_decode(name+1); + return (mk_integer(sc, x)); + } else if (*name == '\\') { /* #\w (character) */ + int c=0; + if(stricmp(name+1,"space")==0) { + c=' '; + } else if(stricmp(name+1,"newline")==0) { + c='\n'; + } else if(stricmp(name+1,"return")==0) { + c='\r'; + } else if(stricmp(name+1,"tab")==0) { + c='\t'; + } else if(name[1]=='x' && name[2]!=0) { + int c1=0; + if(sscanf(name+2,"%x",(unsigned int *)&c1)==1 && c1 < UCHAR_MAX) { + c=c1; + } else { + return sc->NIL; + } +#if USE_ASCII_NAMES + } else if(is_ascii_name(name+1,&c)) { + /* nothing */ +#endif + } else if(name[2]==0) { + c=name[1]; + } else { + return sc->NIL; + } + return mk_character(sc,c); + } else + return (sc->NIL); +} + +/* ========== garbage collector ========== */ + +/*-- + * We use algorithm E (Knuth, The Art of Computer Programming Vol.1, + * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm, + * for marking. + */ +static void mark(pointer a) { + pointer t, q, p; + + t = (pointer) 0; + p = a; +E2: setmark(p); + if(is_vector(p)) { + int i; + int n = ivalue_unchecked(p)/2+ivalue_unchecked(p)%2; + for(i=0; i < n; i++) { + /* Vector cells will be treated like ordinary cells */ + mark(p+1+i); + } + } + if (is_atom(p)) + goto E6; + /* E4: down car */ + q = car(p); + if (q && !is_mark(q)) { + setatom(p); /* a note that we have moved car */ + car(p) = t; + t = p; + p = q; + goto E2; + } +E5: q = cdr(p); /* down cdr */ + if (q && !is_mark(q)) { + cdr(p) = t; + t = p; + p = q; + goto E2; + } +E6: /* up. Undo the link switching from steps E4 and E5. */ + if (!t) + return; + q = t; + if (is_atom(q)) { + clratom(q); + t = car(q); + car(q) = p; + p = q; + goto E5; + } else { + t = cdr(q); + cdr(q) = p; + p = q; + goto E6; + } +} + +/* garbage collection. parameter a, b is marked. */ +static void gc(scheme *sc, pointer a, pointer b) { + pointer p; + int i; + + if(sc->gc_verbose) { + putstr(sc, "gc..."); + } + + /* mark system globals */ + mark(sc->oblist); + mark(sc->global_env); + + /* mark current registers */ + mark(sc->args); + mark(sc->envir); + mark(sc->code); + dump_stack_mark(sc); + mark(sc->value); + mark(sc->inport); + mark(sc->save_inport); + mark(sc->outport); + mark(sc->loadport); + + /* Mark recent objects the interpreter doesn't know about yet. */ + mark(car(sc->sink)); + /* Mark any older stuff above nested C calls */ + mark(sc->c_nest); + + /* mark variables a, b */ + mark(a); + mark(b); + + /* garbage collect */ + clrmark(sc->NIL); + sc->fcells = 0; + sc->free_cell = sc->NIL; + /* free-list is kept sorted by address so as to maintain consecutive + ranges, if possible, for use with vectors. Here we scan the cells + (which are also kept sorted by address) downwards to build the + free-list in sorted order. + */ + for (i = sc->last_cell_seg; i >= 0; i--) { + p = sc->cell_seg[i] + CELL_SEGSIZE; + while (--p >= sc->cell_seg[i]) { + if (is_mark(p)) { + clrmark(p); + } else { + /* reclaim cell */ + if (typeflag(p) != 0) { + finalize_cell(sc, p); + typeflag(p) = 0; + car(p) = sc->NIL; + } + ++sc->fcells; + cdr(p) = sc->free_cell; + sc->free_cell = p; + } + } + } + + if (sc->gc_verbose) { + char msg[80]; + snprintf(msg,80,"done: %ld cells were recovered.\n", sc->fcells); + putstr(sc,msg); + } +} + +static void finalize_cell(scheme *sc, pointer a) { + if(is_string(a)) { + sc->free(strvalue(a)); + } else if(is_port(a)) { + if(a->_object._port->kind&port_file + && a->_object._port->rep.stdio.closeit) { + port_close(sc,a,port_input|port_output); + } else if (a->_object._port->kind & port_srfi6) { + sc->free(a->_object._port->rep.string.start); + } + sc->free(a->_object._port); + } else if(is_foreign_object(a)) { + a->_object._foreign_object._vtable->finalize(sc, a->_object._foreign_object._data); + } +} + +/* ========== Routines for Reading ========== */ + +static int file_push(scheme *sc, const char *fname) { + FILE *fin = NULL; + + if (sc->file_i == MAXFIL-1) + return 0; + fin=fopen(fname,"r"); + if(fin!=0) { + sc->file_i++; + sc->load_stack[sc->file_i].kind=port_file|port_input; + sc->load_stack[sc->file_i].rep.stdio.file=fin; + sc->load_stack[sc->file_i].rep.stdio.closeit=1; + sc->nesting_stack[sc->file_i]=0; + sc->loadport->_object._port=sc->load_stack+sc->file_i; + +#if SHOW_ERROR_LINE + sc->load_stack[sc->file_i].rep.stdio.curr_line = 0; + if(fname) + sc->load_stack[sc->file_i].rep.stdio.filename = store_string(sc, strlen(fname), fname, 0); +#endif + } + return fin!=0; +} + +static void file_pop(scheme *sc) { + if(sc->file_i != 0) { + sc->nesting=sc->nesting_stack[sc->file_i]; + port_close(sc,sc->loadport,port_input); + sc->file_i--; + sc->loadport->_object._port=sc->load_stack+sc->file_i; + } +} + +static int file_interactive(scheme *sc) { + return sc->file_i==0 && sc->load_stack[0].rep.stdio.file==stdin + && sc->inport->_object._port->kind&port_file; +} + +static port *port_rep_from_filename(scheme *sc, const char *fn, int prop) { + FILE *f; + char *rw; + port *pt; + if(prop==(port_input|port_output)) { + rw="a+"; + } else if(prop==port_output) { + rw="w"; + } else { + rw="r"; + } + f=fopen(fn,rw); + if(f==0) { + return 0; + } + pt=port_rep_from_file(sc,f,prop); + pt->rep.stdio.closeit=1; + +#if SHOW_ERROR_LINE + if(fn) + pt->rep.stdio.filename = store_string(sc, strlen(fn), fn, 0); + + pt->rep.stdio.curr_line = 0; +#endif + return pt; +} + +static pointer port_from_filename(scheme *sc, const char *fn, int prop) { + port *pt; + pt=port_rep_from_filename(sc,fn,prop); + if(pt==0) { + return sc->NIL; + } + return mk_port(sc,pt); +} + +static port *port_rep_from_file(scheme *sc, FILE *f, int prop) +{ + port *pt; + + pt = (port *)sc->malloc(sizeof *pt); + if (pt == NULL) { + return NULL; + } + pt->kind = port_file | prop; + pt->rep.stdio.file = f; + pt->rep.stdio.closeit = 0; + return pt; +} + +static pointer port_from_file(scheme *sc, FILE *f, int prop) { + port *pt; + pt=port_rep_from_file(sc,f,prop); + if(pt==0) { + return sc->NIL; + } + return mk_port(sc,pt); +} + +static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop) { + port *pt; + pt=(port*)sc->malloc(sizeof(port)); + if(pt==0) { + return 0; + } + pt->kind=port_string|prop; + pt->rep.string.start=start; + pt->rep.string.curr=start; + pt->rep.string.past_the_end=past_the_end; + return pt; +} + +static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop) { + port *pt; + pt=port_rep_from_string(sc,start,past_the_end,prop); + if(pt==0) { + return sc->NIL; + } + return mk_port(sc,pt); +} + +#define BLOCK_SIZE 256 + +static port *port_rep_from_scratch(scheme *sc) { + port *pt; + char *start; + pt=(port*)sc->malloc(sizeof(port)); + if(pt==0) { + return 0; + } + start=sc->malloc(BLOCK_SIZE); + if(start==0) { + return 0; + } + memset(start,' ',BLOCK_SIZE-1); + start[BLOCK_SIZE-1]='\0'; + pt->kind=port_string|port_output|port_srfi6; + pt->rep.string.start=start; + pt->rep.string.curr=start; + pt->rep.string.past_the_end=start+BLOCK_SIZE-1; + return pt; +} + +static pointer port_from_scratch(scheme *sc) { + port *pt; + pt=port_rep_from_scratch(sc); + if(pt==0) { + return sc->NIL; + } + return mk_port(sc,pt); +} + +static void port_close(scheme *sc, pointer p, int flag) { + port *pt=p->_object._port; + pt->kind&=~flag; + if((pt->kind & (port_input|port_output))==0) { + if(pt->kind&port_file) { + +#if SHOW_ERROR_LINE + /* Cleanup is here so (close-*-port) functions could work too */ + pt->rep.stdio.curr_line = 0; + + if(pt->rep.stdio.filename) + sc->free(pt->rep.stdio.filename); +#endif + + fclose(pt->rep.stdio.file); + } + pt->kind=port_free; + } +} + +/* get new character from input file */ +static int inchar(scheme *sc) { + int c; + port *pt; + + pt = sc->inport->_object._port; + if(pt->kind & port_saw_EOF) + { return EOF; } + c = basic_inchar(pt); + if(c == EOF && sc->inport == sc->loadport) { + /* Instead, set port_saw_EOF */ + pt->kind |= port_saw_EOF; + + /* file_pop(sc); */ + return EOF; + /* NOTREACHED */ + } + return c; +} + +static int basic_inchar(port *pt) { + if(pt->kind & port_file) { + return fgetc(pt->rep.stdio.file); + } else { + if(*pt->rep.string.curr == 0 || + pt->rep.string.curr == pt->rep.string.past_the_end) { + return EOF; + } else { + return *pt->rep.string.curr++; + } + } +} + +/* back character to input buffer */ +static void backchar(scheme *sc, int c) { + port *pt; + if(c==EOF) return; + pt=sc->inport->_object._port; + if(pt->kind&port_file) { + ungetc(c,pt->rep.stdio.file); + } else { + if(pt->rep.string.curr!=pt->rep.string.start) { + --pt->rep.string.curr; + } + } +} + +static int realloc_port_string(scheme *sc, port *p) +{ + char *start=p->rep.string.start; + size_t old_size = p->rep.string.past_the_end - start; + size_t new_size=p->rep.string.past_the_end-start+1+BLOCK_SIZE; + char *str=sc->malloc(new_size); + if(str) { + memset(str,' ',new_size-1); + str[new_size-1]='\0'; + memcpy(str, start, old_size); + p->rep.string.start=str; + p->rep.string.past_the_end=str+new_size-1; + p->rep.string.curr-=start-str; + sc->free(start); + return 1; + } else { + return 0; + } +} + +INTERFACE void putstr(scheme *sc, const char *s) { + port *pt=sc->outport->_object._port; + if(pt->kind&port_file) { + fputs(s,pt->rep.stdio.file); + } else { + for(;*s;s++) { + if(pt->rep.string.curr!=pt->rep.string.past_the_end) { + *pt->rep.string.curr++=*s; + } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) { + *pt->rep.string.curr++=*s; + } + } + } +} + +static void putchars(scheme *sc, const char *s, int len) { + port *pt=sc->outport->_object._port; + if(pt->kind&port_file) { + fwrite(s,1,len,pt->rep.stdio.file); + } else { + for(;len;len--) { + if(pt->rep.string.curr!=pt->rep.string.past_the_end) { + *pt->rep.string.curr++=*s++; + } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) { + *pt->rep.string.curr++=*s++; + } + } + } +} + +INTERFACE void putcharacter(scheme *sc, int c) { + port *pt=sc->outport->_object._port; + if(pt->kind&port_file) { + fputc(c,pt->rep.stdio.file); + } else { + if(pt->rep.string.curr!=pt->rep.string.past_the_end) { + *pt->rep.string.curr++=c; + } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) { + *pt->rep.string.curr++=c; + } + } +} + +/* read characters up to delimiter, but cater to character constants */ +static char *readstr_upto(scheme *sc, char *delim) { + char *p = sc->strbuff; + + while ((p - sc->strbuff < sc->strbuff_size) && + !is_one_of(delim, (*p++ = inchar(sc)))); + + if(p == sc->strbuff+2 && p[-2] == '\\') { + *p=0; + } else { + backchar(sc,p[-1]); + *--p = '\0'; + } + return sc->strbuff; +} + +/* read string expression "xxx...xxx" */ +static pointer readstrexp(scheme *sc) { + char *p = sc->strbuff; + int c; + int c1=0; + enum { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state=st_ok; + + for (;;) { + c=inchar(sc); + if(c == EOF) { + return sc->F; + } + if(p-sc->strbuff > (sc->strbuff_size)-1) { + ptrdiff_t offset = p - sc->strbuff; + if (expand_strbuff(sc) != 0) { + return sc->F; + } + p = sc->strbuff + offset; + } + switch(state) { + case st_ok: + switch(c) { + case '\\': + state=st_bsl; + break; + case '"': + *p=0; + return mk_counted_string(sc,sc->strbuff,p-sc->strbuff); + default: + *p++=c; + break; + } + break; + case st_bsl: + switch(c) { + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + state=st_oct1; + c1=c-'0'; + break; + case 'x': + case 'X': + state=st_x1; + c1=0; + break; + case 'n': + *p++='\n'; + state=st_ok; + break; + case 't': + *p++='\t'; + state=st_ok; + break; + case 'r': + *p++='\r'; + state=st_ok; + break; + case '"': + *p++='"'; + state=st_ok; + break; + default: + *p++=c; + state=st_ok; + break; + } + break; + case st_x1: + case st_x2: + c=toupper(c); + if(c>='0' && c<='F') { + if(c<='9') { + c1=(c1<<4)+c-'0'; + } else { + c1=(c1<<4)+c-'A'+10; + } + if(state==st_x1) { + state=st_x2; + } else { + *p++=c1; + state=st_ok; + } + } else { + return sc->F; + } + break; + case st_oct1: + case st_oct2: + if (c < '0' || c > '7') + { + *p++=c1; + backchar(sc, c); + state=st_ok; + } + else + { + if (state==st_oct2 && c1 >= 32) + return sc->F; + + c1=(c1<<3)+(c-'0'); + + if (state == st_oct1) + state=st_oct2; + else + { + *p++=c1; + state=st_ok; + } + } + break; + + } + } +} + +/* check c is in chars */ +static INLINE int is_one_of(char *s, int c) { + if(c==EOF) return 1; + while (*s) + if (*s++ == c) + return (1); + return (0); +} + +/* skip white characters */ +static INLINE int skipspace(scheme *sc) { + int c = 0, curr_line = 0; + + do { + c=inchar(sc); +#if SHOW_ERROR_LINE + if(c=='\n') + curr_line++; +#endif + } while (isspace(c)); + +/* record it */ +#if SHOW_ERROR_LINE + if (sc->load_stack[sc->file_i].kind & port_file) + sc->load_stack[sc->file_i].rep.stdio.curr_line += curr_line; +#endif + + if(c!=EOF) { + backchar(sc,c); + return 1; + } + else + { return EOF; } +} + +/* get token */ +static int token(scheme *sc) { + int c; + c = skipspace(sc); + if(c == EOF) { return (TOK_EOF); } + switch (c=inchar(sc)) { + case EOF: + return (TOK_EOF); + case '(': + return (TOK_LPAREN); + case ')': + return (TOK_RPAREN); + case '.': + c=inchar(sc); + if(is_one_of(" \n\t",c)) { + return (TOK_DOT); + } else { + backchar(sc,c); + backchar(sc,'.'); + return TOK_ATOM; + } + case '\'': + return (TOK_QUOTE); + case ';': + while ((c=inchar(sc)) != '\n' && c!=EOF) + ; + +#if SHOW_ERROR_LINE + if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file) + sc->load_stack[sc->file_i].rep.stdio.curr_line++; +#endif + + if(c == EOF) + { return (TOK_EOF); } + else + { return (token(sc));} + case '"': + return (TOK_DQUOTE); + case BACKQUOTE: + return (TOK_BQUOTE); + case ',': + if ((c=inchar(sc)) == '@') { + return (TOK_ATMARK); + } else { + backchar(sc,c); + return (TOK_COMMA); + } + case '#': + c=inchar(sc); + if (c == '(') { + return (TOK_VEC); + } else if(c == '!') { + while ((c=inchar(sc)) != '\n' && c!=EOF) + ; + +#if SHOW_ERROR_LINE + if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file) + sc->load_stack[sc->file_i].rep.stdio.curr_line++; +#endif + + if(c == EOF) + { return (TOK_EOF); } + else + { return (token(sc));} + } else { + backchar(sc,c); + if(is_one_of(" tfodxb\\",c)) { + return TOK_SHARP_CONST; + } else { + return (TOK_SHARP); + } + } + default: + backchar(sc,c); + return (TOK_ATOM); + } +} + +/* ========== Routines for Printing ========== */ +#define ok_abbrev(x) (is_pair(x) && cdr(x) == sc->NIL) + +static void printslashstring(scheme *sc, char *p, int len) { + int i; + unsigned char *s=(unsigned char*)p; + putcharacter(sc,'"'); + for ( i=0; i<len; i++) { + if(*s==0xff || *s=='"' || *s<' ' || *s=='\\') { + putcharacter(sc,'\\'); + switch(*s) { + case '"': + putcharacter(sc,'"'); + break; + case '\n': + putcharacter(sc,'n'); + break; + case '\t': + putcharacter(sc,'t'); + break; + case '\r': + putcharacter(sc,'r'); + break; + case '\\': + putcharacter(sc,'\\'); + break; + default: { + int d=*s/16; + putcharacter(sc,'x'); + if(d<10) { + putcharacter(sc,d+'0'); + } else { + putcharacter(sc,d-10+'A'); + } + d=*s%16; + if(d<10) { + putcharacter(sc,d+'0'); + } else { + putcharacter(sc,d-10+'A'); + } + } + } + } else { + putcharacter(sc,*s); + } + s++; + } + putcharacter(sc,'"'); +} + + +/* print atoms */ +static void printatom(scheme *sc, pointer l, int f) { + char *p; + int len; + atom2str(sc,l,f,&p,&len); + putchars(sc,p,len); +} + + +/* Uses internal buffer unless string pointer is already available */ +static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen) { + char *p; + + if (l == sc->NIL) { + p = "()"; + } else if (l == sc->T) { + p = "#t"; + } else if (l == sc->F) { + p = "#f"; + } else if (l == sc->EOF_OBJ) { + p = "#<EOF>"; + } else if (is_port(l)) { + p = "#<PORT>"; + } else if (is_number(l)) { + p = sc->strbuff; + if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */ { + if(num_is_integer(l)) { + snprintf(p, STRBUFFSIZE, "%ld", ivalue_unchecked(l)); + } else { + snprintf(p, STRBUFFSIZE, "%.10g", rvalue_unchecked(l)); + /* r5rs says there must be a '.' (unless 'e'?) */ + f = strcspn(p, ".e"); + if (p[f] == 0) { + p[f] = '.'; /* not found, so add '.0' at the end */ + p[f+1] = '0'; + p[f+2] = 0; + } + } + } else { + long v = ivalue(l); + if (f == 16) { + if (v >= 0) + snprintf(p, STRBUFFSIZE, "%lx", v); + else + snprintf(p, STRBUFFSIZE, "-%lx", -v); + } else if (f == 8) { + if (v >= 0) + snprintf(p, STRBUFFSIZE, "%lo", v); + else + snprintf(p, STRBUFFSIZE, "-%lo", -v); + } else if (f == 2) { + unsigned long b = (v < 0) ? -v : v; + p = &p[STRBUFFSIZE-1]; + *p = 0; + do { *--p = (b&1) ? '1' : '0'; b >>= 1; } while (b != 0); + if (v < 0) *--p = '-'; + } + } + } else if (is_string(l)) { + if (!f) { + p = strvalue(l); + } else { /* Hack, uses the fact that printing is needed */ + *pp=sc->strbuff; + *plen=0; + printslashstring(sc, strvalue(l), strlength(l)); + return; + } + } else if (is_character(l)) { + int c=charvalue(l); + p = sc->strbuff; + if (!f) { + p[0]=c; + p[1]=0; + } else { + switch(c) { + case ' ': + p = "#\\space"; + break; + case '\n': + p = "#\\newline"; + break; + case '\r': + p = "#\\return"; + break; + case '\t': + p = "#\\tab"; + break; + default: +#if USE_ASCII_NAMES + if(c==127) { + p = "#\\del"; + break; + } else if(c<32) { + snprintf(p,STRBUFFSIZE, "#\\%s",charnames[c]); + break; + } +#else + if(c<32) { + snprintf(p,STRBUFFSIZE,"#\\x%x",c); + break; + } +#endif + snprintf(p,STRBUFFSIZE,"#\\%c",c); + break; + } + } + } else if (is_symbol(l)) { + p = symname(l); + } else if (is_proc(l)) { + p = sc->strbuff; + snprintf(p,STRBUFFSIZE,"#<%s PROCEDURE %ld>", procname(l),procnum(l)); + } else if (is_macro(l)) { + p = "#<MACRO>"; + } else if (is_closure(l)) { + p = "#<CLOSURE>"; + } else if (is_promise(l)) { + p = "#<PROMISE>"; + } else if (is_foreign(l)) { + p = sc->strbuff; + snprintf(p,STRBUFFSIZE,"#<FOREIGN PROCEDURE %ld>", procnum(l)); + } else if (is_continuation(l)) { + p = "#<CONTINUATION>"; + } else if (is_foreign_object(l)) { + p = sc->strbuff; + l->_object._foreign_object._vtable->to_string(sc, p, STRBUFFSIZE, l->_object._foreign_object._data); + } else { + p = "#<ERROR>"; + } + *pp=p; + *plen=strlen(p); +} +/* ========== Routines for Evaluation Cycle ========== */ + +/* make closure. c is code. e is environment */ +static pointer mk_closure(scheme *sc, pointer c, pointer e) { + pointer x = get_cell(sc, c, e); + + typeflag(x) = T_CLOSURE; + car(x) = c; + cdr(x) = e; + return (x); +} + +/* make continuation. */ +static pointer mk_continuation(scheme *sc, pointer d) { + pointer x = get_cell(sc, sc->NIL, d); + + typeflag(x) = T_CONTINUATION; + cont_dump(x) = d; + return (x); +} + +static pointer list_star(scheme *sc, pointer d) { + pointer p, q; + if(cdr(d)==sc->NIL) { + return car(d); + } + p=cons(sc,car(d),cdr(d)); + q=p; + while(cdr(cdr(p))!=sc->NIL) { + d=cons(sc,car(p),cdr(p)); + if(cdr(cdr(p))!=sc->NIL) { + p=cdr(d); + } + } + cdr(p)=car(cdr(p)); + return q; +} + +/* reverse list -- produce new list */ +static pointer reverse(scheme *sc, pointer a) { +/* a must be checked by gc */ + pointer p = sc->NIL; + + for ( ; is_pair(a); a = cdr(a)) { + p = cons(sc, car(a), p); + } + return (p); +} + +/* reverse list --- in-place */ +static pointer reverse_in_place(scheme *sc, pointer term, pointer list) { + pointer p = list, result = term, q; + + while (p != sc->NIL) { + q = cdr(p); + cdr(p) = result; + result = p; + p = q; + } + return (result); +} + +/* append list -- produce new list (in reverse order) */ +static pointer revappend(scheme *sc, pointer a, pointer b) { + pointer result = a; + pointer p = b; + + while (is_pair(p)) { + result = cons(sc, car(p), result); + p = cdr(p); + } + + if (p == sc->NIL) { + return result; + } + + return sc->F; /* signal an error */ +} + +/* equivalence of atoms */ +int eqv(pointer a, pointer b) { + if (is_string(a)) { + if (is_string(b)) + return (strvalue(a) == strvalue(b)); + else + return (0); + } else if (is_number(a)) { + if (is_number(b)) { + if (num_is_integer(a) == num_is_integer(b)) + return num_eq(nvalue(a),nvalue(b)); + } + return (0); + } else if (is_character(a)) { + if (is_character(b)) + return charvalue(a)==charvalue(b); + else + return (0); + } else if (is_port(a)) { + if (is_port(b)) + return a==b; + else + return (0); + } else if (is_proc(a)) { + if (is_proc(b)) + return procnum(a)==procnum(b); + else + return (0); + } else { + return (a == b); + } +} + +/* true or false value macro */ +/* () is #t in R5RS */ +#define is_true(p) ((p) != sc->F) +#define is_false(p) ((p) == sc->F) + +/* ========== Environment implementation ========== */ + +#if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST) + +static int hash_fn(const char *key, int table_size) +{ + unsigned int hashed = 0; + const char *c; + int bits_per_int = sizeof(unsigned int)*8; + + for (c = key; *c; c++) { + /* letters have about 5 bits in them */ + hashed = (hashed<<5) | (hashed>>(bits_per_int-5)); + hashed ^= *c; + } + return hashed % table_size; +} +#endif + +#ifndef USE_ALIST_ENV + +/* + * In this implementation, each frame of the environment may be + * a hash table: a vector of alists hashed by variable name. + * In practice, we use a vector only for the initial frame; + * subsequent frames are too small and transient for the lookup + * speed to out-weigh the cost of making a new vector. + */ + +static void new_frame_in_env(scheme *sc, pointer old_env) +{ + pointer new_frame; + + /* The interaction-environment has about 300 variables in it. */ + if (old_env == sc->NIL) { + new_frame = mk_vector(sc, 461); + } else { + new_frame = sc->NIL; + } + + sc->envir = immutable_cons(sc, new_frame, old_env); + setenvironment(sc->envir); +} + +static INLINE void new_slot_spec_in_env(scheme *sc, pointer env, + pointer variable, pointer value) +{ + pointer slot = immutable_cons(sc, variable, value); + + if (is_vector(car(env))) { + int location = hash_fn(symname(variable), ivalue_unchecked(car(env))); + + set_vector_elem(car(env), location, + immutable_cons(sc, slot, vector_elem(car(env), location))); + } else { + car(env) = immutable_cons(sc, slot, car(env)); + } +} + +static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all) +{ + pointer x,y; + int location; + + for (x = env; x != sc->NIL; x = cdr(x)) { + if (is_vector(car(x))) { + location = hash_fn(symname(hdl), ivalue_unchecked(car(x))); + y = vector_elem(car(x), location); + } else { + y = car(x); + } + for ( ; y != sc->NIL; y = cdr(y)) { + if (caar(y) == hdl) { + break; + } + } + if (y != sc->NIL) { + break; + } + if(!all) { + return sc->NIL; + } + } + if (x != sc->NIL) { + return car(y); + } + return sc->NIL; +} + +#else /* USE_ALIST_ENV */ + +static INLINE void new_frame_in_env(scheme *sc, pointer old_env) +{ + sc->envir = immutable_cons(sc, sc->NIL, old_env); + setenvironment(sc->envir); +} + +static INLINE void new_slot_spec_in_env(scheme *sc, pointer env, + pointer variable, pointer value) +{ + car(env) = immutable_cons(sc, immutable_cons(sc, variable, value), car(env)); +} + +static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all) +{ + pointer x,y; + for (x = env; x != sc->NIL; x = cdr(x)) { + for (y = car(x); y != sc->NIL; y = cdr(y)) { + if (caar(y) == hdl) { + break; + } + } + if (y != sc->NIL) { + break; + } + if(!all) { + return sc->NIL; + } + } + if (x != sc->NIL) { + return car(y); + } + return sc->NIL; +} + +#endif /* USE_ALIST_ENV else */ + +static INLINE void new_slot_in_env(scheme *sc, pointer variable, pointer value) +{ + new_slot_spec_in_env(sc, sc->envir, variable, value); +} + +static INLINE void set_slot_in_env(scheme *sc, pointer slot, pointer value) +{ + (void)sc; + cdr(slot) = value; +} + +static INLINE pointer slot_value_in_env(pointer slot) +{ + return cdr(slot); +} + +/* ========== Evaluation Cycle ========== */ + + +static pointer _Error_1(scheme *sc, const char *s, pointer a) { + const char *str = s; +#if USE_ERROR_HOOK + pointer x; + pointer hdl=sc->ERROR_HOOK; +#endif + +#if SHOW_ERROR_LINE + char sbuf[STRBUFFSIZE]; + + /* make sure error is not in REPL */ + if (sc->load_stack[sc->file_i].kind & port_file && + sc->load_stack[sc->file_i].rep.stdio.file != stdin) { + int ln = sc->load_stack[sc->file_i].rep.stdio.curr_line; + const char *fname = sc->load_stack[sc->file_i].rep.stdio.filename; + + /* should never happen */ + if(!fname) fname = "<unknown>"; + + /* we started from 0 */ + ln++; + snprintf(sbuf, STRBUFFSIZE, "(%s : %i) %s", fname, ln, s); + + str = (const char*)sbuf; + } +#endif + +#if USE_ERROR_HOOK + x=find_slot_in_env(sc,sc->envir,hdl,1); + if (x != sc->NIL) { + if(a!=0) { + sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc,(a), sc->NIL)), sc->NIL); + } else { + sc->code = sc->NIL; + } + sc->code = cons(sc, mk_string(sc, str), sc->code); + setimmutable(car(sc->code)); + sc->code = cons(sc, slot_value_in_env(x), sc->code); + sc->op = (int)OP_EVAL; + return sc->T; + } +#endif + + if(a!=0) { + sc->args = cons(sc, (a), sc->NIL); + } else { + sc->args = sc->NIL; + } + sc->args = cons(sc, mk_string(sc, str), sc->args); + setimmutable(car(sc->args)); + sc->op = (int)OP_ERR0; + return sc->T; +} +#define Error_1(sc,s, a) return _Error_1(sc,s,a) +#define Error_0(sc,s) return _Error_1(sc,s,0) + +/* Too small to turn into function */ +# define BEGIN do { +# define END } while (0) +#define s_goto(sc,a) BEGIN \ + sc->op = (int)(a); \ + return sc->T; END + +#define s_return(sc,a) return _s_return(sc,a) + +#ifndef USE_SCHEME_STACK + +/* this structure holds all the interpreter's registers */ +struct dump_stack_frame { + enum scheme_opcodes op; + pointer args; + pointer envir; + pointer code; +}; + +#define STACK_GROWTH 3 + +static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) +{ + int nframes = (int)sc->dump; + struct dump_stack_frame *next_frame; + + /* enough room for the next frame? */ + if (nframes >= sc->dump_size) { + sc->dump_size += STACK_GROWTH; + /* alas there is no sc->realloc */ + sc->dump_base = realloc(sc->dump_base, + sizeof(struct dump_stack_frame) * sc->dump_size); + } + next_frame = (struct dump_stack_frame *)sc->dump_base + nframes; + next_frame->op = op; + next_frame->args = args; + next_frame->envir = sc->envir; + next_frame->code = code; + sc->dump = (pointer)(nframes+1); +} + +static pointer _s_return(scheme *sc, pointer a) +{ + int nframes = (int)sc->dump; + struct dump_stack_frame *frame; + + sc->value = (a); + if (nframes <= 0) { + return sc->NIL; + } + nframes--; + frame = (struct dump_stack_frame *)sc->dump_base + nframes; + sc->op = frame->op; + sc->args = frame->args; + sc->envir = frame->envir; + sc->code = frame->code; + sc->dump = (pointer)nframes; + return sc->T; +} + +static INLINE void dump_stack_reset(scheme *sc) +{ + /* in this implementation, sc->dump is the number of frames on the stack */ + sc->dump = (pointer)0; +} + +static INLINE void dump_stack_initialize(scheme *sc) +{ + sc->dump_size = 0; + sc->dump_base = NULL; + dump_stack_reset(sc); +} + +static void dump_stack_free(scheme *sc) +{ + free(sc->dump_base); + sc->dump_base = NULL; + sc->dump = (pointer)0; + sc->dump_size = 0; +} + +static INLINE void dump_stack_mark(scheme *sc) +{ + int nframes = (int)sc->dump; + int i; + for(i=0; i<nframes; i++) { + struct dump_stack_frame *frame; + frame = (struct dump_stack_frame *)sc->dump_base + i; + mark(frame->args); + mark(frame->envir); + mark(frame->code); + } +} + +#else + +static INLINE void dump_stack_reset(scheme *sc) +{ + sc->dump = sc->NIL; +} + +static INLINE void dump_stack_initialize(scheme *sc) +{ + dump_stack_reset(sc); +} + +static void dump_stack_free(scheme *sc) +{ + sc->dump = sc->NIL; +} + +static pointer _s_return(scheme *sc, pointer a) { + sc->value = (a); + if(sc->dump==sc->NIL) return sc->NIL; + sc->op = ivalue(car(sc->dump)); + sc->args = cadr(sc->dump); + sc->envir = caddr(sc->dump); + sc->code = cadddr(sc->dump); + sc->dump = cddddr(sc->dump); + return sc->T; +} + +static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) { + sc->dump = cons(sc, sc->envir, cons(sc, (code), sc->dump)); + sc->dump = cons(sc, (args), sc->dump); + sc->dump = cons(sc, mk_integer(sc, (long)(op)), sc->dump); +} + +static INLINE void dump_stack_mark(scheme *sc) +{ + mark(sc->dump); +} +#endif + +#define s_retbool(tf) s_return(sc,(tf) ? sc->T : sc->F) + +static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { + pointer x, y; + + switch (op) { + case OP_LOAD: /* load */ + if(file_interactive(sc)) { + fprintf(sc->outport->_object._port->rep.stdio.file, + "Loading %s\n", strvalue(car(sc->args))); + } + if (!file_push(sc,strvalue(car(sc->args)))) { + Error_1(sc,"unable to open", car(sc->args)); + } + else + { + sc->args = mk_integer(sc,sc->file_i); + s_goto(sc,OP_T0LVL); + } + + case OP_T0LVL: /* top level */ + /* If we reached the end of file, this loop is done. */ + if(sc->loadport->_object._port->kind & port_saw_EOF) + { + if(sc->file_i == 0) + { + sc->args=sc->NIL; + s_goto(sc,OP_QUIT); + } + else + { + file_pop(sc); + s_return(sc,sc->value); + } + /* NOTREACHED */ + } + + /* If interactive, be nice to user. */ + if(file_interactive(sc)) + { + sc->envir = sc->global_env; + dump_stack_reset(sc); + putstr(sc,"\n"); + putstr(sc,prompt); + } + + /* Set up another iteration of REPL */ + sc->nesting=0; + sc->save_inport=sc->inport; + sc->inport = sc->loadport; + s_save(sc,OP_T0LVL, sc->NIL, sc->NIL); + s_save(sc,OP_VALUEPRINT, sc->NIL, sc->NIL); + s_save(sc,OP_T1LVL, sc->NIL, sc->NIL); + s_goto(sc,OP_READ_INTERNAL); + + case OP_T1LVL: /* top level */ + sc->code = sc->value; + sc->inport=sc->save_inport; + s_goto(sc,OP_EVAL); + + case OP_READ_INTERNAL: /* internal read */ + sc->tok = token(sc); + if(sc->tok==TOK_EOF) + { s_return(sc,sc->EOF_OBJ); } + s_goto(sc,OP_RDSEXPR); + + case OP_GENSYM: + s_return(sc, gensym(sc)); + + case OP_VALUEPRINT: /* print evaluation result */ + /* OP_VALUEPRINT is always pushed, because when changing from + non-interactive to interactive mode, it needs to be + already on the stack */ + if(sc->tracing) { + putstr(sc,"\nGives: "); + } + if(file_interactive(sc)) { + sc->print_flag = 1; + sc->args = sc->value; + s_goto(sc,OP_P0LIST); + } else { + s_return(sc,sc->value); + } + + case OP_EVAL: /* main part of evaluation */ +#if USE_TRACING + if(sc->tracing) { + /*s_save(sc,OP_VALUEPRINT,sc->NIL,sc->NIL);*/ + s_save(sc,OP_REAL_EVAL,sc->args,sc->code); + sc->args=sc->code; + putstr(sc,"\nEval: "); + s_goto(sc,OP_P0LIST); + } + /* fall through */ + case OP_REAL_EVAL: +#endif + if (is_symbol(sc->code)) { /* symbol */ + x=find_slot_in_env(sc,sc->envir,sc->code,1); + if (x != sc->NIL) { + s_return(sc,slot_value_in_env(x)); + } else { + Error_1(sc,"eval: unbound variable:", sc->code); + } + } else if (is_pair(sc->code)) { + if (is_syntax(x = car(sc->code))) { /* SYNTAX */ + sc->code = cdr(sc->code); + s_goto(sc,syntaxnum(x)); + } else {/* first, eval top element and eval arguments */ + s_save(sc,OP_E0ARGS, sc->NIL, sc->code); + /* If no macros => s_save(sc,OP_E1ARGS, sc->NIL, cdr(sc->code));*/ + sc->code = car(sc->code); + s_goto(sc,OP_EVAL); + } + } else { + s_return(sc,sc->code); + } + + case OP_E0ARGS: /* eval arguments */ + if (is_macro(sc->value)) { /* macro expansion */ + s_save(sc,OP_DOMACRO, sc->NIL, sc->NIL); + sc->args = cons(sc,sc->code, sc->NIL); + sc->code = sc->value; + s_goto(sc,OP_APPLY); + } else { + sc->code = cdr(sc->code); + s_goto(sc,OP_E1ARGS); + } + + case OP_E1ARGS: /* eval arguments */ + sc->args = cons(sc, sc->value, sc->args); + if (is_pair(sc->code)) { /* continue */ + s_save(sc,OP_E1ARGS, sc->args, cdr(sc->code)); + sc->code = car(sc->code); + sc->args = sc->NIL; + s_goto(sc,OP_EVAL); + } else { /* end */ + sc->args = reverse_in_place(sc, sc->NIL, sc->args); + sc->code = car(sc->args); + sc->args = cdr(sc->args); + s_goto(sc,OP_APPLY); + } + +#if USE_TRACING + case OP_TRACING: { + int tr=sc->tracing; + sc->tracing=ivalue(car(sc->args)); + s_return(sc,mk_integer(sc,tr)); + } +#endif + + case OP_APPLY: /* apply 'code' to 'args' */ +#if USE_TRACING + if(sc->tracing) { + s_save(sc,OP_REAL_APPLY,sc->args,sc->code); + sc->print_flag = 1; + /* sc->args=cons(sc,sc->code,sc->args);*/ + putstr(sc,"\nApply to: "); + s_goto(sc,OP_P0LIST); + } + /* fall through */ + case OP_REAL_APPLY: +#endif + if (is_proc(sc->code)) { + s_goto(sc,procnum(sc->code)); /* PROCEDURE */ + } else if (is_foreign(sc->code)) + { + /* Keep nested calls from GC'ing the arglist */ + push_recent_alloc(sc,sc->args,sc->NIL); + x=sc->code->_object._ff(sc,sc->args); + s_return(sc,x); + } else if (is_closure(sc->code) || is_macro(sc->code) + || is_promise(sc->code)) { /* CLOSURE */ + /* Should not accept promise */ + /* make environment */ + new_frame_in_env(sc, closure_env(sc->code)); + for (x = car(closure_code(sc->code)), y = sc->args; + is_pair(x); x = cdr(x), y = cdr(y)) { + if (y == sc->NIL) { + Error_0(sc,"not enough arguments"); + } else { + new_slot_in_env(sc, car(x), car(y)); + } + } + if (x == sc->NIL) { + /*-- + * if (y != sc->NIL) { + * Error_0(sc,"too many arguments"); + * } + */ + } else if (is_symbol(x)) + new_slot_in_env(sc, x, y); + else { + Error_1(sc,"syntax error in closure: not a symbol:", x); + } + sc->code = cdr(closure_code(sc->code)); + sc->args = sc->NIL; + s_goto(sc,OP_BEGIN); + } else if (is_continuation(sc->code)) { /* CONTINUATION */ + sc->dump = cont_dump(sc->code); + s_return(sc,sc->args != sc->NIL ? car(sc->args) : sc->NIL); + } else { + Error_1(sc,"illegal function",sc->code); + } + + case OP_DOMACRO: /* do macro */ + sc->code = sc->value; + s_goto(sc,OP_EVAL); + +#if 1 + case OP_LAMBDA: /* lambda */ + /* If the hook is defined, apply it to sc->code, otherwise + set sc->value fall thru */ + { + pointer f=find_slot_in_env(sc,sc->envir,sc->COMPILE_HOOK,1); + if(f==sc->NIL) { + sc->value = sc->code; + /* Fallthru */ + } else { + s_save(sc,OP_LAMBDA1,sc->args,sc->code); + sc->args=cons(sc,sc->code,sc->NIL); + sc->code=slot_value_in_env(f); + s_goto(sc,OP_APPLY); + } + } + + case OP_LAMBDA1: + s_return(sc,mk_closure(sc, sc->value, sc->envir)); + +#else + case OP_LAMBDA: /* lambda */ + s_return(sc,mk_closure(sc, sc->code, sc->envir)); + +#endif + + case OP_MKCLOSURE: /* make-closure */ + x=car(sc->args); + if(car(x)==sc->LAMBDA) { + x=cdr(x); + } + if(cdr(sc->args)==sc->NIL) { + y=sc->envir; + } else { + y=cadr(sc->args); + } + s_return(sc,mk_closure(sc, x, y)); + + case OP_QUOTE: /* quote */ + s_return(sc,car(sc->code)); + + case OP_DEF0: /* define */ + if(is_immutable(car(sc->code))) + Error_1(sc,"define: unable to alter immutable", car(sc->code)); + + if (is_pair(car(sc->code))) { + x = caar(sc->code); + sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code))); + } else { + x = car(sc->code); + sc->code = cadr(sc->code); + } + if (!is_symbol(x)) { + Error_0(sc,"variable is not a symbol"); + } + s_save(sc,OP_DEF1, sc->NIL, x); + s_goto(sc,OP_EVAL); + + case OP_DEF1: /* define */ + x=find_slot_in_env(sc,sc->envir,sc->code,0); + if (x != sc->NIL) { + set_slot_in_env(sc, x, sc->value); + } else { + new_slot_in_env(sc, sc->code, sc->value); + } + s_return(sc,sc->code); + + + case OP_DEFP: /* defined? */ + x=sc->envir; + if(cdr(sc->args)!=sc->NIL) { + x=cadr(sc->args); + } + s_retbool(find_slot_in_env(sc,x,car(sc->args),1)!=sc->NIL); + + case OP_SET0: /* set! */ + if(is_immutable(car(sc->code))) + Error_1(sc,"set!: unable to alter immutable variable",car(sc->code)); + s_save(sc,OP_SET1, sc->NIL, car(sc->code)); + sc->code = cadr(sc->code); + s_goto(sc,OP_EVAL); + + case OP_SET1: /* set! */ + y=find_slot_in_env(sc,sc->envir,sc->code,1); + if (y != sc->NIL) { + set_slot_in_env(sc, y, sc->value); + s_return(sc,sc->value); + } else { + Error_1(sc,"set!: unbound variable:", sc->code); + } + + + case OP_BEGIN: /* begin */ + if (!is_pair(sc->code)) { + s_return(sc,sc->code); + } + if (cdr(sc->code) != sc->NIL) { + s_save(sc,OP_BEGIN, sc->NIL, cdr(sc->code)); + } + sc->code = car(sc->code); + s_goto(sc,OP_EVAL); + + case OP_IF0: /* if */ + s_save(sc,OP_IF1, sc->NIL, cdr(sc->code)); + sc->code = car(sc->code); + s_goto(sc,OP_EVAL); + + case OP_IF1: /* if */ + if (is_true(sc->value)) + sc->code = car(sc->code); + else + sc->code = cadr(sc->code); /* (if #f 1) ==> () because + * car(sc->NIL) = sc->NIL */ + s_goto(sc,OP_EVAL); + + case OP_LET0: /* let */ + sc->args = sc->NIL; + sc->value = sc->code; + sc->code = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code); + s_goto(sc,OP_LET1); + + case OP_LET1: /* let (calculate parameters) */ + sc->args = cons(sc, sc->value, sc->args); + if (is_pair(sc->code)) { /* continue */ + if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) { + Error_1(sc, "Bad syntax of binding spec in let :", + car(sc->code)); + } + s_save(sc,OP_LET1, sc->args, cdr(sc->code)); + sc->code = cadar(sc->code); + sc->args = sc->NIL; + s_goto(sc,OP_EVAL); + } else { /* end */ + sc->args = reverse_in_place(sc, sc->NIL, sc->args); + sc->code = car(sc->args); + sc->args = cdr(sc->args); + s_goto(sc,OP_LET2); + } + + case OP_LET2: /* let */ + new_frame_in_env(sc, sc->envir); + for (x = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code), y = sc->args; + y != sc->NIL; x = cdr(x), y = cdr(y)) { + new_slot_in_env(sc, caar(x), car(y)); + } + if (is_symbol(car(sc->code))) { /* named let */ + for (x = cadr(sc->code), sc->args = sc->NIL; x != sc->NIL; x = cdr(x)) { + if (!is_pair(x)) + Error_1(sc, "Bad syntax of binding in let :", x); + if (!is_list(sc, car(x))) + Error_1(sc, "Bad syntax of binding in let :", car(x)); + sc->args = cons(sc, caar(x), sc->args); + } + x = mk_closure(sc, cons(sc, reverse_in_place(sc, sc->NIL, sc->args), cddr(sc->code)), sc->envir); + new_slot_in_env(sc, car(sc->code), x); + sc->code = cddr(sc->code); + sc->args = sc->NIL; + } else { + sc->code = cdr(sc->code); + sc->args = sc->NIL; + } + s_goto(sc,OP_BEGIN); + + case OP_LET0AST: /* let* */ + if (car(sc->code) == sc->NIL) { + new_frame_in_env(sc, sc->envir); + sc->code = cdr(sc->code); + s_goto(sc,OP_BEGIN); + } + if(!is_pair(car(sc->code)) || !is_pair(caar(sc->code)) || !is_pair(cdaar(sc->code))) { + Error_1(sc,"Bad syntax of binding spec in let* :",car(sc->code)); + } + s_save(sc,OP_LET1AST, cdr(sc->code), car(sc->code)); + sc->code = cadaar(sc->code); + s_goto(sc,OP_EVAL); + + case OP_LET1AST: /* let* (make new frame) */ + new_frame_in_env(sc, sc->envir); + s_goto(sc,OP_LET2AST); + + case OP_LET2AST: /* let* (calculate parameters) */ + new_slot_in_env(sc, caar(sc->code), sc->value); + sc->code = cdr(sc->code); + if (is_pair(sc->code)) { /* continue */ + s_save(sc,OP_LET2AST, sc->args, sc->code); + sc->code = cadar(sc->code); + sc->args = sc->NIL; + s_goto(sc,OP_EVAL); + } else { /* end */ + sc->code = sc->args; + sc->args = sc->NIL; + s_goto(sc,OP_BEGIN); + } + default: + snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); + Error_0(sc,sc->strbuff); + } + return sc->T; +} + +static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { + pointer x, y; + + switch (op) { + case OP_LET0REC: /* letrec */ + new_frame_in_env(sc, sc->envir); + sc->args = sc->NIL; + sc->value = sc->code; + sc->code = car(sc->code); + s_goto(sc,OP_LET1REC); + + case OP_LET1REC: /* letrec (calculate parameters) */ + sc->args = cons(sc, sc->value, sc->args); + if (is_pair(sc->code)) { /* continue */ + if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) { + Error_1(sc, "Bad syntax of binding spec in letrec :", + car(sc->code)); + } + s_save(sc,OP_LET1REC, sc->args, cdr(sc->code)); + sc->code = cadar(sc->code); + sc->args = sc->NIL; + s_goto(sc,OP_EVAL); + } else { /* end */ + sc->args = reverse_in_place(sc, sc->NIL, sc->args); + sc->code = car(sc->args); + sc->args = cdr(sc->args); + s_goto(sc,OP_LET2REC); + } + + case OP_LET2REC: /* letrec */ + for (x = car(sc->code), y = sc->args; y != sc->NIL; x = cdr(x), y = cdr(y)) { + new_slot_in_env(sc, caar(x), car(y)); + } + sc->code = cdr(sc->code); + sc->args = sc->NIL; + s_goto(sc,OP_BEGIN); + + case OP_COND0: /* cond */ + if (!is_pair(sc->code)) { + Error_0(sc,"syntax error in cond"); + } + s_save(sc,OP_COND1, sc->NIL, sc->code); + sc->code = caar(sc->code); + s_goto(sc,OP_EVAL); + + case OP_COND1: /* cond */ + if (is_true(sc->value)) { + if ((sc->code = cdar(sc->code)) == sc->NIL) { + s_return(sc,sc->value); + } + if(!sc->code || car(sc->code)==sc->FEED_TO) { + if(!is_pair(cdr(sc->code))) { + Error_0(sc,"syntax error in cond"); + } + x=cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL)); + sc->code=cons(sc,cadr(sc->code),cons(sc,x,sc->NIL)); + s_goto(sc,OP_EVAL); + } + s_goto(sc,OP_BEGIN); + } else { + if ((sc->code = cdr(sc->code)) == sc->NIL) { + s_return(sc,sc->NIL); + } else { + s_save(sc,OP_COND1, sc->NIL, sc->code); + sc->code = caar(sc->code); + s_goto(sc,OP_EVAL); + } + } + + case OP_DELAY: /* delay */ + x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir); + typeflag(x)=T_PROMISE; + s_return(sc,x); + + case OP_AND0: /* and */ + if (sc->code == sc->NIL) { + s_return(sc,sc->T); + } + s_save(sc,OP_AND1, sc->NIL, cdr(sc->code)); + sc->code = car(sc->code); + s_goto(sc,OP_EVAL); + + case OP_AND1: /* and */ + if (is_false(sc->value)) { + s_return(sc,sc->value); + } else if (sc->code == sc->NIL) { + s_return(sc,sc->value); + } else { + s_save(sc,OP_AND1, sc->NIL, cdr(sc->code)); + sc->code = car(sc->code); + s_goto(sc,OP_EVAL); + } + + case OP_OR0: /* or */ + if (sc->code == sc->NIL) { + s_return(sc,sc->F); + } + s_save(sc,OP_OR1, sc->NIL, cdr(sc->code)); + sc->code = car(sc->code); + s_goto(sc,OP_EVAL); + + case OP_OR1: /* or */ + if (is_true(sc->value)) { + s_return(sc,sc->value); + } else if (sc->code == sc->NIL) { + s_return(sc,sc->value); + } else { + s_save(sc,OP_OR1, sc->NIL, cdr(sc->code)); + sc->code = car(sc->code); + s_goto(sc,OP_EVAL); + } + + case OP_C0STREAM: /* cons-stream */ + s_save(sc,OP_C1STREAM, sc->NIL, cdr(sc->code)); + sc->code = car(sc->code); + s_goto(sc,OP_EVAL); + + case OP_C1STREAM: /* cons-stream */ + sc->args = sc->value; /* save sc->value to register sc->args for gc */ + x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir); + typeflag(x)=T_PROMISE; + s_return(sc,cons(sc, sc->args, x)); + + case OP_MACRO0: /* macro */ + if (is_pair(car(sc->code))) { + x = caar(sc->code); + sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code))); + } else { + x = car(sc->code); + sc->code = cadr(sc->code); + } + if (!is_symbol(x)) { + Error_0(sc,"variable is not a symbol"); + } + s_save(sc,OP_MACRO1, sc->NIL, x); + s_goto(sc,OP_EVAL); + + case OP_MACRO1: /* macro */ + typeflag(sc->value) = T_MACRO; + x = find_slot_in_env(sc, sc->envir, sc->code, 0); + if (x != sc->NIL) { + set_slot_in_env(sc, x, sc->value); + } else { + new_slot_in_env(sc, sc->code, sc->value); + } + s_return(sc,sc->code); + + case OP_CASE0: /* case */ + s_save(sc,OP_CASE1, sc->NIL, cdr(sc->code)); + sc->code = car(sc->code); + s_goto(sc,OP_EVAL); + + case OP_CASE1: /* case */ + for (x = sc->code; x != sc->NIL; x = cdr(x)) { + if (!is_pair(y = caar(x))) { + break; + } + for ( ; y != sc->NIL; y = cdr(y)) { + if (eqv(car(y), sc->value)) { + break; + } + } + if (y != sc->NIL) { + break; + } + } + if (x != sc->NIL) { + if (is_pair(caar(x))) { + sc->code = cdar(x); + s_goto(sc,OP_BEGIN); + } else {/* else */ + s_save(sc,OP_CASE2, sc->NIL, cdar(x)); + sc->code = caar(x); + s_goto(sc,OP_EVAL); + } + } else { + s_return(sc,sc->NIL); + } + + case OP_CASE2: /* case */ + if (is_true(sc->value)) { + s_goto(sc,OP_BEGIN); + } else { + s_return(sc,sc->NIL); + } + + case OP_PAPPLY: /* apply */ + sc->code = car(sc->args); + sc->args = list_star(sc,cdr(sc->args)); + /*sc->args = cadr(sc->args);*/ + s_goto(sc,OP_APPLY); + + case OP_PEVAL: /* eval */ + if(cdr(sc->args)!=sc->NIL) { + sc->envir=cadr(sc->args); + } + sc->code = car(sc->args); + s_goto(sc,OP_EVAL); + + case OP_CONTINUATION: /* call-with-current-continuation */ + sc->code = car(sc->args); + sc->args = cons(sc, mk_continuation(sc, sc->dump), sc->NIL); + s_goto(sc,OP_APPLY); + + default: + snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); + Error_0(sc,sc->strbuff); + } + return sc->T; +} + +static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { + pointer x; + num v; +#if USE_MATH + double dd; +#endif + + switch (op) { +#if USE_MATH + case OP_INEX2EX: /* inexact->exact */ + x=car(sc->args); + if(num_is_integer(x)) { + s_return(sc,x); + } else if(modf(rvalue_unchecked(x),&dd)==0.0) { + s_return(sc,mk_integer(sc,ivalue(x))); + } else { + Error_1(sc,"inexact->exact: not integral:",x); + } + + case OP_EXP: + x=car(sc->args); + s_return(sc, mk_real(sc, exp(rvalue(x)))); + + case OP_LOG: + x=car(sc->args); + s_return(sc, mk_real(sc, log(rvalue(x)))); + + case OP_SIN: + x=car(sc->args); + s_return(sc, mk_real(sc, sin(rvalue(x)))); + + case OP_COS: + x=car(sc->args); + s_return(sc, mk_real(sc, cos(rvalue(x)))); + + case OP_TAN: + x=car(sc->args); + s_return(sc, mk_real(sc, tan(rvalue(x)))); + + case OP_ASIN: + x=car(sc->args); + s_return(sc, mk_real(sc, asin(rvalue(x)))); + + case OP_ACOS: + x=car(sc->args); + s_return(sc, mk_real(sc, acos(rvalue(x)))); + + case OP_ATAN: + x=car(sc->args); + if(cdr(sc->args)==sc->NIL) { + s_return(sc, mk_real(sc, atan(rvalue(x)))); + } else { + pointer y=cadr(sc->args); + s_return(sc, mk_real(sc, atan2(rvalue(x),rvalue(y)))); + } + + case OP_SQRT: + x=car(sc->args); + s_return(sc, mk_real(sc, sqrt(rvalue(x)))); + + case OP_EXPT: { + double result; + int real_result=1; + pointer y=cadr(sc->args); + x=car(sc->args); + if (num_is_integer(x) && num_is_integer(y)) + real_result=0; + /* This 'if' is an R5RS compatibility fix. */ + /* NOTE: Remove this 'if' fix for R6RS. */ + if (rvalue(x) == 0 && rvalue(y) < 0) { + result = 0.0; + } else { + result = pow(rvalue(x),rvalue(y)); + } + /* Before returning integer result make sure we can. */ + /* If the test fails, result is too big for integer. */ + if (!real_result) + { + long result_as_long = (long)result; + if (result != (double)result_as_long) + real_result = 1; + } + if (real_result) { + s_return(sc, mk_real(sc, result)); + } else { + s_return(sc, mk_integer(sc, result)); + } + } + + case OP_FLOOR: + x=car(sc->args); + s_return(sc, mk_real(sc, floor(rvalue(x)))); + + case OP_CEILING: + x=car(sc->args); + s_return(sc, mk_real(sc, ceil(rvalue(x)))); + + case OP_TRUNCATE : { + double rvalue_of_x ; + x=car(sc->args); + rvalue_of_x = rvalue(x) ; + if (rvalue_of_x > 0) { + s_return(sc, mk_real(sc, floor(rvalue_of_x))); + } else { + s_return(sc, mk_real(sc, ceil(rvalue_of_x))); + } + } + + case OP_ROUND: + x=car(sc->args); + if (num_is_integer(x)) + s_return(sc, x); + s_return(sc, mk_real(sc, round_per_R5RS(rvalue(x)))); +#endif + + case OP_ADD: /* + */ + v=num_zero; + for (x = sc->args; x != sc->NIL; x = cdr(x)) { + v=num_add(v,nvalue(car(x))); + } + s_return(sc,mk_number(sc, v)); + + case OP_MUL: /* * */ + v=num_one; + for (x = sc->args; x != sc->NIL; x = cdr(x)) { + v=num_mul(v,nvalue(car(x))); + } + s_return(sc,mk_number(sc, v)); + + case OP_SUB: /* - */ + if(cdr(sc->args)==sc->NIL) { + x=sc->args; + v=num_zero; + } else { + x = cdr(sc->args); + v = nvalue(car(sc->args)); + } + for (; x != sc->NIL; x = cdr(x)) { + v=num_sub(v,nvalue(car(x))); + } + s_return(sc,mk_number(sc, v)); + + case OP_DIV: /* / */ + if(cdr(sc->args)==sc->NIL) { + x=sc->args; + v=num_one; + } else { + x = cdr(sc->args); + v = nvalue(car(sc->args)); + } + for (; x != sc->NIL; x = cdr(x)) { + if (!is_zero_double(rvalue(car(x)))) + v=num_div(v,nvalue(car(x))); + else { + Error_0(sc,"/: division by zero"); + } + } + s_return(sc,mk_number(sc, v)); + + case OP_INTDIV: /* quotient */ + if(cdr(sc->args)==sc->NIL) { + x=sc->args; + v=num_one; + } else { + x = cdr(sc->args); + v = nvalue(car(sc->args)); + } + for (; x != sc->NIL; x = cdr(x)) { + if (ivalue(car(x)) != 0) + v=num_intdiv(v,nvalue(car(x))); + else { + Error_0(sc,"quotient: division by zero"); + } + } + s_return(sc,mk_number(sc, v)); + + case OP_REM: /* remainder */ + v = nvalue(car(sc->args)); + if (ivalue(cadr(sc->args)) != 0) + v=num_rem(v,nvalue(cadr(sc->args))); + else { + Error_0(sc,"remainder: division by zero"); + } + s_return(sc,mk_number(sc, v)); + + case OP_MOD: /* modulo */ + v = nvalue(car(sc->args)); + if (ivalue(cadr(sc->args)) != 0) + v=num_mod(v,nvalue(cadr(sc->args))); + else { + Error_0(sc,"modulo: division by zero"); + } + s_return(sc,mk_number(sc, v)); + + case OP_CAR: /* car */ + s_return(sc,caar(sc->args)); + + case OP_CDR: /* cdr */ + s_return(sc,cdar(sc->args)); + + case OP_CONS: /* cons */ + cdr(sc->args) = cadr(sc->args); + s_return(sc,sc->args); + + case OP_SETCAR: /* set-car! */ + if(!is_immutable(car(sc->args))) { + caar(sc->args) = cadr(sc->args); + s_return(sc,car(sc->args)); + } else { + Error_0(sc,"set-car!: unable to alter immutable pair"); + } + + case OP_SETCDR: /* set-cdr! */ + if(!is_immutable(car(sc->args))) { + cdar(sc->args) = cadr(sc->args); + s_return(sc,car(sc->args)); + } else { + Error_0(sc,"set-cdr!: unable to alter immutable pair"); + } + + case OP_CHAR2INT: { /* char->integer */ + char c; + c=(char)ivalue(car(sc->args)); + s_return(sc,mk_integer(sc,(unsigned char)c)); + } + + case OP_INT2CHAR: { /* integer->char */ + unsigned char c; + c=(unsigned char)ivalue(car(sc->args)); + s_return(sc,mk_character(sc,(char)c)); + } + + case OP_CHARUPCASE: { + unsigned char c; + c=(unsigned char)ivalue(car(sc->args)); + c=toupper(c); + s_return(sc,mk_character(sc,(char)c)); + } + + case OP_CHARDNCASE: { + unsigned char c; + c=(unsigned char)ivalue(car(sc->args)); + c=tolower(c); + s_return(sc,mk_character(sc,(char)c)); + } + + case OP_STR2SYM: /* string->symbol */ + s_return(sc,mk_symbol(sc,strvalue(car(sc->args)))); + + case OP_STR2ATOM: /* string->atom */ { + char *s=strvalue(car(sc->args)); + long pf = 0; + if(cdr(sc->args)!=sc->NIL) { + /* we know cadr(sc->args) is a natural number */ + /* see if it is 2, 8, 10, or 16, or error */ + pf = ivalue_unchecked(cadr(sc->args)); + if(pf == 16 || pf == 10 || pf == 8 || pf == 2) { + /* base is OK */ + } + else { + pf = -1; + } + } + if (pf < 0) { + Error_1(sc, "string->atom: bad base:", cadr(sc->args)); + } else if(*s=='#') /* no use of base! */ { + s_return(sc, mk_sharp_const(sc, s+1)); + } else { + if (pf == 0 || pf == 10) { + s_return(sc, mk_atom(sc, s)); + } + else { + char *ep; + long iv = strtol(s,&ep,(int )pf); + if (*ep == 0) { + s_return(sc, mk_integer(sc, iv)); + } + else { + s_return(sc, sc->F); + } + } + } + } + + case OP_SYM2STR: /* symbol->string */ + x=mk_string(sc,symname(car(sc->args))); + setimmutable(x); + s_return(sc,x); + + case OP_ATOM2STR: /* atom->string */ { + long pf = 0; + x=car(sc->args); + if(cdr(sc->args)!=sc->NIL) { + /* we know cadr(sc->args) is a natural number */ + /* see if it is 2, 8, 10, or 16, or error */ + pf = ivalue_unchecked(cadr(sc->args)); + if(is_number(x) && (pf == 16 || pf == 10 || pf == 8 || pf == 2)) { + /* base is OK */ + } + else { + pf = -1; + } + } + if (pf < 0) { + Error_1(sc, "atom->string: bad base:", cadr(sc->args)); + } else if(is_number(x) || is_character(x) || is_string(x) || is_symbol(x)) { + char *p; + int len; + atom2str(sc,x,(int )pf,&p,&len); + s_return(sc,mk_counted_string(sc,p,len)); + } else { + Error_1(sc, "atom->string: not an atom:", x); + } + } + + case OP_MKSTRING: { /* make-string */ + int fill=' '; + int len; + + len=ivalue(car(sc->args)); + + if(cdr(sc->args)!=sc->NIL) { + fill=charvalue(cadr(sc->args)); + } + s_return(sc,mk_empty_string(sc,len,(char)fill)); + } + + case OP_STRLEN: /* string-length */ + s_return(sc,mk_integer(sc,strlength(car(sc->args)))); + + case OP_STRREF: { /* string-ref */ + char *str; + int index; + + str=strvalue(car(sc->args)); + + index=ivalue(cadr(sc->args)); + + if(index>=strlength(car(sc->args))) { + Error_1(sc,"string-ref: out of bounds:",cadr(sc->args)); + } + + s_return(sc,mk_character(sc,((unsigned char*)str)[index])); + } + + case OP_STRSET: { /* string-set! */ + char *str; + int index; + int c; + + if(is_immutable(car(sc->args))) { + Error_1(sc,"string-set!: unable to alter immutable string:",car(sc->args)); + } + str=strvalue(car(sc->args)); + + index=ivalue(cadr(sc->args)); + if(index>=strlength(car(sc->args))) { + Error_1(sc,"string-set!: out of bounds:",cadr(sc->args)); + } + + c=charvalue(caddr(sc->args)); + + str[index]=(char)c; + s_return(sc,car(sc->args)); + } + + case OP_STRAPPEND: { /* string-append */ + /* in 1.29 string-append was in Scheme in init.scm but was too slow */ + int len = 0; + pointer newstr; + char *pos; + + /* compute needed length for new string */ + for (x = sc->args; x != sc->NIL; x = cdr(x)) { + len += strlength(car(x)); + } + newstr = mk_empty_string(sc, len, ' '); + /* store the contents of the argument strings into the new string */ + for (pos = strvalue(newstr), x = sc->args; x != sc->NIL; + pos += strlength(car(x)), x = cdr(x)) { + memcpy(pos, strvalue(car(x)), strlength(car(x))); + } + s_return(sc, newstr); + } + + case OP_SUBSTR: { /* substring */ + char *str; + int index0; + int index1; + int len; + + str=strvalue(car(sc->args)); + + index0=ivalue(cadr(sc->args)); + + if(index0>strlength(car(sc->args))) { + Error_1(sc,"substring: start out of bounds:",cadr(sc->args)); + } + + if(cddr(sc->args)!=sc->NIL) { + index1=ivalue(caddr(sc->args)); + if(index1>strlength(car(sc->args)) || index1<index0) { + Error_1(sc,"substring: end out of bounds:",caddr(sc->args)); + } + } else { + index1=strlength(car(sc->args)); + } + + len=index1-index0; + x=mk_empty_string(sc,len,' '); + memcpy(strvalue(x),str+index0,len); + strvalue(x)[len]=0; + + s_return(sc,x); + } + + case OP_VECTOR: { /* vector */ + int i; + pointer vec; + int len=list_length(sc,sc->args); + if(len<0) { + Error_1(sc,"vector: not a proper list:",sc->args); + } + vec=mk_vector(sc,len); + if(sc->no_memory) { s_return(sc, sc->sink); } + for (x = sc->args, i = 0; is_pair(x); x = cdr(x), i++) { + set_vector_elem(vec,i,car(x)); + } + s_return(sc,vec); + } + + case OP_MKVECTOR: { /* make-vector */ + pointer fill=sc->NIL; + int len; + pointer vec; + + len=ivalue(car(sc->args)); + + if(cdr(sc->args)!=sc->NIL) { + fill=cadr(sc->args); + } + vec=mk_vector(sc,len); + if(sc->no_memory) { s_return(sc, sc->sink); } + if(fill!=sc->NIL) { + fill_vector(vec,fill); + } + s_return(sc,vec); + } + + case OP_VECLEN: /* vector-length */ + s_return(sc,mk_integer(sc,ivalue(car(sc->args)))); + + case OP_VECREF: { /* vector-ref */ + int index; + + index=ivalue(cadr(sc->args)); + + if(index>=ivalue(car(sc->args))) { + Error_1(sc,"vector-ref: out of bounds:",cadr(sc->args)); + } + + s_return(sc,vector_elem(car(sc->args),index)); + } + + case OP_VECSET: { /* vector-set! */ + int index; + + if(is_immutable(car(sc->args))) { + Error_1(sc,"vector-set!: unable to alter immutable vector:",car(sc->args)); + } + + index=ivalue(cadr(sc->args)); + if(index>=ivalue(car(sc->args))) { + Error_1(sc,"vector-set!: out of bounds:",cadr(sc->args)); + } + + set_vector_elem(car(sc->args),index,caddr(sc->args)); + s_return(sc,car(sc->args)); + } + + default: + snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); + Error_0(sc,sc->strbuff); + } + return sc->T; +} + +static int is_list(scheme *sc, pointer a) +{ return list_length(sc,a) >= 0; } + +/* Result is: + proper list: length + circular list: -1 + not even a pair: -2 + dotted list: -2 minus length before dot +*/ +int list_length(scheme *sc, pointer a) { + int i=0; + pointer slow, fast; + + slow = fast = a; + while (1) + { + if (fast == sc->NIL) + return i; + if (!is_pair(fast)) + return -2 - i; + fast = cdr(fast); + ++i; + if (fast == sc->NIL) + return i; + if (!is_pair(fast)) + return -2 - i; + ++i; + fast = cdr(fast); + + /* Safe because we would have already returned if `fast' + encountered a non-pair. */ + slow = cdr(slow); + if (fast == slow) + { + /* the fast pointer has looped back around and caught up + with the slow pointer, hence the structure is circular, + not of finite length, and therefore not a list */ + return -1; + } + } +} + +static pointer opexe_3(scheme *sc, enum scheme_opcodes op) { + pointer x; + num v; + int (*comp_func)(num,num)=0; + + switch (op) { + case OP_NOT: /* not */ + s_retbool(is_false(car(sc->args))); + case OP_BOOLP: /* boolean? */ + s_retbool(car(sc->args) == sc->F || car(sc->args) == sc->T); + case OP_EOFOBJP: /* boolean? */ + s_retbool(car(sc->args) == sc->EOF_OBJ); + case OP_NULLP: /* null? */ + s_retbool(car(sc->args) == sc->NIL); + case OP_NUMEQ: /* = */ + case OP_LESS: /* < */ + case OP_GRE: /* > */ + case OP_LEQ: /* <= */ + case OP_GEQ: /* >= */ + switch(op) { + case OP_NUMEQ: comp_func=num_eq; break; + case OP_LESS: comp_func=num_lt; break; + case OP_GRE: comp_func=num_gt; break; + case OP_LEQ: comp_func=num_le; break; + case OP_GEQ: comp_func=num_ge; break; + default: assert (! "reached"); + } + x=sc->args; + v=nvalue(car(x)); + x=cdr(x); + + for (; x != sc->NIL; x = cdr(x)) { + if(!comp_func(v,nvalue(car(x)))) { + s_retbool(0); + } + v=nvalue(car(x)); + } + s_retbool(1); + case OP_SYMBOLP: /* symbol? */ + s_retbool(is_symbol(car(sc->args))); + case OP_NUMBERP: /* number? */ + s_retbool(is_number(car(sc->args))); + case OP_STRINGP: /* string? */ + s_retbool(is_string(car(sc->args))); + case OP_INTEGERP: /* integer? */ + s_retbool(is_integer(car(sc->args))); + case OP_REALP: /* real? */ + s_retbool(is_number(car(sc->args))); /* All numbers are real */ + case OP_CHARP: /* char? */ + s_retbool(is_character(car(sc->args))); +#if USE_CHAR_CLASSIFIERS + case OP_CHARAP: /* char-alphabetic? */ + s_retbool(Cisalpha(ivalue(car(sc->args)))); + case OP_CHARNP: /* char-numeric? */ + s_retbool(Cisdigit(ivalue(car(sc->args)))); + case OP_CHARWP: /* char-whitespace? */ + s_retbool(Cisspace(ivalue(car(sc->args)))); + case OP_CHARUP: /* char-upper-case? */ + s_retbool(Cisupper(ivalue(car(sc->args)))); + case OP_CHARLP: /* char-lower-case? */ + s_retbool(Cislower(ivalue(car(sc->args)))); +#endif + case OP_PORTP: /* port? */ + s_retbool(is_port(car(sc->args))); + case OP_INPORTP: /* input-port? */ + s_retbool(is_inport(car(sc->args))); + case OP_OUTPORTP: /* output-port? */ + s_retbool(is_outport(car(sc->args))); + case OP_PROCP: /* procedure? */ + /*-- + * continuation should be procedure by the example + * (call-with-current-continuation procedure?) ==> #t + * in R^3 report sec. 6.9 + */ + s_retbool(is_proc(car(sc->args)) || is_closure(car(sc->args)) + || is_continuation(car(sc->args)) || is_foreign(car(sc->args))); + case OP_PAIRP: /* pair? */ + s_retbool(is_pair(car(sc->args))); + case OP_LISTP: /* list? */ + s_retbool(list_length(sc,car(sc->args)) >= 0); + + case OP_ENVP: /* environment? */ + s_retbool(is_environment(car(sc->args))); + case OP_VECTORP: /* vector? */ + s_retbool(is_vector(car(sc->args))); + case OP_EQ: /* eq? */ + s_retbool(car(sc->args) == cadr(sc->args)); + case OP_EQV: /* eqv? */ + s_retbool(eqv(car(sc->args), cadr(sc->args))); + default: + snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); + Error_0(sc,sc->strbuff); + } + return sc->T; +} + +static pointer opexe_4(scheme *sc, enum scheme_opcodes op) { + pointer x, y; + + switch (op) { + case OP_FORCE: /* force */ + sc->code = car(sc->args); + if (is_promise(sc->code)) { + /* Should change type to closure here */ + s_save(sc, OP_SAVE_FORCED, sc->NIL, sc->code); + sc->args = sc->NIL; + s_goto(sc,OP_APPLY); + } else { + s_return(sc,sc->code); + } + + case OP_SAVE_FORCED: /* Save forced value replacing promise */ + memcpy(sc->code,sc->value,sizeof(struct cell)); + s_return(sc,sc->value); + + case OP_WRITE: /* write */ + case OP_DISPLAY: /* display */ + case OP_WRITE_CHAR: /* write-char */ + if(is_pair(cdr(sc->args))) { + if(cadr(sc->args)!=sc->outport) { + x=cons(sc,sc->outport,sc->NIL); + s_save(sc,OP_SET_OUTPORT, x, sc->NIL); + sc->outport=cadr(sc->args); + } + } + sc->args = car(sc->args); + if(op==OP_WRITE) { + sc->print_flag = 1; + } else { + sc->print_flag = 0; + } + s_goto(sc,OP_P0LIST); + + case OP_NEWLINE: /* newline */ + if(is_pair(sc->args)) { + if(car(sc->args)!=sc->outport) { + x=cons(sc,sc->outport,sc->NIL); + s_save(sc,OP_SET_OUTPORT, x, sc->NIL); + sc->outport=car(sc->args); + } + } + putstr(sc, "\n"); + s_return(sc,sc->T); + + case OP_ERR0: /* error */ + sc->retcode=-1; + if (!is_string(car(sc->args))) { + sc->args=cons(sc,mk_string(sc," -- "),sc->args); + setimmutable(car(sc->args)); + } + putstr(sc, "Error: "); + putstr(sc, strvalue(car(sc->args))); + sc->args = cdr(sc->args); + s_goto(sc,OP_ERR1); + + case OP_ERR1: /* error */ + putstr(sc, " "); + if (sc->args != sc->NIL) { + s_save(sc,OP_ERR1, cdr(sc->args), sc->NIL); + sc->args = car(sc->args); + sc->print_flag = 1; + s_goto(sc,OP_P0LIST); + } else { + putstr(sc, "\n"); + if(sc->interactive_repl) { + s_goto(sc,OP_T0LVL); + } else { + return sc->NIL; + } + } + + case OP_REVERSE: /* reverse */ + s_return(sc,reverse(sc, car(sc->args))); + + case OP_LIST_STAR: /* list* */ + s_return(sc,list_star(sc,sc->args)); + + case OP_APPEND: /* append */ + x = sc->NIL; + y = sc->args; + if (y == x) { + s_return(sc, x); + } + + /* cdr() in the while condition is not a typo. If car() */ + /* is used (append '() 'a) will return the wrong result.*/ + while (cdr(y) != sc->NIL) { + x = revappend(sc, x, car(y)); + y = cdr(y); + if (x == sc->F) { + Error_0(sc, "non-list argument to append"); + } + } + + s_return(sc, reverse_in_place(sc, car(y), x)); + +#if USE_PLIST + case OP_PUT: /* put */ + if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) { + Error_0(sc,"illegal use of put"); + } + for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) { + if (caar(x) == y) { + break; + } + } + if (x != sc->NIL) + cdar(x) = caddr(sc->args); + else + symprop(car(sc->args)) = cons(sc, cons(sc, y, caddr(sc->args)), + symprop(car(sc->args))); + s_return(sc,sc->T); + + case OP_GET: /* get */ + if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) { + Error_0(sc,"illegal use of get"); + } + for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) { + if (caar(x) == y) { + break; + } + } + if (x != sc->NIL) { + s_return(sc,cdar(x)); + } else { + s_return(sc,sc->NIL); + } +#endif /* USE_PLIST */ + case OP_QUIT: /* quit */ + if(is_pair(sc->args)) { + sc->retcode=ivalue(car(sc->args)); + } + return (sc->NIL); + + case OP_GC: /* gc */ + gc(sc, sc->NIL, sc->NIL); + s_return(sc,sc->T); + + case OP_GCVERB: /* gc-verbose */ + { int was = sc->gc_verbose; + + sc->gc_verbose = (car(sc->args) != sc->F); + s_retbool(was); + } + + case OP_NEWSEGMENT: /* new-segment */ + if (!is_pair(sc->args) || !is_number(car(sc->args))) { + Error_0(sc,"new-segment: argument must be a number"); + } + alloc_cellseg(sc, (int) ivalue(car(sc->args))); + s_return(sc,sc->T); + + case OP_OBLIST: /* oblist */ + s_return(sc, oblist_all_symbols(sc)); + + case OP_CURR_INPORT: /* current-input-port */ + s_return(sc,sc->inport); + + case OP_CURR_OUTPORT: /* current-output-port */ + s_return(sc,sc->outport); + + case OP_OPEN_INFILE: /* open-input-file */ + case OP_OPEN_OUTFILE: /* open-output-file */ + case OP_OPEN_INOUTFILE: /* open-input-output-file */ { + int prop=0; + pointer p; + switch(op) { + case OP_OPEN_INFILE: prop=port_input; break; + case OP_OPEN_OUTFILE: prop=port_output; break; + case OP_OPEN_INOUTFILE: prop=port_input|port_output; break; + default: assert (! "reached"); + } + p=port_from_filename(sc,strvalue(car(sc->args)),prop); + if(p==sc->NIL) { + s_return(sc,sc->F); + } + s_return(sc,p); + break; + default: assert (! "reached"); + } + +#if USE_STRING_PORTS + case OP_OPEN_INSTRING: /* open-input-string */ + case OP_OPEN_INOUTSTRING: /* open-input-output-string */ { + int prop=0; + pointer p; + switch(op) { + case OP_OPEN_INSTRING: prop=port_input; break; + case OP_OPEN_INOUTSTRING: prop=port_input|port_output; break; + default: assert (! "reached"); + } + p=port_from_string(sc, strvalue(car(sc->args)), + strvalue(car(sc->args))+strlength(car(sc->args)), prop); + if(p==sc->NIL) { + s_return(sc,sc->F); + } + s_return(sc,p); + } + case OP_OPEN_OUTSTRING: /* open-output-string */ { + pointer p; + if(car(sc->args)==sc->NIL) { + p=port_from_scratch(sc); + if(p==sc->NIL) { + s_return(sc,sc->F); + } + } else { + p=port_from_string(sc, strvalue(car(sc->args)), + strvalue(car(sc->args))+strlength(car(sc->args)), + port_output); + if(p==sc->NIL) { + s_return(sc,sc->F); + } + } + s_return(sc,p); + } + case OP_GET_OUTSTRING: /* get-output-string */ { + port *p; + + if ((p=car(sc->args)->_object._port)->kind&port_string) { + off_t size; + char *str; + + size=p->rep.string.curr-p->rep.string.start+1; + str=sc->malloc(size); + if(str != NULL) { + pointer s; + + memcpy(str,p->rep.string.start,size-1); + str[size-1]='\0'; + s=mk_string(sc,str); + sc->free(str); + s_return(sc,s); + } + } + s_return(sc,sc->F); + } +#endif + + case OP_CLOSE_INPORT: /* close-input-port */ + port_close(sc,car(sc->args),port_input); + s_return(sc,sc->T); + + case OP_CLOSE_OUTPORT: /* close-output-port */ + port_close(sc,car(sc->args),port_output); + s_return(sc,sc->T); + + case OP_INT_ENV: /* interaction-environment */ + s_return(sc,sc->global_env); + + case OP_CURR_ENV: /* current-environment */ + s_return(sc,sc->envir); + + } + return sc->T; +} + +static pointer opexe_5(scheme *sc, enum scheme_opcodes op) { + pointer x; + + if(sc->nesting!=0) { + int n=sc->nesting; + sc->nesting=0; + sc->retcode=-1; + Error_1(sc,"unmatched parentheses:",mk_integer(sc,n)); + } + + switch (op) { + /* ========== reading part ========== */ + case OP_READ: + if(!is_pair(sc->args)) { + s_goto(sc,OP_READ_INTERNAL); + } + if(!is_inport(car(sc->args))) { + Error_1(sc,"read: not an input port:",car(sc->args)); + } + if(car(sc->args)==sc->inport) { + s_goto(sc,OP_READ_INTERNAL); + } + x=sc->inport; + sc->inport=car(sc->args); + x=cons(sc,x,sc->NIL); + s_save(sc,OP_SET_INPORT, x, sc->NIL); + s_goto(sc,OP_READ_INTERNAL); + + case OP_READ_CHAR: /* read-char */ + case OP_PEEK_CHAR: /* peek-char */ { + int c; + if(is_pair(sc->args)) { + if(car(sc->args)!=sc->inport) { + x=sc->inport; + x=cons(sc,x,sc->NIL); + s_save(sc,OP_SET_INPORT, x, sc->NIL); + sc->inport=car(sc->args); + } + } + c=inchar(sc); + if(c==EOF) { + s_return(sc,sc->EOF_OBJ); + } + if(sc->op==OP_PEEK_CHAR) { + backchar(sc,c); + } + s_return(sc,mk_character(sc,c)); + } + + case OP_CHAR_READY: /* char-ready? */ { + pointer p=sc->inport; + int res; + if(is_pair(sc->args)) { + p=car(sc->args); + } + res=p->_object._port->kind&port_string; + s_retbool(res); + } + + case OP_SET_INPORT: /* set-input-port */ + sc->inport=car(sc->args); + s_return(sc,sc->value); + + case OP_SET_OUTPORT: /* set-output-port */ + sc->outport=car(sc->args); + s_return(sc,sc->value); + + case OP_RDSEXPR: + switch (sc->tok) { + case TOK_EOF: + s_return(sc,sc->EOF_OBJ); + /* NOTREACHED */ +/* + * Commented out because we now skip comments in the scanner + * + case TOK_COMMENT: { + int c; + while ((c=inchar(sc)) != '\n' && c!=EOF) + ; + sc->tok = token(sc); + s_goto(sc,OP_RDSEXPR); + } +*/ + case TOK_VEC: + s_save(sc,OP_RDVEC,sc->NIL,sc->NIL); + /* fall through */ + case TOK_LPAREN: + sc->tok = token(sc); + if (sc->tok == TOK_RPAREN) { + s_return(sc,sc->NIL); + } else if (sc->tok == TOK_DOT) { + Error_0(sc,"syntax error: illegal dot expression"); + } else { + sc->nesting_stack[sc->file_i]++; + s_save(sc,OP_RDLIST, sc->NIL, sc->NIL); + s_goto(sc,OP_RDSEXPR); + } + case TOK_QUOTE: + s_save(sc,OP_RDQUOTE, sc->NIL, sc->NIL); + sc->tok = token(sc); + s_goto(sc,OP_RDSEXPR); + case TOK_BQUOTE: + sc->tok = token(sc); + if(sc->tok==TOK_VEC) { + s_save(sc,OP_RDQQUOTEVEC, sc->NIL, sc->NIL); + sc->tok=TOK_LPAREN; + s_goto(sc,OP_RDSEXPR); + } else { + s_save(sc,OP_RDQQUOTE, sc->NIL, sc->NIL); + } + s_goto(sc,OP_RDSEXPR); + case TOK_COMMA: + s_save(sc,OP_RDUNQUOTE, sc->NIL, sc->NIL); + sc->tok = token(sc); + s_goto(sc,OP_RDSEXPR); + case TOK_ATMARK: + s_save(sc,OP_RDUQTSP, sc->NIL, sc->NIL); + sc->tok = token(sc); + s_goto(sc,OP_RDSEXPR); + case TOK_ATOM: + s_return(sc,mk_atom(sc, readstr_upto(sc, DELIMITERS))); + case TOK_DQUOTE: + x=readstrexp(sc); + if(x==sc->F) { + Error_0(sc,"Error reading string"); + } + setimmutable(x); + s_return(sc,x); + case TOK_SHARP: { + pointer f=find_slot_in_env(sc,sc->envir,sc->SHARP_HOOK,1); + if(f==sc->NIL) { + Error_0(sc,"undefined sharp expression"); + } else { + sc->code=cons(sc,slot_value_in_env(f),sc->NIL); + s_goto(sc,OP_EVAL); + } + } + case TOK_SHARP_CONST: + if ((x = mk_sharp_const(sc, readstr_upto(sc, DELIMITERS))) == sc->NIL) { + Error_0(sc,"undefined sharp expression"); + } else { + s_return(sc,x); + } + default: + Error_0(sc,"syntax error: illegal token"); + } + break; + + case OP_RDLIST: { + sc->args = cons(sc, sc->value, sc->args); + sc->tok = token(sc); +/* We now skip comments in the scanner + while (sc->tok == TOK_COMMENT) { + int c; + while ((c=inchar(sc)) != '\n' && c!=EOF) + ; + sc->tok = token(sc); + } +*/ + if (sc->tok == TOK_EOF) + { s_return(sc,sc->EOF_OBJ); } + else if (sc->tok == TOK_RPAREN) { + int c = inchar(sc); + if (c != '\n') + backchar(sc,c); +#if SHOW_ERROR_LINE + else if (sc->load_stack[sc->file_i].kind & port_file) + sc->load_stack[sc->file_i].rep.stdio.curr_line++; +#endif + sc->nesting_stack[sc->file_i]--; + s_return(sc,reverse_in_place(sc, sc->NIL, sc->args)); + } else if (sc->tok == TOK_DOT) { + s_save(sc,OP_RDDOT, sc->args, sc->NIL); + sc->tok = token(sc); + s_goto(sc,OP_RDSEXPR); + } else { + s_save(sc,OP_RDLIST, sc->args, sc->NIL);; + s_goto(sc,OP_RDSEXPR); + } + } + + case OP_RDDOT: + if (token(sc) != TOK_RPAREN) { + Error_0(sc,"syntax error: illegal dot expression"); + } else { + sc->nesting_stack[sc->file_i]--; + s_return(sc,reverse_in_place(sc, sc->value, sc->args)); + } + + case OP_RDQUOTE: + s_return(sc,cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL))); + + case OP_RDQQUOTE: + s_return(sc,cons(sc, sc->QQUOTE, cons(sc, sc->value, sc->NIL))); + + case OP_RDQQUOTEVEC: + s_return(sc,cons(sc, mk_symbol(sc,"apply"), + cons(sc, mk_symbol(sc,"vector"), + cons(sc,cons(sc, sc->QQUOTE, + cons(sc,sc->value,sc->NIL)), + sc->NIL)))); + + case OP_RDUNQUOTE: + s_return(sc,cons(sc, sc->UNQUOTE, cons(sc, sc->value, sc->NIL))); + + case OP_RDUQTSP: + s_return(sc,cons(sc, sc->UNQUOTESP, cons(sc, sc->value, sc->NIL))); + + case OP_RDVEC: + /*sc->code=cons(sc,mk_proc(sc,OP_VECTOR),sc->value); + s_goto(sc,OP_EVAL); Cannot be quoted*/ + /*x=cons(sc,mk_proc(sc,OP_VECTOR),sc->value); + s_return(sc,x); Cannot be part of pairs*/ + /*sc->code=mk_proc(sc,OP_VECTOR); + sc->args=sc->value; + s_goto(sc,OP_APPLY);*/ + sc->args=sc->value; + s_goto(sc,OP_VECTOR); + + /* ========== printing part ========== */ + case OP_P0LIST: + if(is_vector(sc->args)) { + putstr(sc,"#("); + sc->args=cons(sc,sc->args,mk_integer(sc,0)); + s_goto(sc,OP_PVECFROM); + } else if(is_environment(sc->args)) { + putstr(sc,"#<ENVIRONMENT>"); + s_return(sc,sc->T); + } else if (!is_pair(sc->args)) { + printatom(sc, sc->args, sc->print_flag); + s_return(sc,sc->T); + } else if (car(sc->args) == sc->QUOTE && ok_abbrev(cdr(sc->args))) { + putstr(sc, "'"); + sc->args = cadr(sc->args); + s_goto(sc,OP_P0LIST); + } else if (car(sc->args) == sc->QQUOTE && ok_abbrev(cdr(sc->args))) { + putstr(sc, "`"); + sc->args = cadr(sc->args); + s_goto(sc,OP_P0LIST); + } else if (car(sc->args) == sc->UNQUOTE && ok_abbrev(cdr(sc->args))) { + putstr(sc, ","); + sc->args = cadr(sc->args); + s_goto(sc,OP_P0LIST); + } else if (car(sc->args) == sc->UNQUOTESP && ok_abbrev(cdr(sc->args))) { + putstr(sc, ",@"); + sc->args = cadr(sc->args); + s_goto(sc,OP_P0LIST); + } else { + putstr(sc, "("); + s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL); + sc->args = car(sc->args); + s_goto(sc,OP_P0LIST); + } + + case OP_P1LIST: + if (is_pair(sc->args)) { + s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL); + putstr(sc, " "); + sc->args = car(sc->args); + s_goto(sc,OP_P0LIST); + } else if(is_vector(sc->args)) { + s_save(sc,OP_P1LIST,sc->NIL,sc->NIL); + putstr(sc, " . "); + s_goto(sc,OP_P0LIST); + } else { + if (sc->args != sc->NIL) { + putstr(sc, " . "); + printatom(sc, sc->args, sc->print_flag); + } + putstr(sc, ")"); + s_return(sc,sc->T); + } + case OP_PVECFROM: { + int i=ivalue_unchecked(cdr(sc->args)); + pointer vec=car(sc->args); + int len=ivalue_unchecked(vec); + if(i==len) { + putstr(sc,")"); + s_return(sc,sc->T); + } else { + pointer elem=vector_elem(vec,i); + ivalue_unchecked(cdr(sc->args))=i+1; + s_save(sc,OP_PVECFROM, sc->args, sc->NIL); + sc->args=elem; + if (i > 0) + putstr(sc," "); + s_goto(sc,OP_P0LIST); + } + } + + default: + snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); + Error_0(sc,sc->strbuff); + + } + return sc->T; +} + +static pointer opexe_6(scheme *sc, enum scheme_opcodes op) { + pointer x, y; + long v; + + switch (op) { + case OP_LIST_LENGTH: /* length */ /* a.k */ + v=list_length(sc,car(sc->args)); + if(v<0) { + Error_1(sc,"length: not a list:",car(sc->args)); + } + s_return(sc,mk_integer(sc, v)); + + case OP_ASSQ: /* assq */ /* a.k */ + x = car(sc->args); + for (y = cadr(sc->args); is_pair(y); y = cdr(y)) { + if (!is_pair(car(y))) { + Error_0(sc,"unable to handle non pair element"); + } + if (x == caar(y)) + break; + } + if (is_pair(y)) { + s_return(sc,car(y)); + } else { + s_return(sc,sc->F); + } + + + case OP_GET_CLOSURE: /* get-closure-code */ /* a.k */ + sc->args = car(sc->args); + if (sc->args == sc->NIL) { + s_return(sc,sc->F); + } else if (is_closure(sc->args)) { + s_return(sc,cons(sc, sc->LAMBDA, closure_code(sc->value))); + } else if (is_macro(sc->args)) { + s_return(sc,cons(sc, sc->LAMBDA, closure_code(sc->value))); + } else { + s_return(sc,sc->F); + } + case OP_CLOSUREP: /* closure? */ + /* + * Note, macro object is also a closure. + * Therefore, (closure? <#MACRO>) ==> #t + */ + s_retbool(is_closure(car(sc->args))); + case OP_MACROP: /* macro? */ + s_retbool(is_macro(car(sc->args))); + default: + snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); + Error_0(sc,sc->strbuff); + } + return sc->T; /* NOTREACHED */ +} + +typedef pointer (*dispatch_func)(scheme *, enum scheme_opcodes); + +typedef int (*test_predicate)(pointer); + +static int is_any(pointer p) { + (void)p; + return 1; +} + +static int is_nonneg(pointer p) { + return ivalue(p)>=0 && is_integer(p); +} + +/* Correspond carefully with following defines! */ +static struct { + test_predicate fct; + const char *kind; +} tests[]={ + {0,0}, /* unused */ + {is_any, 0}, + {is_string, "string"}, + {is_symbol, "symbol"}, + {is_port, "port"}, + {is_inport,"input port"}, + {is_outport,"output port"}, + {is_environment, "environment"}, + {is_pair, "pair"}, + {0, "pair or '()"}, + {is_character, "character"}, + {is_vector, "vector"}, + {is_number, "number"}, + {is_integer, "integer"}, + {is_nonneg, "non-negative integer"} +}; + +#define TST_NONE 0 +#define TST_ANY "\001" +#define TST_STRING "\002" +#define TST_SYMBOL "\003" +#define TST_PORT "\004" +#define TST_INPORT "\005" +#define TST_OUTPORT "\006" +#define TST_ENVIRONMENT "\007" +#define TST_PAIR "\010" +#define TST_LIST "\011" +#define TST_CHAR "\012" +#define TST_VECTOR "\013" +#define TST_NUMBER "\014" +#define TST_INTEGER "\015" +#define TST_NATURAL "\016" + +typedef struct { + dispatch_func func; + char *name; + int min_arity; + int max_arity; + char *arg_tests_encoding; +} op_code_info; + +#define INF_ARG 0xffff + +static op_code_info dispatch_table[]= { +#define _OP_DEF(A,B,C,D,E,OP) {A,B,C,D,E}, +#include "opdefines.h" + { 0 } +}; + +static const char *procname(pointer x) { + int n=procnum(x); + const char *name=dispatch_table[n].name; + if(name==0) { + name="ILLEGAL!"; + } + return name; +} + +/* kernel of this interpreter */ +static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) { + sc->op = op; + for (;;) { + op_code_info *pcd=dispatch_table+sc->op; + if (pcd->name!=0) { /* if built-in function, check arguments */ + char msg[STRBUFFSIZE]; + int ok=1; + int n=list_length(sc,sc->args); + + /* Check number of arguments */ + if(n<pcd->min_arity) { + ok=0; + snprintf(msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", + pcd->name, + pcd->min_arity==pcd->max_arity?"":" at least", + pcd->min_arity); + } + if(ok && n>pcd->max_arity) { + ok=0; + snprintf(msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", + pcd->name, + pcd->min_arity==pcd->max_arity?"":" at most", + pcd->max_arity); + } + if(ok) { + if(pcd->arg_tests_encoding!=0) { + int i=0; + int j; + const char *t=pcd->arg_tests_encoding; + pointer arglist=sc->args; + do { + pointer arg=car(arglist); + j=(int)t[0]; + if(j==TST_LIST[0]) { + if(arg!=sc->NIL && !is_pair(arg)) break; + } else { + if(!tests[j].fct(arg)) break; + } + + if(t[1]!=0) {/* last test is replicated as necessary */ + t++; + } + arglist=cdr(arglist); + i++; + } while(i<n); + if(i<n) { + ok=0; + snprintf(msg, STRBUFFSIZE, "%s: argument %d must be: %s, got: %s", + pcd->name, + i+1, + tests[j].kind, + type_to_string(type(car(arglist)))); + } + } + } + if(!ok) { + if(_Error_1(sc,msg,0)==sc->NIL) { + return; + } + pcd=dispatch_table+sc->op; + } + } + ok_to_freely_gc(sc); + if (pcd->func(sc, (enum scheme_opcodes)sc->op) == sc->NIL) { + return; + } + if(sc->no_memory) { + fprintf(stderr,"No memory!\n"); + exit(1); + } + } +} + +/* ========== Initialization of internal keywords ========== */ + +static void assign_syntax(scheme *sc, char *name) { + pointer x; + + x = oblist_add_by_name(sc, name); + typeflag(x) |= T_SYNTAX; +} + +static void assign_proc(scheme *sc, enum scheme_opcodes op, char *name) { + pointer x, y; + + x = mk_symbol(sc, name); + y = mk_proc(sc,op); + new_slot_in_env(sc, x, y); +} + +static pointer mk_proc(scheme *sc, enum scheme_opcodes op) { + pointer y; + + y = get_cell(sc, sc->NIL, sc->NIL); + typeflag(y) = (T_PROC | T_ATOM); + ivalue_unchecked(y) = (long) op; + set_num_integer(y); + return y; +} + +/* Hard-coded for the given keywords. Remember to rewrite if more are added! */ +static int syntaxnum(pointer p) { + const char *s=strvalue(car(p)); + switch(strlength(car(p))) { + case 2: + if(s[0]=='i') return OP_IF0; /* if */ + else return OP_OR0; /* or */ + case 3: + if(s[0]=='a') return OP_AND0; /* and */ + else return OP_LET0; /* let */ + case 4: + switch(s[3]) { + case 'e': return OP_CASE0; /* case */ + case 'd': return OP_COND0; /* cond */ + case '*': return OP_LET0AST; /* let* */ + default: return OP_SET0; /* set! */ + } + case 5: + switch(s[2]) { + case 'g': return OP_BEGIN; /* begin */ + case 'l': return OP_DELAY; /* delay */ + case 'c': return OP_MACRO0; /* macro */ + default: return OP_QUOTE; /* quote */ + } + case 6: + switch(s[2]) { + case 'm': return OP_LAMBDA; /* lambda */ + case 'f': return OP_DEF0; /* define */ + default: return OP_LET0REC; /* letrec */ + } + default: + return OP_C0STREAM; /* cons-stream */ + } +} + +/* initialization of TinyScheme */ +#if USE_INTERFACE +INTERFACE static pointer s_cons(scheme *sc, pointer a, pointer b) { + return cons(sc,a,b); +} +INTERFACE static pointer s_immutable_cons(scheme *sc, pointer a, pointer b) { + return immutable_cons(sc,a,b); +} + +static struct scheme_interface vtbl ={ + scheme_define, + s_cons, + s_immutable_cons, + reserve_cells, + mk_integer, + mk_real, + mk_symbol, + gensym, + mk_string, + mk_counted_string, + mk_character, + mk_vector, + mk_foreign_func, + mk_foreign_object, + get_foreign_object_vtable, + get_foreign_object_data, + putstr, + putcharacter, + + is_string, + string_value, + is_number, + nvalue, + ivalue, + rvalue, + is_integer, + is_real, + is_character, + charvalue, + is_list, + is_vector, + list_length, + ivalue, + fill_vector, + vector_elem, + set_vector_elem, + is_port, + is_pair, + pair_car, + pair_cdr, + set_car, + set_cdr, + + is_symbol, + symname, + + is_syntax, + is_proc, + is_foreign, + syntaxname, + is_closure, + is_macro, + closure_code, + closure_env, + + is_continuation, + is_promise, + is_environment, + is_immutable, + setimmutable, + + scheme_load_file, + scheme_load_string, + port_from_file +}; +#endif + +scheme *scheme_init_new() { + scheme *sc=(scheme*)malloc(sizeof(scheme)); + if(!scheme_init(sc)) { + free(sc); + return 0; + } else { + return sc; + } +} + +scheme *scheme_init_new_custom_alloc(func_alloc malloc, func_dealloc free) { + scheme *sc=(scheme*)malloc(sizeof(scheme)); + if(!scheme_init_custom_alloc(sc,malloc,free)) { + free(sc); + return 0; + } else { + return sc; + } +} + + +int scheme_init(scheme *sc) { + return scheme_init_custom_alloc(sc,malloc,free); +} + +int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) { + int i, n=sizeof(dispatch_table)/sizeof(dispatch_table[0]); + pointer x; + + num_zero.is_fixnum=1; + num_zero.value.ivalue=0; + num_one.is_fixnum=1; + num_one.value.ivalue=1; + +#if USE_INTERFACE + sc->vptr=&vtbl; +#endif + sc->gensym_cnt=0; + sc->malloc=malloc; + sc->free=free; + sc->last_cell_seg = -1; + sc->sink = &sc->_sink; + sc->NIL = &sc->_NIL; + sc->T = &sc->_HASHT; + sc->F = &sc->_HASHF; + sc->EOF_OBJ=&sc->_EOF_OBJ; + sc->free_cell = &sc->_NIL; + sc->fcells = 0; + sc->no_memory=0; + sc->inport=sc->NIL; + sc->outport=sc->NIL; + sc->save_inport=sc->NIL; + sc->loadport=sc->NIL; + sc->nesting=0; + sc->interactive_repl=0; + sc->strbuff = sc->malloc(STRBUFFSIZE); + if (sc->strbuff == 0) { + sc->no_memory=1; + return 0; + } + sc->strbuff_size = STRBUFFSIZE; + + if (alloc_cellseg(sc,FIRST_CELLSEGS) != FIRST_CELLSEGS) { + sc->no_memory=1; + return 0; + } + sc->gc_verbose = 0; + dump_stack_initialize(sc); + sc->code = sc->NIL; + sc->tracing=0; + + /* init sc->NIL */ + typeflag(sc->NIL) = (T_NIL | T_ATOM | MARK); + car(sc->NIL) = cdr(sc->NIL) = sc->NIL; + /* init T */ + typeflag(sc->T) = (T_BOOLEAN | T_ATOM | MARK); + car(sc->T) = cdr(sc->T) = sc->T; + /* init F */ + typeflag(sc->F) = (T_BOOLEAN | T_ATOM | MARK); + car(sc->F) = cdr(sc->F) = sc->F; + /* init EOF_OBJ */ + typeflag(sc->EOF_OBJ) = (T_EOF_OBJ | T_ATOM | MARK); + car(sc->EOF_OBJ) = cdr(sc->EOF_OBJ) = sc->EOF_OBJ; + /* init sink */ + typeflag(sc->sink) = (T_SINK | T_PAIR | MARK); + car(sc->sink) = sc->NIL; + /* init c_nest */ + sc->c_nest = sc->NIL; + + sc->oblist = oblist_initial_value(sc); + /* init global_env */ + new_frame_in_env(sc, sc->NIL); + sc->global_env = sc->envir; + /* init else */ + x = mk_symbol(sc,"else"); + new_slot_in_env(sc, x, sc->T); + + assign_syntax(sc, "lambda"); + assign_syntax(sc, "quote"); + assign_syntax(sc, "define"); + assign_syntax(sc, "if"); + assign_syntax(sc, "begin"); + assign_syntax(sc, "set!"); + assign_syntax(sc, "let"); + assign_syntax(sc, "let*"); + assign_syntax(sc, "letrec"); + assign_syntax(sc, "cond"); + assign_syntax(sc, "delay"); + assign_syntax(sc, "and"); + assign_syntax(sc, "or"); + assign_syntax(sc, "cons-stream"); + assign_syntax(sc, "macro"); + assign_syntax(sc, "case"); + + for(i=0; i<n; i++) { + if(dispatch_table[i].name!=0) { + assign_proc(sc, (enum scheme_opcodes)i, dispatch_table[i].name); + } + } + + /* initialization of global pointers to special symbols */ + sc->LAMBDA = mk_symbol(sc, "lambda"); + sc->QUOTE = mk_symbol(sc, "quote"); + sc->QQUOTE = mk_symbol(sc, "quasiquote"); + sc->UNQUOTE = mk_symbol(sc, "unquote"); + sc->UNQUOTESP = mk_symbol(sc, "unquote-splicing"); + sc->FEED_TO = mk_symbol(sc, "=>"); + sc->COLON_HOOK = mk_symbol(sc,"*colon-hook*"); + sc->ERROR_HOOK = mk_symbol(sc, "*error-hook*"); + sc->SHARP_HOOK = mk_symbol(sc, "*sharp-hook*"); + sc->COMPILE_HOOK = mk_symbol(sc, "*compile-hook*"); + + return !sc->no_memory; +} + +void scheme_set_input_port_file(scheme *sc, FILE *fin) { + sc->inport=port_from_file(sc,fin,port_input); +} + +void scheme_set_input_port_string(scheme *sc, char *start, char *past_the_end) { + sc->inport=port_from_string(sc,start,past_the_end,port_input); +} + +void scheme_set_output_port_file(scheme *sc, FILE *fout) { + sc->outport=port_from_file(sc,fout,port_output); +} + +void scheme_set_output_port_string(scheme *sc, char *start, char *past_the_end) { + sc->outport=port_from_string(sc,start,past_the_end,port_output); +} + +void scheme_set_external_data(scheme *sc, void *p) { + sc->ext_data=p; +} + +void scheme_deinit(scheme *sc) { + int i; + +#if SHOW_ERROR_LINE + char *fname; +#endif + + sc->oblist=sc->NIL; + sc->global_env=sc->NIL; + dump_stack_free(sc); + sc->envir=sc->NIL; + sc->code=sc->NIL; + sc->args=sc->NIL; + sc->value=sc->NIL; + if(is_port(sc->inport)) { + typeflag(sc->inport) = T_ATOM; + } + sc->inport=sc->NIL; + sc->outport=sc->NIL; + if(is_port(sc->save_inport)) { + typeflag(sc->save_inport) = T_ATOM; + } + sc->save_inport=sc->NIL; + if(is_port(sc->loadport)) { + typeflag(sc->loadport) = T_ATOM; + } + sc->loadport=sc->NIL; + sc->gc_verbose=0; + gc(sc,sc->NIL,sc->NIL); + + for(i=0; i<=sc->last_cell_seg; i++) { + sc->free(sc->alloc_seg[i]); + } + sc->free(sc->strbuff); + +#if SHOW_ERROR_LINE + for(i=0; i<=sc->file_i; i++) { + if (sc->load_stack[i].kind & port_file) { + fname = sc->load_stack[i].rep.stdio.filename; + if(fname) + sc->free(fname); + } + } +#endif +} + +void scheme_load_file(scheme *sc, FILE *fin) +{ scheme_load_named_file(sc,fin,0); } + +void scheme_load_named_file(scheme *sc, FILE *fin, const char *filename) { + dump_stack_reset(sc); + sc->envir = sc->global_env; + sc->file_i=0; + sc->load_stack[0].kind=port_input|port_file; + sc->load_stack[0].rep.stdio.file=fin; + sc->loadport=mk_port(sc,sc->load_stack); + sc->retcode=0; + if(fin==stdin) { + sc->interactive_repl=1; + } + +#if SHOW_ERROR_LINE + sc->load_stack[0].rep.stdio.curr_line = 0; + if(fin!=stdin && filename) + sc->load_stack[0].rep.stdio.filename = store_string(sc, strlen(filename), filename, 0); + else + sc->load_stack[0].rep.stdio.filename = NULL; +#endif + + sc->inport=sc->loadport; + sc->args = mk_integer(sc,sc->file_i); + Eval_Cycle(sc, OP_T0LVL); + typeflag(sc->loadport)=T_ATOM; + if(sc->retcode==0) { + sc->retcode=sc->nesting!=0; + } + +#if SHOW_ERROR_LINE + sc->free(sc->load_stack[0].rep.stdio.filename); + sc->load_stack[0].rep.stdio.filename = NULL; +#endif +} + +void scheme_load_string(scheme *sc, const char *cmd) { + dump_stack_reset(sc); + sc->envir = sc->global_env; + sc->file_i=0; + sc->load_stack[0].kind=port_input|port_string; + sc->load_stack[0].rep.string.start=(char*)cmd; /* This func respects const */ + sc->load_stack[0].rep.string.past_the_end=(char*)cmd+strlen(cmd); + sc->load_stack[0].rep.string.curr=(char*)cmd; + sc->loadport=mk_port(sc,sc->load_stack); + sc->retcode=0; + sc->interactive_repl=0; + sc->inport=sc->loadport; + sc->args = mk_integer(sc,sc->file_i); + Eval_Cycle(sc, OP_T0LVL); + typeflag(sc->loadport)=T_ATOM; + if(sc->retcode==0) { + sc->retcode=sc->nesting!=0; + } +} + +void scheme_define(scheme *sc, pointer envir, pointer symbol, pointer value) { + pointer x; + + x=find_slot_in_env(sc,envir,symbol,0); + if (x != sc->NIL) { + set_slot_in_env(sc, x, value); + } else { + new_slot_spec_in_env(sc, envir, symbol, value); + } +} + +#if !STANDALONE +void scheme_register_foreign_func(scheme * sc, scheme_registerable * sr) +{ + scheme_define(sc, + sc->global_env, + mk_symbol(sc,sr->name), + mk_foreign_func(sc, sr->f)); +} + +void scheme_register_foreign_func_list(scheme * sc, + scheme_registerable * list, + int count) +{ + int i; + for(i = 0; i < count; i++) + { + scheme_register_foreign_func(sc, list + i); + } +} + +pointer scheme_apply0(scheme *sc, const char *procname) +{ return scheme_eval(sc, cons(sc,mk_symbol(sc,procname),sc->NIL)); } + +void save_from_C_call(scheme *sc) +{ + pointer saved_data = + cons(sc, + car(sc->sink), + cons(sc, + sc->envir, + sc->dump)); + /* Push */ + sc->c_nest = cons(sc, saved_data, sc->c_nest); + /* Truncate the dump stack so TS will return here when done, not + directly resume pre-C-call operations. */ + dump_stack_reset(sc); +} +void restore_from_C_call(scheme *sc) +{ + car(sc->sink) = caar(sc->c_nest); + sc->envir = cadar(sc->c_nest); + sc->dump = cdr(cdar(sc->c_nest)); + /* Pop */ + sc->c_nest = cdr(sc->c_nest); +} + +/* "func" and "args" are assumed to be already eval'ed. */ +pointer scheme_call(scheme *sc, pointer func, pointer args) +{ + int old_repl = sc->interactive_repl; + sc->interactive_repl = 0; + save_from_C_call(sc); + sc->envir = sc->global_env; + sc->args = args; + sc->code = func; + sc->retcode = 0; + Eval_Cycle(sc, OP_APPLY); + sc->interactive_repl = old_repl; + restore_from_C_call(sc); + return sc->value; +} + +pointer scheme_eval(scheme *sc, pointer obj) +{ + int old_repl = sc->interactive_repl; + sc->interactive_repl = 0; + save_from_C_call(sc); + sc->args = sc->NIL; + sc->code = obj; + sc->retcode = 0; + Eval_Cycle(sc, OP_EVAL); + sc->interactive_repl = old_repl; + restore_from_C_call(sc); + return sc->value; +} + + +#endif + +/* ========== Main ========== */ + +#if STANDALONE + +#if defined(__APPLE__) && !defined (OSX) +int main() +{ + extern MacTS_main(int argc, char **argv); + char** argv; + int argc = ccommand(&argv); + MacTS_main(argc,argv); + return 0; +} +int MacTS_main(int argc, char **argv) { +#else +int main(int argc, char **argv) { +#endif + scheme sc; + FILE *fin; + char *file_name=InitFile; + int retcode; + int isfile=1; + + if(argc==1) { + printf(banner); + } + if(argc==2 && strcmp(argv[1],"-?")==0) { + printf("Usage: tinyscheme -?\n"); + printf("or: tinyscheme [<file1> <file2> ...]\n"); + printf("followed by\n"); + printf(" -1 <file> [<arg1> <arg2> ...]\n"); + printf(" -c <Scheme commands> [<arg1> <arg2> ...]\n"); + printf("assuming that the executable is named tinyscheme.\n"); + printf("Use - as filename for stdin.\n"); + return 1; + } + if(!scheme_init(&sc)) { + fprintf(stderr,"Could not initialize!\n"); + return 2; + } + scheme_set_input_port_file(&sc, stdin); + scheme_set_output_port_file(&sc, stdout); +#if USE_DL + scheme_define(&sc,sc.global_env,mk_symbol(&sc,"load-extension"),mk_foreign_func(&sc, scm_load_ext)); +#endif + argv++; + if(access(file_name,0)!=0) { + char *p=getenv("TINYSCHEMEINIT"); + if(p!=0) { + file_name=p; + } + } + do { + if(strcmp(file_name,"-")==0) { + fin=stdin; + } else if(strcmp(file_name,"-1")==0 || strcmp(file_name,"-c")==0) { + pointer args=sc.NIL; + isfile=file_name[1]=='1'; + file_name=*argv++; + if(strcmp(file_name,"-")==0) { + fin=stdin; + } else if(isfile) { + fin=fopen(file_name,"r"); + } + for(;*argv;argv++) { + pointer value=mk_string(&sc,*argv); + args=cons(&sc,value,args); + } + args=reverse_in_place(&sc,sc.NIL,args); + scheme_define(&sc,sc.global_env,mk_symbol(&sc,"*args*"),args); + + } else { + fin=fopen(file_name,"r"); + } + if(isfile && fin==0) { + fprintf(stderr,"Could not open file %s\n",file_name); + } else { + if(isfile) { + scheme_load_named_file(&sc,fin,file_name); + } else { + scheme_load_string(&sc,file_name); + } + if(!isfile || fin!=stdin) { + if(sc.retcode!=0) { + fprintf(stderr,"Errors encountered reading %s\n",file_name); + } + if(isfile) { + fclose(fin); + } + } + } + file_name=*argv++; + } while(file_name!=0); + if(argc==1) { + scheme_load_named_file(&sc,stdin,0); + } + retcode=sc.retcode; + scheme_deinit(&sc); + + return retcode; +} + +#endif + +/* +Local variables: +c-file-style: "k&r" +End: +*/ diff --git a/tests/gpgscm/scheme.h b/tests/gpgscm/scheme.h new file mode 100644 index 000000000..f4231c474 --- /dev/null +++ b/tests/gpgscm/scheme.h @@ -0,0 +1,266 @@ +/* SCHEME.H */ + +#ifndef _SCHEME_H +#define _SCHEME_H + +#include <stdio.h> + +#ifdef __cplusplus +extern "C" { +#endif + +/* + * Default values for #define'd symbols + */ +#ifndef STANDALONE /* If used as standalone interpreter */ +# define STANDALONE 1 +#endif + +#ifndef _MSC_VER +# define USE_STRCASECMP 1 +# ifndef USE_STRLWR +# define USE_STRLWR 1 +# endif +# define SCHEME_EXPORT +#else +# define USE_STRCASECMP 0 +# define USE_STRLWR 0 +# ifdef _SCHEME_SOURCE +# define SCHEME_EXPORT __declspec(dllexport) +# else +# define SCHEME_EXPORT __declspec(dllimport) +# endif +#endif + +#if USE_NO_FEATURES +# define USE_MATH 0 +# define USE_CHAR_CLASSIFIERS 0 +# define USE_ASCII_NAMES 0 +# define USE_STRING_PORTS 0 +# define USE_ERROR_HOOK 0 +# define USE_TRACING 0 +# define USE_COLON_HOOK 0 +# define USE_DL 0 +# define USE_PLIST 0 +#endif + +/* + * Leave it defined if you want continuations, and also for the Sharp Zaurus. + * Undefine it if you only care about faster speed and not strict Scheme compatibility. + */ +#define USE_SCHEME_STACK + +#if USE_DL +# define USE_INTERFACE 1 +#endif + + +#ifndef USE_MATH /* If math support is needed */ +# define USE_MATH 1 +#endif + +#ifndef USE_CHAR_CLASSIFIERS /* If char classifiers are needed */ +# define USE_CHAR_CLASSIFIERS 1 +#endif + +#ifndef USE_ASCII_NAMES /* If extended escaped characters are needed */ +# define USE_ASCII_NAMES 1 +#endif + +#ifndef USE_STRING_PORTS /* Enable string ports */ +# define USE_STRING_PORTS 1 +#endif + +#ifndef USE_TRACING +# define USE_TRACING 1 +#endif + +#ifndef USE_PLIST +# define USE_PLIST 0 +#endif + +/* To force system errors through user-defined error handling (see *error-hook*) */ +#ifndef USE_ERROR_HOOK +# define USE_ERROR_HOOK 1 +#endif + +#ifndef USE_COLON_HOOK /* Enable qualified qualifier */ +# define USE_COLON_HOOK 1 +#endif + +#ifndef USE_STRCASECMP /* stricmp for Unix */ +# define USE_STRCASECMP 0 +#endif + +#ifndef USE_STRLWR +# define USE_STRLWR 1 +#endif + +#ifndef STDIO_ADDS_CR /* Define if DOS/Windows */ +# define STDIO_ADDS_CR 0 +#endif + +#ifndef INLINE +# define INLINE +#endif + +#ifndef USE_INTERFACE +# define USE_INTERFACE 0 +#endif + +#ifndef SHOW_ERROR_LINE /* Show error line in file */ +# define SHOW_ERROR_LINE 1 +#endif + +typedef struct scheme scheme; +typedef struct cell *pointer; + +typedef void * (*func_alloc)(size_t); +typedef void (*func_dealloc)(void *); + +/* table of functions required for foreign objects */ +typedef struct foreign_object_vtable { + void (*finalize)(scheme *sc, void *data); + void (*to_string)(scheme *sc, char *out, size_t size, void *data); +} foreign_object_vtable; + +/* num, for generic arithmetic */ +typedef struct num { + char is_fixnum; + union { + long ivalue; + double rvalue; + } value; +} num; + +SCHEME_EXPORT scheme *scheme_init_new(void); +SCHEME_EXPORT scheme *scheme_init_new_custom_alloc(func_alloc malloc, func_dealloc free); +SCHEME_EXPORT int scheme_init(scheme *sc); +SCHEME_EXPORT int scheme_init_custom_alloc(scheme *sc, func_alloc, func_dealloc); +SCHEME_EXPORT void scheme_deinit(scheme *sc); +void scheme_set_input_port_file(scheme *sc, FILE *fin); +void scheme_set_input_port_string(scheme *sc, char *start, char *past_the_end); +SCHEME_EXPORT void scheme_set_output_port_file(scheme *sc, FILE *fin); +void scheme_set_output_port_string(scheme *sc, char *start, char *past_the_end); +SCHEME_EXPORT void scheme_load_file(scheme *sc, FILE *fin); +SCHEME_EXPORT void scheme_load_named_file(scheme *sc, FILE *fin, const char *filename); +SCHEME_EXPORT void scheme_load_string(scheme *sc, const char *cmd); +SCHEME_EXPORT pointer scheme_apply0(scheme *sc, const char *procname); +SCHEME_EXPORT pointer scheme_call(scheme *sc, pointer func, pointer args); +SCHEME_EXPORT pointer scheme_eval(scheme *sc, pointer obj); +void scheme_set_external_data(scheme *sc, void *p); +SCHEME_EXPORT void scheme_define(scheme *sc, pointer env, pointer symbol, pointer value); + +typedef pointer (*foreign_func)(scheme *, pointer); + +pointer _cons(scheme *sc, pointer a, pointer b, int immutable); +pointer mk_integer(scheme *sc, long num); +pointer mk_real(scheme *sc, double num); +pointer mk_symbol(scheme *sc, const char *name); +pointer gensym(scheme *sc); +pointer mk_string(scheme *sc, const char *str); +pointer mk_counted_string(scheme *sc, const char *str, int len); +pointer mk_empty_string(scheme *sc, int len, char fill); +pointer mk_character(scheme *sc, int c); +pointer mk_foreign_func(scheme *sc, foreign_func f); +pointer mk_foreign_object(scheme *sc, const foreign_object_vtable *vtable, void *data); +void putstr(scheme *sc, const char *s); +int list_length(scheme *sc, pointer a); +int eqv(pointer a, pointer b); + + +#if USE_INTERFACE +struct scheme_interface { + void (*scheme_define)(scheme *sc, pointer env, pointer symbol, pointer value); + pointer (*cons)(scheme *sc, pointer a, pointer b); + pointer (*immutable_cons)(scheme *sc, pointer a, pointer b); + pointer (*reserve_cells)(scheme *sc, int n); + pointer (*mk_integer)(scheme *sc, long num); + pointer (*mk_real)(scheme *sc, double num); + pointer (*mk_symbol)(scheme *sc, const char *name); + pointer (*gensym)(scheme *sc); + pointer (*mk_string)(scheme *sc, const char *str); + pointer (*mk_counted_string)(scheme *sc, const char *str, int len); + pointer (*mk_character)(scheme *sc, int c); + pointer (*mk_vector)(scheme *sc, int len); + pointer (*mk_foreign_func)(scheme *sc, foreign_func f); + pointer (*mk_foreign_object)(scheme *sc, const foreign_object_vtable *vtable, void *data); + const foreign_object_vtable *(*get_foreign_object_vtable)(pointer p); + void *(*get_foreign_object_data)(pointer p); + void (*putstr)(scheme *sc, const char *s); + void (*putcharacter)(scheme *sc, int c); + + int (*is_string)(pointer p); + char *(*string_value)(pointer p); + int (*is_number)(pointer p); + num (*nvalue)(pointer p); + long (*ivalue)(pointer p); + double (*rvalue)(pointer p); + int (*is_integer)(pointer p); + int (*is_real)(pointer p); + int (*is_character)(pointer p); + long (*charvalue)(pointer p); + int (*is_list)(scheme *sc, pointer p); + int (*is_vector)(pointer p); + int (*list_length)(scheme *sc, pointer vec); + long (*vector_length)(pointer vec); + void (*fill_vector)(pointer vec, pointer elem); + pointer (*vector_elem)(pointer vec, int ielem); + pointer (*set_vector_elem)(pointer vec, int ielem, pointer newel); + int (*is_port)(pointer p); + + int (*is_pair)(pointer p); + pointer (*pair_car)(pointer p); + pointer (*pair_cdr)(pointer p); + pointer (*set_car)(pointer p, pointer q); + pointer (*set_cdr)(pointer p, pointer q); + + int (*is_symbol)(pointer p); + char *(*symname)(pointer p); + + int (*is_syntax)(pointer p); + int (*is_proc)(pointer p); + int (*is_foreign)(pointer p); + char *(*syntaxname)(pointer p); + int (*is_closure)(pointer p); + int (*is_macro)(pointer p); + pointer (*closure_code)(pointer p); + pointer (*closure_env)(pointer p); + + int (*is_continuation)(pointer p); + int (*is_promise)(pointer p); + int (*is_environment)(pointer p); + int (*is_immutable)(pointer p); + void (*setimmutable)(pointer p); + void (*load_file)(scheme *sc, FILE *fin); + void (*load_string)(scheme *sc, const char *input); + pointer (*mk_port_from_file)(scheme *sc, FILE *f, int kind); +}; +#endif + +#if !STANDALONE +typedef struct scheme_registerable +{ + foreign_func f; + const char * name; +} +scheme_registerable; + +void scheme_register_foreign_func_list(scheme * sc, + scheme_registerable * list, + int n); + +#endif /* !STANDALONE */ + +#ifdef __cplusplus +} +#endif + +#endif + + +/* +Local variables: +c-file-style: "k&r" +End: +*/ diff --git a/tests/gpgscm/t-child.c b/tests/gpgscm/t-child.c new file mode 100644 index 000000000..fe2e7b407 --- /dev/null +++ b/tests/gpgscm/t-child.c @@ -0,0 +1,66 @@ +/* Sanity check for the process and IPC primitives. + * + * Copyright (C) 2016 g10 code GmbH + * + * This file is part of GnuPG. + * + * GnuPG is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 3 of the License, or + * (at your option) any later version. + * + * GnuPG is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, see <http://www.gnu.org/licenses/>. + */ + +#include <errno.h> +#include <stdio.h> +#include <string.h> + +#ifdef _WIN32 +# include <fcntl.h> +# include <io.h> +#endif + +int +main (int argc, char **argv) +{ +#if _WIN32 + if (! setmode (stdin, O_BINARY)) + return 23; + if (! setmode (stdout, O_BINARY)) + return 23; +#endif + + if (argc == 1) + return 2; + else if (strcmp (argv[1], "return0") == 0) + return 0; + else if (strcmp (argv[1], "return1") == 0) + return 1; + else if (strcmp (argv[1], "return77") == 0) + return 77; + else if (strcmp (argv[1], "hello_stdout") == 0) + fprintf (stdout, "hello"); + else if (strcmp (argv[1], "hello_stderr") == 0) + fprintf (stderr, "hello"); + else if (strcmp (argv[1], "cat") == 0) + while (! feof (stdin)) + { + char buffer[4096]; + size_t bytes_read; + bytes_read = fread (buffer, 1, sizeof buffer, stdin); + fwrite (buffer, 1, bytes_read, stdout); + } + else + { + fprintf (stderr, "unknown command %s\n", argv[1]); + return 2; + } + return 0; +} diff --git a/tests/gpgscm/t-child.scm b/tests/gpgscm/t-child.scm new file mode 100644 index 000000000..27928f6d8 --- /dev/null +++ b/tests/gpgscm/t-child.scm @@ -0,0 +1,93 @@ +;; Tests for the low-level process and IPC primitives. +;; +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +(echo "Testing process and IPC primitives...") + +(define (qualify executable) + (string-append executable (getenv "EXEEXT"))) + +(assert (= 0 (call `(,(qualify "t-child") "return0")))) +(assert (= 1 (call `(,(qualify "t-child") "return1")))) +(assert (= 77 (call `(,(qualify "t-child") "return77")))) + +(let ((r (call-with-io `(,(qualify "t-child") "return0") ""))) + (assert (= 0 (:retcode r))) + (assert (string=? "" (:stdout r))) + (assert (string=? "" (:stderr r)))) + +(let ((r (call-with-io `(,(qualify "t-child") "return1") ""))) + (assert (= 1 (:retcode r))) + (assert (string=? "" (:stdout r))) + (assert (string=? "" (:stderr r)))) + +(let ((r (call-with-io `(,(qualify "t-child") "return77") ""))) + (assert (= 77 (:retcode r))) + (assert (string=? "" (:stdout r))) + (assert (string=? "" (:stderr r)))) + +(let ((r (call-with-io `(,(qualify "t-child") "hello_stdout") ""))) + (assert (= 0 (:retcode r))) + (assert (string=? "hello" (:stdout r))) + (assert (string=? "" (:stderr r)))) + +(let ((r (call-with-io `(,(qualify "t-child") "hello_stderr") ""))) + (assert (= 0 (:retcode r))) + (assert (string=? "" (:stdout r))) + (assert (string=? "hello" (:stderr r)))) + +(let ((r (call-with-io `(,(qualify "t-child") "cat") "hellohello"))) + (assert (= 0 (:retcode r))) + (assert (string=? "hellohello" (:stdout r))) + (assert (string=? "" (:stderr r)))) + +(define (spawn what) + (spawn-process-fd what CLOSED_FD STDOUT_FILENO STDERR_FILENO)) + +(let ((pid0 (spawn `(,(qualify "t-child") "return0"))) + (pid1 (spawn `(,(qualify "t-child") "return0")))) + (assert (equal? '(0 0) + (wait-processes '("child0" "child1") (list pid0 pid1) #t)))) + +(let ((pid0 (spawn `(,(qualify "t-child") "return1"))) + (pid1 (spawn `(,(qualify "t-child") "return0")))) + (assert (equal? '(1 0) + (wait-processes '("child0" "child1") (list pid0 pid1) #t)))) + +(let ((pid0 (spawn `(,(qualify "t-child") "return0"))) + (pid1 (spawn `(,(qualify "t-child") "return77"))) + (pid2 (spawn `(,(qualify "t-child") "return1")))) + (assert (equal? '(0 77 1) + (wait-processes '("child0" "child1" "child2") + (list pid0 pid1 pid2) #t)))) + +(let* ((p (pipe)) + (pid0 (spawn-process-fd + `(,(qualify "t-child") "hello_stdout") + CLOSED_FD (:write-end p) STDERR_FILENO)) + (_ (close (:write-end p))) + (pid1 (spawn-process-fd + `(,(qualify "t-child") "cat") + (:read-end p) STDOUT_FILENO STDERR_FILENO))) + (close (:read-end p)) + (assert + (equal? '(0 0) + (wait-processes '("child0" "child1") (list pid0 pid1) #t)))) +(echo " world.") + +(echo "All good.") diff --git a/tests/gpgscm/tests.scm b/tests/gpgscm/tests.scm new file mode 100644 index 000000000..c32e2fa5e --- /dev/null +++ b/tests/gpgscm/tests.scm @@ -0,0 +1,443 @@ +;; Common definitions for writing tests. +;; +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +;; Trace displays and returns the given value. A debugging aid. +(define (trace x) + (display x) + (newline) + x) + +;; Stringification. +(define (stringify expression) + (let ((p (open-output-string))) + (write expression p) + (get-output-string p))) + +;; Reporting. +(define (echo . msg) + (for-each (lambda (x) (display x) (display " ")) msg) + (newline)) + +(define (info . msg) + (apply echo msg) + (flush-stdio)) + +(define (error . 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) + (for-each-p' msg proc (lambda (x) x) lst)) + +(define (for-each-p' msg proc fmt lst) + (call-with-progress + msg + (lambda (progress) + (for-each (lambda (a) + (progress (fmt a)) + (proc a)) + lst)))) + +;; Process management. +(define CLOSED_FD -1) +(define (call-with-fds what infd outfd errfd) + (wait-process (stringify what) (spawn-process-fd what infd outfd errfd) #t)) +(define (call what) + (call-with-fds what + CLOSED_FD + (if (< *verbose* 0) STDOUT_FILENO CLOSED_FD) + (if (< *verbose* 0) STDERR_FILENO CLOSED_FD))) + +;; Accessor functions for the results of 'spawn-process'. +(define :stdin car) +(define :stdout cadr) +(define :stderr caddr) +(define :pid cadddr) + +(define (call-with-io what in) + (let ((h (spawn-process what 0))) + (es-write (:stdin h) in) + (es-fclose (:stdin h)) + (let* ((out (es-read-all (:stdout h))) + (err (es-read-all (:stderr h))) + (result (wait-process (car what) (:pid h) #t))) + (es-fclose (:stdout h)) + (es-fclose (:stderr h)) + (list result out err)))) + +;; Accessor function for the results of 'call-with-io'. ':stdout' and +;; ':stderr' can also be used. +(define :retcode car) + +(define (call-check what) + (let ((result (call-with-io what ""))) + (if (= 0 (:retcode result)) + (:stdout result) + (throw (list 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")) + +(define (canonical-path path) + (if (char=? #\/ (string-ref path 0)) + path + (string-append (getcwd) "/" path))) + +(define (in-srcdir what) + (canonical-path (string-append (getenv "srcdir") "/" what))) + +(define (with-path name) + (let loop ((path (string-split (getenv "GPGSCM_PATH") #\:))) + (if (null? path) + name + (let* ((qualified-name (string-append (car path) "/" name)) + (file-exists (call-with-input-file qualified-name + (lambda (x) #t)))) + (if file-exists + qualified-name + (loop (cdr path))))))) + +(define (basename path) + (let ((i (string-index path #\/))) + (if (equal? i #f) + path + (basename (substring path (+ 1 i) (string-length path)))))) + +(define (basename-suffix path suffix) + (basename + (if (string-suffix? path suffix) + (substring path 0 (- (string-length path) (string-length suffix))) + path))) + +;; Helper for (pipe). +(define :read-end car) +(define :write-end cadr) + +;; let-like macro that manages file descriptors. +;; +;; (letfd <bindings> <body>) +;; +;; Bind all variables given in <bindings> and initialize each of them +;; to the given initial value, and close them after evaluting <body>. +(macro (letfd form) + (let ((result-sym (gensym))) + `((lambda (,(caaadr form)) + (let ((,result-sym + ,(if (= 1 (length (cadr form))) + `(begin ,@(cddr form)) + `(letfd ,(cdadr form) ,@(cddr form))))) + (close ,(caaadr form)) + ,result-sym)) ,@(cdaadr form)))) + +(macro (with-working-directory form) + (let ((result-sym (gensym)) (cwd-sym (gensym))) + `(let* ((,cwd-sym (getcwd)) + (_ (if ,(cadr form) (chdir ,(cadr form)))) + (,result-sym (begin ,@(cddr form)))) + (chdir ,cwd-sym) + ,result-sym))) + +(macro (with-temporary-working-directory form) + (let ((result-sym (gensym)) (cwd-sym (gensym)) (tmp-sym (gensym))) + `(let* ((,cwd-sym (getcwd)) + (,tmp-sym (mkdtemp (path-join (getenv "TMP") "gpgscm-XXXXXX"))) + (_ (chdir ,tmp-sym)) + (,result-sym (begin ,@(cdr form)))) + (chdir ,cwd-sym) + (unlink-recursively ,tmp-sym) + ,result-sym))) + +(define (make-temporary-file . args) + (canonical-path (path-join + (mkdtemp (path-join (getenv "TMP") "gpgscm-XXXXXX")) + (if (null? args) "a" (car args))))) + +(define (remove-temporary-file filename) + (catch '() + (unlink filename)) + (let ((dirname (substring filename 0 (string-rindex filename #\/)))) + (catch (echo "removing temporary directory" dirname "failed") + (rmdir dirname)))) + +;; let-like macro that manages temporary files. +;; +;; (lettmp <bindings> <body>) +;; +;; Bind all variables given in <bindings>, initialize each of them to +;; a string representing an unique path in the filesystem, and delete +;; them after evaluting <body>. +(macro (lettmp form) + (let ((result-sym (gensym))) + `((lambda (,(caadr form)) + (let ((,result-sym + ,(if (= 1 (length (cadr form))) + `(begin ,@(cddr form)) + `(lettmp ,(cdadr form) ,@(cddr form))))) + (remove-temporary-file ,(caadr form)) + ,result-sym)) (make-temporary-file ,(symbol->string (caadr form)))))) + +(define (check-execution source transformer) + (lettmp (sink) + (transformer source sink))) + +(define (check-identity source transformer) + (lettmp (sink) + (transformer source sink) + (if (not (file=? source sink)) + (error "mismatch")))) + +;; +;; Monadic pipe support. +;; + +(define pipeM + (package + (define (new procs source sink producer) + (package + (define (dump) + (write (list procs source sink producer)) + (newline)) + (define (add-proc command pid) + (new (cons (list command pid) procs) source sink producer)) + (define (commands) + (map car procs)) + (define (pids) + (map cadr procs)) + (define (set-source source') + (new procs source' sink producer)) + (define (set-sink sink') + (new procs source sink' producer)) + (define (set-producer producer') + (if producer + (throw "producer already set")) + (new procs source sink producer')))))) + + +(define (pipe:do . commands) + (let loop ((M (pipeM::new '() CLOSED_FD CLOSED_FD #f)) (cmds commands)) + (if (null? cmds) + (begin + (if M::producer (M::producer)) + (if (not (null? M::procs)) + (let* ((retcodes (wait-processes (map stringify (M::commands)) + (M::pids) #t)) + (results (map (lambda (p r) (append p (list r))) + M::procs retcodes)) + (failed (filter (lambda (x) (not (= 0 (caddr x)))) + results))) + (if (not (null? failed)) + (throw failed))))) ; xxx nicer reporting + (if (and (= 2 (length cmds)) (number? (cadr cmds))) + ;; hack: if it's an fd, use it as sink + (let ((M' ((car cmds) (M::set-sink (cadr cmds))))) + (if (> M::source 2) (close M::source)) + (if (> (cadr cmds) 2) (close (cadr cmds))) + (loop M' '())) + (let ((M' ((car cmds) M))) + (if (> M::source 2) (close M::source)) + (loop M' (cdr cmds))))))) + +(define (pipe:open pathname flags) + (lambda (M) + (M::set-source (open pathname flags)))) + +(define (pipe:defer producer) + (lambda (M) + (let* ((p (outbound-pipe)) + (M' (M::set-source (:read-end p)))) + (M'::set-producer (lambda () + (producer (:write-end p)) + (close (:write-end p))))))) +(define (pipe:echo data) + (pipe:defer (lambda (sink) (display data (fdopen sink "wb"))))) + +(define (pipe:spawn command) + (lambda (M) + (define (do-spawn M new-source) + (let ((pid (spawn-process-fd command M::source M::sink + (if (> *verbose* 0) + STDERR_FILENO CLOSED_FD))) + (M' (M::set-source new-source))) + (M'::add-proc command pid))) + (if (= CLOSED_FD M::sink) + (let* ((p (pipe)) + (M' (do-spawn (M::set-sink (:write-end p)) (:read-end p)))) + (close (:write-end p)) + (M'::set-sink CLOSED_FD)) + (do-spawn M CLOSED_FD)))) + +(define (pipe:splice sink) + (lambda (M) + (splice M::source sink) + (M::set-source CLOSED_FD))) + +(define (pipe:write-to pathname flags mode) + (open pathname flags mode)) + +;; +;; Monadic transformer support. +;; + +(define (tr:do . commands) + (let loop ((tmpfiles '()) (source #f) (cmds commands)) + (if (null? cmds) + (for-each remove-temporary-file tmpfiles) + (let* ((v ((car cmds) tmpfiles source)) + (tmpfiles' (car v)) + (sink (cadr v)) + (error (caddr v))) + (if error + (begin + (for-each remove-temporary-file tmpfiles') + (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)) + (error (string-append (stringify cmd) " needs an input"))) + (let* ((t (make-temporary-file)) + (cmd (map (lambda (x) + (cond + ((equal? '**in** x) source) + ((equal? '**out** x) t) + (else x))) command))) + (catch (list (cons t tmpfiles) t *error*) + (call-popen cmd input) + (if (and (member '**out** command) (not (file-exists? t))) + (error (string-append (stringify cmd) + " did not produce '" t "'."))) + (list (cons t tmpfiles) t #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)) + (error "mismatch")) + (list tmpfiles source #f))) + +(define (tr:assert-weak-identity reference) + (lambda (tmpfiles source) + (if (not (text-file=? source reference)) + (error "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))) diff --git a/tests/migrations/Makefile.am b/tests/migrations/Makefile.am index 0f581c270..9c82d66ee 100644 --- a/tests/migrations/Makefile.am +++ b/tests/migrations/Makefile.am @@ -26,21 +26,20 @@ include $(top_srcdir)/am/cmacros.am AM_CFLAGS = -TESTS_ENVIRONMENT = GPG_AGENT_INFO= LC_ALL=C +TMP ?= /tmp -TESTS = from-classic.test \ - extended-private-key-format.test +TESTS_ENVIRONMENT = GPG_AGENT_INFO= LC_ALL=C \ + PATH=../gpgscm:$(PATH) \ + TMP=$(TMP) \ + GPGSCM_PATH=$(top_srcdir)/tests/gpgscm:$(top_srcdir)/tests/migrations -TEST_FILES = from-classic.gpghome/pubring.gpg.asc \ - from-classic.gpghome/secring.gpg.asc \ - from-classic.gpghome/trustdb.gpg.asc \ - extended-private-key-format.gpghome/trustdb.gpg.asc \ - extended-private-key-format.gpghome/pubring.kbx.asc \ - extended-private-key-format.gpghome/private-keys-v1.d/13FDB8809B17C5547779F9D205C45F47CE0217CE.key.asc \ - extended-private-key-format.gpghome/private-keys-v1.d/343D8AF79796EE107D645A2787A9D9252F924E6F.key.asc \ - extended-private-key-format.gpghome/private-keys-v1.d/8B5ABF3EF9EB8D96B91A0B8C2C4401C91C834C34.key.asc +TESTS = from-classic.scm \ + extended-pkf.scm -EXTRA_DIST = $(TESTS) $(TEST_FILES) +TEST_FILES = from-classic.tar.asc \ + extended-pkf.tar.asc + +EXTRA_DIST = common.scm $(TESTS) $(TEST_FILES) CLEANFILES = prepared.stamp x y yy z out err $(data_files) \ plain-1 plain-2 plain-3 trustdb.gpg *.lock .\#lk* \ diff --git a/tests/migrations/common.scm b/tests/migrations/common.scm new file mode 100644 index 000000000..79f69e5d1 --- /dev/null +++ b/tests/migrations/common.scm @@ -0,0 +1,39 @@ +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +(if (string=? "" (getenv "srcdir")) + (error "not called from make")) + +(setenv "GNUPGHOME" "" #t) + +(define (qualify executable) + (string-append executable (getenv "EXEEXT"))) + +;; We may not use a relative name for gpg-agent. +(define GPG-AGENT (qualify (string-append (getcwd) "/../../agent/gpg-agent"))) +(define GPG `(,(qualify (string-append (getcwd) "/../../g10/gpg")) + --no-permission-warning --no-greeting + --no-secmem-warning --batch + ,(string-append "--agent-program=" GPG-AGENT + "|--debug-quick-random"))) +(define GPGTAR (qualify (string-append (getcwd) "/../../tools/gpgtar"))) + +(define (untar-armored source-name) + (pipe:do + (pipe:open source-name (logior O_RDONLY O_BINARY)) + (pipe:spawn `(,@GPG --dearmor)) + (pipe:spawn `(,GPGTAR --extract --directory=. -)))) diff --git a/tests/migrations/extended-pkf.scm b/tests/migrations/extended-pkf.scm new file mode 100755 index 000000000..3e76532ba --- /dev/null +++ b/tests/migrations/extended-pkf.scm @@ -0,0 +1,43 @@ +#!/usr/bin/env gpgscm + +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +(load (with-path "common.scm")) + +(define src-tarball (in-srcdir "extended-pkf.tar.asc")) + +(define (setup) + (untar-armored src-tarball) + (setenv "GNUPGHOME" (getcwd) #t)) + +(define (trigger-migration) + (call-check `(,@GPG --list-secret-keys))) + +(define (assert-keys-usable) + (for-each + (lambda (keyid) + (catch (error "Key not found:" keyid) + (call-check `(,@GPG --list-secret-keys ,keyid)))) + '("C40FDECF" "ECABF51D"))) + +(info "Testing the extended private key format ...") +(with-temporary-working-directory + (setup) + (assert-keys-usable)) + +;; XXX try changing a key, and check that the format is not changed. diff --git a/tests/migrations/extended-pkf.tar.asc b/tests/migrations/extended-pkf.tar.asc new file mode 100644 index 000000000..adbe174fe --- /dev/null +++ b/tests/migrations/extended-pkf.tar.asc @@ -0,0 +1,220 @@ +-----BEGIN PGP ARMORED FILE----- +Version: GnuPG v2 +Comment: Use "gpg --dearmor" for unpacking + +cHJpdmF0ZS1rZXlzLXYxLmQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAADAwMDA3NTUAMDAwMTc1MAAwMDAxNzUwADAwMDAwMDAwMDAwADEyNzM2NzI1 +MzA2ADAxNDU0NwAgNQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAB1c3RhcgAwMHRleXRob29uAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAdGV5dGhvb24AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAABwcml2YXRlLWtleXMtdjEu +ZC84QjVBQkYzRUY5RUI4RDk2QjkxQTBCOEMyQzQ0MDFDOTFDODM0QzM0LmtleQAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAMDAwMDY0NAAwMDAx +NzUwADAwMDE3NTAAMDAwMDAwMDEyMDQAMTI3MzY3MjUyNTYAMDIyMTAyACAwAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AHVzdGFyADAwdGV5dGhvb24AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAB0ZXl0aG9v +bgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAEtleTogKHByaXZhdGUta2V5IChlbGcgKHAgIzAwQ0NE +OEIxRjlEQUM3NEQ4MDhDQzUyRjBEODk0NjREQTU1NEM2OUQ2N0YzCiAzMjNDNDJB +OTVDOTk2MkRGNDIxMjZFQzBFMDk3MUY0OUI4MTE1MjlBNkEyQUU5RjBBREVCODM5 +QTYzNDYxNUNENTZGQTU0CiBGNUEwQjdFRjI1QTBFMkZFODQzRkEyRTZFMDIxQ0FC +NDExOUU2MDM5NEM5RDZBM0Y3QUQ0RjU3Nzk2RDM2NjY5QTUxMjY2CiBDMjdBOEQx +QzVBNkI0MTQxRDVDODMxRTg0NTQxRjNDODExRTg5MDc4OTgwMzM4Mjk1RjgyQjdG +N0ZENDMzM0VGRDkzMzEyCiBGMkFCIykoZyAjMDYjKSh5ICMzNzczQTZEOUVDODg5 +RDc2RTMyNEQ2RTVFQzIxQkQ0NTY5OTgzMUFFNEZEMEFFMDM3ODIwCiA1QkFFNUI4 +Q0U4NUZBREFCRDdFNkI3QzczMDI1Q0IzRDczMEQ1QzU4MjkwMzRENzZCRTA4NTVD +MkU5RkY3QTQ5MjNFRkZBCiBGMTZBOTY2Njk0NERCQzYyOTQ4MzhGQzNGMDlGRjk2 +NEE4RDAyM0NCOEVCQTMzMkZCMDUxRUEwMjgyMEVFNjEyMEZGQkU2CiAyQjM2QTIw +MkIzQzc1MkY5REE3NkIyRUMxMUE2N0QyRTM1RTY2RUMxMDYzNTg3QjIyNTAwRThB +NDZEMTU3Qjc1IykoeCAjCiA2OTE1QzZDRUQyNTgxNDNGODkzN0IxMzM1RjQ4ODdG +MDA0MkI3QzYzMDA1Mzk4RjkzOTZCQjg1MzIzOENCNiMpKSkKNjE1Q0Q1NkZBNTQK +IEY1QTBCN0VGMjVBMEUyRkU4NDNGQTJFNkUwMjFDQUI0MTE5RTYwMzk0QzlENkEz +RjdBRDRGNTc3OTZEMzY2NjlBNTEyNjYKIEMyN0E4RDFDNUE2QjQxNDFENUM4MzFF +ODQ1NDFGM0M4MTFFODkwNzg5ODAzMzgyOTVGODJCN0Y3RkQ0MzMzRUZEOTMzMTIK +IEYyQUIjKShnICMwNiMpKHkgIzM3NzNBNkQ5RUM4ODlENzZFMzI0RDZFNUVDMjFC +RDQ1Njk5ODMxQUU0RkQwQUUwMzc4MjAKIDVCQUU1QjhDRTg1RkFEQUJEN0U2QjdD +NzMwMjVDQjNENzMwRDVDNTgyOTAzNEQ3NkJFMDg1NUMyRTlGRjdBNDkyM0VGRkEK +IEYxNkE5NjY2OTQ0REJDNjI5NDgzOEZDM0YwOUZGOTY0QThEMDIzQ0I4RUJBMzMy +RkIwNTFFQTAyODIwRUU2MTIwRkZCRTYKIDJCMzZBMjBwcml2YXRlLWtleXMtdjEu +ZC8zNDNEOEFGNzk3OTZFRTEwN0Q2NDVBMjc4N0E5RDkyNTJGOTI0RTZGLmtleQAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAMDAwMDY0NAAwMDAx +NzUwADAwMDE3NTAAMDAwMDAwMDA3NTQAMTI3MzY3MjUyNTYAMDIyMDQwACAwAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AHVzdGFyADAwdGV5dGhvb24AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAB0ZXl0aG9v +bgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAACgxMTpwcml2YXRlLWtleSgzOmRzYSgxOnAxMjk6AKxx +qlg9Kz9DZ/3N52BC0w+JtYKke39vpdWVDHR3MHmMJ/31Y2iSpm0fvRs3h1j9/fBV +mLOZglNQyH62SxdJyZwCelkZzfUy/qLm9Qaqi7wpg0p4EbmWdoFF/A1Zg/MU7D5w +5xu+EA1J77Z6QyALN9rIOXZ7rLLa64lw/MV4LdIPKSgxOnEyMToAuOPYbSW26ea5 +CR7wQ7OGMRCJJOcpKDE6ZzEyODpfiE8aUjDk+UeuwbuF1qGFO51XmFEaW+iyfCyt +gle8oBAsBXURXbpIhhQfmkz/Jxesbbl2pWgbnq5CqeEF1SqjiJKezFjdkwDjoPXh +ERz0//8Ia8n+PZnjWDDy7ygHutLnR2O+hpZvmbKPtuFpxMF19qHdTx1VdwiLVkW+ +2JoYBikoMTp5MTI4OgIF7eNIdpaYiB0427un4ggc26+Y9nkF93DaMnZEaYSeum6g +/g7D1vwINFgQkMYEWi4DK3W+uH0E/n8o20wS2wvMrbeYaQm5v6ucd001wwFDY6Ad +wpwP7UCLQcu6qqvwNHdxWYK6+gIsSufLmeMGrsvC0WQqYeu1GfGpHIMCZJlZKSgx +OngyMDp/2Na42QEhjCvSBm9cv2Qyk9M5EykpKQAAAAAAAAAAAAAAAAAAAAAAAAAA +cHJpdmF0ZS1rZXlzLXYxLmQvMTNGREI4ODA5QjE3QzU1NDc3NzlGOUQyMDVDNDVG +NDdDRTAyMTdDRS5rZXkAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAADAwMDA2NDQAMDAwMTc1MAAwMDAxNzUwADAwMDAwMDAxNzQyADEyNzM2NzI1 +MjU2ADAyMjAzMgAgMAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAB1c3RhcgAwMHRleXRob29uAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAdGV5dGhvb24AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAABLZXk6IChwcml2YXRlLWtl +eSAocnNhIChuICMwMEE4NTI1Njc2RUNFNEQ3NUZFNkQwMDczRjJCRjk5QTZGNDkz +M0NFQkRENAogNTI4QUY1NkU0QzYxRTJGNzMxMjQ3MzkzNjQ1RERBRjU4RUFERDU2 +NTI5QzI1Mzk3NzgyMzY0NjNERjJENDU4NTIwRTgwRQogMzRDMDU4MjQyQjNGRjg4 +REQzOUE4ODNCNDc1QjY2Q0VBQUJCQzk5ODlGRjAxRkZFNzM3NjYwRTlCNjFCQjlE +QzkxMjA1RAogNDI4RkZGRThGNjc1RkFFRjYxMzY1OEM3MkRBNkQ3NTBDMEVCQzQw +QUY2MjNEMjA2NjkyQzgyNTE0QzQwNEQ4ODI1QUI3MAogMTAwMSMpKGUgIzAxMDEj +KShkICMwMEJDQTAwMTQ0ODVGQjc2RDUwRTlCNkNCQTU3MjFBQzExMjEzOTBGODYw +OEQ0MDg0QgogRDA0NUE4NzZERjM4MTBGMTE0QkMyRDY4RUI1NTJFNjFCMDFFREJD +MjQ4MUYwOEM4MjgzMkUwMEUyNzlENjdBODUzMDU1RAogQ0FFNUMyMzU2ODUxQ0JF +MzZENjEwQzREMkFCNDNGQTY1NTk4NUM0NDY5RDFEOTExRTFBRkQ4MTdFQUE1RkVF +MEZGMjY1NwogNEMzNTlFMTc1Mjg3MDUyMTk0NTNCNTFBRUMxMERCRjc1NjJCMDYx +RDVDNjZDMzVCQjNGOUYwQjIyMkI5RDE5NkI5IykocAogICMwMEMzM0M1ODA2Mzk5 +NkJENTk3NTJBQUJERkRBQ0RBQTdCNEI2NkFBMTc1NEVFMEQ4OUI3Nzk0RjBERThG +RjcyNEM1NAogOUZGMTEyQTMzMjkyQkI5RDdCQ0VFNzk0RjA4MDI0QzNFNTVGRDgy +MzNGNTA3OUVENDk5MUM0REYyNjE4RDkjKShxICMwMAogRENCNTk0NUYwMEYxQUY0 +MzhCRDRDMzExQjhCQUNBM0Q5REIwQUQxNjUxOTg2NTM0MjAzMEYxREYzMDU3RTU1 +MzJDNDdGNQogOEQzMzAzQ0JBM0M4QTI5ODE0RjYxN0I3QjNERUU5OEZBQUFBRUU4 +MTFCNDk4RkFBRjIxNzdCNzc2OSMpKHUgIzI5RkIyRAogRjY5QjIzNUE0OUE5MDZC +MTBFRjdEOEY4MUFBRUE4QUQ4MUU3Q0RERTFGNEE3OUNFMjQ0QkY4RkNFNkRENUVC +MTgxMUIwQgogRDVFNTE2NUI5NTcwODUwMzY5MDFERDI4NUE2MjhDMjk3QTc4MkRB +ODE1NzNBNDNEMUMwOSMpKSkKMUFGRDgxN0VBQTVGRUUwRkYyNjU3CiA0QzM1OUUx +cHVicmluZy5rYngAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAADAwMDA2NDQAMDAwMTc1MAAwMDAxNzUwADAwMDAwMDAzMDI3ADEyNzM2NzI1 +MjU2ADAxMzYxNwAgMAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAB1c3RhcgAwMHRleXRob29uAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAdGV5dGhvb24AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAgAQEAAktCWGYAAAAA +Vxi2I1cYtiMAAAAAAAAAAAAABBcCAQAAAAAAfgAAA4UAAgAcwd67NOqLcQCer6R0 +lz1Q4cQP3s8AAAAgAAAAAM09D1cBy/yssqSQcwWjeIeyeQeqAAAAPAAAAAAAAAAB +AAwAAAIlAAAAIgAAAAAAAgAE//////////8AAAAAAAAAAAAAAABXGLYjAAAAAJkB +ogQ/8lJrEQQArHGqWD0rP0Nn/c3nYELTD4m1gqR7f2+l1ZUMdHcweYwn/fVjaJKm +bR+9GzeHWP398FWYs5mCU1DIfrZLF0nJnAJ6WRnN9TL+oub1BqqLvCmDSngRuZZ2 +gUX8DVmD8xTsPnDnG74QDUnvtnpDIAs32sg5dnusstrriXD8xXgt0g8AoLjj2G0l +tunmuQke8EOzhjEQiSTnA/9fiE8aUjDk+UeuwbuF1qGFO51XmFEaW+iyfCytgle8 +oBAsBXURXbpIhhQfmkz/Jxesbbl2pWgbnq5CqeEF1SqjiJKezFjdkwDjoPXhERz0 +//8Ia8n+PZnjWDDy7ygHutLnR2O+hpZvmbKPtuFpxMF19qHdTx1VdwiLVkW+2JoY +BgP6AgXt40h2lpiIHTjbu6fiCBzbr5j2eQX3cNoydkRphJ66bqD+DsPW/Ag0WBCQ +xgRaLgMrdb64fQT+fyjbTBLbC8ytt5hpCbm/q5x3TTXDAUNjoB3CnA/tQItBy7qq +q/A0d3FZgrr6AixK58uZ4wauy8LRZCph67UZ8akcgwJkmVm0IlRlc3QgdHdvIChu +byBwcCkgPHR3b0BleGFtcGxlLmNvbT6IXwQTEQIAHwUCP/JSawIbAwcLCQgHAwIB +AxUCAwMWAgECHgECF4AACgkQlz1Q4cQP3s+AQwCfQXxEYOueZe/uuozb6mJzagPP +WSkAnRJY8fF2MkdbOgYyseqhwDL/fAWLuQENBD/yUm8QBADM2LH52sdNgIzFLw2J +Rk2lVMadZ/MyPEKpXJli30ISbsDglx9JuBFSmmoq6fCt64OaY0YVzVb6VPWgt+8l +oOL+hD+i5uAhyrQRnmA5TJ1qP3rU9XeW02ZppRJmwnqNHFprQUHVyDHoRUHzyBHo +kHiYAzgpX4K39/1DM+/ZMxLyqwADBgP+N3Om2eyInXbjJNbl7CG9RWmYMa5P0K4D +eCBbrluM6F+tq9fmt8cwJcs9cw1cWCkDTXa+CFXC6f96SSPv+vFqlmaUTbxilIOP +w/Cf+WSo0CPLjrozL7BR6gKCDuYSD/vmKzaiArPHUvnadrLsEaZ9LjXmbsEGNYey +JQDopG0Ve3WISQQYEQIACQUCP/JSbwIbDAAKCRCXPVDhxA/ezyy+AKCZZylXC+0M +3ecBVPV0wVO8LPSF/ACgjhWzMkF6wb/wbItb57YT4uJBdWpyKrYYYncCnYq+gLAI +v8OEIB9wawAAAeACAQAAAAAAXgAAAW4AAQAczyNJCw94uFC7vHNp0SC2Juyr9R0A +AAAgAAAAAAAAAAEADAAAAO8AAAAmAAAAAAABAAT/////AAAAAAAAAAAAAAAAVxi2 +SQAAAACZAIwEP/JTvQEEAKhSVnbs5Ndf5tAHPyv5mm9JM8691FKK9W5MYeL3MSRz +k2Rd2vWOrdVlKcJTl3gjZGPfLUWFIOgONMBYJCs/+I3Tmog7R1tmzqq7yZif8B/+ +c3Zg6bYbudyRIF1Cj//o9nX672E2WMctptdQwOvECvYj0gZpLIJRTEBNiCWrcBAB +AAkBAbQmVGVzdCB0aHJlZSAobm8gcHApIDx0aHJlZUBleGFtcGxlLmNvbT6ItQQT +AQIAHwUCP/JTvQIbAwcLCQgHAwIBAxUCAwMWAgECHgECF4AACgkQ0SC2Juyr9R1q +QwP/bCDX1WGk1u0zkKJWJ/VXnuH3jk6ZevkuHZICwjlqAxv1de5P3Jeya/4kPmEQ +TotEv3xcDAZ+9pBL3TrZolAKhxkBZ08l4QSy76kyf8hB0eoZ2Svs7LrGPBJr6CHX +0kyDiapHgAhBKQq9GhNKpIAZuL6DK2dOaQDtoRSW2iB1h4ksYHkxg+dI/AANhV82 +0vGwpkRIsPBsi1vnthPi4kF1anIqthhidwKdir6AsAi/w4QgH3BrAAAB4AIBAAAA +AABeAAABbgABABzPI0kLD3i4ULu8c2nRILYm7Kv1HQAAACAAAAAAAAAAAQAMAAAA +7wAAACYAAAAAAAEABP////8AAAAAAAAAAAAAAABXGLZJAAAAAJkAjAQ/8lO9AQQA +qFJWduzk11/m0Ac/K/mab0kzzr3UUor1bkxh4vcxJHOTZF3a9Y6t1WUpwlOXeCNk +Y98tRYUg6A40wFgkKz/4jdOaiDtHW2bOqrvJmJ/wH/5zdmDpthu53JEgXUKP/+j2 +dfrvYTZYxy2m11DA68QK9iPSBmksglFMQE2IJatwEAEACQEBtCZUZXN0IHRocmVl +IChubyBwcCkgPHRocmVlQGV4YW1wbGUuY29tPoi1BBMBAgAfBQI/8lO9AhsDBwsJ +CAcDAgEDFQIDAxYCAQIeAQIXgAAKCRDRILYm7Kv1HWpDA/9sINfVYaTW7TOQolYn +9Vee4feOTpl6+S4dkgLCOWoDG/V17k/cl7Jr/iQ+YRBOi0S/fFwMBn72kEvdOtmi +UAqHGQFnTyXhBLLvqTJ/yEHR6hnZK+zsusY8EmvoIdfSTIOJqkeACEEpCr0aE0qk +gBm4voMrZ05pAO2hFJbaIHRydXN0ZGIuZ3BnAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAwMDAwNjQ0ADAwMDE3NTAAMDAwMTc1MAAwMDAw +MDAwMjI2MAAxMjczNjcyNTI1NgAwMTM2MjcAIDAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAdXN0YXIAMDB0ZXl0aG9v +bgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAHRleXRob29uAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AWdwZwMDAQUBAgAAVxi2IwAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAQoAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +CgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAoAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +CgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAoAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +CgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAoAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +CgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAoAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +CgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAoAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAA== +=Joz2 +-----END PGP ARMORED FILE----- diff --git a/tests/migrations/extended-private-key-format.gpghome/private-keys-v1.d/13FDB8809B17C5547779F9D205C45F47CE0217CE.key.asc b/tests/migrations/extended-private-key-format.gpghome/private-keys-v1.d/13FDB8809B17C5547779F9D205C45F47CE0217CE.key.asc deleted file mode 100644 index d9192b19a..000000000 --- a/tests/migrations/extended-private-key-format.gpghome/private-keys-v1.d/13FDB8809B17C5547779F9D205C45F47CE0217CE.key.asc +++ /dev/null @@ -1,27 +0,0 @@ ------BEGIN PGP ARMORED FILE----- -Version: GnuPG v2 -Comment: Use "gpg --dearmor" for unpacking - -S2V5OiAocHJpdmF0ZS1rZXkgKHJzYSAobiAjMDBBODUyNTY3NkVDRTRENzVGRTZE -MDA3M0YyQkY5OUE2RjQ5MzNDRUJERDQKIDUyOEFGNTZFNEM2MUUyRjczMTI0NzM5 -MzY0NUREQUY1OEVBREQ1NjUyOUMyNTM5Nzc4MjM2NDYzREYyRDQ1ODUyMEU4MEUK -IDM0QzA1ODI0MkIzRkY4OEREMzlBODgzQjQ3NUI2NkNFQUFCQkM5OTg5RkYwMUZG -RTczNzY2MEU5QjYxQkI5REM5MTIwNUQKIDQyOEZGRkU4RjY3NUZBRUY2MTM2NThD -NzJEQTZENzUwQzBFQkM0MEFGNjIzRDIwNjY5MkM4MjUxNEM0MDREODgyNUFCNzAK -IDEwMDEjKShlICMwMTAxIykoZCAjMDBCQ0EwMDE0NDg1RkI3NkQ1MEU5QjZDQkE1 -NzIxQUMxMTIxMzkwRjg2MDhENDA4NEIKIEQwNDVBODc2REYzODEwRjExNEJDMkQ2 -OEVCNTUyRTYxQjAxRURCQzI0ODFGMDhDODI4MzJFMDBFMjc5RDY3QTg1MzA1NUQK -IENBRTVDMjM1Njg1MUNCRTM2RDYxMEM0RDJBQjQzRkE2NTU5ODVDNDQ2OUQxRDkx -MUUxQUZEODE3RUFBNUZFRTBGRjI2NTcKIDRDMzU5RTE3NTI4NzA1MjE5NDUzQjUx -QUVDMTBEQkY3NTYyQjA2MUQ1QzY2QzM1QkIzRjlGMEIyMjJCOUQxOTZCOSMpKHAK -ICAjMDBDMzNDNTgwNjM5OTZCRDU5NzUyQUFCREZEQUNEQUE3QjRCNjZBQTE3NTRF -RTBEODlCNzc5NEYwREU4RkY3MjRDNTQKIDlGRjExMkEzMzI5MkJCOUQ3QkNFRTc5 -NEYwODAyNEMzRTU1RkQ4MjMzRjUwNzlFRDQ5OTFDNERGMjYxOEQ5IykocSAjMDAK -IERDQjU5NDVGMDBGMUFGNDM4QkQ0QzMxMUI4QkFDQTNEOURCMEFEMTY1MTk4NjUz -NDIwMzBGMURGMzA1N0U1NTMyQzQ3RjUKIDhEMzMwM0NCQTNDOEEyOTgxNEY2MTdC -N0IzREVFOThGQUFBQUVFODExQjQ5OEZBQUYyMTc3Qjc3NjkjKSh1ICMyOUZCMkQK -IEY2OUIyMzVBNDlBOTA2QjEwRUY3RDhGODFBQUVBOEFEODFFN0NEREUxRjRBNzlD -RTI0NEJGOEZDRTZERDVFQjE4MTFCMEIKIEQ1RTUxNjVCOTU3MDg1MDM2OTAxREQy -ODVBNjI4QzI5N0E3ODJEQTgxNTczQTQzRDFDMDkjKSkpCg== -=laTh ------END PGP ARMORED FILE----- diff --git a/tests/migrations/extended-private-key-format.gpghome/private-keys-v1.d/343D8AF79796EE107D645A2787A9D9252F924E6F.key.asc b/tests/migrations/extended-private-key-format.gpghome/private-keys-v1.d/343D8AF79796EE107D645A2787A9D9252F924E6F.key.asc deleted file mode 100644 index 1eede1c61..000000000 --- a/tests/migrations/extended-private-key-format.gpghome/private-keys-v1.d/343D8AF79796EE107D645A2787A9D9252F924E6F.key.asc +++ /dev/null @@ -1,17 +0,0 @@ ------BEGIN PGP ARMORED FILE----- -Version: GnuPG v2 -Comment: Use "gpg --dearmor" for unpacking - -KDExOnByaXZhdGUta2V5KDM6ZHNhKDE6cDEyOToArHGqWD0rP0Nn/c3nYELTD4m1 -gqR7f2+l1ZUMdHcweYwn/fVjaJKmbR+9GzeHWP398FWYs5mCU1DIfrZLF0nJnAJ6 -WRnN9TL+oub1BqqLvCmDSngRuZZ2gUX8DVmD8xTsPnDnG74QDUnvtnpDIAs32sg5 -dnusstrriXD8xXgt0g8pKDE6cTIxOgC449htJbbp5rkJHvBDs4YxEIkk5ykoMTpn -MTI4Ol+ITxpSMOT5R67Bu4XWoYU7nVeYURpb6LJ8LK2CV7ygECwFdRFdukiGFB+a -TP8nF6xtuXalaBuerkKp4QXVKqOIkp7MWN2TAOOg9eERHPT//whryf49meNYMPLv -KAe60udHY76Glm+Zso+24WnEwXX2od1PHVV3CItWRb7YmhgGKSgxOnkxMjg6AgXt -40h2lpiIHTjbu6fiCBzbr5j2eQX3cNoydkRphJ66bqD+DsPW/Ag0WBCQxgRaLgMr -db64fQT+fyjbTBLbC8ytt5hpCbm/q5x3TTXDAUNjoB3CnA/tQItBy7qqq/A0d3FZ -grr6AixK58uZ4wauy8LRZCph67UZ8akcgwJkmVkpKDE6eDIwOn/Y1rjZASGMK9IG -b1y/ZDKT0zkTKSkp -=muRa ------END PGP ARMORED FILE----- diff --git a/tests/migrations/extended-private-key-format.gpghome/private-keys-v1.d/8B5ABF3EF9EB8D96B91A0B8C2C4401C91C834C34.key.asc b/tests/migrations/extended-private-key-format.gpghome/private-keys-v1.d/8B5ABF3EF9EB8D96B91A0B8C2C4401C91C834C34.key.asc deleted file mode 100644 index 70836735d..000000000 --- a/tests/migrations/extended-private-key-format.gpghome/private-keys-v1.d/8B5ABF3EF9EB8D96B91A0B8C2C4401C91C834C34.key.asc +++ /dev/null @@ -1,20 +0,0 @@ ------BEGIN PGP ARMORED FILE----- -Version: GnuPG v2 -Comment: Use "gpg --dearmor" for unpacking - -S2V5OiAocHJpdmF0ZS1rZXkgKGVsZyAocCAjMDBDQ0Q4QjFGOURBQzc0RDgwOEND -NTJGMEQ4OTQ2NERBNTU0QzY5RDY3RjMKIDMyM0M0MkE5NUM5OTYyREY0MjEyNkVD -MEUwOTcxRjQ5QjgxMTUyOUE2QTJBRTlGMEFERUI4MzlBNjM0NjE1Q0Q1NkZBNTQK -IEY1QTBCN0VGMjVBMEUyRkU4NDNGQTJFNkUwMjFDQUI0MTE5RTYwMzk0QzlENkEz -RjdBRDRGNTc3OTZEMzY2NjlBNTEyNjYKIEMyN0E4RDFDNUE2QjQxNDFENUM4MzFF -ODQ1NDFGM0M4MTFFODkwNzg5ODAzMzgyOTVGODJCN0Y3RkQ0MzMzRUZEOTMzMTIK -IEYyQUIjKShnICMwNiMpKHkgIzM3NzNBNkQ5RUM4ODlENzZFMzI0RDZFNUVDMjFC -RDQ1Njk5ODMxQUU0RkQwQUUwMzc4MjAKIDVCQUU1QjhDRTg1RkFEQUJEN0U2QjdD -NzMwMjVDQjNENzMwRDVDNTgyOTAzNEQ3NkJFMDg1NUMyRTlGRjdBNDkyM0VGRkEK -IEYxNkE5NjY2OTQ0REJDNjI5NDgzOEZDM0YwOUZGOTY0QThEMDIzQ0I4RUJBMzMy -RkIwNTFFQTAyODIwRUU2MTIwRkZCRTYKIDJCMzZBMjAyQjNDNzUyRjlEQTc2QjJF -QzExQTY3RDJFMzVFNjZFQzEwNjM1ODdCMjI1MDBFOEE0NkQxNTdCNzUjKSh4ICMK -IDY5MTVDNkNFRDI1ODE0M0Y4OTM3QjEzMzVGNDg4N0YwMDQyQjdDNjMwMDUzOThG -OTM5NkJCODUzMjM4Q0I2IykpKQo= -=6fkh ------END PGP ARMORED FILE----- diff --git a/tests/migrations/extended-private-key-format.gpghome/pubring.kbx.asc b/tests/migrations/extended-private-key-format.gpghome/pubring.kbx.asc deleted file mode 100644 index 50123712c..000000000 --- a/tests/migrations/extended-private-key-format.gpghome/pubring.kbx.asc +++ /dev/null @@ -1,39 +0,0 @@ ------BEGIN PGP ARMORED FILE----- -Version: GnuPG v2 -Comment: Use "gpg --dearmor" for unpacking - -AAAAIAEBAAJLQlhmAAAAAFcYtiNXGLYjAAAAAAAAAAAAAAQXAgEAAAAAAH4AAAOF -AAIAHMHeuzTqi3EAnq+kdJc9UOHED97PAAAAIAAAAADNPQ9XAcv8rLKkkHMFo3iH -snkHqgAAADwAAAAAAAAAAQAMAAACJQAAACIAAAAAAAIABP//////////AAAAAAAA -AAAAAAAAVxi2IwAAAACZAaIEP/JSaxEEAKxxqlg9Kz9DZ/3N52BC0w+JtYKke39v -pdWVDHR3MHmMJ/31Y2iSpm0fvRs3h1j9/fBVmLOZglNQyH62SxdJyZwCelkZzfUy -/qLm9Qaqi7wpg0p4EbmWdoFF/A1Zg/MU7D5w5xu+EA1J77Z6QyALN9rIOXZ7rLLa -64lw/MV4LdIPAKC449htJbbp5rkJHvBDs4YxEIkk5wP/X4hPGlIw5PlHrsG7hdah -hTudV5hRGlvosnwsrYJXvKAQLAV1EV26SIYUH5pM/ycXrG25dqVoG56uQqnhBdUq -o4iSnsxY3ZMA46D14REc9P//CGvJ/j2Z41gw8u8oB7rS50djvoaWb5myj7bhacTB -dfah3U8dVXcIi1ZFvtiaGAYD+gIF7eNIdpaYiB0427un4ggc26+Y9nkF93DaMnZE -aYSeum6g/g7D1vwINFgQkMYEWi4DK3W+uH0E/n8o20wS2wvMrbeYaQm5v6ucd001 -wwFDY6AdwpwP7UCLQcu6qqvwNHdxWYK6+gIsSufLmeMGrsvC0WQqYeu1GfGpHIMC -ZJlZtCJUZXN0IHR3byAobm8gcHApIDx0d29AZXhhbXBsZS5jb20+iF8EExECAB8F -Aj/yUmsCGwMHCwkIBwMCAQMVAgMDFgIBAh4BAheAAAoJEJc9UOHED97PgEMAn0F8 -RGDrnmXv7rqM2+pic2oDz1kpAJ0SWPHxdjJHWzoGMrHqocAy/3wFi7kBDQQ/8lJv -EAQAzNix+drHTYCMxS8NiUZNpVTGnWfzMjxCqVyZYt9CEm7A4JcfSbgRUppqKunw -reuDmmNGFc1W+lT1oLfvJaDi/oQ/oubgIcq0EZ5gOUydaj961PV3ltNmaaUSZsJ6 -jRxaa0FB1cgx6EVB88gR6JB4mAM4KV+Ct/f9QzPv2TMS8qsAAwYD/jdzptnsiJ12 -4yTW5ewhvUVpmDGuT9CuA3ggW65bjOhfravX5rfHMCXLPXMNXFgpA012vghVwun/ -ekkj7/rxapZmlE28YpSDj8Pwn/lkqNAjy466My+wUeoCgg7mEg/75is2ogKzx1L5 -2nay7BGmfS415m7BBjWHsiUA6KRtFXt1iEkEGBECAAkFAj/yUm8CGwwACgkQlz1Q -4cQP3s8svgCgmWcpVwvtDN3nAVT1dMFTvCz0hfwAoI4VszJBesG/8GyLW+e2E+Li -QXVqciq2GGJ3Ap2KvoCwCL/DhCAfcGsAAAHgAgEAAAAAAF4AAAFuAAEAHM8jSQsP -eLhQu7xzadEgtibsq/UdAAAAIAAAAAAAAAABAAwAAADvAAAAJgAAAAAAAQAE//// -/wAAAAAAAAAAAAAAAFcYtkkAAAAAmQCMBD/yU70BBACoUlZ27OTXX+bQBz8r+Zpv -STPOvdRSivVuTGHi9zEkc5NkXdr1jq3VZSnCU5d4I2Rj3y1FhSDoDjTAWCQrP/iN -05qIO0dbZs6qu8mYn/Af/nN2YOm2G7nckSBdQo//6PZ1+u9hNljHLabXUMDrxAr2 -I9IGaSyCUUxATYglq3AQAQAJAQG0JlRlc3QgdGhyZWUgKG5vIHBwKSA8dGhyZWVA -ZXhhbXBsZS5jb20+iLUEEwECAB8FAj/yU70CGwMHCwkIBwMCAQMVAgMDFgIBAh4B -AheAAAoJENEgtibsq/UdakMD/2wg19VhpNbtM5CiVif1V57h945OmXr5Lh2SAsI5 -agMb9XXuT9yXsmv+JD5hEE6LRL98XAwGfvaQS9062aJQCocZAWdPJeEEsu+pMn/I -QdHqGdkr7Oy6xjwSa+gh19JMg4mqR4AIQSkKvRoTSqSAGbi+gytnTmkA7aEUltog -dYeJLGB5MYPnSPwADYVfNtLxsKZESLA= -=tULv ------END PGP ARMORED FILE----- diff --git a/tests/migrations/extended-private-key-format.gpghome/trustdb.gpg.asc b/tests/migrations/extended-private-key-format.gpghome/trustdb.gpg.asc deleted file mode 100644 index f4d354dcb..000000000 --- a/tests/migrations/extended-private-key-format.gpghome/trustdb.gpg.asc +++ /dev/null @@ -1,31 +0,0 @@ ------BEGIN PGP ARMORED FILE----- -Version: GnuPG v2 -Comment: Use "gpg --dearmor" for unpacking - -AWdwZwMDAQUBAgAAVxi2IwAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAQoAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -CgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAoAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -CgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAoAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -CgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAoAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -CgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAoAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -=eBUi ------END PGP ARMORED FILE----- diff --git a/tests/migrations/extended-private-key-format.test b/tests/migrations/extended-private-key-format.test deleted file mode 100755 index 9c373e877..000000000 --- a/tests/migrations/extended-private-key-format.test +++ /dev/null @@ -1,57 +0,0 @@ -#!/bin/sh -# Copyright 2016 g10 Code GmbH -# -# This file is free software; as a special exception the author gives -# unlimited permission to copy and/or distribute it, with or without -# modifications, as long as this notice is preserved. This file is -# distributed in the hope that it will be useful, but WITHOUT ANY -# WARRANTY, to the extent permitted by law; without even the implied -# warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - -if [ -z "$srcdir" ]; then - echo "not called from make" >&2 - exit 1 -fi - -unset GNUPGHOME -set -e - -# (We may not use a relative name for gpg-agent.) -GPG_AGENT="$(cd ../../agent && /bin/pwd)/gpg-agent" -GPG="../../g10/gpg --no-permission-warning --no-greeting --no-secmem-warning ---batch --agent-program=${GPG_AGENT}|--debug-quick-random" - -TEST="extended-private-key-format" - -setup_home() -{ - XGNUPGHOME="`mktemp -d`" - mkdir -p "$XGNUPGHOME/private-keys-v1.d" - for F in $srcdir/$TEST.gpghome/*.asc; do - $GPG --dearmor <"$F" >"$XGNUPGHOME/`basename $F .asc`" - done - for F in $srcdir/$TEST.gpghome/private-keys-v1.d/*.asc; do - $GPG --dearmor <"$F" >"$XGNUPGHOME/private-keys-v1.d/`basename $F .asc`" - done - chmod go-rwx $XGNUPGHOME/* $XGNUPGHOME/*/* - export GNUPGHOME="$XGNUPGHOME" -} - -cleanup_home() -{ - rm -rf -- "$XGNUPGHOME" -} - -assert_keys_usable() -{ - for KEY in C40FDECF ECABF51D; do - $GPG --list-secret-keys $KEY >/dev/null - done -} - -setup_home -assert_keys_usable -cleanup_home - - -# XXX try changing a key, and check that the format is not changed. diff --git a/tests/migrations/from-classic.gpghome/pubring.gpg.asc b/tests/migrations/from-classic.gpghome/pubring.gpg.asc deleted file mode 100644 index ecdfddcd0..000000000 --- a/tests/migrations/from-classic.gpghome/pubring.gpg.asc +++ /dev/null @@ -1,54 +0,0 @@ ------BEGIN PGP ARMORED FILE----- -Version: GnuPG v2 -Comment: Use "gpg --dearmor" for unpacking - -mQGiBD/yNQgRBAC/KSfe6uVfDgA3BrGpNLhVxT/ytwXMpBI8pEdTiY0jWnYrb/Yu -8wtCeZ9GAux/ZA/ted+7pdibHXfX5PzDfgUTZwrIJa57OUpWwI878AzZxNsnVv1I -P6ufGyESKME4PUQO5heKhwAb0gQwFwArS3v4oeYrEljhJ79kpt319JEAEwCg+hTk -nylYwYGT/PEVQ4JlLPoWmqUEAJn1HX1Od5tyoK4OEAM5G+wHz3SBj4FMonZNWs1I -t03JKHoM5ulQ2FgEWmBVIPTKSDm/jQXPYApz5DpxpoGYbTCaEo6zfE32AEzoXDmG -AZE90Xhq/wcEN+JcHpHytAA/n+hYaR3sYegQ52mWMR+vdd99KO0V0jLRcckgBA7Z -2jlFA/98cyy2nYt0QI5Tf+t/d4WBeib2yNWVtZH/j7XpDqHLZDgVAYkazCA6ZF7B -vLddBEqVAh1X5tqua4AXX9L4SGYb7B0LRV72alhYiWWHez126KjVgwRTUxtEJ4En -HmYJRReLlXosPIRhXSz7HFAqalPXJ0DvC9kzTQnnjPOylyMPTbQjVGVzdCBvbmUg -KHBwPWRlZikgPG9uZUBleGFtcGxlLmNvbT6IWgQTEQIAGgUCP/I1CAIbAwILAgMV -AgMDFgIBAh4BAheAAAoJEA73cJbXTF8iUO4AnA8wHb3erMrfWV3ij0d/cEiSJAYF -AJ9fcbShgTXDN1dIVZvLSW5E93TfC7ACAAOIWgQTEQIAGgUCP/I1CAIbAwILAgMV -AgMDFgIBAh4BAheAAAoJEA73cJbXTF8iUO4An3DqZUvcr92tYI+Ewj4jcmzFrNKM -AJ4yYTZj75t4d7WhUv1WjtDgJkkAm7ACAAO5AQ0EP/I1DRAEAOgCS1p47zcdec0U -vVC0phewalHUU6f7mulWr0j0ZY1RU0IOP18HAeT7INcwPcUaUvC9KYenXmYbvO1i -7sNNUCOsKUamwg+oSNMcbM3AwNwxlggTyJS1N6WzIX7MjRLUlUqtbLRhPDGlCltt -6yeAjS0pZT646TANaBDiRIgk94ADAAMFA/9Gh2X1Sy+4Ip/RtMJDPZOY+Y6sWUN7 -OiM2BkdUmCLOmaOVfgrsEevKdSBBj0oVWN81U02i7jQzhhAI3tZMFJmP/hlF7AlS -5HSaLj2+t1nHAKKy70QhskINR41CCv9sHAc5gN1WrY5NDpeI12GmqsWMPQVPUHsT -Te0QsT6XbHzvC4hJBBgRAgAJBQI/8jUNAhsMAAoJEA73cJbXTF8icHgAoMoPkG6U -dFdvTjKc/phZ6XojaDd9AKCokQkuhQ1wgXe2naMXaMGvzRaYzbACAAOZAaIEP/JS -axEEAKxxqlg9Kz9DZ/3N52BC0w+JtYKke39vpdWVDHR3MHmMJ/31Y2iSpm0fvRs3 -h1j9/fBVmLOZglNQyH62SxdJyZwCelkZzfUy/qLm9Qaqi7wpg0p4EbmWdoFF/A1Z -g/MU7D5w5xu+EA1J77Z6QyALN9rIOXZ7rLLa64lw/MV4LdIPAKC449htJbbp5rkJ -HvBDs4YxEIkk5wP/X4hPGlIw5PlHrsG7hdahhTudV5hRGlvosnwsrYJXvKAQLAV1 -EV26SIYUH5pM/ycXrG25dqVoG56uQqnhBdUqo4iSnsxY3ZMA46D14REc9P//CGvJ -/j2Z41gw8u8oB7rS50djvoaWb5myj7bhacTBdfah3U8dVXcIi1ZFvtiaGAYD+gIF -7eNIdpaYiB0427un4ggc26+Y9nkF93DaMnZEaYSeum6g/g7D1vwINFgQkMYEWi4D -K3W+uH0E/n8o20wS2wvMrbeYaQm5v6ucd001wwFDY6AdwpwP7UCLQcu6qqvwNHdx -WYK6+gIsSufLmeMGrsvC0WQqYeu1GfGpHIMCZJlZtCJUZXN0IHR3byAobm8gcHAp -IDx0d29AZXhhbXBsZS5jb20+iF8EExECAB8FAj/yUmsCGwMHCwkIBwMCAQMVAgMD -FgIBAh4BAheAAAoJEJc9UOHED97PgEMAn0F8RGDrnmXv7rqM2+pic2oDz1kpAJ0S -WPHxdjJHWzoGMrHqocAy/3wFi7ACAAO5AQ0EP/JSbxAEAMzYsfnax02AjMUvDYlG -TaVUxp1n8zI8QqlcmWLfQhJuwOCXH0m4EVKaairp8K3rg5pjRhXNVvpU9aC37yWg -4v6EP6Lm4CHKtBGeYDlMnWo/etT1d5bTZmmlEmbCeo0cWmtBQdXIMehFQfPIEeiQ -eJgDOClfgrf3/UMz79kzEvKrAAMGA/43c6bZ7IidduMk1uXsIb1FaZgxrk/QrgN4 -IFuuW4zoX62r1+a3xzAlyz1zDVxYKQNNdr4IVcLp/3pJI+/68WqWZpRNvGKUg4/D -8J/5ZKjQI8uOujMvsFHqAoIO5hIP++YrNqICs8dS+dp2suwRpn0uNeZuwQY1h7Il -AOikbRV7dYhJBBgRAgAJBQI/8lJvAhsMAAoJEJc9UOHED97PLL4AoJlnKVcL7Qzd -5wFU9XTBU7ws9IX8AKCOFbMyQXrBv/Bsi1vnthPi4kF1arACAAOYjAQ/8lO9AQQA -qFJWduzk11/m0Ac/K/mab0kzzr3UUor1bkxh4vcxJHOTZF3a9Y6t1WUpwlOXeCNk -Y98tRYUg6A40wFgkKz/4jdOaiDtHW2bOqrvJmJ/wH/5zdmDpthu53JEgXUKP/+j2 -dfrvYTZYxy2m11DA68QK9iPSBmksglFMQE2IJatwEAEACQEBtCZUZXN0IHRocmVl -IChubyBwcCkgPHRocmVlQGV4YW1wbGUuY29tPoi1BBMBAgAfBQI/8lO9AhsDBwsJ -CAcDAgEDFQIDAxYCAQIeAQIXgAAKCRDRILYm7Kv1HWpDA/9sINfVYaTW7TOQolYn -9Vee4feOTpl6+S4dkgLCOWoDG/V17k/cl7Jr/iQ+YRBOi0S/fFwMBn72kEvdOtmi -UAqHGQFnTyXhBLLvqTJ/yEHR6hnZK+zsusY8EmvoIdfSTIOJqkeACEEpCr0aE0qk -gBm4voMrZ05pAO2hFJbaIHWHibACAAM= -=fphx ------END PGP ARMORED FILE----- diff --git a/tests/migrations/from-classic.gpghome/secring.gpg.asc b/tests/migrations/from-classic.gpghome/secring.gpg.asc deleted file mode 100644 index 6aa367a6b..000000000 --- a/tests/migrations/from-classic.gpghome/secring.gpg.asc +++ /dev/null @@ -1,68 +0,0 @@ ------BEGIN PGP ARMORED FILE----- -Version: GnuPG v2 -Comment: Use "gpg --dearmor" for unpacking - -lQHpBD/yNQgRBAC/KSfe6uVfDgA3BrGpNLhVxT/ytwXMpBI8pEdTiY0jWnYrb/Yu -8wtCeZ9GAux/ZA/ted+7pdibHXfX5PzDfgUTZwrIJa57OUpWwI878AzZxNsnVv1I -P6ufGyESKME4PUQO5heKhwAb0gQwFwArS3v4oeYrEljhJ79kpt319JEAEwCg+hTk -nylYwYGT/PEVQ4JlLPoWmqUEAJn1HX1Od5tyoK4OEAM5G+wHz3SBj4FMonZNWs1I -t03JKHoM5ulQ2FgEWmBVIPTKSDm/jQXPYApz5DpxpoGYbTCaEo6zfE32AEzoXDmG -AZE90Xhq/wcEN+JcHpHytAA/n+hYaR3sYegQ52mWMR+vdd99KO0V0jLRcckgBA7Z -2jlFA/98cyy2nYt0QI5Tf+t/d4WBeib2yNWVtZH/j7XpDqHLZDgVAYkazCA6ZF7B -vLddBEqVAh1X5tqua4AXX9L4SGYb7B0LRV72alhYiWWHez126KjVgwRTUxtEJ4En -HmYJRReLlXosPIRhXSz7HFAqalPXJ0DvC9kzTQnnjPOylyMPTf4HAwI+6Mr+dvBp -XtZVHbBd1xUPHQl/+cIIBV6w3EFQuR6w7OorCYE6OHrHfEsFwCi3PNG5WUsMYIj2 -eddOuyRWtFR/QsaltCNUZXN0IG9uZSAocHA9ZGVmKSA8b25lQGV4YW1wbGUuY29t -PohaBBMRAgAaBQI/8jUIAhsDAgsCAxUCAwMWAgECHgECF4AACgkQDvdwltdMXyJQ -7gCcDzAdvd6syt9ZXeKPR39wSJIkBgUAn19xtKGBNcM3V0hVm8tJbkT3dN8LsAIA -AIhaBBMRAgAaBQI/8jUIAhsDAgsCAxUCAwMWAgECHgECF4AACgkQDvdwltdMXyJQ -7gCfcOplS9yv3a1gj4TCPiNybMWs0owAnjJhNmPvm3h3taFS/VaO0OAmSQCbsAIA -AJ0BXwQ/8jUNEAQA6AJLWnjvNx15zRS9ULSmF7BqUdRTp/ua6VavSPRljVFTQg4/ -XwcB5Psg1zA9xRpS8L0ph6deZhu87WLuw01QI6wpRqbCD6hI0xxszcDA3DGWCBPI -lLU3pbMhfsyNEtSVSq1stGE8MaUKW23rJ4CNLSllPrjpMA1oEOJEiCT3gAMAAwUD -/0aHZfVLL7gin9G0wkM9k5j5jqxZQ3s6IzYGR1SYIs6Zo5V+CuwR68p1IEGPShVY -3zVTTaLuNDOGEAje1kwUmY/+GUXsCVLkdJouPb63WccAorLvRCGyQg1HjUIK/2wc -BzmA3Vatjk0Ol4jXYaaqxYw9BU9QexNN7RCxPpdsfO8L/gcDArbUVjowJlNA1rny -wPbRkyAfJDY8m6+s1oM56PICi8N/E3TM/0A2fOESbsTfW6eKCmrIB3VDnURtVUTv -WS71OKAqhddkD8tUtVQWdKXL5YhJBBgRAgAJBQI/8jUNAhsMAAoJEA73cJbXTF8i -cHgAoMoPkG6UdFdvTjKc/phZ6XojaDd9AKCokQkuhQ1wgXe2naMXaMGvzRaYzbAC -AACVAekEP/JSaxEEAKxxqlg9Kz9DZ/3N52BC0w+JtYKke39vpdWVDHR3MHmMJ/31 -Y2iSpm0fvRs3h1j9/fBVmLOZglNQyH62SxdJyZwCelkZzfUy/qLm9Qaqi7wpg0p4 -EbmWdoFF/A1Zg/MU7D5w5xu+EA1J77Z6QyALN9rIOXZ7rLLa64lw/MV4LdIPAKC4 -49htJbbp5rkJHvBDs4YxEIkk5wP/X4hPGlIw5PlHrsG7hdahhTudV5hRGlvosnws -rYJXvKAQLAV1EV26SIYUH5pM/ycXrG25dqVoG56uQqnhBdUqo4iSnsxY3ZMA46D1 -4REc9P//CGvJ/j2Z41gw8u8oB7rS50djvoaWb5myj7bhacTBdfah3U8dVXcIi1ZF -vtiaGAYD+gIF7eNIdpaYiB0427un4ggc26+Y9nkF93DaMnZEaYSeum6g/g7D1vwI -NFgQkMYEWi4DK3W+uH0E/n8o20wS2wvMrbeYaQm5v6ucd001wwFDY6AdwpwP7UCL -Qcu6qqvwNHdxWYK6+gIsSufLmeMGrsvC0WQqYeu1GfGpHIMCZJlZ/gcDAt0kdqtP -lKPG1udCj4rXVf+JWEOsbdSsnimRh7rcSE5ksh/JzinsE9rm9FRY112AWfzPaj99 -0JAuaDOzn4d/6tPUnHa0IlRlc3QgdHdvIChubyBwcCkgPHR3b0BleGFtcGxlLmNv -bT6IXwQTEQIAHwUCP/JSawIbAwcLCQgHAwIBAxUCAwMWAgECHgECF4AACgkQlz1Q -4cQP3s+AQwCfQXxEYOueZe/uuozb6mJzagPPWSkAnRJY8fF2MkdbOgYyseqhwDL/ -fAWLsAIAAJ0BXwQ/8lJvEAQAzNix+drHTYCMxS8NiUZNpVTGnWfzMjxCqVyZYt9C -Em7A4JcfSbgRUppqKunwreuDmmNGFc1W+lT1oLfvJaDi/oQ/oubgIcq0EZ5gOUyd -aj961PV3ltNmaaUSZsJ6jRxaa0FB1cgx6EVB88gR6JB4mAM4KV+Ct/f9QzPv2TMS -8qsAAwYD/jdzptnsiJ124yTW5ewhvUVpmDGuT9CuA3ggW65bjOhfravX5rfHMCXL -PXMNXFgpA012vghVwun/ekkj7/rxapZmlE28YpSDj8Pwn/lkqNAjy466My+wUeoC -gg7mEg/75is2ogKzx1L52nay7BGmfS415m7BBjWHsiUA6KRtFXt1/gcDAp6cJdVh -287E1o1bCCplLBBjGAPRdWYlnZoJXXn7OUTHTSvMQkEZhAgDOKIiiwC88Drlk+bS -m9MngTW7YnBsrRfIGhpSxLcYSeMk2xu8m4hJBBgRAgAJBQI/8lJvAhsMAAoJEJc9 -UOHED97PLL4AoJlnKVcL7Qzd5wFU9XTBU7ws9IX8AKCOFbMyQXrBv/Bsi1vnthPi -4kF1arACAACVAgQEP/JTvQEEAKhSVnbs5Ndf5tAHPyv5mm9JM8691FKK9W5MYeL3 -MSRzk2Rd2vWOrdVlKcJTl3gjZGPfLUWFIOgONMBYJCs/+I3Tmog7R1tmzqq7yZif -8B/+c3Zg6bYbudyRIF1Cj//o9nX672E2WMctptdQwOvECvYj0gZpLIJRTEBNiCWr -cBABAAkBAf4HAwL3+6VQeHRq3tZqCOiuxPcuaSlTpURzbLJBa70QpeAbLZjOIjbm -dQuNBzmxYZNe5V8mf33q2gn/P9vjki0Z/k96qJOXBgLSJkyK4FPi2dtqKkrOonkx -rFv2AZ6Gt3zGp6dN3meYvG8GIiIvFiZmKYOrt4/XsAnPhXetbN23vO3dJxquD9sw -O8phwR2u6ii789nbXjD6vOyyv7WcogUVQTHC9pJQrOkDX9aMxiVWHvvv2o2FOU/n -JanwL/QN4J0sL36ytLoqhsUnayhhHbAP5TA+Vbk9JWvwO+6n8KDiUOkyaIzDaOgr -BvU1eMSv89MiYH8JiNU9nO9ungT0hxJMn9OwFcrXGCXZ6xXct9yN4nlVV0r16032 -DE7m0JQuwoLm4S7OkQEBHlvtfs/WZzMWkFbduOarPr1uzf92BaSjpQLEAKCFgX1/ -zBPnmqDOnOdL4AIZcYR+q+vWvQLI1RoYSCiodfNQt7iq2IRF8j4qis88QC/JMb60 -JlRlc3QgdGhyZWUgKG5vIHBwKSA8dGhyZWVAZXhhbXBsZS5jb20+iLUEEwECAB8F -Aj/yU70CGwMHCwkIBwMCAQMVAgMDFgIBAh4BAheAAAoJENEgtibsq/UdakMD/2wg -19VhpNbtM5CiVif1V57h945OmXr5Lh2SAsI5agMb9XXuT9yXsmv+JD5hEE6LRL98 -XAwGfvaQS9062aJQCocZAWdPJeEEsu+pMn/IQdHqGdkr7Oy6xjwSa+gh19JMg4mq -R4AIQSkKvRoTSqSAGbi+gytnTmkA7aEUltogdYeJsAIAAA== -=QqWQ ------END PGP ARMORED FILE----- diff --git a/tests/migrations/from-classic.gpghome/trustdb.gpg.asc b/tests/migrations/from-classic.gpghome/trustdb.gpg.asc deleted file mode 100644 index d4ab65d5e..000000000 --- a/tests/migrations/from-classic.gpghome/trustdb.gpg.asc +++ /dev/null @@ -1,31 +0,0 @@ ------BEGIN PGP ARMORED FILE----- -Version: GnuPG v2 -Comment: Use "gpg --dearmor" for unpacking - -AWdwZwMDAQUBAgAAVxdnIQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAQoAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -CgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAoAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -CgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAoAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -CgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAoAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -CgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAoAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -=XUWW ------END PGP ARMORED FILE----- diff --git a/tests/migrations/from-classic.scm b/tests/migrations/from-classic.scm new file mode 100755 index 000000000..2128532d8 --- /dev/null +++ b/tests/migrations/from-classic.scm @@ -0,0 +1,61 @@ +#!/usr/bin/env gpgscm + +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +(load (with-path "common.scm")) + +(define src-tarball (in-srcdir "from-classic.tar.asc")) + +(define (setup) + (untar-armored src-tarball) + (setenv "GNUPGHOME" (getcwd) #t)) + +(define (trigger-migration) + (call-check `(,@GPG --list-secret-keys))) + +(define (assert-migrated) + (unless (file-exists? ".gpg-v21-migrated") + (error "Not migrated")) + + (for-each + (lambda (keyid) + (catch (error "Key not found:" keyid) + (call-check `(,@GPG --list-secret-keys ,keyid)))) + '("D74C5F22" "C40FDECF" "ECABF51D"))) + +(info "Testing a clean migration ...") +(with-temporary-working-directory + (setup) + (trigger-migration) + (assert-migrated)) + +(info "Testing a migration with existing private-keys-v1.d ...") +(with-temporary-working-directory + (setup) + (mkdir "private-keys-v1.d" "-rwx") + (trigger-migration) + (assert-migrated)) + +(info "Testing a migration with existing but weird private-keys-v1.d ...") +(with-temporary-working-directory + (setup) + (mkdir "private-keys-v1.d" "") + (trigger-migration) + (assert-migrated)) + +;; XXX Check a case where the migration fails. diff --git a/tests/migrations/from-classic.tar.asc b/tests/migrations/from-classic.tar.asc new file mode 100644 index 000000000..f35637d50 --- /dev/null +++ b/tests/migrations/from-classic.tar.asc @@ -0,0 +1,209 @@ +-----BEGIN PGP ARMORED FILE----- +Version: GnuPG v2 +Comment: Use "gpg --dearmor" for unpacking + +cHVicmluZy5ncGcAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAADAwMDA2NDQAMDAwMTc1MAAwMDAxNzUwADAwMDAwMDA0MzQ3ADEyNzM2NzI0 +NjE3ADAxMzYxNgAgMAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAB1c3RhcgAwMHRleXRob29uAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAdGV5dGhvb24AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACZAaIEP/I1CBEEAL8pJ97q +5V8OADcGsak0uFXFP/K3BcykEjykR1OJjSNaditv9i7zC0J5n0YC7H9kD+1537ul +2Jsdd9fk/MN+BRNnCsglrns5SlbAjzvwDNnE2ydW/Ug/q58bIRIowTg9RA7mF4qH +ABvSBDAXACtLe/ih5isSWOEnv2Sm3fX0kQATAKD6FOSfKVjBgZP88RVDgmUs+haa +pQQAmfUdfU53m3Kgrg4QAzkb7AfPdIGPgUyidk1azUi3Tckoegzm6VDYWARaYFUg +9MpIOb+NBc9gCnPkOnGmgZhtMJoSjrN8TfYATOhcOYYBkT3ReGr/BwQ34lwekfK0 +AD+f6FhpHexh6BDnaZYxH691330o7RXSMtFxySAEDtnaOUUD/3xzLLadi3RAjlN/ +6393hYF6JvbI1ZW1kf+PtekOoctkOBUBiRrMIDpkXsG8t10ESpUCHVfm2q5rgBdf +0vhIZhvsHQtFXvZqWFiJZYd7PXboqNWDBFNTG0QngSceZglFF4uVeiw8hGFdLPsc +UCpqU9cnQO8L2TNNCeeM87KXIw9NtCNUZXN0IG9uZSAocHA9ZGVmKSA8b25lQGV4 +YW1wbGUuY29tPohaBBMRAgAaBQI/8jUIAhsDAgsCAxUCAwMWAgECHgECF4AACgkQ +DvdwltdMXyJQ7gCcDzAdvd6syt9ZXeKPR39wSJIkBgUAn19xtKGBNcM3V0hVm8tJ +bkT3dN8LsAIAA4haBBMRAgAaBQI/8jUIAhsDAgsCAxUCAwMWAgECHgECF4AACgkQ +DvdwltdMXyJQ7gCfcOplS9yv3a1gj4TCPiNybMWs0owAnjJhNmPvm3h3taFS/VaO +0OAmSQCbsAIAA7kBDQQ/8jUNEAQA6AJLWnjvNx15zRS9ULSmF7BqUdRTp/ua6Vav +SPRljVFTQg4/XwcB5Psg1zA9xRpS8L0ph6deZhu87WLuw01QI6wpRqbCD6hI0xxs +zcDA3DGWCBPIlLU3pbMhfsyNEtSVSq1stGE8MaUKW23rJ4CNLSllPrjpMA1oEOJE +iCT3gAMAAwUD/0aHZfVLL7gin9G0wkM9k5j5jqxZQ3s6IzYGR1SYIs6Zo5V+CuwR +68p1IEGPShVY3zVTTaLuNDOGEAje1kwUmY/+GUXsCVLkdJouPb63WccAorLvRCGy +Qg1HjUIK/2wcBzmA3Vatjk0Ol4jXYaaqxYw9BU9QexNN7RCxPpdsfO8LiEkEGBEC +AAkFAj/yNQ0CGwwACgkQDvdwltdMXyJweACgyg+QbpR0V29OMpz+mFnpeiNoN30A +oKiRCS6FDXCBd7adoxdowa/NFpjNsAIAA5kBogQ/8lJrEQQArHGqWD0rP0Nn/c3n +YELTD4m1gqR7f2+l1ZUMdHcweYwn/fVjaJKmbR+9GzeHWP398FWYs5mCU1DIfrZL +F0nJnAJ6WRnN9TL+oub1BqqLvCmDSngRuZZ2gUX8DVmD8xTsPnDnG74QDUnvtnpD +IAs32sg5dnusstrriXD8xXgt0g8AoLjj2G0ltunmuQke8EOzhjEQiSTnA/9fiE8a +UjDk+UeuwbuF1qGFO51XmFEaW+iyfCytgle8oBAsBXURXbpIhhQfmkz/Jxesbbl2 +pWgbnq5CqeEF1SqjiJKezFjdkwDjoPXhERz0//8Ia8n+PZnjWDDy7ygHutLnR2O+ +hpZvmbKPtuFpxMF19qHdTx1VdwiLVkW+2JoYBgP6AgXt40h2lpiIHTjbu6fiCBzb +r5j2eQX3cNoydkRphJ66bqD+DsPW/Ag0WBCQxgRaLgMrdb64fQT+fyjbTBLbC8yt +t5hpCbm/q5x3TTXDAUNjoB3CnA/tQItBy7qqq/A0d3FZgrr6AixK58uZ4wauy8LR +ZCph67UZ8akcgwJkmVm0IlRlc3QgdHdvIChubyBwcCkgPHR3b0BleGFtcGxlLmNv +bT6IXwQTEQIAHwUCP/JSawIbAwcLCQgHAwIBAxUCAwMWAgECHgECF4AACgkQlz1Q +4cQP3s+AQwCfQXxEYOueZe/uuozb6mJzagPPWSkAnRJY8fF2MkdbOgYyseqhwDL/ +fAWLsAIAA7kBDQQ/8lJvEAQAzNix+drHTYCMxS8NiUZNpVTGnWfzMjxCqVyZYt9C +Em7A4JcfSbgRUppqKunwreuDmmNGFc1W+lT1oLfvJaDi/oQ/oubgIcq0EZ5gOUyd +aj961PV3ltNmaaUSZsJ6jRxaa0FB1cgx6EVB88gR6JB4mAM4KV+Ct/f9QzPv2TMS +8qsAAwYD/jdzptnsiJ124yTW5ewhvUVpmDGuT9CuA3ggW65bjOhfravX5rfHMCXL +PXMNXFgpA012vghVwun/ekkj7/rxapZmlE28YpSDj8Pwn/lkqNAjy466My+wUeoC +gg7mEg/75is2ogKzx1L52nay7BGmfS415m7BBjWHsiUA6KRtFXt1iEkEGBECAAkF +Aj/yUm8CGwwACgkQlz1Q4cQP3s8svgCgmWcpVwvtDN3nAVT1dMFTvCz0hfwAoI4V +szJBesG/8GyLW+e2E+LiQXVqsAIAA5iMBD/yU70BBACoUlZ27OTXX+bQBz8r+Zpv +STPOvdRSivVuTGHi9zEkc5NkXdr1jq3VZSnCU5d4I2Rj3y1FhSDoDjTAWCQrP/iN +05qIO0dbZs6qu8mYn/Af/nN2YOm2G7nckSBdQo//6PZ1+u9hNljHLabXUMDrxAr2 +I9IGaSyCUUxATYglq3AQAQAJAQG0JlRlc3QgdGhyZWUgKG5vIHBwKSA8dGhyZWVA +ZXhhbXBsZS5jb20+iLUEEwECAB8FAj/yU70CGwMHCwkIBwMCAQMVAgMDFgIBAh4B +AheAAAoJENEgtibsq/UdakMD/2wg19VhpNbtM5CiVif1V57h945OmXr5Lh2SAsI5 +agMb9XXuT9yXsmv+JD5hEE6LRL98XAwGfvaQS9062aJQCocZAWdPJeEEsu+pMn/I +QdHqGdkr7Oy6xjwSa+gh19JMg4mqR4AIQSkKvRoTSqSAGbi+gytnTmkA7aEUltog +dYeJsAIAA2aUTbxilIOPw/Cf+WSo0CPLjrozL7BR6gKCDuYSD/vmKzaiArPHUvna +drLsEaZ9LjXmbsEGNYeyJQDopG0Ve3WISQQYEQIACQUCP/JSbwIbDAAKCRCXPVDh +xA/ezyy+AKCZZylXC+0M3ecBVPV0wVO8LPSF/ACgjhWzMkF6wb/wbItb57YT4uJB +dWqwAgADmIwEP/JTvQEEAKhSVnbs5Ndf5tAHPyv5mm9JM8691FKK9W5MYeL3MSRz +k2Rd2vWOrdVlKcJTl3gjZGPfLUWFIOgONMBYJCs/+I3Tmog7R1tmzqq7yZif8B/+ +c3Zg6bYbudyRIF1Cj//o9nX672E2WMctptdQwOvECvYj0gZpLIJRTEBNiCWrcBAB +c2VjcmluZy5ncGcAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAADAwMDA2NDQAMDAwMTc1MAAwMDAxNzUwADAwMDAwMDA1NjIyADEyNzM2NzI0 +NjE3ADAxMzU3NwAgMAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAB1c3RhcgAwMHRleXRob29uAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAdGV5dGhvb24AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACVAekEP/I1CBEEAL8pJ97q +5V8OADcGsak0uFXFP/K3BcykEjykR1OJjSNaditv9i7zC0J5n0YC7H9kD+1537ul +2Jsdd9fk/MN+BRNnCsglrns5SlbAjzvwDNnE2ydW/Ug/q58bIRIowTg9RA7mF4qH +ABvSBDAXACtLe/ih5isSWOEnv2Sm3fX0kQATAKD6FOSfKVjBgZP88RVDgmUs+haa +pQQAmfUdfU53m3Kgrg4QAzkb7AfPdIGPgUyidk1azUi3Tckoegzm6VDYWARaYFUg +9MpIOb+NBc9gCnPkOnGmgZhtMJoSjrN8TfYATOhcOYYBkT3ReGr/BwQ34lwekfK0 +AD+f6FhpHexh6BDnaZYxH691330o7RXSMtFxySAEDtnaOUUD/3xzLLadi3RAjlN/ +6393hYF6JvbI1ZW1kf+PtekOoctkOBUBiRrMIDpkXsG8t10ESpUCHVfm2q5rgBdf +0vhIZhvsHQtFXvZqWFiJZYd7PXboqNWDBFNTG0QngSceZglFF4uVeiw8hGFdLPsc +UCpqU9cnQO8L2TNNCeeM87KXIw9N/gcDAj7oyv528Gle1lUdsF3XFQ8dCX/5wggF +XrDcQVC5HrDs6isJgTo4esd8SwXAKLc80blZSwxgiPZ51067JFa0VH9CxqW0I1Rl +c3Qgb25lIChwcD1kZWYpIDxvbmVAZXhhbXBsZS5jb20+iFoEExECABoFAj/yNQgC +GwMCCwIDFQIDAxYCAQIeAQIXgAAKCRAO93CW10xfIlDuAJwPMB293qzK31ld4o9H +f3BIkiQGBQCfX3G0oYE1wzdXSFWby0luRPd03wuwAgAAiFoEExECABoFAj/yNQgC +GwMCCwIDFQIDAxYCAQIeAQIXgAAKCRAO93CW10xfIlDuAJ9w6mVL3K/drWCPhMI+ +I3JsxazSjACeMmE2Y++beHe1oVL9Vo7Q4CZJAJuwAgAAnQFfBD/yNQ0QBADoAkta +eO83HXnNFL1QtKYXsGpR1FOn+5rpVq9I9GWNUVNCDj9fBwHk+yDXMD3FGlLwvSmH +p15mG7ztYu7DTVAjrClGpsIPqEjTHGzNwMDcMZYIE8iUtTelsyF+zI0S1JVKrWy0 +YTwxpQpbbesngI0tKWU+uOkwDWgQ4kSIJPeAAwADBQP/Rodl9UsvuCKf0bTCQz2T +mPmOrFlDezojNgZHVJgizpmjlX4K7BHrynUgQY9KFVjfNVNNou40M4YQCN7WTBSZ +j/4ZRewJUuR0mi49vrdZxwCisu9EIbJCDUeNQgr/bBwHOYDdVq2OTQ6XiNdhpqrF +jD0FT1B7E03tELE+l2x87wv+BwMCttRWOjAmU0DWufLA9tGTIB8kNjybr6zWgzno +8gKLw38TdMz/QDZ84RJuxN9bp4oKasgHdUOdRG1VRO9ZLvU4oCqF12QPy1S1VBZ0 +pcvliEkEGBECAAkFAj/yNQ0CGwwACgkQDvdwltdMXyJweACgyg+QbpR0V29OMpz+ +mFnpeiNoN30AoKiRCS6FDXCBd7adoxdowa/NFpjNsAIAAJUB6QQ/8lJrEQQArHGq +WD0rP0Nn/c3nYELTD4m1gqR7f2+l1ZUMdHcweYwn/fVjaJKmbR+9GzeHWP398FWY +s5mCU1DIfrZLF0nJnAJ6WRnN9TL+oub1BqqLvCmDSngRuZZ2gUX8DVmD8xTsPnDn +G74QDUnvtnpDIAs32sg5dnusstrriXD8xXgt0g8AoLjj2G0ltunmuQke8EOzhjEQ +iSTnA/9fiE8aUjDk+UeuwbuF1qGFO51XmFEaW+iyfCytgle8oBAsBXURXbpIhhQf +mkz/Jxesbbl2pWgbnq5CqeEF1SqjiJKezFjdkwDjoPXhERz0//8Ia8n+PZnjWDDy +7ygHutLnR2O+hpZvmbKPtuFpxMF19qHdTx1VdwiLVkW+2JoYBgP6AgXt40h2lpiI +HTjbu6fiCBzbr5j2eQX3cNoydkRphJ66bqD+DsPW/Ag0WBCQxgRaLgMrdb64fQT+ +fyjbTBLbC8ytt5hpCbm/q5x3TTXDAUNjoB3CnA/tQItBy7qqq/A0d3FZgrr6AixK +58uZ4wauy8LRZCph67UZ8akcgwJkmVn+BwMC3SR2q0+Uo8bW50KPitdV/4lYQ6xt +1KyeKZGHutxITmSyH8nOKewT2ub0VFjXXYBZ/M9qP33QkC5oM7Ofh3/q09ScdrQi +VGVzdCB0d28gKG5vIHBwKSA8dHdvQGV4YW1wbGUuY29tPohfBBMRAgAfBQI/8lJr +AhsDBwsJCAcDAgEDFQIDAxYCAQIeAQIXgAAKCRCXPVDhxA/ez4BDAJ9BfERg655l +7+66jNvqYnNqA89ZKQCdEljx8XYyR1s6BjKx6qHAMv98BYuwAgAAnQFfBD/yUm8Q +BADM2LH52sdNgIzFLw2JRk2lVMadZ/MyPEKpXJli30ISbsDglx9JuBFSmmoq6fCt +64OaY0YVzVb6VPWgt+8loOL+hD+i5uAhyrQRnmA5TJ1qP3rU9XeW02ZppRJmwnqN +HFprQUHVyDHoRUHzyBHokHiYAzgpX4K39/1DM+/ZMxLyqwADBgP+N3Om2eyInXbj +JNbl7CG9RWmYMa5P0K4DeCBbrluM6F+tq9fmt8cwJcs9cw1cWCkDTXa+CFXC6f96 +SSPv+vFqlmaUTbxilIOPw/Cf+WSo0CPLjrozL7BR6gKCDuYSD/vmKzaiArPHUvna +drLsEaZ9LjXmbsEGNYeyJQDopG0Ve3X+BwMCnpwl1WHbzsTWjVsIKmUsEGMYA9F1 +ZiWdmgldefs5RMdNK8xCQRmECAM4oiKLALzwOuWT5tKb0yeBNbticGytF8gaGlLE +txhJ4yTbG7ybiEkEGBECAAkFAj/yUm8CGwwACgkQlz1Q4cQP3s8svgCgmWcpVwvt +DN3nAVT1dMFTvCz0hfwAoI4VszJBesG/8GyLW+e2E+LiQXVqsAIAAJUCBAQ/8lO9 +AQQAqFJWduzk11/m0Ac/K/mab0kzzr3UUor1bkxh4vcxJHOTZF3a9Y6t1WUpwlOX +eCNkY98tRYUg6A40wFgkKz/4jdOaiDtHW2bOqrvJmJ/wH/5zdmDpthu53JEgXUKP +/+j2dfrvYTZYxy2m11DA68QK9iPSBmksglFMQE2IJatwEAEACQEB/gcDAvf7pVB4 +dGre1moI6K7E9y5pKVOlRHNsskFrvRCl4BstmM4iNuZ1C40HObFhk17lXyZ/fera +Cf8/2+OSLRn+T3qok5cGAtImTIrgU+LZ22oqSs6ieTGsW/YBnoa3fManp03eZ5i8 +bwYiIi8WJmYpg6u3j9ewCc+Fd61s3be87d0nGq4P2zA7ymHBHa7qKLvz2dteMPq8 +7LK/tZyiBRVBMcL2klCs6QNf1ozGJVYe++/ajYU5T+clqfAv9A3gnSwvfrK0uiqG +xSdrKGEdsA/lMD5VuT0la/A77qfwoOJQ6TJojMNo6CsG9TV4xK/z0yJgfwmI1T2c +726eBPSHEkyf07AVytcYJdnrFdy33I3ieVVXSvXrTfYMTubQlC7CgubhLs6RAQEe +W+1+z9ZnMxaQVt245qs+vW7N/3YFpKOlAsQAoIWBfX/ME+eaoM6c50vgAhlxhH6r +69a9AsjVGhhIKKh181C3uKrYhEXyPiqKzzxAL8kxvrQmVGVzdCB0aHJlZSAobm8g +cHApIDx0aHJlZUBleGFtcGxlLmNvbT6ItQQTAQIAHwUCP/JTvQIbAwcLCQgHAwIB +AxUCAwMWAgECHgECF4AACgkQ0SC2Juyr9R1qQwP/bCDX1WGk1u0zkKJWJ/VXnuH3 +jk6ZevkuHZICwjlqAxv1de5P3Jeya/4kPmEQTotEv3xcDAZ+9pBL3TrZolAKhxkB +Z08l4QSy76kyf8hB0eoZ2Svs7LrGPBJr6CHX0kyDiapHgAhBKQq9GhNKpIAZuL6D +K2dOaQDtoRSW2iB1h4mwAgAA9gGehrd8xqenTd5nmLxvBiIiLxYmZimDq7eP17AJ +z4V3rWzdt7zt3Scarg/bMDvKYcEdruoou/PZ214w+rzssr+1nKIFFUExwvaSUKzp +A1/WjMYlVh7779qNhTlP5yWp8C/0DeCdLC9+srS6KoZ0cnVzdGRiLmdwZwAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAMDAwMDY0NAAwMDAx +NzUwADAwMDE3NTAAMDAwMDAwMDIyNjAAMTI3MzY3MjQ2MTcAMDEzNjI3ACAwAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AHVzdGFyADAwdGV5dGhvb24AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAB0ZXl0aG9v +bgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAFncGcDAwEFAQIAAFcXZyEAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAEKAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +CgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAoAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +CgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAoAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +CgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAoAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +CgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAoAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +CgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAoAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +CgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAoAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAoAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAKAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +CgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAoAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA +AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA= +=nYpX +-----END PGP ARMORED FILE----- diff --git a/tests/migrations/from-classic.test b/tests/migrations/from-classic.test deleted file mode 100755 index 9b81d452b..000000000 --- a/tests/migrations/from-classic.test +++ /dev/null @@ -1,77 +0,0 @@ -#!/bin/sh -# Copyright 2016 g10 Code GmbH -# -# This file is free software; as a special exception the author gives -# unlimited permission to copy and/or distribute it, with or without -# modifications, as long as this notice is preserved. This file is -# distributed in the hope that it will be useful, but WITHOUT ANY -# WARRANTY, to the extent permitted by law; without even the implied -# warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - -if [ -z "$srcdir" ]; then - echo "not called from make" >&2 - exit 1 -fi - -unset GNUPGHOME -set -e - -# (We may not use a relative name for gpg-agent.) -GPG_AGENT="$(cd ../../agent && /bin/pwd)/gpg-agent" -GPG="../../g10/gpg --no-permission-warning --no-greeting --no-secmem-warning ---batch --agent-program=${GPG_AGENT}|--debug-quick-random" - -TEST="from-classic" - -setup_home() -{ - XGNUPGHOME="`mktemp -d`" - rm -rf -- scratch - mkdir -p "$XGNUPGHOME" - for F in $srcdir/$TEST.gpghome/*.asc; do - $GPG --dearmor <"$F" >"$XGNUPGHOME/`basename $F .asc`" - done - chmod go-rwx $XGNUPGHOME/* - export GNUPGHOME="$XGNUPGHOME" -} - -cleanup_home() -{ - rm -rf -- "$XGNUPGHOME" -} - -trigger_migration() -{ - $GPG --list-secret-keys >/dev/null 2>&1 -} - -assert_migrated() -{ - test -f $GNUPGHOME/.gpg-v21-migrated - - for KEY in D74C5F22 C40FDECF ECABF51D; do - $GPG --list-secret-keys $KEY >/dev/null - done -} - -setup_home -trigger_migration -assert_migrated -cleanup_home - -# Test with an existing private-keys-v1.d. -setup_home -mkdir "$GNUPGHOME/private-keys-v1.d" -trigger_migration -assert_migrated -cleanup_home - -# Test with an existing private-keys-v1.d with weird permissions. -setup_home -mkdir "$GNUPGHOME/private-keys-v1.d" -chmod 0 "$GNUPGHOME/private-keys-v1.d" -trigger_migration -assert_migrated -cleanup_home - -# XXX Check a case where the migration fails. diff --git a/tests/openpgp/4gb-packet.scm b/tests/openpgp/4gb-packet.scm new file mode 100755 index 000000000..8b2fcd6ca --- /dev/null +++ b/tests/openpgp/4gb-packet.scm @@ -0,0 +1,27 @@ +#!/usr/bin/env gpgscm + +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +;; GnuPG through 2.1.7 would incorrect mark packets whose size is +;; 2^32-1 as invalid and exit with status code 2. + +(load (with-path "defs.scm")) + +(if (= 0 (call `(,@GPG --list-packets ,(in-srcdir "4gb-packet.asc")))) + (info "Can parse 4GB packets.") + (error "Failed to parse 4GB packet.")) diff --git a/tests/openpgp/Makefile.am b/tests/openpgp/Makefile.am index bb1047d5e..012a3f20c 100644 --- a/tests/openpgp/Makefile.am +++ b/tests/openpgp/Makefile.am @@ -22,7 +22,8 @@ # Programs required before we can run these tests. required_pgms = ../../g10/gpg$(EXEEXT) ../../agent/gpg-agent$(EXEEXT) \ ../../tools/gpg-connect-agent$(EXEEXT) \ - ../../tools/mk-tdata$(EXEEXT) + ../../tools/mk-tdata$(EXEEXT) \ + ../gpgscm/gpgscm$(EXEEXT) AM_CPPFLAGS = -I$(top_srcdir)/common include $(top_srcdir)/am/cmacros.am @@ -33,32 +34,54 @@ noinst_PROGRAMS = fake-pinentry fake_pinentry_SOURCES = fake-pinentry.c -TESTS_ENVIRONMENT = GNUPGHOME=$(abs_builddir) GPG_AGENT_INFO= LC_ALL=C +TMP ?= /tmp -if SQLITE3 -sqlite3_dependent_tests = tofu.test -else -sqlite3_dependent_tests = -endif +TESTS_ENVIRONMENT = GNUPGHOME=$(abs_builddir) GPG_AGENT_INFO= LC_ALL=C \ + EXEEXT=$(EXEEXT) \ + PATH=../gpgscm:$(PATH) \ + TMP=$(TMP) \ + objdir=$(abs_top_builddir) \ + GPGSCM_PATH=$(top_srcdir)/tests/gpgscm:$(top_srcdir)/tests/openpgp -# Note: version.test needs to be the first test to run and finish.test +# Note: setup.scm needs to be the first test to run and finish.scm # the last one -TESTS = version.test mds.test \ - decrypt.test decrypt-dsa.test \ - sigs.test sigs-dsa.test \ - encrypt.test encrypt-dsa.test \ - seat.test clearsig.test encryptp.test detach.test \ - armsigs.test armencrypt.test armencryptp.test \ - signencrypt.test signencrypt-dsa.test \ - armsignencrypt.test armdetach.test \ - armdetachm.test detachm.test genkey1024.test \ - conventional.test conventional-mdc.test \ - multisig.test verify.test armor.test \ - import.test ecc.test 4gb-packet.test \ - $(sqlite3_dependent_tests) \ - gpgtar.test use-exact-key.test default-key.test \ - export.test \ - finish.test +TESTS = setup.scm \ + version.scm \ + mds.scm \ + decrypt.scm \ + decrypt-dsa.scm \ + sigs.scm \ + sigs-dsa.scm \ + encrypt.scm \ + encrypt-dsa.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 \ + armor.scm \ + import.scm \ + ecc.scm \ + 4gb-packet.scm \ + tofu.scm \ + gpgtar.scm \ + use-exact-key.scm \ + default-key.scm \ + export.scm \ + finish.scm TEST_FILES = pubring.asc secring.asc plain-1o.asc plain-2o.asc plain-3o.asc \ @@ -98,10 +121,14 @@ priv_keys = privkeys/50B2D4FA4122C212611048BC5FC31BD44393626E.asc \ privkeys/1DF48228FEFF3EC2481B106E0ACA8C465C662CC5.asc \ privkeys/A2832820DC9F40751BDCD375BB0945BA33EC6B4C.asc \ privkeys/ADE710D74409777B7729A7653373D820F67892E0.asc \ - privkeys/CEFC51AF91F68A2904FBFF62C4F075A4785B803F.asc - - -sample_keys = samplekeys/ecc-sample-1-pub.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 \ @@ -114,10 +141,14 @@ sample_keys = samplekeys/ecc-sample-1-pub.asc \ samplekeys/whats-new-in-2.1.asc \ samplekeys/e2e-p256-1-clr.asc \ samplekeys/e2e-p256-1-prt.asc \ - samplekeys/E657FB607BB4F21C90BB6651BC067AF28BC90111.asc - -EXTRA_DIST = defs.inc pinentry.sh $(TESTS) $(TEST_FILES) ChangeLog-2011 \ - mkdemodirs signdemokey $(priv_keys) $(sample_keys) + samplekeys/E657FB607BB4F21C90BB6651BC067AF28BC90111.asc \ + samplekeys/rsa-rsa-sample-1.asc \ + samplekeys/ed25519-cv25519-sample-1.asc \ + samplekeys/silent-running.asc + +EXTRA_DIST = defs.inc defs.scm pinentry.sh $(TESTS) $(TEST_FILES) \ + mkdemodirs signdemokey $(priv_keys) $(sample_keys) \ + ChangeLog-2011 CLEANFILES = prepared.stamp x y yy z out err $(data_files) \ plain-1 plain-2 plain-3 trustdb.gpg *.lock .\#lk* \ diff --git a/tests/openpgp/README b/tests/openpgp/README new file mode 100644 index 000000000..1f8654b08 --- /dev/null +++ b/tests/openpgp/README @@ -0,0 +1,161 @@ +# Emacs, this is an -*- org -*- file. + +* How to run the test suite +** using the legacy driver +On POSIX you can just use + + $ make -C tests/openpgp check + +or + + $ make -C tests/openpgp check TESTS="setup.scm your-test.scm finish.scm" + +as before. +** using the Scheme driver +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=<path to>/tests/openpgp \ + GPGSCM_PATH=<path to>/tests/gpgscm:<path to>/tests/openpgp \ + $(pwd)/tests/gpgscm/gpgscm [gpgscm args] \ + run-tests.scm [test suite runner args] + +*** Arguments supported by the test suite runner +The test suite runner supports four modes of operation, +{sequential,parallel}x{isolated,shared}. You can select the mode of +operation using a combination of the flags --parallel, --sequential, +--shared, and --isolated. + +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'). By default all tests listed in +run-tests.scm are executed. 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 '.'. +** Temporary files +(lettmp <bindings> <body>) will create and delete temporary files that +you can use in <body>. (with-temporary-working-directory <body>) will +create a temporary director, change to that, and clean it up after +executing <body>). + +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/armdetach.scm b/tests/openpgp/armdetach.scm new file mode 100755 index 000000000..69e09d8ce --- /dev/null +++ b/tests/openpgp/armdetach.scm @@ -0,0 +1,31 @@ +#!/usr/bin/env gpgscm + +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +(load (with-path "defs.scm")) + +(for-each-p + "Checking armored detached signatures" + (lambda (source) + (lettmp (tmp) + (call-popen `(,@GPG --yes --passphrase-fd "0" -sab + --output ,tmp ,source ) usrpass1) + (pipe:do + (pipe:open source (logior O_RDONLY O_BINARY)) + (pipe:spawn `(,@GPG --yes ,tmp))))) + (append plain-files data-files)) diff --git a/tests/openpgp/armdetachm.scm b/tests/openpgp/armdetachm.scm new file mode 100755 index 000000000..618f7aab4 --- /dev/null +++ b/tests/openpgp/armdetachm.scm @@ -0,0 +1,35 @@ +#!/usr/bin/env gpgscm + +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +(load (with-path "defs.scm")) + +(define files (append plain-files data-files)) + +(info "Checking armored detached signatures of multiple files") +(lettmp (tmp) + (call-popen `(,@GPG --yes --passphrase-fd "0" -sab + --output ,tmp ,@files) usrpass1) + (pipe:do + (pipe:defer (lambda (sink) + (for-each (lambda (file) + (pipe:do + (pipe:open file (logior O_RDONLY O_BINARY)) + (pipe:splice sink))) + files))) + (pipe:spawn `(,@GPG --yes ,tmp)))) diff --git a/tests/openpgp/armencrypt.scm b/tests/openpgp/armencrypt.scm new file mode 100755 index 000000000..b0cf0991a --- /dev/null +++ b/tests/openpgp/armencrypt.scm @@ -0,0 +1,30 @@ +#!/usr/bin/env gpgscm + +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +(load (with-path "defs.scm")) + +(for-each-p + "Checking armored encryption" + (lambda (source) + (tr:do + (tr:open source) + (tr:gpg usrpass1 `(--yes --passphrase-fd "0" -ea --recipient ,usrname2)) + (tr:gpg "" '(--yes)) + (tr:assert-identity source))) + (append plain-files data-files)) diff --git a/tests/openpgp/armencryptp.scm b/tests/openpgp/armencryptp.scm new file mode 100755 index 000000000..7555ce9d9 --- /dev/null +++ b/tests/openpgp/armencryptp.scm @@ -0,0 +1,31 @@ +#!/usr/bin/env gpgscm + +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +(load (with-path "defs.scm")) + +(for-each-p + "Checking armored encryption and decryption using pipes" + (lambda (source) + (tr:do + (tr:open source) + (tr:pipe-do + (pipe:gpg `(--yes -ea --recipient ,usrname2)) + (pipe:gpg '(--yes))) + (tr:assert-identity source))) + (append plain-files data-files)) diff --git a/tests/openpgp/armor.scm b/tests/openpgp/armor.scm new file mode 100755 index 000000000..5b4ea1409 --- /dev/null +++ b/tests/openpgp/armor.scm @@ -0,0 +1,766 @@ +#!/usr/bin/env gpgscm + +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +(load (with-path "defs.scm")) + +(define armored_key_8192 "-----BEGIN PGP PUBLIC KEY BLOCK----- +Version: SKS 1.0.9 + +mQGiBDnKLQkRBACVlYh6HivoRjHzGedNpnYPISxImK3eFgt+qs/DD9rqhBOSUTYvmKfa1u7M +W4XDc23YEoq3MyhtC35IL2RH6rmeIPz7ZVK5rUKWMqzf94n58gIkgdDZgCcaDWImtZFSjji4 +TGhepaIz75iIbymvtnjr9d++fH/lFkz0HDjbOkXCfwCg9GeOjiWw1yBK8cO11acAjk+QpW8D +/i8ftC1hV0iuh9mswYeG05pBbeeaOW4I2Ps4IcecpXhSyPaP1YiXKRqg9GX2brNgXwc3MEiq +Wn4UU407RzjrUNF4/d20Q7N2g2MDUDzBtmMytfT2LLKlj53Cq+p510yXESA7UHjiOpRrHPN9 +R69wHmHPsLPkdkB/jRTSM1gzQNtXA/96bRpfGMtCssfB449gBA/kYF14iXUM5KTF6YPSFhCC +xPGNMoP1uxTk0NHvcYZe4zW2O6b/f9x5Lh15RI1ozWXakX6u3xEV3OqsvVTtXupe4MljHQlX +YwMDI3MUzFtnHR+He1Bw5lkBVWtkV7rX2kX749J1EgADwlNEP1KFRdjqi7QhU3VzdW11IE9T +QVdBIDxzdXN1bXVvQGRlYmlhbi5vcmc+iEYEEBECAAYFAjvNYPUACgkQU+WZW1FVMwrlTACf +RigokAWd1OqYtcOt3v829fhNqYEAnR9uUslZr6B6RaW0z8/BZZuhGuLViEYEEBECAAYFAjzG +evgACgkQfGUzr9MtPXGWyACg066aP5SSkBHWqqYGGLZv9sVRMNIAoIEHBI1gq4rPJatYDdau +Ni6DUTkGiEYEEBECAAYFAjzGfBAACgkQ9D5yZjzIjAlTqACeJmtp9kpfljkARhfa3QTc2Q56 +WKkAoJmUchp+fAceVeFncpFeo6leM1YhiEYEEBECAAYFAjzGftIACgkQ2QCnNZ2xmQQCegCg +rdTsTWzaZk6gF+mtvIDwKsUx8gwAnRUbdDfOP0qL+83Bbz2r/IzPxjCEiEYEEBECAAYFAj2T +Rd0ACgkQFwU5DuZsm7BfXQCeNVG09VZ2VnuuWTRbgoANXGIyRb0AoI/giUU4DcIpAPbcoNV7 +PzCIreyviEYEExECAAYFAj2508wACgkQ0pu//EQuY8KiUwCdHijK7Wkim2FUPU6i6KxwRH/k +kFwAn1sOAWVOrLfRBfrNNQBANpbr5ufniEYEExECAAYFAj27vpsACgkQKb5dImj9VJ9m2wCc +DeL9IkWpytXLPFhKCH9U9XhzPA4AnRjiY3y6AdNhbUgG/eS8Dumch0dniEYEExECAAYFAj5q +MCcACgkQO/YJxouvzb2O5QCghtxYfrIcbfTcBwvz9vG1sBHkQSkAnj3PMjN9dk1x1e4rUD9d +S00JOoI0iFYEExECABYFAjnKLQkECwoEAwMVAwIDFgIBAheAAAoJEN7sjAneQVsOUfcAoNgN +xaeqMn5EWO2MkwVvVrLjWI2FAKDLnp19rJsU69OK7qHqfMeGWFXsQYheBBMRAgAWBQI5yi0J +BAsKBAMDFQMCAxYCAQIXgAASCRDe7IwJ3kFbDgdlR1BHAAEBUfcAoNgNxaeqMn5EWO2MkwVv +VrLjWI2FAKDLnp19rJsU69OK7qHqfMeGWFXsQYiVAwUQOcrkWi2pLp/VI9wNAQE5mAP/WW9g +shqGqWN/rWevpVKlzwqGSqMUq6E2K34dHrFdqd/WnY8ng5zAd66Ey3OLS5x9/+KI6W9MU5OI +WmxOfrp7PxwqLrQH/BruPTHe9mZbkSyjWIS/V+W8/lYtzIUYTd0584+1x7cK6jah3mAdFu5t +8fr1k3NyVXFH66dLrLF0bBu0JFN1c3VtdSBPU0FXQSA8c3VzdW11LW9AZGViaWFuLm9yLmpw +PohGBBARAgAGBQI7zWD4AAoJEFPlmVtRVTMKpEEAn0Oxl1tcdFf6LxiG2URD7kmHNm+iAJ9l +uLXjsYvo0OXlG1HlaFkFduhgp4hGBBARAgAGBQI8xnr7AAoJEHxlM6/TLT1xZlEAnjSeGhDQ +mbidMrjv4nOaWWDePjN7AKDXoHEhZbpUIJLJBgS4jZfuGtT3VYhGBBARAgAGBQI8xnwTAAoJ +EPQ+cmY8yIwJTjEAnAllI6IPXWJlHjtwqlHHwprrZG4eAJwMTl5Rbqu1lf+Lmz3N8QBrcTjn +zYhGBBARAgAGBQI8xn7VAAoJENkApzWdsZkE6M4AoIpVj26AQLU6dtiJuLNMio8jKx/AAJ9n +8VzpA4GFEL3Rg2eqNvuQC0bJp4hGBBARAgAGBQI9k0XgAAoJEBcFOQ7mbJuwsaUAnRIT1q2W +kEgui423U/TVWLvSp2/aAKDG6xkJ+tdAmBnO5CcQcNswRmK4NIhGBBMRAgAGBQI9u76dAAoJ +ECm+XSJo/VSfDJQAn0pZLQJhXUWzasjG2s2L8egRvvkmAJ4yTxKBoZbvtruTf//8HwNLRs9W +v4hGBBMRAgAGBQI+ajAuAAoJEDv2CcaLr829bTYAoJzZa95z3Ty/rVS8Q5viOnicJwtOAKCG +RKoaw3UZfpm6RLHZ4aHlYxCA0YhXBBMRAgAXBQI6aHxFBQsHCgMEAxUDAgMWAgECF4AACgkQ +3uyMCd5BWw4I+ACfQhdkd2tu9qqWuWW7O1GsLpb359oAoLleotCCH4La5L5ZE/cPIde9+p8o +iF8EExECABcFAjpofEUFCwcKAwQDFQMCAxYCAQIXgAASCRDe7IwJ3kFbDgdlR1BHAAEBCPgA +n0IXZHdrbvaqlrlluztRrC6W9+faAKC5XqLQgh+C2uS+WRP3DyHXvfqfKLQlU3VzdW11IE9T +QVdBIDxzdXN1bXUtb0Bnb2ZvcndhcmQub3JnPohGBBARAgAGBQI7zWD4AAoJEFPlmVtRVTMK +aY0An0oI4Fwko9YsVWS+0M3/Tpc8FB2eAJ4oALojFgFkOWYT97dh8rTQW8BhyohGBBARAgAG +BQI8xnr7AAoJEHxlM6/TLT1xsXcAoJV/9zoudxvWy+LwktkGyCB7aTx4AJ0Z8GWmx2/C4W2M +tSyaUscY3X19uYhGBBARAgAGBQI8xnwTAAoJEPQ+cmY8yIwJpxQAn3efnPpctMJFDQomRDbo +7Q8rg6r4AKCq7LZmOaXvyrBF/JcYjOCLtYMPIIhGBBARAgAGBQI8xn7VAAoJENkApzWdsZkE +iB0AnRQs0XjhpGOpR1lyEOuZkm2xxHPzAJ9Is3sG9UMOr+YS5V1GXXiFM29S3YhGBBARAgAG +BQI9k0XgAAoJEBcFOQ7mbJuwjiAAn2wcQP9HreVLCSQruB1wnX/s79ZcAKCRcecLF+wiRo59 +JJvwtnxp2W24EYhGBBMRAgAGBQI9u76dAAoJECm+XSJo/VSftKUAoJQ/cYKqkyOLSOelU8eM +plFiFJlPAJwK7B0HrN+tDmR7r8Hc0GrRrbAuvYhGBBMRAgAGBQI+ajAuAAoJEDv2CcaLr829 +PX0An2kfEs+3iR5qV35EQlCdL5ITZCSNAKCf8HErpT620TUhU6hI7vW5R3LNgohXBBMRAgAX +BQI6aHxeBQsHCgMEAxUDAgMWAgECF4AACgkQ3uyMCd5BWw5HzwCdF8w3WjnwTvktko3ZB7IM +mFLKvSQAn3GbioDBdV+j6xuhSI90osLMu1jgiF8EExECABcFAjpofF4FCwcKAwQDFQMCAxYC +AQIXgAASCRDe7IwJ3kFbDgdlR1BHAAEBR88AnRfMN1o58E75LZKN2QeyDJhSyr0kAJ9xm4qA +wXVfo+sboUiPdKLCzLtY4IkBIgQQAQIADAUCQpGGggUDABJ1AAAKCRCXELibyletfJEKCACw +Yf5qY4J3RtHnC56HmGiW4GXaahJpBQ1JcWmfx7CkTqJPQveg+KQ4pfLuJvZ8v4YqPZCxPOeK +/ZhIO48UB4obcD8BZdSkRA4QBamRp8iqcgrCot/LA5xQu9tivIhUJP/1dT6PmDy4DAV3Flgt +HgED5niVESDPfz3Gjff5iWWIs6dM3bycxoTcFWLz++578aOasoq9T8Tfua9H8UrouVz3+6TK +xG0rGeb2jOQOQcbLCn3soU/Z60H3SvJYHzgxlS5bqIybrjo3sAnuus/kisrmNjeFfQBdl9v+ +GnK65D1tmBa1+6a95uHb+OG4eHzIXmvnDI4A1RhRKiZ/kpVsT7RViQEiBBABAgAMBQJCo1H8 +BQMAEnUAAAoJEJcQuJvKV618bJgIAMb9Xiv8ps3quJ9ByHhbIQtBOymH0fFiodsutPrcR2Af +1lc/eh3Ik20Z9Ba3g5V6eUW+3sjpDsjKtI1CXuRq0Zgmze3hrUTMRmyrLoaHPocrqfj2G9mW +y2OomLHMDurcJFQkSUJioI4Kxo+1NBZmylPKUEeIEoP8UBJbKxf78dVh00ZUecwZcn9lLiZA +TycRQ0WTT1Yv1fI+tBmvSrpMSe+0k+JS+QigvINN5vUxaV1cN6mkREPYVm7oHzPCQ2C9NX1q +cI/Wkc38ieZw1Sv9vyPCCL6MYd/2t1209a/ZKADaw5l+mhyWUqIT6SXPLxMDy0NvPhTKdDr1 +7S5LOcKhwPqJASIEEAECAAwFAkK2pukFAwASdQAACgkQlxC4m8pXrXxvUQgAlfw6doD0JHtY +iN9uCp2M1orLKS/zm66e9eiYPJwbim96KiwP98Ti5J+QO5hZdT3dhW2Avw5JPFiQukSc/rjT +1YHRyuhZfXKhQhsjom5JmyFSdeIzjnz0PIM2qZaK4OfFihleQfQ8Y94wkPwYtkEXxpBQSClg +Xk6QJEql34sQexIDM7VsREwv/eIQ73RMquat4RZP1L3h4nj1UJu/X7ey3HVVo61gH0RIAR+A +adv59AAp//TkKUNIRCHOsIpFCXHjJsJxRvJKhiz3T6FhqFEQNF2tDJKHFV1FcLAIEZheuGOV +fKNXgmvVATPHrJsg5HsZACg/aRFq9NL9FYskFyGcB4kBIgQQAQIADAUCQrdR0QUDABJ1AAAK +CRCXELibyletfMNMB/49u9oQzbmTtmHaoKuvou7OA6zmrfeu5X9vV1efZgItF78J7G19fVt8 +K3e6kn0KGYVL+FTbPdEbvrYTb+jfMkzrHooxQYSr0j8Baqfh2bMuZzuw2pVtgBUTYHoihNjQ +lv6GPtF7Y3CVWLUYXZ25yqY3Hzh9YneoH8bUVFZWxRFitqGB+noFpvm0YXrCJZ19BDNTQlx7 +5quAl4KTNOAxapsKaBrz/4PrnNbuwZBkzP5EEuEyjTM+6UBhxibXfdWKnZw6ky7k6tuUsc68 +qfQJBK6KBmVLflZ5nrd2N90Ueb0m3xfzdncBAZb43THGhi6XyZ4jvbMjvjm3MCGuUosYYbT6 +iQEiBBABAgAMBQJCyQLdBQMAEnUAAAoJEJcQuJvKV618Jz0IAKstm2VX39p4Lt4k55ZdOqXG +CqHCFT5YYOVcnptx8dKTpHWQXpI2lUJBAcWz0IAXXFhyUbGpvS1E9T/pYF97RSSsQyTncQll +mLbzy3fESVkGT9xpEvF7ZaK+61BKuWFpbKRdpy5wWakk0GRyF0156vxm7vQh4XI91TwXj7DA +v6KYWdjnHcEB8O9jLw6RlD4Y6dKjb/v7vTY6dGmYYyOQVK+Bmr/8vVcNDf+tevExsytTu4FZ +tL9yp+yHODfHP5LZk3mC7UGR/mUKFDYhuEzzIU5ozc6qUfC5ViGt2Hjg45i2T79WeSV0UHSE +8c3JOgE3e7A71bQEUJygPC9S+RTuc8aJASIEEAECAAwFAkLMT3oFAwASdQAACgkQlxC4m8pX +rXwoBgf+MEjA/hx7UMl6LHwheZ9qzH/4P1d4CU46SzoC/XEPqWGs9sJw0dKxEAnRZgrG1WMP +Ml127bOHby5WWDa/xGi0siYM64F386SG0W42FD67vPK9mMPnCDIQ4xn5gGoqUUl8ZzFG0eNv +XRg0bmMVmoZFvaUyf0uah/0dYCYplgAjJtmC3cmNuJ98PoYEVHMKKGtPW4fVf+TcN90HVjXU +kr0GnAvRegb3ZXnte3GrOe3jOfXjfjZMyEM6a16FFuKHmykgfyX/I4tS9GqoxPZ6s0KARKn0 +YLZUuxxFL7i1VaGJR/9duyUc8T0BLc9O4TxNuvd1vd5UKVVmTL04fe0q1Bfu4okBIgQQAQIA +DAUCQtGX8QUDABJ1AAAKCRCXELibyletfNEoCACtKtfWhAfkxLqPihQMbvwXTuSszG61XNYb +a41gTOpjADF2jQAQ2y8oilVyr5RgSvug8knik3EitSpBOOg0o5Y9NHF3e+85r27m8T5cP3g5 +GHAeugRFDqMXXioiAw9WoyvG9ruMY4caD3gAuogM4hB/3EMEHSlMylMrXLUtbGkQKqkLVJQn +7V/3SVG8zfUyGb0lSFaGtHFa6LaIIuvJwkQYGMT/SiK7ISqPKOPD7kKRWhxjgcfzVthqGORn +uQGi+316fdA+JzEYOI/gGdcZsbN/KrMSNQ0DOdSRIeiATy9M0fd+8QtUPOCtaDKLYISSrm72 +xgnKbussJRxAPjxo66dPiQEiBBABAgAMBQJC42DIBQMAEnUAAAoJEJcQuJvKV6181SUIAL/P +gZhrwepyFUhr+nlYvxeflrxgR9Yl1aNtTngcOYlFU273cs3XnkczIpkg4fVikY5s56Y42G8F +NvqRu0M0eL5kJvYi50NNMQnf39GkZZp2LrL9bZ9n7ysWU5tiOJsxCBnaOiAg/p6vCUVN3NV+ +t8vRP1fHwPsd5tYEBqA/g4g1U0xJAG+JqJftSDRDLxfTZ16hBdHzlQ3opqMMmW5Mv005p4o+ +buh4HzQLmBHDE98BeZ7CpjYeXY23bu8oi0tvkcTjCEeBWrXWfA3pKSX5HH63nmG3ryKuP0tr +1A2gTgs9JtLXnGFJUdVYULiQbU781wR6+9o/0h6NuCJDPmJMNmmJASIEEAECAAwFAkLmBFIF +AwASdQAACgkQlxC4m8pXrXxYZwf/ah4IaTK3CbtqF1+4uz7VVRKemSaNg3jMKLey2simqAQs +1JwqkLuwEgrwF7XiejfLAvX0/yFqJZkdtDFqeK0VrwOq3WIpfj7+g5B9YSW0CkasD0HUci/l +oXQiT9CN7PAe1vM5X4X3cqlXfC9tmU7fH7kc0kULxYHAfn96nZQklZS9aVecJ0H+pqMlPoDt +xtxweNa7UJWAanO9kbPZ/xEdSlkuqzk1CK6ThURedc2lCE+qobPpUZri1FEvMBjyXoQ9MyD6 +AFWfax9eNn1ZSRq9t2WpPyFSQmCvyGETHyvM2BBiFR6UAQUKdr+d4ZE09cR0wXpEtoqaNeJ8 +AidTEGkuLYkBIgQQAQIADAUCQuydlwUDABJ1AAAKCRCXELibyletfLsbB/0X/Jafv+v43U26 +W3HD5XdmHaNdxm7uthGzGGzATGcTAUd3/t8fyVFk2XgmUYxtz0wHUdM8GiyK0tpKBu6wqcbO +nGkBlvC1m6Blxy+PvpJxQ2sK4ycN8ToEEn/7HCCJesS2fvDudXkvdvskXkxZprPWe7JTHNxj +fvESUAbLLmSpNGflZnMAOfuQP0hFBQr4D5FEA+zMf7FtrwkBanXt6W65xxEIJ/239ctCsRe8 +jIQ4LesYQN7hyX6x9bP9h3tEw6+OtvjYbMH+2B/3muNVac/9bYqi9rnuGew9eAjmdmm0u8T5 +7Iboy5mUDH2wjpRo6MGU1cHe4oZscW0f9TPE+6XbiQEiBBABAgAMBQJC7UXaBQMAEnUAAAoJ +EJcQuJvKV618zbcH/RlUtrZSBcUafmhY29s9BYycwWx/UoeJRIJmi852TguSGsoPuAYEGeaW +WxCdSru2ibn7GPBXowM5u+4MqYqaRB695sg/Ajxho2Djys3lV0TPeSIbyZ7cXbjoSDnSVw/N +eWGKJLwbFVZPjjC7mcGIMhE1NGGxyRO5H1Z6GA8dEP3zR0rIivklN8KEngfyLRVvB5WYPBs+ +buaNF5HflsBXl2bOP5ueThcal1PSE4HNoQXz79t0Cw7kpsWy3FyFUVVRHPyvwVpJSdYjz8Ur +L4cD3Dj9SOPwa4AvM7WX+JXbPEIFxi+NA4R0TVxIZXJ/HX8AZj87RFxGYlTfP3GFFw+52QaJ +ASIEEAECAAwFAkMHCEAFAwASdQAACgkQlxC4m8pXrXxGXQgAwFY5RYFHKcYkL9nDfblQDjXW +Ictj1rlP2yPsy8dKX579ejhdd8o0TGJf8AzYRaDEpffPf/ZvyfRltqKd979GzdAE3smkrGeD +kPuUY2rEF6Eon549Tn7omGYNueDuO27QQ4zIs0k9h4m+pE6PxPTgC5BsEVF8Hrz647/XSTf2 +G0Wo11y/KBWGJ9BYvZ1YSxwmk5zicGF4sYNktO1Yl6CGS1ugP9zitCuwSiUm+gJrMCZ3am/D ++Of+80Ui7e/V9yOOeyC7/gqQq4okPZbdVzJ3hiG2Y3eip19ewHYlYSiLoBW3rr3M3mKBTcbx ++nLfVOTUHp8HdqxIyI782SaZlpg0mYkBIgQQAQIADAUCQwhbTQUDABJ1AAAKCRCXELibylet +fD7WB/9ydWuVT1DeeL3UBqqeRRN+mt5DChdFeCjJhWcAjds8R6Z8Q9c+kpKEk+MeSevKaOAf +iiM2JBtruIxt1sfh/vVEFgjHP/M0sF1il6TwZEKqVn5c3ikMYCMXy75xheslCJoX7fi4jZut +TO8+JqjVN+z+SYzeRrvQFcjJoIOLRnshh2XgUiXVf/xo/My+fM9rKnMHxF/75PaFVVz8cXz1 +X3jsuUOVLxnUZHsOaP9r1h3bq8uHJxkxPElVPbCuKLdCWrNOHHX6/+TAH9xohUvrBm6HXqbv +O/aVGqf+Bip6oWSB6rSIe9+0GmXLRe4Ph3ekBvyGUJM/nFhN4hQHX69xZS7yiQEiBBABAgAM +BQJDEOyRBQMAEnUAAAoJEJcQuJvKV618IlwIAIPbWp20TBCnU0D3kE6JFqRaVKqNAFaJbmRn +48qxX10NmHnBAluU1iJiUsVL2kOpvf2eyFUsX+sQfVJPzmWkUU2gED/+WZNkcmxPZ72FtJCs +hW30BcJnLjcRo8wv/6nhdEZ2JYNiBIFHxNQ6iiB7BzVpYsMp1l5tI6mIhbxYxMNETTMrb+hK +NNAhxjrqiWxPNlrzw6TaKnBOE0Au/Asjz9n37hsPV5Q9xY3zXbff3yDirVkBC4l0Vc+U6drX +XiFBjQj77yt6AjTYUzBZY7UuGQ0W6o/6QF3KfiC3WAoFJL7SLujIaALkALs+lFzsu3CA9KoB +X8Ca4hA7kzOP1H76VZKJASIEEAECAAwFAkMSPXoFAwASdQAACgkQlxC4m8pXrXx3cQf9GBPO +XIrdbvUWIKTofiwftiy6j3MhKOszHkzR9quCu6aLu/aVvIA/avTZHjfj0EvYaQaSNMWplMiX +i2UhkPHe4cgJYkbjmXEz16GtXYPZXGP1FubQ/RwQ7yQKaVtXSCgz+ZdR5tKhU5kruxAsVjly +KcQvST95wlqxLuvXzSCjPdWj4qBvkuEt6QADx8EYCafraIiHPRkKtAAiK0sXJSkLevXn3zAN +6X6ngvZZiNQFvfWLFV8Rodz1vI4S6Af2MTSlVV9Vw0voJGprcsNDlB8k5B/Kl9LigeKdkFa8 +JVfwOQppAtU+Nq3pHjquEafZrPVF9HWY0G0Szh5tOFEpVMF6g4kBIgQQAQIADAUCQxQ7iwUD +ABJ1AAAKCRCXELibyletfBVfB/9ydVsiBrNWLt0RwbAdMvHRceHz1twh+YeSnpr9Equ7aDMG +qou4ppl/nTbnZIizdWn3dnRKt+vKY/puuPIT9kEVF7DlfBOcWBdLBvJz34eBt29BCFgvsfOS +fwESMNKgquZmrraGpEvj4cSTOmW3DJPevB+6ajsN87BC5Qp2MjDGVkwT/Nj6R60pz/vmeSwl +0BmzgthrBd+NfHSA116HEAF1V21/2UhA1hbkPKe40jWp6HK+GcXDC3+PucTJeS8nX4LLQnWZ +JCr1QUbkaW6jHCw7i/pgCLfqBBdIh7xJE7d+6mut1AKtq2qUSpEM4qTvrR89DLz3OtNiMnr9 +hq7s5SyduQINBDnKLe0QCACUXlS4TkpEZZP06rJ2IVWZ2v7ZSPkLXjDRcC8h6ESQeZdBOSbd +dciiWYiHtGq2kyx+eoltwooP7EgJ9m35wn0FGV+5hpKbhSwz2Up9oYsSbexjx/hlopUYGCL4 +kgezCUWQsKypsitJChjV8MHgePDQcF3ho+qK+0ZJeevbYKSZ9bLyzt/i3/b3Jnt0f8tsFP3P +djel4N76DyQiTyuoOxzZJUJDKx1zr745PUMGcur79oAxuahUfPcRpuwcHFOB0yO7SwEY8fe2 +68U5/AZrGwX+UAZhN7y2MMkU/xK/4BIDY5/W4NY3EX2APAYMRanI+mFW3idui8EEzpzKZ1K1 +8RODAAMFCACOAfgCjg7cgjZe58k0lAV0SANrJbMqgAT1M7v4f5mOf5e3B4si9z8Mk1hx5cRX +I3dDz/W4LPh8eONmMPjov42NOz8z84PksQBbnjlfZ5UCotPS2fZ2actJPhYCho+a4iXwRm8B +aXQ3DFa1CsWdXvkGsNIouuSkGoGh6+sEgAdP6JXanM9YGTQINy9Xsg9YOj1UWInSwRqUmJnj +aNQhxJfj8j5W0uXixzkbKB+Is92mfo8Km3TAi9u0Ge/Acb5Cz0c5sqs+oWqcouaTS3o8/1n6 +CZVmvcHyGI0APiALwU84z7YT9srpXHrjiHo2oS3M4sLxl0nuSFqD6uiIFrg7yF+HiEYEGBEC +AAYFAjnKLe0ACgkQ3uyMCd5BWw6XgQCg7Gu7XOzqnEcnCYR7v6rub5d0zwwAoOsQ9TNDYmVl +nW1ff9rt1YcTH9LiiE4EGBECAAYFAjnKLe0AEgkQ3uyMCd5BWw4HZUdQRwABAZeBAKDsa7tc +7OqcRycJhHu/qu5vl3TPDACg6xD1M0NiZWWdbV9/2u3VhxMf0uI= +=oXxa +-----END PGP PUBLIC KEY BLOCK----- +") + +;; Bug solved 2005-04-07: +;; Try importing the attached key file. As the key is exactly 8192 +;; bytes long, radix64_read is called twice - the first time to read +;; the 8192 bytes, and then once again, to handle the pad '=' on the +;; last four character radix64 block '0uI='. gpg bails out with +;; gpg: [don't know]: invalid packet (ctb=2d) +;; On a read for only the = sign, radix64_read returns -1 for EOF. +;; This causes the iobuf code to pop the armor filter and thus the next +;; byte read is the '-' from the END header line, causing an error. +(info "Checking armored_key_8192") +(pipe:do + (pipe:echo armored_key_8192) + (pipe:gpg '(--import))) + +(define nopad_armored_msg "-----BEGIN PGP MESSAGE----- +Version: GnuPG v1.4.11-svn5139 (GNU/Linux) + +hQEOA2rm1+5GqHH4EAQAi8xXorNRK4QSZR1os2xtbVeZg5pI0hrdyejn0jSnlWmw +wqnhQnoOXsX/ZE8Sq0deOJDKhIJztVcu4QB17R0zRxXhN+huXq/DRGUa3X2xF+Po +4bP1XsZT6jYc6RDiN8KzQkuUgEjGsQhEYzBMFgk+tFDDA6PYKRk2mn0UaTyR6NUD +/jimx1teliNBMhrPQjbBMCdgczfUhH0srGFKovkduf+Fmn0v4rV3JAhtHPYaPrgY +hQtCMdjgCdh3uMK6rbprGdQ2lh4PAFKd25djBJlf8KBqkJXimAYhe5Y1q/x58xbA +R5/tAKZFKT+ooU9qjVzXA0APHBwV50/K76Rsxo0QQOTihQEMA7WIRff0Cc1UAQf+ +MZ5HWEX6+2teJWGVKMmJBFkYF4rAEIoqEmtzRWcsAPx6PFXQt5Ok3PbSGDgOsQTQ +XwR5bEmZ6Gd/O2xIM4BnwKQ/g6PxksPuni0ajZS5YWdoGY7ZTS1LpZMFj++fhtQ9 +1hd8j+i4P+GA2+4TUxVVFwIbHDT58+mw+tYD0KDfizdSwVc22F+5nT1tLaKJVvmu +VX5L9u8OY6kR/xP09uCq+YzzHt1bi49Avrq9PpV2wbo2P0t7H+3bI92oGvpMPM2L +ONAXyh11dlQkIrOiVztWtTYIfoCsV7Ud+25V+jYEfd9hyE0gf4awgqhpLwPrzzAs +aHKQwrjlMaByKKht2teMJNLtARZ+7LbxgF0TR/019x4+XHCBhmwmPzL+OnPTC1r7 +fdB0kte5OefTUfglJyz9tD9QnrvCvuOmKxcsOu0C6NLUqZRJN9knhLBZyXbwx/Cm +yA60Er2dGssL7e4pa+qW2O/xJRL1IaWpgZa6Ne89ut25hbEDWexCAikBnPUrwrLE +sqWOepzPNGxUILOcjDV2jKq0t7XKfwj6UPoCQxY6FQpx/0goWllh+PuVLz7tazsM +c01KGfU61j5EyyuytOkJO2XgyXZj6Zat194NgsMrNGBBWl5QSGUb5W0jW1bHm0Cr +U+xNTvjnlVZzqy8w3GDr2bCWi6qJs20TrbsbDa4+sK9+WDJ2fcb6LzfTGOekbvyc +OKyYcEL/UXMH0uYrReRiH/gheESZqyQ1kCz+/q01D0N0KBqj6LHCJyK6cOukrY5M +Cd+Kdk2gPL5VP0FSVJLoFXfbfwQtjIkbhsP06sFOBszPhd8bh+/r+RKWaqQvHJDX +u5XqE/lJfBpNd+NBPK1p1fMVW/ljj3EwsJCdYOxh2moXD7gcehbaHCN/pFxD2Xiu +wFHAqTghAtge4DuIECN+8QrE6xgCnwx1TYlhd9T4f+OqTcn/RdSrGcR/TtQK7TJY +R2zVvj7vougCx5avrNwmJNX2DiJJl/nDHmjzEFByFv+UvL1PUn4m0dsbyx8alixE +dw4wl352n/ZpjIc7GdLeusuUPJ7xFY3r1xS16QuInhuj+ZIlPVVeo1vI29BxGP7n +HH9JmewN57O8xztGeBSMb5dZCSsGaiZtT7TdF2C+r6NgwcULzpgANVMVjNt0U305 +ZhTf0FxH1LFTDd6IH1ry3EABCRQX+NDi78m9082QJPw0u46P6fchF2xW8MlJHa0W +u+G0+DNrHXUFZBxt0yG7YqWYzqezXX/9ngin/W0o3Myf7RdHxmlwSm7fUuz2nYTn +0gpJqmu1MdDN5wKxuIO3qMOoG8LGJwnR31sDo9BG+8Hpp+yxYMEMMpmW33otfYcq +Qqt7L5kWYDrQb0jGr52hS8fBujYi58AY++a/RqddFkU4c3kgA11A2GNqsbtxw7rU +jN1uqPs2bQA2HqEdlL2ZD71E8jZXztKxMIHyXbJuIEt3GOywJWeHNi2vZa2F4tIw +bEy12FJXLW/6Dac7COzqVILjNH45S37JRQCc/0kAJV1VWMyhuPBU2LoPwMhdXiDm +k2vznYlm2cEuvFL/6DRm32Dd/YaA0fw3S/L7nFyuA2FVJjs17XiIRdUemxXt1kC0 +1KPjNVekwJph2YE8GMyyV4nsuf5yGw0wJkXqRYR72Cf8mgxc6rPIS0panSWlAl1x +5TMf9pEh0TUkNENAbxFazsfpG1RTEVzjpeLXrDSK84O3WW0jUHoG3IyP5iVli3g+ +/HPmOdd6+hBVZq11BcA97xnozZE0d0zFCVkpp2bcK/69X9NC/Cl9FTI0DzdoWMVL +XTwmOV9BYsXAjJLXAfQR2eDrunaNkZO+rr3KT0/TtqhpcCo2AdP2IPglVRcYGLlr +SUoF/sAtUgFLGnVnURrkAnKamSs7KBx6J4Y4uiBUqMxX6L4T456FBxHHMQNy7cQB +quyVixd21NB+P8GYdwb+KLpVjiQRdveqDjBJEn/nTK1yKAhq7SY8B6StVgbzPcmQ +Pt52HkVTh8a45gxvF8qGWcbhw1E9rwVT6yPFJXQiR/4ciEFFEfqQkYzNz7wVstqe +R0Uf/rqwBdUCDpPzMPgl9OPKFMHNJ2tfYYU4kzfzdxBb6aKJbOX8xkxrhmktyUaE +Ap4b2gngCenXf/1zrVoyH8+KOQPZZXlnUK1HfIERZwh2JlmowLvobMlup5zL/+s3 +kRsnxRLbJqn0tYYYFwKsGbEqHZUpzbWR6TKNsJvoRlcgOKbAqel8ggFXiSc4co/f +VZqk2IPzaQCkTyAU+B5Fl29bTfB4LK9gvZlY63y/VFD2bEBVk36pI9M7CokAr+00 +KvAKEzpmSXN4RHKwJ0W1gZz4IGPKvi3eO6a35wd47K2tIS5K3IfTjsIsUM+agh37 +7xJiJByfKgA7ardssI1xeG46U2iIBvdUNeQe4Q2ODF4AjxczK3hJwBPg55FGkhll +dIDa07ZsOTB23LpoCejKi4zzn5DsDNqQLaYaSP0Cud6DOuSsmUFHSHSo+NtzqEQG +rm2o1LkZwQ85iDf1A3b/pzHBf2xhxEEdtMZ2yfWxPJvz+8hsasysqPD8BTJIy0jn +NzmXJKTj8ll9IhQjr3UBCZZXWUPNbrl3zKGUTQMXbdUIV6cB6hjLERILhgm2VhKR +eEOFMaqATMKnGETa03l6wDhWDyj7HbgzgKkveHJ5PDFKz+RJ3sIwgKD4LoSOYtZr +MGuHzMtiFSx+42ZitFm28G6rzj7NUVA+FHvlkogLWCfrXkNyEp0F3D/qbg3S8WS3 +WrdUbLwbjFRSHgkdIUA4yIjCSmRzupfpvXS3UZPFD/tLZicU0ogfVL/2KK5WLYW2 +03q6egJXqYX1iQSOTXwx+Msw9zVzwcAI8j7KKDLVv0fLWXSMOg2ondmznb3s0Y91 +iaYjf7iFhuGH0hk0rTc6+CkxUhet2GeBc51G5XuLt7+Pgml8k7bZHU8kOB6etEP2 +i++7b6uCAhBW3o6shyoRgJNYJmzYbThfIx3yu+3vl1gkSxSQFo4RpEmk8VtjUsio +tYJNRsAq79wGsyLuPwLKPkPihjGEf488A2NKuVnHB7051oU9hWbRGCVhzdOnD04Q +HKzZVjt2HyI0v1sY/Nq3BqVH1Ha1CkmySYeeKXRgVQfD6RIzfd3Dgr34+rZqF3qD +MXna3FeH2W22dbZH/yA+KuQEjU+uOOk8QQsqXorunuyuslrOmGzaDPILW8zJeV+v +tBeecStyR4FdtWl1KH7YTdFDkeGKOQeBAKYpyYUKr3s1grPh6caqgF1FMNL3Qw+s +x4d0zp9efHkGqhp1az97oNFBzGmsBD759iPu44QaElulO3OAPyn2GYZA3NhnFX7Q +uGtFLSexLpVTlVyBHf/QeGJk2lkDuOegiAkW81lorVF0+gFFae/HIOnEZgVK0/Nu +h8XNFvGd7iKlNhfLtRbKPqHYOtxxGC7gpuSa/M4kgvTmN78QonKjZPDxhlDhYE19 +WOHq14t60lZopVLY1bQREvem1K/RmPk8lak+uf/Fa+UqZ5C33m6kmbM8rwYmuSs5 +Y3M3mR2n4tsTrXEO1AN1vShuIJoMEJ0ledDJiWKkLHRZ/SJOBLYMM+F3/hliWB47 +eNkfQgo9JaTiNs9SBVVcxWYEGUieAZjOekD74oN9nOLVaXS82kQostloXhPHvBG3 +gKQufi48gOj1i7REcTyhQMhIXa/NQ80aKZEedH+qQvYTTNGe1XIJnRILyQfirtgX +2m7PTaup+psJEOP/+Yf07G5KzN3wtBIXi3Avlr39ihdbuORERUNvu6kR2psvlXdQ +otIijpBJW3Ur5yTpnTUo7chSlWFzbmVYv2cyXPrQc06RSxzrIQFjyTKI1/Pf6Aax +wA7Uep62ga5r3IuR26XfaxunphrmFwb47EiFYP6JaNCYW7x5y4OGl8w1OYmabhwP +azJsUAAem/lXZpPjx3s9meC48fHpuM5N9myIuRlLN1Rtl7EIG8cuZuubi+VUEhWD +byap1IYIFZjWnS22/yuw6pzyNk5Mr5ccyo5xxvg1ZyC5rondGCcm1egSDcrHXQsE +pR+jKBcR5AUKBhrgSy+N4HHZvsah+eNnTIZIm2Hh92vTLZZF7u3lW3mlePp4/zAt +VMbn09ET1qWaIl9xMuHDIfIsSXMLsj4+o8qKaxipQ2sjFjnsFGIK1cAjjptpoUYU +CffDWoBnLGkFSVTTooOQHuQhUmqaIv2pXWid/f1smPUjkshLoWiPoVl9lLzvo/XH +NhoJ159/qczMsiosx3Y6e/haFlIfrklSklJCO+j4N/PYW+vyqYg/O6FlWF3BPRhp +qnKwe+KfUeAyXQKG5CkONWBmUAhuLWOLU1P5280iAKHnOe3YRxkGIpsFJlIA9dIX +Lf8KW9zFYMS5J1xysSyYtCwUfa/ewpRY+KuLAH/3wSbxViuhwJ1aoS2N6m8hkTqy +SODnP5Nz/n/EZi3wWesBnz8oqBdrwkOWRnfFORpRkAedcsd9XYCbF1dHozHBdY8Y +uu8N91ob/5c4RmP08Q5ama/BjaxskdMH3tw7kW/7r9tpzS7a2SLLzbDnyycZjknV +tPr/xi2bmXHkUNnFwsTL0qvIkcZpae3k2oTwgNrjczqIdYGynflOc/gqxVeBO8gk +t7mqZ5sCOlhqPkf+/1EY9kVwS0lh84yV2SskkuhEOF5BZP7IgNTgeZlgTwYRsGZq +R40pWhW2iuAWfHop7NkrIWRvtyVtVtzwqtTLOs4oNrZU6f8xh+1asPdLqp48h53N +wwS3AduoX31189s/ZnYUR74dfYcf3JehKyBTsfPfq+8rHf/LOHc831bavHQ4ncnW +f//8T5Xipbjo+WX6LQxr9NnCIkZaJ4cjET+SBvEf2YGRjtG+3jGmWdgAkZLhWJFp +xqhhOorpOFItwHiYIqsy6WEcEf2hEAww7NnC1qNmglDXw2ou2WOk/WDL+Oya9ANY +1HAaYrNmyjZ45GXvt9/ISzeiFaClgetu/zmJTe0IG7qxuOsd0MG8DugeFwUDZQrq +rrVL4U6Z9MZLQl/DAYppnxSmne8vQfwHQqRXoazaIxAh3/uWh/w220YuSIHJt8Cm +a6J0w6YlQtBmaeY22/rbiOJLqAMtBDC4cCAp8nSuxZKdVTpJA7axQee6lWTzan5q +WVyvyIkqq/4iuU+WLDtHV441cgnYENyZ/T6jrHwrX1AYIv8d2Bi179JVa0OKO7di +axMS+65agfbswB1wKRU1QYin1sDQUMPjGbEtP0reyAFwpBlmA38rIg3j4xr1nm8p +MkdCKOdqZw2ppWDTLFqqM6iUpTiOUZLzC80si8C0VYkTCZkCRze9QTAD3cdfITZZ +huiHO3K4pS/6ao4QJtr78B4yyUMST8isRibuvqxQYaEIgO7DkFjD0Vh815jkydXB +Mag8MjSydC3MuAYFtruOm0H2OtoBsY8YBbeQXeC04U49P0ktYYI7MNsShhfFxRtR +kXV/PldGwhF3egUjSjk5UBiZEUDw39PMiWy6k/uM1KiT6AewNryw6j5SqqzeWynh +MWAqxK2oIV+zhoR8EaX1sIZ3LtPeDi61GIaeKhnv88FhDQDX+pjm6I2qKgXhnYxr +TI8YqfbGXGpCZWk13AL6CyYqSzcLeJYKInETPbmZ0D/eA00dKvDUcHnt4UEpuVHq +XUHETJR1OEF/xNF2DyXBja1+B8fGfChRMjmk2J3YjmIcg1m6svC5r3Cti7WpbKIs +qldz+u5QKRbAbj+izAd9PEHbJ7azMlFHyL1W69VkO9C2u3qYF3Kx4diDAQFVGisv +6wVaT7kZod6Yn3dkv19EicvCnfyq1vE511OExvi75E01iznFRjdXIjCOpcsbVsnS +vbdCo+TnLi01Fg7c4Bp50VMxZOKwvY083cxbR+csrf8z0TyfuaxPsy4YiLhv7SMU +5D5f85TSgP1j1Gqy2vCqqh5iegpi9+JhO2efZGFTZTyuCsGiIzC9CyQ7BUPHTz12 +nvFa0pYNUjFHJD0FN8qVMVVOgl2SWldRaRD77FbcLsyiS19dFgnvbxXtEdW5OPD/ +AdxCM5PtrJymOijry6jKs7oU/9jZJMw1sooVjcX9Xo9e5HWRqawTAe24nhwzlSRT +3GLcU/jTOmsjq3NLbzzC0VQb6/nqkN5t4f3JJj6jzRo/1lxKhHB4c+/CgVtQ3GPi +aCjiyDt3qey29K5lMNmo+dIMtIh6Sf4klKSOlh3oT0XgM1WNNeJdFt6v344vxOrq +/jw3tSMx9vRMDv52bdtCzzcfkVlSYLPlhS9ErBjaICVWqfaFJMzD2euHmau0RuPV +S96FiHJfc4t0Lgb75bwIXA6a0SSS/JrDRUynBr3kmSUDJs67i3ULJ1rMV553K/3g +xOBRT3t+gAYbl+5Dfu1+btu1MkmpVA1duQYcVxO/Mw2asc/kvXA+rGrs3FsScGmD +Kr/1yLfXvM+p0bYlkCfVoOVEqfU83t1+5Hxp3PlqYwzxlBPx4rgofnDRyeLGtu7j ++1rZ8m1W/lndkJVf445LqcXWJy8c9V476LXpoRL5oNAQkEERDK5NHS45TP7cYFId +0xuLwCQQ5hh3cBw+oBSqRZmjiEuxSArhBaw93S5SM96dXhoAmXEiipNbIXO53pqa +jFeb2kVctAeNhupsUMql4nocwUYWyi0bMBzJH4eUakgBShxJjtAD+k2SEFk+nCVL +76fVSxUwmpdqOTSMNo/L0CpG3zHU+CflPBnmSXFyTgZD9F2FJCUBWWdKst4bHq0T +qoL4Y5Wqj6YK8QtZecrqigrayOk+CEM02C6nhyM7Hdt8sWSPtpWGkF85Ksz9RCxF +QnfIQImjM9Qt6Hd7c8EOxpgdZufvD10vlELH8O5U+TimCoCaViiTcH7p9BziOI4b +18d9bgXkj6GZmS5uOSBsMIF+uZjKQxyMgwzAaEYHA+vlKPS15rDDtlDNGWDHfNik +hj7b/FesKCBCdqYpxKWmcHgX4aN7MNMTy+HroF/XVAPGzxGAnMS6oFahb4C/o4be +T8k1mGhTlTQRWMi3VI9LrXoP1MsH8LwbaPSnSo80X5sbgZmSlctu5QiSaFm0kYc4 +HxMR9fJzxZyuXM/IbXSdlYCc04xwNO7hrF2n2HI4x5BR7fWZSl/E2yfpxwdBtcBf +l2amxpmIjusGprhGCI860vpQxfyWyTfWNdMX+OFL+Jsgog6Qm8A6bSaNTs35Dkf9 +TjvTPS3wUPwDbTuk9++zPiKt5h85IOFaFzyjC/u+C38IvNmvUUcYLha8GEVz4OnA +KT7FrOizC7pdyrqbCIJhoZsOzk8romND67wXfgIWZXYMU1b2K81jIFSvkVwrXT9w +56vollH0x8YJD9xC3U8QcMDnK3FwuOrlGxHY8BfNszCV/OXpT0qlBVC/gywaq993 +YJoQOWugT4CWpmSqnRLjTV3gJTHH+qqQZ23TsoVE9WoByXj/yb14FtdRq9oGL8H4 +Ke03JNOkAlwzohG0XEsoHLC9+o5x6KT37OtLuds2bYV+PzSRVLJjsqNL3C5XSp/a +nfXTim+6VIANM25jzxfCcot+VBz13fhwnaY3Am78ZEjQVmJn+Z4DbWIIIc6XGtBG +eNydm9WNcZ2jF64aMN62DBp3RGqgnhE/qXTv/Sw0l9qiOCeWJ5GwqU+Bj08D4/6y +6xBaaWHcPqCNuyk7pPG/tN59GVUP/jHEX77Z2kn6RiLbnKahcekaifolgBuhgiw1 +/c0fbWmJZVCUVhVPI7fHTAaUIO/VrK878WkSUWL5dRvjXp1yCvAxeYffsdwamPyQ +R67h7sHAPPtYs9XpIjZxTzGF0YDFc+mpfYykLvc5ixrcuHGo3Km/hzdjVRhcCydM +CexKFEHqI97u0Bz5aNW3tOE4iTeNth80tl2rV2PsJoK6FRkdGgFGdIsHZkhy3lsG +GwGcp4bmAawGB/MmjnIQRPeVaSobJSln0BgP/j77h+pe+eTswwxBeCh90umeE9sd +dFfKQNzuZvd5heYwzbLTwlWbNn8wnB/nh/Jh4O6w3db6WDi8Yl54mt1OSFNVjT9b +1rM0CfUDFDk+Jzd3fwY5QQDy+Dy8oPm0lm0xCj7mrzmlVGP5JmLCvPiJUTPuybdr +WlBJe9T3Hyi5xkYgl9P6Itxho+qHEMUYa3ScBBC8Tvl7y91Gp26CIfR5pQxkLKmh +KI2wYSHF9fytr5F6imJ6kTocxq8T6UvVgXi61pWScjifnQdQBYtNcsmu6F2djNAF +RIunpWxbcq9b1nuQaMx6aQhYTMnau/ApeW6Y4bbVwUHyHCWMwy4TiE1ifFrvOYzQ +Ph3WPsfDJ7dfvHfN7/Vr/qF3mcORScAfkWa2yhVitoBnBMJ9fM+q6Qrxulp8xOqH +0UwdTA/FSaIApZbIHVO5xquLVXDD8Hoene6GWz+wep/oUqXc2k1wl/8XbhKlS29z +N6vJZ5zVJqLSWWyHceh9L1fd6ycHaNeYkPSAGBA5IluJfm0NsQHGW6LyGkkpnFVp +mmB+crDof/RHYDU/ep3I+BP27yTFw+j4vgELB6XN689kE2dWetrINmemwilaFoNd +eDmVpKbQR3J3WD9WNTseI2OJtZn/E+W8mzRkp3G54nGVq94nMYqxCMFHSGQm78iW +CLqjp0uNPM1NUdAH9Y5jaWF7NzBQGh5H3KLqvn95ynwMbWeFEZ9tzjLoIO3u3qzJ +eBlhnrM7JnwG/8XYatKQ4JaLteyTdYrlENwmQa0d41kuWiZYGGar4Jwqqf/Ma26V +UR+IXP39j9agKLjzDDJJgt5Z0rknEWy8wQMhIY6WiKYpYGH4c9zrYtdzwRU7+w1I +h85xbqgPMTSVlmRlgn81vpljz61Tw2hkb1sUB2uqgas7nwUod2+eiZWBOKDl3awq +u6kwgp94M0opu9t5xx5oJeb+WdQd1nWo/5E3Pdp1hNPwFpqW0TjMgAtQHmXy3r0r +sI4pjs5PS6JZ05D5+WR3GA5KDA1cCMq3kBDNhsxqUeKkM2BNuq/J/qQL1pyXjlwr +4dqR7r49Op0PDIkkl5BEUOXLjLgwAN+TRMhu52vdM9V1jTBFG1hGFd4M7+4jOviy +jaPsJyzrhvL0tkvxpq5eQUJRqMqqqrJd16UmJZef/xhYFuu+p6sr4oNtE+JxuOmE +JgaC8I2HM6mIBq3VV4heR0CZUzP1WYk/iv+Z8WmYMTa2AVBbgwHlUK2fhLci8uPp +tEsLiwyWubB4elo2VLxvgXPaBROuzqANnGSeFM9B2XZoGejAVsDRk9/cfzHunHcv +is98xkuq9JRtWPdNIXgKVIvP0GuuDP1CNhdWR7XULqMZbZmq6UWsUwRWfPBZ9NM6 +rag4I+gpwnHPHAK3yBe40bgw9J9pSJVClNkH2RLoA4t7V2atSQOatLTP2JictUD1 +2R9kaeRdQ0XHbRe5QnvrByFy1noidLgyv2PXbZMHW+1OyGKMfY3eKa4/k/Wmgw+Z +QUaomeAVqguCRQB/8QBv7f1fLJu+ZqhjhQXZoTk0MdDro40fTI5wxxg/yV25sw42 +McPy8dR14mKAXocHpYhP792wVhemaBPZC17LXt95xLvfAOLDz/ORalrUHdhwUtZu +VKzQcxFhVp4aOCYR8gFgMKYNwX5E7I0ixfoTKf099fqwsAvKlOCqnoOuzFnRPrui +XNg3CkWkJqZG4UgLE9mL0l4CAZ2J9kbleN+4YMLQUXFvlk74Qial8hE0QBIdCCyu +6huelLEGsUZd+c+VsEQRUfq9sVUONGcIt9LQGFb/IYQoko87E1RThq2b5D+R1R4v +AWMIJGit1k0F3SxYdeUEYTCqpUddXtjhjSUGbzikMU/PbmyZXFu5PHMK6L8MVoWL +ZQ2TwphlVTo/gVz7dvW7KeZinnHB1BE2EOoSfhRukO2ckRH+bzuwC76xczosPLGn +LnYQFLqpYBDN1uCrvoyaV4S0xhgHsfl7kyPVdoqDcoVJSik8uKu6KSCUUyUbrrjg +lANey8pArBpI7x9BREUnGWNwZS6s5O9giMI58xljBm9wvu91fqGdga3qrv1QMgQg +Hytb/q+OAgQaQ1wIJpZbKliWz8uqPk41fsDy6ZKOO6UXYwjOg822Wwj7xSpbSRf/ +lhegSXgfihyeEeeWeMTLDWI+N2zuj16zZSCyQHqaDS+vCkMkAXUtJx5Ia3maBHAK +m1UMTJD6pP99zIqum5/QK4QKEk4rIvYtO0nTOW3L9fos2a6Cc2FouFon0Sbz2+IT +fVM7zO7RBwI+xSyDmV1nc8C5VyKxUlAAcuqVKEe9YnG5pwv3ogPKQZ0TqSp8zUCO +YOxHkG4F1kxAXHdrVarP+BYQuYIru1ZFovUQ5vYnl/8F3/7cuD7opnO5hKBr0tvD +6lM2PvPpIzlOVDiNZSZDHOfmYWWVlq4uzzuP8tG3tLyYBGG/AZuDTA7WNrOGTSSB +ZP9FVxvNT3kaxGHmjO7lGA1FtjRmkMJr05EWMHHvatvRcDFBVR1thxLkyfneSWs2 +orwnAqkYe8Fz9U8p38L4UC+J+2EZszHAeSO+eW3jrqZuFYbckROdzhktdUsRZcdL +WFpDIN5zINOo13q2Ei/nG2kIlYKp6Mq0b+wN4x/ILkBWnOuzKXOY6dSrRr4y/zq1 +dpr4ZfQezvsLNh8zjMolwXYdLj32Rg8cgmq6bPWIm0k9Qbln9HCBTO5VihgUfvIe +edpOxvSi+HpgIGnGl1M/w62z9HnZBCIcgZS4Z3EPvi7CWQg4S1aOABj/mri/RBh4 +k2vx1D0EQX5gBRcbgIGdyFyiRT4cAdPiXyje4zLIl0XT+v3/+LJnX7NPWXLPSOM4 +Skq+fDvzrFQYdZ7yefdxIujVKdI3iuo9dWTwITApf/KYop/M4vb5CJfa12Sig+VA +k8wdIDwXkklbOvpe468KAtTdUyoluuoROH0hXNaypKHBLMHk0JJRVB9OxBlIdQSs +jEoUZqQF4Kll7vHSC2sDeYfwiuBp5qZRPet+ew0SdwZfVmXcvjVKr8iPJEtr07Wj +CtyMi2+yw4G4X99em2JJu728dI4OWPUeyuR4x3dRf1fM5OshgLYxEJl0CMDqKVr6 +GqJ/HAhj7lLQ9k4NOLn/RgKt65jXrjEJB+IHFFitqGu9qLKM8QkMAAKwBfsRyJiZ +2e7aMj3w51DrifRL7uq8WZdP+RzvNb81WItRtVBQecHnPHrZI9Hwq7guxlzZTOT1 +lmUYNC48LVuq+aZsaD5i6MmT0hXCTC8GC4W+KAAqM1ZkHi8sV9zztWD0YCxmvjpi +ldx0MTVU8dqySwvBFK0faO31pG1rf8qGVN99Ys/pY4OWGcnbDwGblWhhYlJYZ8uZ +7IHt+0Zh3hpVWtOAttwifKXM6bGRX83O1FVExJhXkjg3zrklxNv+3baMHKrZFryi +uDtE3LLbc5ypK1Afp5oenYpUiQwUeJ0fGYH2NT1fEc8UCRqmvcJGSc/MmBiWRMQN +Iz83mOJ1sP3e0dbbXr4ZcCDf+RLKZRS8AH1zRp1FoBUIhyu4HVOs1C9YBmpaUGyX +t/c2O+1Slh7bpAKQnguBqIno6O7XB9rZrs/PXezDv/03CU5lQkYqai8SZck1LrhE +Ta3ak+EV76QfHTQm0DiVFIMD7IaXAjyYdm6nCDxZkLN+Ir/neEC10UzcWHqNIdKe +o2ao5YePZFY/WW0HicTH62MJDZFvgppWZSxx00IktHmTsILKgHkGgBgMvLTkRX+H +DdAzqFYNeewOnF2m4U3Z8R2pt3/m63p3sMSYsHnpK3OKjI0trrRJHuFjgTDAwhVm +xMimLL/8SnVJW+KtjZ+XazD0hMvBC2GzcrYr4h66iVOZI1tsFE44BAlh9LW7h0D6 +FRRkZkbipDpv5uiKoOr6qrhjf4/2NxCdkYI36cAfU2czuPPZ7OoHkLniBbUuKavc +n45Mn8tkq0qaCfUns46OUCc4qyBb3igBKVLlDlhP6gjNNdYKNaRKsQ09bs7TUk+d +fJupU57YoatfskkG/RPhJebLSuuvh5+Z966ZTfGSVVIOFPDdACv/S6lJN8DiD7H1 +8b+bAVMdVcXn/egeKvsNuWovYZU4DPVdOLM0E5wGGCmqyt1ygFSaUcoFVFiYfnAB +FkIxxBOtp67dLSazZDRRcsJRLroZ0AQRl7x9zN8Z5E/OxvQtiv2C/evhntVm2Tjr +wdJlwPysZfKqjnccXkM5pkoMN3/vrNVjCGMYrCRz2AOPNVHrTr0Hm7TAFJ6QQOPk +xITHOlIHEBGg1T1ZI3gwSyl9WLlGRp5vyQ+rdef4zg1ycDIj7sxFA2nzBsUBm5Xd +SgYzbnp32Nir9MSr7pHy5XFPCKVzs0R3GqfAjGQlyt9Xuxau52u194n386tockI7 +iOe2u7DPjqVXcS9Z6lNFO0o6H27F2x+dicSeHXBoWU6DBxvvjWtHG5E/9blp7zCF +weP5dMmB3UzuL3DcIFprNGJt9kEqmN80eWQRn6H3X/IzNWjLT52AT6pKS1sowOsj +RztQ2qAJ5md7Uz7fTniUtjp831SmxvUx49Sh7XYfNEpqjyY9VizByKPOUdUKmoXr +fgXIfsi6yLYkoR/g34dh2JsKrC1bVtC2AiRVAgtcBDN1zFm5hiQGztq7D/aXzr09 +q9szvRnXUat9iAJjCPsfjVJ6k4YjpmQ3iX2Kz+JHHNBYD7EAW89GhTSqJJB0viM8 +3lhxgxZgxnBz8ymwhKsyu1GKzJCv3cmvTqhlHo5xpn1YMFU7ea5xm5XkYKysWhq5 +w1dSMKhuvA0dNau3XTef7M0AI8iWIXdM70447qn2Gwp0bO7f2KZVtXoYMzr51CaP +QoAEL6FfwULtruriOK26YhmH1F1ey31xgjE0eTbxW6AFLEvYQ0OX0PmjX1/OBW1x +sVil7+beskMwIJpRPlsx1LUc8uojLnaD2j0ymqkxCuF9G/WkX1nlyi1s/SJpqAbF +EzXkwj+4B1wM/c6fHfxyt0wxzaTNoZi/omqG6PdXmJDnNF3DlWs5LpHQOsKKKXSh +2Uv4055evCC9R60LgC/xONXYB4zHTlmeBNnZO9lwcT1AdQ3Ho0h7TnqFm4IBnVva +f5DZ5ntxLyygAdRLLHR2rQ3SN1Ms4rX3CtfMGvISX14CYu9U7WaHtL1XLbfw7Q2e +z+wf0xE2zq/cO2161rUUQ7eq4XmF/qYreQ0nBT29ell6wE0540ncv8FAOO3dWK66 +4PrGQJFY8qgZ8B9wmTuHUBvTZ6du3KI1LYGOS5yIktfFX+0UWK+kPRQnLt/ibzID +n1FoGt4lBlDuOBq3KcVZ5KiwEbS5uNsOuApygXanE9bEIXmGDKqGIMsIz3ZrEURp +vVMxcr5fZDhNFsaJ6W/MuN1F9+V3Xu4qgS6603JiD/TRiZwKmt+YjZkmD90p5xU1 +joRyPUNv2SVkOqAmxVV0DCEctj3UT6S6XN3eDNN5v+JA4qAJqoSdVjV8M+8R8bHs +6bDuwPrmOrQ5IFQKC0u0AqmrxfQjNXNftN0OwymryZcg2YTpOu6XAmwa058b7Dp5 +VR11McEUfl5qGtnc8Nhp3TUdvJ0ugx55LTM70SPZqADChRwdz/LGzA6Cj7DTKtAd +/aD3ccRN4sEXEPGhYacalHKNSAyQPSLWc8+7T2GI8KHZgDQMreHDjzWQwUydEliq +1wgEkXu72pRArUJ5jmE8ac8r3xGukO+HbAsijgQqKPctveQbGJ+Ypv08wKJHXauq +E11NwaijBOZoZ6BrCFG/yOrjStDSbrhqd9qVqm3QCewoA2AifcNnzhcQw5Yk5a2I +ehhGFN7eJxFM+bkXyHMcd3j/4K+7P0WChAS0vujJdm5I8HJYNtz6AlLT+ZT91zGX +pJOUOnguWtWKhOQ3Hkzy3LrRhjFUmpdh56zOuKOoWP3tIhX5NMZyEBe9JQCYgXMX +MXLA7uM/muO+Ju0p6TW9eZbc0vdmAjSDXGfJHsdXwt3XuxnbFIpSHhvLTsBqX78s +cS2kv1IIVvolSeBIFhWmpB8Z0whWNwKWk/Ze9rR+ESmmCM7ykQO+IuEjD/AdzOfC +H85sQ5uJLcL9xtzdkQ5jkryp0wZSgbApXnKMvt5pVxbUqLkEkguuiGwvPmKvAQau +jxnypJh+ygKiDrK1WQmaV6sDHofvLjE7VC0SbH2l6ueQ6lQBhE/26UOFKrsOmxmU +u6fwhiVyv8tiPR5/FLlp3ZuS4FjS6ZzBPAW/8VEhdeU7T6vOvpkDUxQZGsz+L3Nt +u0mHVaMR1NaMIc6LwCoc2UcWJSlVf8C/tjvWDY8cyNDUCeMpnadQCrxgvVhC6r6Q +SIJXxnkRgt9QkOQYzHx+l5I6klB6npXYE02+IVjririiAdIT1SCRBOxW02o8Jefk +lMpqXygQEb21j5LQZgFmwiQSEx5xpvmvjAn7CkWZ+RIwjnLdymz8yUAWHPv433iE +RvkJ3XeKw6TSrHfiJtVPOVoMbILBjxLHP5SxZ6S671WN+aujWpCKeUkIwiemiHBQ +NlpR54J9O0u/yDYhDtTWicSnDvMUJPEPOGMhDXgxzl6JdbnvpjEQhPL4/UMpQCuW +U4kySde3ANyjUgaldWOT4omzh5KLnrBxUrfsV9uFbPnNMROliOU8fpYvkrLaAb32 +mVGbYBncYJPgeVrFQTl2sBM6UMsDFeplGahZ1pzJLkC8aqySgIDpAyvZRBXYDe35 +C5sqCCdjeAUJ+/DOQOoOb8owQR0413HTnHQOU8ZkTsuqSnfNoH6KmjU3XH+xMlhi +8YqLK+83J9ACgk9e1BkYQA6TdJuI2Nt4MRoBdFnXP8SfpcCO5dm1Prs7hOlhEJQb +W7vNkZdwAK4WnotcVHRYScTuqn4eA4FIPBu8Mc56QLe9G7FWD8Z7g3bgbIDmgaw/ +Zc/V/6H8jUKMlEtPfJeHFmRxh1F5nDpjJswmLAGP+xJm9WUvuFDKHo/svpUb8KG3 +JP9gu7Hy39pZCU242AH4PK3cxPifhQU88GDWac5FfbGZ3fzoIW/NdxZnhSY7WY4A +nk9SEv3HGjkmpPGnu3AYDMYnE7XiYk7rtDBMh7ZkZLw26NH9hZeOE4sLqa7aS8KU +/WbhWzobgS4AlIZVNTUAPPkzKnPCIUPofCF13e23d0QI9nZDTe6JktEzP86lpzw2 +kQg1Zr2pm67jC9FQcu3nUgy0/XBPaBzn3LjCIYB9DX8ZjXBvRnG60qatu/yEYDQJ +0KE/4V47I2Qs91jjmmTY3yRkCOWR3Hpbi9JIXLuLivvMz36AYQvCrwBxXImBxjNj +u2d6McMg+LdDrtFjIIViqFJzYSjI/dtCT0aFHN3yF2Cfiy3tvlV8ja2B7Y6w+sOe +BByjguuUl83bDGZWZD3BXRDiKEjeNJMJT/hlVsIjH++370rZD/XMYimE/oe5m5wQ +lL4MMw/WjKHT1X+CJs5tDInM9nyzlbwHXkF25iYwA59Fu1Zbdlagz+SmDp3J1dxm +SbRHKDo3dPp4n3XhHcdH+H4eOdCTOQ9U3jOn5how8DnkHMGHj9NG3Ga6jZqSp5US +GithsWl6RhTeWYI2vZBafYF75whkB/iPTbwz/SKQprh6D5XbfQ23yp6k9CY1jnSK +qrxMsEfuJ07xN5Ri4VRn1EOEs5QXf2aD5znMFXlUrVbNRKuYJ64U92wdHjqwZsUA +CnVlkC+NUWBqLOEWOv7J57Id84Fast/x4DyKri3hqcfw8+t9lXfDFojmHWaPvqSt +t7Hxxr0dYIQddMF0vePV0OGNMXLAcg9wQ0Hhretge4sbWkp2cW0ESTsvNpk12YJ2 +l14yFBgLOZd5T+xsV/NG+3jB5lyXfhRYa+eTC0VbEyXAWog/3Kl4XcPEAL2rXCju +T3Z35x7XdbMCz5GSBvsmU92blmscpBLDOUJNpQBKIHyBmixM77YKMyE5ISpQ1Rk3 +hUAoOKIicF278ToBpdWJ/CyLkROzrTuuR7GAG4hhkor76alvyxW1F1rONuWkZkk9 +kV79E8Et772+7ndPsGQ1ZLkWvCHl9hTUJPdsRMjK/NZhuytD/oMWndUewg9AUY4Y +YUu8iqRsSyE7rcsK/LvBXbjf/LZd5orDCXyWDT7sGZfKtJHiiEHoMhsH/YNcSPKq +KhPyOz/p4hFFAaGfhxAdSnrh91qviqHpdyT5K6J/kzrrMZm3Mbsoxi5n5hIpeO3w +4g5i7nGJ8C+TxZqaOr5jL8qYpHN9e+Lakr3oN5pDlpvKlXNzf2de3OgyOXMkbNie +n0tdlCSkOxh9vCSiekjcclhPzVdcuqNuTriVcZiwcWaGQZq52MGkVbmTY9+qp11T +OPj51ZB5KbEJaSfzLvX4ju1XZWdbz5FAkt9RyDqm0cLNWU1Ue5iEQuK1fLoDqH8N +YyJWoHavKb33jQnqHvZrBnwxUlrpbfvqmqCvdsKdsjNu6lcreQU+reRSIbkgiVjT +jYMWeTLzoMFyo4sVGik2ogUXnVSiWGAxnvc35iB863IlIjr9iYHsiSkZ1Zd2ytQ/ +t2jf7n1chJTyn1wkI3w6Gj1oW1CO+4083O0GfU7aUJUwUACsUAXMso+EdH9uDu5b +UIS4U2WFff2dJgvNKXZh3vdsAruoEzsk3avocj72GvCBg+qbHL8rDfaZeT5qaBy8 +xNhiOqXULKfg/CwU/ilvt+V/QTvo9WIv11f7mYS0j18GJsgaVm4Mrw7uh4T9A5f5 +4PnmZsNM5b0HpW62DCnARfkjGEObdTC0znKbSoGn4wD3H09T5HP88oSd2q+rdx11 +GFCdo3MOYEhI7y0cUBO+onZozOVJELyW9sbGoXy5jcRtah63sXcZN/+hayQiH+3s +eLh7rOtQSV/Et1P3oDK8hrMUnNcK6+BMediPxf/PHWCGBqjZP0t4diaON/UBavvZ +SWA/m2Utgyqvy7h5IEOUbIomiKz90OypeHd57tVNC0BNMIQHnAYvgaDrZbUHpT2T +7LqLPpG9rffH12550v/ZCCUrIFy0SiaXNZYQiDeG5/WiBOzS0MZZ3PVIMqx0czOG +Tx8WUcSEasnjAH+pGK16YGDc66YLnrMhyySgiIrWsKqf8NolxDd67Z6AXcvKh+zy +sCwUHzvTgXJ81ejNWekHIaAUZnpYXe2DCKXUuEOFJpYCdn4EfgOryDwte2WlGvUS +ZPfj3Ym43bG0RoyFSo5qnJNE1Z7jjNJKxOEIFy8NHvb46ipcY7UeT2r6R8OJLi/H +yM/8L2op7rXw6UEPat05dCp90VrXtzrT8UgF72yGVP7Wc0Hosb42JuqxmXtLlX6I +oOu0l7Ht4zaKMm7DGbznsqHs2daXNhJTAQ49e4owHN8zpIZrt+SbN4b1/svO4hZJ +fK5izj6botAkJIAnY8FT+lyrJ3oRtB3dq51lg/tWXsTR7RYyl2UVxXDRw0mpW5pe +J8XS2J7tLaTIsVbuO19Q4de5u47KlzOn+exdvmPu6QwZVBIIs2CIFhYKjXKVxKAs +tTuVv8ygT033gzrXOU9XkbjEPaTY9Dy0WlUf7wwg5Ug5dmEhrRRlhu4+rOc9mGH5 +NzEwSl4ZJmEPP1auB87iM3l1g0KcL81QX0kcTVCS0AnJUNTg1eSr+zc84tn2VLyp +xdWidOZ5V5T5p7O0TDDZ/PJAddWAuGhRmK5vSW0XaNYcKUdSOTwul4+881/i/1mh +ft2mHm5+PymHbBRVLMmVvB/AG9jqACnRXg4pbHwxp8RRMm5AXwQiRrKA7arUPttd +1Faxq6C4e2GIYDdbWmLRg2P3PYZXbZE2HNo5DGpZ60xs9GwirIPeZZbmPjRTTvqC +h7TBHyNZm/mQ3jB+f+2vdH0k9kXFxGCcitg+1faAjCOIkcQKdpc8RMz+e+XSIV39 +ZcIlLrV2Ku5jpJ9MbWNg4BpcCDi14nteey2R4JQGOSyeR27VMjGtVWB+b8fNjT29 +J9fDdgcso4OINe2jDC2oqtmlCHXMYDsaWx9uAB0LKsGbMYsF4kR8EqS10Yo709ij +ARppJ4cRcYmxN+GsVLemIBTYVObK6Ro/k88rOZk00+cLGNWsZwkp2Bgdu5cuNfEX +/0xkeR8dtuIZhAYdc61Hc61TVEQFPUyhbLgS/PEc7jhkLkbD3p4acVNrqt2I6WAH +iAcLHJe6aCB29C1XRJf8DI9a5+7nXqSKFdv1pKQgVBLon+gk5CctlDsl/H2J4ehW +J7/MrWpmKmlG5AUuTESqB9tShUZPCoxkB2wEWgNtPwoCi7+P57NR5A8BD56zP7hJ +3vrkxSLHnzKBVkrN82cDk/RiVJz7PM6108APRRWncXx5kIfeK48A5FxgcZ7RElV6 +UWQGFfoGlC3rRJyMYAKai5Ial/mQVLwtcdTweaQdNiDXVKeAFyXgznA3fkMfE+9d +0v0u6FtMml7KSXUwIT6JKmg17W4Lr8qdGFzz6W2YqAI0RelErgTbuai35i/4YTnW +r5hOuCNTsDYZA0XuNVq2xbIcLoCJPOkOGRNtCKZdIt4CwBFGFg4ak4KVhpFjNTvC +wBhDj7exxsiOdtpniKeHOiGk0hH6IEMITL5e+C9ycXmur9geA4v3Vr8E3MAsFixZ +mYbgqx/xlI8Ahprd36ab+YTwmhRoav1ZsHJiiejNfUmv8Z625nQ7Pj6LPysLNZ0O ++UKZ6wm6mEBYm4hP6GfqJK3k/4V9nOt8sXxfo3FXKVAus26m9dDYOL1qb4NWsRLx +r7hGMJfsf+hwcCpcN2urK/C6Mzpa923kMBBp/E35ObTyv9A9Fnjdpsp2t3Oo+G6z +Q9IYGV2taJt3pPWK+qLGxkTEb8HzfH98vdWfdplr0B5C9pXel+gK0Dmk6+LnxYXk +TA6ao7f8mxzLSMUiPjLW1Rl1udPnNjGFIdgcPQ9ZNJSx+6O3o2LcU6YVcwTcb4ES +vqT+dWkh88O0WoKWkQL36V5mBUudSl6WipcLY2twp+WWweJquHA4xh13uqqbhF4Y +4kwkupt8Im0oQKrLSofMaEalUPMZkIaXai6qhz5niRfo7x5fe8+8jS20HMUljbDG +sn/Uyc1/MBv+8w1TXBOWoAgaoutuzOocARU2RbGrICc0Mm/rbuUt9nVKxpW1WvML +awKfDhbY2XYoYn0CzfYrvA6oGZJ3bNwRa8MtEkmQdR7Qb99H5hn9StOKNE3BVKEu +AZFgiWTGI2Eq/XlCOHW1vL/D4bPun/0PP8IfL3PyPjiELm/CSVYP59v1ZGtZyPqz +2By3MT+7r1gqjU02HMElDq/+2MeJMu5YMzhcibQABS4JmqPHr5fpvqTzyz0T+zs7 +KRdMh7LVQ0WmW1F1pkwHEjVV8oFWkHCh0s4e0pmYPhW3/YRDVyAGSFNY9zKsv8a9 +BpLQEEY0JqW4aXLibKciLcj1dkY7XOrpFTir+LwYaCt7NayHm8ddWjWBg694U4Hc +zxs8FWCp0VKm9/HlS4Nt1VkoYmxWdZCLCpllS7ZmQ4K9m4UfIRcyfh6NGeUOJ+SL +av+L7m8I0TyRZ/0hra1D1c31Rltmt/2BoOnE6oo5plmxOkpV7PX4tLZO5oNlbbel +C1IkzdjI9GLQgqr9XhNszFyeVfb8W3UjRNHzv+NfLY/bqU8vhDjtHmchlsnOiFSL +TbW8I6VtbzhVAh6cwCE+1uLhd4B/pBczdg4DTxv7DkTZamvzOAVfyK5r38A2vCwe +LOFpV0BN9v/4RqfXejFiw8gfXcA+UJNcOvVuRp6Hz8tmnZzyfTWTMRP38FTR6qVL +7TGxeUwCmmAzYR3tUAwBYQzb7rLg5U7jeMtii08URsKUqOMFWvEomrm3Gb+/mRXA +LZSjp18pflAxDtqvHNCxie5Fo1yMbqnO2kYT0BK/mppsLzKYH4QiuYjjTv9ffKjc +A6RtTVJ/U1aUnJZ62nQJcbAw3Lv6YgtNFFqUq+KlwEhudvJpKtMf/zwp+caxyYNn +F04gCsJlIVvqYUAZ2LV53tnLkBMs85bs0nzRBUkPCw1PK7YRv39mirDMYvbV3F5t +bOUjeQvUx+tYzRrnT/ndmpPFR/iS2xatvoErkuIPxMrgX7W3amN6CHKGsqQn9VHd +ujqoTTHMkIdyq7NcC0DIvUGjIXMMOwHL3bq04rYXadpsNgiKxqhvjallJC/1aNKg +ra2KuxKxHT4g1lt501i1Xz91bjwXJPnKB5vwseEm4eElS6k/EUBWoR0AWGWu+nCz +RWt60260ENuSuLT7BB7pbUUfgYxcHd5oJO7jQYK9xY7LImJzR+BYKO0l9M/TMWtL +LxecJE2SdMkUJcNAM8p5BVL6W9gBzDK/UIh4qM4Ja31CwOdyrUUVr29HuUxnTNVh +7RCX+WkSSGdiq1G/PEb8YwPPs7roZSP/nBcj4GNh6aZFiv+RBntOpzJA2oxoJ/z7 +4hK2g+UC62A+krW41h3QvMCZ/ZcNmQWcLg1EsnVGThFajtz5+1MU/p/R0JZ1HE/E +UUoi+Aj6MC1MBsOaTqKNKq+0JL11hxya0uypiBJTQsCex63bdXGmOoN8OK+TQ9gt +GO24H17S3ZXXy3koLUY50YGVXXY6UXgVYL0TlGWQFNjEzDxgZI4/tJckEyv+0gv8 +82eMDz5sMDVFXdYme8Rz3RyrG2+4kS1dYQNQ3vKuSABtAMU8v8RcoBX/EZGgOXy8 +4K0F+nD/Ldoi9d355n/pumiT5uz8omBNFs8Xv5zIArGCGg8fBQAqRslA6su041rp +Uet3zhg3/EICocyFAsEL8a/qmG7SgmiLOx58ehTBs3/WMWr0am59UJUKN0iDHjB7 +lOezHJg78R98dfWIeWq2nSbOcriPvZcaWKbTDmh5ss5bNhwLHn1EwVpIdWzJo51R +3J321Fnm1m1IpPRBkc1DV1Jt7daR27QuC+ikQC33SKOUnKeE9Kb6sRSA/9jBuzIH +Z51iPuEZDLgFlomc5easAMfMYg1JEi9ocRsnzyEL8P5HS5znAdqO3kBFsG6X2b4r +z0wgBl0TO9jKgut/WbW7rp4AhZQlrRo+ARF1J1G7dPov3SZ74eIhbbIOYf5owapY +Fud9ctRnE90T1B8N07RRorhMvhPw0fxiJBPMq0jGVTTxp93gEA79CEBh/c6RhhdZ +++zOma31Jc/nwvxY/FzGEUdzT+m89leib3I2DIHGBaQ5ZKUNXFRz/VF++sH3YrGB +UQXRJEu/rbjJMXCfhs3TLor10cDx2P1bnO6oNTwt+BQuWH6Vz/cV6+KYDheGK5IQ +N8iryCFvr41BDkMj1YaL55EqWpEk64adh5WN8YtruTowlJjsZ+d6MM/vsVz0USLU +TeoXzOiNIfXFO8xjN2PS4PcsEOq2ti/oTPlJJW3hQ6dB4R8nk++iS+NZ6SRUnI8U +mQ0utN+N/1HQKLh9nzUACdWe9BJ4KMJMpF8Vdk7mghIcX3aG9H+duT3FY8P0nsed +cJM5H5tG1RkLw98POYNnPjn7j8iETIAlNG4QFh1qSO27rCHu9X2+9r0XxDPZiNhT ++HmdKXeIrAd2HotvWdwBnBChfxAb32I8QQHqwxkS9eBcexC7IxIkI3HLO1/EqKZU +XqpLF8eyZ5YlNwavBoHPs5yiVJyXX9HHDwF12hGiPpj5cmjgAX5jxV3OTVp7A6rc +cx2Appm5AeN8nz5XE4WrQeQQek19Dd6bM0p0kowmusMRSjOJvLCTtmTyLeVMXsFi +/mLYee6rSEyjrB8lIjVMWq33rz//tnU1NuoqTM0X5Tj9iUd7R2f8DAA8q2NageAR +kFK7B2IAIKpfy+366Axc8cE2+of8SocRdbavX35xTahsnQhaFpoDoxlhoOkCTtzj +Y25jc8xNSO7ULGjE30DIPSNp35KG14rNVNTHJB62ks3z0XirNU4/pUrYOzIfBdZL +49ETu3y7oVb/ouhZs3QCptZlkiFf9quG/eTumY4cm63n5nTLjWwPpUFQzPE2gpgS +FJXFFlm252hRNKtJnNZv55EBUxcd5T6GjykyfpKxEnxBNbOLzsg3c/uXDKbJjpwt +qpCqA4Y2BXHYNti+l4Fxjfy/WQ7a+pwMj8ImA5vqxn14N8cQAKSYI7m8k3ZH5EHy +LMCrU94T6QFvpxzrRB392MIVR0IRe6mAvdPXpbHdKXkIYNYCtVZBt8TC/kPjuoXK +84PlabtFzJAMZlf4Eg1+2WLTPCJageKSUsOKbJqn65tw5OX1i7W+hdQQnNl/c+CC +jR1ZJp+AK5dOi7mR8lV7NPPoI7wkeY8avx4pwFpMtcexxAldfx5sG4Fd3MXSYJAz +4n+qqrXjkTOfYlbuPcG6CPUcFR6siHktns5HyKBrNm8/8pk61/qgtJy/1pMpUia3 +kV8aFL+8Mey3soYij+DBeiOIE/5tyASokdngNiwZvw4K40PsW+jzQCiXYeGfhi9C +YiTydDpT+pWBLxdKdk2B+wTIl+F6XniREcz5o2+ZyJzf8u3Nf1DI/bqwNk1+tg9t +yHcjEHoQsA8YsLkK9JzhE48pLJaLHeGGfJlXlN6lPKhMrvWiEAdjvTLqykyjgv21 +wTgZg8BSf2rKApVGVmJRr1H4hf4eLpT5llt3byZ/lnmTfgJ9gLo32wDfPF4xi1U9 +nW6fk1mLN1tp3YDaIAnr1qbD0kFXkcjGRmWg68vukVNzaRcdF6Su/Y8jLlm3GQM6 +q7hJWH2ZnqiOx+9XPHyb6IDF4AXxbYWu35EiSgqu+5L0W11GlyKbB7plExhPXEn3 +HItmzZ/wuAhf3DOb/szBdeOAevcTjNagohAeax3yvnavgQ2925YGhezxgaEoxo+7 +U9B7T03XEGTaIx5qn8EMqu1wKy546kSWBhAxq8wHXqQfeA3w88f12l3VVDT9nYoU +lEIJyS6kzOASMh0n3AGFv+q1YG4ZGlO88810wFoGXAOJhCQ5jgAWFDrK68F67Lps +Cq9lWODdG9dypIn/bGcv0fOQtoj1YmA5ZzvYgzEawftbGruaMW1FjHJcH4Lnosa3 +0hDBLBclrgG5ZoMeOtTQpmRkmioTawwGVoX3fmi6eKtLWKJWL9znh6KRLWIPOQb9 +/KhHmuxPyVYkpBVc7EDyEXdaZfN57JTCvjBaGZBF3eE826q9mSTOiaTOEUDU/TD4 +vCmsDCL9/hVlWf1IjutZ6Iy/BGupHY04lOM18Wvr3Npm2B1TVB49mtZdhbN5bUw+ +xevTb5dgAfYnaDds4zIX+h2FNeLp5rDty2x3th+5Hre/TUY/zJ2WaM0yigQ1s9Rn +5uZ6sg/bPe+M6nOzPguHz77pqSVa9PrGsHo65Hgb1w71S1NXOMFaCKQEH6lVl6kv +UPKs73P0vUhAJM0njD+8LaXIsaTsILNY2IbOPyMsT6TgpvHkzlO5nR+h7R/o2pao +kDmW0vBuHdw15V58JlYD7DR6eqsP0ESdnJRjEiuvnJEWElXXDA6OX89OqiM6cnFX +LuN8BrmhdfH8nPXDTPkIGLcCOgBg9anEwAWG0T8ZXKY60nElz+bScXijDpyxnGpL +/Wmwr2L0WtYoDyT/X5a8qtWY0B0I72NFeoEkg/A5rHGZ+SfSc79sE+4dm/zVNU37 +AurHotydNRXi5tL8/SgWggSD//KPv39pg8lmUi8AIfe/+Vrmqy3fnCUgyMb2iULM +mMahyuZb7m4Glsd/VbCprT++3ZLV1K+SzP9GCZymos3byCw4CZV6oTrkyw9lqCf/ +O4xXy6Kz+Cl91do8OlIG3PhOmRSvVU1uDQmdX26mbbckLhmk6ZPYltg4/A33rfmB +Atc+5XtVRhRteZ3Bk0csryFi1ljX5jdslsYsiOzPzs4FfzY4pcP/75ec92VEb3C0 +8lF786UbHHVBu6ZGDSBASbhqlVE5vC1z5b2YJRiNolpr+2KUOsDF8ReXDaogAgyj +vcczjik83AV4+Wyc70sc6Y+9kpTxchdhmug8Fdrx7gUwwkqm25m9ia5Z1qIX5RQv +RG/pMtdOLbps0XoE1GEZjOC74bIfRffcspiPmUEDKlfqcHdB78Z6sgNAO3TfRzTV +elsEB27DNDNC4OAYLqfXnt3WPhfKyE2LHGf3jqX+izVgy2LdqxDd5TB6LEnWpLbC +K388OEnmc2HBxhcoPQqcd5zyDGsXXhK1EuNnJMvP2G3Ug26wKd0xo1H8Y5cVMEw1 +W6YHmLvsxKAOEScsjqfEMkwMQri1d21fzCwcfqF1v7sA2GwLf1QNC8Vfrle1vU2E +dvrMtsnv4XZHSPMlsYZpsNpR5L7T79hTjsHIVHvfOwG+VhzL43G8EIdUVLDrwZzk +FtJE4jF0CG/mTcgXPiT9gY5RBDYFjdwEVyz9nCBBopoYmY15tM19g9uZErZ2pm2V +2pJXdsVMTLM/m9kZcShA7I89XtCZyBlvfV2IO/xLeqhKCBhY945k1EDvQGHWyJ+k +lC6zPO1F0ihTLE3mhDIV/9WX9V9iKMMcO7b1XRhH9ym6O/bE6XECIvA6V5Zi2Hvy +p5knHk4cuGSOuQaAxlUHgDTZVuFQrBeygh2xJRHDD0aDKff8lJrUGmSG6STKd2IR +C7YWBdt/nfpSXEqKejOteMxil0XuOxQUTqmIyysvEXsQAluYyEqNd97LleWuKvox +0oUIj3W7AuztDo6NesANMSvMquGE1DCRm+SlVab/LpT05CYpLNhsiPjzRy0vTDhz +RS+2i3d7OFWzmmy0A1dVFojqvVe+rVLgF8L9aVEOg/t8l0/SIS1X7c1deYYIlqyg +aQ1kjUOrUNaxIXyBgo8drkBt/esoO2aG30Ty5BmNerORyWi97Kf9Kz0FFwXFhjWF +wfhV3iVlvfB4yt4xyVOiS23PvRqhQh5FDGUacg7l18VFgQkEPCCXoel9oWQaqB// +efrcNeNlOjRs/zf+gkgQ+YGK1Tg4WkcFCrWyJ4CWp1FDy777m4tgCABc+Uf9elwc +OnEFDjVMJlIojzQ8ojtsMqDyqka71A02UbR22JV5GGLMrZn7v4a7m3IwYKsYDOMq +rdnhETVHpR/MZNpmIl9sJDqp0l9f4nfZ0NXaEGtJWrAi1y8dF7DXw06ejb63m/vP +u3CpEPd031clExD9laaCBX8+eIpZ1qA6auswkck/itIasaeXO0B1pyKKfT8/sdBF +Yec7SXwaZ7YMdwMeQ/q9epaQCjfC6WhiyZFOspC8iKCv+YG9DnL+IPLoz19Uy+0s +3MIo2eEb4UEoVusA+qPmyo2J54jxjoLg3lopEzZy6INaWmLwfLwuUPmW4ZQVGxTX +K48eY7AQVwofe7+bVabVaJt15o0lC4bwwyvUFmVYYiWb6cQPghLlarFhCgQG6PuG +cb2pbwNpS37CR3ClVoKoGpRim8UdgQCc/87wfpKGdIkNHL03U14uE/S+pnWKgxE/ +hVlfAJmEN2XXaxs8EUnyTyChxvXtR6oVPinbtDKUh+K6jhFrc6j4c2W9LaX6x3VW +8YceU4m1088zXoAQ+JQ9ZjEE3EZSBhNTtD2CUBWxVvMtI1aD4pXoGcftSC48nJcm +2yva7a45CfUthHrGM8K5DqHuxgYPkbvMxpQhoSAABg1XttOEBhr0wLCe6GwjB1MV +NJ02CTwcU9NdGCXNwVY8bMQYUNmKWgno59C4nnYKGx89J6ot0oSDeozipqGR6qHH +k6TOjTmJck0x5v4UB2bFTqv2d757j1wHX9aWI+TfE5LId9VNlx8eEceJPwLQCN+x +sklKuZgzJ2kbopE/t6+AmOOf8Exowa74kJFjSRE/T0muNYRFFGUj5s+Q3IVqPc07 +N//rNHGR64YK7rUuIWM225WP9PF4cTIUwReOO9+G/RF/wwlYdPFx7gGE+RZpvRet +idaiJdgWpWq2LCfDUr1lY5tpO5t0HIEEfGfCngGiMmxtBHjlQsnTxxiUbU76omrG +GflKQZprwhbm0QjLr8DdqAWbl9NHyx7sNvNIBvIKfx4ha1HdIWqv7TIc4F7weR03 +zm4S2xk3TvQvF5B5S/wkP2ah1Q4D6s2zb/ltAfEdjZh1OplgUwtdl5qmD+6Gb4Rf +MZhmhwPjFlH6tZbzVlbEKCBAVb1f7fBHdITP9J6vuZdfJX2KLgmowSCvF/CV2eFg +MkYByXc70gFxGVQYWf+iyokBlopcPrUtaE6lz9HdvdYs8h9E6utNfigBO8HwesOv +3mzx8QdZIxjlFobEryoM8coveomoQHMysGW2T7ZZcSH/qdGsim4wbz0Gh/2a3tZt +JLwcuOTnkCy48iRcbmp1yM2v32466e5swRG08jx7WvfksGsyw3s1Bf2aKvXmLTfn +shsnvKATqsbt9oYfNRSkr1VfbSHrtX/4QFSWoKA/y++3BCf1fymNwgZRqyWGiJ1L +J+eXOgl8hPXQqwR6NAONtq81uJP5hPZ96B4W8A69Onlz+0O4yuHL0DzJXR6Y4WAa ++n5TWI7+D5nt5qMpURepwZVFAUblGqnzrt+ObSbZ4439acvFBqn2FqR1l903cMQc +LVM+5iO7QFHh3cAp0wh5q500lgTI6E7isKaphnf7lrYfhu/XGLEMmhiIr6vCHIHZ +qqF4LZ57amrwoa6vdbU0Mb84aN72gTee/hstZUUD9hS2NN6bRwwdV7Q8kCd7KXh4 +ksi+C9ezIkLL5rk/4RJEIVXzAYsk8+EPTLmsOpEld9Fhsz8qVixgMUKGuP7DTME0 +Ho+OlDdCc+LjeZ5PutEd+NErTSnKa0/wvr0p3SoNfNIBbLZ3B5vZmc/PJ/lC78dt +lEJSoPLROxAjjmVL1PBS/xK2C2HFGl5GUtAJr3MBB4AoZqsm0ZE4FzSgkivPbDgT +BC5uErDc8j5XERShES53q+pqsH6iFCWjtxfbQR2ZuaENehgBS9TZ5FC8TqhG+veg +f3nyC6l3N1+2Q2vG37MM+u4de+UueB4J5aYaTOnozJefc+B0yqdShxKFjJczuQ+y +U3DWcLMFVWcxWLJEc/ofdTjaKArlOsPSXcfK+MkGg7uamfmpwBGAVLAg7XQAczQR +xItqTHxdRgyKmVmSQ+W32dPQezdGlwGx6/6xd4tgvkbmvcdiD2Dxd+hERwLxV8ch +/6QZsS+2QLwsfCd5PuowAd4smW+t0hh/T2P9nJj9RFqAGJZjxlk2uiWgXnJqYka8 +9Wh3i+l5VjU9Vp88jbXsgNDnXv2moTm8PhU7xs7yup2OEOyINZQKmP/IruBdnIxL +//mkxVweMNZx/zX8EIU/ZCWJLhTZdD1zQ64qg7OLsbDyoxUgjRqAm3ThGm+/RM2m +4oYmgnEo0992SEooQQdaEaknVqxr3cFBPipBjhtSrvHtTmPdeXZd9LJMzDma1QPN +CVE3N3cFlUjmZc6TbNobJs82eepRP5rReUDh774+Dmzjt9zG/f5lwd9AsMak8tSJ +QqtordsjIBbD9mullL9VCAoEaICDQuKJyuRZKC6Zl8KmUlbJeRWAZoGYzFh9gQNZ +vyowcho94c5OJVoWrkN9orZ3/AilScbdAbbVx1WUge/M1MTIimoyityrctwS1kCj +5mEpsmR0KFkxQa0g/N40ieVaidIKulHKJ7/xXUO8Xev8W/73Foh9iJ4Zzk6WeBr6 +TzopDhv9S9C7DjYyPkIa/h/TcoW0ERGleqaXNUdv4FMw/h5elQz8UNTX44LA8e2C +9rMkErSGRCMJFNMfw1tE9i4bDvfaupbAQ2wpASuLnrE1o8NCHAAVhL4NVhVhuTQZ +0+p9l1MOKB4Mm1lJ7IQctspsgdI6tX8mSHtFkzxGVTV2mReDgM+xCiM/oK5Nqi3u +bLeC/zCdhj08i1S33/NLgDTqXHiRQ4ixwmySXpJOhC/rbvcpS8n8LFY7vstUAg0P +xc+wdjQV2oe7k2nuR/57pExIffynJ7VDbbKwSZ3Dolj78q9WuB7ej+AqXWyJWG8a +aB7ayuu2J9r5kVjvR4XhHsJsPA5HOe79TJwfLdUdGvoH95mHx5G3BnuqShPWFvB0 +ejs4MN7tUoAMa06Te9AR20s867XbFWlA287mptLRKaWeQF7348vEpGjSQIJOzODS +GCqFqaWn4ketWLu/EWfrSFMQMLeOlgIjWroeU2j1pIlPAS275ukJq06Tzs3vKq/u +dDZsFg5skLngk8Uf1IBAuqnvFo+oCmK4Hcjdm22Ab4s7s1cLoRZOOVM+il3kM71X +pcvOL/MnpEZ7z/Dv+0/EkvOaB6h+f6TXk5pSlW8IwlZ1IyXjXshY8uPo4zr9DuGa +yHjCfvQxdHzSjBQ8EFcTarxQngcNynIcOt8EhYcg8sM4l73YoE50GIbJEtQStxO4 +sTdfyE+648y3mVXqMmLslw+W5i5CLN2EHvMLiOPcRccRpyfgSzrKOkAh94FjgRyn +lENX1UgKrCEAQwSdtKW9KdvO0IoLkRqcsISbji0M5H1hxwY3WImYxnPSkLrIDXnx +1W5qCXTjPqRAyuhLO3L49NcwCbCzRUXbfeATqQNWHrqjgI3rDfXhM2CMEzyndQ2v +qRKS6NKd7gCRAUJWwqqZeJhkMjIyEodY8Ni001VxiCAjRIekn7W+p0dxfedQWpVI +mDDElCMlXPQ5wcEftCjNDwrExEV/AAqEPgNzARnzQO3zrdTgs3LNTQ+KD/XRSeE+ +PlRMnR/buNn+EqXFNmF9iQt/y93Btb6GmMe4gAaAUfLpirozlnLYq4crn+LF4HHU +tIi+AFTXrckbd+UH29l1JZLssgC5hNFVyJ5yl1e5XL+G3Ak63UyGeoqTbuNDMCRY +L4FCEG38vzg6KZMzKyRbge3jPvI/ant0OwF2R/xNXaTedwHLBw29ObXNrnjzYMcG +nAhc/i4QSXZpjoucfurBkyeUeRofRc1m62MZJvURsniWqpg1YQeJPBibww3vHd+O +59UrrcXjga11aRhTV91rGMlgigMeOxn3R4yR16QTRIlnwXUpV4fNddJ4YMNBs4yQ +bwvO3LZxAoYInLFBI2RMYaXr+ujFMTpw0INHPqo3TXFsHnNa6HVYdNKbouXv5/2j +bANMr6X1ITuTvtQN4tWGbop5qfp90b9pPyw8P0bxSdro4ZHMeSgbiS9q6qZxjVz7 +jnOKMUrdbDkbYM+ojXZ18/4WPKtaxf6lTLrh3m5CJ1V8slRJp0Jes74aDQf/OXqo +QgqVrI2wnl1klGwn06bhVaymdk0hMkxAfeHBGZIQ4BMMZ3aLuVWjAcBH/HP1tVQ4 +IG7MHRnm81yVNgA6yAuZZIPQwxDWVko7rRm/DnsJcpKfL0nZHoF+bJ6q4Rd6Dey1 +S96L4PDmXseFkVZOH/7dNWyKuvSA/MmthkN14lWJiYJebaXb7oZG3XDC70o7bG6Y +mtGOrOwVthFereg1Ii98ZA4nKgqeu2paMju/t03hQXHY5iqyV9ax0A3B0rdivz4U +VbqCcO7pGNb/Ki3gGc3hfVw9YXnR7E+tra19eE7UM7o+YlunKF1Q5dJaLKY1z3L9 +3UAJmXG/sZcLqrDn9zHfb/YxqbyIkM7VIU2kKztWCCNiNKgLQsIoVzK4sbS2LVDI +grmvZg+Q7EkwxZ1FXeBGJmsiyjKYPU3PI8ZBU1MXjwTjtnQRuBSxh+Ok9glPeE+1 +rUDdlVoogUGgPAvLV3BM43E/Q5VE+X04KvPNKINvvS1nZpGKyyy1MayOfstc7Hsw +W/RgllTEd7VW5jgZKg7YyA8r8cUjMqE7zewrq6MtkoFk6ZVslWxfoADBW3ivwdwe +I4XwNboOgBx77qxf95aHRRdqWZa0JF8zvK5BH6EpBI29hlJU4leax696ACA7QIIM +Rpc+ulkvHsNxsUlrUut9AXoob0MqDJRmZvU4gSVivHjvKLEIlymJw4pLbMWhcrNa +v94TExP21Fy/zYcWiZT2nCX6qZVXTcUcQGIrBTWDbR8bxKll4FNo/2zmelyFmeXt +iH+Zp2EwFAUELsrxx9plNd5WceyU9VnZoeucNFd2QFl7lV9KL8AlQaaMdsYOt27m +8j7iNBID4HtCYM0xLwE/5uqVQPxX6qzPPZc66MSRIi8ZHZPFvVilFVzFyZSrq5Lo +ojQQmAycQGOzx7dwx7vi9SeTrBRY2PK3WVurcLiRxM+2u9vjlxigwimpnK3VU1dh +GDoPghB3O34bfiV5GndcnPDLJxsSGWz2z2WiyCFgCkVp3shHUN5c2PLWDIOf/Ejz +LzNJXFKjO6/6ZGpMmGf6bZCa9MBnvXMNic9/k0lmtbgj8SS+2//gko1EDa/Gpaqo +J2xgEuHLvp9KQABWt9VRI+tNUJQCS/Jq10ZiT1TzhczyJEqbtVDOo0l5A5sMV0PO +HszFNxw2BmuM8RYGgAe5pkrdzVdtB8TLmhys7P+xRXNXnsUb+878kt2EyiXjMl1g +oFeAlj2afj/GgelJG0G0FXm5WPDhbthHOO1hW9RP5WCTybjUTAS+GbikVwxa7bZE +LHrROUOInY0ntR9lRNjpVCMdajCsMiqT/G0C/ApzeW6ErLMFIDdVdGSdnz/WDi5C +xQTIS1FOAdefQ0CohE0yOOvjKTAGzht+g4gYiSa/mOnvXcCVM8t39thglZhq4+6G +oWpOrXwByd8OA5f1aQMqSgoySJOGg8a3X7NR9bEDbF7/6QNJE5FvxwXvA8zcabUo +OGxXen85Gkq1M/VnlJ3RGM8vA5UizsdPESYUCVH1eKg8ROlrQOr3ISj5kaNL42fv +OSROmeHvZrHtvGn6hLTNPtWcm1hGSJS/Q5CEZe0/4ActkorF9kuoHCSG3UegX/lg +5mD9aMTHUhD5VooS6OdyakqD+6LptNqQPL0IQALsS9Ls+8KUBxIi9cOe0xIusAQl +OmyJcUJNr+Oq+Ypr6sWvelbWiymgGDN4gHm6BvzyXv5ihnvnmkIQ16WkAsIChzZx +cZUl/bz9bDsSyJ4FyzSRoWuURTz9la3Bo2x5ufLChv2i9+X9WO6Y3nFc4KOBY4hD +WeFt0ZUiY30SyTiWqrPHP8Lnto9JTBOZcIIHOqPgy4L+685Ou6xwO0cUzicIza5M +TbMBOPfnVSgPSCFImGSjAaahWEvl360B8qjx8i1vgkUOxjqfFMnjZUF5b9lBDS72 +JK0esvGRUQqyC4uQHbTi8EOJYaOnCn+0lXPzLNpN171DHfEg/X6iiD0zTjMX/7Sk +PPm2z3zH7yJmeDnh5e/gvgWaPuTVaN+LdUYv/ijqfS3bx6yF1VpNr+esTI23S+o2 +1HqlCfhZUnVmn6r0J1L8tuVeZaMni1qOFs4KacGA9UwAZeGVdOmK0rFIqUXKDehq +7BAmDZV3hnQD2TQzgfDfXpegRECX/wZZVrcg896NltY1r6AVm9jcKLVCNalyoCwe +Rp6anjx8qsUxnXXYN2rhl/l2Y9D23QZ2OM0cpvb9QPJGGgGeSaQu6p8N4hRUroje +UlL8vBLle6tcvVoiRCvPCja857vnthqUppv9bzM9SAyMz4RXcYgQvFErExOI0eyT +II67WbrY2j9ul7h4fZjNKCND7o2aENbylK8CU1wlwEBYC8BPgkTqi+dErP+VrWte +QAhjomMkOVKKzG8JaoPJoVYBmMkMTCPsFFuTjtgvg2+a+DOiYbI8yTDT4+Mi/Woi +gZUcE0HUosPkkJ2ZU3zDXdwPIr4DI7TlrnZPF99Es68+NXD6lQgc6U2fjnBfKMFw +MfaTfrg3ykA8mBwqZ6hQdIoqha14uje9Ses2axrEF1FY+pU7JEKDozmo3HzgTfYA +UFoHCu4Zbeu1IiHHJuVSRrwVy0BsY0nrq0Tjq2uYSbXyR9KylHCxztpzku5Gncy2 +Cl0sBUqv1uNWIt1v6yHdupzRM/fIZ3F95nPIomgM+uHmdpHaXyizM4D3doRGzNPH +fOm6jWgKCllI8JHYJ1DUBUokYv8TYJLf0gOSaZLZmpEh88iXfBP52ZBlUIokeUN0 +aZlxSqawVMteeqcjCs7TNySBDzfTCZREHr77tnBz4+jINXi06mh+/Hz+LRA3YNRD +Do5hyzvvFBg49rY0JzZPTC9J4bi+w1MPmmdz0OgQGG1Wiu+4LrSuBUOgiA0V+FyY +/Md51ShFwRg/5zgcWS4hK1Eg4kKTKLF6Wjdu88PCKx2+gu9dYjXgdRuzZ6LUqqS2 +It/j3VptrXm8NwQFGM27HnqGwK5u+Ym3qLJ0FE4vWNbbxGlZtX3NS8SqZSqVfbqq +TwIz4lXU3ipZJ5b42IanZ2nfWqKpdYn99C7yK6AbwA+qZf5zmy436dH+Rvo6PC6W ++9MQcrrNgvq0tiAJvA39dzb77bhRjAKzL5cDiA40hPlcZs5+Q5g9XpYtKsSfzu7s +FCFRnhXmhiBXoUqf5jsYNrm5dvtl27wPTaKvVQQ6SsVtXDZSWEbdAj8Xfeq7kev+ +jtvaOUmFRMaFevzu5t2uuLYzH7zufMB6p13chVUH9yRnWBzdha/Sqf78k57UQnZg +EJwvXcDJ+uFbnd2sibgoASzDNljSfERK5RfD7Re3n5dK6W0PXzic+7ljGoSLedtd +6DD11IzD6WjBlE/9Aiof6IUDdzuo2VZ0XtufBxmYHXUx9LF3/dgGOr8hvxz/wpMx +nPnr9QDgF9svoCvYq1toUbtWgKd1LjXeVoprAhHXwbn4Z8hj7+/LpPYwR1X3u1ik +wL916n0bOkLgWgqGjqsrgskk5Lk6ZzyrESZ0xd6/+dSrf2YxLivF8O4eCLfNxB3d +=3akT +-----END PGP MESSAGE----- + +") + +(define alpha_seckey "-----BEGIN PGP PRIVATE KEY BLOCK----- +Version: GnuPG v1.4.8 (GNU/Linux) + +lQHhBDbjjp4RBAC2ZbFDX0wmJI8yLDYQdIiZeAuHLmfyHsqXaLGUMZtWiAvn/hNp +ctwahmzKm5oXinHUvUkLOQ0s8rOlu15nhw4azc30rTP1LsIkn5zORNnFdgYC6RKy +hOeim/63+/yGtdnTm49lVfaCqwsEmBCEkXaeWDGq+ie1b89J89T6n/JquwCgoQkj +VeVGG+B/SzJ6+yifdHWQVkcD/RXDyLXX4+WHGP2aet51XlKojWGwsZmc9LPPYhwU +/RcUO7ce1QQb0XFlUVFBhY0JQpM/ty/kNi+aGWFzigbQ+HAWZkUvA8+VIAVneN+p ++SHhGIyLTXKpAYTq46AwvllZ5Cpvf02Cp/+W1aVyA0qnBWMyeIxXmR9HOi6lxxn5 +cjajA/9VZufOXWqCXkBvz4Oy3Q5FbjQQ0/+ty8rDn8OTaiPi41FyUnEi6LO+qyBS +09FjnZj++PkcRcXW99SNxmEJRY7MuNHt5wIvEH2jNEOJ9lszzZFBDbuwsjXHK35+ +lPbGEy69xCP26iEafysKKbRXJhE1C+tk8SnK+Gm62sivmK/5av4CAwKcF1Qep+Pf +ssOqtJhr+klruUBf55onBJi4vkk0gK3m32p/05YB2bbMURGz8R4JxUZfUxjdDk73 +LaNYRbQpQWxwaGEgVGVzdCAoZGVtbyBrZXkpIDxhbHBoYUBleGFtcGxlLm5ldD6I +VQQTEQIAFQUCNuOOngMLCgMDFQMCAxYCAQIXgAAKCRAtcnzHaGl3NDl4AJ4rouHB ++LpCkNi5C59jHEa1kbANzACgmddtrNSj1yPyTCwUwRghPUomECS0EEFsaWNlIChk +ZW1vIGtleSmIVQQTEQIAFQUCNuO2qwMLCgMDFQMCAxYCAQIXgAAKCRAtcnzHaGl3 +NCeMAJ9MeUVrago5Jc6PdwdeN5OMwby37QCghW65cZTQlD1bBlIq/QM8bz9AN4G0 +J0FsZmEgVGVzdCAoZGVtbyBrZXkpIDxhbGZhQGV4YW1wbGUubmV0PohVBBMRAgAV +BQI247hYAwsKAwMVAwIDFgIBAheAAAoJEC1yfMdoaXc0t8IAoJPwa6j+Vm5Vi3Nv +uo8JZri4PJ/DAJ9dqbmaJdB8FdJnHfGh1rXK3y/Jcp0BuAQ2448PEAQAnI3XH1f0 +uyN9fZnw72zsHMw706g7EW29nD4UDQG4OzRZViSrUa5n39eI7QrfTO+1meVvs0y8 +F/PvFst5jH68rPLnGSrXz4sTl1T4cop1FBkquvCAKwPLy0lE7jjtCyItOSwIOo8x +oTfY4JEEXmcqsbm+KHv9yYSF/YK4Cf7bIzcAAwcD/Rnl5jKxoucDA96pD2829TKs +LFQSau+Xiy8bvOSSDdlyABsOkNBSaeKO3eAQEKgDM7dzjVNTnAlpQ0EQ8Y9Z8pxO +WYEQYlaMrnRBC4DZ2IadzEhLlIOz5BVp/jfhrr8oVVBwKZXsrz9PZLz+e4Yn+siU +Uvlei9boD9L2ZgSOHakP/gIDApwXVB6n49+yw6e5k2VJBGTFDkQbxpgi4oslePpT +7Tc2qjAke4zO8JHkgKSokEgnMpMz412q9otFX/3qC5MpPG5P8f4r00Kfy9Am/thk +ri01WTIUqF8L/VZXJxLKVoRAabSXudG0eavfah14fN5/+Bw5i8vSHhc/xmQEKTya +2X8Nt1F5zMrE1LAGVVCL9i/DUygnJYOZzAd1Ct0RJ4kFj7lOBICF2IWWiEYEGBEC +AAYFAjbjjw8ACgkQLXJ8x2hpdzQgqQCgn81AaW8W/lyVwMh/UBeMuVMUb24An2uz +wg7Md81a5RI3F2FG8747t9gX +=VM1e +-----END PGP PRIVATE KEY BLOCK----- +") + +;; Bug 1179 solved 2010-05-12: +;; It occured for messages of a multiple of the iobuf block size where +;; the last line had no pad character. Due to premature poppng of thea +;; rmor filter gpg swalled the CRC line and passed the '-----END...' +;; line on to the decryption layer. + +(info "Importing alpha_seckey") +(pipe:do + (pipe:echo alpha_seckey) + (pipe:gpg '(--import))) + +(info "Checking for bug #1179") +(tr:do + (tr:pipe-do + (pipe:echo nopad_armored_msg) + (pipe:gpg '()))) diff --git a/tests/openpgp/armsignencrypt.scm b/tests/openpgp/armsignencrypt.scm new file mode 100755 index 000000000..b84bfe4e0 --- /dev/null +++ b/tests/openpgp/armsignencrypt.scm @@ -0,0 +1,30 @@ +#!/usr/bin/env gpgscm + +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +(load (with-path "defs.scm")) + +(for-each-p + "Checking armored signing and encryption" + (lambda (source) + (tr:do + (tr:open source) + (tr:gpg usrpass1 `(--yes --passphrase-fd "0" -sea --recipient ,usrname2)) + (tr:gpg "" '(--yes)) + (tr:assert-identity source))) + (append plain-files data-files)) diff --git a/tests/openpgp/armsigs.scm b/tests/openpgp/armsigs.scm new file mode 100755 index 000000000..d897581cb --- /dev/null +++ b/tests/openpgp/armsigs.scm @@ -0,0 +1,30 @@ +#!/usr/bin/env gpgscm + +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +(load (with-path "defs.scm")) + +(for-each-p + "Checking armored signatures" + (lambda (source) + (tr:do + (tr:open source) + (tr:gpg usrpass1 `(--yes --passphrase-fd "0" -sa --recipient ,usrname2)) + (tr:gpg "" '(--yes)) + (tr:assert-identity source))) + (append plain-files data-files)) diff --git a/tests/openpgp/clearsig.scm b/tests/openpgp/clearsig.scm new file mode 100755 index 000000000..96b1b4c31 --- /dev/null +++ b/tests/openpgp/clearsig.scm @@ -0,0 +1,107 @@ +#!/usr/bin/env gpgscm + +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +(load (with-path "defs.scm")) + +(define (check-signing args input) + (lambda (source sink) + (lettmp (signed) + (call-popen `(,@GPG --output ,signed --yes + ,@args ,source) input) + (call-popen `(,@GPG --output ,sink --yes ,signed) "")))) + +(for-each-p + "Checking signing and verifying plain text messages" + (lambda (source) + ((if (equal? "plain-3" source) + ;; plain-3 does not end in a newline, and gpg will add one. + ;; Therefore, we merely check that the verification is ok. + check-execution + ;; Otherwise, we do check that we recover the original file. + check-identity) + source + (check-signing '(--passphrase-fd "0" --clearsign) usrpass1))) + (append plain-files '("plain-large"))) + +;; The test vectors are lists of length three, containing +;; - a string to be signed, +;; - a flag indicating whether we verify that the exact message is +;; reconstructed (whitespace at the end is normalized for plain text +;; messages), +;; - and a list of arguments to add to gpg when encoding +;; the string. + +(define :string car) +(define :check-equality cadr) +(define :options caddr) + +(define + vectors + '(;; one with long lines + ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxyx + +xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +" #t ()) + + ;; one with only one long line + ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxyx +" #t ()) + + ;; and one with an empty body + ("" #f ()) + + ;; and one with one empty line at the end + ("line 1 +line 2 +line 3 +there is a blank line after this + +" #t ()) + + ;; I think this file will be constructed wrong (gpg 0.9.3) but it + ;; should verify okay anyway. + ("this is a sig test + " #f ()) + + ;; check our special diff mode + ("--- mainproc.c Tue Jun 27 09:28:11 2000 ++++ mainproc.c~ Thu Jun 8 22:50:25 2000 +@@ -1190,16 +1190,13 @@ + md_enable( c->mfx.md, n1->pkt->pkt.signature->digest_algo); + } + /* ask for file and hash it */ +- if( c->sigs_only ) { ++ if( c->sigs_only ) + rc = hash_datafiles( c->mfx.md, NULL, + c->signed_data, c->sigfilename, + n1? (n1->pkt->pkt.onepass_sig->sig_class == 0x01):0 ); +" #t (--not-dash-escaped)))) + +(let ((counter (make-counter))) + (for-each-p' + "Checking signing and verifying test vectors" + (lambda (vec) + (lettmp (tmp) + (with-output-to-file tmp (lambda () (display (:string vec)))) + ((if (:check-equality vec) check-identity check-execution) + tmp + (check-signing `(--passphrase-fd "0" --clearsign ,@(:options vec)) + usrpass1)))) + (lambda (vec) (counter)) + vectors)) diff --git a/tests/openpgp/conventional-mdc.scm b/tests/openpgp/conventional-mdc.scm new file mode 100755 index 000000000..c52492175 --- /dev/null +++ b/tests/openpgp/conventional-mdc.scm @@ -0,0 +1,65 @@ +#!/usr/bin/env gpgscm + +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +(load (with-path "defs.scm")) + +(define s2k '--s2k-count=65536) +(define passphrase "Hier spricht HAL") + +(define (file-copy-n from to n) + (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 n))) + +(define test-files + (map (lambda (size) + (let ((tmp (make-temporary-file + (string-append "data-80000-" (number->string size))))) + (file-copy-n "data-80000" tmp size) + tmp)) + '(0 1 2 3 9 10 11 19 20 21 22 23 39 40 41 8192 32000))) + +(for-each-p + "Checking conventional encryption with MDC" + (lambda (algo) + (for-each-p + "" + (lambda (source) + (tr:do + (tr:open source) + (tr:gpg passphrase `(--yes --passphrase-fd "0" ,s2k + --force-mdc -c + --cipher-algo ,algo)) + (tr:gpg passphrase `(--yes --passphrase-fd "0" ,s2k)) + (tr:assert-identity source))) + test-files)) + all-cipher-algos) + +(for-each remove-temporary-file test-files) + +(for-each-p + "Checking sign+symencrypt" + (lambda (source) + (tr:do + (tr:open source) + (tr:gpg passphrase `(--yes --passphrase-fd "0" ,s2k -cs)) + (tr:gpg passphrase `(--yes --passphrase-fd "0" ,s2k)) + (tr:assert-identity source))) + (append plain-files data-files)) diff --git a/tests/openpgp/conventional.scm b/tests/openpgp/conventional.scm new file mode 100755 index 000000000..67e28e246 --- /dev/null +++ b/tests/openpgp/conventional.scm @@ -0,0 +1,48 @@ +#!/usr/bin/env gpgscm + +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +(load (with-path "defs.scm")) + +(define s2k '--s2k-count=65536) +(define passphrase "Hier spricht HAL") + +(for-each-p + "Checking conventional encryption" + (lambda (source) + (tr:do + (tr:open source) + (tr:gpg passphrase `(--yes --passphrase-fd "0" ,s2k -c)) + (tr:gpg passphrase `(--yes --passphrase-fd "0" ,s2k)) + (tr:assert-identity source))) + '("plain-2" "data-32000")) + +(for-each-p + "Checking conventional encryption using a specific cipher" + (lambda (algo) + (for-each-p + "" + (lambda (source) + (tr:do + (tr:open source) + (tr:gpg passphrase `(--yes --passphrase-fd "0" ,s2k -c + --cipher-algo ,algo)) + (tr:gpg passphrase `(--yes --passphrase-fd "0" ,s2k)) + (tr:assert-identity source))) + '("plain-1" "data-80000"))) + all-cipher-algos) diff --git a/tests/openpgp/decrypt-dsa.scm b/tests/openpgp/decrypt-dsa.scm new file mode 100755 index 000000000..b01a0f771 --- /dev/null +++ b/tests/openpgp/decrypt-dsa.scm @@ -0,0 +1,29 @@ +#!/usr/bin/env gpgscm + +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +(load (with-path "defs.scm")) + +(for-each-p + "Checking decryption of supplied DSA encrypted file" + (lambda (name) + (tr:do + (tr:open (in-srcdir (string-append name "-pgp.asc"))) + (tr:gpg "" '(--yes)) + (tr:assert-identity name))) + (list (car plain-files))) diff --git a/tests/openpgp/decrypt.scm b/tests/openpgp/decrypt.scm new file mode 100755 index 000000000..ec0f8e7ee --- /dev/null +++ b/tests/openpgp/decrypt.scm @@ -0,0 +1,29 @@ +#!/usr/bin/env gpgscm + +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +(load (with-path "defs.scm")) + +(for-each-p + "Checking decryption of supplied files" + (lambda (name) + (tr:do + (tr:open (in-srcdir (string-append name ".asc"))) + (tr:gpg "" '(--yes)) + (tr:assert-identity name))) + plain-files) diff --git a/tests/openpgp/default-key.scm b/tests/openpgp/default-key.scm new file mode 100755 index 000000000..443365883 --- /dev/null +++ b/tests/openpgp/default-key.scm @@ -0,0 +1,76 @@ +#!/usr/bin/env gpgscm + +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +(load (with-path "defs.scm")) + +;; Import the sample key +;; +;; pub 1024R/8BC90111 2015-12-02 +;; Key fingerprint = E657 FB60 7BB4 F21C 90BB 6651 BC06 7AF2 8BC9 0111 +;; uid [ultimate] Barrett Brown <[email protected]> +;; sub 1024R/3E880CFF 2015-12-02 (encryption) +;; sub 1024R/F5F77B83 2015-12-02 (signing) +;; sub 1024R/45117079 2015-12-02 (encryption) +;; sub 1024R/1EA97479 2015-12-02 (signing) + +(info "Importing public key.") +(call-check + `(,(tool 'gpg) --import + ,(in-srcdir "samplekeys/E657FB607BB4F21C90BB6651BC067AF28BC90111.asc"))) + +;; By default, the most recent, valid signing subkey (1EA97479). +(for-each-p + "Checking that the most recent, valid signing subkey is used by default" + (lambda (keyid) + (tr:do + (tr:pipe-do + (pipe:defer (lambda (sink) (display "" (fdopen sink "w")))) + (pipe:gpg `(--default-key ,keyid -s)) + (pipe:gpg '(--verify --status-fd=1))) + (tr:call-with-content + (lambda (c) + (unless (string-contains? + c "VALIDSIG 5FBA84ACE02DCB17DA3DFF6BBCA43C441EA97479") + (exit 1)))))) + '("8BC90111" "3E880CFF" "F5F77B83" "45117079" "1EA97479")) + +;; But, if we request a particular signing key, we should get it. +(for-each-p + "Checking that the most recent, valid encryption subkey is used by default" + (lambda (keyid) + (tr:do + (tr:pipe-do + (pipe:defer (lambda (sink) (display "" (fdopen sink "w")))) + ;; We need another recipient, because --encrypt-to-default-key is + ;; not considered a recipient and gpg doesn't encrypt without any + ;; recipients. + ;; + ;; Note: it doesn't matter whether we specify the primary key or + ;; a subkey: the newest encryption subkey will be used. + (pipe:gpg `(--default-key ,keyid --encrypt-to-default-key + -r "439F02CA" -e)) + (pipe:gpg '(--list-packets))) + (tr:call-with-content + (lambda (c) + (unless (any (lambda (line) + (and (string-prefix? line ":pubkey enc packet:") + (string-suffix? line "45117079"))) + (string-split c #\newline)) + (exit 1)))))) + '("8BC90111" "3E880CFF" "F5F77B83" "45117079" "1EA97479")) diff --git a/tests/openpgp/defs.scm b/tests/openpgp/defs.scm new file mode 100644 index 000000000..8ceffc815 --- /dev/null +++ b/tests/openpgp/defs.scm @@ -0,0 +1,134 @@ +;; Common definitions for the OpenPGP test scripts. +;; +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +;; +;; Constants. +;; + +(define usrname1 "[email protected]") +(define usrpass1 "def") +(define usrname2 "[email protected]") +(define usrpass2 "") +(define usrname3 "[email protected]") +(define usrpass3 "") + +(define dsa-usrname1 "pgp5") +;; we use the sub key because we do not yet have the logic to to derive +;; the first encryption key from a keyblock (I guess) (Well of course +;; we have this by now and the notation below will lookup the primary +;; first and then search for the encryption subkey.) +(define dsa-usrname2 "0xCB879DE9") + +(define key-file1 "samplekeys/rsa-rsa-sample-1.asc") +(define key-file2 "samplekeys/ed25519-cv25519-sample-1.asc") + +(define plain-files '("plain-1" "plain-2" "plain-3")) +(define data-files '("data-500" "data-9000" "data-32000" "data-80000")) +(define exp-files '()) + +(define (qualify executable) + (string-append executable (getenv "EXEEXT"))) + +(define (getenv' key default) + (let ((value (getenv key))) + (if (string=? "" value) + default + value))) + +(define tools + '((gpg "GPG" "g10/gpg") + (gpg-agent "GPG_AGENT" "agent/gpg-agent") + (gpg-connect-agent "GPG_CONNECT_AGENT" "tools/gpg-connect-agent") + (gpgconf "GPGCONF" "tools/gpgconf") + (gpg-preset-passphrase "GPG_PRESET_PASSPHRASE" + "agent/gpg-preset-passphrase") + (mktdata "MKTDATA" "tools/mk-tdata") + (gpgtar "GPGTAR" "tools/gpgtar") + (gpg-zip "GPGZIP" "tools/gpg-zip"))) + +(define (tool which) + (let ((t (assoc which tools)) + (prefix (getenv "BIN_PREFIX"))) + (getenv' (cadr t) + (qualify (if (string=? prefix "") + (string-append (getenv "objdir") "/" (caddr t)) + (string-append prefix "/" (basename (caddr t)))))))) + + +(define have-opt-always-trust + (string-contains? (call-popen `(,(tool 'gpg) --dump-options) "") + "--always-trust")) + +(define GPG `(,(tool 'gpg) --no-permission-warning + ,@(if have-opt-always-trust '(--always-trust) '()))) +(define PINENTRY (string-append (getcwd) "/" (qualify "fake-pinentry"))) + +(define (tr:gpg input args) + (tr:spawn input `(,@GPG --output **out** ,@args **in**))) + +(define (pipe:gpg args) + (pipe:spawn `(,@GPG --output - ,@args -))) + +(define (gpg-with-colons args) + (let ((s (call-popen `(,@GPG --with-colons ,@args) ""))) + (map (lambda (line) (string-split line #\:)) + (string-split s #\newline)))) + +(define (get-config what) + (string-split (caddar (gpg-with-colons `(--list-config ,what))) #\;)) + +(define all-pubkey-algos (get-config "pubkeyname")) +(define all-hash-algos (get-config "digestname")) +(define all-cipher-algos (get-config "ciphername")) + +(define (have-pubkey-algo? x) + (not (not (member x all-pubkey-algos)))) +(define (have-hash-algo? x) + (not (not (member x all-hash-algos)))) +(define (have-cipher-algo? x) + (not (not (member x all-cipher-algos)))) + +(define (gpg-pipe args0 args1 errfd) + (lambda (source sink) + (let* ((p (pipe)) + (task0 (spawn-process-fd `(,@GPG ,@args0) + source (:write-end p) errfd)) + (_ (close (:write-end p))) + (task1 (spawn-process-fd `(,@GPG ,@args1) + (:read-end p) sink errfd))) + (close (:read-end p)) + (wait-processes (list GPG GPG) (list task0 task1) #t)))) + +(setenv "GPG_AGENT_INFO" "" #t) +(setenv "GNUPGHOME" (getcwd) #t) + +;; +;; GnuPG helper. +;; + +;; Call GPG to obtain the hash sums. Either specify an input file in +;; ARGS, or an string in INPUT. Returns a list of (<algo> +;; "<hashsum>") lists. +(define (gpg-hash-string args input) + (map + (lambda (line) + (let ((p (string-split line #\:))) + (list (string->number (cadr p)) (caddr p)))) + (string-split + (call-popen `(,@GPG --with-colons ,@args) input) #\newline))) diff --git a/tests/openpgp/detach.scm b/tests/openpgp/detach.scm new file mode 100755 index 000000000..375e92272 --- /dev/null +++ b/tests/openpgp/detach.scm @@ -0,0 +1,31 @@ +#!/usr/bin/env gpgscm + +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +(load (with-path "defs.scm")) + +(for-each-p + "Checking detached signatures" + (lambda (source) + (lettmp (tmp) + (call-popen `(,@GPG --yes --passphrase-fd "0" -sb + --output ,tmp ,source ) usrpass1) + (pipe:do + (pipe:open source (logior O_RDONLY O_BINARY)) + (pipe:spawn `(,@GPG --yes ,tmp))))) + (append plain-files data-files)) diff --git a/tests/openpgp/detachm.scm b/tests/openpgp/detachm.scm new file mode 100755 index 000000000..a4ebce03e --- /dev/null +++ b/tests/openpgp/detachm.scm @@ -0,0 +1,35 @@ +#!/usr/bin/env gpgscm + +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +(load (with-path "defs.scm")) + +(define files (append plain-files data-files)) + +(info "Checking detached signatures of multiple files") +(lettmp (tmp) + (call-popen `(,@GPG --yes --passphrase-fd "0" -sb + --output ,tmp ,@files) usrpass1) + (pipe:do + (pipe:defer (lambda (sink) + (for-each (lambda (file) + (pipe:do + (pipe:open file (logior O_RDONLY O_BINARY)) + (pipe:splice sink))) + files))) + (pipe:spawn `(,@GPG --yes ,tmp)))) diff --git a/tests/openpgp/ecc.scm b/tests/openpgp/ecc.scm new file mode 100755 index 000000000..f2f3b7c3a --- /dev/null +++ b/tests/openpgp/ecc.scm @@ -0,0 +1,249 @@ +#!/usr/bin/env gpgscm + +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +(load (with-path "defs.scm")) + +(define keygrips '("8E06A180EFFE4C65B812150CAF19BF30C0689A4C" + "E4403F3FD7A443FAC29FEF288FA0D20AC212851E" + "0B7554421FFB14A06CB9F63FB49A85A58E97ABAC" + "303ACC892C2D786C8A789677C0BE54DA8538F903" + "9FE5C36985351524B6AFA19FDCBC1A3A750B6F5F" + "145A52CC7ED3FD41C5B0A26BE220FEED36AF24DE")) +(define mainkeyids '("BAA59D9C" "0F54719F" "45AF2FFE")) + +(unless (have-pubkey-algo? "ECDH") + (skip "No ECC support due to an old Libgcrypt")) + +(info "Preparing for ECC test") +(for-each + (lambda (grip) + (catch '() (unlink (string-append "private-keys-v1.d/" grip ".key"))) + (call-check `(,(tool 'gpg-preset-passphrase) + --preset --passphrase ecc ,grip))) + keygrips) + +(info "Importing ECC public keys") +(for-each + (lambda (keyid) + (call `(,(tool 'gpg) --delete-key --batch --yes ,keyid))) + mainkeyids) + +(for-each + (lambda (n) + (call-check `(,(tool 'gpg) --import + ,(in-srcdir (string-append + "samplekeys/ecc-sample-" + (number->string n) + "-pub.asc"))))) + '(1 2 3)) + +;; The following is an opaque ECDSA signature on a message "This is one +;; line\n" (17 byte long) by the primary 256 bit key: +(define msg_opaque_signed_256 "-----BEGIN PGP MESSAGE----- +Version: GnuPG v2.1.0-ecc (GNU/Linux) + +owGbwMvMwCHMvVT3w66lc+cwrlFK4k5N1k3KT6nUK6ko8Zl8MSEkI7NYAYjy81IV +cjLzUrk64lgYhDkY2FiZQNIMXJwCMO31rxgZ+tW/zesUPxWzdKWrtLGW/LkP5rXL +V/Yvnr/EKjBbQuvZSYa/klsum6XFmTze+maVgclT6Rc6hzqqxNy6o6qdTTmLJuvp +AQA= +=GDv4 +-----END PGP MESSAGE----") + +;; The following is an opaque ECDSA signature on a message "This is one +;; line\n" (17 byte long) by the primary 384 bit key: +(define msg_opaque_signed_384 "-----BEGIN PGP MESSAGE----- +Version: PGP Command Line v10.0.0 (Linux) + +qANQR1DIqwE7wsvMwCnM2WDcwR9SOJ/xtFISd25qcXFieqpeSUUJAxCEZGQWKwBR +fl6qQk5mXirXoXJmVgbfYC5xmC5hzsDPjHXqbDLzpXpTBXSZV3L6bAgP3Kq7Ykmo +7Ds1v4UfBS+3CSSon7Pzq79WLjzXXEH54MkjPxnrw+8cfMVnY7Bi18J702Nnsa7a +9lMv/PM0/ao9CZ3KX7Q+Tv1rllTZ5Hj4V1frw431QnHfAA== +=elKT +-----END PGP MESSAGE-----") + +;; The following is an opaque ECDSA signature on a message "This is one +;; line\n" (17 byte long) by the primary 521 bit key: +(define msg_opaque_signed_521 "-----BEGIN PGP MESSAGE----- +Version: PGP Command Line v10.0.0 (Linux) + +qANQR1DIwA8BO8LLzMAlnO3Y8tB1vf4/xtNKSdy5qcXFiempeiUVJQxAEJKRWawA +RPl5qQo5mXmpXIdmMLMy+AaLnoLpEubatpeJY2Lystd7Qt32q2UcvRS5kNPWtDB7 +ryufvcrWtFM7Jx8qXKDxZuqr7b9PGv1Ssk+I8TzB2O9dZC+n/jv+PAdbuu7mLe33 +Gf9pLd3weV3Qno6FOqxGa5ZszQx+uer2xH3/El9x/2pVeO4l15ScsL7qWMTmffmG +Ic1RdzgeCfosMF+l/zVRchcLKzenEQA= +=ATtX +-----END PGP MESSAGE-----") + +(lettmp (z) + (letfd ((fd (open z (logior O_WRONLY O_CREAT O_BINARY) #o600))) + (display "This is one line\n" (fdopen fd "wb"))) + + (for-each-p + "Checking opaque ECDSA signatures" + (lambda (test) + (lettmp (x y) + (call-with-output-file + x (lambda (p) (display (eval test (current-environment)) p))) + (call-check `(,(tool 'gpg) --verify ,x)) + (call-check `(,(tool 'gpg) --output ,y ,x)) + (unless (file=? y z) (error "mismatch")))) + '(msg_opaque_signed_256 msg_opaque_signed_384 msg_opaque_signed_521))) + +;; +;; Import the secret keys so that we now can sign and decrypt. +;; +;; Note that the PGP generated secret keys are not self-signed, thus we +;; need to pass an appropriate option. +;; +(info "Importing ECC secret keys") +(setenv "PINENTRY_USER_DATA" "ecc" #t) +(for-each + (lambda (n) + (call-check `(,(tool 'gpg) --import + ,@(if (> n 1) '(--allow-non-selfsigned-uid) '()) + ,(in-srcdir (string-append + "samplekeys/ecc-sample-" + (number->string n) + "-sec.asc"))))) + '(1 2 3)) + +;; +;; Check a few sample encrtpted messages. +;; +(info "Checking ECC encryption") + +;; The following block encrypts the text "This is one line\n", 17 bytes, +;; with the subkey 4089AB73. +(define msg_encrypted_256 "-----BEGIN PGP MESSAGE----- +Version: GnuPG v2.1.0-ecc (GNU/Linux) + +hH4Dd863o0CJq3MSAgMEHdIYZQx+rV1cjy7qitIOEICFFzp4cjsRX4r+rDdMcQUs +h7VZmbP1c9C0s9sgCKwubWfkcYUl2ZOju4gy+s4MYTBb4/j8JjnJ9Bqn6LWutTXJ +zwsdP13VIJLnhiNqISdR3/6xWQ0ICRYzwb95nUZ1c1DSVgFpjPgUvi4pgYbTpcDB +jzILKWBfBDT/jck169XE8vgtbcqVQYZ7lZpaY9CzEbC+4dXZmV1gm5MafpTyFWgH +VnyrZB4gad9Lp9e0RKHHcOOE7s/NeLuu +=odUZ +-----END PGP MESSAGE-----") + +;; The following block encrypts the text "This is one line\n", 17 bytes, +;; with the subkey 9A201946: +(define msg_encrypted_384 "-----BEGIN PGP MESSAGE----- +Version: PGP Command Line v10.0.0 (Linux) + +qANQR1DBngOqi5OPmiAZRhIDAwQqIr/00cJyf+QP+VA4QKVkk77KMHdz9OVaR2XK +0VYu0F/HPm89vL2orfm2hrAZxY9G2R0PG4Wk5Lg04UjKca/O72uWtjdPYulFidmo +uB0QpzXFz22ZZinxeVPLPEr19Pow0EwCc95cg4HAgrD0nV9vRcTJ/+juVfvsJhAO +isMKqrFNMvwnK5A1ECeyVXe7oLZl0lUBRhLr59QTtvf85QJjg/m5kaGy8XCJvLv3 +61pZa6KUmw89PjtPak7ebcjnINL01vwmyeg1PAyW/xjeGGvcO+R4P1b4ewyFnJyR +svzIJcP7d4DqYOw7 +=oiTJ +-----END PGP MESSAGE-----") + +;; The following block encrypts the text "This is one line\n", 17 bytes, +;; with the subkey A81C4838: +(define msg_encrypted_521 "-----BEGIN PGP MESSAGE----- +Version: PGP Command Line v10.0.0 (Linux) + +qANQR1DBwAIDB+qqSKgcSDgSBCMEAKpzTUxB4c56C7g09ekD9I+ttC5ER/xzDmXU +OJmFqU5w3FllhFj4TgGxxdH+8fv4W2Ag0IKoJvIY9V1V7oUCClfqAR01QbN7jGH/ +I9GFFnH19AYEgMKgFmh14ZwN1BS6/VHh+H4apaYqapbx8/09EL+DV9zWLX4GRLXQ +VqCR1N2rXE29MJFzGmDOCueQNkUjcbuenoCSKcNT+6xhO27U9IYVCg4BhRUDGfD6 +dhfRzBLxL+bKR9JVAe46+K8NLjRVu/bd4Iounx4UF5dBk8ERy+/8k9XantDoQgo6 +RPqCad4Dg/QqkpbK3y574ds3VFNJmc4dVpsXm7lGV5w0FBxhVNPoWNhhECMlTroX +Rg== +=5GqW +-----END PGP MESSAGE-----") + +(lettmp (z) + (letfd ((fd (open z (logior O_WRONLY O_CREAT O_BINARY) #o600))) + (display "This is one line\n" (fdopen fd "wb"))) + + (for-each-p + "Checking ECDSA decryption" + (lambda (test) + (lettmp (x y) + (call-with-output-file + x (lambda (p) (display (eval test (current-environment)) p))) + (call-check `(,@GPG --yes --output ,y ,x)) + (unless (file=? y z) (error "mismatch")))) + '(msg_encrypted_256 msg_encrypted_384 msg_encrypted_521))) + +;; +;; Now check that we can encrypt and decrypt our own messages. +;; +;; Note that we don't need to provide a passppharse because we already +;; preset the passphrase into the gpg-agent. +;; +(for-each-p + "Checking ECC encryption and decryption" + (lambda (source) + (for-each-p + "" + (lambda (keyid) + (tr:do + (tr:open source) + (tr:gpg "" `(--yes --encrypt --recipient ,keyid)) + (tr:gpg "" '(--yes)) + (tr:assert-identity source))) + mainkeyids)) + (append plain-files data-files)) + +;; +;; Now check that we can sign and verify our own messages. +;; +(for-each-p + "Checking ECC signing and verifiction" + (lambda (source) + (for-each-p + "" + (lambda (keyid) + (tr:do + (tr:open source) + (tr:gpg "" `(--yes --sign --local-user ,keyid)) + (tr:gpg "" '(--yes)) + (tr:assert-identity source))) + mainkeyids)) + (append plain-files data-files)) + +;; +;; Let us also try to import the keys only from a secret keyblock. +;; +;; Because PGP does not sign the UID, it is not very useful to work +;; with this key unless we go into the trouble of adding the +;; self-signature. +;; +(info "Importing ECC secret keys directly") +(for-each + (lambda (keyid) + (catch '() (unlink (string-append "private-keys-v1.d/" keyid ".key")))) + keygrips) +(for-each + (lambda (keyid) + (call `(,(tool 'gpg) --delete-key --batch --yes ,keyid))) + mainkeyids) + +(for-each + (lambda (n) + (call-check `(,(tool 'gpg) --import + ,@(if (> n 1) '(--allow-non-selfsigned-uid) '()) + ,(in-srcdir (string-append + "samplekeys/ecc-sample-" + (number->string n) + "-sec.asc"))))) + '(1 2 3)) diff --git a/tests/openpgp/encrypt-dsa.scm b/tests/openpgp/encrypt-dsa.scm new file mode 100755 index 000000000..5228e43a7 --- /dev/null +++ b/tests/openpgp/encrypt-dsa.scm @@ -0,0 +1,45 @@ +#!/usr/bin/env gpgscm + +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +(load (with-path "defs.scm")) + +(for-each-p + "Checking encryption using DSA" + (lambda (source) + (tr:do + (tr:open source) + (tr:gpg "" `(--yes --encrypt --recipient ,dsa-usrname2)) + (tr:gpg "" '(--yes)) + (tr:assert-identity source))) + (append plain-files data-files)) + +(for-each-p + "Checking encryption using DSA and a specific cipher algorithm" + (lambda (cipher) + (for-each-p + "" + (lambda (source) + (tr:do + (tr:open source) + (tr:gpg "" `(--yes --encrypt --recipient ,dsa-usrname2 + --cipher-algo ,cipher)) + (tr:gpg "" '(--yes)) + (tr:assert-identity source))) + (append plain-files data-files))) + all-cipher-algos) diff --git a/tests/openpgp/encrypt.scm b/tests/openpgp/encrypt.scm new file mode 100755 index 000000000..7452fc5b5 --- /dev/null +++ b/tests/openpgp/encrypt.scm @@ -0,0 +1,60 @@ +#!/usr/bin/env gpgscm + +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +(load (with-path "defs.scm")) + +(for-each-p + "Checking encryption" + (lambda (source) + (tr:do + (tr:open source) + (tr:gpg "" `(--yes --encrypt --recipient ,usrname2)) + (tr:gpg "" '(--yes)) + (tr:assert-identity source))) + (append plain-files data-files)) + +(for-each-p + "Checking encryption using a specific cipher algorithm" + (lambda (cipher) + (for-each-p + "" + (lambda (source) + (tr:do + (tr:open source) + (tr:gpg "" `(--yes --encrypt --recipient ,usrname2 + --cipher-algo ,cipher)) + (tr:gpg "" '(--yes)) + (tr:assert-identity source))) + (append plain-files data-files))) + all-cipher-algos) + + +;; We encrypt to two keys and we have also put the first key into our +;; pubring, so that decryption will work. +(for-each-p + "Checking encryption using a key from file" + (lambda (source) + (tr:do + (tr:open source) + (tr:gpg "" `(--yes -v --no-keyring --encrypt + --recipient-file ,(in-srcdir key-file1) + --hidden-recipient-file ,(in-srcdir key-file2))) + (tr:gpg "" '(--yes)) + (tr:assert-identity source))) + plain-files) diff --git a/tests/openpgp/encryptp.scm b/tests/openpgp/encryptp.scm new file mode 100755 index 000000000..2b010acd1 --- /dev/null +++ b/tests/openpgp/encryptp.scm @@ -0,0 +1,31 @@ +#!/usr/bin/env gpgscm + +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +(load (with-path "defs.scm")) + +(for-each-p + "Checking encryption and decryption using pipes" + (lambda (source) + (tr:do + (tr:open source) + (tr:pipe-do + (pipe:gpg `(--yes --encrypt --recipient ,usrname2)) + (pipe:gpg '(--yes))) + (tr:assert-identity source))) + (append plain-files data-files)) diff --git a/tests/openpgp/export.scm b/tests/openpgp/export.scm new file mode 100755 index 000000000..829170541 --- /dev/null +++ b/tests/openpgp/export.scm @@ -0,0 +1,99 @@ +#!/usr/bin/env gpgscm + +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +(load (with-path "defs.scm")) + +(define (check-for predicate lines message) + (unless (any predicate lines) + (error message))) + +(define (check-exported-key dump keyid) + (check-for (lambda (l) + (and (string-prefix? l " keyid: ") + (string-suffix? l keyid))) dump + "Keyid not found") + (check-for (lambda (l) (string-prefix? l ":user ID packet:")) dump + "User ID packet not found") + (check-for (lambda (l) + (and (string-prefix? l ":signature packet:") + (string-contains? l "keyid") + (string-suffix? l keyid))) dump + "Signature packet not found")) + +(define (check-exported-public-key packet-dump keyid) + (let ((dump (string-split packet-dump #\newline))) + (check-for (lambda (l) (string-prefix? l ":public key packet:")) dump + "Public key packet not found") + (check-exported-key dump keyid))) + +(define (check-exported-private-key packet-dump keyid) + (let ((dump (string-split packet-dump #\newline))) + (check-for (lambda (l) (string-prefix? l ":secret key packet:")) dump + "Secret key packet not found") + (check-exported-key dump keyid))) + +(lettmp + ;; Prepare two temporary files for communication with the fake + ;; pinentry program. + (logfile ppfile) + + (define (prepare-passphrases . passphrases) + (call-with-output-file ppfile + (lambda (port) + (for-each (lambda (passphrase) + (display passphrase port) + (display #\newline port)) passphrases)))) + + (define CONFIRM "fake-entry being started to CONFIRM the weak phrase") + + (define (assert-passphrases-consumed) + (call-with-input-file ppfile + (lambda (port) + (unless + (eof-object? (peek-char port)) + (error (string-append + "Expected all passphrases to be consumed, but found: " + (read-all port))))))) + + (setenv "PINENTRY_USER_DATA" + (string-append "--logfile=" logfile " --passphrasefile=" ppfile) #t) + + (for-each-p + "Checking key export" + (lambda (keyid) + (tr:do + (tr:pipe-do + (pipe:gpg `(--export ,keyid)) + (pipe:gpg '(--list-packets))) + (tr:call-with-content check-exported-public-key keyid)) + + (if (string=? "D74C5F22" keyid) + ;; Key D74C5F22 is protected by a passphrase. Prepare this + ;; one. Currently, GnuPG does not ask for an export passphrase + ;; in this case. + (prepare-passphrases usrpass1)) + + (tr:do + (tr:pipe-do + (pipe:gpg `(--export-secret-keys ,keyid)) + (pipe:gpg '(--list-packets))) + (tr:call-with-content check-exported-private-key keyid)) + + (assert-passphrases-consumed)) + '("D74C5F22" "C40FDECF" "ECABF51D"))) diff --git a/tests/openpgp/finish.scm b/tests/openpgp/finish.scm new file mode 100755 index 000000000..48801c861 --- /dev/null +++ b/tests/openpgp/finish.scm @@ -0,0 +1,23 @@ +#!/usr/bin/env gpgscm + +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +(load (with-path "defs.scm")) + +(echo "Killing gpg-agent...") +(call-check `(,(tool 'gpg-connect-agent) --verbose killagent /bye)) diff --git a/tests/openpgp/genkey1024.scm b/tests/openpgp/genkey1024.scm new file mode 100755 index 000000000..9870f4624 --- /dev/null +++ b/tests/openpgp/genkey1024.scm @@ -0,0 +1,52 @@ +#!/usr/bin/env gpgscm + +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +(load (with-path "defs.scm")) + +(define (genkey config) + (pipe:do + (pipe:echo config) + (pipe:spawn `(,(tool 'gpg) --quiet --batch --gen-key)))) + +(info "Checking batch key generation") +(genkey "Key-Type: DSA +Key-Length: 1024 +Subkey-Type: ELG +Subkey-Length: 1024 +Name-Real: Harry H. +Name-Comment: test key +Name-Email: hh@@ddorf.de +Expire-Date: 1 +%no-protection +%transient-key +%commit +") + +(if (have-pubkey-algo? "RSA") + (genkey "Key-Type: RSA +Key-Length: 1024 +Key-Usage: sign,encrypt +Name-Real: Harry A. +Name-Comment: RSA test key +Name-Email: hh@@ddorf.de +Expire-Date: 2 +%no-protection +%transient-key +%commit +")) diff --git a/tests/openpgp/gpg-agent.conf.tmpl b/tests/openpgp/gpg-agent.conf.tmpl index b3cb54f09..70e163317 100644 --- a/tests/openpgp/gpg-agent.conf.tmpl +++ b/tests/openpgp/gpg-agent.conf.tmpl @@ -1,4 +1,2 @@ allow-preset-passphrase no-grab - - diff --git a/tests/openpgp/gpgtar.scm b/tests/openpgp/gpgtar.scm new file mode 100755 index 000000000..07f2fd7f7 --- /dev/null +++ b/tests/openpgp/gpgtar.scm @@ -0,0 +1,92 @@ +#!/usr/bin/env gpgscm + +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +(load (with-path "defs.scm")) + +(unless (= 0 (call `(,(tool 'gpgtar) --help))) + (skip "gpgtar not installed")) + +(define testfiles (append plain-files data-files)) +(define gpgargs + (if have-opt-always-trust + "--no-permission-warning --always-trust" + "--no-permission-warning")) + +(define (do-test create-flags inspect-flags extract-flags) + (lettmp (archive) + (call-check `(,(tool 'gpgtar) --gpg ,(tool 'gpg) --gpg-args ,gpgargs + ,@create-flags + --output ,archive + ,@testfiles)) + (tr:do + (tr:pipe-do + (pipe:spawn `(,(tool 'gpgtar) --gpg ,(tool 'gpg) --gpg-args ,gpgargs + --list-archive ,@inspect-flags + ,archive))) + (tr:call-with-content + (lambda (c) + (unless (all (lambda (f) (string-contains? c f)) testfiles) + (error "some file(s) are missing from archive"))))) + + (with-temporary-working-directory + (call-check `(,(tool 'gpgtar) --gpg ,(tool 'gpg) --gpg-args ,gpgargs + --tar-args --directory=. + ,@extract-flags + ,archive)) + + (for-each + (lambda (f) (unless (call-with-input-file f (lambda (x) #t)) + (error (string-append "missing file: " f)))) + testfiles)))) + +(info "Checking gpgtar without encryption") +(do-test '(--skip-crypto --encrypt) '(--skip-crypto) + '(--skip-crypto --decrypt)) + +(info "Checking gpgtar without encryption with nicer actions") +(do-test '(--create) '(--skip-crypto) '(--extract)) + +(info "Checking gpgtar with asymmetric encryption") +(do-test `(--encrypt --recipient ,usrname2) '() '(--decrypt)) + +(info "Checking gpgtar with asymmetric encryption and signature") +(do-test `(--encrypt --recipient ,usrname2 --sign --local-user ,usrname3) + '() '(--decrypt)) + +(info "Checking gpgtar with signature") +(do-test `(--sign --local-user ,usrname3) '() '(--decrypt)) + +(lettmp (passphrasefile) + (letfd ((fd (open passphrasefile (logior O_WRONLY O_CREAT O_BINARY) #o600))) + (display "streng geheimes hupsipupsi" (fdopen fd "wb"))) + + (let ((ppflags `(--gpg-args ,(string-append "--passphrase-file=" + passphrasefile)))) + (info "Checking gpgtar with symmetric encryption") + (do-test `(,@ppflags --symmetric) ppflags (cons '--decrypt ppflags)) + + (info "Checking gpgtar with symmetric encryption and chosen cipher") + (do-test `(,@ppflags --symmetric --gpg-args + ,(string-append "--cipher=" (car all-cipher-algos))) + ppflags (cons '--decrypt ppflags)) + + (info "Checking gpgtar with both symmetric and asymmetric encryption") + (do-test `(,@ppflags --symmetric --encrypt --recipient ,usrname2 + --sign --local-user ,usrname3) + ppflags (cons '--decrypt ppflags)))) diff --git a/tests/openpgp/import.scm b/tests/openpgp/import.scm new file mode 100755 index 000000000..580acea0d --- /dev/null +++ b/tests/openpgp/import.scm @@ -0,0 +1,60 @@ +#!/usr/bin/env gpgscm + +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +(load (with-path "defs.scm")) + +(info "Checking bug 894: segv importing certain keys.") +(call-check `(,(tool 'gpg) --import ,(in-srcdir "bug894-test.asc"))) + +(define keyid "0xC108E83A") +(info "Checking bug 1223: designated revoker sigs are not properly merged.") +(call `(,(tool 'gpg) --delete-key --batch --yes ,keyid)) +(call `(,(tool 'gpg) --import ,(in-srcdir "bug1223-bogus.asc"))) +(call `(,(tool 'gpg) --import ,(in-srcdir "bug1223-good.asc"))) +(tr:do + (tr:pipe-do + (pipe:gpg `(--list-keys --with-colons ,keyid))) + (tr:call-with-content + (lambda (c) + ;; XXX we do not have a regexp library + (unless (any (lambda (line) + (and (string-prefix? line "rvk:") + (string-contains? line ":0EE5BE979282D80B9F7540F1CCD2ED94D21739E9:"))) + (string-split c #\newline)) + (exit 1))))) + +(define fpr1 "9E669861368BCA0BE42DAF7DDDA252EBB8EBE1AF") +(define fpr2 "A55120427374F3F7AA5F1166DDA252EBB8EBE1AF") +(info "Checking import of two keys with colliding long key ids.") +(call `(,(tool 'gpg) --delete-key --batch --yes ,fpr1 ,fpr2)) +(call `(,(tool 'gpg) --import ,(in-srcdir "samplekeys/dda252ebb8ebe1af-1.asc"))) +(call `(,(tool 'gpg) --import ,(in-srcdir "samplekeys/dda252ebb8ebe1af-2.asc"))) +(tr:do + (tr:pipe-do + (pipe:gpg `(--list-keys --with-colons ,fpr1 ,fpr2))) + (tr:call-with-content + (lambda (c) + ;; XXX we do not have a regexp library + (let ((keys (filter + (lambda (line) + (and (string-prefix? line "pub:") + (string-contains? line ":4096:1:DDA252EBB8EBE1AF:"))) + (string-split c #\newline)))) + (unless (= 2 (length keys)) + (error "Importing keys with long id collision failed")))))) diff --git a/tests/openpgp/mds.scm b/tests/openpgp/mds.scm new file mode 100755 index 000000000..8ca6c7b31 --- /dev/null +++ b/tests/openpgp/mds.scm @@ -0,0 +1,68 @@ +#!/usr/bin/env gpgscm + +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +(load (with-path "defs.scm")) + +(define empty-string-hashes + `((1 "D41D8CD98F00B204E9800998ECF8427E" "MD5") + (2 "DA39A3EE5E6B4B0D3255BFEF95601890AFD80709" "SHA1") + (3 "9C1185A5C5E9FC54612808977EE8F548B2258D31" "RIPEMD160") + (11 "D14A028C2A3A2BC9476102BB288234C415A2B01F828EA62AC5B3E42F" "SHA224") + (8 "E3B0C44298FC1C149AFBF4C8996FB92427AE41E4649B934CA495991B7852B855" "SHA256") + (9 "38B060A751AC96384CD9327EB1B1E36A21FDB71114BE07434C0CC7BF63F6E1DA274EDEBFE76F65FBD51AD2F14898B95B" "SHA384") + (10 + "CF83E1357EEFB8BDF1542850D66D8007D620E4050B5715DC83F4A921D36CE9CE47D0D13C5D85F2B0FF8318D2877EEC2F63B931BD47417A81A538327AF927DA3E" + "SHA512"))) + +(define abc-hashes + `((1 "C3FCD3D76192E4007DFB496CCA67E13B" "MD5") + (2 "32D10C7B8CF96570CA04CE37F2A19D84240D3A89" "SHA1") + (3 "F71C27109C692C1B56BBDCEB5B9D2865B3708DBC" "RIPEMD160") + (11 "45A5F72C39C5CFF2522EB3429799E49E5F44B356EF926BCF390DCCC2" "SHA224") + (8 "71C480DF93D6AE2F1EFAD1447C66C9525E316218CF51FC8D9ED832F2DAF18B73" "SHA256") + (9 "FEB67349DF3DB6F5924815D6C3DC133F091809213731FE5C7B5F4999E463479FF2877F5F2936FA63BB43784B12F3EBB4" "SHA384") + (10 "4DBFF86CC2CA1BAE1E16468A05CB9881C97F1753BCE3619034898FAA1AABE429955A1BF8EC483D7421FE3C1646613A59ED5441FB0F321389F77F48A879C7B1F1" "SHA512"))) + +;; Symbolic names for the triples above. +(define :algo car) +(define :value cadr) +(define :name caddr) + +;; Test whether HASH matches REF. +(define (test-hash hash ref) + (unless (eq? #f ref) + (if (not (string=? (:value hash) (:value ref))) + (error "failed")))) + +;; Test whether the hashes computed over S match the REFERENCE set. +(define (test-hashes msg s reference) + (for-each-p' + msg + (lambda (hash) (test-hash hash (assv (:algo hash) reference))) + (lambda (hash) + (let ((ref (assv (:algo hash) reference))) + (if (eq? #f ref) + (string-append "no-ref-for:" (number->string (:algo hash))) + (:name ref)))) + (gpg-hash-string '(--print-mds) s))) + +(test-hashes "Hashing the empty string" + "" empty-string-hashes) +(test-hashes "Hashing the string \"abcdefghijklmnopqrstuvwxyz\"" + "abcdefghijklmnopqrstuvwxyz" abc-hashes) diff --git a/tests/openpgp/multisig.scm b/tests/openpgp/multisig.scm new file mode 100755 index 000000000..53c905fe1 --- /dev/null +++ b/tests/openpgp/multisig.scm @@ -0,0 +1,168 @@ +#!/usr/bin/env gpgscm + +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +;; Check that gpg verifies only signatures where there is no ambiguity +;; in the order of packets. Needs the Demo Keys Lima and Mike. +;; +;; Note: We do not support multiple signatures anymore thus this test is +;; not really needed because verify could do the same. We keep it anyway. + +(load (with-path "defs.scm")) + +(define sig-1ls1ls-valid " +-----BEGIN PGP ARMORED FILE----- + +kA0DAAIRN8q1H7eRA/gBrCdiBXRleHQxOogq9EkgYW0gc29ycnksIEkgY2FuJ3Qg +ZG8gdGhhdAqIPwMFADqIKvQ3yrUft5ED+BEC2joAoJaSaXOZEtSZqQ780HIXG77e +8PB7AJ4wCprmaFTO0fBaTcXDuEOBdAWnOZANAwACETfKtR+3kQP4AawnYgV0ZXh0 +MTqIKvRJIGFtIHNvcnJ5LCBJIGNhbid0IGRvIHRoYXQKiD8DBQA6iCr0N8q1H7eR +A/gRAto6AKCWkmlzmRLUmakO/NByFxu+3vDwewCeMAqa5mhUztHwWk3Fw7hDgXQF +pzk= +=8jSC +-----END PGP ARMORED FILE----- +") +(define sig-ls-valid " +-----BEGIN PGP ARMORED FILE----- + +rCdiBXRleHQxOogrS0kgYW0gc29ycnksIEkgY2FuJ3QgZG8gdGhhdAqIPwMFADqI +K0s3yrUft5ED+BECLQMAn2jZUNOpB4OuurSQkc2TRfg6ek02AJ9+oJS0frQ+yUsT +QDUFTH2PvZRxjw== +=J+lb +-----END PGP ARMORED FILE----- +") +(define sig-sl-valid " +-----BEGIN PGP ARMORED FILE----- + +iD8DBQA6iCtLN8q1H7eRA/gRAi0DAJ9o2VDTqQeDrrq0kJHNk0X4OnpNNgCffqCU +tH60PslLE0A1BUx9j72UcY+sJ2IFdGV4dDE6iCtLSSBhbSBzb3JyeSwgSSBjYW4n +dCBkbyB0aGF0Cg== +=N9MP +-----END PGP ARMORED FILE----- +") +(define sig-11lss-valid-but-is-not " +-----BEGIN PGP ARMORED FILE----- + +kA0DAAIRN8q1H7eRA/gAkA0DAAIRN8q1H7eRA/gBrCdiBXRleHQxOogyXUkgYW0g +c29ycnksIEkgY2FuJ3QgZG8gdGhhdAqIPwMFADqIMl03yrUft5ED+BECwQAAnRXT +mXjVd385oD38W80XuheWKTGcAJ9pZ6/flaKDfw+SLido7xaUHuhp5Yg/AwUAOogy +XTfKtR+3kQP4EQLBAACgnN0IP+NztE0aAc/DZ17yHWR9diwAniN0P01WmbgZJoZB +Q341WRXKS/at +=Ekrs +-----END PGP ARMORED FILE----- +") +(define sig-11lss11lss-valid-but-is-not " +-----BEGIN PGP ARMORED FILE----- + +kA0DAAIRN8q1H7eRA/gAkA0DAAIRN8q1H7eRA/gBrCdiBXRleHQxOogyXUkgYW0g +c29ycnksIEkgY2FuJ3QgZG8gdGhhdAqIPwMFADqIMl03yrUft5ED+BECwQAAnRXT +mXjVd385oD38W80XuheWKTGcAJ9pZ6/flaKDfw+SLido7xaUHuhp5Yg/AwUAOogy +XTfKtR+3kQP4EQLBAACgnN0IP+NztE0aAc/DZ17yHWR9diwAniN0P01WmbgZJoZB +Q341WRXKS/atkA0DAAIRN8q1H7eRA/gAkA0DAAIRN8q1H7eRA/gBrCdiBXRleHQx +OogyXUkgYW0gc29ycnksIEkgY2FuJ3QgZG8gdGhhdAqIPwMFADqIMl03yrUft5ED ++BECwQAAnRXTmXjVd385oD38W80XuheWKTGcAJ9pZ6/flaKDfw+SLido7xaUHuhp +5Yg/AwUAOogyXTfKtR+3kQP4EQLBAACgnN0IP+NztE0aAc/DZ17yHWR9diwAniN0 +P01WmbgZJoZBQ341WRXKS/at +=P1Mu +-----END PGP ARMORED FILE----- +") +(define sig-ssl-valid-but-is-not " +-----BEGIN PGP ARMORED FILE----- + +iD8DBQA6iCtLN8q1H7eRA/gRAi0DAJ9o2VDTqQeDrrq0kJHNk0X4OnpNNgCffqCU +tH60PslLE0A1BUx9j72UcY+IPwMFADqIK0s3yrUft5ED+BECLQMAn2jZUNOpB4Ou +urSQkc2TRfg6ek02AJ9+oJS0frQ+yUsTQDUFTH2PvZRxj6wnYgV0ZXh0MTqIK0tJ +IGFtIHNvcnJ5LCBJIGNhbid0IGRvIHRoYXQK +=Zven +-----END PGP ARMORED FILE----- +") +(define sig-1lsls-invalid " +-----BEGIN PGP ARMORED FILE----- + +kA0DAAIRN8q1H7eRA/gBrCdiBXRleHQxOogq9EkgYW0gc29ycnksIEkgY2FuJ3Qg +ZG8gdGhhdAqIPwMFADqIKvQ3yrUft5ED+BEC2joAoJaSaXOZEtSZqQ780HIXG77e +8PB7AJ4wCprmaFTO0fBaTcXDuEOBdAWnOawnYgV0ZXh0MTqIK0tJIGFtIHNvcnJ5 +LCBJIGNhbid0IGRvIHRoYXQKiD8DBQA6iCtLN8q1H7eRA/gRAi0DAJ9o2VDTqQeD +rrq0kJHNk0X4OnpNNgCffqCUtH60PslLE0A1BUx9j72UcY8= +=nkeu +-----END PGP ARMORED FILE----- +") +(define sig-lsls-invalid " +-----BEGIN PGP ARMORED FILE----- + +rCdiBXRleHQxOogrS0kgYW0gc29ycnksIEkgY2FuJ3QgZG8gdGhhdAqIPwMFADqI +K0s3yrUft5ED+BECLQMAn2jZUNOpB4OuurSQkc2TRfg6ek02AJ9+oJS0frQ+yUsT +QDUFTH2PvZRxj6wnYgV0ZXh0MTqIK0tJIGFtIHNvcnJ5LCBJIGNhbid0IGRvIHRo +YXQKiD8DBQA6iCtLN8q1H7eRA/gRAi0DAJ9o2VDTqQeDrrq0kJHNk0X4OnpNNgCf +fqCUtH60PslLE0A1BUx9j72UcY8= +=BlZH +-----END PGP ARMORED FILE----- +") +(define sig-lss-invalid " +-----BEGIN PGP ARMORED FILE----- + +rCdiBXRleHQxOogrS0kgYW0gc29ycnksIEkgY2FuJ3QgZG8gdGhhdAqIPwMFADqI +K0s3yrUft5ED+BECLQMAn2jZUNOpB4OuurSQkc2TRfg6ek02AJ9+oJS0frQ+yUsT +QDUFTH2PvZRxj4g/AwUAOogrSzfKtR+3kQP4EQItAwCfaNlQ06kHg666tJCRzZNF ++Dp6TTYAn36glLR+tD7JSxNANQVMfY+9lHGP +=jmt6 +-----END PGP ARMORED FILE----- +") +(define sig-slsl-invalid " +-----BEGIN PGP ARMORED FILE----- + +iD8DBQA6iCtLN8q1H7eRA/gRAi0DAJ9o2VDTqQeDrrq0kJHNk0X4OnpNNgCffqCU +tH60PslLE0A1BUx9j72UcY+sJ2IFdGV4dDE6iCtLSSBhbSBzb3JyeSwgSSBjYW4n +dCBkbyB0aGF0Cog/AwUAOogrSzfKtR+3kQP4EQItAwCfaNlQ06kHg666tJCRzZNF ++Dp6TTYAn36glLR+tD7JSxNANQVMfY+9lHGPrCdiBXRleHQxOogrS0kgYW0gc29y +cnksIEkgY2FuJ3QgZG8gdGhhdAo= +=phBF +-----END PGP ARMORED FILE----- +") + +(for-each-p + "Checking that a valid signature is verified as such" + (lambda (armored-file) + (tr:do + (tr:pipe-do + (pipe:echo (eval armored-file (current-environment))) + (pipe:spawn `(,@GPG --dearmor))) + (tr:spawn "" `(,@GPG --verify **in**)))) + '(sig-sl-valid)) + +;; ??? +;; +;; #for i in "$sig-11lss-valid-but-is-not" "$sig-11lss11lss-valid-but-is-not" \ +;; # "$sig-ssl-valid-but-is-not"; do +;; # echo "$i" | $GPG --dearmor >x +;; # $GPG --verify <x 2>/dev/null || error "valid is invalid" +;; #done + +(for-each-p + "Checking that an invalid signature is verified as such" + (lambda (armored-file) + (lettmp (file) + (pipe:do + (pipe:echo (eval armored-file (current-environment))) + (pipe:spawn `(,@GPG --dearmor)) + (pipe:write-to file (logior O_WRONLY O_CREAT O_BINARY) #o600)) + + (if (= 0 (call `(,@GPG --verify ,file))) + (error "Bad signature verified ok"))) + '(sig-1ls1ls-valid sig-ls-valid sig-1lsls-invalid + sig-lsls-invalid sig-lss-invalid sig-slsl-invalid)) diff --git a/tests/openpgp/privkeys/1E28F20E41B54C2D1234D896096495FF57E08D18.asc b/tests/openpgp/privkeys/1E28F20E41B54C2D1234D896096495FF57E08D18.asc new file mode 100644 index 000000000..d0b621a16 --- /dev/null +++ b/tests/openpgp/privkeys/1E28F20E41B54C2D1234D896096495FF57E08D18.asc @@ -0,0 +1,9 @@ +-----BEGIN PGP ARMORED FILE----- +Version: GnuPG v2 +Comment: Use "gpg --dearmor" for unpacking + +KDExOnByaXZhdGUta2V5KDM6ZWNjKDU6Y3VydmU3OkVkMjU1MTkpKDU6ZmxhZ3M1 +OmVkZHNhKSgxOnEzMzpAZ8zkuQDL9x7rcvvoo6s3iEF1j88Dknd9nZhLnTEoBRkp +KDE6ZDMyOnicJkwzhZjYg5Fd8zqmEsZLPdGwe+z+8DU6lq6zj5HcKSkp +=ZStX +-----END PGP ARMORED FILE----- diff --git a/tests/openpgp/privkeys/C6A6390E9388CDBAD71EAEA698233FE5E04F001E.asc b/tests/openpgp/privkeys/C6A6390E9388CDBAD71EAEA698233FE5E04F001E.asc new file mode 100644 index 000000000..939e8ab8d --- /dev/null +++ b/tests/openpgp/privkeys/C6A6390E9388CDBAD71EAEA698233FE5E04F001E.asc @@ -0,0 +1,27 @@ +-----BEGIN PGP ARMORED FILE----- +Version: GnuPG v2 +Comment: Use "gpg --dearmor" for unpacking + +KDExOnByaXZhdGUta2V5KDM6cnNhKDE6bjI1NzoAqBvNbHXRfWWcek7De5Xpw8bO +d8KibdW2sE6F2ZeqifoTvLTDcv2lIGqqovKQuRV9x5UkUIY0RQ0F6uI0d/o3nBSt +8H8JsUylzCoTeds4UiFgpRA+O+egd8DyE7sABtlmBXHApYa7Vl/I/sASuSKS1VQF +0JzkWSzj+381GZDtSg7t2z+A+n9S0MmrSM4EtPHZ5aelr7CQ65FHhmOkebJqcfX/ +j6gVX1FaZnJGzDkfgWDybaZWU9JXs+KlrJnVm6lO2YXb54TBnE2wW5PVm30dSCab +YoHrivL01NuCadhUI+oiAVfTg41H69dRCelt07x2lrnXXdIX1/Q58h/a4IawxSko +MTplMzoBAAEpKDE6ZDI1Njog6qS8HovBCoLrvf1v9wg5YfWupIlKiWTGu/FgjF6D +uthfhGOa4giRwuEbm/RzkT46NL1SGR0mAilM9zL/5Ro7cR8n7rAWq+PxCLIck6zB +BDEY0QfmkfGtUTX1YBHexXXBDieDIdEP1hyUqUZhQuBObi/fS8E4pt4TMjLTCTo1 +XEqZxqvK11AD6y2GddnCtH8vTgUaALzxNks23nngDEAdaDfJMHobST4Jb9RYVHNN +zsZnLkKRr+GIemOoRXlCvTmTaw+8Vh6vUq8OWB5jryNxmt64FtWAHpLcW0n5OE6S +6OlndqM92Xe9NT12wu75Mn+qTYrVauSPQvVveZMakG/hKSgxOnAxMjk6AMNAbeJx +Bb6BlIWYMYrpAhkuPBgB3HvS0wZQ/n0j8LLEh+BJI8xa9HgDz7LOJPo00w6ERHvb +Q+8VVBP69wxwHFJSfxJsImqUmQYXgoA2n/6GAqfj4oFK/FAsFd350bkaFnZcSxqj +hJai8JQPku0cZqPudfRzThX5XIBbynMBNqIxKSgxOnExMjk6ANxpdW6WqMrWGerg +X1i4MQd9ofyyWaT2XaGrnwMJY1qUqAqPViqZWPpPmya8mVrT9XkajdtPUm0zVzeK +IjEScdvoS/pwkIMmM2+GRCFCo9zrsExeqa1cQpc8GFDZgynZ9/jXWeRiidU1xTMt +gANAiZWOb8Ww6ti9p+t96liUEB7VKSgxOnUxMjk6AK/BZIZC/C6GJyRhEoTBlzmn +nSC5eC6MojPTOQwd5VIkeEq4illBE7DF/5gFw/fufn7s+0vicZx/8yLH1mFYkbwq +DfuoY/Da5lnRFw6fGOj4N0ikS26FApjlh2DS09HtIFuNAhErr5PDPjF1F31XL/1M +50jkxfKPamxMiEs8it0VKSkp +=GHvX +-----END PGP ARMORED FILE----- diff --git a/tests/openpgp/privkeys/D69102E0F5AC6B6DB8E4D16DA8E18CF46D88CAE3.asc b/tests/openpgp/privkeys/D69102E0F5AC6B6DB8E4D16DA8E18CF46D88CAE3.asc new file mode 100644 index 000000000..86f6acfab --- /dev/null +++ b/tests/openpgp/privkeys/D69102E0F5AC6B6DB8E4D16DA8E18CF46D88CAE3.asc @@ -0,0 +1,27 @@ +-----BEGIN PGP ARMORED FILE----- +Version: GnuPG v2 +Comment: Use "gpg --dearmor" for unpacking + +KDExOnByaXZhdGUta2V5KDM6cnNhKDE6bjI1NzoA255CUJxFEKLVwEoSgwZqXd94 +AhjGUbMY6NXdFj5cCq0JmWZrbpT/5OblTrymiH1iLmI0ymo+/s8vh6NtB98dhr1s +yH3asNQfXZRfF+u5X5hLDNPF4sUelsl4+EUef0Hbc9U+e+8F8A9TMxELSqQ8Ul3H +u42hc+/ugkc1G/8++Sv/f60TqWcUR2GmuiAvkuS1WmdATMhwPr7vMfssV0X0mboz +32//b/UfuOyctso5FM+bRaKrEJDQ2WDg57yqnaqsKEgajW0jElpAVIn792W6YWKO +k4auYSpO5f7BVs40Z+bxKGxiH87z9fnmlYAsQwPOOxZwWaCSrReeheK6c6emASko +MTplMzoBAAEpKDE6ZDI1NjoYgHaQ5xkEJcvyhmZm/H8/doq9XnrkazZ7O5OimKsi +Jx4BYZ4uGdeBd9/bbKFTwaauMBddrIQstNFuW5BIJt9KGgtvRC3y49JABClRJ45o +mOVpSp3dkp+6s5hDHUsCvZvjN3D02LzxLx8u0lb6fopFp4rSD5dqB48KNTGQAbvK +hqYZ521wmTfYLiy9taVAhqZLHlhfmrHYmdvvKjdNE3tSActlHWXdu119rdHhJ0zJ +Rxx/N845rl+PXXdFHveQxCBhHBQpSUaKpte+ZbT4vrjyNugD6XjDi4HLI9CysUDP +A0IFD+BJWw7NgYY51yamT7nNcMD6bJdgtt1FXbSgh7jVKSgxOnAxMjk6AN7btgbl +HEHrKf77a9ptklDvd2bEkUOwj3bFavB1lpkliW1USoWMx97zjxRPzQOs6EoE7u9Z +JRDO8xA9ZbI0WOk7io5OHpVp1BHyeqebqfxHzN5wsRphu+peg7vYfENVf0lA8LIU +NeUkbfEWDQ+inXxqkgD51gPfrU3PRdCDM8fnKSgxOnExMjk6APxHMsTrjaUoITcI +LqT35wDinFnX1+OgKD00krcUmc+G0ylLMolVxsB4yDVIkY8QfhbaGtFoP45PCnxS +rvHKrTt/6sZJCWXf+3KaN0QSxyfi/mEPj3KbXhmaY6x8R4aB/M7ipLXNdj/308pu +a50YPwIYyX0L0qoRBBo/xQDgOsXXKSgxOnUxMjk6AMzWw92nzShDRzPZwBvb48YY +YzZFiFtJbcZ1n8DaiM7VmzAkRqwmCu6HPP/8IC4d6UkFUUlHyDyxSaKuA45Y+FR1 +Pb2/Y/mQVsBanK4i+1oL4fYGexFO0qjA+8l2+6BEWbKQX60nIcFXD2hAP0aqWDGO +lXrPhpWPRrwDd4j9DEvfKSkp +=1cwG +-----END PGP ARMORED FILE----- diff --git a/tests/openpgp/privkeys/EB33B687EB8581AB64D04852A54453E85F3DF62D.asc b/tests/openpgp/privkeys/EB33B687EB8581AB64D04852A54453E85F3DF62D.asc new file mode 100644 index 000000000..ede9a9159 --- /dev/null +++ b/tests/openpgp/privkeys/EB33B687EB8581AB64D04852A54453E85F3DF62D.asc @@ -0,0 +1,10 @@ +-----BEGIN PGP ARMORED FILE----- +Version: GnuPG v2 +Comment: Use "gpg --dearmor" for unpacking + +KDExOnByaXZhdGUta2V5KDM6ZWNjKDU6Y3VydmUxMDpDdXJ2ZTI1NTE5KSg1OmZs +YWdzOTpkamItdHdlYWspKDE6cTMzOkAWeeZlz31O4qTmIKr3CZhlRUXZFxc3YKyo +CXyIZBBRaykoMTpkMzI6VN/VGmlcwGBPcLTya2hfU4t37nMcFCKdNSXjJ5DFA0Ap +KSk= +=eVhB +-----END PGP ARMORED FILE----- diff --git a/tests/openpgp/quick-key-manipulation.test b/tests/openpgp/quick-key-manipulation.test new file mode 100755 index 000000000..4185601bb --- /dev/null +++ b/tests/openpgp/quick-key-manipulation.test @@ -0,0 +1,70 @@ +#!/bin/sh +# Copyright 2016 Free Software Foundation, Inc. +# This file is free software; as a special exception the author gives +# unlimited permission to copy and/or distribute it, with or without +# modifications, as long as this notice is preserved. This file is +# distributed in the hope that it will be useful, but WITHOUT ANY +# WARRANTY, to the extent permitted by law; without even the implied +# warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +. $srcdir/defs.inc || exit 3 + +export PINENTRY_USER_DATA=test + +alpha="Alpha <[email protected]>" +bravo="Bravo <[email protected]>" + +$GPG --with-colons --with-fingerprint --list-secret-keys ="$alpha" && + error "User ID '$alpha'exists when it should not!" +$GPG --with-colons --with-fingerprint --list-secret-keys ="$bravo" && + error "User ID '$bravo' exists when it should not!" + +#info verify that key creation works +$GPG --quick-gen-key "$alpha" || \ + error "failed to generate key" + +fpr=$($GPG --with-colons --with-fingerprint --list-secret-keys ="$alpha" | \ + grep '^fpr:' | cut -f10 -d: | head -n1) + +$GPG --check-trustdb + +cleanup() { + $GPG --batch --yes --delete-secret-key "0x$fpr" + $GPG --batch --yes --delete-key "0x$fpr" +} + +count_uids_of_secret() { + if ! [ $($GPG --with-colons --list-secret-keys ="$1" | \ + grep -c '^uid:u:') = "$2" ] ; then + cleanup + error "wrong number of user IDs for '$1' after $3" + fi +} + +count_uids_of_secret "$alpha" 1 "key generation" + +#info verify that we can add a user ID +if ! $GPG --quick-adduid ="$alpha" "$bravo" ; then + cleanup + error "failed to add user id" +fi + +$GPG --check-trustdb + +count_uids_of_secret "$alpha" 2 "adding User ID" +count_uids_of_secret "$bravo" 2 "adding User ID" + +#info verify that we can revoke a user ID +if ! $GPG --quick-revuid ="$bravo" "$alpha"; then + cleanup + error "failed to revoke user id" +fi + +$GPG --check-trustdb + +count_uids_of_secret "$bravo" 1 "revoking user ID" + +cleanup + +! $GPG --with-colons --list-secret-keys ="$bravo" || + error "key still exists when it should not!" diff --git a/tests/openpgp/run-tests.scm b/tests/openpgp/run-tests.scm new file mode 100644 index 000000000..a921fdbe9 --- /dev/null +++ b/tests/openpgp/run-tests.scm @@ -0,0 +1,209 @@ +;; 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 <http://www.gnu.org/licenses/>. + +(if (string=? "" (getenv "srcdir")) + (begin + (echo "Environment variable '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) + +(define test-pool + (package + (define (new procs) + (package + (define (add test) + (new (cons test procs))) + (define (wait) + (let ((unfinished (filter (lambda (t) (not t::retcode)) procs))) + (if (null? unfinished) + (package) + (let* ((commands (map (lambda (t) t::command) unfinished)) + (pids (map (lambda (t) t::pid) unfinished)) + (results + (map (lambda (pid retcode) (list pid retcode)) + pids + (wait-processes (map stringify commands) pids #t)))) + (new + (map (lambda (t) + (if t::retcode + t + (t::set-retcode (cadr (assoc t::pid results))))) + procs)))))) + (define (passed) + (filter (lambda (p) (= 0 p::retcode)) procs)) + (define (skipped) + (filter (lambda (p) (= 77 p::retcode)) procs)) + (define (hard-errored) + (filter (lambda (p) (= 99 p::retcode)) procs)) + (define (failed) + (filter (lambda (p) + (not (or (= 0 p::retcode) (= 77 p::retcode) + (= 99 p::retcode)))) + procs)) + (define (report) + (echo (length procs) "tests run," + (length (passed)) "succeeded," + (length (failed)) "failed," + (length (skipped)) "skipped.") + (length (failed))))))) + +(define (verbosity n) + (if (= 0 n) '() (cons '--verbose (verbosity (- n 1))))) + +(define test + (package + (define (scm name . args) + (new name #f `(,*argv0* ,@(verbosity *verbose*) ,@args + ,(in-srcdir name)) #f #f)) + (define (new name directory command pid retcode) + (package + (define (set-directory x) + (new name x command pid retcode)) + (define (set-retcode x) + (new name directory command pid x)) + (define (set-pid x) + (new name directory command x retcode)) + (define (run-sync) + (with-working-directory directory + (let* ((p (inbound-pipe)) + (pid (spawn-process-fd command CLOSED_FD + (:write-end p) (:write-end p)))) + (close (:write-end p)) + (splice (:read-end p) STDERR_FILENO) + (close (:read-end p)) + (let ((t' (set-retcode (wait-process name pid #t)))) + (t'::report) + t')))) + (define (run-sync-quiet) + (with-working-directory directory + (set-retcode + (wait-process + name (spawn-process-fd command CLOSED_FD CLOSED_FD CLOSED_FD) #t)))) + (define (run-async) + (with-working-directory directory + (set-pid (spawn-process-fd command CLOSED_FD CLOSED_FD CLOSED_FD)))) + (define (status) + (let ((t (assoc retcode '((0 "PASS") (77 "SKIP") (99 "ERROR"))))) + (if (not t) "FAIL" (cadr t)))) + (define (report) + (echo (string-append (status retcode) ":") name)))))) + +(define (run-tests-parallel-shared setup teardown . tests) + (setup::run-sync) + (let loop ((pool (test-pool::new '())) (tests' tests)) + (if (null? tests') + (let ((results (pool::wait))) + (for-each (lambda (t) (t::report)) results::procs) + (teardown::run-sync) + (exit (results::report))) + (let ((test (car tests'))) + (loop (pool::add (test::run-async)) (cdr tests')))))) + +(define (run-tests-parallel-isolated setup teardown . tests) + (let loop ((pool (test-pool::new '())) (tests' tests)) + (if (null? tests') + (let ((results (pool::wait))) + (for-each (lambda (t) + (let ((teardown' (teardown::set-directory t::directory))) + (teardown'::run-sync-quiet)) + (unlink-recursively t::directory) + (t::report)) results::procs) + (exit (results::report))) + (let* ((wd (mkdtemp "gpgscm-XXXXXX")) + (test (car tests')) + (test' (test::set-directory wd)) + (setup' (setup::set-directory wd))) + (setup'::run-sync-quiet) + (loop (pool::add (test'::run-async)) (cdr tests')))))) + +(define (run-tests-sequential-shared setup teardown . tests) + (let loop ((pool (test-pool::new '())) + (tests' `(,setup ,@tests ,teardown))) + (if (null? tests') + (let ((results (pool::wait))) + (exit (results::report))) + (let ((test (car tests'))) + (loop (pool::add (test::run-sync)) (cdr tests')))))) + +(define (run-tests-sequential-isolated setup teardown . tests) + (let loop ((pool (test-pool::new '())) (tests' tests)) + (if (null? tests') + (let ((results (pool::wait))) + (for-each (lambda (t) + (let ((teardown' (teardown::set-directory t::directory))) + (teardown'::run-sync-quiet)) + (unlink-recursively t::directory)) + results::procs) + (exit (results::report))) + (let* ((wd (mkdtemp "gpgscm-XXXXXX")) + (test (car tests')) + (test' (test::set-directory wd)) + (setup' (setup::set-directory wd))) + (setup'::run-sync-quiet) + (loop (pool::add (test'::run-sync)) (cdr tests')))))) + +(define all-tests + '("version.scm" + "mds.scm" + "decrypt.scm" + "decrypt-dsa.scm" + "sigs.scm" + "sigs-dsa.scm" + "encrypt.scm" + "encrypt-dsa.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" + "armor.scm" + "import.scm" + "ecc.scm" + "4gb-packet.scm" + "gpgtar.scm" + "use-exact-key.scm" + "default-key.scm")) + +(let* ((runner (if (member "--parallel" *args*) + (if (member "--shared" *args*) + run-tests-parallel-shared + run-tests-parallel-isolated) + (if (member "--shared" *args*) + run-tests-sequential-shared + run-tests-sequential-isolated))) + (tests' (filter (lambda (arg) (not (string-prefix? arg "--"))) *args*)) + (tests (if (null? tests') all-tests tests'))) + (apply runner (append (list (test::scm "setup.scm") (test::scm "finish.scm")) + (map test::scm tests)))) diff --git a/tests/openpgp/samplekeys/README b/tests/openpgp/samplekeys/README index 20d9f5137..29524d512 100644 --- a/tests/openpgp/samplekeys/README +++ b/tests/openpgp/samplekeys/README @@ -14,3 +14,6 @@ whats-new-in-2.1.asc Collection of sample keys. e2e-p256-1-clr.asc Google End-end-End test key (no protection) e2e-p256-1-prt.asc Ditto, but protected with passphrase "a". E657FB607BB4F21C90BB6651BC067AF28BC90111.asc Key with subkeys (no protection) +rsa-rsa-sample-1.asc RSA+RSA sample key (no passphrase) +ed25519-cv25519-sample-1.asc Ed25519+CV25519 sample key (no passphrase) +silent-running.asc Collection of sample secret keys (no passphrases) diff --git a/tests/openpgp/samplekeys/ed25519-cv25519-sample-1.asc b/tests/openpgp/samplekeys/ed25519-cv25519-sample-1.asc new file mode 100644 index 000000000..54d204427 --- /dev/null +++ b/tests/openpgp/samplekeys/ed25519-cv25519-sample-1.asc @@ -0,0 +1,21 @@ +pub ed25519 2016-06-22 [SC] + B21DEAB4F875FB3DA42F1D1D139563682A020D0A + Keygrip = 1E28F20E41B54C2D1234D896096495FF57E08D18 +uid [ unknown] [email protected] +sub cv25519 2016-06-22 [E] + 8D0221D9B2877A741D69AC4E9185878E4FCD74C0 + Keygrip = EB33B687EB8581AB64D04852A54453E85F3DF62D + +-----BEGIN PGP PUBLIC KEY BLOCK----- +Version: GnuPG v2 + +mDMEV2o9XRYJKwYBBAHaRw8BAQdAZ8zkuQDL9x7rcvvoo6s3iEF1j88Dknd9nZhL +nTEoBRm0G3BhdHJpY2UubHVtdW1iYUBleGFtcGxlLm5ldIh5BBMWCAAhBQJXaj1d +AhsDBQsJCAcCBhUICQoLAgQWAgMBAh4BAheAAAoJEBOVY2gqAg0KmQ0BAMUNzAlT +OzG7tolSI92lhePi5VqutdqTEQTyYYWi1aEsAP0YfiuosNggTc0oRTSz46S3i0Qj +AlpXwfU00888yIreDbg4BFdqPY0SCisGAQQBl1UBBQEBB0AWeeZlz31O4qTmIKr3 +CZhlRUXZFxc3YKyoCXyIZBBRawMBCAeIYQQYFggACQUCV2o9jQIbDAAKCRATlWNo +KgINCsuFAP9BplWl813pi779V8OMsRGs/ynyihnOESft/H8qlM8PDQEAqIUPpIty +OX/OBFy2RIlIi7J1bTp9RzcbzQ/4Fk4hWQQ= +=qRfF +-----END PGP PUBLIC KEY BLOCK----- diff --git a/tests/openpgp/samplekeys/rsa-rsa-sample-1.asc b/tests/openpgp/samplekeys/rsa-rsa-sample-1.asc new file mode 100644 index 000000000..382d4e64c --- /dev/null +++ b/tests/openpgp/samplekeys/rsa-rsa-sample-1.asc @@ -0,0 +1,38 @@ +pub rsa2048 2016-06-22 [SC] + 5B83120DB1E3A65AE5A8DCF6AA43F1DCC7FED1B7 + Keygrip = C6A6390E9388CDBAD71EAEA698233FE5E04F001E +uid [ unknown] [email protected] +sub rsa2048 2016-06-22 [E] + 4CB4D8C018C57E60EB3847901D777619BE310D79 + Keygrip = D69102E0F5AC6B6DB8E4D16DA8E18CF46D88CAE3 + +-----BEGIN PGP PUBLIC KEY BLOCK----- +Version: GnuPG v2 + +mQENBFdqP+gBCACoG81sddF9ZZx6TsN7lenDxs53wqJt1bawToXZl6qJ+hO8tMNy +/aUgaqqi8pC5FX3HlSRQhjRFDQXq4jR3+jecFK3wfwmxTKXMKhN52zhSIWClED47 +56B3wPITuwAG2WYFccClhrtWX8j+wBK5IpLVVAXQnORZLOP7fzUZkO1KDu3bP4D6 +f1LQyatIzgS08dnlp6WvsJDrkUeGY6R5smpx9f+PqBVfUVpmckbMOR+BYPJtplZT +0lez4qWsmdWbqU7ZhdvnhMGcTbBbk9WbfR1IJptigeuK8vTU24Jp2FQj6iIBV9OD +jUfr11EJ6W3TvHaWuddd0hfX9DnyH9rghrDFABEBAAG0FnN0ZXZlLmJpa29AZXhh +bXBsZS5uZXSJATcEEwEIACEFAldqP+gCGwMFCwkIBwIGFQgJCgsCBBYCAwECHgEC +F4AACgkQqkPx3Mf+0bd5kggAphS7UDycKadfaRH5JENmKXeI+UUd+E0iERwv7eXq +RcgjNK1oHQSXN+ejDEXzZv2fcCRB7rWEvEXL0pCtPveyzDAQJdhZTRVgmfCXTr1m +9pJfVC3B20jgx6ZxZO8jKDL+bqvufWJczWDT0iHP0Jv04SqASLRs2JRPy+a+w3GJ ++DzG8orfAKiIE1Qycovr8Ol+jdo9ZV9blRA8/j4eqZYg4b7AOf8/mDyXsx3xzSPV +uwkDSluhaOrsV8N0suZ51rfdpapv6VJsXlyQbceJwwgSt2A1n2Sw3ZINwpO7BODy +wO6J44751+qY4cmap4NItyqGQTT6TUEL9ANfrZFmPWmFWLkBDQRXaj/oAQgA255C +UJxFEKLVwEoSgwZqXd94AhjGUbMY6NXdFj5cCq0JmWZrbpT/5OblTrymiH1iLmI0 +ymo+/s8vh6NtB98dhr1syH3asNQfXZRfF+u5X5hLDNPF4sUelsl4+EUef0Hbc9U+ +e+8F8A9TMxELSqQ8Ul3Hu42hc+/ugkc1G/8++Sv/f60TqWcUR2GmuiAvkuS1WmdA +TMhwPr7vMfssV0X0mboz32//b/UfuOyctso5FM+bRaKrEJDQ2WDg57yqnaqsKEga +jW0jElpAVIn792W6YWKOk4auYSpO5f7BVs40Z+bxKGxiH87z9fnmlYAsQwPOOxZw +WaCSrReeheK6c6emAQARAQABiQEfBBgBCAAJBQJXaj/oAhsMAAoJEKpD8dzH/tG3 +baoH/0KI3pIUiIYiLESGXqF+s/W2BmGNwdkYldcyFwkXz84VXoG0B3k7nrwT2DOJ +AEeToavzd3J+aZ4PmxBRAMtDhah0wsMXrwCI8y9Stmm6PIssnu9IP9+jgr4IkKIR +UB/Wn6nzgseaNd7vN4JChCyLSvF+vLd3D56Wzq+hBjybaE+zcEusVLdKYDm2i0YC +pkBkmSuC18lLxhNC8oSCCvVOiyw+TqGHhLnrpA4nGi0MLjAR3OgJ5d/TclYgkLcp +yOupg9GplQsAZUFfQPrY80SJuN9ijBp4xtA1U+WCGKh4ySv1+odpRjPX3eOGUFKZ +sJRKpZupoGWfVN78wm1nPLBKTvM= +=6N/A +-----END PGP PUBLIC KEY BLOCK----- diff --git a/tests/openpgp/samplekeys/silent-running.asc b/tests/openpgp/samplekeys/silent-running.asc new file mode 100644 index 000000000..e7c6db3a6 --- /dev/null +++ b/tests/openpgp/samplekeys/silent-running.asc @@ -0,0 +1,120 @@ +-----BEGIN PGP PRIVATE KEY BLOCK----- +Version: GnuPG v2 + +lFgEV3IffxYJKwYBBAHaRw8BAQdA0exktohYX2Qglxscg720r5ztQNXO8EP9sOE7 +HDy0V+UAAQCrqLqMY3RkiCZfrUTncLPw1sKwswv4CzXrTz9J1FfcqBF8tBRkZXdl +eUB0ZXN0LmdudXBnLm9yZ4h5BBMWCAAhBQJXch9/AhsDBQsJCAcCBhUICQoLAgQW +AgMBAh4BAheAAAoJENGdIrBu54ZoG3MBAN67BaQAle/6688gLNHd7NAK6Y4wpZjp +XQ/f7IvK0pLfAP9OMpB1F9ZTkKSnUK09xbcTZ4cjpXxeWOV9WByAlAALBpxdBFdy +H38SCisGAQQBl1UBBQEBB0Df5kbxuQhCob7r2HS5o1qlKETsFQ+vuvjnZChSMI66 +bgMBCAcAAP9nJLg2+ywR8nkhq+4jCavrLsg7ZeVdD2XVxBGNORf1gA/fiGEEGBYI +AAkFAldyH38CGwwACgkQ0Z0isG7nhmgUMQEAiqUsUHufGyswOGYbyKXzJRDq5++d +dKTGRdSNaqrEfy4A/jZjfQb6h2QxwYd5TODiTkH7E9cVV606xkAPksgtnVAPlFgE +V3IfjRYJKwYBBAHaRw8BAQdAkeNVby/yL09w6/kK7YCoQfY7eX/p8Vrt7mIC0+iP +5jEAAQDFDD31lYLVNxo2tDeOa2bAlCAt4NwVz/TbkzW/5fK5MhEatBNodWV5QHRl +c3QuZ251cGcub3JniHkEExYIACEFAldyH40CGwMFCwkIBwIGFQgJCgsCBBYCAwEC +HgECF4AACgkQO1PIAKpZJYNglwD/ctHCJHYi1/voImCwHH5X/I6CidNX3NXoOhF8 +qdwKnUEBANAT43oV9dLyWtmeIR5on6pU0AAcrIRQFCF4+nmU7UoOnF0EV3IfjRIK +KwYBBAGXVQEFAQEHQKOiOA8BE49l+sYsTCNXuzqO+KX3z2yoxQvBHESc+X47AwEI +BwAA/34rrv4xMpH7nLMFy0YZ704KJXVF9F8wF2ezOmJLa7OoD0iIYQQYFggACQUC +V3IfjQIbDAAKCRA7U8gAqlklg0UyAQCxOjO3xMym0YykBollbcl0dZVYSxC2uJin +1sHNuDPHJgD9Gtivb16M8Uki1nbvGGtBAL9d7gWkc9Bc3y/hTVyx1QSUWARXch+d +FgkrBgEEAdpHDwEBB0CeoZAXe1DVjhfuO0cmGrwj9N7jKtK0Piri1sLyRFxOYQAB +AI0E37I3sdgBE3TMsXmbTYQthNpAqig4qZCW/QYbRLa+D0e0FGxvdWllQHRlc3Qu +Z251cGcub3JniHkEExYIACEFAldyH50CGwMFCwkIBwIGFQgJCgsCBBYCAwECHgEC +F4AACgkQf9VUPZH3nAdD2gD9EJsV/2gjNtyWaUyh3TPdp3++1Mpr8Y/GsO8idxvM +JdABAKszZ+7aUjU2dGRWJ1tjHXO45PRdAZhBD0/BNFF4eS0MnF0EV3IfnRIKKwYB +BAGXVQEFAQEHQFA82/BnrK3JntjvGKIkXN9LCevdNFx4T2v9JzJUxJwZAwEIBwAA +/1h2uhoBkxjdsU4VNgydEqFTVdcAOuqOFoGa9rlXcnzoDw6IYQQYFggACQUCV3If +nQIbDAAKCRB/1VQ9kfecB0sqAQCDOeZpp4AjSREuQKLqGsxj2by8ZLcrcF8CT2Qr +BoDljAD/WOCVNx8hIpyQ/40dzqUDQ79uwYEEUV1EF74aoQcqJg2VA5gEV3IfuQEI +AO5PDCysh81uBsbKNZZSusUJOluMbgywXXw3XUa8cV8hdA50rEJifG7Lsg0jAQDp +wjoPVPadmYcEA+p8q4j2vVcZaROmlahSjQEFePceH8Ufvl6JT/NgEyzkLMThsq/Q +XMxhzU4942p5PO/IG2vFCcVYo01/utuxv/UAgBQZ9qVkk0VN1JiCk9uckJLaX93M +jLLGifEPDAmQxpHsMvAZxoRSeZlgYqxBvizv0UPovgutdWpQ7hyKKuA3ceYOPVPI +PX7fhBJ3JhSqqaOMoK7+EW3b06fjHD6sbSSi7SMJeMgvyI86A/rtJSvpJV16WfQb +3hBBR2/QR6XzmavlL7+Nr60AEQEAAQAH+gKEKyi9maF9q+ylbfNsZDR4aHlW/kJ8 +CkCphP6eNsQ+Yi9U5Ay/ZXj2BadF21jbHwXl64u/FkPqsu/i6RzFHjKxPf7LH4Fr +fbmpCSHy23sFXsk4wfNb7FfpAOADUhOxK4ms7rIIzUHujcoqXr/AkN3YlcDXvG1d +bx1zJ+cObyBH7l5lLZvvl6jLiV+XOWxX3lU95F3akFOuI9q39uhPxn009mVXCNqJ +Jo8OwoPmScADHLYYfv110ywdVQwxAFwBX1oPZ+on/llHnkgf0ijnc/xvdf+zFFEq +qM4bjVbhRiA8ibWvWH+ac2Itcar6esroHt1kgIUM2ee+PK6ub5on37EEAPC4HVh0 +5poQZORMy0kQc/nc9kz9K9VD6cI+bcQiyr606qre6gUVhfr9L+XibpK/6Fdzbcwc +Aug9M7L+QruFQRxtGXj4R07GnPHP83OIGoGYATxcOwrJ3uCCwIS5vK8m9X7Alzaq +zzCmf1wXW5h8rfcztY/Wmxk88Deswwjysn2PBAD9b8L6/LDXnaRfpgXV2i+hON/r +qNCmZ4Oss77w62Qw4V2YmtuoeeBaC79Wa4nWGSON+uFAWn4lzb3EQshYADMFKejT +xd+/KFTowRAxUq9wzS4JjF4S2FN6l2TVA7V6pK54VmJdPUTN0JNG5eFuFiqoJsS4 +gQY3Ead60BtjQHjZAwP/c4AUjetPX23G4pINGrV0Dfw8xKWMSFjf49s2XnJ0tRCS +gFj+jv9qLwivNzK5mqfz1iynbiqe4M4DIAjuPRcci95xBI0m7t1ECw6xeuunUp9x +IlzjX0vejGklA/qSN6oi91Bs/49rVKt6uhEwCi0a8ECr3y4+CCqJ530+boMT6opH +gbQbdmFsbGV5LWZvcmdlQHRlc3QuZ251cGcub3JniQE3BBMBCAAhBQJXch+5AhsD +BQsJCAcCBhUICQoLAgQWAgMBAh4BAheAAAoJEGd0fnraHQ8MWjAIAOMIyXGSfmZh +q6dT4/R/KPRMHiWcZq+1RpHH/it9uLLIkxFn8disnIlYfCHFynj3HwQNWYAmSPQe +jC38O7UVftlWp2zxBw6719YKiopZZNy60/iRgDb3vv1fFxkq6kE+XtXW3n2m/piQ +cI/jY2LRyIkVOEGDvFWcAF4iDHgkQrV4uLH0dmCzg2fIVULBT0ITtybUtOOJmrpp +E+yysTiHfewvhIgiOFzy+CZbdlPfVp3IUGhrNU9XiWraU38dwNXVYnE5uwotqf7G +U03pmw2GCA+txq3NofMM4kFHN+eVE4+lXUEhVJRXa4y2PgKFYmBFoED9SahuxO2o +1Cj+IpFgn2idA5gEV3IfuQEIALsnERBUkAFXZilIJRCpkbT6xhlsT1OZ7a+fHXwZ +1P3uElapJo9ODGX9T93s10GiL+KiXm32wxUP1BdsFkFsnahzo+U7OrB35ASDNpkl +p+CbO+UrUAIPD5NGpWuHKoPzc+SwW69fTeZyLRHqOldOA88/6veA9vbCTYGgpyAR +kwMLKqX6EDnX+mbNhKEEixWp1Elw5OCv7N0NbFLIZ9YTTOGpn/HvHv1CCmlrlc/W +BnJJE0D6345FslQ77V0ImMpNlEl8fy53g4JAYYW/w+CnXHl2vVD8ye9lKuFwB62n +vAnpjOEbAtyOncm2quSkBlcv0jo7EGDMxH31ki+yDuQeoPUAEQEAAQAH+QEwC5ST +pmeAky/lrgKJXCWoLI11wABTHj+6kUVvC1VIzcn9M2okzMEkiePp849bKzwGqFwn +Sdak4PiWR+l5xuH0r4OuMnGmcrmxAXqYU0fo6q9KIC0n9+lvdDywWppqw/+dobKF +UGlX34xZDnsf9ITVexuMY6s7BKKzDv+nmbJWIx9PehNUlh7Ucvy0/Lm0hHr/G1B/ +6ziybm5gCUTKBm4MsepTCCyFf/C/i53l+qdHUnWQdg+lGoU3Y98MiRM7Zr2QKznJ +fn74eVlYi4byjKeFujQyIw8tbH+G/RWw+WQzEjY8VLdLMf6u/T1g6htumQxPDLIQ +WxPz29ney9+WFZMEAM7itO8IEFUqy9MLp2kjRlwCMc+rRzLzh1d2c7gbdtxCOVoc +krq5QPeOyWM7IMxImvcTXJUB2jQikw7NXtCRfDHD2egyJRGN2J5SdE2EHvQRtFwl +6GoQ+mrJnPqetSoSZnC54HrlxIZEWE1Tzg79JoDbzPkwRKY8MIf4U3NniAmnBADn +lRsJLygRb1xZ5aUhRkJc8KYdwrcCSgG5gvm+yzv5aOMXWU1P65GARCUFEOzHJVMs +ML620SKS3RQ50hM1QLYSdox/vuEyk5m7Ty6cSGtagvohckWFh9Jry5FthlMYqVzR +HZmZXlCngc7umuWrzBdtAJAQt9sQ9M41iCjn8k3cAwQAu92QEan/m46qnszif++G +PzrbwKFsQzU45DPCx4QXBcnZT4jz3a2vSq99COBob4oVlETP2S6wy8w5KS4xQXVN +Q88TZZmJwdxsw5cUc3ANapMofwhrddhswFF/lmE1at1J0Uvpq79ZJt7yaSmZibXy +jDc3ygf26B0SKThVA4IUzYQ3u4kBHwQYAQgACQUCV3IfuQIbDAAKCRBndH562h0P +DP/rCACNRLCM6oyCyu+bB+UFdgN1UMsPGmh8xlfHFB3WG24JWDflEgN2Co+5ltzo +CI8AQ+6va86PeE8LgLCvLhrZbCnCxmjPb4SIHgPLC1aaTM9mu86iDLEERHEBLVhS +n57XSLpJqZMXSIJO74BGn+t0sBSZvGtQF56EImc9AyTLW99EPc4rXARL/V850rVa +PzTVbDOfm5lRbmt1+G0mo51SrFZh0Vy0cydk6uGpqxxkxE5y54vBMyZuUMmlkr71 +14TPfuNB0Wkd7coE3xKPOp5b+ntDPAuxgXej8OtrBeZxcOnSP84IcATSkReMIqJy +31+hvjDtkhZq0FMIBmz0RFFmS7+qlFgEV3If3hYJKwYBBAHaRw8BAQdAfyxylIVJ +wo+mAg95LN3U9BHYRtKa0tPmOgDzYKcTElcAAQC/fqSbQ5ghgYJ2/F+Nl2ZA1+co +EE4o48YvknnmcP5OpBCstB1mcmVlbWFuLmxvd2VsbEB0ZXN0LmdudXBnLm9yZ4h5 +BBMWCAAhBQJXch/eAhsDBQsJCAcCBhUICQoLAgQWAgMBAh4BAheAAAoJED3AlPrw +yKQlrNcBAOsJAoLfXYv+z519rALFI+crxv5z9p2xXSplKliWNJ+ZAQCvpfUIDynR +n/s+IBGjwR30BlZF63NxQ9i9cIxUBzXSAZxdBFdyH94SCisGAQQBl1UBBQEBB0A5 +052JXUgFlcERPDwoQqJIbLIE3hoFp3qL3/YvPuOFawMBCAcAAP93FWcg/I/NAq0j +spa8n8gVgn8FZA9RqGptElNIHnamgA5siGEEGBYIAAkFAldyH94CGwwACgkQPcCU ++vDIpCWaCgEAwkDqEeC+fCKkoNAslozwf+VJQDNpzzpLaDwO5oSZaiwA/3jIErkx +UMuG5sa5hR6CYVY8Iiwy4NRCM/r66oDqwr8OlFgEV3If8BYJKwYBBAHaRw8BAQdA +GwS/1um/1QQXarZFcDgmaYjRBc/m4BV9iQVOrJBIroEAAQD8rIxduReDq/gYofIG +GGfOF1Smb4XCQ30uZlkIMDR6+Q7ZtBpqb2huLmtlZW5hbkB0ZXN0LmdudXBnLm9y +Z4h5BBMWCAAhBQJXch/wAhsDBQsJCAcCBhUICQoLAgQWAgMBAh4BAheAAAoJEDIG +dpEV2WgEG6sA+gN5F+IftoJ3cSONXL5mddA9TTX0VV6Znf0OyvBv0DDnAPwNXZVa +eCr4OfGNkapOViamN6ndRzT1OYbU1gvcKNwUDpxdBFdyH/ASCisGAQQBl1UBBQEB +B0BVSesW6o8soaWsMmvizFt7dwYAt4GdoJUA0aKyTTAFWAMBCAcAAP9vJIIHAR/w ++IvwZq0POVxmevdWXJ78tA/yvY2e12P0mBHbiGEEGBYIAAkFAldyH/ACGwwACgkQ +MgZ2kRXZaARftQD+P4TwgTJdftgvk1H60MoCN9B4RLH2pieeiHTcqvrErE4A/2y1 +ynHx1S3VwE8C++aZ5/WLiv6Dtjd8JKjw8wKEqswBlFgEV3IgBhYJKwYBBAHaRw8B +AQdAbqmt5oTNiHg1qhAylVX2eHdXSDCzovbZ8q7hrZpd95oAAP497J3U+4M4G+Ec +hW30e+Ye7DArAzVj+moq1tVCZVe3pRFAtBtNYXJ0eS5CYXJrZXJAdGVzdC5nbnVw +Zy5vcmeIeQQTFggAIQUCV3IgBgIbAwULCQgHAgYVCAkKCwIEFgIDAQIeAQIXgAAK +CRAGGYXu0KJiLW1OAQD9KtP+snTW+rOA4EtquLI6e3mk9geLTICbNo8bk58v/gD/ +QkFaXjRkRwD1S9X1z6rWPR3fH0CHfyymyMKgmoelgAOcXQRXciAGEgorBgEEAZdV +AQUBAQdAycZZHE3yuTQECmpx+X+hgjR38KPxKiQ51OSB6WsFrC0DAQgHAAD/VUz9 +WYTnMkjvH7JZCw7yswLBO/FVJFlqrXsDlNMYBzgOxohhBBgWCAAJBQJXciAGAhsM +AAoJEAYZhe7QomItaZcBAMCzB1ks9GOQL1og/q643obuGoB0xmsUJoQO2xo67z0o +AQC7NeBSnzYXfGwvPwsc9kgkgMt3RmzuYgwdyRtNOL+GAZRYBFdyIBQWCSsGAQQB +2kcPAQEHQDDvfVidNYqiTBgBqDDTa40gxTdrgO1q3ssIaOigtntlAAEAxbKQpqA8 +huHRHAiQXkUaRAKLzP5xPDHnnqN5u6GeMDYPrbQYQW5keS5Xb2xmQHRlc3QuZ251 +cGcub3JniHkEExYIACEFAldyIBQCGwMFCwkIBwIGFQgJCgsCBBYCAwECHgECF4AA +CgkQFO3P+6onnuT3IAD9Ek+AmmvN9CU3LdLl0ADX2ba92fY++8u11AZULvys/RkA ++wRix4Rw1xL59EpowGWGuZ9Ky9aG5w7iZICBakgvs+QBnF0EV3IgFBIKKwYBBAGX +VQEFAQEHQCdfyKinwttnpD0M/OIZGMwkLHtPdAgOnvnpdj8/gNxEAwEIBwAA/27g +/G5idxYoUaAsG8cq5ziA9OvRovQKT3E6MLGIBv7QER2IYQQYFggACQUCV3IgFAIb +DAAKCRAU7c/7qiee5KeqAQC96Df0rgZteOKtiMt+wXwQufkjT5XrDWNyvI+NaVhS +2QD/cUSRyh72N4sp8MV8BhN9RE+snFc2OW6ROafIizDtRgE= +=tU5z +-----END PGP PRIVATE KEY BLOCK----- diff --git a/tests/openpgp/samplemsgs/clearsig-1-key-1.asc b/tests/openpgp/samplemsgs/clearsig-1-key-1.asc new file mode 100644 index 000000000..4673c4007 --- /dev/null +++ b/tests/openpgp/samplemsgs/clearsig-1-key-1.asc @@ -0,0 +1,17 @@ +-----BEGIN PGP SIGNED MESSAGE----- +Hash: SHA256 + +You are scrupulously honest, frank, and straightforward. Therefore you +have few friends. +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v2 + +iQE0BAEBCAAeBQJXakWmFxxzdGV2ZS5iaWtvQGV4YW1wbGUubmV0AAoJEKpD8dzH +/tG3OiIH/18NlMSXXRFRrxXq9OZySzJxgLI7BjGilRTqb4ALeFzNjmCwu3Y+Gkdg +t7NjYjSe0erWiKYDEmALICwcpmSmXHA//gol3QkHJKIlKQGXJP1qLvIde5+lnK8K +YVwLKLBQBQtlGMkMXPdUEn9PgzSoBFoFIqrzQmAdLO3yijSdm0Mzl9wyIhtbUXk+ +VgX2d/6DRIwcKcFoX2QbFlM/z1kdrS6cOYFbJWavEpLDz9ON8Q8a8uqcBiqRlSpW +eGOMMsysJs+44+qX6uE3hu2KJE9xvHwhSjJOxqtw8dN3KZ1+8IkxsDrvDAhn+Klf +Hbtj647f/iTOF88o1ihO7goDi93Bpv4= +=xAv4 +-----END PGP SIGNATURE----- diff --git a/tests/openpgp/samplemsgs/clearsig-2-keys-1.asc b/tests/openpgp/samplemsgs/clearsig-2-keys-1.asc new file mode 100644 index 000000000..0d7823ec1 --- /dev/null +++ b/tests/openpgp/samplemsgs/clearsig-2-keys-1.asc @@ -0,0 +1,20 @@ +-----BEGIN PGP SIGNED MESSAGE----- +Hash: SHA256 + +"The geeks shall inherit the earth." + -- Karl Lehenbauer +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v2 + +iQE0BAEBCAAeBQJXakX/FxxzdGV2ZS5iaWtvQGV4YW1wbGUubmV0AAoJEKpD8dzH +/tG3g1AH/iQakK5FoXpNQs6Nj9NR4NUwtIPmlLS/Tas21CDs1Lo1Fum1gjU0VUFN +63+FTnbRg8nXfee9RPddLnec9lYWVqWSkggTFER8qQrj/EurltLMv/tHAZ+B0ueI +mh2XkNHA6KXu3DFipAXQezWaUqi485TGTY6Qv9JtG/plOZBakcRTgCSAamyaDPBA +PHgp85bPf5Zu4aFRBfmJp+IUH/EFLNFIHNXpYyZZy5ZdB3GuhAHGFp6tlpRFk4Z5 +vRU9BtdoeiIeoRHp4orMESGlbeZxUXG3CCrgzVk0e1pab0NrehwQ23+axMxFipya +t6mi8Zrxpp7eFc9+ozp+7r4cH//uw8+IewQBFggAIwUCV2pF/xwccGF0cmljZS5s +dW11bWJhQGV4YW1wbGUubmV0AAoJEBOVY2gqAg0Ko1YBAKVC98xZvGsNoaq0yDHG +AJKmsvjnc8z3qmEHzGtxOQCiAP92ffXZr0EM4qNqbDR0EAws9qNo0XlDPcm0LDxy +0JVcDw== +=Ta4l +-----END PGP SIGNATURE----- diff --git a/tests/openpgp/samplemsgs/clearsig-2-keys-2.asc b/tests/openpgp/samplemsgs/clearsig-2-keys-2.asc new file mode 100644 index 000000000..992f2baf9 --- /dev/null +++ b/tests/openpgp/samplemsgs/clearsig-2-keys-2.asc @@ -0,0 +1,20 @@ +-----BEGIN PGP SIGNED MESSAGE----- +Hash: SHA256 + +The very remembrance of my former misfortune proves a new one to me. + -- Miguel de Cervantes +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v2 + +iHsEARYIACMFAldqRlwcHHBhdHJpY2UubHVtdW1iYUBleGFtcGxlLm5ldAAKCRAT +lWNoKgINCubRAQC0VyMKKFXWWxLOwCFO5ovhONxq2VLQ6c7jklZt0AAETgEA8ikc +doPxIamOCta2QwgS0JHPhvgmL98GWM1dMLfD3gOJATQEAQEIAB4FAldqRlwXHHN0 +ZXZlLmJpa29AZXhhbXBsZS5uZXQACgkQqkPx3Mf+0beYKQgAp60uW2OmVAyaP2MC +F6alWqWVkxw66L6QW6ciOpiuqjEoc9TN6pNIIP+MeSPu+SE71kw4nD0Vvu5mgH/2 +74dZMf7vFX3vERL/g8u7lTOv2GkXyKpFKAwvMxqPJ7zKUH9z6LxeBc2tNImjQ4mS +7OL30n+SPrsY4FR3BS/d/EY2y+L9spi92oiJeXjgNHH7iIr5iWiSSXS7AwBla0zu +r+mkX2Aats488CEfENACugg79q7cNLpUioeKdOHcqDxCS9wSpYK5Y2+IBqmFEv6t +DKZ1iZnLlk6rHpkZ8aQi96PFbZVZPGnxsOFKkNPWwHjniKeJzoJwd7FqR5i2vrsJ +UiWYwA== +=gWAP +-----END PGP SIGNATURE----- diff --git a/tests/openpgp/samplemsgs/enc-1-key-1.asc b/tests/openpgp/samplemsgs/enc-1-key-1.asc new file mode 100644 index 000000000..bd653307b --- /dev/null +++ b/tests/openpgp/samplemsgs/enc-1-key-1.asc @@ -0,0 +1,9 @@ +-----BEGIN PGP MESSAGE----- +Version: GnuPG v2 + +hF4DkYWHjk/NdMASAQdAPDV6Y3JTfAGDX8pfZcT6YggC7qV3g8B1ezijcfIcdVAw ++hCFGXS1EikBbZ21v79GtGh6Wp3fmyZFRQcsJZciLE/EFcbf9Mv4Q2qfRhKYHlqj +0lwBRYQrwTJbMNspOwd2MidjYYUxb/02PNiqZSrWUeX0iPsgHFToJol9RVAqs4Zz +bZNKL6y/GeRIRZY12Lzo2TIXSLfjvbMTdkoz53mMKiUXsi/fCKXkTmgIheni8w== +=kmqY +-----END PGP MESSAGE----- diff --git a/tests/openpgp/samplemsgs/enc-1-key-1.gpg b/tests/openpgp/samplemsgs/enc-1-key-1.gpg Binary files differnew file mode 100644 index 000000000..6f0fe4fc1 --- /dev/null +++ b/tests/openpgp/samplemsgs/enc-1-key-1.gpg diff --git a/tests/openpgp/samplemsgs/enc-1-key-2.asc b/tests/openpgp/samplemsgs/enc-1-key-2.asc new file mode 100644 index 000000000..e9e6e7040 --- /dev/null +++ b/tests/openpgp/samplemsgs/enc-1-key-2.asc @@ -0,0 +1,16 @@ +-----BEGIN PGP MESSAGE----- +Version: GnuPG v2 + +hQEMAx13dhm+MQ15AQf8DKnGFmadCHP3k8blxdRa73pC3BL0fn9YSp2+EvKP7n4Y +KsVHmKSZ43RL2pq24y5CImLCu6gPkyFGzTn/vmxq8E2Ul8WOvyJiEuRTczNr5NNs +rZiF7dRMSjeZXCEHme24XIXKGzbnlkALHxh83GpgxVmLqKIlHEjgXYn9fneH85M4 +KTBxIxpAhIKzninnGk2ikmAS2C6z370tRLYP+tQ6gcP8BbehCZFM+TRqyS3aXjdq +WaV3OgY7uWzj4P0PBXBWx0V829tfgRF9Z70Zx+HA1BpOqvmOcsztah1Jq/pyAaeR +7t2FunUZuUwbBIYg67/cxStYAXF9ih70tjSRfYBiotLAEAEvZfW1G7lMnfFCWxx8 +S8L+AD+BEdycI/kUZhgxFVde985CSYcpIcQZE4IuTYCoc96ZXsvil5Zlf5I//KDz +toq+bxa+VU4Gr+h4lbcq8Sj8OPkx11/P4dOyydiYKLqEThig5l/h5IiROL8AvIMf +TpNhu8TnECbjaEDaDt3RE3vIFP7ZV8zfpsibSFDaK9K0UhniSt/wF4NekBltUcBc +kozlxWbvQ0k3A+xl1dBCBEpFaJrywRYFvz2sY5ISJS1X3ePJ4c9fsPXePTiy9a3W +ItE= +=rFeH +-----END PGP MESSAGE----- diff --git a/tests/openpgp/samplemsgs/enc-1-key-2.gpg b/tests/openpgp/samplemsgs/enc-1-key-2.gpg Binary files differnew file mode 100644 index 000000000..c62b63a97 --- /dev/null +++ b/tests/openpgp/samplemsgs/enc-1-key-2.gpg diff --git a/tests/openpgp/samplemsgs/enc-2-keys-1.asc b/tests/openpgp/samplemsgs/enc-2-keys-1.asc new file mode 100644 index 000000000..abff59621 --- /dev/null +++ b/tests/openpgp/samplemsgs/enc-2-keys-1.asc @@ -0,0 +1,17 @@ +-----BEGIN PGP MESSAGE----- +Version: GnuPG v2 + +hQEMAx13dhm+MQ15AQgAkI1KV+RVcuDJlzwXShDT9d2r+1GlV2r16z5vp0aDLETz +Ga+OCTSiDR8So9xqM8kNKp12t2OrhmIerYu3dHQxZAWuqbhj/xkxfh0OyAP2wZb4 +MtwXIcRKWgUz5pUPYcp/7+Eo/dlBs1QaqxF8Lnh5jAlpxDeQvfSgjTZicZAS0rtY +XONLWaX4nuuHb2DNrQWLDsMvDrwu8fJLPMNy7+tEzECs1G7Tv7D9xu/QHbGw6Zvk +fxjWlLsD2nUQYwn/GpqitD02y7BHDoZKXIO8GccHdPhPOxZHLCiGIHQ7r61ResHA +3SlqEsNF9OV81RaIg55ndM72ZLbDTC8ZQDIu/5cXaoReA5GFh45PzXTAEgEHQIFu +PbA2WmzBGnzmBfXmRg8AVKE2JVvSYLjBynfTPbtKMAUbz9U2grH/0BdZPWaGuYUh +HNPg9vmmzL5Ch3rSSunzhtxadesh/Gsic9ETkFz/d9K3AVzb9WEneFuEkk43lJAu +X+btUyQ8rBhkmBQPorvZN+1i+NL0XOP3UJ0iIpo3bn/J7Dy9IEDojQAFtdOBuw6F +hbWOMoRVodE5aA6JcRDR2HLj68X3TAou91a8krHJ8NAK84ilrZd07XEwGtNbaom5 +rZK9xNFIUV0Ddog6r5rJ/pqsN6o3iEYI2uhh0KYntbIHrRD05ZWRCXhQIGPb6qp8 +wEEydtbQpfJFRru8q7Y0V6MlzYflxI1H +=m6X7 +-----END PGP MESSAGE----- diff --git a/tests/openpgp/samplemsgs/enc-2-keys-1.gpg b/tests/openpgp/samplemsgs/enc-2-keys-1.gpg Binary files differnew file mode 100644 index 000000000..1485b0430 --- /dev/null +++ b/tests/openpgp/samplemsgs/enc-2-keys-1.gpg diff --git a/tests/openpgp/samplemsgs/enc-2-keys-2.asc b/tests/openpgp/samplemsgs/enc-2-keys-2.asc new file mode 100644 index 000000000..ec6202ce6 --- /dev/null +++ b/tests/openpgp/samplemsgs/enc-2-keys-2.asc @@ -0,0 +1,16 @@ +-----BEGIN PGP MESSAGE----- +Version: GnuPG v2 + +hF4DkYWHjk/NdMASAQdALju99o8iXdJNYTuUNrk3ZgfLNvw4GuaLed/2PDLbLUEw +LaFnwh5u4djUOPPtZHbNzmJimOobJxYg3gwDew3ERLBqweQqRcqFaypu9+Ss86Df +hQEMAx13dhm+MQ15AQgAwHCbQ5TeyLGsrs+oC/dB7AZphqWwsSoVXTuxAi3NPbEF +upvp3mu19HpBJFXijsjysaMbwUGB+DRVhMYwAANfnJJ2oxltNbhMeGic/vRsCjHx +cJhjv/T0Jc3Yuh3YFlp4V3wMiTa7METMBL/2CQtT+MSQbBubkegcNPBkB5ss1civ +WpQckerDKtv9ik0+gvYCgHw0wLyf7UmHRekiJigUats0IhEHoZYv/qa3kvcmJaKV +WffHsOwxoS0jCwj15eV2YHQVJp7nnyxXlX9E7z4gzjxH4MbXpi+tVvBLGM8pHEg6 +EJ3U7koABqQ8446CnWC+OJKWO5cHoJjkOSCGALDoENKRAenz/t9qGzMWPInAx2iH +lNg2brHS7UM8z53ESeqpYfaHS1QiMvtZWo8Wl9QPJa8vfrDw/bCtNALYU/OHw95N +k9E+/JgWk9oQFc+syNHDJzw0qfEzblxzng5/d6W8vjggFkIrKwMwE1/6x1w6ZLoV +MYG0TXjnLNBGzGCFRSoDx/RuzybgdDSySV/6OFfPAMSo1g== +=iPxe +-----END PGP MESSAGE----- diff --git a/tests/openpgp/samplemsgs/enc-2-keys-2.gpg b/tests/openpgp/samplemsgs/enc-2-keys-2.gpg Binary files differnew file mode 100644 index 000000000..a2889cb27 --- /dev/null +++ b/tests/openpgp/samplemsgs/enc-2-keys-2.gpg diff --git a/tests/openpgp/samplemsgs/encsig-2-2-keys-3.asc b/tests/openpgp/samplemsgs/encsig-2-2-keys-3.asc new file mode 100644 index 000000000..e563e8df9 --- /dev/null +++ b/tests/openpgp/samplemsgs/encsig-2-2-keys-3.asc @@ -0,0 +1,35 @@ +-----BEGIN PGP MESSAGE----- +Version: GnuPG v2 + +hQEMAx13dhm+MQ15AQf7B8SvOp1oKADLmqzPCJp8kLUvt2oemNHYvSU06gTlTT8m +DGJnA8a4S0+3q3Oqt/CObBX5tNr9KIB3OOgL8LujUffFVo2A6qfBWYnpyrDeJQOH +idilyZvAu4CdovVvp+2DxAfBYNb0jinIjZEcF3YuIFqk1o5n9Jx0C3LDMgQwjKkb +xEZeUkjt4i9Pb2JNP6+LQ8deDwLLcpS5ykP98MTHgG1OGw5QX1xxKArEq4YJXye3 +ubQBAifE3fGKswGiV5UuwrP3cB92KdtqYLCckrheDa96YJp7kZNDPFds4aqaD5i4 +Ps/bxXeZmeybhgxTT8Q1Ld7wUd+sFV36uRieHOMEIoReA5GFh45PzXTAEgEHQEyw +MoBXgqtfF8+TdiUcIqeH+eXNOHjqGujt00BRn8JTMJNuCXoMZDmu45AaXZqiYxov +TTfDyKGLVvaiTxEJdl/ty55X9C9ANppdFm3qZGZ6GdLqAQBRsaHHa5lSfUBrgJXC +DLidkt1TA0u7owjuWRkUDlzBt3lEcgYEFd6c2zy3wxljpU0zB/gEmlEQiQAYB9dR +alrnENgo93aExGoTW0LgsZlf1n8GuPCyK+3m+1+2ryr3qNreg69Y5HaW3aV4pEG/ +mMnxVffq0sJGtEQRAx8dESImO+jPVmdKx6JcGWQ4B3RmD3qzOgbGwRoeC+C/isV7 +t+VEC0iOlC+QyK7S1QgxcWwzl9ExSs1d+BM3cwNlwe2mLckgsayEUGXrafpifiTR +w1CSyt25fb23iwOu1XZeHGnth/XAAJQcUsi02E+fpMPyS4S0v71PBn8By7iXHE8W +stFZMP9Gcly6lh9qOFg108P+mIWOVj7xtCUMl0RRwxS2hrKypucJtPSmVZ6EgVok +8j0tNm5nSjLzQ4A8I+O20Tx0sPBjmvH3IbMNCvjAQp6gXYlDgiHv2zxAgHwNJjRh +ft1AJy/61HG3MtRNV1QP06l6tofGAzP4gBBqLJkVcK1bCGpx17LZ7t9GI573Y7Jr +CIFN+CUWqzN64Q90IMDFwOl2ghQGZsIRh0jG3wOjd3C5cFo176BJiAq5WVelVEO8 +A3J/xMofeDdAVTkbpDpW+rE66I5dBwa8s9ej1zTpM0hmbiON+Ld9cCW3VPuDjjj3 +pAndSOcbfoq0Qd1RwshQVpfJJYjuhz9qCdlp392KWSvwTD/YuMIZ+nudgxk9Vbu/ +Z3ro/ggyH0FmnaJ53GnJ3NjsiJkSbQ21fSw0zJDNabpwdVPSzSvPtflh1qKiU60M +eNI/QI6lKyZzwFCuAkcZKGWGQrDLjmbRtSMJHAw2cT1sQQJ5XtciiL+pOixawyNE +pTnYI4f/983JewwweUwFJ5GkD/uY6hM10b4OKpjjm8rfpBVmW8rsuAGa5sSOAZB4 +xt+u6/dzVDCdQKtYV4pQHsHahAAkIGT1pWi0PMyWM3deo3sGaiCGcpM7qpO2qE4b +paimL2Un0J1qPkr4cbykzzUx4U1zgHUHKDPhmSEtqLfPEd2DjUHsAvJZJFER4lD9 +yursATLzunEYiWUTuE6DKjcfQYPrAmat/mzquvf+oV5YgPvcY85U3t1XeyW9Zyip +APYSJdgYdN8Wemh21vvGj8B7xnWMaJlcbsCbvuu2GALUGQKbhYzV02lMPSbEUHRH +pRI8NviMcR4UD0/FK7g91I7yDqX6BLBckUw+W1KYKqVvlcMuDUOc5nQTxWXrPWJu +o6EU4sD4bDaFOdDW8cuSBhxiifU+I+1s89p6+6M/Qwenh0hTvUsQwpUx/cXwjNXT +0uRaIk/yjbEZj80lTKyAn1TvlJ4A2vYjscqfiiVYBU1/enfnsYgUf+TTK2qm3TtV +HiuLLNvE2uy2IQfeZ3DnzZlMoCY8PA67yQCxJXR/hVX+/hzlZ0PoPylkYejs +=yD/C +-----END PGP MESSAGE----- diff --git a/tests/openpgp/samplemsgs/encsig-2-2-keys-3.gpg b/tests/openpgp/samplemsgs/encsig-2-2-keys-3.gpg Binary files differnew file mode 100644 index 000000000..b262d458f --- /dev/null +++ b/tests/openpgp/samplemsgs/encsig-2-2-keys-3.gpg diff --git a/tests/openpgp/samplemsgs/encsig-2-2-keys-4.asc b/tests/openpgp/samplemsgs/encsig-2-2-keys-4.asc new file mode 100644 index 000000000..1b63617de --- /dev/null +++ b/tests/openpgp/samplemsgs/encsig-2-2-keys-4.asc @@ -0,0 +1,33 @@ +-----BEGIN PGP MESSAGE----- +Version: GnuPG v2 + +hF4DkYWHjk/NdMASAQdAtNe4V9DKNR+N65wm9hJk8xRewYZPhmWADCcFraD0rnUw +MWX9tj1E6GIKEhCAMomt/PoboZ8ncBJ4JZ/x4fltX5qsfIZkVqILolPAzrp5EbeE +hQEMAx13dhm+MQ15AQgAkQn04BIdVZ6w0q13WfIoSepk2aQs39E6rmfZRUUs5Axk +aTkHLQa3jSIpWXtSdrm5DBX0rhuNSiFk1h2pwc0OSnIhl6jxrjX1TN4dbXrtaJUz +rguevhF72sfksr7p5sy/yFF1DBv3Z6MRKyyt4FjpbhzczDU0BD4cz0IGMb5tHLB0 +kTS1pJYtkajuWEGiyfT2dR1g0SdNoVwXiu+Hw+buPabAdjgVKocyGmdbYr/ip88t +9o9AayTN2BH0z35YBwpdULcoM3Dww+sTcO2sG6xiy7E24t8RPFUQOfFm5vfmI8EH +Zy4nId6ZkGEdkzX2UkU6FvX5vvru76My07nqKENDBdLpAXp08EPSUkTgnl9d7Hyq +R1jMFiML3/QtMH7azdmjKdmkhrYPMgNoAiK1lO7pw3dU4eHfWDnPUWw8y/WHmoUT +lxtZunT8GUh8ZxXl+skOqy2UXHPPRSN602oqma+yYKZrzn8hQm7Rq/tbmFPRTE7V +cPCuRD0u3Rwnhldq//r5w6AgG1jKu0gXXzLYcubEl7S8fvXG/udSg1ASjhdhbYPD +larTKCby1fESurfhwFnyaIGPknpzGooGFU7sIkrjilNPfVGv8CC10yMp7jOM7nXH +hZ3w6JNHzB3UxlVjOjUkXFRxm3X4ydNXFgrp8soGyOnhjcUcN8A8gIXJoDQwB9G1 +STIilDwsBzFJOZfJSdy0/mjecvqT2slFsl3fjr0h0M2cTsYw1Ws5iG17HTJBVjpW +frmWVjGVLRXkLGkumNbLpGxImlz2wlvuSlk/mqgrbRyyz6ifEpQc2o7uFvT6BGTp +pG6qPafKLEAOkfOZGt/BKMsWESoOXlIa5B8B/4/t8me0Lni7RS09908ait1poKEM +cDYNPtClQlBLJB3GLxPDDUT1WNcEBc+vScU317S5BRgDXBdao16DLzoIoh0C8kYu +JBIQvXYLw23IBilHxzv0Fr/ta2joAUOnojNZMAaOawWj8i8/EwO2Hl0epx8Ww3ft +VMnCF3nVuAIhjYEEzYI90dzA35lcSyEcBDXKBUAnOLi0LhwySi3rzM/d0yxdDGZH +oPw2JQWpgCuv4OMin5YSRowUPhgFmltNc9I6qgVdy1vLKndC/OnCCtQj2OpUrYsH +l1H3ADreaiunjtCrFTGYLey4EK6koLcb+qdKAOkRTaH28nRQGEyzZ4U93mbTsNmJ +nAW4JCbZtMap9on9koJwiopEA+ONuktCD0j6RSAC+HdyhwN+MTWqCtTbO/tIvaqZ +HtAlhiHk3GSi/qaox5dLKZqu5pa92OwiZrS6vS+dWTQpmyCyHYZcglsaRiHAGIEB +3MVPKMvLgp5wV9uuSnr0aXaXoyEXjjMHbP8UnAxojnVxGJTOzsijE59ovddLgqUD +81jYd4K3XIX+aWy3GicJaiAgzOYwJzBrOLZFGIlm9HkXKwM2gqd6TNjKQHxS63o0 +H6vXirtZmnRfA2SnmkGACbwTEa7vKARt4W45rXXk1GiQcxV0U7QrdQ9jMHIPtJF+ +py8jqdfjnNsUNM7PyTVjB9nTk9V3BkwIjUs46R6LqElZsAQQGcVo/EzBoPhjNUaf +K+I= +=kQLr +-----END PGP MESSAGE----- diff --git a/tests/openpgp/samplemsgs/encsig-2-2-keys-4.gpg b/tests/openpgp/samplemsgs/encsig-2-2-keys-4.gpg Binary files differnew file mode 100644 index 000000000..940a96458 --- /dev/null +++ b/tests/openpgp/samplemsgs/encsig-2-2-keys-4.gpg diff --git a/tests/openpgp/samplemsgs/encsig-2-keys-1.asc b/tests/openpgp/samplemsgs/encsig-2-keys-1.asc new file mode 100644 index 000000000..649921e58 --- /dev/null +++ b/tests/openpgp/samplemsgs/encsig-2-keys-1.asc @@ -0,0 +1,18 @@ +-----BEGIN PGP MESSAGE----- +Version: GnuPG v2 + +hQEMAx13dhm+MQ15AQgAiZPJa/zmtJ6cDpHVze6zBS+4OCbGeEpzcHBkpWiLKV91 +6CiwLTtL6Fhs7P/i5lEUzWQnRp0IGmUe8Ft5tugAL3ibv3Xm9PstXPZ2Q6EGzDCY +98x1aQooSuiUwIB4uQ8zFqA2TYGNfRcDCGdHHLpWAps4F/QkZkQGEWmy7KQZetc+ +mLP6z04fQz5XemL0MaJcarLRE0OK8FI4+413DqQB3RyZsMFiFDAY46g3rA7xymuo +Elum8PjMDXtAEpYAs2NHR29okFMinB7rR/DFGabQtzWIJPlgyGOFUVXs7YWj0Git +SgEje73u8eEYAJYTpud1zup/KPUYOqJzyIMvOHDMz4ReA5GFh45PzXTAEgEHQGSH +2coczePYstzayq418VjtNF+0ohoFKm8lrR9THREYMFJ4oA6/e7r3g38CWlb8kKxN +butxPKCcO2OjZYU5PZMk03CwbpSWM0FTNJEzXfqdKtLAOgHgccG9wgBqAbcTejiX +FQBBsLXRybq8Bra8qW+RVJ5noCav3TH06h8ZVXz/jJMLSUfKt8l+xRQDkYZ88cN3 +GhWNSc1eBOjS8e3JwGYaGs4vuoRVECbzee1DWNk3CUQOgeqZKLoSYHDRwHMpzP/N +suXLpGTV7EoN4+qOcF5q/6cZV4gaGxgokoCUrM+IYfhOjmqK3lfo9/1GUxppyE+x +XsWKiUMta3tJ6zhWYJPCZCqIZvzmkSfk3pNtOnsmmhF9gzwN8ehi/FHGFyHc8/gW +qxx0KsCG7FO4Y514pdoa70KqA8QO63YjxTaFBH858yZr5ORlhzElwctgivU= +=cWGf +-----END PGP MESSAGE----- diff --git a/tests/openpgp/samplemsgs/encsig-2-keys-1.gpg b/tests/openpgp/samplemsgs/encsig-2-keys-1.gpg Binary files differnew file mode 100644 index 000000000..38ff6b6d4 --- /dev/null +++ b/tests/openpgp/samplemsgs/encsig-2-keys-1.gpg diff --git a/tests/openpgp/samplemsgs/encsig-2-keys-2.asc b/tests/openpgp/samplemsgs/encsig-2-keys-2.asc new file mode 100644 index 000000000..4eee21db7 --- /dev/null +++ b/tests/openpgp/samplemsgs/encsig-2-keys-2.asc @@ -0,0 +1,18 @@ +-----BEGIN PGP MESSAGE----- +Version: GnuPG v2 + +hF4DkYWHjk/NdMASAQdA9op1WNWUj4E0PZ2h33tolomYTag75nRNg8qLo/2xfXcw +QrekSuMoLtkv1KO6/tLIohqYYYdZL5cGadTxlBLyIEj32ISVj7El6DxJrmqKIK3y +hQEMAx13dhm+MQ15AQgAnY6drrcce7MeloBIECLSbFIDjKOloUT4xtqspTg3GM1d +wkXtTJOdEm1yLcNQsb+d8ZdZZfYZhotCyMlZ5QQtvf+0XOieb/FlitUI0twAMsj/ +kwjN9dop+KGLZadFoar5A8TBXUz25PfWmwEzz2qSmIPuoIUzhK90B3eGUG6foGzm +1zEAawfyJ9w7XVAV6pNGJWG2LHSQr2POaMbZs/3iqxQl8p2yb25SlKrg3I35UClZ +0FC9Hidw8bZ8/rZCyX9KYtHIENHzqT5+XEpaXwN4hBqwpVgUn6DcESv2BAR7KCHD +ZwRRNVZtUvrftj05UIxAgnSAdK5GAyhLfWjCsH5Q3tLAPQGFdlgyYU9q+hWrrqwW +1tAvUJQpSW97WyK1Aa9RJOLPNpfU1wzRGzzOuNuuqbL4l9OQktJ81Mihh4IWCXQD +4mN7+nvltCm13bANdujRvZstGGFefRiwkBlEQq9uQMM2SVXA+JAff+AvD5F1Ofq8 +DPVMf/WDsKcoTTdqJahk/zoX4yFHprS50tO2z0Mb9souX14+AN+JJzAGQaGRlXXD +TWeEkUXD18HcVzHfooqLUlYYr5zD2f2gNNVskPYH/iP3FGllvzBeQI1NCznAj+Zr +AdOEXHKOkCJmj2RKnxXeOWTJSczoBlQgIQGd/yP/2TPsGesd4SbqFStYuefEZtw= +=hq0A +-----END PGP MESSAGE----- diff --git a/tests/openpgp/samplemsgs/encsig-2-keys-2.gpg b/tests/openpgp/samplemsgs/encsig-2-keys-2.gpg Binary files differnew file mode 100644 index 000000000..6407387d4 --- /dev/null +++ b/tests/openpgp/samplemsgs/encsig-2-keys-2.gpg diff --git a/tests/openpgp/samplemsgs/encsig-2-keys-3.asc b/tests/openpgp/samplemsgs/encsig-2-keys-3.asc new file mode 100644 index 000000000..f10e92a7f --- /dev/null +++ b/tests/openpgp/samplemsgs/encsig-2-keys-3.asc @@ -0,0 +1,23 @@ +-----BEGIN PGP MESSAGE----- +Version: GnuPG v2 + +hQEMAx13dhm+MQ15AQf+KX1A2pYF9HnvwZZU6kmiOKs6NL/d/8Y+kwfiLot5SnQW +S/2JJm0b7ijyxBOoTyXu8UOqyaPa/eIJWeMqNANExkX83S1hoKfzgrBluzZR4sUB +r6bZ5E26pn+gy+r1RvQJnxUWMX41ux+DSc+oqf36cZ5A4R1Ai6cD9jqW7vE0KINo +jn6Od45NHNG16Q7igH9HgJiOXaibHFyiAfV5du0XB0HxpBlBKIBSV/4ewFUzxVy+ +oR4/3F7SkaUtGwcEi+PUEU26KuYz2ltYA9Ex/yTd59YcYbPTiiq+ynGRpOTgB0ti +y7aYzJVOPWGCKn/TFy69QIoJZgcWTrmUJK39wxFNM4ReA5GFh45PzXTAEgEHQKqL +epFBazPDtJvYGye9GW9gHMSjuTFuEm3yuo6kPIggMBRK/vWfTa7emGniukdA/8Bn +hXrpSZUBab19RlT/mDhC8+CBE7MvEQMHsZvwsEWzt9LBAQFgEPLmrwSchnzw5+vN +bcfeBye2n5STluKZ5IrW4XwZAvmp54w2OI/FDzf5dL1r+KCNiZpcmVO6IVVbEIeL +eZj++YAPDS0cf/bPfWbyfvC/MLNM6IFICdkdlKQ30FC801Xv4OuXvgctjIkZBEDR +CkDvkyrIEUtN9jJaAWjP3KopsCsxGtZ/ZPVU2yv8ekPRZ1paUIb370/NhEz9l2kK +GwmqNm9g6/ekJwIF6kZKoEzncX7cpF0diSTHCyB/CsWc1ncWgn/nktZDsd7UicKP +ypHScloUZfXDiQBcKV+0p6BxYib1MJOFrRbJTu+0Xu3KjcbecQ/mymgfDlkVUwXP +QeGaQNUgQzO+iAW1hPH5Qf8eB8n2DlbqsFEWIXG7B3pGCI0eBWPeR/JpuCnIHMTh +50YOwGqNQLjqRnl6hFi8amSIK5jRvRMzRWYO8TSZaYVh7uLh83cKkSV2e7d2pax6 +CqubZsoiaX71x+r3NaPYf+4hzAQUxPDZET2hTR4GOeEGT14t9RhqMPLTS+f9Ij7D +/LbCpm6sc6eSmbKXZF/XAPpkBmnRIpgqJuA0TgNBnU7a0NEQP6nsicOpviH9SFEL +waeu +=6uha +-----END PGP MESSAGE----- diff --git a/tests/openpgp/samplemsgs/encsig-2-keys-3.gpg b/tests/openpgp/samplemsgs/encsig-2-keys-3.gpg Binary files differnew file mode 100644 index 000000000..144936690 --- /dev/null +++ b/tests/openpgp/samplemsgs/encsig-2-keys-3.gpg diff --git a/tests/openpgp/samplemsgs/encsig-2-keys-4.asc b/tests/openpgp/samplemsgs/encsig-2-keys-4.asc new file mode 100644 index 000000000..8937f5e88 --- /dev/null +++ b/tests/openpgp/samplemsgs/encsig-2-keys-4.asc @@ -0,0 +1,23 @@ +-----BEGIN PGP MESSAGE----- +Version: GnuPG v2 + +hF4DkYWHjk/NdMASAQdAM+CNEu/KZIBKoKmvE96atl4CEdxThqamGsRt9IgeMxcw +Te0hTUQf5LrrK9MhGymBcB2nCCy0bPtqVhA8TdZ6y3CH0QYMObkbSbIcVnGaVmGd +hQEMAx13dhm+MQ15AQf9FcEbvw9ocsmqrteF2Cu6W2ChxrNy6ay0gcDwvd2QfbAE +muM+OcKrvXhgDikOt3gAv4ES+2/ACzsqIZZJGUVWlrkSXYq9Uon+YX1zeK3BfmOK +GvfLqc7p9x0YtrC8KEeMaqpd8z5bRhpF0ZPF4WbvZyiauDAa62FJiH/r4YngGLoY +2hXFNZ2FFHa2EuobUfJUJwfA7VC13IdvqZ76bixrSSjxJjhntiswxYQI+OaXnEg8 +S/UwxR06GT7vOra1O9TGIHYwTcRGQT/3NHcIO3aJMRCHVP2dOLBMkFqkYf44kGeA +e718nBN1UB7cfgv+n2bj7SYGdlEH0bmmpNTavEsDZdLBGQEcNlkdz3CqdqRhXUek +hoWzCKTzOhIkoIhdyZd0stBlYJ54dT+9470JogkVqkNCWjAP1svI6LprOAR5b1sV +m5ar5pCspumNRfMv6oDjXIsjCaux4zJfJV8XO38wmMn30eMPg1CzbKjhqMW+IfXe +Tn8yxDBVGScIKkmaks6AE1v9WtfBSz+zT8sFe1ZFUMRcJ4+vohYmLVZXqkXGFJu7 +F3j8URhctnGb88h33y2+xglaqptso7XpM91OR17e6Vhh4dNAWB/GdKy4VviVY3W+ +fJ+zoimrPTFmPo2Ag+mveTsnTzmGdy4FHDDQCKE6QVcJPfVcfN0+yiPIOx/XacZR +ZnQlI9Z+iYuN5yEchnVK65XZGQkdK+4/5Q/QGq7vLwaOHkMtItplIsretCGHAGEj +XcCeHIY4pVZOd8Of8CSSPvtcaz4+FbZ/cfKXXf1zjdxg5BRkVvBAAtAYqquDUPJn +qcG7tcUD6pQXVDHq+s0j8BofK9BXjjicrTI64RZw2RYntdbRSqd82offshvF4MJm +72hIMbg5ExZsvdUa+IcRw49PoX/fEhKkmElZCI+5fsMG/NJuTfAtNjG5RbdgrYzQ +eR6eIMr6BnY9ZZQRPbuv0te4di55B+HqmTry +=/grx +-----END PGP MESSAGE----- diff --git a/tests/openpgp/samplemsgs/encsig-2-keys-4.gpg b/tests/openpgp/samplemsgs/encsig-2-keys-4.gpg Binary files differnew file mode 100644 index 000000000..46d2037b7 --- /dev/null +++ b/tests/openpgp/samplemsgs/encsig-2-keys-4.gpg diff --git a/tests/openpgp/samplemsgs/encz0-1-key-1.asc b/tests/openpgp/samplemsgs/encz0-1-key-1.asc new file mode 100644 index 000000000..cf534db06 --- /dev/null +++ b/tests/openpgp/samplemsgs/encz0-1-key-1.asc @@ -0,0 +1,12 @@ +-----BEGIN PGP MESSAGE----- +Version: GnuPG v2 + +hF4DkYWHjk/NdMASAQdAPo9H2rEUOisFYLfLQu91wGJCSIGs9jFiYwQsKlhsZlMw +itRELU7+unvpPp8bIINqu4X6FP7hDzkZjOlQM/5JS0Z/q2jaWo4av8DCxYCK+yHU +0sATAZtMvHD99HWEAis3GUlFBzf/jxPBmayNElVyifc5eH4d2pRfCqlZPx9gKX69 +OYymTKuUkkmzCgBxVfA7XPdIdqTmDbSjVwQ2LFeB8hQv6PsYFHY1vqs4xVmeotIu +pgG1a40+6f8HC9YDNn2lUzktui/mi/VNqDwV9vOHYklGqpVDd81nHAl1wGkAzgBs +8sYAcQjRAArAPKBaPTCtn6PZF4p4sDcabGImGR8cWwZHb9yxkHIomJRHUVTF1Uz4 +MUANuPQHpJE4eqKHUaE6wyTXyGEqJQ== +=UB/1 +-----END PGP MESSAGE----- diff --git a/tests/openpgp/samplemsgs/encz0-1-key-2.asc b/tests/openpgp/samplemsgs/encz0-1-key-2.asc new file mode 100644 index 000000000..a885f5b8d --- /dev/null +++ b/tests/openpgp/samplemsgs/encz0-1-key-2.asc @@ -0,0 +1,13 @@ +-----BEGIN PGP MESSAGE----- +Version: GnuPG v2 + +hQEMAx13dhm+MQ15AQf/WO25gVi//kxCs0RH+BbJ5OWRRkyZ5fD7mYUs6anJ/zRE +SE/SKwNk4KsWi4ajRR7b7txj7HQN8l6RpjUFXDJwd0onkb5JoCcvVIdaSTRR8z3s +5tkI/KTkPhlDPN+E5jCllUnJNSLoUwIIMw5Zgn0gRXxZeR6pUCB00+GmSPpoV+6X +pEk8yuP5gcCFz2uiPmRl6QBezq6QLwlzYS6Kj+m2k2zqgEEgBc31aVnze8FTElbf +Mm2wQ+w50PVaqHKkH7206PMIAd3Jsv2QP4XfgDDRxOe1/s6dHiCOfnhdrx/Fblp2 +VjluZFc/yL2YfofqqEWAxLLzh47aVN6JLr3bhdAVvNJEATedhlr+GTfhfI+KYO9r +rZlP9aDHzvMKkqyX4WDD0O6a+698AnoseFVmrrBIsokdIt1RjLcpycE4BsCQOXHe +EDBJtGo= +=O1Fl +-----END PGP MESSAGE----- diff --git a/tests/openpgp/samplemsgs/sig-1-key-1.asc b/tests/openpgp/samplemsgs/sig-1-key-1.asc new file mode 100644 index 000000000..875cf831b --- /dev/null +++ b/tests/openpgp/samplemsgs/sig-1-key-1.asc @@ -0,0 +1,8 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v2 + +iHsEABYIACMFAldqTEMcHHBhdHJpY2UubHVtdW1iYUBleGFtcGxlLm5ldAAKCRAT +lWNoKgINCu0XAQC6VSdsGyTbvFPp5e6BmkmBzPcb5Kex4ar722k0jzhLzgD+Js2q +Y1JIdjfW4GnFhdzqyUbuGTlk1wNY7Re1uNyD6gw= +=c0oW +-----END PGP SIGNATURE----- diff --git a/tests/openpgp/samplemsgs/sig-1-key-1.sig b/tests/openpgp/samplemsgs/sig-1-key-1.sig Binary files differnew file mode 100644 index 000000000..9c823cd3e --- /dev/null +++ b/tests/openpgp/samplemsgs/sig-1-key-1.sig diff --git a/tests/openpgp/samplemsgs/sig-1-key-2.asc b/tests/openpgp/samplemsgs/sig-1-key-2.asc new file mode 100644 index 000000000..f7ae1209f --- /dev/null +++ b/tests/openpgp/samplemsgs/sig-1-key-2.asc @@ -0,0 +1,12 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v2 + +iQE0BAABCAAeBQJXaky2FxxzdGV2ZS5iaWtvQGV4YW1wbGUubmV0AAoJEKpD8dzH +/tG3LSUH+gJ++JOZuy5GfHwK+5GEGmeVbex4U9N84tYYAwZOsOpQsh4JxT44IH8S +OG9OViY9xUaUmeSvVsuDR890RiZtKOXO3hCMwUo+HCDFLXgIXxosLlS55G1vfi8X +NPl78Y9NFdtwtAkirpOT0oULJcbZ9NItkPjhoxZ16TlgG3GUE6lZzlZJLFAVCw7u +6twOtPnq1AB4xB49rsIIW1XhCNrajwzBCghhl/PD4uM7ptSpGkZur5uOJ7nLjNEM +Qo1mF+jQ6rjWA4OrvpmtW482yvNWejAS+JMlhNcP63hlBySjX3tFhGm8tWtUauCT +3Ky7iF4dFFmhpIXUBT6mMmci4WdA3gE= +=VdOj +-----END PGP SIGNATURE----- diff --git a/tests/openpgp/samplemsgs/sig-1-key-2.sig b/tests/openpgp/samplemsgs/sig-1-key-2.sig Binary files differnew file mode 100644 index 000000000..a4f5199e5 --- /dev/null +++ b/tests/openpgp/samplemsgs/sig-1-key-2.sig diff --git a/tests/openpgp/samplemsgs/sig-2-keys-1.asc b/tests/openpgp/samplemsgs/sig-2-keys-1.asc new file mode 100644 index 000000000..8c767b246 --- /dev/null +++ b/tests/openpgp/samplemsgs/sig-2-keys-1.asc @@ -0,0 +1,15 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v2 + +iHsEABYIACMFAldqTMccHHBhdHJpY2UubHVtdW1iYUBleGFtcGxlLm5ldAAKCRAT +lWNoKgINCgcQAP0f1yNJcHiBvy3nK7SSuzBf1EgSpy/lFlVSjZ1e/7CEKQD/W68C +Zs8iGAyZplpsXKoz/g7LWSU5z/K3lLWwfre7gAGJATQEAAEIAB4FAldqTMcXHHN0 +ZXZlLmJpa29AZXhhbXBsZS5uZXQACgkQqkPx3Mf+0bdg8wf/ff4tEMfqdwk1dXJm +4+iyrNvKyCfv/T5W8BVL16wc8jn+80HJkHK/pSw5Rr6nsEf1P00u5AnothUPfUl2 +Yqvjg4+oQYvutePo1uLq0LA1lyWfQ1PV6I14B/dd9rBYdPjYIJJsPjr/k5N3Qz9M +8RNtDp/rPDVNVHzDbZN77oGE2jokGRfodRo6qnurqU4CnJYinrnzKV4wqrilNKlE +R2CBieb3riDFUH59PH9S9fHuTHBV7q0HlxNJkI6NeoFwtRcS2f8P5B7FK7VCMrUB +R46JExeWhvUlY2ZkKLU98bI3TLnFD0aQHRzKgJj8sWjD+Akzf408EmnOIyyf6MF8 +H7uIHg== +=ErBQ +-----END PGP SIGNATURE----- diff --git a/tests/openpgp/samplemsgs/sig-2-keys-1.sig b/tests/openpgp/samplemsgs/sig-2-keys-1.sig Binary files differnew file mode 100644 index 000000000..541285f19 --- /dev/null +++ b/tests/openpgp/samplemsgs/sig-2-keys-1.sig diff --git a/tests/openpgp/samplemsgs/sig-2-keys-2.asc b/tests/openpgp/samplemsgs/sig-2-keys-2.asc new file mode 100644 index 000000000..16ae64c8b --- /dev/null +++ b/tests/openpgp/samplemsgs/sig-2-keys-2.asc @@ -0,0 +1,15 @@ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v2 + +iQE0BAABCAAeBQJXakzUFxxzdGV2ZS5iaWtvQGV4YW1wbGUubmV0AAoJEKpD8dzH +/tG3B8EH/247hq+cJ8eR8eXb1mv1Bdj9SwYI4yDs/xCZ7FIkU8vVSRYQpeYz59ie +3WZw8Cj1Sd44tr3+viVK682lWXwpHIAl3xUizP+HTFs23tfyH3er7IhDO/aApZ+V +Wd+0oDJY7E/ztsD3CpU50ptKU9D72CgJT8K1/pwBtivzOiMto/scPwVFNDzGlny8 +FC06j+2FyXFkXCLwvz/Xdk+hJmv8lQRGNxnSIB5bU+0/GLEd9wJUFTV3WSs5enEM +zqtGBh6v395BXnqrDHpOmT+EkWrpBOSo5vkPZrbN4bOC9nKSa9isCvU/+fjHW3Dn +GpHVTH1hCWsKRhQjxuOOq/X21YpvgJ2IewQAFggAIwUCV2pM1BwccGF0cmljZS5s +dW11bWJhQGV4YW1wbGUubmV0AAoJEBOVY2gqAg0KPJMA/0+3s4HPotwYw8K8pug3 +7Mxgd9LNIBi/d0nSpBnZTHySAQDURAoIZp0IZI/PS7Jc9A8M3TgWdm1LUkj+qU9x +3L6RCQ== +=3oWb +-----END PGP SIGNATURE----- diff --git a/tests/openpgp/samplemsgs/sig-2-keys-2.sig b/tests/openpgp/samplemsgs/sig-2-keys-2.sig Binary files differnew file mode 100644 index 000000000..187e22a32 --- /dev/null +++ b/tests/openpgp/samplemsgs/sig-2-keys-2.sig diff --git a/tests/openpgp/samplemsgs/signed-1-key-1.asc b/tests/openpgp/samplemsgs/signed-1-key-1.asc new file mode 100644 index 000000000..d71c74d80 --- /dev/null +++ b/tests/openpgp/samplemsgs/signed-1-key-1.asc @@ -0,0 +1,15 @@ +-----BEGIN PGP MESSAGE----- +Version: GnuPG v2 + +owGbwMvMwMG4yvnjneP/Lm5nPJ2exBCe5XbZI7E8O7UyVb1YwTk/LzmntDgzP8+K +i9OzBCiSl1+ikJpYXKlQkq9QkJMIpDNSFZJz8svzFMozUvMUKvNL1ctSFdKByoAq +ikrzwArKM/JzUrk4kzOLkkuL9bg6GU1YGBg5GORYmUD2icsUl6SWpeolZWbnO6RW +JOYW5KTq5aWWMHBxCsAcl9zJ/od/6lrXa9snvZR9wrpXuEblNq/F3pzYWed8DZd8 +aApUzgkTy1K64+QU7HuL525G4vM3Yibfvq+VLTf/aFx46FSc7I2MpE2vElhvztZ5 +8SQ2ZWe7m5apT9qu7UfXyhrxxfutyt+ot3daXp3hyxuVPzdfKD147N8djoc5634y +6n9Uvfa7Uec030zZjae3VHScMDY1tD7yQjrFNnXptYQXP+RPtD1l+Kn33I87jeHT +SYnUk8r3zD71zahJbfZYwem0c+WbOzs/+qQeKeE/kaL+Y8GHeY9vbkq6eGNKWag+ +Y+Ydhac6bccZHEpXHFBfy3iBJ9OrZub93Oulx4Tnz5U5tZuL31VZOSzlyESvoJeb +/0kDAA== +=T94L +-----END PGP MESSAGE----- diff --git a/tests/openpgp/samplemsgs/signed-1-key-1.gpg b/tests/openpgp/samplemsgs/signed-1-key-1.gpg new file mode 100644 index 000000000..8ab90c13c --- /dev/null +++ b/tests/openpgp/samplemsgs/signed-1-key-1.gpg @@ -0,0 +1,6 @@ +�5RkhTG�콢���]�S�L��F_1I���A|d��l�d�άw��fU�ZTԶT#Z m}����?D�[b������B�>�CD���.��9�;���wΏ�>��KN/yy����咛�b��ֺ�kl +ˈTT*XJ�(h�ĦR��N�X p���.x��p�8�X +LB �/ �\�-��1S��[iض���{.�-03R݉H�!/�@�� �y.�D�b2�\!�dc����+�I:� +H�B�0� ��K���p�4��A +���re{��2 )�+��T�g)�g:��Y�YK8IK�arK��R�8;~��r�E�J ���8�C�d��� dm�h�i̬���h8���qq�iT��g�*��ưiT#����W�L#� WU#�M�Yw�� �K��%��O�-�Ze� $XB�3p] ���p2Ԥ k7��b�YzS(}��9 ���=J9�eTT�jEӚ��94S�m,"������;b�����{K¥��o���M +�z2�2ƒb!m#��C+9U>Ә��"_u���s��k�'_��˗?����O�ä�Y�; �|;�v~��9��O�k
�w�>o�Զ�?\����}� �w��d�K�3�ܟ]�Ǯ��o�/��g =�b�wwN��kU�Fp(��:r!�T��+��_�`܉���g��� �������v���z����v�- �:��> ��|�ԁ��GWڵ_<�t�~�@��О��m�
� T �����5�d����;^�[�G��my��:T�&����Ŋ
C��[�܅�j{ۙ�1*��_�u��%1����
\ No newline at end of file diff --git a/tests/openpgp/samplemsgs/signed-1-key-2.asc b/tests/openpgp/samplemsgs/signed-1-key-2.asc new file mode 100644 index 000000000..64483fb7a --- /dev/null +++ b/tests/openpgp/samplemsgs/signed-1-key-2.asc @@ -0,0 +1,12 @@ +-----BEGIN PGP MESSAGE----- +Version: GnuPG v2 + +owGbwMvMwCEmPDU5Q4uJl4vx9AG9JIbwLLcnnCHl+Qq5qXkKOfn52akpCvmlJQpp +Rfm5CiUZqQoFRZnF+XkKSYlFxTpcnP55qQrFieUKuaUpurpcnCFABflAVUVgweIS +oCI9Li6//HKFnNQSoJEK6UCqJCOzWKEoMz2jxEqhBGgTxMTUomKFxKJUsJ2Zeelg +S0H2lWfmpeSX63GFZ2TmAA0H2pefBpLIVShPLIarTixRSMzJAWsAOkVBVxfMhDgF +pCc9v0QhI7OEKzMPLJGRmpiix9VRzcIgxsGgzMoE8rWMTEFiSVFmcqpeTmluaW5S +okNqRWJuQU6qXl5qCQMXpwAsoD78YWRY1rZ/7kOLr4GrbvSU6HqKnVy6+1BllLYd +c5ebbu2ltZ89GRkOBN6327Z+J4eaa5ppOGeA08P8xgvlcft8tz5u9i7jncwKAA== +=uuW/ +-----END PGP MESSAGE----- diff --git a/tests/openpgp/samplemsgs/signed-1-key-2.gpg b/tests/openpgp/samplemsgs/signed-1-key-2.gpg Binary files differnew file mode 100644 index 000000000..23f045701 --- /dev/null +++ b/tests/openpgp/samplemsgs/signed-1-key-2.gpg diff --git a/tests/openpgp/samplemsgs/signed-2-keys-1.asc b/tests/openpgp/samplemsgs/signed-2-keys-1.asc new file mode 100644 index 000000000..38d25b113 --- /dev/null +++ b/tests/openpgp/samplemsgs/signed-2-keys-1.asc @@ -0,0 +1,17 @@ +-----BEGIN PGP MESSAGE----- +Version: GnuPG v2 + +owGbwMvMwMG4yvnjneP/Lm5nmADiiglPTc7QYuLlYjwdm8QQnuVu45iTo+CWmZeY +npOq4JNYXqyQm1ipkJSqkFRZkFhcnJoCZCjkpCYW5WXmpSuUZKQqFGfmFgDVJhaV +KOSnKaTkA8W5yjNLMvJLS4DymXnZQAE9ro5qFgYxDgZlViaQJTIyBYklRZnJqXo5 +pbmluUmJDqkViSBj9PJSSxi4OAVgzpoVw/A/fBVnTGzGFd0DUzZcu6HNcm/6mpaZ +CeuOc+89eOsmg9YGRYb/5U3LTx4pf5Ru3ceW/X+Vkdq22kuGCxqaVwYJHZSL/xfN +08lowsLAyMEgB7FdXKa4JLUsVS8pMzsf3WJY8LR2sv/P9VLy+VZyrvhebd6WMyoz +V/kIXW+p2WbcI1vw58xdofBbU9eHtM2Y47ft6Bm5bS0NL6d6zzl7YsfLl5qKLFJb +s/cVKFe1MM7POqrEqzEr7cqe3amsN08ntDsvbLr3tc1ATKhTgMVKMIhjznseR54F +L1tyl7eUv96SYCbIf+uzu5vZnjWHvulP1zm579qel7afa77Enc94Nnn+U4Xf7F8W +PA5Kumj01S639ux3PcYFLR9+tey0bTDyNPhkqiddvLY9O8ztd94SDw4ph4+bbol+ +5S1+5dJ1vl1w7VSbtSf5dPfV1uxLr7UQnvGiwplnVpzt8XOvFXbHZ6yx2Hm52Kry +0TndFZfZqkRzFGxn7bkOAA== +=iswv +-----END PGP MESSAGE----- diff --git a/tests/openpgp/samplemsgs/signed-2-keys-1.gpg b/tests/openpgp/samplemsgs/signed-2-keys-1.gpg Binary files differnew file mode 100644 index 000000000..ebf677129 --- /dev/null +++ b/tests/openpgp/samplemsgs/signed-2-keys-1.gpg diff --git a/tests/openpgp/samplemsgs/signed-2-keys-2.asc b/tests/openpgp/samplemsgs/signed-2-keys-2.asc new file mode 100644 index 000000000..5219e130b --- /dev/null +++ b/tests/openpgp/samplemsgs/signed-2-keys-2.asc @@ -0,0 +1,24 @@ +-----BEGIN PGP MESSAGE----- +Version: GnuPG v2 + +owFdk21sFFUUhqcf4O7wIQQLpi71skoKZFj4wUdrgiwYxVaUFrZUvkzuzJ7ZuezM +3M3Mnd2OEpNiTVGTQlSKUn+A1WjBBFMDRIWAKG0qJYEWhVKgkECqBkrQ8AM1u96Z +hVT9NTmZc573ve+5d8eEIiEwdcpORZtTOEEUdnhlwb5n7lzqzp49XHDqV1mo37xi +ZTC8jjrIAGxKiKjI5QXWdZpBTANkYJuBhRhFMiDHVEia6JJXMgsw85pFbLqI6nGU +wS7iEzpJgi0hbMa9NmLaju73WShOEiZhruSBTeTDXRQHMHyMSpg3oAG2kEZslCaQ +QVTlzcRM2EvDYjBc6xAGvi2FmszClhtByDfv2IyTVOCivhQxGSQsXwzbtmNwhOgd +TMNpGP3p6eWnOGe549v8D4tbMqmsc4pJGZJdkRiEYcZpvkWaMZEXlAycS6jFKVX3 +A7QAJcBkOqCMBrzgnvmARZ2EJolktClFde9M/27iKVOHaaMxZYiuIwsUyuN7FfKj +tpiijAsQvioXZajFNDcvzwfiFGzP8SiC+DXC9/fJU1H5J+YtWhJxPjV/HSqAjlQL +wMsmSZSkf1CeYYQvIDh3LopRA62msswXK6FwNWGcIzsJVAOW6hgQFt8qWFAsFASE +sjGF3u2aFuKCaYjIJEmj0ICNlA4RE5ggBic9uIpd6kPZyjdLVjSdbP+96b2J2rhc +6bKGZXtvnJv+1L7wY4MZdSC06tOxx74KzS7rosOTWn6MbN8wPHT1txnNVwJjRnpz +j7wxs7uxV5+8dsPWRzsbetK3bx0emD0wuWfhJ92pNT8fbNh1oO5O1clXbo9r6u96 +ePDQ3ujiwc9PPP3n+x+t7r320xKnONu3deXGlmhh4+nhDyraXv871ifYtUvGt7Wd +jw0PdexeVDLyS1Wd3tizqXx/y/XpFaj1h7e3dLofJ7+YX8NK9xRFrweaZ/4hvTy2 +dekL+w+tiu3JFlX2GJ+VH6m7cXHdc3drl3//+MXO6tx3E53si32nDo7ULO5o73qp +XbnUG2xtP13XX7roKB3Z9lqxMDUgPJFPLRRKYWYRBSK6YziGjP8f3YNHXV4v5BTt +5qbStev/6ghX7xz/4e4jQ09Wtm5898Ss4LfbmkswuyDkttyc9807ZRfmfX3m+Vv1 +/bO+HIzB9sv3pGjwzHGlv+JZ8R8= +=pstx +-----END PGP MESSAGE----- diff --git a/tests/openpgp/samplemsgs/signed-2-keys-2.gpg b/tests/openpgp/samplemsgs/signed-2-keys-2.gpg Binary files differnew file mode 100644 index 000000000..42741b394 --- /dev/null +++ b/tests/openpgp/samplemsgs/signed-2-keys-2.gpg diff --git a/tests/openpgp/samplemsgs/signed-data-1.txt b/tests/openpgp/samplemsgs/signed-data-1.txt new file mode 100644 index 000000000..060720104 --- /dev/null +++ b/tests/openpgp/samplemsgs/signed-data-1.txt @@ -0,0 +1,7 @@ +This conjunction of an immense military establishment and a large arms +industry is now in the American experience... We must not fail to +comprehend its grave implications... We must guard against the +acquisition of unwarranted influence...by the military-industrial +complex. The potential for the disastrous rise of misplaced power +exists and will persist. + -- Dwight D. Eisenhower, from his farewell address in 1961 diff --git a/tests/openpgp/samplemsgs/signedz0-1-key-1.gpg b/tests/openpgp/samplemsgs/signedz0-1-key-1.gpg Binary files differnew file mode 100644 index 000000000..400bcba02 --- /dev/null +++ b/tests/openpgp/samplemsgs/signedz0-1-key-1.gpg diff --git a/tests/openpgp/samplemsgs/signedz0-1-key-2.gpg b/tests/openpgp/samplemsgs/signedz0-1-key-2.gpg Binary files differnew file mode 100644 index 000000000..55f3637b3 --- /dev/null +++ b/tests/openpgp/samplemsgs/signedz0-1-key-2.gpg diff --git a/tests/openpgp/samplemsgs/signedz0-2-keys-1.gpg b/tests/openpgp/samplemsgs/signedz0-2-keys-1.gpg Binary files differnew file mode 100644 index 000000000..84f2fd293 --- /dev/null +++ b/tests/openpgp/samplemsgs/signedz0-2-keys-1.gpg diff --git a/tests/openpgp/samplemsgs/signedz0-2-keys-2.gpg b/tests/openpgp/samplemsgs/signedz0-2-keys-2.gpg Binary files differnew file mode 100644 index 000000000..7e142b910 --- /dev/null +++ b/tests/openpgp/samplemsgs/signedz0-2-keys-2.gpg diff --git a/tests/openpgp/seat.scm b/tests/openpgp/seat.scm new file mode 100755 index 000000000..aceeccac1 --- /dev/null +++ b/tests/openpgp/seat.scm @@ -0,0 +1,30 @@ +#!/usr/bin/env gpgscm + +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +(load (with-path "defs.scm")) + +(for-each-p + "Checking encryption, signing, and producing armored output" + (lambda (source) + (tr:do + (tr:open source) + (tr:gpg usrpass1 '(--yes -seat -r [email protected] --passphrase-fd "0")) + (tr:gpg "" '(--yes)) + (tr:assert-weak-identity source))) + plain-files) diff --git a/tests/openpgp/setup.scm b/tests/openpgp/setup.scm new file mode 100755 index 000000000..9ad19c284 --- /dev/null +++ b/tests/openpgp/setup.scm @@ -0,0 +1,129 @@ +#!/usr/bin/env gpgscm + +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +(load (with-path "defs.scm")) + +(echo "Creating test environment...") + +(letfd ((fd (open "random_seed" (logior O_WRONLY O_CREAT O_BINARY) #o600))) + (call-with-fds (list (tool 'mktdata) "600") CLOSED_FD fd STDERR_FILENO)) + +(for-each-p + "Creating configuration files" + (lambda (name) + (file-copy (in-srcdir (string-append name ".tmpl")) name) + (let ((p (open-input-output-file name))) + (cond + ((string=? "gpg.conf" name) + (if have-opt-always-trust + (display "no-auto-check-trustdb\n" p)) + (display (string-append "agent-program " + (tool 'gpg-agent) + "|--debug-quick-random\n") p) + (display "allow-weak-digest-algos\n" p)) + ((string=? "gpg-agent.conf" name) + (display (string-append "pinentry-program " PINENTRY "\n") p))))) + '("gpg.conf" "gpg-agent.conf")) + +(echo "Starting gpg-agent...") +(call-check `(,(tool 'gpg-connect-agent) --verbose + ,(string-append "--agent-program=" (tool 'gpg-agent) + "|--debug-quick-random") + /bye)) + +(for-each-p "Creating sample data files" + (lambda (size) + (letfd ((fd (open (string-append "data-" (number->string size)) + (logior O_WRONLY O_CREAT O_BINARY) #o600))) + (call-with-fds (list (tool 'mktdata) (number->string size)) + CLOSED_FD fd STDERR_FILENO))) + '(500 9000 32000 80000)) + +(define (dearmor source-name sink-name) + (pipe:do + (pipe:open source-name (logior O_RDONLY O_BINARY)) + (pipe:spawn `(,@GPG --dearmor)) + (pipe:write-to sink-name + (logior O_WRONLY O_CREAT O_BINARY) + #o600))) + +(for-each-p "Unpacking samples" + (lambda (name) + (dearmor (in-srcdir (string-append name "o.asc")) name)) + '("plain-1" "plain-2" "plain-3" "plain-large")) + +;; XXX implement cleanup +(catch '() + (mkdir "private-keys-v1.d" "-rwx")) + +(define counter (make-counter)) +(for-each-p' "Storing private keys" + (lambda (name) + (dearmor (in-srcdir (string-append "/privkeys/" name ".asc")) + (string-append "private-keys-v1.d/" name ".key"))) + (lambda (name) (counter)) + '("50B2D4FA4122C212611048BC5FC31BD44393626E" + "7E201E28B6FEB2927B321F443205F4724EBE637E" + "13FDB8809B17C5547779F9D205C45F47CE0217CE" + "343D8AF79796EE107D645A2787A9D9252F924E6F" + "8B5ABF3EF9EB8D96B91A0B8C2C4401C91C834C34" + "0D6F6AD4C4C803B25470F9104E9F4E6A4CA64255" + "FD692BD59D6640A84C8422573D469F84F3B98E53" + "76F7E2B35832976B50A27A282D9B87E44577EB66" + "A0747D5F9425E6664F4FFBEED20FBCA79FDED2BD" + "00FE67F28A52A8AA08FFAED20AF832DA916D1985" + "1DF48228FEFF3EC2481B106E0ACA8C465C662CC5" + "A2832820DC9F40751BDCD375BB0945BA33EC6B4C" + "ADE710D74409777B7729A7653373D820F67892E0" + "CEFC51AF91F68A2904FBFF62C4F075A4785B803F" + "1E28F20E41B54C2D1234D896096495FF57E08D18" + "EB33B687EB8581AB64D04852A54453E85F3DF62D" + "C6A6390E9388CDBAD71EAEA698233FE5E04F001E" + "D69102E0F5AC6B6DB8E4D16DA8E18CF46D88CAE3")) + +(info "Importing public demo and test keys") +(call-check `(,@GPG --yes --import + ,(in-srcdir "pubdemo.asc") + ,(in-srcdir "pubring.asc") + ,(in-srcdir key-file1))) +;; (letfd ((source (open (in-srcdir "pubring.pkr.asc") O_RDONLY))) +;; ((gpg-pipe '(--dearmor) '(--yes --import) STDERR_FILENO) +;; source CLOSED_FD)) +(pipe:do + (pipe:open (in-srcdir "pubring.pkr.asc") (logior O_RDONLY O_BINARY)) + (pipe:spawn `(,@GPG --dearmor)) + (pipe:spawn `(,@GPG --yes --import))) + +(info "Preset passphrases") +(call-check `(,(tool 'gpg-preset-passphrase) + --preset --passphrase def + "50B2D4FA4122C212611048BC5FC31BD44393626E")) +(call-check `(,(tool 'gpg-preset-passphrase) + --preset --passphrase def + "7E201E28B6FEB2927B321F443205F4724EBE637E")) +(call-check `(,(tool 'gpg-preset-passphrase) + --preset --passphrase abc + "76F7E2B35832976B50A27A282D9B87E44577EB66")) +(call-check `(,(tool 'gpg-preset-passphrase) + --preset --passphrase abc + "A0747D5F9425E6664F4FFBEED20FBCA79FDED2BD")) + +(echo "All set up.") diff --git a/tests/openpgp/signencrypt-dsa.scm b/tests/openpgp/signencrypt-dsa.scm new file mode 100755 index 000000000..baf1def53 --- /dev/null +++ b/tests/openpgp/signencrypt-dsa.scm @@ -0,0 +1,48 @@ +#!/usr/bin/env gpgscm + +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +(load (with-path "defs.scm")) + +(for-each-p + "Checking signing and encryption using DSA" + (lambda (source) + (tr:do + (tr:open source) + (tr:gpg usrpass1 `(--yes --passphrase-fd "0" -se + -u ,dsa-usrname1 + --recipient ,dsa-usrname2)) + (tr:gpg "" '(--yes)) + (tr:assert-identity source))) + (append plain-files data-files)) + +(define algos (if (have-hash-algo? "RIPEMD160") + '("SHA1" "RIPEMD160") + '("SHA1"))) +(for-each-p + "Checking signing and encryption using DSA with a specific hash algorithm" + (lambda (hash) + (tr:do + (tr:open (car plain-files)) + (tr:gpg usrpass1 `(--yes --passphrase-fd "0" -se + -u ,dsa-usrname1 + --recipient ,dsa-usrname2 + --digest-algo ,hash)) + (tr:gpg "" '(--yes)) + (tr:assert-identity (car plain-files)))) + algos) diff --git a/tests/openpgp/signencrypt.scm b/tests/openpgp/signencrypt.scm new file mode 100755 index 000000000..b138dce50 --- /dev/null +++ b/tests/openpgp/signencrypt.scm @@ -0,0 +1,39 @@ +#!/usr/bin/env gpgscm + +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +(load (with-path "defs.scm")) + +(for-each-p + "Checking signing and encryption" + (lambda (source) + (tr:do + (tr:open source) + (tr:gpg usrpass1 `(--yes --passphrase-fd "0" -se --recipient ,usrname2)) + (tr:gpg "" '(--yes)) + (tr:assert-identity source))) + (append plain-files data-files)) + +(info "Checking bug 537: MDC problem with old style compressed packets.") +(lettmp (tmp) + (call-popen `(,@GPG --yes --passphrase-fd "0" + --output ,tmp ,(in-srcdir "bug537-test.data.asc")) + usrpass1) + (if (not (string=? "4336AE2A528FAE091E73E59E325B588FEE795F9B" + (cadar (gpg-hash-string `(--print-md SHA1 ,tmp) "")))) + (error "bug537-test.data.asc: mismatch (bug 537)"))) diff --git a/tests/openpgp/sigs-dsa.scm b/tests/openpgp/sigs-dsa.scm new file mode 100755 index 000000000..bf5e41501 --- /dev/null +++ b/tests/openpgp/sigs-dsa.scm @@ -0,0 +1,43 @@ +#!/usr/bin/env gpgscm + +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +(load (with-path "defs.scm")) + +(for-each-p + "Checking signing using DSA with the default hash algorithm" + (lambda (source) + (tr:do + (tr:open source) + (tr:gpg "" `(--yes --sign --user ,dsa-usrname1)) + (tr:gpg "" '(--yes)) + (tr:assert-identity source))) + (append plain-files data-files)) + +(define algos (if (have-hash-algo? "RIPEMD160") + '("SHA1" "RIPEMD160") + '("SHA1"))) +(for-each-p + "Checking signing using DSA with a specific hash algorithm" + (lambda (hash) + (tr:do + (tr:open (car plain-files)) + (tr:gpg "" `(--yes --sign --user ,dsa-usrname1 --digest-algo ,hash)) + (tr:gpg "" '(--yes)) + (tr:assert-identity (car plain-files)))) + algos) diff --git a/tests/openpgp/sigs.scm b/tests/openpgp/sigs.scm new file mode 100755 index 000000000..c47823108 --- /dev/null +++ b/tests/openpgp/sigs.scm @@ -0,0 +1,50 @@ +#!/usr/bin/env gpgscm + +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +(load (with-path "defs.scm")) + +(for-each-p + "Checking signing with the default hash algorithm" + (lambda (source) + (tr:do + (tr:open source) + (tr:gpg "" '(--yes --sign)) + (tr:gpg "" '(--yes)) + (tr:assert-identity source))) + (append plain-files data-files)) + +(for-each-p + "Checking signing with a specific hash algorithm" + (lambda (hash) + (if (have-pubkey-algo? "RSA") + ;; RSA key, so any hash is okay. + (tr:do + (tr:open (car plain-files)) + (tr:gpg "" `(--yes --sign --user ,usrname3 --digest-algo ,hash)) + (tr:gpg "" '(--yes)) + (tr:assert-identity (car plain-files)))) + (if (not (equal? "MD5" hash)) + ;; Using the DSA sig key - only 160 bit or larger hashes + (tr:do + (tr:open (car plain-files)) + (tr:gpg usrpass1 + `(--yes --sign --passphrase-fd "0" --digest-algo ,hash)) + (tr:gpg "" '(--yes)) + (tr:assert-identity (car plain-files))))) + all-hash-algos) diff --git a/tests/openpgp/tofu.scm b/tests/openpgp/tofu.scm new file mode 100755 index 000000000..38b6a0f0f --- /dev/null +++ b/tests/openpgp/tofu.scm @@ -0,0 +1,167 @@ +#!/usr/bin/env gpgscm + +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +(load (with-path "defs.scm")) + + ;; Redefine GPG without --always-trust and a fixed time. +(define GPG `(,(tool 'gpg) --no-permission-warning + --faked-system-time=1466684990)) +(define GNUPGHOME (getenv "GNUPGHOME")) +(if (string=? "" GNUPGHOME) + (error "GNUPGHOME not set")) + +(catch (skip "Tofu not supported") + (call-check `(,@GPG --trust-model=tofu --list-config))) + +(define KEYS '("2183839A" "BC15C85A" "EE37CF96")) + +;; Import the test keys. +(call-check `(,@GPG --import ,(in-srcdir "tofu-keys.asc"))) + +;; Make sure the keys are imported. +(for-each (lambda (keyid) + (catch (error "Missing key" keyid) + (call-check `(,@GPG --list-keys ,keyid)))) + KEYS) + +;; Get tofu policy for KEYID. Any remaining arguments are simply +;; passed to GPG. +;; +;; This function only supports keys with a single user id. +(define (getpolicy keyid format . args) + (let ((policy + (list-ref (assoc "uid" (gpg-with-colons + `(--tofu-db-format ,format + --trust-model=tofu + ,@args + --list-keys ,keyid))) 17))) + (unless (member policy '("auto" "good" "unknown" "bad" "ask")) + (error "Bad policy:" policy)) + policy)) + +;; Check that KEYID's tofu policy matches EXPECTED-POLICY. Any +;; remaining arguments are simply passed to GPG. +;; +;; This function only supports keys with a single user id. +(define (checkpolicy keyid format expected-policy . args) + (let ((policy (apply getpolicy `(,keyid ,format ,@args)))) + (unless (string=? policy expected-policy) + (error keyid ": Expected policy to be" expected-policy + "but got" policy)))) + +;; Get the trust level for KEYID. Any remaining arguments are simply +;; passed to GPG. +;; +;; This function only supports keys with a single user id. +(define (gettrust keyid format . args) + (let ((trust + (list-ref (assoc "pub" (gpg-with-colons + `(--tofu-db-format ,format + --trust-model=tofu + ,@args + --list-keys ,keyid))) 1))) + (unless (and (= 1 (string-length trust)) + (member (string-ref trust 0) (string->list "oidreqnmfuws-"))) + (error "Bad trust value:" trust)) + trust)) + +;; Check that KEYID's trust level matches EXPECTED-TRUST. Any +;; remaining arguments are simply passed to GPG. +;; +;; This function only supports keys with a single user id. +(define (checktrust keyid format expected-trust . args) + (let ((trust (apply gettrust `(,keyid ,format ,@args)))) + (unless (string=? trust expected-trust) + (error keyid ": Expected trust to be" expected-trust + "but got" trust)))) + +;; Set key KEYID's policy to POLICY. Any remaining arguments are +;; passed as options to gpg. +(define (setpolicy keyid format policy . args) + (call-check `(,@GPG --tofu-db-format ,format + --trust-model=tofu ,@args + --tofu-policy ,policy ,keyid))) + +(for-each-p + "Testing tofu db formats" + (lambda (format) + ;; Carefully remove the TOFU db. + (catch '() (unlink (string-append GNUPGHOME "/tofu.db"))) + (catch '() (unlink-recursively (string-append GNUPGHOME "/tofu.d"))) + + ;; Verify a message. There should be no conflict and the trust + ;; policy should be set to auto. + (call-check `(,@GPG --tofu-db-format ,format --trust-model=tofu + --verify ,(in-srcdir "tofu-2183839A-1.txt"))) + + (checkpolicy "2183839A" format "auto") + ;; Check default trust. + (checktrust "2183839A" format "m") + + ;; Trust should be derived lazily. Thus, if the policy is set to + ;; auto and we change --tofu-default-policy, then the trust should + ;; change as well. Try it. + (checktrust "2183839A" format "f" '--tofu-default-policy=good) + (checktrust "2183839A" format "-" '--tofu-default-policy=unknown) + (checktrust "2183839A" format "n" '--tofu-default-policy=bad) + + ;; Change the policy to something other than auto and make sure the + ;; policy and the trust are correct. + (for-each-p + "" + (lambda (policy) + (let ((expected-trust + (cond + ((string=? "good" policy) "f") + ((string=? "unknown" policy) "-") + (else "n")))) + (setpolicy "2183839A" format policy) + + ;; Since we have a fixed policy, the trust level shouldn't + ;; change if we change the default policy. + (for-each-p + "" + (lambda (default-policy) + (checkpolicy "2183839A" format policy + '--tofu-default-policy default-policy) + (checktrust "2183839A" format expected-trust + '--tofu-default-policy default-policy)) + '("auto" "good" "unknown" "bad" "ask")))) + '("good" "unknown" "bad")) + + ;; BC15C85A conflicts with 2183839A. On conflict, this will set + ;; BC15C85A to ask. If 2183839A is auto (it's not, it's bad), then + ;; it will be set to ask. + (call-check `(,@GPG --tofu-db-format ,format --trust-model=tofu + --verify ,(in-srcdir "tofu-BC15C85A-1.txt"))) + (checkpolicy "BC15C85A" format "ask") + (checkpolicy "2183839A" format "bad") + + ;; EE37CF96 conflicts with 2183839A and BC15C85A. We change + ;; BC15C85A's policy to auto and leave 2183839A's policy at bad. + ;; This conflict should cause BC15C85A's policy to be changed to + ;; ask (since it is auto), but not affect 2183839A's policy. + (setpolicy "BC15C85A" format "auto") + (checkpolicy "BC15C85A" format "auto") + (call-check `(,@GPG --tofu-db-format ,format --trust-model=tofu + --verify ,(in-srcdir "tofu-EE37CF96-1.txt"))) + (checkpolicy "BC15C85A" format "ask") + (checkpolicy "2183839A" format "bad") + (checkpolicy "EE37CF96" format "ask")) + '("split" "flat")) diff --git a/tests/openpgp/tofu.test b/tests/openpgp/tofu.test index 18c17562c..0d34af409 100755 --- a/tests/openpgp/tofu.test +++ b/tests/openpgp/tofu.test @@ -4,6 +4,9 @@ # set -x +# Redefine GPG with a fixed time. +GPG="$GPG --faked-system-time=1466684990" + KEYS="2183839A BC15C85A EE37CF96" # Make sure $srcdir is set. diff --git a/tests/openpgp/use-exact-key.scm b/tests/openpgp/use-exact-key.scm new file mode 100755 index 000000000..bec537bb9 --- /dev/null +++ b/tests/openpgp/use-exact-key.scm @@ -0,0 +1,68 @@ +#!/usr/bin/env gpgscm + +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +(load (with-path "defs.scm")) + +;; Import the sample key +;; +;; pub 1024R/8BC90111 2015-12-02 +;; Key fingerprint = E657 FB60 7BB4 F21C 90BB 6651 BC06 7AF2 8BC9 0111 +;; uid [ultimate] Barrett Brown <[email protected]> +;; sub 1024R/3E880CFF 2015-12-02 (encryption) +;; sub 1024R/F5F77B83 2015-12-02 (signing) +;; sub 1024R/45117079 2015-12-02 (encryption) +;; sub 1024R/1EA97479 2015-12-02 (signing) + +(info "Importing public key.") +(call-check + `(,(tool 'gpg) --import + ,(in-srcdir "samplekeys/E657FB607BB4F21C90BB6651BC067AF28BC90111.asc"))) + +;; By default, the most recent, valid signing subkey (1EA97479). +(for-each-p + "Checking that the most recent, valid signing subkey is used by default" + (lambda (keyid) + (tr:do + (tr:pipe-do + (pipe:defer (lambda (sink) (display "" (fdopen sink "w")))) + (pipe:gpg `(-s -u ,keyid)) + (pipe:gpg '(--verify --status-fd=1))) + (tr:call-with-content + (lambda (c) + (unless (string-contains? + c "VALIDSIG 5FBA84ACE02DCB17DA3DFF6BBCA43C441EA97479") + (exit 1)))))) + '("8BC90111" "3E880CFF" "F5F77B83" "45117079" "1EA97479")) + +;; But, if we request a particular signing key, we should get it. +(for-each-p + "Checking that we can select a specific signing key" + (lambda (keyid) + (tr:do + (tr:pipe-do + (pipe:defer (lambda (sink) (display "" (fdopen sink "w")))) + (pipe:gpg `(-s -u ,(string-append keyid "!"))) + (pipe:gpg '(--verify --status-fd=1))) + (tr:call-with-content + (lambda (c) + ;; XXX we do not have a regexp library + (unless (and (string-contains? c "VALIDSIG") + (string-contains? c keyid)) + (exit 1)))))) + '("8BC90111" "F5F77B83" "1EA97479")) diff --git a/tests/openpgp/verify.scm b/tests/openpgp/verify.scm new file mode 100755 index 000000000..de03db531 --- /dev/null +++ b/tests/openpgp/verify.scm @@ -0,0 +1,274 @@ +#!/usr/bin/env gpgscm + +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +(load (with-path "defs.scm")) + +;; +;; Two simple tests to check that verify fails for bad input data +;; +(for-each-p + "Checking bogus signature" + (lambda (char) + (lettmp (x) + (pipe:do + (pipe:spawn `(,(tool 'mktdata) --char ,char "64")) + (pipe:write-to x (logior O_WRONLY O_CREAT O_BINARY) #o600)) + (if (= 0 (call `(,@GPG --verify ,x data-500))) + (error "no error code from verify")))) + '("0x2d" "0xca")) + +;; A plain signed message created using +;; echo abc | gpg --homedir . --passphrase-fd 0 -u Alpha -z0 -sa msg +(define msg_ols_asc " +-----BEGIN PGP MESSAGE----- + +kA0DAAIRLXJ8x2hpdzQBrQEHYgNtc2dEDFJaSSB0aGluayB0aGF0IGFsbCByaWdo +dC10aGlua2luZyBwZW9wbGUgaW4gdGhpcyBjb3VudHJ5IGFyZSBzaWNrIGFuZAp0 +aXJlZCBvZiBiZWluZyB0b2xkIHRoYXQgb3JkaW5hcnkgZGVjZW50IHBlb3BsZSBh +cmUgZmVkIHVwIGluIHRoaXMKY291bnRyeSB3aXRoIGJlaW5nIHNpY2sgYW5kIHRp +cmVkLiAgSSdtIGNlcnRhaW5seSBub3QuICBCdXQgSSdtCnNpY2sgYW5kIHRpcmVk +IG9mIGJlaW5nIHRvbGQgdGhhdCBJIGFtLgotIE1vbnR5IFB5dGhvbgqIPwMFAEQM +UlotcnzHaGl3NBECR4IAoJlEGTY+bHjD2HYuCixLQCmk01pbAKCIjkzLOAmkZNm0 +D8luT78c/1x45Q== +=a29i +-----END PGP MESSAGE----- +") + +;; A plain signed message created using +;; echo abc | gpg --homedir . --passphrase-fd 0 -u Alpha -sa msg +(define msg_cols_asc " +-----BEGIN PGP MESSAGE----- + +owGbwMvMwCSoW1RzPCOz3IRxLSN7EnNucboLT6Cgp0JJRmZeNpBMLFFIzMlRKMpM +zyjRBQtm5qUrFKTmF+SkKmTmgdQVKyTnl+aVFFUqJBalKhRnJmcrJOalcJVkFqWm +KOSnKSSlgrSU5OekQMzLL0rJzEsEKk9JTU7NK4EZBtKcBtRRWgAzlwtmbnlmSQbU +GJjxCmDj9RQUPNVzFZJTi0oSM/NyKhXy8kuAYk6lJSBxLlTF2NziqZCYq8elq+Cb +n1dSqRBQWZKRn8fVYc/MygAKBljYCDIFiTDMT+9seu836Q+bevyHTJ0dzPNuvCjn +ZpgrwX38z58rJsfYDhwOSS4SkN/d6vUAAA== +=s6sY +-----END PGP MESSAGE----- +") + +;; A PGP 2 style message. +(define msg_sl_asc " +-----BEGIN PGP MESSAGE----- + +iD8DBQBEDFJaLXJ8x2hpdzQRAkeCAKCZRBk2Pmx4w9h2LgosS0AppNNaWwCgiI5M +yzgJpGTZtA/Jbk+/HP9ceOWtAQdiA21zZ0QMUlpJIHRoaW5rIHRoYXQgYWxsIHJp +Z2h0LXRoaW5raW5nIHBlb3BsZSBpbiB0aGlzIGNvdW50cnkgYXJlIHNpY2sgYW5k +CnRpcmVkIG9mIGJlaW5nIHRvbGQgdGhhdCBvcmRpbmFyeSBkZWNlbnQgcGVvcGxl +IGFyZSBmZWQgdXAgaW4gdGhpcwpjb3VudHJ5IHdpdGggYmVpbmcgc2ljayBhbmQg +dGlyZWQuICBJJ20gY2VydGFpbmx5IG5vdC4gIEJ1dCBJJ20Kc2ljayBhbmQgdGly +ZWQgb2YgYmVpbmcgdG9sZCB0aGF0IEkgYW0uCi0gTW9udHkgUHl0aG9uCg== +=0ukK +-----END PGP MESSAGE----- +") + +;; An OpenPGP message lacking the onepass packet. We used to accept +;; such messages but now consider them invalid. +(define bad_ls_asc " +-----BEGIN PGP MESSAGE----- + +rQEHYgNtc2dEDFJaSSB0aGluayB0aGF0IGFsbCByaWdodC10aGlua2luZyBwZW9w +bGUgaW4gdGhpcyBjb3VudHJ5IGFyZSBzaWNrIGFuZAp0aXJlZCBvZiBiZWluZyB0 +b2xkIHRoYXQgb3JkaW5hcnkgZGVjZW50IHBlb3BsZSBhcmUgZmVkIHVwIGluIHRo +aXMKY291bnRyeSB3aXRoIGJlaW5nIHNpY2sgYW5kIHRpcmVkLiAgSSdtIGNlcnRh +aW5seSBub3QuICBCdXQgSSdtCnNpY2sgYW5kIHRpcmVkIG9mIGJlaW5nIHRvbGQg +dGhhdCBJIGFtLgotIE1vbnR5IFB5dGhvbgqIPwMFAEQMUlotcnzHaGl3NBECR4IA +oJlEGTY+bHjD2HYuCixLQCmk01pbAKCIjkzLOAmkZNm0D8luT78c/1x45Q== +=Mpiu +-----END PGP MESSAGE----- +") + + +;; A signed message prefixed with an unsigned literal packet. +;; (fols = faked-literal-data, one-pass, literal-data, signature) +;; This should throw an error because running gpg to extract the +;; signed data will return both literal data packets +(define bad_fols_asc " +-----BEGIN PGP MESSAGE----- + +rF1iDG1zZy51bnNpZ25lZEQMY0x0aW1lc2hhcmluZywgbjoKCUFuIGFjY2VzcyBt +ZXRob2Qgd2hlcmVieSBvbmUgY29tcHV0ZXIgYWJ1c2VzIG1hbnkgcGVvcGxlLgqQ +DQMAAhEtcnzHaGl3NAGtAQdiA21zZ0QMUlpJIHRoaW5rIHRoYXQgYWxsIHJpZ2h0 +LXRoaW5raW5nIHBlb3BsZSBpbiB0aGlzIGNvdW50cnkgYXJlIHNpY2sgYW5kCnRp +cmVkIG9mIGJlaW5nIHRvbGQgdGhhdCBvcmRpbmFyeSBkZWNlbnQgcGVvcGxlIGFy +ZSBmZWQgdXAgaW4gdGhpcwpjb3VudHJ5IHdpdGggYmVpbmcgc2ljayBhbmQgdGly +ZWQuICBJJ20gY2VydGFpbmx5IG5vdC4gIEJ1dCBJJ20Kc2ljayBhbmQgdGlyZWQg +b2YgYmVpbmcgdG9sZCB0aGF0IEkgYW0uCi0gTW9udHkgUHl0aG9uCog/AwUARAxS +Wi1yfMdoaXc0EQJHggCgmUQZNj5seMPYdi4KLEtAKaTTWlsAoIiOTMs4CaRk2bQP +yW5Pvxz/XHjl +=UNM4 +-----END PGP MESSAGE----- +") + +;; A signed message suffixed with an unsigned literal packet. +;; (fols = faked-literal-data, one-pass, literal-data, signature) +;; This should throw an error because running gpg to extract the +;; signed data will return both literal data packets +(define bad_olsf_asc " +-----BEGIN PGP MESSAGE----- + +kA0DAAIRLXJ8x2hpdzQBrQEHYgNtc2dEDFJaSSB0aGluayB0aGF0IGFsbCByaWdo +dC10aGlua2luZyBwZW9wbGUgaW4gdGhpcyBjb3VudHJ5IGFyZSBzaWNrIGFuZAp0 +aXJlZCBvZiBiZWluZyB0b2xkIHRoYXQgb3JkaW5hcnkgZGVjZW50IHBlb3BsZSBh +cmUgZmVkIHVwIGluIHRoaXMKY291bnRyeSB3aXRoIGJlaW5nIHNpY2sgYW5kIHRp +cmVkLiAgSSdtIGNlcnRhaW5seSBub3QuICBCdXQgSSdtCnNpY2sgYW5kIHRpcmVk +IG9mIGJlaW5nIHRvbGQgdGhhdCBJIGFtLgotIE1vbnR5IFB5dGhvbgqIPwMFAEQM +UlotcnzHaGl3NBECR4IAoJlEGTY+bHjD2HYuCixLQCmk01pbAKCIjkzLOAmkZNm0 +D8luT78c/1x45axdYgxtc2cudW5zaWduZWREDGNMdGltZXNoYXJpbmcsIG46CglB +biBhY2Nlc3MgbWV0aG9kIHdoZXJlYnkgb25lIGNvbXB1dGVyIGFidXNlcyBtYW55 +IHBlb3BsZS4K +=3gnG +-----END PGP MESSAGE----- +") + + +;; Two standard signed messages in a row +(define msg_olsols_asc_multiple " +-----BEGIN PGP MESSAGE----- + +kA0DAAIRLXJ8x2hpdzQBrQEHYgNtc2dEDFJaSSB0aGluayB0aGF0IGFsbCByaWdo +dC10aGlua2luZyBwZW9wbGUgaW4gdGhpcyBjb3VudHJ5IGFyZSBzaWNrIGFuZAp0 +aXJlZCBvZiBiZWluZyB0b2xkIHRoYXQgb3JkaW5hcnkgZGVjZW50IHBlb3BsZSBh +cmUgZmVkIHVwIGluIHRoaXMKY291bnRyeSB3aXRoIGJlaW5nIHNpY2sgYW5kIHRp +cmVkLiAgSSdtIGNlcnRhaW5seSBub3QuICBCdXQgSSdtCnNpY2sgYW5kIHRpcmVk +IG9mIGJlaW5nIHRvbGQgdGhhdCBJIGFtLgotIE1vbnR5IFB5dGhvbgqIPwMFAEQM +UlotcnzHaGl3NBECR4IAoJlEGTY+bHjD2HYuCixLQCmk01pbAKCIjkzLOAmkZNm0 +D8luT78c/1x45ZANAwACES1yfMdoaXc0Aa0BB2IDbXNnRAxSWkkgdGhpbmsgdGhh +dCBhbGwgcmlnaHQtdGhpbmtpbmcgcGVvcGxlIGluIHRoaXMgY291bnRyeSBhcmUg +c2ljayBhbmQKdGlyZWQgb2YgYmVpbmcgdG9sZCB0aGF0IG9yZGluYXJ5IGRlY2Vu +dCBwZW9wbGUgYXJlIGZlZCB1cCBpbiB0aGlzCmNvdW50cnkgd2l0aCBiZWluZyBz +aWNrIGFuZCB0aXJlZC4gIEknbSBjZXJ0YWlubHkgbm90LiAgQnV0IEknbQpzaWNr +IGFuZCB0aXJlZCBvZiBiZWluZyB0b2xkIHRoYXQgSSBhbS4KLSBNb250eSBQeXRo +b24KiD8DBQBEDFJaLXJ8x2hpdzQRAkeCAKCZRBk2Pmx4w9h2LgosS0AppNNaWwCg +iI5MyzgJpGTZtA/Jbk+/HP9ceOU= +=8nLN +-----END PGP MESSAGE----- +") + +;; A standard message with two signatures (actually the same signature +;; duplicated). +(define msg_oolss_asc " +-----BEGIN PGP MESSAGE----- + +kA0DAAIRLXJ8x2hpdzQBkA0DAAIRLXJ8x2hpdzQBrQEHYgNtc2dEDFJaSSB0aGlu +ayB0aGF0IGFsbCByaWdodC10aGlua2luZyBwZW9wbGUgaW4gdGhpcyBjb3VudHJ5 +IGFyZSBzaWNrIGFuZAp0aXJlZCBvZiBiZWluZyB0b2xkIHRoYXQgb3JkaW5hcnkg +ZGVjZW50IHBlb3BsZSBhcmUgZmVkIHVwIGluIHRoaXMKY291bnRyeSB3aXRoIGJl +aW5nIHNpY2sgYW5kIHRpcmVkLiAgSSdtIGNlcnRhaW5seSBub3QuICBCdXQgSSdt +CnNpY2sgYW5kIHRpcmVkIG9mIGJlaW5nIHRvbGQgdGhhdCBJIGFtLgotIE1vbnR5 +IFB5dGhvbgqIPwMFAEQMUlotcnzHaGl3NBECR4IAoJlEGTY+bHjD2HYuCixLQCmk +01pbAKCIjkzLOAmkZNm0D8luT78c/1x45Yg/AwUARAxSWi1yfMdoaXc0EQJHggCg +mUQZNj5seMPYdi4KLEtAKaTTWlsAoIiOTMs4CaRk2bQPyW5Pvxz/XHjl +=KVw5 +-----END PGP MESSAGE----- +") + +;; A standard message with two one-pass packet but only one signature +;; packet +(define bad_ools_asc " +-----BEGIN PGP MESSAGE----- + +kA0DAAIRLXJ8x2hpdzQBkA0DAAIRLXJ8x2hpdzQBrQEHYgNtc2dEDFJaSSB0aGlu +ayB0aGF0IGFsbCByaWdodC10aGlua2luZyBwZW9wbGUgaW4gdGhpcyBjb3VudHJ5 +IGFyZSBzaWNrIGFuZAp0aXJlZCBvZiBiZWluZyB0b2xkIHRoYXQgb3JkaW5hcnkg +ZGVjZW50IHBlb3BsZSBhcmUgZmVkIHVwIGluIHRoaXMKY291bnRyeSB3aXRoIGJl +aW5nIHNpY2sgYW5kIHRpcmVkLiAgSSdtIGNlcnRhaW5seSBub3QuICBCdXQgSSdt +CnNpY2sgYW5kIHRpcmVkIG9mIGJlaW5nIHRvbGQgdGhhdCBJIGFtLgotIE1vbnR5 +IFB5dGhvbgqIPwMFAEQMUlotcnzHaGl3NBECR4IAoJlEGTY+bHjD2HYuCixLQCmk +01pbAKCIjkzLOAmkZNm0D8luT78c/1x45Q== +=1/ix +-----END PGP MESSAGE----- +") + +;; Standard cleartext signature +(define msg_cls_asc " +-----BEGIN PGP SIGNED MESSAGE----- +Hash: SHA1 + +I think that all right-thinking people in this country are sick and +tired of being told that ordinary decent people are fed up in this +country with being sick and tired. I'm certainly not. But I'm +sick and tired of being told that I am. +- - Monty Python +-----BEGIN PGP SIGNATURE----- + +iD8DBQFEDVp1LXJ8x2hpdzQRAplUAKCMfpG3GPw/TLN52tosgXP5lNECkwCfQhAa +emmev7IuQjWYrGF9Lxj+zj8= +=qJsY +-----END PGP SIGNATURE----- +") + +;; Cleartext signature with two signatures +(define msg_clss_asc " +-----BEGIN PGP SIGNED MESSAGE----- +Hash: SHA1 + +What is the difference between a Turing machine and the modern computer? +It's the same as that between Hillary's ascent of Everest and the +establishment of a Hilton on its peak. +-----BEGIN PGP SIGNATURE----- + +iD8DBQFEDVz6LXJ8x2hpdzQRAtkGAKCeMhNbHnh339fpjNj9owsYcC4zBwCfYO5l +2u+KEfXX0FKyk8SMzLjZ536IPwMFAUQNXPr+GAsdqeOwshEC2QYAoPOWAiQm0EF/ +FWIAQUplk7JWbyRKAJ92ZJyJpWfzb0yc1s7MY65r2qEHrg== +=1Xvv +-----END PGP SIGNATURE----- +") + +;; Two clear text signatures in a row +(define msg_clsclss_asc_multiple (string-append msg_cls_asc msg_clss_asc)) + +;; Fixme: We need more tests with manipulated cleartext signatures. + +;; +;; Now run the tests. +;; +(for-each-p + "Checking that a valid signature is verified as such" + (lambda (armored-file) + (pipe:do + (pipe:echo (eval armored-file (current-environment))) + (pipe:spawn `(,@GPG --verify)))) + '(msg_ols_asc msg_cols_asc msg_sl_asc msg_oolss_asc msg_cls_asc msg_clss_asc)) + +(for-each-p + "Checking that a valid signature over multiple messages is verified as such" + (lambda (armored-file) + (pipe:do + (pipe:echo (eval armored-file (current-environment))) + (pipe:spawn `(,@GPG --verify --allow-multiple-messages))) + (catch '() + (pipe:do + (pipe:defer (lambda (sink) + (display armored-file (fdopen sink "w")))) + (pipe:spawn `(,@GPG --verify))) + (error "verification succeded but should not"))) + '(msg_olsols_asc_multiple msg_clsclss_asc_multiple)) + +(for-each-p + "Checking that an invalid signature is verified as such" + (lambda (armored-file) + (catch '() + (pipe:do + (pipe:echo (eval armored-file (current-environment))) + (pipe:spawn `(,@GPG --verify))) + (error "verification succeded but should not"))) + '(bad_ls_asc bad_fols_asc bad_olsf_asc bad_ools_asc)) diff --git a/tests/openpgp/version.scm b/tests/openpgp/version.scm new file mode 100755 index 000000000..57efb937b --- /dev/null +++ b/tests/openpgp/version.scm @@ -0,0 +1,24 @@ +#!/usr/bin/env gpgscm + +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +(load (with-path "defs.scm")) + +(info "Printing the GPG version") +(assert (string-contains? (call-check `(,@GPG --version)) + "gpg (GnuPG) 2.")) |