security-and-privacy/gnupg
security-and-privacy
/
gnupg
mirror of git://git.gnupg.org/gnupg.git
1
0
Fork 0
Code Releases Activity

tests/gpgscm: Add a TinySCHEME-based test driver. 

* configure.ac: Add new component.
* tests/Makefile.am: Likewise.
* tests/gpgscm/Makefile.am: New file.
* tests/gpgscm/ffi-private.h: Likewise.
* tests/gpgscm/ffi.c: Likewise.
* tests/gpgscm/ffi.h: Likewise.
* tests/gpgscm/ffi.scm: Likewise.
* tests/gpgscm/lib.scm: Likewise.
* tests/gpgscm/main.c: Likewise.
* tests/gpgscm/private.h: Likewise.
* tests/gpgscm/repl.scm: Likewise.
* tests/gpgscm/scheme-config.h: Likewise.
* tests/gpgscm/t-child.c: Likewise.
* tests/gpgscm/t-child.scm: Likewise.
* tests/gpgscm/tests.scm: Likewise.

Signed-off-by: Justus Winter <justus@g10code.com>
This commit is contained in:
Justus Winter 2016-01-06 11:55:25 +01:00
parent e86e90cc03
commit e3e51316f1
15 changed files with 2531 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
configure.ac
View File

@ -1898,6 +1898,7 @@ tools/gpg-zip
tools/Makefile
doc/Makefile
tests/Makefile
tests/gpgscm/Makefile
tests/openpgp/Makefile
tests/migrations/Makefile
tests/pkits/Makefile

2
tests/Makefile.am
View File

@ -25,7 +25,7 @@ else
openpgp =
endif
SUBDIRS = ${openpgp} . migrations pkits
SUBDIRS = gpgscm ${openpgp} . migrations pkits
GPGSM = ../sm/gpgsm

57
tests/gpgscm/Makefile.am Normal file
View File

@ -0,0 +1,57 @@
# 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 = \
COPYING \
Manual.txt \
ffi.scm \
init.scm \
lib.scm \
t-child.scm \
tests.scm
AM_CPPFLAGS = -I$(top_srcdir)/common
include $(top_srcdir)/am/cmacros.am
AM_CFLAGS =
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)
.PHONY: check
check: gpgscm$(EXEEXT) t-child$(EXEEXT)
EXEEXT=$(EXEEXT) GPGSCM_PATH=$(srcdir) \
./gpgscm$(EXEEXT) $(srcdir)/t-child.scm

132
tests/gpgscm/ffi-private.h Normal file
View File

@ -0,0 +1,132 @@
/* 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_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_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)))
const 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 { \
scheme_define ((SC), \
(SC)->global_env, \
mk_symbol ((SC), ffi_schemify_name ("_" #F, 0)), \
mk_foreign_func ((SC), (do_##F))); \
ffi_scheme_eval ((SC), \
"(define (%s . a) (ffi-apply \"%s\" %s a))", \
(NAME), (NAME), ffi_schemify_name ("_" #F, 0)); \
} while (0)
#define ffi_define_function(SC, F) \
ffi_define_function_name ((SC), ffi_schemify_name (#F, 0), F)
#define ffi_define_constant(SC, C) \
scheme_define ((SC), \
(SC)->global_env, \
mk_symbol ((SC), ffi_schemify_name (#C, 1)), \
mk_integer ((SC), (C)))
#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) \
scheme_define ((SC), \
(SC)->global_env, \
mk_symbol ((SC), ffi_schemify_name (#C, 0)), \
(P))
#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 */

1167
tests/gpgscm/ffi.c Normal file
View File

File diff suppressed because it is too large Load Diff

30
tests/gpgscm/ffi.h Normal file
View File

@ -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 */

40
tests/gpgscm/ffi.scm Normal file
View File

@ -0,0 +1,40 @@
;; 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))))

163
tests/gpgscm/lib.scm Normal file
View File

