doc: Fix description of the field 11.
[gnupg.git] / tests / gpgscm / lib.scm
1 ;; Additional library functions for TinySCHEME.
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 (macro (assert form)
21   (let ((tag (get-tag form)))
22     `(if (not ,(cadr form))
23          (throw ,(if (and (pair? tag) (string? (car tag)) (number? (cdr tag)))
24                      `(string-append ,(car tag) ":"
25                                      ,(number->string (+ 1 (cdr tag)))
26                                      ": Assertion failed: ")
27                      "Assertion failed: ")
28                 (quote ,(cadr form))))))
29 (assert #t)
30 (assert (not #f))
31
32 ;; Trace displays and returns the given value.  A debugging aid.
33 (define (trace x)
34   (display x)
35   (newline)
36   x)
37
38 ;; Stringification.
39 (define (stringify expression)
40   (let ((p (open-output-string)))
41     (write expression p)
42     (get-output-string p)))
43
44 (define (filter pred lst)
45   (cond ((null? lst) '())
46         ((pred (car lst))
47          (cons (car lst) (filter pred (cdr lst))))
48         (else (filter pred (cdr lst)))))
49
50 (define (any p l)
51   (cond ((null? l) #f)
52         ((p (car l)) #t)
53         (else (any p (cdr l)))))
54
55 (define (all p l)
56   (cond ((null? l) #t)
57         ((not (p (car l))) #f)
58         (else (all p (cdr l)))))
59
60 ;; Return the first element of a list.
61 (define first car)
62
63 ;; Return the last element of a list.
64 (define (last lst)
65   (if (null? (cdr lst))
66       (car lst)
67       (last (cdr lst))))
68
69 ;; Compute the powerset of a list.
70 (define (powerset set)
71   (if (null? set)
72       '(())
73       (let ((rst (powerset (cdr set))))
74         (append (map (lambda (x) (cons (car set) x))
75                      rst)
76                 rst))))
77
78 ;; Is PREFIX a prefix of S?
79 (define (string-prefix? s prefix)
80   (and (>= (string-length s) (string-length prefix))
81        (string=? prefix (substring s 0 (string-length prefix)))))
82 (assert (string-prefix? "Scheme" "Sch"))
83
84 ;; Is SUFFIX a suffix of S?
85 (define (string-suffix? s suffix)
86   (and (>= (string-length s) (string-length suffix))
87        (string=? suffix (substring s (- (string-length s)
88                                         (string-length suffix))
89                                    (string-length s)))))
90 (assert (string-suffix? "Scheme" "eme"))
91
92 ;; Locate the first occurrence of needle in haystack starting at offset.
93 (ffi-define (string-index haystack needle [offset]))
94 (assert (= 2 (string-index "Hallo" #\l)))
95 (assert (= 3 (string-index "Hallo" #\l 3)))
96 (assert (equal? #f (string-index "Hallo" #\.)))
97
98 ;; Locate the last occurrence of needle in haystack starting at offset.
99 (ffi-define (string-rindex haystack needle [offset]))
100 (assert (= 3 (string-rindex "Hallo" #\l)))
101 (assert (equal? #f (string-rindex "Hallo" #\a 2)))
102 (assert (equal? #f (string-rindex "Hallo" #\.)))
103
104 ;; Split HAYSTACK at each character that makes PREDICATE true at most
105 ;; N times.
106 (define (string-split-pln haystack predicate lookahead n)
107   (let ((length (string-length haystack)))
108     (define (split acc offset n)
109       (if (>= offset length)
110           (reverse! acc)
111           (let ((i (lookahead haystack offset)))
112             (if (or (eq? i #f) (= 0 n))
113                 (reverse! (cons (substring haystack offset length) acc))
114                 (split (cons (substring haystack offset i) acc)
115                        (+ i 1) (- n 1))))))
116     (split '() 0 n)))
117
118 (define (string-indexp haystack offset predicate)
119   (cond
120    ((= (string-length haystack) offset)
121     #f)
122    ((predicate (string-ref haystack offset))
123     offset)
124    (else
125     (string-indexp haystack (+ 1 offset) predicate))))
126
127 ;; Split HAYSTACK at each character that makes PREDICATE true at most
128 ;; N times.
129 (define (string-splitp haystack predicate n)
130   (string-split-pln haystack predicate
131                     (lambda (haystack offset)
132                       (string-indexp haystack offset predicate))
133                     n))
134 (assert (equal? '("a" "b") (string-splitp "a b" char-whitespace? -1)))
135 (assert (equal? '("a" "b") (string-splitp "a\tb" char-whitespace? -1)))
136 (assert (equal? '("a" "" "b") (string-splitp "a \tb" char-whitespace? -1)))
137
138 ;; Split haystack at delimiter at most n times.
139 (define (string-splitn haystack delimiter n)
140   (string-split-pln haystack
141                     (lambda (c) (char=? c delimiter))
142                     (lambda (haystack offset)
143                       (string-index haystack delimiter offset))
144                     n))
145 (assert (= 2 (length (string-splitn "foo:bar:baz" #\: 1))))
146 (assert (string=? "foo" (car (string-splitn "foo:bar:baz" #\: 1))))
147 (assert (string=? "bar:baz" (cadr (string-splitn "foo:bar:baz" #\: 1))))
148
149 ;; Split haystack at delimiter.
150 (define (string-split haystack delimiter)
151   (string-splitn haystack delimiter -1))
152 (assert (= 3 (length (string-split "foo:bar:baz" #\:))))
153 (assert (string=? "foo" (car (string-split "foo:bar:baz" #\:))))
154 (assert (string=? "bar" (cadr (string-split "foo:bar:baz" #\:))))
155 (assert (string=? "baz" (caddr (string-split "foo:bar:baz" #\:))))
156
157 ;; Split haystack at newlines.
158 (define (string-split-newlines haystack)
159   (if *win32*
160       (map (lambda (line) (if (string-suffix? line "\r")
161                               (substring line 0 (- (string-length line) 1))
162                               line))
163            (string-split haystack #\newline))
164       (string-split haystack #\newline)))
165
166 ;; Trim the prefix of S containing only characters that make PREDICATE
167 ;; true.
168 (define (string-ltrim predicate s)
169   (if (string=? s "")
170       ""
171       (let loop ((s' (string->list s)))
172         (if (predicate (car s'))
173             (loop (cdr s'))
174             (list->string s')))))
175 (assert (string=? "" (string-ltrim char-whitespace? "")))
176 (assert (string=? "foo" (string-ltrim char-whitespace? "  foo")))
177
178 ;; Trim the suffix of S containing only characters that make PREDICATE
179 ;; true.
180 (define (string-rtrim predicate s)
181   (if (string=? s "")
182       ""
183       (let loop ((s' (reverse! (string->list s))))
184         (if (predicate (car s'))
185             (loop (cdr s'))
186             (list->string (reverse! s'))))))
187 (assert (string=? "" (string-rtrim char-whitespace? "")))
188 (assert (string=? "foo" (string-rtrim char-whitespace? "foo     ")))
189
190 ;; Trim both the prefix and suffix of S containing only characters
191 ;; that make PREDICATE true.
192 (define (string-trim predicate s)
193   (string-ltrim predicate (string-rtrim predicate s)))
194 (assert (string=? "" (string-trim char-whitespace? "")))
195 (assert (string=? "foo" (string-trim char-whitespace? "         foo     ")))
196
197 ;; Check if needle is contained in haystack.
198 (ffi-define (string-contains? haystack needle))
199 (assert (string-contains? "Hallo" "llo"))
200 (assert (not (string-contains? "Hallo" "olla")))
201
202 ;; Translate characters.
203 (define (string-translate s from to)
204   (list->string (map (lambda (c)
205                        (let ((i (string-index from c)))
206                          (if i (string-ref to i) c))) (string->list s))))
207 (assert (equal? (string-translate "foo/bar" "/" ".") "foo.bar"))
208
209 ;; Read a word from port P.
210 (define (read-word . p)
211   (list->string
212    (let f ()
213      (let ((c (apply peek-char p)))
214        (cond
215         ((eof-object? c) '())
216         ((char-alphabetic? c)
217          (apply read-char p)
218          (cons c (f)))
219         (else
220          (apply read-char p)
221          '()))))))
222
223 (define (list->string-reversed lst)
224   (let* ((len (length lst))
225          (str (make-string len)))
226     (let loop ((i (- len 1))
227                (l lst))
228       (if (< i 0)
229           (begin
230             (assert (null? l))
231             str)
232           (begin
233             (string-set! str i (car l))
234             (loop (- i 1) (cdr l)))))))
235
236 ;; Read a line from port P.
237 (define (read-line . p)
238   (let loop ((acc '()))
239     (let ((c (apply peek-char p)))
240       (cond
241        ((eof-object? c)
242         (if (null? acc)
243             c ;; #eof
244             (list->string-reversed acc)))
245        ((char=? c #\newline)
246         (apply read-char p)
247         (list->string-reversed acc))
248        (else
249         (apply read-char p)
250         (loop (cons c acc)))))))
251
252 ;; Read everything from port P.
253 (define (read-all . p)
254   (let loop ((acc (open-output-string)))
255     (let ((c (apply peek-char p)))
256       (cond
257        ((eof-object? c) (get-output-string acc))
258        (else
259         (write-char (apply read-char p) acc)
260         (loop acc))))))
261
262 ;;
263 ;; Windows support.
264 ;;
265
266 ;; Like call-with-input-file but opens the file in 'binary' mode.
267 (define (call-with-binary-input-file filename proc)
268   (letfd ((fd (open filename (logior O_RDONLY O_BINARY))))
269          (proc (fdopen fd "rb"))))
270
271 ;; Like call-with-output-file but opens the file in 'binary' mode.
272 (define (call-with-binary-output-file filename proc)
273   (letfd ((fd (open filename (logior O_WRONLY O_CREAT O_BINARY) #o600)))
274          (proc (fdopen fd "wb"))))
275
276 ;;
277 ;; Libc functions.
278 ;;
279
280 ;; Change the read/write offset.
281 (ffi-define (seek fd offset whence))
282
283 ;; Constants for WHENCE.
284 (ffi-define SEEK_SET)
285 (ffi-define SEEK_CUR)
286 (ffi-define SEEK_END)
287
288 ;; Get our process id.
289 (ffi-define (getpid))
290
291 ;; Copy data from file descriptor SOURCE to every file descriptor in
292 ;; SINKS.
293 (ffi-define (splice source . sinks))
294
295 ;;
296 ;; Random numbers.
297 ;;
298
299 ;; Seed the random number generator.
300 (ffi-define (srandom seed))
301
302 ;; Get a pseudo-random number between 0 (inclusive) and SCALE
303 ;; (exclusive).
304 (ffi-define (random scale))
305
306 ;; Create a string of the given SIZE containing pseudo-random data.
307 (ffi-define (make-random-string size))