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 ;; Command line flag handling.  Returns the elements following KEY in
  87 ;; ARGUMENTS up to the next argument, or #f if KEY is not in
  88 ;; ARGUMENTS.
  89 (define (flag key arguments)
  90   (cond
  91    ((null? arguments)
  92     #f)
  93    ((string=? key (car arguments))
  94     (let loop ((acc '())
  95                (args (cdr arguments)))
  96       (if (or (null? args) (string-prefix? (car args) "--"))
  97           (reverse acc)
  98           (loop (cons (car args) acc) (cdr args)))))
  99    ((string=? "--" (car arguments))
 100     #f)
 101    (else
 102     (flag key (cdr arguments)))))
 103 (assert (equal? (flag "--xxx" '("--yyy")) #f))
 104 (assert (equal? (flag "--xxx" '("--xxx")) '()))
 105 (assert (equal? (flag "--xxx" '("--xxx" "yyy")) '("yyy")))
 106 (assert (equal? (flag "--xxx" '("--xxx" "yyy" "zzz")) '("yyy" "zzz")))
 107 (assert (equal? (flag "--xxx" '("--xxx" "yyy" "zzz" "--")) '("yyy" "zzz")))
 108 (assert (equal? (flag "--xxx" '("--xxx" "yyy" "--" "zzz")) '("yyy")))
 109 (assert (equal? (flag "--" '("--" "xxx" "yyy" "--" "zzz")) '("xxx" "yyy")))
 110
 111 (define (parse-makefile port key)
 112   (define (is-continuation? tokens)
 113     (string=? (last tokens) "\\"))
 114   (define (valid-token? s)
 115     (< 0 (string-length s)))
 116   (define (drop-continuations tokens)
 117     (let loop ((acc '()) (tks tokens))
 118       (if (null? tks)
 119           (reverse acc)
 120           (loop (if (string=? "\\" (car tks))
 121                     acc
 122                     (cons (car tks) acc)) (cdr tks)))))
 123   (let next ((acc '()) (found #f))
 124     (let ((line (read-line port)))
 125       (if (eof-object? line)
 126           acc
 127           (let ((tokens (filter valid-token?
 128                                 (string-splitp (string-trim char-whitespace?
 129                                                             line)
 130                                                char-whitespace? -1))))
 131             (cond
 132              ((or (null? tokens)
 133                   (string-prefix? (car tokens) "#")
 134                   (and (not found) (not (and (string=? key (car tokens))
 135                                              (string=? "=" (cadr tokens))))))
 136               (next acc found))
 137              ((not found)
 138               (assert (and (string=? key (car tokens))
 139                            (string=? "=" (cadr tokens))))
 140               (if (is-continuation? tokens)
 141                   (next (drop-continuations (cddr tokens)) #t)
 142                   (drop-continuations (cddr tokens))))
 143              (else
 144               (assert found)
 145               (if (is-continuation? tokens)
 146                   (next (append acc (drop-continuations tokens)) found)
 147                   (append acc (drop-continuations tokens))))))))))
 148
 149 (define (parse-makefile-expand filename expand key)
 150   (define (variable? v)
 151     (and (string-prefix? v "$(") (string-suffix? v ")")))
 152
 153   (let expand-all ((values (parse-makefile (open-input-file filename) key)))
 154     (if (any variable? values)
 155         (expand-all
 156          (let expand-one ((acc '()) (v values))
 157            (cond
 158             ((null? v)
 159              acc)
 160             ((variable? (car v))
 161              (let ((makefile (open-input-file filename))
 162                    (key (substring (car v) 2 (- (string-length (car v)) 1))))
 163                (expand-one (append acc (expand filename makefile key))
 164                            (cdr v))))
 165             (else
 166              (expand-one (append acc (list (car v))) (cdr v))))))
 167         values)))