gpgscm: Fix reallocating string ports.
[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 starting at offset.
59 (ffi-define (string-index haystack needle [offset]))
60 (assert (= 2 (string-index "Hallo" #\l)))
61 (assert (= 3 (string-index "Hallo" #\l 3)))
62 (assert (equal? #f (string-index "Hallo" #\.)))
63
64 ;; Locate the last occurrence of needle in haystack starting at offset.
65 (ffi-define (string-rindex haystack needle [offset]))
66 (assert (= 3 (string-rindex "Hallo" #\l)))
67 (assert (equal? #f (string-rindex "Hallo" #\a 2)))
68 (assert (equal? #f (string-rindex "Hallo" #\.)))
69
70 ;; Split haystack at delimiter at most n times.
71 (define (string-splitn haystack delimiter n)
72   (let ((length (string-length haystack)))
73     (define (split acc delimiter offset n)
74       (if (>= offset length)
75           (reverse acc)
76           (let ((i (string-index haystack delimiter offset)))
77             (if (or (eq? i #f) (= 0 n))
78                 (reverse (cons (substring haystack offset length) acc))
79                 (split (cons (substring haystack offset i) acc)
80                        delimiter (+ i 1) (- n 1))))))
81     (split '() delimiter 0 n)))
82 (assert (= 2 (length (string-splitn "foo:bar:baz" #\: 1))))
83 (assert (string=? "foo" (car (string-splitn "foo:bar:baz" #\: 1))))
84 (assert (string=? "bar:baz" (cadr (string-splitn "foo:bar:baz" #\: 1))))
85
86 ;; Split haystack at delimiter.
87 (define (string-split haystack delimiter)
88   (string-splitn haystack delimiter -1))
89 (assert (= 3 (length (string-split "foo:bar:baz" #\:))))
90 (assert (string=? "foo" (car (string-split "foo:bar:baz" #\:))))
91 (assert (string=? "bar" (cadr (string-split "foo:bar:baz" #\:))))
92 (assert (string=? "baz" (caddr (string-split "foo:bar:baz" #\:))))
93
94 ;; Trim the prefix of S containing only characters that make PREDICATE
95 ;; true.
96 (define (string-ltrim predicate s)
97   (let loop ((s' (string->list s)))
98     (if (predicate (car s'))
99         (loop (cdr s'))
100         (list->string s'))))
101 (assert (string=? "foo" (string-ltrim char-whitespace? "  foo")))
102
103 ;; Trim the suffix of S containing only characters that make PREDICATE
104 ;; true.
105 (define (string-rtrim predicate s)
106   (let loop ((s' (reverse (string->list s))))
107     (if (predicate (car s'))
108         (loop (cdr s'))
109         (list->string (reverse s')))))
110 (assert (string=? "foo" (string-rtrim char-whitespace? "foo     ")))
111
112 ;; Trim both the prefix and suffix of S containing only characters
113 ;; that make PREDICATE true.
114 (define (string-trim predicate s)
115   (string-ltrim predicate (string-rtrim predicate s)))
116 (assert (string=? "foo" (string-trim char-whitespace? "         foo     ")))
117
118 ;; Check if needle is contained in haystack.
119 (ffi-define (string-contains? haystack needle))
120 (assert (string-contains? "Hallo" "llo"))
121 (assert (not (string-contains? "Hallo" "olla")))
122
123 ;; Read a word from port P.
124 (define (read-word . p)
125   (list->string
126    (let f ()
127      (let ((c (apply peek-char p)))
128        (cond
129         ((eof-object? c) '())
130         ((char-alphabetic? c)
131          (apply read-char p)
132          (cons c (f)))
133         (else
134          (apply read-char p)
135          '()))))))
136
137 ;; Read a line from port P.
138 (define (read-line . p)
139   (list->string
140    (let f ()
141      (let ((c (apply peek-char p)))
142        (cond
143         ((eof-object? c) '())
144         ((char=? c #\newline)
145          (apply read-char p)
146          '())
147         (else
148          (apply read-char p)
149          (cons c (f))))))))
150
151 ;; Read everything from port P.
152 (define (read-all . p)
153   (let loop ((acc (open-output-string)))
154     (let ((c (apply peek-char p)))
155       (cond
156        ((eof-object? c) (get-output-string acc))
157        (else
158         (write-char (apply read-char p) acc)
159         (loop acc))))))