gpgscm: Improve library functions.

* tests/gpgscm/tests.scm (absolute-path?): New function.
(canonical-path): Use the new function.
* tests/gpgscm/lib.scm (string-split-pln): New function.
(string-indexp, string-splitp): Likewise.
(string-splitn): Express using the above function.
(string-ltrim, string-rtrim): Fix corner case.
(list->string-reversed): New function.
(read-line): Fix performance.

Signed-off-by: Justus Winter <justus@g10code.com>

2 files changed, 88 insertions, 34 deletions

diff --git a/tests/gpgscm/lib.scm b/tests/gpgscm/lib.scm
index 4e19eae60..fabbef8a4 100644
--- a/tests/gpgscm/lib.scm
+++ b/tests/gpgscm/lib.scm
@@ -86,18 +86,47 @@
 (assert (equal? #f (string-rindex "Hallo" #\a 2)))
 (assert (equal? #f (string-rindex "Hallo" #\.)))
 
-;; Split haystack at delimiter at most n times.
-(define (string-splitn haystack delimiter n)
+;; 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 delimiter offset n)
+    (define (split acc offset n)
       (if (>= offset length)
 	  (reverse acc)
-	  (let ((i (string-index haystack delimiter offset)))
+	  (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)
-		       delimiter (+ i 1) (- n 1))))))
-    (split '() delimiter 0 n)))
+		       (+ 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))))
@@ -122,25 +151,32 @@
 ;; Trim the prefix of S containing only characters that make PREDICATE
 ;; 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 	")))
 
 ;; Check if needle is contained in haystack.
@@ -162,19 +198,34 @@
 	 (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)
diff --git a/tests/gpgscm/tests.scm b/tests/gpgscm/tests.scm
index bec19223d..d360272fd 100644
--- a/tests/gpgscm/tests.scm
+++ b/tests/gpgscm/tests.scm
@@ -186,16 +186,19 @@
 (assert (string=? (path-join "foo" "bar" "baz") "foo/bar/baz"))
 (assert (string=? (path-join "" "bar" "baz") "bar/baz"))
 
+;; Is PATH an absolute path?
+(define (absolute-path? path)
+  (or (char=? #\/ (string-ref path 0))
+      (and *win32* (char=? #\\ (string-ref path 0)))
+      (and *win32*
+	   (char-alphabetic? (string-ref path 0))
+	   (char=? #\: (string-ref path 1))
+	   (or (char=? #\/ (string-ref path 2))
+	       (char=? #\\ (string-ref path 2))))))
+
+;; Make PATH absolute.
 (define (canonical-path path)
-  (if (or (char=? #\/ (string-ref path 0))
-	  (and *win32* (char=? #\\ (string-ref path 0)))
-	  (and *win32*
-	       (char-alphabetic? (string-ref path 0))
-	       (char=? #\: (string-ref path 1))
-	       (or (char=? #\/ (string-ref path 2))
-		   (char=? #\\ (string-ref path 2)))))
-      path
-      (path-join (getcwd) path)))
+  (if (absolute-path? path) path (path-join (getcwd) path)))
 
 (define (in-srcdir . names)
   (canonical-path (apply path-join (cons (getenv "srcdir") names))))