extra/pcre/pcre.factor

   1 ! Copyright (C) 2013, 2016 Björn Lindqvist
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: accessors alien alien.accessors alien.c-types alien.data
   5 alien.enums alien.strings arrays assocs combinators fry
   6 io.encodings.string io.encodings.utf8 kernel literals math
   7 math.bitwise math.parser pcre.ffi regexp sequences splitting strings ;
   8 IN: pcre
   9
  10 ERROR: bad-option what ;
  11
  12 ERROR: malformed-regexp expr error ;
  13
  14 ERROR: pcre-error value ;
  15
  16 : version ( -- f )
  17     pcre_version " -" splitting:split first string>number ;
  18
  19 <PRIVATE
  20
  21 : replace-all ( seq subseqs new -- seq )
  22     swapd '[ _ replace ] reduce ;
  23
  24 : split-subseqs ( seq subseqs -- seqs )
  25     dup first [ replace-all ] keep split-subseq [ >string ] map harvest ;
  26
  27 : utf8-start-byte? ( byte -- ? )
  28     0xc0 bitand 0x80 = not ;
  29
  30 : next-utf8-char ( byte-array pos -- pos' )
  31     1 + 2dup swap ?nth [
  32         utf8-start-byte? [ nip ] [ next-utf8-char ] if
  33     ] [ 2drop f ] if* ;
  34
  35 : check-bad-option ( err value what -- value )
  36     rot 0 = [ drop ] [ bad-option ] if ;
  37
  38 : pcre-config ( what -- value )
  39     [
  40         dup {
  41             PCRE_CONFIG_MATCH_LIMIT
  42             PCRE_CONFIG_MATCH_LIMIT_RECURSION
  43         } member? [
  44             { long } [ pcre_config ] with-out-parameters
  45         ] [
  46             { int } [ pcre_config ] with-out-parameters
  47         ] if
  48     ] keep check-bad-option ;
  49
  50 : pcre-fullinfo ( pcre extra what -- obj )
  51     [ { int } [ pcre_fullinfo ] with-out-parameters ] keep
  52     check-bad-option ;
  53
  54 : pcre-substring-list ( subject match-array count -- alien )
  55     { void* } [ pcre_get_substring_list drop ] with-out-parameters ;
  56
  57 : name-count ( pcre extra -- n )
  58     PCRE_INFO_NAMECOUNT pcre-fullinfo ;
  59
  60 : name-table ( pcre extra -- addr )
  61     [ drop alien-address 32 on-bits unmask ]
  62     ! On at least win64, the pointer is returned as an int and is
  63     ! negative. Cast it to a uint and everything works.
  64     [ PCRE_INFO_NAMETABLE pcre-fullinfo int <ref> uint deref ] 2bi + ;
  65
  66 : name-entry-size ( pcre extra -- size )
  67     PCRE_INFO_NAMEENTRYSIZE pcre-fullinfo ;
  68
  69 : name-table-entry ( addr -- group-index group-name )
  70     [ <alien> 1 alien-unsigned-1 ]
  71     [ 2 + <alien> utf8 alien>string ] bi ;
  72
  73 : name-table-entries ( pcre extra -- addrs )
  74     [ name-table ] [ name-entry-size ] [ name-count ] 2tri
  75     <iota> [ * + name-table-entry 2array ] 2with map ;
  76
  77 : options ( pcre -- opts )
  78     f PCRE_INFO_OPTIONS pcre-fullinfo ;
  79
  80 : default-opts ( -- opts )
  81     PCRE_UTF8 version 8.10 >= [ PCRE_UCP bitor ] when ;
  82
  83 : (pcre) ( expr -- pcre err-message err-offset )
  84     default-opts { c-string int } [ f pcre_compile ] with-out-parameters ;
  85
  86 : <pcre> ( expr -- pcre )
  87     dup (pcre) 2array swap [ 2nip ] [ malformed-regexp ] if* ;
  88
  89 : <pcre-extra> ( pcre -- pcre-extra )
  90     0 { c-string } [ pcre_study ] with-out-parameters drop ;
  91
  92 : exec ( pcre extra subject ofs opts -- count match-data )
  93     [ dup length ] 2dip 30 int <c-array> 30 [ pcre_exec ] 2keep drop ;
  94
  95 TUPLE: matcher pcre extra subject ofs exec-opts ;
  96
  97 : <matcher> ( subject compiled-pcre -- matcher )
  98     [ utf8 encode ] dip [ pcre>> ] [ extra>> ] bi rot 0 0 matcher boa ;
  99
 100 CONSTANT: empty-match-opts flags{ PCRE_NOTEMPTY_ATSTART PCRE_ANCHORED }
 101
 102 : findnext ( matcher -- matcher match/f )
 103     dup {
 104         [ pcre>> ]
 105         [ extra>> ]
 106         [ subject>> ]
 107         [ ofs>> ]
 108         [ exec-opts>> ]
 109     } cleave exec over dup -1 < [
 110         PCRE_ERRORS number>enum pcre-error
 111     ] [
 112         -1 = [
 113             2drop dup exec-opts>> 0 =
 114             [ f ]
 115             [
 116                 dup [ subject>> ] [ ofs>> ] bi next-utf8-char
 117                 [ >>ofs 0 >>exec-opts findnext ] [ f ] if*
 118             ] if
 119         ] [
 120             [
 121                 nip
 122                 [ first2 = [ empty-match-opts ] [ 0 ] if >>exec-opts ]
 123                 [ second >>ofs ] bi
 124             ] [
 125                 2array
 126             ] 2bi
 127         ] if
 128     ] if ;
 129
 130 : parse-match ( subject nametable match-data -- match )
 131     swapd first2 swap [ pcre-substring-list ] keep void* <c-direct-array>
 132     [ utf8 alien>string ] { } map-as [ of swap 2array ] with map-index ;
 133
 134 PRIVATE>
 135
 136 TUPLE: compiled-pcre pcre extra nametable ;
 137
 138 : <compiled-pcre> ( expr -- compiled-pcre )
 139     <pcre> dup <pcre-extra> 2dup name-table-entries compiled-pcre boa ;
 140
 141 : has-option? ( compiled-pcre option -- ? )
 142     [ pcre>> options ] dip bitand 0 > ;
 143
 144 GENERIC: findall ( subject obj -- matches )
 145
 146 M: compiled-pcre findall
 147     [ <matcher> [ findnext dup ] [ ] produce 2nip ]
 148     [ nametable>> rot [ parse-match ] 2with { } map-as ] 2bi ;
 149
 150 M: string findall
 151     <compiled-pcre> findall ;
 152
 153 M: regexp:regexp findall
 154     raw>> findall ;
 155
 156 : matches? ( subject obj -- ? )
 157     dupd findall [ nip length 1 = ] [ ?first ?first ?last = ] 2bi and ;
 158
 159 : split ( subject obj -- strings )
 160     dupd findall [ first second ] map split-subseqs ;