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