tests: Reuse GPGME's tests.
[gnupg.git] / 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)))