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