@ -0,0 +1,163 @@
;; 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.
(define (string-index haystack needle)
(define (index i haystack needle)
(if (= (length haystack) 0)
#f
(if (char=? (car haystack) needle)
i
(index (+ i 1) (cdr haystack) needle))))
(index 0 (string->list haystack) needle))
;; Locate the last occurrence of needle in haystack.
(define (string-rindex haystack needle)
(let ((rindex (string-index (list->string (reverse (string->list haystack)))
needle)))
(if rindex (- (string-length haystack) rindex 1) #f)))
;; Split haystack at delimiter at most n times.
(define (string-splitn haystack delimiter n)
(define (split acc haystack delimiter n)
(if (= (string-length haystack) 0)
(reverse acc)
(let ((i (string-index haystack delimiter)))
(if (not (or (eq? i #f) (= 0 n)))
(split (cons (substring haystack 0 i) acc)
(substring haystack (+ i 1) (string-length haystack))
delimiter (- n 1))
(split (cons haystack acc) "" delimiter 0)
))))
(split '() haystack delimiter n))
;; Split haystack at delimiter.
(define (string-split haystack delimiter)
(string-splitn haystack delimiter -1))
;; Trim the prefix of S containing only characters that make PREDICATE
;; true. For example (string-ltrim char-whitespace? " foo") =>
;; "foo".
(define (string-ltrim predicate s)
(let loop ((s' (string->list s)))
(if (predicate (car s'))
(loop (cdr s'))
(list->string s'))))
;; 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')))))
;; 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)))
(define (string-contains? s contained)
(let loop ((offset 0))
(if (<= (+ offset (string-length contained)) (string-length s))
(if (string=? (substring s offset (+ offset (string-length contained)))
contained)
#t
(loop (+ 1 offset)))
#f)))
(define (echo . msg)
(for-each (lambda (x) (display x) (display " ")) msg)
(newline))
;; 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)
(list->string
(let f ()
(let ((c (apply peek-char p)))
(cond
((eof-object? c) '())
(else (apply read-char p)
(cons c (f))))))))

286
tests/gpgscm/main.c Normal file
View File

@ -0,0 +1,286 @@
/* 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"
/* 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 ();
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);
return EXIT_SUCCESS;
}

26
tests/gpgscm/private.h Normal file
View File

@ -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__ */

50
tests/gpgscm/repl.scm Normal file
View File

@ -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))))

36
tests/gpgscm/scheme-config.h Normal file
View File

@ -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__ */

66
tests/gpgscm/t-child.c Normal file
View File

@ -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;
}

74
tests/gpgscm/t-child.scm Normal file
View File

@ -0,0 +1,74 @@
(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.")

402
tests/gpgscm/tests.scm Normal file
View File

@ -0,0 +1,402 @@
;; 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 (info msg)
(display msg)
(newline)
(flush-stdio))
(define (error msg)
(info msg)
(exit 1))
(define (skip msg)
(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)))
(define (call-check what)
(if (not (= 0 (call what)))
(throw (list what "failed"))))
;; 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-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=? 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 (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))))))
;; 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 "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 (string-append (mkdtemp "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)))
(loop (car v) (cadr v) (cdr cmds))))))
(define (tr:open pathname)
(lambda (tmpfiles source)
(list tmpfiles pathname)))
(define (tr:spawn input command)
(lambda (tmpfiles source)
(let* ((t (make-temporary-file))
(cmd (map (lambda (x)
(cond
((equal? '**in** x) source)
((equal? '**out** x) t)
(else x))) command)))
(call-popen cmd input)
(list (cons t tmpfiles) t))))
(define (tr:write-to pathname)
(lambda (tmpfiles source)
(rename source pathname)
(list tmpfiles pathname)))
(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))))
(define (tr:assert-identity reference)
(lambda (tmpfiles source)
(if (not (file=? source reference))
(error "mismatch"))
(list tmpfiles source)))
(define (tr:assert-weak-identity reference)
(lambda (tmpfiles source)
(if (not (text-file=? source reference))
(error "mismatch"))
(list tmpfiles source)))
(define (tr:call-with-content function)
(lambda (tmpfiles source)
(function (call-with-input-file source read-all))
(list tmpfiles source)))