1#if defined(PERL_EXT_RE_DEBUG) && !defined(DEBUGGING) 2# define DEBUGGING 3# define DEBUGGING_RE_ONLY 4#endif 5 6#define PERL_NO_GET_CONTEXT 7#include "EXTERN.h" 8#include "perl.h" 9#include "XSUB.h" 10#include "re_comp.h" 11 12#undef dXSBOOTARGSXSAPIVERCHK 13/* skip API version checking due to different interp struct size but, 14 this hack is until GitHub issue #14169 is resolved */ 15#define dXSBOOTARGSXSAPIVERCHK dXSBOOTARGSNOVERCHK 16 17START_EXTERN_C 18 19extern REGEXP* my_re_compile (pTHX_ SV * const pattern, const U32 pm_flags); 20extern REGEXP* my_re_op_compile (pTHX_ SV ** const patternp, int pat_count, 21 OP *expr, const regexp_engine* eng, REGEXP *volatile old_re, 22 bool *is_bare_re, U32 rx_flags, U32 pm_flags); 23 24extern I32 my_regexec (pTHX_ REGEXP * const prog, char* stringarg, char* strend, 25 char* strbeg, SSize_t minend, SV* screamer, 26 void* data, U32 flags); 27 28extern char* my_re_intuit_start(pTHX_ 29 REGEXP * const rx, 30 SV *sv, 31 const char * const strbeg, 32 char *strpos, 33 char *strend, 34 const U32 flags, 35 re_scream_pos_data *data); 36 37extern SV* my_re_intuit_string (pTHX_ REGEXP * const prog); 38 39extern void my_regfree (pTHX_ REGEXP * const r); 40 41extern void my_reg_numbered_buff_fetch(pTHX_ REGEXP * const rx, const I32 paren, 42 SV * const usesv); 43extern void my_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren, 44 SV const * const value); 45extern I32 my_reg_numbered_buff_length(pTHX_ REGEXP * const rx, 46 const SV * const sv, const I32 paren); 47 48extern SV* my_reg_named_buff(pTHX_ REGEXP * const, SV * const, SV * const, 49 const U32); 50extern SV* my_reg_named_buff_iter(pTHX_ REGEXP * const rx, 51 const SV * const lastkey, const U32 flags); 52 53extern SV* my_reg_qr_package(pTHX_ REGEXP * const rx); 54#if defined(USE_ITHREADS) 55extern void* my_regdupe (pTHX_ REGEXP * const r, CLONE_PARAMS *param); 56#endif 57extern void my_regprop(pTHX_ 58 const regexp *prog, SV* sv, const regnode* o, 59 const regmatch_info *reginfo, const RExC_state_t *pRExC_state 60); 61 62EXTERN_C const struct regexp_engine my_reg_engine; 63EXTERN_C const struct regexp_engine wild_reg_engine; 64 65END_EXTERN_C 66 67const struct regexp_engine my_reg_engine = { 68 my_re_compile, 69 my_regexec, 70 my_re_intuit_start, 71 my_re_intuit_string, 72 my_regfree, 73 my_reg_numbered_buff_fetch, 74 my_reg_numbered_buff_store, 75 my_reg_numbered_buff_length, 76 my_reg_named_buff, 77 my_reg_named_buff_iter, 78 my_reg_qr_package, 79#if defined(USE_ITHREADS) 80 my_regdupe, 81#endif 82 my_re_op_compile, 83}; 84 85/* For use with Unicode property wildcards, when we want to see the compilation 86 * of the wildcard subpattern, but don't want to see the matching process. All 87 * but the compilation are the regcomp.c/regexec.c functions which aren't 88 * subject to 'use re' */ 89const struct regexp_engine wild_reg_engine = { 90 my_re_compile, 91 Perl_regexec_flags, 92 Perl_re_intuit_start, 93 Perl_re_intuit_string, 94 Perl_regfree_internal, 95 Perl_reg_numbered_buff_fetch, 96 Perl_reg_numbered_buff_store, 97 Perl_reg_numbered_buff_length, 98 Perl_reg_named_buff, 99 Perl_reg_named_buff_iter, 100 Perl_reg_qr_package, 101#if defined(USE_ITHREADS) 102 Perl_regdupe_internal, 103#endif 104 my_re_op_compile, 105}; 106 107#define newSVbool_(x) newSViv((x) ? 1 : 0) 108 109MODULE = re PACKAGE = re 110 111void 112install() 113 PPCODE: 114 PL_colorset = 0; /* Allow reinspection of ENV. */ 115 /* PL_debug |= DEBUG_r_FLAG; */ 116 XPUSHs(sv_2mortal(newSViv(PTR2IV(&my_reg_engine)))); 117 118void 119regmust(sv) 120 SV * sv 121PROTOTYPE: $ 122PREINIT: 123 REGEXP *re; 124PPCODE: 125{ 126 if ((re = SvRX(sv)) /* assign deliberate */ 127 /* only for re engines we know about */ 128 && ( RX_ENGINE(re) == &my_reg_engine 129 || RX_ENGINE(re) == &wild_reg_engine 130 || RX_ENGINE(re) == &PL_core_reg_engine)) 131 { 132 SV *an = &PL_sv_no; 133 SV *fl = &PL_sv_no; 134 if (RX_ANCHORED_SUBSTR(re)) { 135 an = sv_2mortal(newSVsv(RX_ANCHORED_SUBSTR(re))); 136 } else if (RX_ANCHORED_UTF8(re)) { 137 an = sv_2mortal(newSVsv(RX_ANCHORED_UTF8(re))); 138 } 139 if (RX_FLOAT_SUBSTR(re)) { 140 fl = sv_2mortal(newSVsv(RX_FLOAT_SUBSTR(re))); 141 } else if (RX_FLOAT_UTF8(re)) { 142 fl = sv_2mortal(newSVsv(RX_FLOAT_UTF8(re))); 143 } 144 EXTEND(SP, 2); 145 PUSHs(an); 146 PUSHs(fl); 147 XSRETURN(2); 148 } 149 XSRETURN_UNDEF; 150} 151 152SV * 153optimization(sv) 154 SV * sv 155PROTOTYPE: $ 156PREINIT: 157 REGEXP *re; 158 regexp *r; 159 struct reg_substr_datum * data; 160 HV *hv; 161CODE: 162{ 163 re = SvRX(sv); 164 if (!re) { 165 XSRETURN_UNDEF; 166 } 167 168 /* only for re engines we know about */ 169 if ( RX_ENGINE(re) != &my_reg_engine 170 && RX_ENGINE(re) != &wild_reg_engine 171 && RX_ENGINE(re) != &PL_core_reg_engine) 172 { 173 XSRETURN_UNDEF; 174 } 175 176 if (!PL_colorset) { 177 reginitcolors(); 178 } 179 180 r = ReANY(re); 181 hv = newHV(); 182 183 hv_stores(hv, "minlen", newSViv(r->minlen)); 184 hv_stores(hv, "minlenret", newSViv(r->minlenret)); 185 hv_stores(hv, "gofs", newSViv(r->gofs)); 186 187 data = &r->substrs->data[0]; 188 hv_stores(hv, "anchored", data->substr 189 ? newSVsv(data->substr) : &PL_sv_undef); 190 hv_stores(hv, "anchored utf8", data->utf8_substr 191 ? newSVsv(data->utf8_substr) : &PL_sv_undef); 192 hv_stores(hv, "anchored min offset", newSViv(data->min_offset)); 193 hv_stores(hv, "anchored max offset", newSViv(data->max_offset)); 194 hv_stores(hv, "anchored end shift", newSViv(data->end_shift)); 195 196 data = &r->substrs->data[1]; 197 hv_stores(hv, "floating", data->substr 198 ? newSVsv(data->substr) : &PL_sv_undef); 199 hv_stores(hv, "floating utf8", data->utf8_substr 200 ? newSVsv(data->utf8_substr) : &PL_sv_undef); 201 hv_stores(hv, "floating min offset", newSViv(data->min_offset)); 202 hv_stores(hv, "floating max offset", newSViv(data->max_offset)); 203 hv_stores(hv, "floating end shift", newSViv(data->end_shift)); 204 205 hv_stores(hv, "checking", newSVpv( 206 (!r->check_substr && !r->check_utf8) 207 ? "none" 208 : ( r->check_substr == r->substrs->data[1].substr 209 && r->check_utf8 == r->substrs->data[1].utf8_substr 210 ) 211 ? "floating" 212 : "anchored" 213 , 0)); 214 215 hv_stores(hv, "noscan", newSVbool_(r->intflags & PREGf_NOSCAN)); 216 hv_stores(hv, "isall", newSVbool_(r->extflags & RXf_CHECK_ALL)); 217 hv_stores(hv, "anchor SBOL", newSVbool_(r->intflags & PREGf_ANCH_SBOL)); 218 hv_stores(hv, "anchor MBOL", newSVbool_(r->intflags & PREGf_ANCH_MBOL)); 219 hv_stores(hv, "anchor GPOS", newSVbool_(r->intflags & PREGf_ANCH_GPOS)); 220 hv_stores(hv, "skip", newSVbool_(r->intflags & PREGf_SKIP)); 221 hv_stores(hv, "implicit", newSVbool_(r->intflags & PREGf_IMPLICIT)); 222 223 { 224 RXi_GET_DECL(r, ri); 225 if (ri->regstclass) { 226 SV* sv = newSV(0); 227 /* not Perl_regprop, we must have the DEBUGGING version */ 228 my_regprop(aTHX_ r, sv, ri->regstclass, NULL, NULL); 229 hv_stores(hv, "stclass", sv); 230 } else { 231 hv_stores(hv, "stclass", &PL_sv_undef); 232 } 233 } 234 235 RETVAL = newRV_noinc((SV *)hv); 236} 237OUTPUT: 238 RETVAL 239 240# 241# ex: set ts=8 sts=4 sw=4 et: 242# 243