guile/pcre.scm

   1 ;;  Copyright (C) 2015
   2 ;;      "Mu Lei" known as "NalaGinrut" <NalaGinrut@gmail.com>
   3 ;;  This file is free software: you can redistribute it and/or modify
   4 ;;  it under the terms of the GNU General Public License as published by
   5 ;;  the Free Software Foundation, either version 3 of the License, or
   6 ;;  (at your option) any later version.
   7
   8 ;;  This file is distributed in the hope that it will be useful,
   9 ;;  but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 ;;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 ;;  GNU General Public License for more details.
  12
  13 ;;  You should have received a copy of the GNU General Public License
  14 ;;  along with this program.  If not, see <http://www.gnu.org/licenses/>.
  15
  16 (library (pcre)
  17   (export new-pcre
  18           pcre-match
  19           pcre-get-substring
  20           pcre-search)
  21   (import (guile) (rnrs) (system foreign)))
  22
  23 (define (make-blob-pointer len)
  24   (bytevector->pointer (make-bytevector len)))
  25
  26 (define pcre-ffi (dynamic-link "libpcre"))
  27
  28 (define %pcre-compile2
  29   (pointer->procedure '*
  30                        (dynamic-func "pcre_compile2" pcre-ffi)
  31                        (list '* int '* '* '* '*)))
  32
  33 (define %pcre-compile
  34   (pointer->procedure '*
  35                        (dynamic-func "pcre_compile" pcre-ffi)
  36                        (list '* int '* '* '*)))
  37
  38 (define %pcre-exec
  39   (pointer->procedure int
  40                       (dynamic-func "pcre_exec" pcre-ffi)
  41                       (list '* '* '* int int int '* int)))
  42
  43 (define %pcre-study
  44   (pointer->procedure '*
  45                       (dynamic-func "pcre_study" pcre-ffi)
  46                       (list '* int '*)))
  47
  48 (define %pcre-get-substring
  49   (pointer->procedure '*
  50                       (dynamic-func "pcre_get_substring" pcre-ffi)
  51                       (list '* '* int int '*)))
  52
  53 (define %pcre-free
  54   (pointer->procedure void
  55                       (dynamic-func "pcre_free" pcre-ffi)
  56                       (list '*)))
  57
  58 (define %pcre-free-study (dynamic-func "pcre_free_study" pcre-ffi))
  59
  60 (define %pcre-free-substring (dynamic-func "pcre_free_substring" pcre-ffi))
  61
  62 (define-record-type pcre
  63   (fields
  64    errptr
  65    (mutable strptr)
  66    (mutable ovector)
  67    (mutable matched)
  68    (mutable code)
  69    (mutable extra)))
  70
  71 (define (%new-pcre)
  72   (make-pcre (make-blob-pointer (sizeof ptrdiff_t)) ; errptr
  73              #f #f 0 #f #f))
  74
  75 (define* (new-pcre re #:optional (options 0))
  76   (let ((reptr (string->pointer re))
  77         ;;(errcodeptr (make-blob-pointer int))
  78         (erroffset (make-blob-pointer int))
  79         (tableptr %null-pointer)
  80         (pcre (%new-pcre)))
  81     ;; FIXME: add exception handling
  82     (pcre-code-set! pcre (%pcre-compile reptr options (pcre-errptr pcre)
  83                                         erroffset tableptr))
  84     ;;(set-pointer-finalizer! (pcre-code pcre) %pcre-free)
  85     pcre))
  86
  87 (define* (pcre-match pcre str #:key (study-options 0) (exec-options 0)
  88                      (ovecsize 30) (offset 0))
  89   (let ((extra (%pcre-study (pcre-code pcre) study-options (pcre-errptr pcre)))
  90         (strptr (string->pointer str))
  91         (ovector (make-blob-pointer (* int ovecsize))))
  92     (pcre-matched-set! pcre
  93                        (%pcre-exec (pcre-code pcre)
  94                                    extra
  95                                    strptr
  96                                    (string-length str)
  97                                    offset
  98                                    exec-options
  99                                    ovector
 100                                    ovecsize))
 101     (pcre-ovector-set! pcre ovector)
 102     (pcre-strptr-set! pcre strptr)
 103     (set-pointer-finalizer! extra %pcre-free-study)
 104     pcre))
 105
 106 (define (pcre-get-substring pcre index)
 107   (let ((strptr (pcre-strptr pcre))
 108         (ovector (pcre-ovector pcre))
 109         (matched (pcre-matched pcre))
 110         (buf (make-blob-pointer (sizeof ptrdiff_t))))
 111     (%pcre-get-substring strptr ovector matched index buf)
 112     (let ((ret (pointer->string (dereference-pointer buf))))
 113       (set-pointer-finalizer! (dereference-pointer buf) %pcre-free-substring)
 114       ret)))
 115
 116 (define* (pcre-search pcre str #:key (study-options 0) (exec-options 0)
 117                       (exclude " "))
 118   (define (trim s)
 119     (string-trim-both s (lambda (x) (string-contains exclude (string x)))))
 120   (define len (string-length str))
 121   (let lp((i 0) (ret '()))
 122     (cond
 123      ((>= i len) (reverse ret))
 124      (else
 125       (pcre-match pcre str #:study-options study-options #:exec-options exec-options #:offset i)
 126       (if (<= (pcre-matched pcre) 0)
 127           (lp len ret)
 128           (let ((hit (trim (pcre-get-substring pcre 1)))
 129                 (sublen (string-length (pcre-get-substring pcre 0))))
 130             (if (zero? sublen)
 131                 (lp len ret)
 132                 (lp (+ i sublen) (cons hit ret)))))))))
 133
 134 (define (pcre-free pcre)
 135   (and (not (null-pointer? (pcre-code pcre)))
 136        (%pcre-free (pcre-code pcre))))