diff --git a/Makefile.am b/Makefile.am
index dc999fb..1bdd373 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -1,62 +1,63 @@
 # 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 <https://www.gnu.org/licenses/>.
 
 EXTRA_DIST = \
 	LICENSE.TinySCHEME \
 	Manual.txt \
 	ffi.scm \
 	init.scm \
 	lib.scm \
 	repl.scm \
 	t-child.scm \
+	xml.scm \
 	tests.scm \
 	gnupg.scm \
 	time.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 scheme.c scheme.h scheme-private.h \
 	opdefines.h small-integers.h
 gpgscm_LDADD = $(LDADD) $(common_libs) \
 	$(NETLIBS) $(LIBICONV) $(LIBREADLINE) $(LIBINTL) \
 	$(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/lib.scm b/lib.scm
index cafca8d..258f692 100644
--- a/lib.scm
+++ b/lib.scm
@@ -1,300 +1,307 @@
 ;; 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)
   (let ((tag (get-tag form)))
     `(if (not ,(cadr form))
 	 (throw ,(if (and (pair? tag) (string? (car tag)) (number? (cdr tag)))
 		     `(string-append ,(car tag) ":"
 				     ,(number->string (+ 1 (cdr tag)))
 				     ": Assertion failed: ")
 		     "Assertion failed: ")
 		(quote ,(cadr form))))))
 (assert #t)
 (assert (not #f))
 
 ;; 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)))
 
 (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)))))
 
 ;; Return the first element of a list.
 (define first car)
 
 ;; Return the last element of a list.
 (define (last lst)
   (if (null? (cdr lst))
       (car lst)
       (last (cdr lst))))
 
 ;; Compute the powerset of a list.
 (define (powerset set)
   (if (null? set)
       '(())
       (let ((rst (powerset (cdr set))))
         (append (map (lambda (x) (cons (car set) x))
                      rst)
                 rst))))
 
 ;; 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 each character that makes PREDICATE true at most
 ;; N times.
 (define (string-split-pln haystack predicate lookahead n)
   (let ((length (string-length haystack)))
     (define (split acc offset n)
       (if (>= offset length)
 	  (reverse! acc)
 	  (let ((i (lookahead haystack offset)))
 	    (if (or (eq? i #f) (= 0 n))
 		(reverse! (cons (substring haystack offset length) acc))
 		(split (cons (substring haystack offset i) acc)
 		       (+ i 1) (- n 1))))))
     (split '() 0 n)))
 
 (define (string-indexp haystack offset predicate)
   (cond
    ((= (string-length haystack) offset)
     #f)
    ((predicate (string-ref haystack offset))
     offset)
    (else
     (string-indexp haystack (+ 1 offset) predicate))))
 
 ;; Split HAYSTACK at each character that makes PREDICATE true at most
 ;; N times.
 (define (string-splitp haystack predicate n)
   (string-split-pln haystack predicate
 		    (lambda (haystack offset)
 		      (string-indexp haystack offset predicate))
 		    n))
 (assert (equal? '("a" "b") (string-splitp "a b" char-whitespace? -1)))
 (assert (equal? '("a" "b") (string-splitp "a\tb" char-whitespace? -1)))
 (assert (equal? '("a" "" "b") (string-splitp "a \tb" char-whitespace? -1)))
 
 ;; Split haystack at delimiter at most n times.
 (define (string-splitn haystack delimiter n)
   (string-split-pln haystack
 		    (lambda (c) (char=? c delimiter))
 		    (lambda (haystack offset)
 		      (string-index haystack delimiter offset))
 		    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" #\:))))
 
 ;; Split haystack at newlines.
 (define (string-split-newlines haystack)
   (if *win32*
       (map (lambda (line) (if (string-suffix? line "\r")
 			      (substring line 0 (- (string-length line) 1))
 			      line))
 	   (string-split haystack #\newline))
       (string-split haystack #\newline)))
 
 ;; Trim the prefix of S containing only characters that make PREDICATE
 ;; true.
 (define (string-ltrim predicate s)
   (if (string=? s "")
       ""
       (let loop ((s' (string->list s)))
 	(if (predicate (car s'))
 	    (loop (cdr s'))
 	    (list->string s')))))
 (assert (string=? "" (string-ltrim char-whitespace? "")))
 (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)
   (if (string=? s "")
       ""
       (let loop ((s' (reverse! (string->list s))))
 	(if (predicate (car s'))
 	    (loop (cdr s'))
 	    (list->string (reverse! s'))))))
 (assert (string=? "" (string-rtrim char-whitespace? "")))
 (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=? "" (string-trim char-whitespace? "")))
 (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")))
 
+;; Translate characters.
+(define (string-translate s from to)
+  (list->string (map (lambda (c)
+		       (let ((i (string-index from c)))
+			 (if i (string-ref to i) c))) (string->list s))))
+(assert (equal? (string-translate "foo/bar" "/" ".") "foo.bar"))
+
 ;; 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)
 	 '()))))))
 
 (define (list->string-reversed lst)
   (let* ((len (length lst))
 	 (str (make-string len)))
     (let loop ((i (- len 1))
 	       (l lst))
       (if (< i 0)
 	  (begin
 	    (assert (null? l))
 	    str)
 	  (begin
 	    (string-set! str i (car l))
 	    (loop (- i 1) (cdr l)))))))
 
 ;; Read a line from port P.
 (define (read-line . p)
   (let loop ((acc '()))
     (let ((c (apply peek-char p)))
       (cond
        ((eof-object? c)
 	(if (null? acc)
 	    c ;; #eof
 	    (list->string-reversed acc)))
        ((char=? c #\newline)
 	(apply read-char p)
 	(list->string-reversed acc))
        (else
 	(apply read-char p)
 	(loop (cons c acc)))))))
 
 ;; 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))))))
 
 ;;
 ;; Windows support.
 ;;
 
 ;; Like call-with-input-file but opens the file in 'binary' mode.
 (define (call-with-binary-input-file filename proc)
   (letfd ((fd (open filename (logior O_RDONLY O_BINARY))))
 	 (proc (fdopen fd "rb"))))
 
 ;; Like call-with-output-file but opens the file in 'binary' mode.
 (define (call-with-binary-output-file filename proc)
   (letfd ((fd (open filename (logior O_WRONLY O_CREAT O_BINARY) #o600)))
 	 (proc (fdopen fd "wb"))))
 
 ;;
 ;; Libc functions.
 ;;
 
 ;; Change the read/write offset.
 (ffi-define (seek fd offset whence))
 
 ;; Constants for WHENCE.
 (ffi-define SEEK_SET)
 (ffi-define SEEK_CUR)
 (ffi-define SEEK_END)
 
 ;; Get our process id.
 (ffi-define (getpid))
 
 ;; Copy data from file descriptor SOURCE to every file descriptor in
 ;; SINKS.
 (ffi-define (splice source . sinks))
 
 ;;
 ;; Random numbers.
 ;;
 
 ;; Seed the random number generator.
 (ffi-define (srandom seed))
 
 ;; Get a pseudo-random number between 0 (inclusive) and SCALE
 ;; (exclusive).
 (ffi-define (random scale))
 
 ;; Create a string of the given SIZE containing pseudo-random data.
 (ffi-define (make-random-string size))
diff --git a/main.c b/main.c
index 5e04d97..e4b535e 100644
--- a/main.c
+++ b/main.c
@@ -1,344 +1,346 @@
 /* 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 <https://www.gnu.org/licenses/>.
  */
 
 #include <config.h>
 
 #include <assert.h>
 #include <ctype.h>
 #include <errno.h>
 #include <fcntl.h>
 #include <gcrypt.h>
 #include <gpg-error.h>
 #include <stdio.h>
 #include <stdlib.h>
 #include <string.h>
 #include <sys/types.h>
 #include <sys/stat.h>
 #include <unistd.h>
 
 #if HAVE_MMAP
 #include <sys/mman.h>
 #endif
 
 #include "private.h"
 #include "scheme.h"
 #include "scheme-private.h"
 #include "ffi.h"
 #include "../common/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 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)
           {
             err = 0;
             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");
       goto leave;
     }
   if (verbose > 1)
     fprintf (stderr, "Loading %s...\n", qualified_name);
 
 #if HAVE_MMAP
   /* Always try to mmap the file.  This allows the pages to be shared
    * between processes.  If anything fails, we fall back to using
    * buffered streams.  */
   if (1)
     {
       struct stat st;
       void *map;
       size_t len;
       int fd = fileno (h);
 
       if (fd < 0)
         goto fallback;
 
       if (fstat (fd, &st))
         goto fallback;
 
       len = (size_t) st.st_size;
       if ((off_t) len != st.st_size)
         goto fallback;	/* Truncated.  */
 
       map = mmap (NULL, len, PROT_READ, MAP_SHARED, fd, 0);
       if (map == MAP_FAILED)
         goto fallback;
 
       scheme_load_memory (sc, map, len, qualified_name);
       munmap (map, len);
     }
   else
   fallback:
 #endif
     scheme_load_named_file (sc, h, qualified_name);
   fclose (h);
 
   if (sc->retcode && sc->nesting)
     {
       fprintf (stderr, "%s: Unbalanced parenthesis\n", qualified_name);
       err = gpg_error (GPG_ERR_GENERAL);
     }
 
  leave:
   if (file_name != qualified_name)
     free (qualified_name);
   return err;
 }
 
 
 
 int
 main (int argc, char **argv)
 {
   int retcode;
   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", GPGRT_LOG_WITH_PREFIX);
 
   /* Make sure that our subsystems are ready.  */
   i18n_init ();
   init_common_subsystems (&argc, &argv);
 
   if (!gcry_check_version (NEED_LIBGCRYPT_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, script ? script : "interactive",
                     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, "xml.scm", 0, 1);
   if (! err)
     err = load (sc, "tests.scm", 0, 1);
   if (! err)
     err = load (sc, "gnupg.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));
     }
 
   retcode = sc->retcode;
   scheme_load_string (sc, "(*run-atexit-handlers*)");
   scheme_deinit (sc);
   xfree (sc);
   return retcode;
 }
diff --git a/tests.scm b/tests.scm
index b2dcc54..3118977 100644
--- a/tests.scm
+++ b/tests.scm
@@ -1,672 +1,762 @@
 ;; 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/>.
 
 ;; Reporting.
 (define (echo . msg)
   (for-each (lambda (x) (display x) (display " ")) msg)
   (newline))
 
 (define (info . msg)
   (apply echo msg)
   (flush-stdio))
 
 (define (log . msg)
   (if (> (*verbose*) 0)
       (apply info msg)))
 
 (define (fail . msg)
   (apply info msg)
   (exit 1))
 
 (define (skip . msg)
   (apply info msg)
   (exit 77))
 
 (define (make-counter)
   (let ((c 0))
     (lambda ()
       (let ((r c))
 	(set! c (+ 1 c))
 	r))))
 
 (define *progress-nesting* 0)
 
 (define (call-with-progress msg what)
   (set! *progress-nesting* (+ 1 *progress-nesting*))
   (if (= 1 *progress-nesting*)
       (begin
 	(info msg)
 	(display "    > ")
 	(flush-stdio)
 	(what (lambda (item)
 	      (display item)
 	      (display " ")
 	      (flush-stdio)))
 	(info "< "))
       (begin
 	(what (lambda (item) (display ".") (flush-stdio)))
 	(display " ")
 	(flush-stdio)))
   (set! *progress-nesting* (- *progress-nesting* 1)))
 
 (define (for-each-p msg proc lst . lsts)
   (apply for-each-p' `(,msg ,proc ,(lambda (x . xs) x) ,lst ,@lsts)))
 
 (define (for-each-p' msg proc fmt lst . lsts)
   (call-with-progress
    msg
    (lambda (progress)
      (apply for-each
 	    `(,(lambda args
 		 (progress (apply fmt args))
 		 (apply proc args))
 	      ,lst ,@lsts)))))
 
 ;; Process management.
 (define CLOSED_FD -1)
 (define (call-with-fds what infd outfd errfd)
   (wait-process (stringify what) (spawn-process-fd what infd outfd errfd) #t))
 (define (call what)
   (call-with-fds what
 		 CLOSED_FD
 		 (if (< (*verbose*) 0) STDOUT_FILENO CLOSED_FD)
 		 (if (< (*verbose*) 0) STDERR_FILENO CLOSED_FD)))
 
 ;; Accessor functions for the results of 'spawn-process'.
 (define :stdin car)
 (define :stdout cadr)
 (define :stderr caddr)
 (define :pid cadddr)
 
 (define (call-with-io what in)
   (let ((h (spawn-process what 0)))
     (es-write (:stdin h) in)
     (es-fclose (:stdin h))
     (let* ((out (es-read-all (:stdout h)))
 	   (err (es-read-all (:stderr h)))
 	   (result (wait-process (car what) (:pid h) #t)))
       (es-fclose (:stdout h))
       (es-fclose (:stderr h))
       (if (> (*verbose*) 2)
 	  (info "Child" (:pid h) "returned:"
 		`((command ,(stringify what))
 		  (status ,result)
 		  (stdout ,out)
 		  (stderr ,err))))
       (list result out err))))
 
 ;; Accessor function for the results of 'call-with-io'.  ':stdout' and
 ;; ':stderr' can also be used.
 (define :retcode car)
 
 (define (call-check what)
   (let ((result (call-with-io what "")))
     (if (= 0 (:retcode result))
 	(:stdout result)
 	(throw (string-append (stringify what) " failed")
 	       (:stderr result)))))
 
 (define (call-popen command input-string)
   (let ((result (call-with-io command input-string)))
     (if (= 0 (:retcode result))
 	(:stdout result)
 	(throw (:stderr result)))))
 
 ;;
 ;; estream helpers.
 ;;
 
 (define (es-read-all stream)
   (let loop
       ((acc ""))
     (if (es-feof stream)
 	acc
 	(loop (string-append acc (es-read stream 4096))))))
 
 ;;
 ;; File management.
 ;;
 (define (file-exists? name)
   (call-with-input-file name (lambda (port) #t)))
 
 (define (file=? a b)
   (file-equal a b #t))
 
 (define (text-file=? a b)
   (file-equal a b #f))
 
 (define (file-copy from to)
   (catch '() (unlink to))
   (letfd ((source (open from (logior O_RDONLY O_BINARY)))
 	  (sink (open to (logior O_WRONLY O_CREAT O_BINARY) #o600)))
     (splice source sink)))
 
 (define (text-file-copy from to)
   (catch '() (unlink to))
   (letfd ((source (open from O_RDONLY))
 	  (sink (open to (logior O_WRONLY O_CREAT) #o600)))
     (splice source sink)))
 
 (define (path-join . components)
   (let loop ((acc #f) (rest (filter (lambda (s)
 				      (not (string=? "" s))) components)))
     (if (null? rest)
 	acc
 	(loop (if (string? acc)
 		  (string-append acc "/" (car rest))
 		  (car rest))
 	      (cdr rest)))))
 (assert (string=? (path-join "foo" "bar" "baz") "foo/bar/baz"))
 (assert (string=? (path-join "" "bar" "baz") "bar/baz"))
 
 ;; Is PATH an absolute path?
 (define (absolute-path? path)
   (or (char=? #\/ (string-ref path 0))
       (and *win32* (char=? #\\ (string-ref path 0)))
       (and *win32*
 	   (char-alphabetic? (string-ref path 0))
 	   (char=? #\: (string-ref path 1))
 	   (or (char=? #\/ (string-ref path 2))
 	       (char=? #\\ (string-ref path 2))))))
 
 ;; Make PATH absolute.
 (define (canonical-path path)
   (if (absolute-path? path) path (path-join (getcwd) path)))
 
 (define (in-srcdir . names)
   (canonical-path (apply path-join (cons (getenv "abs_top_srcdir") names))))
 
 ;; Try to find NAME in PATHS.  Returns the full path name on success,
 ;; or raises an error.
 (define (path-expand name paths)
   (let loop ((path paths))
     (if (null? path)
 	(throw "Could not find" name "in" paths)
 	(let* ((qualified-name (path-join (car path) name))
 	       (file-exists (call-with-input-file qualified-name
 			      (lambda (x) #t))))
 	  (if file-exists
 	      qualified-name
 	      (loop (cdr path)))))))
 
 ;; Expand NAME using the gpgscm load path.  Use like this:
 ;;   (load (with-path "library.scm"))
 (define (with-path name)
   (catch name
 	 (path-expand name (string-split (getenv "GPGSCM_PATH") *pathsep*))))
 
 (define (basename path)
   (let ((i (string-index path #\/)))
     (if (equal? i #f)
 	path
 	(basename (substring path (+ 1 i) (string-length path))))))
 
 (define (basename-suffix path suffix)
   (basename
    (if (string-suffix? path suffix)
        (substring path 0 (- (string-length path) (string-length suffix)))
        path)))
 
+(define (dirname path)
+  (let ((i (string-rindex path #\/)))
+    (if i (substring path 0 i) ".")))
+
 ;; 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>.
 (define-macro (letfd bindings . body)
   (let bind ((bindings' bindings))
     (if (null? bindings')
 	`(begin ,@body)
 	(let* ((binding (car bindings'))
 	       (name (car binding))
 	       (initializer (cadr binding)))
 	  `(let ((,name ,initializer))
 	     (finally (close ,name)
 		      ,(bind (cdr bindings'))))))))
 
 (define-macro (with-working-directory new-directory . expressions)
   (let ((new-dir (gensym))
 	(old-dir (gensym)))
     `(let* ((,new-dir ,new-directory)
 	    (,old-dir (getcwd)))
        (dynamic-wind
 	   (lambda () (if ,new-dir (chdir ,new-dir)))
 	   (lambda () ,@expressions)
 	   (lambda () (chdir ,old-dir))))))
 
 ;; Make a temporary directory.  If arguments are given, they are
 ;; joined using path-join, and must end in a component ending in
 ;; "XXXXXX".  If no arguments are given, a suitable location and
 ;; generic name is used.  Returns an absolute path.
 (define (mkdtemp . components)
   (canonical-path (_mkdtemp (if (null? components)
 				(path-join
 				 (get-temp-path)
 				 (string-append "gpgscm-" (get-isotime) "-"
 						(basename-suffix *scriptname* ".scm")
 						"-XXXXXX"))
 				(apply path-join components)))))
 
 ;; Make a temporary directory and remove it at interpreter shutdown.
 ;; Note that there are macros that limit the lifetime of temporary
 ;; directories and files to a lexical scope.  Use those if possible.
 ;; Otherwise this works like mkdtemp.
 (define (mkdtemp-autoremove . components)
   (let ((dir (apply mkdtemp components)))
     (atexit (lambda () (unlink-recursively dir)))
     dir))
 
 (define-macro (with-temporary-working-directory . expressions)
   (let ((tmp-sym (gensym)))
     `(let* ((,tmp-sym (mkdtemp)))
        (finally (unlink-recursively ,tmp-sym)
 		(with-working-directory ,tmp-sym
 					,@expressions)))))
 
 (define (make-temporary-file . args)
   (canonical-path (path-join
 		   (mkdtemp)
 		   (if (null? args) "a" (car args)))))
 
 (define (remove-temporary-file filename)
   (catch '()
     (unlink filename))
   (let ((dirname (substring filename 0 (string-rindex filename #\/))))
     (catch (echo "removing temporary directory" dirname "failed")
       (rmdir dirname))))
 
 ;; let-like macro that manages temporary files.
 ;;
 ;; (lettmp <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>.
 (define-macro (lettmp bindings . body)
   (let bind ((bindings' bindings))
     (if (null? bindings')
 	`(begin ,@body)
 	(let ((name (car bindings'))
 	      (rest (cdr bindings')))
 	  `(let ((,name (make-temporary-file ,(symbol->string name))))
 	     (finally (remove-temporary-file ,name)
 		      ,(bind rest)))))))
 
 (define (check-execution source transformer)
   (lettmp (sink)
 	  (transformer source sink)))
 
 (define (check-identity source transformer)
   (lettmp (sink)
 	  (transformer source sink)
 	  (if (not (file=? source sink))
 	      (fail "mismatch"))))
 
 ;;
 ;; Monadic pipe support.
 ;;
 
 (define pipeM
   (package
    (define (new procs source sink producer)
      (package
       (define (dump)
 	(write (list procs source sink producer))
 	(newline))
       (define (add-proc command pid)
 	(new (cons (list command pid) procs) source sink producer))
       (define (commands)
 	(map car procs))
       (define (pids)
 	(map cadr procs))
       (define (set-source source')
 	(new procs source' sink producer))
       (define (set-sink sink')
 	(new procs source sink' producer))
       (define (set-producer producer')
 	(if producer
 	    (throw "producer already set"))
 	(new procs source sink producer'))))))
 
 
 (define (pipe:do . commands)
   (let loop ((M (pipeM::new '() CLOSED_FD CLOSED_FD #f)) (cmds commands))
     (if (null? cmds)
 	(begin
 	  (if M::producer (M::producer))
 	  (if (not (null? M::procs))
 	      (let* ((retcodes (wait-processes (map stringify (M::commands))
 					       (M::pids) #t))
 		     (results (map (lambda (p r) (append p (list r)))
 				   M::procs retcodes))
 		     (failed (filter (lambda (x) (not (= 0 (caddr x))))
 				     results)))
 		(if (not (null? failed))
 		    (throw failed))))) ; xxx nicer reporting
 	(if (and (= 2 (length cmds)) (number? (cadr cmds)))
 	    ;; hack: if it's an fd, use it as sink
 	    (let ((M' ((car cmds) (M::set-sink (cadr cmds)))))
 	      (if (> M::source 2) (close M::source))
 	      (if (> (cadr cmds) 2) (close (cadr cmds)))
 	      (loop M' '()))
 	    (let ((M' ((car cmds) M)))
 	      (if (> M::source 2) (close M::source))
 	      (loop M' (cdr cmds)))))))
 
 (define (pipe:open pathname flags)
   (lambda (M)
     (M::set-source (open pathname flags))))
 
 (define (pipe:defer producer)
   (lambda (M)
     (let* ((p (outbound-pipe))
 	   (M' (M::set-source (:read-end p))))
       (M'::set-producer (lambda ()
 			  (producer (:write-end p))
 			  (close (:write-end p)))))))
 (define (pipe:echo data)
  (pipe:defer (lambda (sink) (display data (fdopen sink "wb")))))
 
 (define (pipe:spawn command)
   (lambda (M)
     (define (do-spawn M new-source)
       (let ((pid (spawn-process-fd command M::source M::sink
 				   (if (> (*verbose*) 0)
 				       STDERR_FILENO CLOSED_FD)))
 	    (M' (M::set-source new-source)))
 	(M'::add-proc command pid)))
     (if (= CLOSED_FD M::sink)
 	(let* ((p (pipe))
 	       (M' (do-spawn (M::set-sink (:write-end p)) (:read-end p))))
 	  (close (:write-end p))
 	  (M'::set-sink CLOSED_FD))
 	(do-spawn M CLOSED_FD))))
 
 (define (pipe:splice sink)
   (lambda (M)
     (splice M::source sink)
     (M::set-source CLOSED_FD)))
 
 (define (pipe:write-to pathname flags mode)
   (open pathname flags mode))
 
 ;;
 ;; Monadic transformer support.
 ;;
 
 (define (tr:do . commands)
   (let loop ((tmpfiles '()) (source  #f) (cmds commands))
     (if (null? cmds)
 	(for-each remove-temporary-file tmpfiles)
 	(let* ((v ((car cmds) tmpfiles source))
 	       (tmpfiles' (car v))
 	       (sink (cadr v))
 	       (error (caddr v)))
 	  (if error
 	      (begin
 		(for-each remove-temporary-file tmpfiles')
 		(apply throw error)))
 	  (loop tmpfiles' sink (cdr cmds))))))
 
 (define (tr:open pathname)
   (lambda (tmpfiles source)
     (list tmpfiles pathname #f)))
 
 (define (tr:spawn input command)
   (lambda (tmpfiles source)
     (if (and (member '**in** command) (not source))
 	(fail (string-append (stringify cmd) " needs an input")))
     (let* ((t (make-temporary-file))
 	   (cmd (map (lambda (x)
 		       (cond
 			((equal? '**in** x) source)
 			((equal? '**out** x) t)
 			(else x))) command)))
       (catch (list (cons t tmpfiles) t *error*)
 	     (call-popen cmd input)
 	     (if (and (member '**out** command) (not (file-exists? t)))
 		 (fail (string-append (stringify cmd)
 				       " did not produce '" t "'.")))
 	     (list (cons t tmpfiles) t #f)))))
 
 (define (tr:write-to pathname)
   (lambda (tmpfiles source)
     (rename source pathname)
     (list tmpfiles pathname #f)))
 
 (define (tr:pipe-do . commands)
   (lambda (tmpfiles source)
     (let ((t (make-temporary-file)))
       (apply pipe:do
         `(,@(if source `(,(pipe:open source (logior O_RDONLY O_BINARY))) '())
 	  ,@commands
 	  ,(pipe:write-to t (logior O_WRONLY O_BINARY O_CREAT) #o600)))
       (list (cons t tmpfiles) t #f))))
 
 (define (tr:assert-identity reference)
   (lambda (tmpfiles source)
     (if (not (file=? source reference))
 	(fail "mismatch"))
     (list tmpfiles source #f)))
 
 (define (tr:assert-weak-identity reference)
   (lambda (tmpfiles source)
     (if (not (text-file=? source reference))
 	(fail "mismatch"))
     (list tmpfiles source #f)))
 
 (define (tr:call-with-content function . args)
   (lambda (tmpfiles source)
     (catch (list tmpfiles source *error*)
 	   (apply function `(,(call-with-input-file source read-all) ,@args)))
     (list tmpfiles source #f)))
 
 ;;
 ;; Developing and debugging tests.
 ;;
 
 ;; Spawn an os shell.
 (define (interactive-shell)
   (call-with-fds `(,(getenv "SHELL") -i) 0 1 2))
 
 ;;
 ;; The main test framework.
 ;;
 
 ;; A pool of tests.
 (define test-pool
   (package
    (define (new procs)
      (package
       (define (add test)
 	(set! procs (cons test procs))
 	(current-environment))
       (define (pid->test pid)
 	(let ((t (filter (lambda (x) (= pid x::pid)) procs)))
 	  (if (null? t) #f (car t))))
       (define (wait)
 	(let ((unfinished (filter (lambda (t) (not t::retcode)) procs)))
 	  (if (null? unfinished)
 	      (current-environment)
 	      (let ((names (map (lambda (t) t::name) unfinished))
 		    (pids (map (lambda (t) t::pid) unfinished)))
 		(for-each
-		 (lambda (test retcode) (test:::set! 'retcode retcode))
+		 (lambda (test retcode)
+		   (test::set-end-time!)
+		   (test:::set! 'retcode retcode))
 		 (map pid->test pids)
 		 (wait-processes (map stringify names) pids #t)))))
 	(current-environment))
       (define (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)
 	(define (print-tests tests message)
 	  (unless (null? tests)
 		  (apply echo (cons message
 				    (map (lambda (t) t::name) tests)))))
 
 	(let ((failed' (failed)) (skipped' (skipped)))
 	  (echo (length procs) "tests run,"
 		(length (passed)) "succeeded,"
 		(length failed') "failed,"
 		(length skipped') "skipped.")
 	  (print-tests failed' "Failed tests:")
 	  (print-tests skipped' "Skipped tests:")
-	  (length failed')))))))
+	  (length failed')))
+
+      (define (xml)
+	(xx::document
+	 (xx::tag 'testsuites
+		  `((xmlns:xsi "http://www.w3.org/2001/XMLSchema-instance")
+		    ("xsi:noNamespaceSchemaLocation"
+		     "https://windyroad.com.au/dl/Open%20Source/JUnit.xsd"))
+		  (map (lambda (t) (t::xml)) procs))))))))
 
 (define (verbosity n)
   (if (= 0 n) '() (cons '--verbose (verbosity (- n 1)))))
 
 (define (locate-test path)
   (if (absolute-path? path) path (in-srcdir path)))
 
 ;; A single test.
 (define test
+ (begin
+
+  ;; Private definitions.
+
+  (define (isotime->junit t)
+    "[0-9]{4}-[0-9]{2}-[0-9]{2}T[0-9]{2}:[0-9]{2}:[0-9]{2}"
+    "20170418T145809"
+    (string-append (substring t 0 4)
+		   "-"
+		   (substring t 4 6)
+		   "-"
+		   (substring t 6 11)
+		   ":"
+		   (substring t 11 13)
+		   ":"
+		   (substring t 13 15)))
+
   (package
    (define (scm setup name path . args)
      ;; Start the process.
      (define (spawn-scm args' in out err)
        (spawn-process-fd `(,*argv0* ,@(verbosity (*verbose*))
 				    ,(locate-test path)
 				    ,@(if setup (force setup) '())
 				    ,@args' ,@args) in out err))
      (new name #f spawn-scm #f #f CLOSED_FD))
 
    (define (binary setup name path . args)
      ;; Start the process.
      (define (spawn-binary args' in out err)
        (spawn-process-fd `(,path ,@(if setup (force setup) '()) ,@args' ,@args)
 			 in out err))
      (new name #f spawn-binary #f #f CLOSED_FD))
 
    (define (new name directory spawn pid retcode logfd)
      (package
+
+      ;; XXX: OO glue.
+      (define self (current-environment))
       (define (:set! key value)
 	(eval `(set! ,key ,value) (current-environment))
 	(current-environment))
+
+      ;; The log is written here.
+      (define log-file-name "not set")
+
+      ;; Record time stamps.
+      (define timestamp #f)
+      (define start-time 0)
+      (define end-time 0)
+
+      (define (set-start-time!)
+	(set! timestamp (isotime->junit (get-isotime)))
+	(set! start-time (get-time)))
+      (define (set-end-time!)
+	(set! end-time (get-time)))
+
       (define (open-log-file)
-	(let ((filename (string-append (basename name) ".log")))
-	  (catch '() (unlink filename))
-	  (open filename (logior O_RDWR O_BINARY O_CREAT) #o600)))
+	(set! log-file-name (string-append (basename name) ".log"))
+	(catch '() (unlink log-file-name))
+	(open log-file-name (logior O_RDWR O_BINARY O_CREAT) #o600))
+
       (define (run-sync . args)
+	(set-start-time!)
 	(letfd ((log (open-log-file)))
 	  (with-working-directory directory
 	    (let* ((p (inbound-pipe))
 		   (pid' (spawn args 0 (:write-end p) (:write-end p))))
 	      (close (:write-end p))
 	      (splice (:read-end p) STDERR_FILENO log)
 	      (close (:read-end p))
 	      (set! pid pid')
 	      (set! retcode (wait-process name pid' #t)))))
 	(report)
 	(current-environment))
       (define (run-sync-quiet . args)
+	(set-start-time!)
 	(with-working-directory directory
-	  (set! pid (spawn args CLOSED_FD CLOSED_FD CLOSED_FD))
-	  (set! retcode (wait-process name pid #t)))
+	  (set! pid (spawn args CLOSED_FD CLOSED_FD CLOSED_FD)))
+	(set! retcode (wait-process name pid #t))
+	(set-end-time!)
 	(current-environment))
       (define (run-async . args)
+	(set-start-time!)
 	(let ((log (open-log-file)))
 	  (with-working-directory directory
 	    (set! pid (spawn args CLOSED_FD log log)))
 	  (set! logfd log))
 	(current-environment))
       (define (status)
-	(let ((t (assoc retcode '((0 "PASS") (77 "SKIP") (99 "ERROR")))))
-	  (if (not t) "FAIL" (cadr t))))
+	(let ((t (assoc retcode '((0 PASS) (77 SKIP) (99 ERROR)))))
+	  (if (not t) 'FAIL (cadr t))))
+      (define (status-string)
+	(cadr (assoc (status) '((PASS "PASS")
+			       (SKIP "SKIP")
+			       (ERROR "ERROR")
+			       (FAIL "FAIL")))))
       (define (report)
 	(unless (= logfd CLOSED_FD)
 		(seek logfd 0 SEEK_SET)
 		(splice logfd STDERR_FILENO)
 		(close logfd))
-	(echo (string-append (status) ":") name))))))
+	(echo (string-append (status-string) ":") name))
+
+      (define (xml)
+	(xx::tag
+	 'testsuite
+	 `((name ,name)
+	   (time ,(- end-time start-time))
+	   (package ,(dirname name))
+	   (id 0)
+	   (timestamp ,timestamp)
+	   (hostname "unknown")
+	   (tests 1)
+	   (failures ,(if (eq? FAIL (status)) 1 0))
+	   (errors ,(if (eq? ERROR (status)) 1 0)))
+	 (list
+	  (xx::tag 'properties)
+	  (xx::tag 'testcase
+		   `((name ,(basename name))
+		     (classname ,(string-translate (dirname name) "/" "."))
+		     (time ,(- end-time start-time)))
+		   `(,@(case (status)
+			 ((PASS) '())
+			 ((SKIP) (list (xx::tag 'skipped)))
+			 ((ERROR) (list
+				   (xx::tag 'error '((message "Unknown error.")))))
+			 (else
+			  (list (xx::tag 'failure '((message "Unknown error."))))))))
+	  (xx::tag 'system-out '()
+		   (list (xx::textnode (read-all (open-input-file log-file-name)))))
+	  (xx::tag 'system-err '() (list (xx::textnode "")))))))))))
 
 ;; Run the setup target to create an environment, then run all given
 ;; tests in parallel.
 (define (run-tests-parallel tests)
   (let loop ((pool (test-pool::new '())) (tests' tests))
     (if (null? tests')
 	(let ((results (pool::wait)))
 	  (for-each (lambda (t) (t::report)) (reverse results::procs))
+	  ((results::xml) (open-output-file "report.xml"))
 	  (exit (results::report)))
 	(let ((wd (mkdtemp-autoremove))
 	      (test (car tests')))
 	  (test:::set! 'directory wd)
 	  (loop (pool::add (test::run-async))
 		(cdr tests'))))))
 
 ;; Run the setup target to create an environment, then run all given
 ;; tests in sequence.
 (define (run-tests-sequential tests)
   (let loop ((pool (test-pool::new '())) (tests' tests))
     (if (null? tests')
 	(let ((results (pool::wait)))
+	  ((results::xml) (open-output-file "report.xml"))
 	  (exit (results::report)))
 	(let ((wd (mkdtemp-autoremove))
 	      (test (car tests')))
 	  (test:::set! 'directory wd)
 	  (loop (pool::add (test::run-sync))
 		(cdr tests'))))))
 
 ;; Helper to create environment caches from test functions.  SETUP
 ;; must be a test implementing the producer side cache protocol.
 ;; Returns a promise containing the arguments that must be passed to a
 ;; test implementing the consumer side of the cache protocol.
 (define (make-environment-cache setup)
   (delay (with-temporary-working-directory
 	  (let ((tarball (make-temporary-file "environment-cache")))
 	    (atexit (lambda () (remove-temporary-file tarball)))
 	    (setup::run-sync '--create-tarball tarball)
 	    `(--unpack-tarball ,tarball)))))
 
 ;; Command line flag handling.  Returns the elements following KEY in
 ;; ARGUMENTS up to the next argument, or #f if KEY is not in
 ;; ARGUMENTS.
 (define (flag key arguments)
   (cond
    ((null? arguments)
     #f)
    ((string=? key (car arguments))
     (let loop ((acc '())
 	       (args (cdr arguments)))
       (if (or (null? args) (string-prefix? (car args) "--"))
 	  (reverse acc)
 	  (loop (cons (car args) acc) (cdr args)))))
    ((string=? "--" (car arguments))
     #f)
    (else
     (flag key (cdr arguments)))))
 (assert (equal? (flag "--xxx" '("--yyy")) #f))
 (assert (equal? (flag "--xxx" '("--xxx")) '()))
 (assert (equal? (flag "--xxx" '("--xxx" "yyy")) '("yyy")))
 (assert (equal? (flag "--xxx" '("--xxx" "yyy" "zzz")) '("yyy" "zzz")))
 (assert (equal? (flag "--xxx" '("--xxx" "yyy" "zzz" "--")) '("yyy" "zzz")))
 (assert (equal? (flag "--xxx" '("--xxx" "yyy" "--" "zzz")) '("yyy")))
 (assert (equal? (flag "--" '("--" "xxx" "yyy" "--" "zzz")) '("xxx" "yyy")))
diff --git a/xml.scm b/xml.scm
new file mode 100644
index 0000000..771ec36
--- /dev/null
+++ b/xml.scm
@@ -0,0 +1,142 @@
+;; A tiny XML library.
+;;
+;; Copyright (C) 2017 g10 Code GmbH
+;;
+;; This file is part of GnuPG.
+;;
+;; GnuPG is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; GnuPG is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, see <http://www.gnu.org/licenses/>.
+
+(define xx
+  (begin
+
+    ;; Private declarations.
+    (define quote-text
+      '((#\< "&lt;")
+	(#\> "&gt;")
+	(#\& "&amp;")))
+
+    (define quote-attribute-'
+      '((#\< "&lt;")
+	(#\> "&gt;")
+	(#\& "&amp;")
+	(#\' "&apos;")))
+
+    (define quote-attribute-''
+      '((#\< "&lt;")
+	(#\> "&gt;")
+	(#\& "&amp;")
+	(#\" "&quot;")))
+
+    (define (escape-string quotation string sink)
+      ;; This implementation is a bit awkward because iteration is so
+      ;; slow in TinySCHEME.  We rely on string-index to skip to the
+      ;; next character we need to escape.  We also avoid allocations
+      ;; wherever possible.
+
+      ;; Given a list of integers or #f, return the sublist that
+      ;; starts with the lowest integer.
+      (define (min* x)
+	(let loop ((lowest x) (rest x))
+	  (if (null? rest)
+	      lowest
+	      (loop (if (or (null? lowest) (not (car lowest))
+			    (and (car rest) (> (car lowest) (car rest)))) rest lowest)
+		    (cdr rest)))))
+
+      (let ((i 0) (start 0) (len (string-length string))
+	    (indices (map (lambda (x) (string-index string (car x))) quotation))
+	    (next #f) (c #f))
+
+	;; Set 'i' to the index of the next character that needs
+	;; escaping, 'c' to the character that needs to be escaped,
+	;; and update 'indices'.
+	(define (skip!)
+	  (set! next (min* indices))
+	  (set! i (if (null? next) #f (car next)))
+	  (if i
+	      (begin
+		(set! c (string-ref string i))
+		(set-car! next (string-index string c (+ 1 i))))
+	      (set! i (string-length string))))
+
+	(let loop ()
+	  (skip!)
+	  (if (< i len)
+	      (begin
+		(display (substring string start i) sink)
+		(display (cadr (assv c quotation)) sink)
+		(set! i (+ 1 i))
+		(set! start i)
+		(loop))
+	      (display (substring string start len) sink)))))
+
+    (let ((escape-string-s (lambda (quotation string)
+			     (let ((sink (open-output-string)))
+			       (escape-string quotation string sink)
+			       (get-output-string sink)))))
+      (assert (equal? (escape-string-s quote-text "foo") "foo"))
+      (assert (equal? (escape-string-s quote-text "foo&") "foo&amp;"))
+      (assert (equal? (escape-string-s quote-text "&foo") "&amp;foo"))
+      (assert (equal? (escape-string-s quote-text "foo&bar") "foo&amp;bar"))
+      (assert (equal? (escape-string-s quote-text "foo<bar") "foo&lt;bar"))
+      (assert (equal? (escape-string-s quote-text "foo>bar") "foo&gt;bar")))
+
+    (define (escape quotation datum sink)
+      (cond
+       ((string? datum) (escape-string quotation datum sink))
+       ((symbol? datum) (escape-string quotation (symbol->string datum) sink))
+       ((number? datum) (display (number->string datum) sink))
+       (else
+	(throw "Do not know how to encode" datum))))
+
+    (define (name->string name)
+      (cond
+       ((symbol? name) (symbol->string name))
+       (else name)))
+
+    (package
+
+     (define (textnode string)
+       (lambda (sink)
+	 (escape quote-text string sink)))
+
+     (define (tag name . rest)
+       (let ((attributes (if (null? rest) '() (car rest)))
+	     (children (if (> (length rest) 1) (cadr rest) '())))
+	 (lambda (sink)
+	   (display "<" sink)
+	   (display (name->string name) sink)
+	   (unless (null? attributes)
+		   (display " " sink)
+		   (for-each (lambda (a)
+			       (display (car a) sink)
+			       (display "=\"" sink)
+			       (escape quote-attribute-'' (cadr a) sink)
+			       (display "\" " sink)) attributes))
+	   (if (null? children)
+	       (display "/>\n" sink)
+	       (begin
+		 (display ">\n" sink)
+		 (for-each (lambda (c) (c sink)) children)
+		 (display "</" sink)
+		 (display (name->string name) sink)
+		 (display ">\n" sink))))))
+
+     (define (document root . rest)
+       (let ((attributes (if (null? rest) '() (car rest))))
+	 (lambda (sink)
+	   ;; xxx ignores attributes
+	   (display "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" sink)
+	   (root sink)
+	   (newline sink)))))))