tests/gpgme/gpgme-defs.scm

   1 #!/usr/bin/env gpgscm
   2
   3 ;; Copyright (C) 2016 g10 Code GmbH
   4 ;;
   5 ;; This file is part of GnuPG.
   6 ;;
   7 ;; GnuPG is free software; you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published by
   9 ;; the Free Software Foundation; either version 3 of the License, or
  10 ;; (at your option) any later version.
  11 ;;
  12 ;; GnuPG is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;; GNU General Public License for more details.
  16 ;;
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with this program; if not, see <http://www.gnu.org/licenses/>.
  19
  20 (load (with-path "defs.scm"))
  21
  22 (define gpgme-srcdir (getenv "XTEST_GPGME_SRCDIR"))
  23 (when (string=? "" gpgme-srcdir)
  24     (info
  25      "SKIP: Environment variable 'XTEST_GPGME_SRCDIR' not set.  Please"
  26      "point it to a recent GPGME source tree to run the GPGME test suite.")
  27     (exit 0))
  28
  29 (define (in-gpgme-srcdir . names)
  30   (canonical-path (apply path-join (cons gpgme-srcdir names))))
  31
  32 (define gpgme-builddir (getenv "XTEST_GPGME_BUILDDIR"))
  33 (when (string=? "" gpgme-builddir)
  34     (info
  35      "SKIP: Environment variable 'XTEST_GPGME_BUILDDIR' not set.  Please"
  36      "point it to a recent GPGME build tree to run the GPGME test suite.")
  37     (exit 0))
  38
  39 ;; Make sure that GPGME picks up our gpgconf.  This makes GPGME use
  40 ;; and thus executes the tests with GnuPG components from the build
  41 ;; tree.
  42 (setenv "PATH" (string-append (path-join (getenv "GNUPG_BUILDDIR") "tools")
  43                               (string *pathsep*) (getenv "PATH")) #t)
  44
  45 (define (create-file name content)
  46   (letfd ((fd (open name (logior O_WRONLY O_CREAT O_BINARY) #o600)))
  47     (display content (fdopen fd "wb"))))
  48
  49 (define (create-gpgmehome . path)
  50   (create-file "gpg.conf" "no-force-v3-sigs\n")
  51   (create-file
  52    "gpg-agent.conf"
  53    (string-append "pinentry-program "
  54                   (in-gpgme-srcdir "tests" "gpg" "pinentry") "\n"))
  55   (mkdir "private-keys-v1.d" "-rwx")
  56
  57   (log "Storing private keys")
  58   (for-each
  59    (lambda (name)
  60      (file-copy (apply in-gpgme-srcdir `(,@path ,name))
  61                 (path-join "private-keys-v1.d"
  62                            (string-append name ".key"))))
  63    '("13CD0F3BDF24BE53FE192D62F18737256FF6E4FD"
  64      "76F7E2B35832976B50A27A282D9B87E44577EB66"
  65      "A0747D5F9425E6664F4FFBEED20FBCA79FDED2BD"
  66      "13CBE3758AFE42B5E5E2AE4CED27AFA455E3F87F"
  67      "7A030357C0F253A5BBCD282FFC4E521B37558F5C"))
  68
  69   (log "Importing public demo and test keys")
  70   (for-each
  71    (lambda (file)
  72      (call-check `(,@GPG --yes --import ,(apply in-gpgme-srcdir
  73                                                 `(,@path ,file)))))
  74    (list "pubdemo.asc" "secdemo.asc"))
  75   (stop-agent))
  76
  77 ;; Initialize the test environment, install appropriate configuration
  78 ;; and start the agent, with the keys from the legacy test suite.
  79 (define (setup-gpgme-environment . path)
  80   (if (member "--unpack-tarball" *args*)
  81       (begin
  82         (call-check `(,(tool 'gpgtar) --extract --directory=. ,(cadr *args*)))
  83         (start-agent))
  84       (apply create-gpgme-gpghome path)))
  85
  86 (define (parse-makefile port key)
  87   (define (is-continuation? tokens)
  88     (string=? (last tokens) "\\"))
  89   (define (valid-token? s)
  90     (< 0 (string-length s)))
  91   (define (drop-continuations tokens)
  92     (let loop ((acc '()) (tks tokens))
  93       (if (null? tks)
  94           (reverse acc)
  95           (loop (if (string=? "\\" (car tks))
  96                     acc
  97                     (cons (car tks) acc)) (cdr tks)))))
  98   (let next ((acc '()) (found #f))
  99     (let ((line (read-line port)))
 100       (if (eof-object? line)
 101           acc
 102           (let ((tokens (filter valid-token?
 103                                 (string-splitp (string-trim char-whitespace?
 104                                                             line)
 105                                                char-whitespace? -1))))
 106             (cond
 107              ((or (null? tokens)
 108                   (string-prefix? (car tokens) "#")
 109                   (and (not found) (not (and (string=? key (car tokens))
 110                                              (string=? "=" (cadr tokens))))))
 111               (next acc found))
 112              ((not found)
 113               (assert (and (string=? key (car tokens))
 114                            (string=? "=" (cadr tokens))))
 115               (if (is-continuation? tokens)
 116                   (next (drop-continuations (cddr tokens)) #t)
 117                   (drop-continuations (cddr tokens))))
 118              (else
 119               (assert found)
 120               (if (is-continuation? tokens)
 121                   (next (append acc (drop-continuations tokens)) found)
 122                   (append acc (drop-continuations tokens))))))))))
 123
 124 (define (parse-makefile-expand filename expand key)
 125   (define (variable? v)
 126     (and (string-prefix? v "$(") (string-suffix? v ")")))
 127
 128   (let expand-all ((values (parse-makefile (open-input-file filename) key)))
 129     (if (any variable? values)
 130         (expand-all
 131          (let expand-one ((acc '()) (v values))
 132            (cond
 133             ((null? v)
 134              acc)
 135             ((variable? (car v))
 136              (let ((makefile (open-input-file filename))
 137                    (key (substring (car v) 2 (- (string-length (car v)) 1))))
 138                (expand-one (append acc (expand filename makefile key))
 139                            (cdr v))))
 140             (else
 141              (expand-one (append acc (list (car v))) (cdr v))))))
 142         values)))