mirror of
git://git.gnupg.org/gnupg.git
synced 2024-12-23 10:29:58 +01:00
aab6ba0bb6
* tests/gpgscm/init.scm (vm-history-print): Check that the tag added to expressions when parsing source files matches the expected format. * tests/gpgscm/lib.scm (assert): Likewise. -- This makes the error handling more robust. We saw the assumption about the format of the tags being violated on one build system, and it obscured the view on the underlying problem. Signed-off-by: Justus Winter <justus@g10code.com>
289 lines
8.6 KiB
Scheme
289 lines
8.6 KiB
Scheme
;; 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)
|
|
(let ((tag (get-tag form)))
|
|
`(if (not ,(cadr form))
|
|
(throw ,(if (and (pair? tag) (string? (car tag)) (number? (cdr tag)))
|
|
`(string-append ,(car tag) ":"
|
|
,(number->string (+ 1 (cdr tag)))
|
|
": Assertion failed: ")
|
|
"Assertion failed: ")
|
|
(quote ,(cadr form))))))
|
|
(assert #t)
|
|
(assert (not #f))
|
|
|
|
(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)))))
|
|
|
|
;; Return the first element of a list.
|
|
(define first car)
|
|
|
|
;; Return the last element of a list.
|
|
(define (last lst)
|
|
(if (null? (cdr lst))
|
|
(car lst)
|
|
(last (cdr lst))))
|
|
|
|
;; Compute the powerset of a list.
|
|
(define (powerset set)
|
|
(if (null? set)
|
|
'(())
|
|
(let ((rst (powerset (cdr set))))
|
|
(append (map (lambda (x) (cons (car set) x))
|
|
rst)
|
|
rst))))
|
|
|
|
;; 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 starting at offset.
|
|
(ffi-define (string-index haystack needle [offset]))
|
|
(assert (= 2 (string-index "Hallo" #\l)))
|
|
(assert (= 3 (string-index "Hallo" #\l 3)))
|
|
(assert (equal? #f (string-index "Hallo" #\.)))
|
|
|
|
;; Locate the last occurrence of needle in haystack starting at offset.
|
|
(ffi-define (string-rindex haystack needle [offset]))
|
|
(assert (= 3 (string-rindex "Hallo" #\l)))
|
|
(assert (equal? #f (string-rindex "Hallo" #\a 2)))
|
|
(assert (equal? #f (string-rindex "Hallo" #\.)))
|
|
|
|
;; Split HAYSTACK at each character that makes PREDICATE true at most
|
|
;; N times.
|
|
(define (string-split-pln haystack predicate lookahead n)
|
|
(let ((length (string-length haystack)))
|
|
(define (split acc offset n)
|
|
(if (>= offset length)
|
|
(reverse acc)
|
|
(let ((i (lookahead haystack offset)))
|
|
(if (or (eq? i #f) (= 0 n))
|
|
(reverse (cons (substring haystack offset length) acc))
|
|
(split (cons (substring haystack offset i) acc)
|
|
(+ i 1) (- n 1))))))
|
|
(split '() 0 n)))
|
|
|
|
(define (string-indexp haystack offset predicate)
|
|
(cond
|
|
((= (string-length haystack) offset)
|
|
#f)
|
|
((predicate (string-ref haystack offset))
|
|
offset)
|
|
(else
|
|
(string-indexp haystack (+ 1 offset) predicate))))
|
|
|
|
;; Split HAYSTACK at each character that makes PREDICATE true at most
|
|
;; N times.
|
|
(define (string-splitp haystack predicate n)
|
|
(string-split-pln haystack predicate
|
|
(lambda (haystack offset)
|
|
(string-indexp haystack offset predicate))
|
|
n))
|
|
(assert (equal? '("a" "b") (string-splitp "a b" char-whitespace? -1)))
|
|
(assert (equal? '("a" "b") (string-splitp "a\tb" char-whitespace? -1)))
|
|
(assert (equal? '("a" "" "b") (string-splitp "a \tb" char-whitespace? -1)))
|
|
|
|
;; Split haystack at delimiter at most n times.
|
|
(define (string-splitn haystack delimiter n)
|
|
(string-split-pln haystack
|
|
(lambda (c) (char=? c delimiter))
|
|
(lambda (haystack offset)
|
|
(string-index haystack delimiter offset))
|
|
n))
|
|
(assert (= 2 (length (string-splitn "foo:bar:baz" #\: 1))))
|
|
(assert (string=? "foo" (car (string-splitn "foo:bar:baz" #\: 1))))
|
|
(assert (string=? "bar:baz" (cadr (string-splitn "foo:bar:baz" #\: 1))))
|
|
|
|
;; Split haystack at delimiter.
|
|
(define (string-split haystack delimiter)
|
|
(string-splitn haystack delimiter -1))
|
|
(assert (= 3 (length (string-split "foo:bar:baz" #\:))))
|
|
(assert (string=? "foo" (car (string-split "foo:bar:baz" #\:))))
|
|
(assert (string=? "bar" (cadr (string-split "foo:bar:baz" #\:))))
|
|
(assert (string=? "baz" (caddr (string-split "foo:bar:baz" #\:))))
|
|
|
|
;; Split haystack at newlines.
|
|
(define (string-split-newlines haystack)
|
|
(if *win32*
|
|
(map (lambda (line) (if (string-suffix? line "\r")
|
|
(substring line 0 (- (string-length line) 1))
|
|
line))
|
|
(string-split haystack #\newline))
|
|
(string-split haystack #\newline)))
|
|
|
|
;; Trim the prefix of S containing only characters that make PREDICATE
|
|
;; true.
|
|
(define (string-ltrim predicate s)
|
|
(if (string=? s "")
|
|
""
|
|
(let loop ((s' (string->list s)))
|
|
(if (predicate (car s'))
|
|
(loop (cdr s'))
|
|
(list->string s')))))
|
|
(assert (string=? "" (string-ltrim char-whitespace? "")))
|
|
(assert (string=? "foo" (string-ltrim char-whitespace? " foo")))
|
|
|
|
;; Trim the suffix of S containing only characters that make PREDICATE
|
|
;; true.
|
|
(define (string-rtrim predicate s)
|
|
(if (string=? s "")
|
|
""
|
|
(let loop ((s' (reverse (string->list s))))
|
|
(if (predicate (car s'))
|
|
(loop (cdr s'))
|
|
(list->string (reverse s'))))))
|
|
(assert (string=? "" (string-rtrim char-whitespace? "")))
|
|
(assert (string=? "foo" (string-rtrim char-whitespace? "foo ")))
|
|
|
|
;; 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)))
|
|
(assert (string=? "" (string-trim char-whitespace? "")))
|
|
(assert (string=? "foo" (string-trim char-whitespace? " foo ")))
|
|
|
|
;; Check if needle is contained in haystack.
|
|
(ffi-define (string-contains? haystack needle))
|
|
(assert (string-contains? "Hallo" "llo"))
|
|
(assert (not (string-contains? "Hallo" "olla")))
|
|
|
|
;; 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)
|
|
'()))))))
|
|
|
|
(define (list->string-reversed lst)
|
|
(let* ((len (length lst))
|
|
(str (make-string len)))
|
|
(let loop ((i (- len 1))
|
|
(l lst))
|
|
(if (< i 0)
|
|
(begin
|
|
(assert (null? l))
|
|
str)
|
|
(begin
|
|
(string-set! str i (car l))
|
|
(loop (- i 1) (cdr l)))))))
|
|
|
|
;; Read a line from port P.
|
|
(define (read-line . p)
|
|
(let loop ((acc '()))
|
|
(let ((c (apply peek-char p)))
|
|
(cond
|
|
((eof-object? c)
|
|
(if (null? acc)
|
|
c ;; #eof
|
|
(list->string-reversed acc)))
|
|
((char=? c #\newline)
|
|
(apply read-char p)
|
|
(list->string-reversed acc))
|
|
(else
|
|
(apply read-char p)
|
|
(loop (cons c acc)))))))
|
|
|
|
;; Read everything from port P.
|
|
(define (read-all . p)
|
|
(let loop ((acc (open-output-string)))
|
|
(let ((c (apply peek-char p)))
|
|
(cond
|
|
((eof-object? c) (get-output-string acc))
|
|
(else
|
|
(write-char (apply read-char p) acc)
|
|
(loop acc))))))
|
|
|
|
;;
|
|
;; Windows support.
|
|
;;
|
|
|
|
;; Like call-with-input-file but opens the file in 'binary' mode.
|
|
(define (call-with-binary-input-file filename proc)
|
|
(letfd ((fd (open filename (logior O_RDONLY O_BINARY))))
|
|
(proc (fdopen fd "rb"))))
|
|
|
|
;; Like call-with-output-file but opens the file in 'binary' mode.
|
|
(define (call-with-binary-output-file filename proc)
|
|
(letfd ((fd (open filename (logior O_WRONLY O_CREAT O_BINARY) #o600)))
|
|
(proc (fdopen fd "wb"))))
|
|
|
|
;;
|
|
;; Libc functions.
|
|
;;
|
|
|
|
;; Change the read/write offset.
|
|
(ffi-define (seek fd offset whence))
|
|
|
|
;; Constants for WHENCE.
|
|
(ffi-define SEEK_SET)
|
|
(ffi-define SEEK_CUR)
|
|
(ffi-define SEEK_END)
|
|
|
|
;; Get our process id.
|
|
(ffi-define (getpid))
|
|
|
|
;; Copy data from file descriptor SOURCE to every file descriptor in
|
|
;; SINKS.
|
|
(ffi-define (splice source . sinks))
|
|
|
|
;;
|
|
;; Random numbers.
|
|
;;
|
|
|
|
;; Seed the random number generator.
|
|
(ffi-define (srandom seed))
|
|
|
|
;; Get a pseudo-random number between 0 (inclusive) and SCALE
|
|
;; (exclusive).
|
|
(ffi-define (random scale))
|
|
|
|
;; Create a string of the given SIZE containing pseudo-random data.
|
|
(ffi-define (make-random-string size))
|