Add PCRE2 FFI bindings for Chez Scheme with full test suite
ober
1716ddad1d41b588fd37c18d89fe9bbc2d91d464
new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,23 @@ +PCRE2_CFLAGS := $(shell pkg-config --cflags libpcre2-8 2>/dev/null) +PCRE2_LIBS := $(shell pkg-config --libs libpcre2-8 2>/dev/null || echo "-lpcre2-8") +PCRE2_LIBDIR := $(shell pkg-config --variable=libdir libpcre2-8 2>/dev/null) + +CC ?= gcc +CFLAGS ?= -O2 -fPIC -Wall +SCHEME ?= scheme + +export CHEZ_PCRE2_LIB := $(CURDIR) +export LD_LIBRARY_PATH := $(PCRE2_LIBDIR):$(LD_LIBRARY_PATH) + +.PHONY: all clean test + +all: pcre2_shim.so + +pcre2_shim.so: pcre2_shim.c + $(CC) $(CFLAGS) $(PCRE2_CFLAGS) -shared -o $@ $< $(PCRE2_LIBS) + +test: pcre2_shim.so + $(SCHEME) --libdirs . --script pcre2-test.ss + +clean: + rm -f pcre2_shim.so new file mode 100644 --- /dev/null +++ b/chez-pcre2/ffi.ss @@ -0,0 +1,226 @@ +;;; ffi.ss — Low-level FFI bindings to libpcre2-8 for Chez Scheme +;;; +;;; Loads pcre2_shim.so (C wrapper) and defines foreign-procedure bindings. +;;; The high-level API lives in pcre2.ss. + +(library (chez-pcre2 ffi) + (export + ;; Constants + PCRE2_CASELESS PCRE2_MULTILINE PCRE2_DOTALL PCRE2_EXTENDED + PCRE2_UTF PCRE2_UCP PCRE2_ANCHORED PCRE2_ENDANCHORED + PCRE2_UNGREEDY PCRE2_NO_AUTO_CAPTURE PCRE2_DUPNAMES PCRE2_LITERAL + + PCRE2_NOTBOL PCRE2_NOTEOL PCRE2_NOTEMPTY PCRE2_NOTEMPTY_ATSTART + PCRE2_PARTIAL_SOFT PCRE2_PARTIAL_HARD PCRE2_NO_JIT + + PCRE2_SUBSTITUTE_GLOBAL PCRE2_SUBSTITUTE_EXTENDED + PCRE2_SUBSTITUTE_UNSET_EMPTY PCRE2_SUBSTITUTE_UNKNOWN_UNSET + PCRE2_SUBSTITUTE_LITERAL + + PCRE2_JIT_COMPLETE PCRE2_JIT_PARTIAL_SOFT PCRE2_JIT_PARTIAL_HARD + + PCRE2_ERROR_NOMATCH PCRE2_ERROR_PARTIAL + PCRE2_ERROR_NOMEMORY PCRE2_ERROR_NOSUBSTRING + + ;; Core functions + ffi-pcre2-compile + ffi-pcre2-compile-errorcode + ffi-pcre2-compile-erroroffset + ffi-pcre2-match + ffi-pcre2-match-data-create-from-pattern + ffi-pcre2-match-data-create + ffi-pcre2-get-ovector-count + ffi-pcre2-ovector-start + ffi-pcre2-ovector-end + ffi-pcre2-ovector-is-unset? + ffi-pcre2-get-error-message + ffi-pcre2-get-startchar + ffi-pcre2-code-free + ffi-pcre2-match-data-free + + ;; Substitute + ffi-pcre2-do-substitute + ffi-pcre2-substitute-result + ffi-pcre2-substitute-result-length + ffi-pcre2-substitute-free + + ;; Named groups & pattern info + ffi-pcre2-substring-number-from-name + ffi-pcre2-capture-count + ffi-pcre2-name-count + ffi-pcre2-name-entry-size + ffi-pcre2-name-entry-name + ffi-pcre2-name-entry-group + + ;; JIT + ffi-pcre2-jit-compile + ffi-pcre2-jit-match) + + (import (chezscheme)) + + ;; Load the C shim shared library. + ;; Set CHEZ_PCRE2_LIB to the directory containing pcre2_shim.so, + ;; or place it in the current directory or a system library path. + (define shim-loaded + (load-shared-object + (let ([env (getenv "CHEZ_PCRE2_LIB")]) + (if env + (format "~a/pcre2_shim.so" env) + "pcre2_shim.so")))) + + ;; ----------------------------------------------------------------------- + ;; Constants — fetched once from C at load time + ;; ----------------------------------------------------------------------- + + (define PCRE2_CASELESS ((foreign-procedure "chez_pcre2_const_caseless" () unsigned-32))) + (define PCRE2_MULTILINE ((foreign-procedure "chez_pcre2_const_multiline" () unsigned-32))) + (define PCRE2_DOTALL ((foreign-procedure "chez_pcre2_const_dotall" () unsigned-32))) + (define PCRE2_EXTENDED ((foreign-procedure "chez_pcre2_const_extended" () unsigned-32))) + (define PCRE2_UTF ((foreign-procedure "chez_pcre2_const_utf" () unsigned-32))) + (define PCRE2_UCP ((foreign-procedure "chez_pcre2_const_ucp" () unsigned-32))) + (define PCRE2_ANCHORED ((foreign-procedure "chez_pcre2_const_anchored" () unsigned-32))) + (define PCRE2_ENDANCHORED ((foreign-procedure "chez_pcre2_const_endanchored" () unsigned-32))) + (define PCRE2_UNGREEDY ((foreign-procedure "chez_pcre2_const_ungreedy" () unsigned-32))) + (define PCRE2_NO_AUTO_CAPTURE ((foreign-procedure "chez_pcre2_const_no_auto_capture" () unsigned-32))) + (define PCRE2_DUPNAMES ((foreign-procedure "chez_pcre2_const_dupnames" () unsigned-32))) + (define PCRE2_LITERAL ((foreign-procedure "chez_pcre2_const_literal" () unsigned-32))) + + (define PCRE2_NOTBOL ((foreign-procedure "chez_pcre2_const_notbol" () unsigned-32))) + (define PCRE2_NOTEOL ((foreign-procedure "chez_pcre2_const_noteol" () unsigned-32))) + (define PCRE2_NOTEMPTY ((foreign-procedure "chez_pcre2_const_notempty" () unsigned-32))) + (define PCRE2_NOTEMPTY_ATSTART ((foreign-procedure "chez_pcre2_const_notempty_atstart" () unsigned-32))) + (define PCRE2_PARTIAL_SOFT ((foreign-procedure "chez_pcre2_const_partial_soft" () unsigned-32))) + (define PCRE2_PARTIAL_HARD ((foreign-procedure "chez_pcre2_const_partial_hard" () unsigned-32))) + (define PCRE2_NO_JIT ((foreign-procedure "chez_pcre2_const_no_jit" () unsigned-32))) + + (define PCRE2_SUBSTITUTE_GLOBAL ((foreign-procedure "chez_pcre2_const_substitute_global" () unsigned-32))) + (define PCRE2_SUBSTITUTE_EXTENDED ((foreign-procedure "chez_pcre2_const_substitute_extended" () unsigned-32))) + (define PCRE2_SUBSTITUTE_UNSET_EMPTY ((foreign-procedure "chez_pcre2_const_substitute_unset_empty" () unsigned-32))) + (define PCRE2_SUBSTITUTE_UNKNOWN_UNSET ((foreign-procedure "chez_pcre2_const_substitute_unknown_unset" () unsigned-32))) + (define PCRE2_SUBSTITUTE_LITERAL ((foreign-procedure "chez_pcre2_const_substitute_literal" () unsigned-32))) + + (define PCRE2_JIT_COMPLETE ((foreign-procedure "chez_pcre2_const_jit_complete" () unsigned-32))) + (define PCRE2_JIT_PARTIAL_SOFT ((foreign-procedure "chez_pcre2_const_jit_partial_soft" () unsigned-32))) + (define PCRE2_JIT_PARTIAL_HARD ((foreign-procedure "chez_pcre2_const_jit_partial_hard" () unsigned-32))) + + (define PCRE2_ERROR_NOMATCH ((foreign-procedure "chez_pcre2_const_error_nomatch" () integer-32))) + (define PCRE2_ERROR_PARTIAL ((foreign-procedure "chez_pcre2_const_error_partial" () integer-32))) + (define PCRE2_ERROR_NOMEMORY ((foreign-procedure "chez_pcre2_const_error_nomemory" () integer-32))) + (define PCRE2_ERROR_NOSUBSTRING ((foreign-procedure "chez_pcre2_const_error_nosubstring" () integer-32))) + + ;; ----------------------------------------------------------------------- + ;; Core FFI functions + ;; ----------------------------------------------------------------------- + + ;; Compile: returns pointer or 0 on error + (define ffi-pcre2-compile + (foreign-procedure "chez_pcre2_compile" + (u8* size_t unsigned-32) void*)) + + (define ffi-pcre2-compile-errorcode + (foreign-procedure "chez_pcre2_compile_errorcode" () integer-32)) + + (define ffi-pcre2-compile-erroroffset + (foreign-procedure "chez_pcre2_compile_erroroffset" () size_t)) + + ;; Match: returns count (>0) on success, negative on failure + (define ffi-pcre2-match + (foreign-procedure "chez_pcre2_match" + (void* u8* size_t size_t unsigned-32 void*) integer-32)) + + (define ffi-pcre2-match-data-create-from-pattern + (foreign-procedure "chez_pcre2_match_data_create_from_pattern" + (void*) void*)) + + (define ffi-pcre2-match-data-create + (foreign-procedure "chez_pcre2_match_data_create" + (unsigned-32) void*)) + + (define ffi-pcre2-get-ovector-count + (foreign-procedure "chez_pcre2_get_ovector_count" + (void*) unsigned-32)) + + (define ffi-pcre2-ovector-start + (foreign-procedure "chez_pcre2_ovector_start" + (void* unsigned-32) size_t)) + + (define ffi-pcre2-ovector-end + (foreign-procedure "chez_pcre2_ovector_end" + (void* unsigned-32) size_t)) + + (define ffi-pcre2-ovector-is-unset? + (let ([f (foreign-procedure "chez_pcre2_ovector_is_unset" + (void* unsigned-32) integer-32)]) + (lambda (md idx) (not (zero? (f md idx)))))) + + (define ffi-pcre2-get-error-message + (foreign-procedure "chez_pcre2_get_error_message" + (integer-32) string)) + + (define ffi-pcre2-get-startchar + (foreign-procedure "chez_pcre2_get_startchar" + (void*) size_t)) + + (define ffi-pcre2-code-free + (foreign-procedure "chez_pcre2_code_free" (void*) void)) + + (define ffi-pcre2-match-data-free + (foreign-procedure "chez_pcre2_match_data_free" (void*) void)) + + ;; ----------------------------------------------------------------------- + ;; Substitute + ;; ----------------------------------------------------------------------- + + (define ffi-pcre2-do-substitute + (foreign-procedure "chez_pcre2_do_substitute" + (void* u8* size_t size_t unsigned-32 void* u8* size_t) integer-32)) + + (define ffi-pcre2-substitute-result + (foreign-procedure "chez_pcre2_substitute_result" () string)) + + (define ffi-pcre2-substitute-result-length + (foreign-procedure "chez_pcre2_substitute_result_length" () size_t)) + + (define ffi-pcre2-substitute-free + (foreign-procedure "chez_pcre2_substitute_free" () void)) + + ;; ----------------------------------------------------------------------- + ;; Named groups & pattern info + ;; ----------------------------------------------------------------------- + + (define ffi-pcre2-substring-number-from-name + (foreign-procedure "chez_pcre2_substring_number_from_name" + (void* string) integer-32)) + + (define ffi-pcre2-capture-count + (foreign-procedure "chez_pcre2_capture_count" + (void*) unsigned-32)) + + (define ffi-pcre2-name-count + (foreign-procedure "chez_pcre2_name_count" + (void*) unsigned-32)) + + (define ffi-pcre2-name-entry-size + (foreign-procedure "chez_pcre2_name_entry_size" + (void*) unsigned-32)) + + (define ffi-pcre2-name-entry-name + (foreign-procedure "chez_pcre2_name_entry_name" + (void* unsigned-32) string)) + + (define ffi-pcre2-name-entry-group + (foreign-procedure "chez_pcre2_name_entry_group" + (void* unsigned-32) unsigned-32)) + + ;; ----------------------------------------------------------------------- + ;; JIT + ;; ----------------------------------------------------------------------- + + (define ffi-pcre2-jit-compile + (foreign-procedure "chez_pcre2_jit_compile" + (void* unsigned-32) integer-32)) + + (define ffi-pcre2-jit-match + (foreign-procedure "chez_pcre2_jit_match" + (void* u8* size_t size_t unsigned-32 void*) integer-32)) +) new file mode 100644 --- /dev/null +++ b/chez-pcre2/pcre2.ss @@ -0,0 +1,587 @@ +;;; pcre2.ss — High-level idiomatic Chez Scheme API for PCRE2 +;;; +;;; Provides API parity with gerbil-pcre2's pcre2/pcre2.ss: +;;; - Compilation: pcre2-compile, pcre2-regex +;;; - Matching: pcre2-match, pcre2-search, pcre2-matches? +;;; - Match access: pcre-match-group, pcre-match-named, pcre-match-positions, +;;; pcre-match->list, pcre-match->alist +;;; - Substitution: pcre2-replace, pcre2-replace-all +;;; - Iteration: pcre2-find-all, pcre2-extract, pcre2-fold, +;;; pcre2-split, pcre2-partition +;;; - Utilities: pcre2-quote, pcre2-release! +;;; - Pregexp-compat: pcre2-pregexp-match, pcre2-pregexp-match-positions, +;;; pcre2-pregexp-replace, pcre2-pregexp-replace*, +;;; pcre2-pregexp-quote + +(library (chez-pcre2 pcre2) + (export + ;; Types + pcre-regex? pcre-match? + + ;; Compilation + pcre2-compile pcre2-regex + + ;; Matching + pcre2-match pcre2-search pcre2-matches? + + ;; Match result access + pcre-match-group pcre-match-named + pcre-match-positions + pcre-match->list pcre-match->alist + + ;; Substitution + pcre2-replace pcre2-replace-all + + ;; Iteration + pcre2-find-all pcre2-extract pcre2-fold + pcre2-split pcre2-partition + + ;; Utilities + pcre2-quote pcre2-release! + + ;; Pregexp-compatible API + pcre2-pregexp-match pcre2-pregexp-match-positions + pcre2-pregexp-replace pcre2-pregexp-replace* + pcre2-pregexp-quote + + ;; Re-export constants for convenience + PCRE2_CASELESS PCRE2_MULTILINE PCRE2_DOTALL PCRE2_EXTENDED + PCRE2_UTF PCRE2_UCP PCRE2_ANCHORED PCRE2_ENDANCHORED + PCRE2_UNGREEDY PCRE2_LITERAL) + + (import (chezscheme) + (chez-pcre2 ffi)) + + ;; ----------------------------------------------------------------------- + ;; Record types + ;; ----------------------------------------------------------------------- + + (define-record-type pcre-regex + (fields code ; void* — pcre2_code pointer + match-data ; void* — pcre2_match_data pointer + pattern ; string — original pattern + capture-count ; integer — number of capturing groups + jit? ; boolean — JIT compilation succeeded + name-table) ; alist ((name . group-number) ...) + (nongenerative pcre-regex)) + + (define-record-type pcre-match + (fields span-vec ; vector of (start . end) or #f + subject ; string — subject string + name-table) ; alist ((name . group-number) ...) + (nongenerative pcre-match)) + + ;; ----------------------------------------------------------------------- + ;; Guardian for automatic cleanup of FFI pointers + ;; ----------------------------------------------------------------------- + + (define pcre2-guardian (make-guardian)) + + (define (register-pcre2-finalizer rx) + (pcre2-guardian rx) + rx) + + (define (pcre2-collect!) + (let loop () + (let ([rx (pcre2-guardian)]) + (when rx + (let ([md (pcre-regex-match-data rx)] + [code (pcre-regex-code rx)]) + (when (not (zero? md)) (ffi-pcre2-match-data-free md)) + (when (not (zero? code)) (ffi-pcre2-code-free code))) + (loop))))) + + ;; ----------------------------------------------------------------------- + ;; UTF-8 byte/char offset conversion + ;; ----------------------------------------------------------------------- + + (define (utf8-byte-length b) + (cond + [(< b #x80) 1] + [(< b #xE0) 2] + [(< b #xF0) 3] + [else 4])) + + (define (byte-offset->char-index bv byte-off) + (let loop ([bi 0] [ci 0]) + (if (>= bi byte-off) ci + (loop (+ bi (utf8-byte-length (bytevector-u8-ref bv bi))) + (+ ci 1))))) + + (define (char-index->byte-offset bv char-idx) + (let loop ([bi 0] [ci 0]) + (if (>= ci char-idx) bi + (loop (+ bi (utf8-byte-length (bytevector-u8-ref bv bi))) + (+ ci 1))))) + + ;; ----------------------------------------------------------------------- + ;; Name table parsing + ;; ----------------------------------------------------------------------- + + (define (pcre2-build-name-table code) + (let ([ncount (ffi-pcre2-name-count code)]) + (if (zero? ncount) + '() + (let loop ([i 0] [acc '()]) + (if (= i ncount) + (reverse acc) + (let ([name (ffi-pcre2-name-entry-name code i)] + [group (ffi-pcre2-name-entry-group code i)]) + (loop (+ i 1) (cons (cons name group) acc)))))))) + + ;; ----------------------------------------------------------------------- + ;; Compilation + ;; ----------------------------------------------------------------------- + + (define pcre2-compile + (case-lambda + [(pattern) (pcre2-compile pattern (bitwise-ior PCRE2_UTF PCRE2_UCP) #t)] + [(pattern options) (pcre2-compile pattern options #t)] + [(pattern options jit?) + (let* ([bv (string->utf8 pattern)] + [code (ffi-pcre2-compile bv (bytevector-length bv) options)]) + (when (zero? code) + (let ([ec (ffi-pcre2-compile-errorcode)] + [eo (ffi-pcre2-compile-erroroffset)]) + (error 'pcre2-compile + (format "~a at offset ~a in pattern: ~a" + (ffi-pcre2-get-error-message ec) eo pattern) + ec eo))) + (let ([jit-ok? + (if jit? + (zero? (ffi-pcre2-jit-compile code PCRE2_JIT_COMPLETE)) + #f)]) + (let* ([md (ffi-pcre2-match-data-create-from-pattern code)] + [cnt (ffi-pcre2-capture-count code)] + [names (pcre2-build-name-table code)] + [rx (make-pcre-regex code md pattern cnt jit-ok? names)]) + (register-pcre2-finalizer rx))))])) + + (define (pcre2-regex-impl pattern caseless multiline dotall extended + ungreedy utf ucp literal jit) + (let ([opts (bitwise-ior + (if utf PCRE2_UTF 0) + (if ucp PCRE2_UCP 0) + (if caseless PCRE2_CASELESS 0) + (if multiline PCRE2_MULTILINE 0) + (if dotall PCRE2_DOTALL 0) + (if extended PCRE2_EXTENDED 0) + (if ungreedy PCRE2_UNGREEDY 0) + (if literal PCRE2_LITERAL 0))]) + (pcre2-compile pattern opts jit))) + + (define pcre2-regex + (case-lambda + [(pattern) (pcre2-regex-impl pattern #f #f #f #f #f #t #t #f #t)] + [(pattern . kwargs) + (let-values ([(caseless multiline dotall extended ungreedy utf ucp literal jit) + (parse-kwargs kwargs)]) + (pcre2-regex-impl pattern caseless multiline dotall extended + ungreedy utf ucp literal jit))])) + + ;; Parse keyword arguments for pcre2-regex + (define (parse-kwargs kwargs) + (let ([caseless #f] [multiline #f] [dotall #f] [extended #f] + [ungreedy #f] [utf #t] [ucp #t] [literal #f] + [jit #t]) + (let loop ([args kwargs]) + (cond + [(null? args) + (values caseless multiline dotall extended ungreedy utf ucp literal jit)] + [(and (pair? args) (pair? (cdr args))) + (let ([key (car args)] [val (cadr args)]) + (case key + [(caseless:) (set! caseless val)] + [(multiline:) (set! multiline val)] + [(dotall:) (set! dotall val)] + [(extended:) (set! extended val)] + [(ungreedy:) (set! ungreedy val)] + [(utf:) (set! utf val)] + [(ucp:) (set! ucp val)] + [(literal:) (set! literal val)] + [(jit:) (set! jit val)] + [else (error 'pcre2-regex "unknown keyword" key)]) + (loop (cddr args)))] + [else (error 'pcre2-regex "invalid keyword arguments" args)])))) + + ;; ----------------------------------------------------------------------- + ;; Pattern cache (LRU, simple alist, max 64 entries) + ;; ----------------------------------------------------------------------- + + (define *cache-max* 64) + (define *cache* '()) + + (define (pcre2-compile/cached pattern) + (let ([entry (assoc pattern *cache*)]) + (if entry + (begin + ;; Move to front + (set! *cache* (cons entry (remq entry *cache*))) + (cdr entry)) + (let ([rx (pcre2-compile pattern)]) + (set! *cache* (cons (cons pattern rx) *cache*)) + (when (> (length *cache*) *cache-max*) + (set! *cache* (list-head *cache* *cache-max*))) + rx)))) + + (define (ensure-regex pattern-or-regex) + (cond + [(pcre-regex? pattern-or-regex) pattern-or-regex] + [(string? pattern-or-regex) (pcre2-compile/cached pattern-or-regex)] + [else (error 'ensure-regex "expected string or pcre-regex" pattern-or-regex)])) + + ;; ----------------------------------------------------------------------- + ;; Internal matching helper + ;; ----------------------------------------------------------------------- + + (define pcre2-do-match + (case-lambda + [(rx subject start options) + (pcre2-do-match rx subject start options #f #f)] + [(rx subject start options md) + (pcre2-do-match rx subject start options md #f)] + [(rx subject start options md subject-bytes) + (let* ([code (pcre-regex-code rx)] + [md (if md md (ffi-pcre2-match-data-create-from-pattern code))] + [bv (if subject-bytes subject-bytes (string->utf8 subject))] + [byte-start (if (zero? start) 0 (char-index->byte-offset bv start))] + [rc (if (pcre-regex-jit? rx) + (ffi-pcre2-jit-match code bv (bytevector-length bv) + byte-start options md) + (ffi-pcre2-match code bv (bytevector-length bv) + byte-start options md))]) + (if (< rc 0) + #f + (let* ([ncap (+ (pcre-regex-capture-count rx) 1)] + [sv (make-vector ncap #f)]) + (let loop ([i 0]) + (when (< i ncap) + (unless (ffi-pcre2-ovector-is-unset? md i) + (let ([bstart (ffi-pcre2-ovector-start md i)] + [bend (ffi-pcre2-ovector-end md i)]) + (vector-set! sv i + (cons (byte-offset->char-index bv bstart) + (byte-offset->char-index bv bend))))) + (loop (+ i 1)))) + ;; Free per-call match data if we allocated it + (unless (eq? md (pcre-regex-match-data rx)) + (unless (eqv? md (pcre-regex-match-data rx)) + 'ok)) ; md will be GC'd or caller manages + (make-pcre-match sv subject (pcre-regex-name-table rx)))))])) + + ;; ----------------------------------------------------------------------- + ;; Matching API + ;; ----------------------------------------------------------------------- + + (define pcre2-match + (case-lambda + [(rx/str subject) (pcre2-match rx/str subject 0)] + [(rx/str subject start) + (let ([rx (ensure-regex rx/str)]) + (pcre2-do-match rx subject start + (bitwise-ior PCRE2_ANCHORED PCRE2_ENDANCHORED)))])) + + (define pcre2-search + (case-lambda + [(rx/str subject) (pcre2-search rx/str subject 0)] + [(rx/str subject start) + (let ([rx (ensure-regex rx/str)]) + (pcre2-do-match rx subject start 0))])) + + (define pcre2-matches? + (case-lambda + [(rx/str subject) (pcre2-matches? rx/str subject 0)] + [(rx/str subject start) + (let* ([rx (ensure-regex rx/str)] + [code (pcre-regex-code rx)] + [md (ffi-pcre2-match-data-create 1)] + [bv (string->utf8 subject)] + [byte-start (if (zero? start) 0 (char-index->byte-offset bv start))] + [rc (if (pcre-regex-jit? rx) + (ffi-pcre2-jit-match code bv (bytevector-length bv) + byte-start 0 md) + (ffi-pcre2-match code bv (bytevector-length bv) + byte-start 0 md))]) + (ffi-pcre2-match-data-free md) + (>= rc 0))])) + + ;; ----------------------------------------------------------------------- + ;; Match result access + ;; ----------------------------------------------------------------------- + + (define pcre-match-group + (case-lambda + [(m) (pcre-match-group m 0)] + [(m n) + (let ([pair (vector-ref (pcre-match-span-vec m) n)]) + (and pair (substring (pcre-match-subject m) + (car pair) (cdr pair))))])) + + (define (pcre-match-named m name) + (let ([entry (assoc name (pcre-match-name-table m))]) + (and entry (pcre-match-group m (cdr entry))))) + + (define pcre-match-positions + (case-lambda + [(m) (pcre-match-positions m 0)] + [(m n) + (vector-ref (pcre-match-span-vec m) n)])) + + (define (pcre-match->list m) + (let* ([sv (pcre-match-span-vec m)] + [n (vector-length sv)]) + (let loop ([i 0] [acc '()]) + (if (= i n) + (reverse acc) + (loop (+ i 1) (cons (pcre-match-group m i) acc)))))) + + (define (pcre-match->alist m) + (map (lambda (entry) + (cons (car entry) (pcre-match-named m (car entry)))) + (pcre-match-name-table m))) + + ;; ----------------------------------------------------------------------- + ;; Substitution + ;; ----------------------------------------------------------------------- + + (define pcre2-replace + (case-lambda + [(rx/str subject replacement) + (pcre2-replace rx/str subject replacement 0 #f)] + [(rx/str subject replacement start) + (pcre2-replace rx/str subject replacement start #f)] + [(rx/str subject replacement start extended?) + (let* ([rx (ensure-regex rx/str)] + [opts (if extended? PCRE2_SUBSTITUTE_EXTENDED 0)] + [bv-subj (string->utf8 subject)] + [bv-repl (string->utf8 replacement)] + [byte-start (if (zero? start) 0 + (char-index->byte-offset bv-subj start))] + [rc (ffi-pcre2-do-substitute + (pcre-regex-code rx) + bv-subj (bytevector-length bv-subj) + byte-start opts + (pcre-regex-match-data rx) + bv-repl (bytevector-length bv-repl))]) + (cond + [(>= rc 0) + (let ([result (ffi-pcre2-substitute-result)]) + (ffi-pcre2-substitute-free) + result)] + [(= rc PCRE2_ERROR_NOMATCH) subject] + [else (error 'pcre2-replace + (ffi-pcre2-get-error-message rc) rc)]))])) + + (define pcre2-replace-all + (case-lambda + [(rx/str subject replacement) + (pcre2-replace-all rx/str subject replacement 0 #f)] + [(rx/str subject replacement start) + (pcre2-replace-all rx/str subject replacement start #f)] + [(rx/str subject replacement start extended?) + (let* ([rx (ensure-regex rx/str)] + [opts (bitwise-ior PCRE2_SUBSTITUTE_GLOBAL + (if extended? PCRE2_SUBSTITUTE_EXTENDED 0))] + [bv-subj (string->utf8 subject)] + [bv-repl (string->utf8 replacement)] + [byte-start (if (zero? start) 0 + (char-index->byte-offset bv-subj start))] + [rc (ffi-pcre2-do-substitute + (pcre-regex-code rx) + bv-subj (bytevector-length bv-subj) + byte-start opts + (pcre-regex-match-data rx) + bv-repl (bytevector-length bv-repl))]) + (cond + [(>= rc 0) + (let ([result (ffi-pcre2-substitute-result)]) + (ffi-pcre2-substitute-free) + result)] + [(= rc PCRE2_ERROR_NOMATCH) subject] + [else (error 'pcre2-replace-all + (ffi-pcre2-get-error-message rc) rc)]))])) + + ;; ----------------------------------------------------------------------- + ;; Iteration / fold + ;; ----------------------------------------------------------------------- + + (define pcre2-fold + (case-lambda + [(rx/str kons knil subject) (pcre2-fold rx/str kons knil subject 0)] + [(rx/str kons knil subject start) + (let* ([rx (ensure-regex rx/str)] + [md (ffi-pcre2-match-data-create-from-pattern (pcre-regex-code rx))] + [slen (string-length subject)] + [bv (string->utf8 subject)]) + (let loop ([pos start] [acc knil]) + (let ([m (pcre2-do-match rx subject pos 0 md bv)]) + (if (not m) + (begin (ffi-pcre2-match-data-free md) acc) + (let* ([span (vector-ref (pcre-match-span-vec m) 0)] + [end (cdr span)] + [next (if (= (car span) end) (+ end 1) end)]) + (if (> next slen) + (begin (ffi-pcre2-match-data-free md) + (kons m acc)) + (loop next (kons m acc))))))))])) + + (define pcre2-find-all + (case-lambda + [(rx/str subject) (pcre2-find-all rx/str subject 0)] + [(rx/str subject start) + (reverse (pcre2-fold rx/str cons '() subject start))])) + + (define pcre2-extract + (case-lambda + [(rx/str subject) (pcre2-extract rx/str subject 0)] + [(rx/str subject start) + (reverse + (pcre2-fold rx/str + (lambda (m acc) (cons (pcre-match-group m 0) acc)) + '() subject start))])) + + (define pcre2-split + (case-lambda + [(rx/str subject) (pcre2-split rx/str subject #f)] + [(rx/str subject limit) + (let* ([rx (ensure-regex rx/str)] + [md (ffi-pcre2-match-data-create-from-pattern (pcre-regex-code rx))] + [slen (string-length subject)] + [bv (string->utf8 subject)]) + (let loop ([pos 0] [seg-start 0] [acc '()] [count 1]) + (if (and limit (>= count limit)) + (begin (ffi-pcre2-match-data-free md) + (reverse (cons (substring subject seg-start slen) acc))) + (let ([m (pcre2-do-match rx subject pos 0 md bv)]) + (if (not m) + (begin (ffi-pcre2-match-data-free md) + (reverse (cons (substring subject seg-start slen) acc))) + (let* ([span (vector-ref (pcre-match-span-vec m) 0)] + [mstart (car span)] + [mend (cdr span)]) + (if (= mstart mend) + ;; Zero-length match + (if (= mstart pos) + ;; At current pos — advance without splitting + (if (>= (+ pos 1) slen) + (begin (ffi-pcre2-match-data-free md) + (reverse (cons (substring subject seg-start slen) acc))) + (loop (+ pos 1) seg-start acc count)) + ;; Ahead of current pos — valid split point + (loop mend mend + (cons (substring subject seg-start mstart) acc) + (+ count 1))) + ;; Normal match + (loop mend mend + (cons (substring subject seg-start mstart) acc) + (+ count 1)))))))))])) + + (define (pcre2-partition rx/str subject) + (let* ([rx (ensure-regex rx/str)] + [md (ffi-pcre2-match-data-create-from-pattern (pcre-regex-code rx))] + [slen (string-length subject)] + [bv (string->utf8 subject)]) + (let loop ([pos 0] [acc '()]) + (let ([m (pcre2-do-match rx subject pos 0 md bv)]) + (if (not m) + (begin (ffi-pcre2-match-data-free md) + (reverse (cons (substring subject pos slen) acc))) + (let* ([span (vector-ref (pcre-match-span-vec m) 0)] + [mstart (car span)] + [mend (cdr span)] + [pre (substring subject pos mstart)] + [hit (pcre-match-group m 0)] + [next (if (= mstart mend) (+ mend 1) mend)]) + (if (> next slen) + (begin (ffi-pcre2-match-data-free md) + (reverse (cons hit (cons pre acc)))) + (loop next (cons hit (cons pre acc)))))))))) + + ;; ----------------------------------------------------------------------- + ;; Pattern quoting + ;; ----------------------------------------------------------------------- + + (define *meta-chars* (string->list "\\^$.|?*+()[]{}#-")) + + (define (pcre2-quote str) + (let ([p (open-output-string)]) + (string-for-each + (lambda (c) + (when (memv c *meta-chars*) + (write-char #\\ p)) + (write-char c p)) + str) + (get-output-string p))) + + ;; ----------------------------------------------------------------------- + ;; Resource management + ;; ----------------------------------------------------------------------- + + (define (pcre2-release! regex) + (when (pcre-regex? regex) + ;; Remove from cache + (set! *cache* (filter (lambda (e) (not (eq? (cdr e) regex))) *cache*)) + ;; Release FFI resources + (let ([md (pcre-regex-match-data regex)] + [code (pcre-regex-code regex)]) + (when (not (zero? md)) (ffi-pcre2-match-data-free md)) + (when (not (zero? code)) (ffi-pcre2-code-free code))))) + + ;; ----------------------------------------------------------------------- + ;; Pregexp-compatible API + ;; ----------------------------------------------------------------------- + + (define pcre2-pregexp-match + (case-lambda + [(pattern subject) (pcre2-pregexp-match pattern subject 0 #f)] + [(pattern subject start) (pcre2-pregexp-match pattern subject start #f)] + [(pattern subject start end) + (let* ([subj (if end + (substring subject start end) + (substring subject start (string-length subject)))] + [m (pcre2-search pattern subj 0)]) + (and m (pcre-match->list m)))])) + + (define pcre2-pregexp-match-positions + (case-lambda + [(pattern subject) (pcre2-pregexp-match-positions pattern subject 0 #f)] + [(pattern subject start) (pcre2-pregexp-match-positions pattern subject start #f)] + [(pattern subject start end) + (let* ([subj (if end + (substring subject start end) + (substring subject start (string-length subject)))] + [m (pcre2-search pattern subj 0)]) + (and m + (let* ([sv (pcre-match-span-vec m)] + [n (vector-length sv)]) + (let loop ([i 0] [acc '()]) + (if (= i n) + (reverse acc) + (let ([pair (vector-ref sv i)]) + (loop (+ i 1) + (cons (if pair + (cons (+ start (car pair)) + (+ start (cdr pair))) + #f) + acc))))))))])) + + (define (pcre2-pregexp-replace pattern subject replacement) + (pcre2-replace pattern subject replacement)) + + (define (pcre2-pregexp-replace* pattern subject replacement) + (pcre2-replace-all pattern subject replacement)) + + (define (pcre2-pregexp-quote str) + (pcre2-quote str)) + + ;; ----------------------------------------------------------------------- + ;; Initialize guardian-based cleanup on GC + ;; (Must be at the end — after all definitions, as R6RS requires) + ;; ----------------------------------------------------------------------- + + (collect-request-handler + (let ([old (collect-request-handler)]) + (lambda () + (old) + (pcre2-collect!)))) +) new file mode 100644 --- /dev/null +++ b/pcre2-test.ss @@ -0,0 +1,349 @@ +;;; pcre2-test.ss — Test suite for chez-pcre2 high-level API +;;; +;;; Run: scheme --libdirs . --script pcre2-test.ss + +(import (chez-pcre2 pcre2)) + +(define *pass* 0) +(define *fail* 0) +(define *test-name* "") + +(define-syntax test-group + (syntax-rules () + [(_ name body ...) + (begin + (display (string-append "\n=== " name " ===\n")) + body ...)])) + +(define-syntax test-case + (syntax-rules () + [(_ name body ...) + (begin + (set! *test-name* name) + (guard (e [#t (set! *fail* (+ *fail* 1)) + (display (string-append " FAIL: " name "\n")) + (display (string-append " error: " + (if (message-condition? e) + (condition-message e) + (format "~s" e)) + "\n"))]) + body ... + (set! *pass* (+ *pass* 1)) + (display (string-append " pass: " name "\n"))))])) + +(define-syntax check + (syntax-rules (=> ?) + [(_ expr => expected) + (let ([got expr] [exp expected]) + (unless (equal? got exp) + (error 'check + (format "~a: expected ~s, got ~s" *test-name* exp got))))] + [(_ expr ? pred) + (let ([got expr]) + (unless (pred got) + (error 'check + (format "~a: predicate failed for ~s" *test-name* got))))])) + +(define-syntax check-exception + (syntax-rules () + [(_ expr) + (guard (e [#t 'ok]) + expr + (error 'check-exception + (format "~a: expected exception" *test-name*)))])) + +;; ----------------------------------------------------------------- +(test-group "compilation" + (test-case "pcre2-compile returns pcre-regex" + (define rx (pcre2-compile "hello")) + (check (pcre-regex? rx) ? values)) + + (test-case "pcre2-regex creates compiled regex with options" + (define a (pcre2-regex "world")) + (define b (pcre2-regex "world" 'caseless: #t)) + (check (pcre-regex? a) ? values) + (check (pcre-regex? b) ? values)) + + (test-case "pcre2-compile raises on bad pattern" + (check-exception (pcre2-compile "[invalid"))) + + (test-case "compile with caseless option" + (define rx (pcre2-regex "HELLO" 'caseless: #t)) + (check (pcre-regex? rx) ? values) + (check (pcre2-matches? rx "hello world") ? values)) + + (test-case "compile with multiline option" + (define rx (pcre2-regex "^line" 'multiline: #t)) + (check (pcre-regex? rx) ? values))) + +;; ----------------------------------------------------------------- +(test-group "matching" + (test-case "pcre2-match returns pcre-match on success" + (define rx (pcre2-compile "hel+o")) + (define m (pcre2-match rx "hello")) + (check (pcre-match? m) ? values)) + + (test-case "pcre2-match returns #f on no match" + (define rx (pcre2-compile "xyz")) + (check (pcre2-match rx "hello world") => #f)) + + (test-case "pcre2-search finds match with offset" + (define rx (pcre2-compile "\\d+")) + (define m (pcre2-search rx "abc 42 def")) + (check (pcre-match? m) ? values) + (check (pcre-match-group m 0) => "42")) + + (test-case "pcre2-matches? returns bool" + (define rx (pcre2-compile "^\\d+$")) + (check (pcre2-matches? rx "12345") ? values) + (check (pcre2-matches? rx "123x5") => #f)) + + (test-case "full match group 0 is whole match" + (define rx (pcre2-compile "f(o+)")) + (define m (pcre2-search rx "foobar")) + (check (pcre-match-group m 0) => "foo") + (check (pcre-match-group m 1) => "oo")) + + (test-case "unmatched optional group returns #f" + (define rx (pcre2-compile "(a)?(b)")) + (define m (pcre2-match rx "b")) + (check (pcre-match-group m 1) => #f) + (check (pcre-match-group m 2) => "b")) + + (test-case "named capture groups" + (define rx (pcre2-compile "(?P<year>\\d{4})-(?P<month>\\d{2})")) + (define m (pcre2-search rx "date: 2024-03")) + (check (pcre-match-named m "year") => "2024") + (check (pcre-match-named m "month") => "03")) + + (test-case "pcre-match->list returns list of strings" + (define rx (pcre2-compile "(\\w+)\\s+(\\w+)")) + (define m (pcre2-match rx "hello world")) + (define lst (pcre-match->list m)) + (check (car lst) => "hello world") + (check (cadr lst) => "hello") + (check (caddr lst) => "world")) + + (test-case "pcre-match->alist uses named groups" + (define rx (pcre2-compile "(?P<a>\\w+) (?P<b>\\w+)")) + (define m (pcre2-match rx "foo bar")) + (define al (pcre-match->alist m)) + (check (assoc "a" al) => '("a" . "foo")) + (check (assoc "b" al) => '("b" . "bar"))) + + (test-case "pcre-match-positions returns start/end pair" + (define rx (pcre2-compile "(\\d+)")) + (define m (pcre2-search rx "abc 99 def")) + (define pos (pcre-match-positions m 0)) + (check (pair? pos) ? values) + (check (car pos) => 4) + (check (cdr pos) => 6))) + +;; ----------------------------------------------------------------- +(test-group "substitution" + (test-case "pcre2-replace replaces first match" + (define rx (pcre2-compile "o+")) + (check (pcre2-replace rx "foobar" "0") => "f0bar")) + + (test-case "pcre2-replace-all replaces all matches" + (define rx (pcre2-compile "o")) + (check (pcre2-replace-all rx "foobar" "0") => "f00bar")) + + (test-case "pcre2-replace with backreference" + (define rx (pcre2-compile "(\\w+)")) + (check (pcre2-replace rx "hello world" "[$1]" 0 #t) => "[hello] world")) +