pcre2.scm - cs-pcre2 - Chez Scheme bindings for PCRE2.

cs-pcre2 - Chez Scheme bindings for PCRE2.
git clone https://benconnors.ca/git-repos/cs-pcre2
pcre2.scm (10146B) - raw
      1 ; Chez Scheme bindings for (a subset of) PCRE2
      2 
      3 (library (pcre2 (1))
      4          (export
      5            pcre2-compile
      6            pcre2-match
      7            pcre2-get-match-count
      8            pcre2-get-match-groupcount
      9            pcre2-get-match-group 
     10            pcre2-get-match-groups)
     11          (import (chezscheme))
     12 
     13          (define pcre2-library-load (load-shared-object "libpcre2-8.so"))
     14 
     15          ;;; BEGIN Constants
     16 
     17          (define SIZE_T-SIZE (foreign-sizeof 'size_t))
     18          (define PCRE2-ZERO-TERMINATED (- (expt 2 (* 8 SIZE_T-SIZE)) 1))
     19          (define PCRE2-UNSET PCRE2-ZERO-TERMINATED)
     20 
     21          ;;; END Constants
     22 
     23          ;;; BEGIN Memory Management
     24 
     25          ; This guardian handles deallocating PCRE2-allocated foreign pointers when they're no 
     26          ; longer accessible from scheme
     27          (define pcre2-guardian (make-guardian))
     28 
     29          ; Add a pointer to the guardian with the given cleanup function (`pcre2-code-free-base` or
     30          ; `pcre2-match-data-free-base`)
     31          (define (pcre2-guard-pointer ptr cleanup)
     32            (cons ptr cleanup))
     33 
     34 
     35          ; Get the foreign pointer from a guarded pointer
     36          (define (pcre2-get-pointer-ptr ptr)
     37            (car ptr))
     38 
     39          ; Get the cleanup function from a guarded pointer
     40          (define (pcre2-get-pointer-cleanup ptr)
     41            (cdr ptr))
     42 
     43          ; Guard a code pointer
     44          (define (pcre2-guard-code-pointer ptr)
     45            (pcre2-guard-pointer ptr pcre2-code-free-base))
     46 
     47          ; Guard a match data pointer
     48          (define (pcre2-guard-match-pointer ptr)
     49            (pcre2-guard-pointer ptr pcre2-match-data-free-base))
     50 
     51          ; Run cleanup; called when new data is allocated
     52          (define (pcre2-cleanup)
     53            (let f ()
     54              (let ((x (pcre2-guardian)))
     55                (when x
     56                  ((pcre2-get-pointer-cleanup x) (pcre2-get-pointer-ptr x))
     57                  (f)))))
     58 
     59          ;;; END Memory Management
     60 
     61          ;;; BEGIN Compilation Functions
     62 
     63          (define pcre2-compile-base
     64            (foreign-procedure "pcre2_compile_8"
     65                               (string size_t unsigned-32 void* void* void*)
     66                               void*))
     67 
     68          (define pcre2-code-free-base
     69            (foreign-procedure "pcre2_code_free_8"
     70                               (void*)
     71                               void))
     72 
     73          ; Compile a string pattern for use in match
     74          (define (pcre2-compile pattern options)
     75            (pcre2-cleanup)
     76            (let* ((errorcode (foreign-alloc (foreign-sizeof 'int)))
     77                   (erroroffset (foreign-alloc (foreign-sizeof 'size_t)))
     78                   (code (pcre2-compile-base pattern PCRE2-ZERO-TERMINATED options errorcode erroroffset 0))
     79                   (errorc (foreign-ref 'int errorcode 0)))
     80              (if (< errorc 0)
     81                (error 'pcre2-compile (pcre2-get-error-message errorc) (foreign-ref 'size_t erroroffset 0))
     82                (pcre2-guard-code-pointer code))))
     83 
     84          ;;; END Compilation Functions
     85 
     86          ;;; BEGIN Utility Functions
     87 
     88          (define pcre2-get-error-message-base 
     89            (foreign-procedure "pcre2_get_error_message_8"
     90                               (int u8* size_t)
     91                               int))
     92 
     93          ; Get the PCRE2 error message corresponding to the given code
     94          (define (pcre2-get-error-message errorcode)
     95            (let* ((buff (make-bytevector 255))
     96                   (len (pcre2-get-error-message-base errorcode buff 255)))
     97              (substring (utf8->string buff) 0 len)))
     98 
     99          ;;; END Utility Functions
    100 
    101          ;;; BEGIN Matching Functions
    102 
    103          ; Note: functions here take either `match-data-ptr` or `match-data`; if they take 
    104          ; `match-data-ptr`, they expect a guarded pointer as returned from `pcre2-guard-pointer`.
    105          ; Otherwise, they expect a match data object as returned from `pcre2-match`
    106 
    107          (define pcre2-match-base
    108            (foreign-procedure "pcre2_match_8"
    109                               (void* string size_t size_t unsigned-32 void* void*)
    110                               int))
    111 
    112          (define pcre2-match-data-free-base 
    113            (foreign-procedure "pcre2_match_data_free_8"
    114                               (void*)
    115                               void))
    116 
    117          (define pcre2-match-data-create-from-pattern-base
    118            (foreign-procedure "pcre2_match_data_create_from_pattern_8"
    119                               (void* void*)
    120                               void*))
    121 
    122          ; Create a match data block with enough storage to hold the groups in `pattern`
    123          (define (pcre2-match-data-create-from-pattern pattern)
    124            (pcre2-guard-match-pointer (pcre2-match-data-create-from-pattern-base (pcre2-get-pointer-ptr pattern) 0)))
    125 
    126          (define pcre2-get-ovector-count-base
    127            (foreign-procedure "pcre2_get_ovector_count_8"
    128                               (void*)
    129                               unsigned-32))
    130 
    131          ; Get the number of groups in a given match data block
    132          (define (pcre2-get-ovector-count match-data-ptr)
    133            (pcre2-get-ovector-count-base (pcre2-get-pointer-ptr match-data-ptr)))
    134 
    135          (define pcre2-get-ovector-pointer-base
    136            (foreign-procedure "pcre2_get_ovector_pointer_8"
    137                               (void*)
    138                               void*))
    139 
    140          ; Get the pointer to the first group in the match data block
    141          (define (pcre2-get-ovector-pointer match-data-ptr)
    142            (pcre2-get-ovector-pointer-base (pcre2-get-pointer-ptr match-data-ptr)))
    143 
    144          ; Create a match data object for `match-data-ptr` with the relevant info
    145          (define (pcre2-make-match-data-object count match-data-ptr)
    146            (list match-data-ptr count (pcre2-get-ovector-count match-data-ptr) (pcre2-get-ovector-pointer match-data-ptr)))
    147 
    148          ; Accessor functions for match data objects returned from `pcre2-match`
    149          (define pcre2-get-match-ptr car)
    150          (define pcre2-get-match-ovector-ptr cadddr)
    151          ; These three are the only public ones
    152          (define pcre2-get-match-count cadr)
    153          (define pcre2-get-match-groupcount caddr)
    154 
    155          ; Match `str` against `pattern` starting at `offset`; returns #f if no match
    156          (define (pcre2-match pattern str offset options)
    157            (pcre2-cleanup)
    158            (let* ((match-data (pcre2-match-data-create-from-pattern pattern))
    159                   (errorcode (pcre2-match-base (pcre2-get-pointer-ptr pattern) str PCRE2-ZERO-TERMINATED offset options (pcre2-get-pointer-ptr match-data) 0)))
    160              (display errorcode)
    161              (newline)
    162              (cond ((< errorcode -1) (error 'pcre2-match (pcre2-get-error-message errorcode) errorcode))
    163                    ((< errorcode 2) #f)
    164                    (else (pcre2-make-match-data-object (- errorcode 1) match-data)))))
    165 
    166          (define pcre2-substring-length-bynumber-base
    167            (foreign-procedure "pcre2_substring_length_bynumber_8"
    168                               (void* unsigned-32 void*)
    169                               int))
    170 
    171          ; Get the length of a substring
    172          (define (pcre2-substring-length-bynumber match-data-ptr num)
    173            (let* ((lenptr (foreign-alloc SIZE_T-SIZE))
    174                   (errorcode (pcre2-substring-length-bynumber-base (pcre2-get-pointer-ptr match-data-ptr) num lenptr))
    175                   (len (foreign-ref 'size_t lenptr 0)))
    176              (if (< errorcode 0)
    177                (error 'pcre2-substring-length-bynumber (pcre2-get-error-message errorcode) match-data-ptr)
    178                len)))
    179 
    180          (define (pcre2-substring-length-bynumber-b match-data num)
    181            (let* ((ovector (pcre2-get-match-ovector-ptr match-data))
    182                   (start (foreign-ref 'size_t ovector (* 2 num SIZE_T-SIZE)))
    183                   (end (foreign-ref 'size_t ovector (* (+ 1 (* 2 num)) SIZE_T-SIZE))))
    184              (if (= start end PCRE2-UNSET) #f
    185                (- end start))))
    186 
    187          (define pcre2-substring-copy-bynumber-base
    188            (foreign-procedure "pcre2_substring_copy_bynumber_8"
    189                               (void* unsigned-32 u8* void*)
    190                               int))
    191 
    192          ; Get a match substring; some gymnastics are needed because PCRE2 operates in code units 
    193          ; (bytes) while Chez Scheme operates in UTF-8 characters
    194          (define (pcre2-substring-copy-bynumber match-data num)
    195            (let* ((strlen (pcre2-substring-length-bynumber-b match-data num)))
    196              (if (not strlen) 
    197                #f ; This group is unset
    198                (begin
    199                  (let* 
    200                    ((match-data-ptr (pcre2-get-match-ptr match-data))
    201                     (bufflen (+ strlen 1))
    202                     (buff (make-bytevector (+ bufflen 1)))
    203                     (bufflenptr (foreign-alloc SIZE_T-SIZE)))
    204                    (foreign-set! 'size_t bufflenptr 0 bufflen)
    205                    (let* ((errorcode (pcre2-substring-copy-bynumber-base 
    206                                        (pcre2-get-pointer-ptr match-data-ptr)
    207                                        num
    208                                        buff
    209                                        bufflenptr)))
    210                      (when (< errorcode 0)
    211                        (error 'pcre2-substring-copy-bynumber (pcre2-get-error-message errorcode) match-data-ptr))
    212                      (bytevector-truncate! buff (- bufflen 1))
    213                      (utf8->string buff)))))))
    214 
    215          ; Get a match group for `match-data`
    216          (define (pcre2-get-match-group match-data n)
    217            (when (or (>= n (pcre2-get-match-groupcount match-data)) (< n 0))
    218              (error 'pcre2-get-match-group "Invalid group number" n))
    219            (pcre2-substring-copy-bynumber match-data n))
    220 
    221          ; Get all the substring groups for `match-data`
    222          (define (pcre2-get-match-groups match-data)
    223            (define count (pcre2-get-match-groupcount match-data))
    224            (define (inner n running)
    225              (if (= n -1) running
    226                (inner (- n 1) (cons (pcre2-get-match-group match-data n) running))))
    227            (inner (- count 1) '()))
    228 
    229          ;;; END Matching Functions
    230 
    231          )