gpgscm: Use native string searching functions.

* tests/gpgscm/ffi-private.h: Handle character arguments.
* tests/gpgscm/ffi.c (do_string_index): New function.
(do_string_rindex): Likewise.
(do_string_contains): Likewise.
(ffi_init): Define new functions.
* tests/gpgscm/ffi.scm (ffi-define): New macro.
* tests/gpgscm/lib.scm (string-index): Use native function,
demonstrate behavior.
(string-rindex): Likewise.
(string-contains?): Likewise.
Demonstrate behavior of various other functions.
(read-all): Rework so that it can handle large files.

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

tests/gpgscm/ffi-private.h

@@ -33,6 +33,7 @@ int ffi_bool_value (scheme *sc, pointer p);
 
 #define CONVERSION_number(SC, X) (SC)->vptr->ivalue (X)
 #define CONVERSION_string(SC, X) (SC)->vptr->string_value (X)
+#define CONVERSION_character(SC, X) (SC)->vptr->charvalue (X)
 #define CONVERSION_list(SC, X)	(X)
 #define CONVERSION_bool(SC, X)	ffi_bool_value ((SC), (X))
 #define CONVERSION_path(SC, X)	(((SC)->vptr->is_string (X)	  \
@@ -41,6 +42,7 @@ int ffi_bool_value (scheme *sc, pointer p);
 
 #define IS_A_number(SC, X)	(SC)->vptr->is_number (X)
 #define IS_A_string(SC, X)	(SC)->vptr->is_string (X)
+#define IS_A_character(SC, X)	(SC)->vptr->is_character (X)
 #define IS_A_list(SC, X)	(SC)->vptr->is_list ((SC), X)
 #define IS_A_bool(SC, X)	((X) == (SC)->F || (X) == (SC)->T)
 #define IS_A_path(SC, X)	((SC)->vptr->is_string (X)	\

tests/gpgscm/ffi.c

@@ -939,6 +939,72 @@ do_splice (scheme *sc, pointer args)
   FFI_RETURN (sc);
 }
 
+static pointer
+do_string_index (scheme *sc, pointer args)
+{
+  FFI_PROLOG ();
+  char *haystack;
+  char needle;
+  ssize_t offset = 0;
+  char *position;
+  FFI_ARG_OR_RETURN (sc, char *, haystack, string, args);
+  FFI_ARG_OR_RETURN (sc, char, needle, character, args);
+  if (args != sc->NIL)
+    {
+      FFI_ARG_OR_RETURN (sc, ssize_t, offset, number, args);
+      if (offset < 0)
+        return ffi_sprintf (sc, "offset must be positive");
+      if (offset > strlen (haystack))
+        return ffi_sprintf (sc, "offset exceeds haystack");
+    }
+  FFI_ARGS_DONE_OR_RETURN (sc, args);
+
+  position = strchr (haystack+offset, needle);
+  if (position)
+    FFI_RETURN_INT (sc, position - haystack);
+  else
+    FFI_RETURN_POINTER (sc, sc->F);
+}
+
+static pointer
+do_string_rindex (scheme *sc, pointer args)
+{
+  FFI_PROLOG ();
+  char *haystack;
+  char needle;
+  ssize_t offset = 0;
+  char *position;
+  FFI_ARG_OR_RETURN (sc, char *, haystack, string, args);
+  FFI_ARG_OR_RETURN (sc, char, needle, character, args);
+  if (args != sc->NIL)
+    {
+      FFI_ARG_OR_RETURN (sc, ssize_t, offset, number, args);
+      if (offset < 0)
+        return ffi_sprintf (sc, "offset must be positive");
+      if (offset > strlen (haystack))
+        return ffi_sprintf (sc, "offset exceeds haystack");
+    }
+  FFI_ARGS_DONE_OR_RETURN (sc, args);
+
+  position = strrchr (haystack+offset, needle);
+  if (position)
+    FFI_RETURN_INT (sc, position - haystack);
+  else
+    FFI_RETURN_POINTER (sc, sc->F);
+}
+
+static pointer
+do_string_contains (scheme *sc, pointer args)
+{
+  FFI_PROLOG ();
+  char *haystack;
+  char *needle;
+  FFI_ARG_OR_RETURN (sc, char *, haystack, string, args);
+  FFI_ARG_OR_RETURN (sc, char *, needle, string, args);
+  FFI_ARGS_DONE_OR_RETURN (sc, args);
+  FFI_RETURN_POINTER (sc, strstr (haystack, needle) ? sc->T : sc->F);
+}
+
 
 gpg_error_t
 ffi_list2argv (scheme *sc, pointer list, char ***argv, size_t *len)
@@ -1134,6 +1200,9 @@ ffi_init (scheme *sc, const char *argv0, int argc, const char **argv)
   /* Test helper functions.  */
   ffi_define_function (sc, file_equal);
   ffi_define_function (sc, splice);
+  ffi_define_function (sc, string_index);
+  ffi_define_function (sc, string_rindex);
+  ffi_define_function_name (sc, "string-contains?", string_contains);
 
   /* User interface.  */
   ffi_define_function (sc, flush_stdio);

tests/gpgscm/ffi.scm

@@ -38,3 +38,7 @@
     (write (cons (string->symbol name) args) args')
     (throw (string-append
 	    (get-output-string args') ": " message))))
+
+;; Pseudo-definitions for foreign functions.  Evaluates to no code,
+;; but serves as documentation.
+(macro (ffi-define form))

tests/gpgscm/lib.scm

@@ -55,48 +55,50 @@
 				   (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 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.
-(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 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 delimiter at most n times.
 (define (string-splitn haystack delimiter n)
-  (define (split acc haystack delimiter n)
-    (if (= (string-length haystack) 0)
+  (let ((length (string-length haystack)))
+    (define (split acc delimiter offset n)
+      (if (>= offset length)
 	  (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))
+	  (let ((i (string-index haystack delimiter 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)))
+(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" #\:))))
 
 ;; 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'))))
+(assert (string=? "foo" (string-ltrim char-whitespace? "  foo")))
 
 ;; Trim the suffix of S containing only characters that make PREDICATE
 ;; true.
@@ -105,20 +107,18 @@
     (if (predicate (car s'))
 	(loop (cdr s'))
 	(list->string (reverse s')))))
+(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=? "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)
@@ -154,10 +154,10 @@
 
 ;; Read everything from port P.
 (define (read-all . p)
-  (list->string
-   (let f ()
+  (let loop ((acc (open-output-string)))
     (let ((c (apply peek-char p)))
       (cond
-	((eof-object? c) '())
-	(else (apply read-char p)
-	 (cons c (f))))))))
+       ((eof-object? c) (get-output-string acc))
+       (else
+	(write-char (apply read-char p) acc)
+	(loop acc))))))