1 ! Copyright (C) 2013 Björn Lindqvist
2 ! See http://factorcode.org/license.txt for BSD license
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 pcre.ffi sequences splitting strings ;
11 ERROR: bad-option what ;
13 ERROR: malformed-regexp expr error ;
15 ERROR: pcre-error value ;
19 : replace-all ( seq subseqs new -- seq )
20 swapd '[ _ replace ] reduce ;
22 : split-subseqs ( seq subseqs -- seqs )
23 dup first [ replace-all ] keep split-subseq [ >string ] map harvest ;
25 : 2with ( param1 param2 obj quot -- obj curry )
26 [ -rot ] dip [ [ rot ] dip call ] 3curry ; inline
28 : utf8-start-byte? ( byte -- ? )
29 0xc0 bitand 0x80 = not ;
31 : next-utf8-char ( byte-array pos -- pos' )
33 utf8-start-byte? [ nip ] [ next-utf8-char ] if
36 : check-bad-option ( err value what -- value )
37 rot 0 = [ drop ] [ bad-option ] if ;
39 : pcre-config ( what -- value )
42 PCRE_CONFIG_MATCH_LIMIT
43 PCRE_CONFIG_MATCH_LIMIT_RECURSION
45 { long } [ pcre_config ] with-out-parameters
47 { int } [ pcre_config ] with-out-parameters
49 ] keep check-bad-option ;
51 : pcre-fullinfo ( pcre extra what -- obj )
52 [ { int } [ pcre_fullinfo ] with-out-parameters ] keep
55 : pcre-substring-list ( subject match-array count -- alien )
56 { void* } [ pcre_get_substring_list drop ] with-out-parameters ;
58 : name-count ( pcre extra -- n )
59 PCRE_INFO_NAMECOUNT pcre-fullinfo ;
61 : name-table ( pcre extra -- addr )
62 [ drop alien-address 32 on-bits unmask ]
63 ! On at least win64, the pointer is returned as an int and is
64 ! negative. Cast it to a uint and everything works.
65 [ PCRE_INFO_NAMETABLE pcre-fullinfo int <ref> uint deref ] 2bi + ;
67 : name-entry-size ( pcre extra -- size )
68 PCRE_INFO_NAMEENTRYSIZE pcre-fullinfo ;
70 : name-table-entry ( addr -- group-index group-name )
71 [ <alien> 1 alien-unsigned-1 ]
72 [ 2 + <alien> utf8 alien>string ] bi ;
74 : name-table-entries ( pcre extra -- addrs )
75 [ name-table ] [ name-entry-size ] [ name-count ] 2tri
76 iota [ * + name-table-entry 2array ] 2with map ;
78 : options ( pcre -- opts )
79 f PCRE_INFO_OPTIONS pcre-fullinfo ;
81 CONSTANT: default-opts flags{ PCRE_UTF8 PCRE_UCP }
83 : (pcre) ( expr -- pcre err-message err-offset )
84 default-opts { c-string int } [ f pcre_compile ] with-out-parameters ;
86 : <pcre> ( expr -- pcre )
87 dup (pcre) 2array swap [ 2nip ] [ malformed-regexp ] if* ;
89 : <pcre-extra> ( pcre -- pcre-extra )
90 0 { c-string } [ pcre_study ] with-out-parameters drop ;
92 : exec ( pcre extra subject ofs opts -- count match-data )
93 [ dup length ] 2dip 30 int <c-array> 30 [ pcre_exec ] 2keep drop ;
95 TUPLE: matcher pcre extra subject ofs exec-opts ;
97 : <matcher> ( subject compiled-pcre -- matcher )
98 [ utf8 encode ] dip [ pcre>> ] [ extra>> ] bi rot 0 0 matcher boa ;
100 CONSTANT: empty-match-opts flags{ PCRE_NOTEMPTY_ATSTART PCRE_ANCHORED }
102 : findnext ( matcher -- matcher match/f )
109 } cleave exec over dup -1 < [
110 PCRE_ERRORS number>enum pcre-error
113 2drop dup exec-opts>> 0 =
116 dup [ subject>> ] [ ofs>> ] bi next-utf8-char
117 [ >>ofs 0 >>exec-opts findnext ] [ f ] if*
122 [ first2 = [ empty-match-opts ] [ 0 ] if >>exec-opts ]
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 ;
136 TUPLE: compiled-pcre pcre extra nametable ;
138 : <compiled-pcre> ( expr -- compiled-pcre )
139 <pcre> dup <pcre-extra> 2dup name-table-entries compiled-pcre boa ;
141 : has-option? ( compiled-pcre option -- ? )
142 [ pcre>> options ] dip bitand 0 > ;
144 GENERIC: findall ( subject obj -- matches )
146 M: compiled-pcre findall
147 [ <matcher> [ findnext dup ] [ ] produce 2nip ]
148 [ nametable>> rot [ parse-match ] 2with { } map-as ] 2bi ;
151 <compiled-pcre> findall ;
153 M: regexp:regexp findall
156 : matches? ( subject obj -- ? )
157 dupd findall [ nip length 1 = ] [ ?first ?first ?last = ] 2bi and ;
159 : split ( subject obj -- strings )
160 dupd findall [ first second ] map split-subseqs ;