7d2d1ebacad5077e599aa1e6223951a7ca4f937c
[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   `(if (not ,(cadr form))
22        (begin
23          (display "Assertion failed: ")
24          (write (quote ,(cadr form)))
25          (newline)
26          (exit 1))))
27 (assert #t)
28
29 (define (filter pred lst)
30   (cond ((null? lst) '())
31         ((pred (car lst))
32          (cons (car lst) (filter pred (cdr lst))))
33         (else (filter pred (cdr lst)))))
34
35 (define (any p l)
36   (cond ((null? l) #f)
37         ((p (car l)) #t)
38         (else (any p (cdr l)))))
39
40 (define (all p l)
41   (cond ((null? l) #t)
42         ((not (p (car l))) #f)
43         (else (all p (cdr l)))))
44
45 ;; Return the first element of a list.
46 (define first car)
47
48 ;; Return the last element of a list.
49 (define (last lst)
50   (if (null? (cdr lst))
51       (car lst)
52       (last (cdr lst))))
53
54 ;; Compute the powerset of a list.
55 (define (powerset set)
56   (if (null? set)
57       '(())
58       (let ((rst (powerset (cdr set))))
59         (append (map (lambda (x) (cons (car set) x))
60                      rst)
61                 rst))))
62
63 ;; Is PREFIX a prefix of S?
64 (define (string-prefix? s prefix)
65   (and (>= (string-length s) (string-length prefix))
66        (string=? prefix (substring s 0 (string-length prefix)))))
67 (assert (string-prefix? "Scheme" "Sch"))
68
69 ;; Is SUFFIX a suffix of S?
70 (define (string-suffix? s suffix)
71   (and (>= (string-length s) (string-length suffix))
72        (string=? suffix (substring s (- (string-length s)
73                                         (string-length suffix))
74                                    (string-length s)))))
75 (assert (string-suffix? "Scheme" "eme"))
76
77 ;; Locate the first occurrence of needle in haystack starting at offset.
78 (ffi-define (string-index haystack needle [offset]))
79 (assert (= 2 (string-index "Hallo" #\l)))
80 (assert (= 3 (string-index "Hallo" #\l 3)))
81 (assert (equal? #f (string-index "Hallo" #\.)))
82
83 ;; Locate the last occurrence of needle in haystack starting at offset.
84 (ffi-define (string-rindex haystack needle [offset]))
85 (assert (= 3 (string-rindex "Hallo" #\l)))
86 (assert (equal? #f (string-rindex "Hallo" #\a 2)))
87 (assert (equal? #f (string-rindex "Hallo" #\.)))
88
89 ;; Split haystack at delimiter at most n times.
90 (define (string-splitn haystack delimiter n)
91   (let ((length (string-length haystack)))
92     (define (split acc delimiter offset n)
93       (if (>= offset length)
94           (reverse acc)
95           (let ((i (string-index haystack delimiter offset)))
96             (if (or (eq? i #f) (= 0 n))
97                 (reverse (cons (substring haystack offset length) acc))
98                 (split (cons (substring haystack offset i) acc)
99                        delimiter (+ i 1) (- n 1))))))
100     (split '() delimiter 0 n)))
101 (assert (= 2 (length (string-splitn "foo:bar:baz" #\: 1))))
102 (assert (string=? "foo" (car (string-splitn "foo:bar:baz" #\: 1))))
103 (assert (string=? "bar:baz" (cadr (string-splitn "foo:bar:baz" #\: 1))))
104
105 ;; Split haystack at delimiter.
106 (define (string-split haystack delimiter)
107   (string-splitn haystack delimiter -1))
108 (assert (= 3 (length (string-split "foo:bar:baz" #\:))))
109 (assert (string=? "foo" (car (string-split "foo:bar:baz" #\:))))
110 (assert (string=? "bar" (cadr (string-split "foo:bar:baz" #\:))))
111 (assert (string=? "baz" (caddr (string-split "foo:bar:baz" #\:))))
112
113 ;; Split haystack at newlines.
114 (define (string-split-newlines haystack)
115   (if *win32*
116       (map (lambda (line) (if (string-suffix? line "\r")
117                               (substring line 0 (- (string-length line) 1))
118                               line))
119            (string-split haystack #\newline))
120       (string-split haystack #\newline)))
121
122 ;; Trim the prefix of S containing only characters that make PREDICATE
123 ;; true.
124 (define (string-ltrim predicate s)
125   (let loop ((s' (string->list s)))
126     (if (predicate (car s'))
127         (loop (cdr s'))
128         (list->string s'))))
129 (assert (string=? "foo" (string-ltrim char-whitespace? "  foo")))
130
131 ;; Trim the suffix of S containing only characters that make PREDICATE
132 ;; true.
133 (define (string-rtrim predicate s)
134   (let loop ((s' (reverse (string->list s))))
135     (if (predicate (car s'))
136         (loop (cdr s'))
137         (list->string (reverse s')))))
138 (assert (string=? "foo" (string-rtrim char-whitespace? "foo     ")))
139
140 ;; Trim both the prefix and suffix of S containing only characters
141 ;; that make PREDICATE true.
142 (define (string-trim predicate s)
143   (string-ltrim predicate (string-rtrim predicate s)))
144 (assert (string=? "foo" (string-trim char-whitespace? "         foo     ")))
145
146 ;; Check if needle is contained in haystack.
147 (ffi-define (string-contains? haystack needle))
148 (assert (string-contains? "Hallo" "llo"))
149 (assert (not (string-contains? "Hallo" "olla")))
150
151 ;; Read a word from port P.
152 (define (read-word . p)
153   (list->string
154    (let f ()
155      (let ((c (apply peek-char p)))
156        (cond
157         ((eof-object? c) '())
158         ((char-alphabetic? c)
159          (apply read-char p)
160          (cons c (f)))
161         (else
162          (apply read-char p)
163          '()))))))
164
165 ;; Read a line from port P.
166 (define (read-line . p)
167   (list->string
168    (let f ()
169      (let ((c (apply peek-char p)))
170        (cond
171         ((eof-object? c) '())
172         ((char=? c #\newline)
173          (apply read-char p)
174          '())
175         (else
176          (apply read-char p)
177          (cons c (f))))))))
178
179 ;; Read everything from port P.
180 (define (read-all . p)
181   (let loop ((acc (open-output-string)))
182     (let ((c (apply peek-char p)))
183       (cond
184        ((eof-object? c) (get-output-string acc))
185        (else
186         (write-char (apply read-char p) acc)
187         (loop acc))))))
188
189 ;;
190 ;; Windows support.
191 ;;
192
193 ;; Like call-with-input-file but opens the file in 'binary' mode.
194 (define (call-with-binary-input-file filename proc)
195   (letfd ((fd (open filename (logior O_RDONLY O_BINARY))))
196          (proc (fdopen fd "rb"))))
197
198 ;; Like call-with-output-file but opens the file in 'binary' mode.
199 (define (call-with-binary-output-file filename proc)
200   (letfd ((fd (open filename (logior O_WRONLY O_CREAT O_BINARY) #o600)))
201          (proc (fdopen fd "wb"))))
202
203 ;;
204 ;; Libc functions.
205 ;;
206
207 ;; Get our process id.
208 (ffi-define (getpid))
209
210 ;; Copy data from file descriptor SOURCE to SINK.
211 (ffi-define (splice source sink))
212
213 ;;
214 ;; Random numbers.
215 ;;
216
217 ;; Seed the random number generator.
218 (ffi-define (srandom seed))
219
220 ;; Get a pseudo-random number between 0 (inclusive) and SCALE
221 ;; (exclusive).
222 (ffi-define (random scale))
223
224 ;; Create a string of the given SIZE containing pseudo-random data.
225 (ffi-define (make-random-string size))