tests: Improve handling of Windows newlines.
[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 ;; Split haystack at newlines.
96 (define (string-split-newlines haystack)
97   (if *win32*
98       (map (lambda (line) (if (string-suffix? line "\r")
99                               (substring line 0 (- (string-length line) 1))
100                               line))
101            (string-split haystack #\newline))
102       (string-split haystack #\newline)))
103
104 ;; Trim the prefix of S containing only characters that make PREDICATE
105 ;; true.
106 (define (string-ltrim predicate s)
107   (let loop ((s' (string->list s)))
108     (if (predicate (car s'))
109         (loop (cdr s'))
110         (list->string s'))))
111 (assert (string=? "foo" (string-ltrim char-whitespace? "  foo")))
112
113 ;; Trim the suffix of S containing only characters that make PREDICATE
114 ;; true.
115 (define (string-rtrim predicate s)
116   (let loop ((s' (reverse (string->list s))))
117     (if (predicate (car s'))
118         (loop (cdr s'))
119         (list->string (reverse s')))))
120 (assert (string=? "foo" (string-rtrim char-whitespace? "foo     ")))
121
122 ;; Trim both the prefix and suffix of S containing only characters
123 ;; that make PREDICATE true.
124 (define (string-trim predicate s)
125   (string-ltrim predicate (string-rtrim predicate s)))
126 (assert (string=? "foo" (string-trim char-whitespace? "         foo     ")))
127
128 ;; Check if needle is contained in haystack.
129 (ffi-define (string-contains? haystack needle))
130 (assert (string-contains? "Hallo" "llo"))
131 (assert (not (string-contains? "Hallo" "olla")))
132
133 ;; Read a word from port P.
134 (define (read-word . p)
135   (list->string
136    (let f ()
137      (let ((c (apply peek-char p)))
138        (cond
139         ((eof-object? c) '())
140         ((char-alphabetic? c)
141          (apply read-char p)
142          (cons c (f)))
143         (else
144          (apply read-char p)
145          '()))))))
146
147 ;; Read a line from port P.
148 (define (read-line . p)
149   (list->string
150    (let f ()
151      (let ((c (apply peek-char p)))
152        (cond
153         ((eof-object? c) '())
154         ((char=? c #\newline)
155          (apply read-char p)
156          '())
157         (else
158          (apply read-char p)
159          (cons c (f))))))))
160
161 ;; Read everything from port P.
162 (define (read-all . p)
163   (let loop ((acc (open-output-string)))
164     (let ((c (apply peek-char p)))
165       (cond
166        ((eof-object? c) (get-output-string acc))
167        (else
168         (write-char (apply read-char p) acc)
169         (loop acc))))))