diff options
Diffstat (limited to 'tests/gpgscm/lib.scm')
| -rw-r--r-- | tests/gpgscm/lib.scm | 163 |
1 files changed, 163 insertions, 0 deletions
diff --git a/tests/gpgscm/lib.scm b/tests/gpgscm/lib.scm new file mode 100644 index 000000000..871cc8f5c --- /dev/null +++ b/tests/gpgscm/lib.scm @@ -0,0 +1,163 @@ +;; Additional library functions for TinySCHEME. +;; +;; Copyright (C) 2016 g10 Code GmbH +;; +;; This file is part of GnuPG. +;; +;; GnuPG is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; GnuPG is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, see <http://www.gnu.org/licenses/>. + +(macro (assert form) + `(if (not ,(cadr form)) + (begin + (display (list "Assertion failed:" (quote ,(cadr form)))) + (newline) + (exit 1)))) +(assert #t) + +(define (filter pred lst) + (cond ((null? lst) '()) + ((pred (car lst)) + (cons (car lst) (filter pred (cdr lst)))) + (else (filter pred (cdr lst))))) + +(define (any p l) + (cond ((null? l) #f) + ((p (car l)) #t) + (else (any p (cdr l))))) + +(define (all p l) + (cond ((null? l) #t) + ((not (p (car l))) #f) + (else (all p (cdr l))))) + +;; Is PREFIX a prefix of S? +(define (string-prefix? s prefix) + (and (>= (string-length s) (string-length prefix)) + (string=? prefix (substring s 0 (string-length prefix))))) +(assert (string-prefix? "Scheme" "Sch")) + +;; Is SUFFIX a suffix of S? +(define (string-suffix? s suffix) + (and (>= (string-length s) (string-length suffix)) + (string=? suffix (substring s (- (string-length s) + (string-length suffix)) + (string-length s))))) +(assert (string-suffix? "Scheme" "eme")) + +;; Locate the first occurrence of needle in haystack. +(define (string-index haystack needle) + (define (index i haystack needle) + (if (= (length haystack) 0) + #f + (if (char=? (car haystack) needle) + i + (index (+ i 1) (cdr haystack) needle)))) + (index 0 (string->list haystack) needle)) + +;; Locate the last occurrence of needle in haystack. +(define (string-rindex haystack needle) + (let ((rindex (string-index (list->string (reverse (string->list haystack))) + needle))) + (if rindex (- (string-length haystack) rindex 1) #f))) + +;; Split haystack at delimiter at most n times. +(define (string-splitn haystack delimiter n) + (define (split acc haystack delimiter n) + (if (= (string-length haystack) 0) + (reverse acc) + (let ((i (string-index haystack delimiter))) + (if (not (or (eq? i #f) (= 0 n))) + (split (cons (substring haystack 0 i) acc) + (substring haystack (+ i 1) (string-length haystack)) + delimiter (- n 1)) + (split (cons haystack acc) "" delimiter 0) + )))) + (split '() haystack delimiter n)) + +;; Split haystack at delimiter. +(define (string-split haystack delimiter) + (string-splitn haystack delimiter -1)) + +;; Trim the prefix of S containing only characters that make PREDICATE +;; true. For example (string-ltrim char-whitespace? " foo") => +;; "foo". +(define (string-ltrim predicate s) + (let loop ((s' (string->list s))) + (if (predicate (car s')) + (loop (cdr s')) + (list->string s')))) + +;; Trim the suffix of S containing only characters that make PREDICATE +;; true. +(define (string-rtrim predicate s) + (let loop ((s' (reverse (string->list s)))) + (if (predicate (car s')) + (loop (cdr s')) + (list->string (reverse s'))))) + +;; Trim both the prefix and suffix of S containing only characters +;; that make PREDICATE true. +(define (string-trim predicate s) + (string-ltrim predicate (string-rtrim predicate s))) + +(define (string-contains? s contained) + (let loop ((offset 0)) + (if (<= (+ offset (string-length contained)) (string-length s)) + (if (string=? (substring s offset (+ offset (string-length contained))) + contained) + #t + (loop (+ 1 offset))) + #f))) + +(define (echo . msg) + (for-each (lambda (x) (display x) (display " ")) msg) + (newline)) + +;; Read a word from port P. +(define (read-word . p) + (list->string + (let f () + (let ((c (apply peek-char p))) + (cond + ((eof-object? c) '()) + ((char-alphabetic? c) + (apply read-char p) + (cons c (f))) + (else + (apply read-char p) + '())))))) + +;; Read a line from port P. +(define (read-line . p) + (list->string + (let f () + (let ((c (apply peek-char p))) + (cond + ((eof-object? c) '()) + ((char=? c #\newline) + (apply read-char p) + '()) + (else + (apply read-char p) + (cons c (f)))))))) + +;; Read everything from port P. +(define (read-all . p) + (list->string + (let f () + (let ((c (apply peek-char p))) + (cond + ((eof-object? c) '()) + (else (apply read-char p) + (cons c (f)))))))) |