diff --git a/tests/gpgscm/ffi-private.h b/tests/gpgscm/ffi-private.h index 5467dac60..849d1b7e9 100644 --- a/tests/gpgscm/ffi-private.h +++ b/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) \ diff --git a/tests/gpgscm/ffi.c b/tests/gpgscm/ffi.c index babf1e1b0..fe418fc91 100644 --- a/tests/gpgscm/ffi.c +++ b/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); diff --git a/tests/gpgscm/ffi.scm b/tests/gpgscm/ffi.scm index d0b8a9937..7c2f93aba 100644 --- a/tests/gpgscm/ffi.scm +++ b/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)) diff --git a/tests/gpgscm/lib.scm b/tests/gpgscm/lib.scm index 871cc8f5c..48f53ea2f 100644 --- a/tests/gpgscm/lib.scm +++ b/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) - (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 ((length (string-length haystack))) + (define (split acc delimiter offset n) + (if (>= offset length) + (reverse acc) + (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 ((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))))))