gpg: Extend --quick-gen-key for creating keys from a card.
[gnupg.git] / tests / gpgscm / lib.scm
index 871cc8f..258f692 100644 (file)
 ;; 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))))
+  (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))
+
+;; Trace displays and returns the given value.  A debugging aid.
+(define (trace x)
+  (display x)
+  (newline)
+  x)
+
+;; Stringification.
+(define (stringify expression)
+  (let ((p (open-output-string)))
+    (write expression p)
+    (get-output-string p)))
 
 (define (filter pred lst)
   (cond ((null? lst) '())
         ((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-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)))
+;; 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)
-  (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))
+  (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.  For example (string-ltrim char-whitespace? "  foo") =>
-;; "foo".
+;; true.
 (define (string-ltrim predicate s)
-  (let loop ((s' (string->list s)))
-    (if (predicate (car s'))
-       (loop (cdr s'))
-       (list->string 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)
-  (let loop ((s' (reverse (string->list s))))
-    (if (predicate (car s'))
-       (loop (cdr s'))
-       (list->string (reverse 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     ")))
 
-(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)))
+;; Check if needle is contained in haystack.
+(ffi-define (string-contains? haystack needle))
+(assert (string-contains? "Hallo" "llo"))
+(assert (not (string-contains? "Hallo" "olla")))
 
-(define (echo . msg)
-  (for-each (lambda (x) (display x) (display " ")) msg)
-  (newline))
+;; Translate characters.
+(define (string-translate s from to)
+  (list->string (map (lambda (c)
+                      (let ((i (string-index from c)))
+                        (if i (string-ref to i) c))) (string->list s))))
+(assert (equal? (string-translate "foo/bar" "/" ".") "foo.bar"))
 
 ;; Read a word from port P.
 (define (read-word . p)
         (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)
-  (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))))))))
+  (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)
-  (list->string
-   (let f ()
-     (let ((c (apply peek-char p)))
-       (cond
-       ((eof-object? c) '())
-       (else (apply read-char p)
-        (cons c (f))))))))
+  (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))