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