added pcre module for guile

2024-09-20 18:18:51 +03:00 · 2015-03-22 03:04:03 +08:00 · 2015-03-22 03:04:03 +08:00 · 6f215337b6
commit 6f215337b6
parent ffddef669d
1 changed files with 108 additions and 0 deletions
--- a/guile/pcre.scm
+++ 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)))))))