tests/gpgscm: Add a TinySCHEME-based test driver.
[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 (list "Assertion failed:" (quote ,(cadr form))))
24          (newline)
25          (exit 1))))
26 (assert #t)
27
28 (define (filter pred lst)
29   (cond ((null? lst) '())
30         ((pred (car lst))
31          (cons (car lst) (filter pred (cdr lst))))
32         (else (filter pred (cdr lst)))))
33
34 (define (any p l)
35   (cond ((null? l) #f)
36         ((p (car l)) #t)
37         (else (any p (cdr l)))))
38
39 (define (all p l)
40   (cond ((null? l) #t)
41         ((not (p (car l))) #f)
42         (else (all p (cdr l)))))
43
44 ;; Is PREFIX a prefix of S?
45 (define (string-prefix? s prefix)
46   (and (>= (string-length s) (string-length prefix))
47        (string=? prefix (substring s 0 (string-length prefix)))))
48 (assert (string-prefix? "Scheme" "Sch"))
49
50 ;; Is SUFFIX a suffix of S?
51 (define (string-suffix? s suffix)
52   (and (>= (string-length s) (string-length suffix))
53        (string=? suffix (substring s (- (string-length s)
54                                         (string-length suffix))
55                                    (string-length s)))))
56 (assert (string-suffix? "Scheme" "eme"))
57
58 ;; Locate the first occurrence of needle in haystack.
59 (define (string-index haystack needle)
60   (define (index i haystack needle)
61     (if (= (length haystack) 0)
62         #f
63         (if (char=? (car haystack) needle)
64             i
65             (index (+ i 1) (cdr haystack) needle))))
66   (index 0 (string->list haystack) needle))
67
68 ;; Locate the last occurrence of needle in haystack.
69 (define (string-rindex haystack needle)
70   (let ((rindex (string-index (list->string (reverse (string->list haystack)))
71                               needle)))
72     (if rindex (- (string-length haystack) rindex 1) #f)))
73
74 ;; Split haystack at delimiter at most n times.
75 (define (string-splitn haystack delimiter n)
76   (define (split acc haystack delimiter n)
77     (if (= (string-length haystack) 0)
78         (reverse acc)
79         (let ((i (string-index haystack delimiter)))
80           (if (not (or (eq? i #f) (= 0 n)))
81               (split (cons (substring haystack 0 i) acc)
82                      (substring haystack (+ i 1) (string-length haystack))
83                      delimiter (- n 1))
84               (split (cons haystack acc) "" delimiter 0)
85               ))))
86   (split '() haystack delimiter n))
87
88 ;; Split haystack at delimiter.
89 (define (string-split haystack delimiter)
90   (string-splitn haystack delimiter -1))
91
92 ;; Trim the prefix of S containing only characters that make PREDICATE
93 ;; true.  For example (string-ltrim char-whitespace? "  foo") =>
94 ;; "foo".
95 (define (string-ltrim predicate s)
96   (let loop ((s' (string->list s)))
97     (if (predicate (car s'))
98         (loop (cdr s'))
99         (list->string s'))))
100
101 ;; Trim the suffix of S containing only characters that make PREDICATE
102 ;; true.
103 (define (string-rtrim predicate s)
104   (let loop ((s' (reverse (string->list s))))
105     (if (predicate (car s'))
106         (loop (cdr s'))
107         (list->string (reverse s')))))
108
109 ;; Trim both the prefix and suffix of S containing only characters
110 ;; that make PREDICATE true.
111 (define (string-trim predicate s)
112   (string-ltrim predicate (string-rtrim predicate s)))
113
114 (define (string-contains? s contained)
115   (let loop ((offset 0))
116     (if (<= (+ offset (string-length contained)) (string-length s))
117         (if (string=? (substring s offset (+ offset (string-length contained)))
118                       contained)
119             #t
120             (loop (+ 1 offset)))
121         #f)))
122
123 (define (echo . msg)
124   (for-each (lambda (x) (display x) (display " ")) msg)
125   (newline))
126
127 ;; Read a word from port P.
128 (define (read-word . p)
129   (list->string
130    (let f ()
131      (let ((c (apply peek-char p)))
132        (cond
133         ((eof-object? c) '())
134         ((char-alphabetic? c)
135          (apply read-char p)
136          (cons c (f)))
137         (else
138          (apply read-char p)
139          '()))))))
140
141 ;; Read a line from port P.
142 (define (read-line . p)
143   (list->string
144    (let f ()
145      (let ((c (apply peek-char p)))
146        (cond
147         ((eof-object? c) '())
148         ((char=? c #\newline)
149          (apply read-char p)
150          '())
151         (else
152          (apply read-char p)
153          (cons c (f))))))))
154
155 ;; Read everything from port P.
156 (define (read-all . p)
157   (list->string
158    (let f ()
159      (let ((c (apply peek-char p)))
160        (cond
161         ((eof-object? c) '())
162         (else (apply read-char p)
163          (cons c (f))))))))