diff --git a/guile/pcre.scm b/guile/pcre.scm new file mode 100644 index 00000000..a845b5d1 --- /dev/null +++ b/guile/pcre.scm @@ -0,0 +1,108 @@ +(use-modules (rnrs) + (system foreign)) + +(define (make-blob-pointer len) + (bytevector->pointer (make-bytevector len))) + +(define pcre-ffi (dynamic-link "libpcre")) + +(define %pcre-compile2 + (pointer->procedure '* + (dynamic-func "pcre_compile2" pcre-ffi) + (list '* int '* '* '* '*))) + +(define %pcre-compile + (pointer->procedure '* + (dynamic-func "pcre_compile" pcre-ffi) + (list '* int '* '* '*))) + +(define %pcre-exec + (pointer->procedure int + (dynamic-func "pcre_exec" pcre-ffi) + (list '* '* '* int int int '* int))) + +(define %pcre-study + (pointer->procedure '* + (dynamic-func "pcre_study" pcre-ffi) + (list '* int '*))) + +(define %pcre-get-substring + (pointer->procedure '* + (dynamic-func "pcre_get_substring" pcre-ffi) + (list '* '* int int '*))) + +(define %pcre-free-study + (pointer->procedure void + (dynamic-func "pcre_free_study" pcre-ffi) + (list '*))) + +(define %pcre-free-substring + (pointer->procedure void + (dynamic-func "pcre_free_substring" pcre-ffi) + (list '*))) + +(define-record-type pcre + (fields + errptr + (mutable strptr) + (mutable ovector) + (mutable matched) + (mutable code) + (mutable extra))) + +(define (%new-pcre) + (make-pcre (make-blob-pointer uint64) ; errptr + #f #f 0 #f #f)) + +(define* (new-pcre re #:optional (options 0)) + (let ((reptr (string->pointer re)) + ;;(errcodeptr (make-blob-pointer int)) + (erroffset (make-blob-pointer int)) + (tableptr %null-pointer) + (pcre (%new-pcre))) + ;; FIXME: add exceptional handling + (pcre-code-set! pcre + (%pcre-compile reptr options (pcre-errptr pcre) + erroffset tableptr)) + pcre)) + +(define* (pcre-match pcre str #:key (study-options 0) (exec-options 0) + (ovecsize 30) (offset 0)) + (let ((extra (%pcre-study (pcre-code pcre) study-options (pcre-errptr pcre))) + (strptr (string->pointer str)) + (ovector (make-blob-pointer (* int ovecsize)))) + (pcre-matched-set! pcre + (%pcre-exec (pcre-code pcre) + extra + strptr + (string-length str) + offset + exec-options + ovector + ovecsize)) + (pcre-ovector-set! pcre ovector) + (pcre-strptr-set! pcre strptr) + (%pcre-free-study extra) + pcre)) + +(define (pcre-get-substring pcre index) + (let ((strptr (pcre-strptr pcre)) + (ovector (pcre-ovector pcre)) + (matched (pcre-matched pcre)) + (buf (make-blob-pointer uint64))) + (%pcre-get-substring strptr ovector matched index buf) + (let ((ret (pointer->string (dereference-pointer buf)))) + (%pcre-free-substring (dereference-pointer buf)) + ret))) + +(define* (pcre-search pcre str #:key (study-options 0) (exec-options 0) + (trim string-trim-both)) + (define len (string-length str)) + (let lp((i 0) (ret '())) + (cond + ((>= i len) (reverse ret)) + (else + (pcre-match pcre str #:study-options study-options #:exec-options exec-options #:offset i) + (let* ((sub (pcre-get-substring pcre 0)) + (sublen (string-length sub))) + (lp (+ i sublen) (cons (trim sub) ret)))))))