/* -*- c-basic-offset:4 -*- */
#define PERL_EXT_RE_BUILD
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#define PCRE2_CODE_UNIT_WIDTH 8
#include <pcre2.h>
/* older versions: */
#ifndef PCRE2_ENDANCHORED
# define PCRE2_ENDANCHORED 0
#endif
#ifndef PCRE2_NO_JIT
# define PCRE2_NO_JIT 0
#endif
#include "PCRE2.h"
#include "regcomp.h"
#undef USE_MATCH_CONTEXT
#ifndef strEQc
# define strEQc(s, c) strEQ(s, ("" c ""))
#endif
#ifndef PERL_STATIC_INLINE
# define PERL_STATIC_INLINE static
#endif
#if PERL_VERSION <= 10
#define Perl_ck_warner Perl_warner
#endif
static char retbuf[64];
#if PERL_VERSION > 10
#define RegSV(p) SvANY(p)
#else
#define RegSV(p) (p)
#endif
static pcre2_match_context_8 *match_context = NULL;
#ifdef USE_MATCH_CONTEXT
static pcre2_jit_stack *jit_stack = NULL;
static pcre2_compile_context_8 *compile_context = NULL;
/* default is 32k already */
static pcre2_jit_stack *get_jit_stack(void)
{
if (!jit_stack)
jit_stack = pcre2_jit_stack_create(32*1024, 1024*1024, NULL);
return jit_stack;
}
#endif
REGEXP *
#if PERL_VERSION < 12
PCRE2_comp(pTHX_ const SV * const pattern, const U32 flags)
#else
PCRE2_comp(pTHX_ SV * const pattern, U32 flags)
#endif
{
REGEXP *rx;
regexp *re;
struct re_engine_pcre2_data *ridata = calloc(1, sizeof(struct re_engine_pcre2_data));
STRLEN plen;
char *exp = SvPV((SV*)pattern, plen);
U32 extflags = flags;
SV * wrapped = newSVpvn_flags("(?", 2, SVs_TEMP);
SV * wrapped_unset = newSVpvn_flags("", 0, SVs_TEMP);
/* pcre2_compile */
int errcode;
PCRE2_SIZE erroffset;
/* pcre2_pattern_info */
U32 nparens;
/* pcre_compile */
U32 options = PCRE2_DUPNAMES;
#if PERL_VERSION >= 14
/* named captures */
I32 namecount;
#endif
if (plen == 1 && exp[0] == ' ') {
/* C<split " ">, bypass the PCRE2 engine alltogether and act as perl does */
if (flags & RXf_SPLIT)
extflags |= (RXf_SKIPWHITE|RXf_WHITE);
else /* Have C<split / /> split on whitespace. / /," x y " -> (,x,y) */
extflags |= RXf_WHITE;
}
/* RXf_NULL - Have C<split //> split by characters */
if (plen == 0)
extflags |= RXf_NULL;
/* RXf_START_ONLY - Have C<split /^/> split on newlines */
else if (plen == 1 && exp[0] == '^')
extflags |= RXf_START_ONLY;
/* RXf_WHITE - Have C<split /\s+/> split on whitespace */
else if (plen == 3 && strnEQ("\\s+", exp, 3))
extflags |= RXf_WHITE;
/* bypass anchors for now. needs the 4 ->substrs buffers. */
if
#ifdef RXf_IS_ANCHORED
(flags & RXf_IS_ANCHORED) /* => 5.20 */
#else
(flags & (RXf_ANCH|RXf_ANCH_GPOS))
#endif
{
/* options |= PCRE2_ANCHORED; */ /* no \g anchors yet */
DEBUG_r(PerlIO_printf(Perl_debug_log,
"anchored \"\\g\" at 0 fallback to core\n"));
return Perl_re_compile(aTHX_ pattern, flags);
}
/* Perl modifiers to PCRE2 flags, /s is implicit and /p isn't used
* but they pose no problem so ignore them */
/* qr// stringification, TODO: (?flags:pattern) */
if (flags & RXf_PMf_FOLD) {
options |= PCRE2_CASELESS; /* /i */
sv_catpvn(wrapped, "i", 1);
}
if (flags & RXf_PMf_SINGLELINE) {
sv_catpvn(wrapped, "s", 1);
}
if (flags & RXf_PMf_EXTENDED) {
options |= PCRE2_EXTENDED; /* /x */
sv_catpvn(wrapped, "x", 1);
}
#ifdef RXf_PMf_EXTENDED_MORE
if (flags & RXf_PMf_EXTENDED_MORE) {
# ifdef PCRE2_EXTENDED_MORE
/* allow space and tab in [ ] classes */
options |= PCRE2_EXTENDED_MORE;
sv_catpvn(wrapped, "x", 1);
# else
Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "/xx ignored by pcre2");
return Perl_re_compile(aTHX_ pattern, flags);
# endif
}
#endif
if (flags & RXf_PMf_MULTILINE) {
options |= PCRE2_MULTILINE; /* /m */
sv_catpvn(wrapped, "m", 1);
}
#ifdef RXf_PMf_NOCAPTURE
if (flags & RXf_PMf_NOCAPTURE) {
options |= PCRE2_NO_AUTO_CAPTURE; /* (?: and /n */
sv_catpvn(wrapped, "n", 1);
}
#endif
/* since 5.14: */
#ifdef RXf_PMf_CHARSET
if (flags & RXf_PMf_CHARSET) {
regex_charset cs = get_regex_charset(flags);
switch (cs) {
case REGEX_UNICODE_CHARSET:
options |= (PCRE2_UTF|PCRE2_NO_UTF_CHECK);
sv_catpvn(wrapped, "u", 1);
break;
case REGEX_ASCII_RESTRICTED_CHARSET:
options |= PCRE2_NEVER_UCP; /* /a */
sv_catpvn(wrapped, "a", 1);
break;
case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
options |= PCRE2_NEVER_UTF; /* /aa */
sv_catpvn(wrapped, "aa", 2);
break;
case REGEX_DEPENDS_CHARSET:
/* /d old, problematic, pre-5.14 B<D>efault character set
behavior. Its only use is to force that old behavior. */
break;
case REGEX_LOCALE_CHARSET:
/* /l sets the character set to that of whatever B<L>ocale is in
effect at the time of the execution of the pattern match. */
/* XXX PCRE2 maketables if necessary */
Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
"/l local charset option ignored by pcre2");
return Perl_re_compile(aTHX_ pattern, flags);
}
}
#endif
/* TODO: l d c */
/* The pattern is known to be UTF-8. Perl wouldn't turn this on unless it's
* a valid UTF-8 sequence so tell PCRE2 not to check for that */
#ifdef RXf_UTF8
if (flags & RXf_UTF8)
#else
if (SvUTF8(pattern))
#endif
options |= (PCRE2_UTF|PCRE2_NO_UTF_CHECK);
ridata->ri = pcre2_compile(
(PCRE2_SPTR8)exp, plen, /* pattern */
options, /* options */
&errcode, /* errors */
&erroffset, /* error offset */
#ifdef USE_MATCH_CONTEXT
compile_context
#else
NULL
#endif
);
if (!ridata->ri) {
PCRE2_UCHAR buf[256];
/* ignore matching errors. prefer the core error */
if (errcode < 100) { /* Compile errors */
pcre2_get_error_message(errcode, buf, sizeof(buf));
Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
"PCRE2 compilation failed at offset %u: %s (%d)\n",
(unsigned)erroffset, buf, errcode);
}
return Perl_re_compile(aTHX_ pattern, flags);
} else {
ridata->match_data = pcre2_match_data_create_from_pattern(ridata->ri, NULL);
}
/* pcre2_config_8(PCRE2_CONFIG_JIT, &have_jit);
if (have_jit) */
pcre2_jit_compile(ridata->ri, PCRE2_JIT_COMPLETE); /* no partial matches */
#if PERL_VERSION >= 12
rx = (REGEXP*) newSV_type(SVt_REGEXP);
#else
Newxz(rx, 1, REGEXP);
rx->refcnt = 1;
#endif
re = RegSV(rx);
re->intflags = options;
re->extflags = extflags;
re->engine = &pcre2_engine;
if (SvCUR(wrapped_unset)) {
sv_catpvn(wrapped, "-", 1);
sv_catsv(wrapped, wrapped_unset);
}
sv_catpvn(wrapped, ":", 1);
#if PERL_VERSION > 10
re->pre_prefix = SvCUR(wrapped);
#endif
sv_catpvn(wrapped, exp, plen);
sv_catpvn(wrapped, ")", 1);
#if PERL_VERSION == 10
re->wraplen = SvCUR(wrapped);
re->wrapped = savepvn(SvPVX(wrapped), SvCUR(wrapped));
#else
RX_WRAPPED(rx) = savepvn(SvPVX(wrapped), SvCUR(wrapped));
RX_WRAPLEN(rx) = SvCUR(wrapped);
#endif
DEBUG_r(sv_dump((SV*)rx));
#if PERL_VERSION == 10
/* Preserve a copy of the original pattern */
re->prelen = (I32)plen;
re->precomp = SAVEPVN(exp, plen);
#endif
/* Store our private object */
re->pprivate = ridata;
/* If named captures are defined make rx->paren_names */
#if PERL_VERSION >= 14
(void)pcre2_pattern_info(ridata->ri, PCRE2_INFO_NAMECOUNT, &namecount);
if ((namecount <= 0) || (options & PCRE2_NO_AUTO_CAPTURE)) {
re->paren_names = NULL;
} else {
PCRE2_make_nametable(re, ridata->ri, namecount);
}
#endif
/* Check how many parens we need */
(void)pcre2_pattern_info(ridata->ri, PCRE2_INFO_CAPTURECOUNT, &nparens);
re->nparens = nparens;
#if (PERL_VERSION >= 37 && PERL_SUBVERSION >= 8)
/* this is used to support Branch Reset (?|(a)|(b)) style patterns.
* The physical buffer layout may be larger than the logical layout
*/
re->logical_nparens = nparens;
#endif
/* these are run time properties, they should be 0 after compile. They
* should only be set after execution */
re->lastparen = 0;
re->lastcloseparen = 0;
Newxz(re->offs, nparens + 1, regexp_paren_pair);
/* return the regexp */
return rx;
}
#if PERL_VERSION >= 18
/* code blocks are extracted like this:
/a(?{$a=2;$b=3;($b)=$a})b/ =>
expr: list - const 'a' + getvars + const '(?{$a=2;$b=3;($b)=$a})' + const 'b'
TODO: pat_count > 1 and !expr (t/variable_expand.t)
*/
REGEXP*
PCRE2_op_comp(pTHX_ SV ** const patternp, int pat_count,
OP *expr, const struct regexp_engine* eng,
REGEXP *old_re,
bool *is_bare_re, U32 orig_rx_flags, U32 pm_flags)
{
SV *pattern = NULL;
if (!patternp) {
OP *o = expr;
for (; !o || OP_CLASS(o) != OA_SVOP; o = o->op_next) ;
if (o && OP_CLASS(o) == OA_SVOP) {
/* having a single const op only? */
if (o->op_next == o || o->op_next->op_type == OP_LIST) {
pattern = cSVOPx_sv(o);
DEBUG_r(PerlIO_printf(Perl_debug_log,
"PCRE2 op_comp: single const op \"%" SVf "\"\n", SVfARG(pattern)));
}
else { /* no, fallback to core with codeblocks */
DEBUG_r(PerlIO_printf(Perl_debug_log,
"PCRE2 op_comp: codeblock. fallback to core\n"));
return Perl_re_op_compile
(aTHX_ patternp, pat_count, expr,
&PL_core_reg_engine,
old_re, is_bare_re, orig_rx_flags, pm_flags);
}
}
} else if (pat_count > 1) {
SV **svp;
SV *concat = newSVpvn_flags("",0,SVs_TEMP);
bool can_concat = TRUE; /* can we handle the concat patterns by ourselves? */
DEBUG_r(PerlIO_printf(Perl_debug_log,
"PCRE2 op_comp: multi pattern nargs=%d\n", pat_count));
/* concat_pat problem: if all the members are ours (even core),
concat by ourselves. #26 */
for (svp = patternp; svp < patternp + pat_count; svp++) {
SV *sv = SvROK(*svp) ? SvRV(*svp) : *svp;
if (SvTYPE(sv) == SVt_REGEXP) {
bool is_ours = RX_ENGINE((REGEXP*)sv) == &pcre2_engine;
bool is_core = RX_ENGINE((REGEXP*)sv) == &PL_core_reg_engine;
DEBUG_r(PerlIO_printf(Perl_debug_log,
" %" SVf " <%s engine>\n", SVfARG(sv),
is_core ? "core" :
is_ours ? "pcre" : "plugin"));
if (!is_ours && !is_core) /* we can concat ours and core... */
can_concat = FALSE;
if (can_concat)
sv_catsv(concat, sv);
else if (!is_core) /* convert back to core for S_concat_pat */
*svp = (SV*)re_compile(sv, pm_flags);
} else {
if (can_concat && SvPOK(sv))
sv_catsv(concat, sv);
else
can_concat = FALSE; /* ...but not others */
DEBUG_r(PerlIO_printf(Perl_debug_log,
" %" SVf "\n", SVfARG(sv)));
}
}
if (can_concat)
pattern = concat;
else
return Perl_re_op_compile(aTHX_ patternp, pat_count, expr,
&PL_core_reg_engine,
old_re, is_bare_re, orig_rx_flags, pm_flags);
} else {
pattern = *patternp;
}
DEBUG_r(PerlIO_printf(Perl_debug_log,
"PCRE2 op_comp: \"%" SVf "\" 0x%x 0x%x\n", SVfARG(pattern),
orig_rx_flags, pm_flags));
#if PERL_VERSION == 18
/* intflags missing */
return PCRE2_comp(aTHX_ pattern, orig_rx_flags);
#else
return PCRE2_comp(aTHX_ pattern, orig_rx_flags?orig_rx_flags:pm_flags);
#endif
}
#endif
I32
#if PERL_VERSION < 20
PCRE2_exec(pTHX_ REGEXP * const rx, char *stringarg, char *strend,
char *strbeg, I32 minend, SV * sv,
void *data, U32 flags)
#else
PCRE2_exec(pTHX_ REGEXP * const rx, char *stringarg, char *strend,
char *strbeg, SSize_t minend, SV * sv,
void *data, U32 flags)
#endif
{
I32 rc;
I32 i;
int have_jit;
PCRE2_SIZE *ovector;
regexp * re = RegSV(rx);
struct re_engine_pcre2_data *ridata = re->pprivate;
pcre2_code *ri = ridata->ri;
/* TODO utf8 problem: if the subject turns out to be utf8 here, but the
pattern was not compiled as utf8 aware, we'd need to recompile
it here. See GH #15 */
pcre2_config_8(PCRE2_CONFIG_JIT, &have_jit);
if (have_jit) {
#ifdef USE_MATCH_CONTEXT
match_context = pcre2_match_context_create(NULL);
/* default MATCH_LIMIT: 10000000 - uint32_t,
but even 5120000000 is not big enough for the core test suite */
/*pcre2_set_match_limit(match_context, 5120000000);*/
/*pcre2_jit_stack_assign(match_context, NULL, get_jit_stack());*/
#endif
/* Masks for identifying the public options that are permitted at match time. */
#define PUBLIC_JIT_MATCH_OPTIONS \
(PCRE2_NO_UTF_CHECK|PCRE2_NOTBOL|PCRE2_NOTEOL|PCRE2_NOTEMPTY|\
PCRE2_NOTEMPTY_ATSTART|PCRE2_PARTIAL_SOFT|PCRE2_PARTIAL_HARD)
assert(ridata->match_data);
rc = (I32)pcre2_jit_match(
ri,
(PCRE2_SPTR8)stringarg,
strend - strbeg, /* length */
stringarg - strbeg, /* offset */
re->intflags & PUBLIC_JIT_MATCH_OPTIONS,
ridata->match_data, /* block for storing the result */
match_context
);
} else {
DEBUG_r(PerlIO_printf(Perl_debug_log,
"PCRE2 skip jit match \"%.*s\" =~ /%s/\n",
(int)re->sublen, strbeg, RX_WRAPPED(rx)));
assert(ridata->match_data);
#define PUBLIC_MATCH_OPTIONS \
(PCRE2_ANCHORED|PCRE2_ENDANCHORED|PCRE2_NOTBOL|PCRE2_NOTEOL|PCRE2_NOTEMPTY| \
PCRE2_NOTEMPTY_ATSTART|PCRE2_NO_UTF_CHECK|PCRE2_PARTIAL_HARD| \
PCRE2_PARTIAL_SOFT|PCRE2_NO_JIT)
rc = (I32)pcre2_match(
ri,
(PCRE2_SPTR8)stringarg,
strend - strbeg, /* length */
stringarg - strbeg, /* offset */
re->intflags & PUBLIC_MATCH_OPTIONS,
ridata->match_data, /* block for storing the result */
match_context
);
}
/* Matching failed */
if (rc < 0) {
#ifdef USE_MATCH_CONTEXT
if (have_jit && match_context)
pcre2_match_context_free(match_context);
#endif
if (rc != PCRE2_ERROR_NOMATCH) {
PCRE2_UCHAR buf[256];
pcre2_get_error_message(rc, buf, sizeof(buf));
Perl_croak(aTHX_ "PCRE2 match error: %s (%d)\n", buf, (int)rc);
}
return 0;
}
re->sublen = strend - strbeg;
re->subbeg = savepvn(strbeg, re->sublen);
rc = pcre2_get_ovector_count(ridata->match_data);
ovector = pcre2_get_ovector_pointer(ridata->match_data);
DEBUG_r(PerlIO_printf(Perl_debug_log,
"PCRE2 match \"%.*s\" =~ /%s/: found %d matches\n",
(int)re->sublen, strbeg, RX_WRAPPED(rx), rc-1));
re->lastparen = rc - 1;
re->lastcloseparen = rc -1;
for (i = 0; i < rc; i++) {
re->offs[i].start = ovector[i * 2];
re->offs[i].end = ovector[i * 2 + 1];
DEBUG_r(PerlIO_printf(Perl_debug_log,
"match[%d]: \"%.*s\" [%d,%d]\n",
i, (int)(re->offs[i].end - re->offs[i].start), &stringarg[re->offs[i].start],
(int)re->offs[i].start, (int)re->offs[i].end));
}
for (i = rc; i <= re->nparens; i++) {
re->offs[i].start = -1;
re->offs[i].end = -1;
}
/* XXX: nparens needs to be set to CAPTURECOUNT */
#ifdef USE_MATCH_CONTEXT
if (have_jit && match_context)
pcre2_match_context_free(match_context);
#endif
return 1;
}
char *
#if PERL_VERSION < 20
PCRE2_intuit(pTHX_ REGEXP * const rx, SV * sv,
char *strpos, char *strend, const U32 flags, re_scream_pos_data *data)
#else
PCRE2_intuit(pTHX_ REGEXP * const rx, SV * sv, const char *strbeg,
char *strpos, char *strend, U32 flags, re_scream_pos_data *data)
#endif
{
PERL_UNUSED_ARG(rx);
PERL_UNUSED_ARG(sv);
#if PERL_VERSION >= 20
PERL_UNUSED_ARG(strbeg);
#endif
PERL_UNUSED_ARG(strpos);
PERL_UNUSED_ARG(strend);
PERL_UNUSED_ARG(flags);
PERL_UNUSED_ARG(data);
return NULL;
}
SV *
PCRE2_checkstr(pTHX_ REGEXP * const rx)
{
PERL_UNUSED_ARG(rx);
return NULL;
}
void
PCRE2_free(pTHX_ REGEXP * const rx)
{
regexp *re = RegSV(rx);
struct re_engine_pcre2_data *ridata = re->pprivate;
pcre2_code *ri = ridata->ri;
pcre2_code_free(ri);
pcre2_match_data_free(ridata->match_data);
free(ridata);
}
void *
PCRE2_dupe(pTHX_ REGEXP * const rx, CLONE_PARAMS *param)
{
PERL_UNUSED_ARG(param);
regexp *re = RegSV(rx);
return re->pprivate;
}
SV *
PCRE2_package(pTHX_ REGEXP * const rx)
{
PERL_UNUSED_ARG(rx);
return newSVpvs("re::engine::PCRE2");
}
/*
* Internal utility functions
*/
#if PERL_VERSION >= 14
void
PCRE2_make_nametable(regexp * const re, pcre2_code * const ri, const I32 namecount)
{
unsigned char *name_table, *tabptr;
U32 name_entry_size;
int i;
/* The name table */
(void)pcre2_pattern_info(ri, PCRE2_INFO_NAMETABLE, &name_table);
/* Size of each entry */
(void)pcre2_pattern_info(ri, PCRE2_INFO_NAMEENTRYSIZE, &name_entry_size);
re->paren_names = newHV();
tabptr = name_table;
for (i = 0; i < namecount; i++) {
const char *key = (char*)tabptr + 2;
I32 npar = (tabptr[0] << 8) | tabptr[1]; /* the groupno (little endian only?) */
SV *sv = *hv_fetch(re->paren_names, key, strlen(key), TRUE);
if (!sv)
Perl_croak(aTHX_ "panic: paren_name hash element allocation failed");
if (!SvPOK(sv)) {
/* The first (and maybe only) entry with this name */
(void)SvUPGRADE(sv, SVt_PVIV);
/* buffer of I32 groupno */
sv_setpvn(sv, (char *)&(npar), sizeof(I32));
SvIOK_on(sv);
SvIVX(sv) = 1;
} else {
/* duplicate names: An entry under this name has appeared before, append */
IV count = SvIV(sv);
STRLEN len = SvCUR(sv);
I32 *pv = (I32*)SvPVX_const(sv);
IV j;
assert(count < namecount);
assert(count <= len*sizeof(I32));
for (j = 0; j < count; j++) {
if (pv[j] == npar) {
count = 0;
break;
}
}
if (count) {
pv = (I32*)SvGROW(sv, len + sizeof(I32)+1);
SvCUR_set(sv, len + sizeof(I32));
pv[count] = npar;
SvIVX(sv)++;
}
}
tabptr += name_entry_size;
}
}
#endif
/* Note: some pcre versions overwrite the uint32_t value, esp. size.
because some values are longer, size_t vs u32! */
#define DECL_U32_PATTERN_INFO(rx,name,UCNAME) \
PERL_STATIC_INLINE U32 \
PCRE2_##name(REGEXP* rx) { \
regexp *re = RegSV(rx); \
struct re_engine_pcre2_data *ridata = re->pprivate; \
pcre2_code *ri = ridata->ri; \
U32 retval = -1; \
pcre2_pattern_info(ri, PCRE2_INFO_##UCNAME, &retval); \
return retval; \
}
#define DECL_UV_PATTERN_INFO(rx,name,UCNAME) \
PERL_STATIC_INLINE UV \
PCRE2_##name(REGEXP* rx) { \
regexp *re = RegSV(rx); \
struct re_engine_pcre2_data *ridata = re->pprivate; \
pcre2_code *ri = ridata->ri; \
size_t retval = 0; \
pcre2_pattern_info(ri, PCRE2_INFO_##UCNAME, &retval); \
return (UV)retval; \
}
#define DECL_UNDEF_PATTERN_INFO(rx,name,UCNAME) \
PERL_STATIC_INLINE UV \
PCRE2_##name(REGEXP* rx) { \
return (UV)-1; \
}
DECL_U32_PATTERN_INFO(rx, _alloptions, ALLOPTIONS)
DECL_U32_PATTERN_INFO(rx, _argoptions, ARGOPTIONS)
DECL_U32_PATTERN_INFO(rx, backrefmax, BACKREFMAX)
DECL_U32_PATTERN_INFO(rx, bsr, BSR)
DECL_U32_PATTERN_INFO(rx, capturecount, CAPTURECOUNT)
DECL_U32_PATTERN_INFO(rx, firstcodetype, FIRSTCODETYPE)
DECL_U32_PATTERN_INFO(rx, firstcodeunit, FIRSTCODEUNIT)
#ifdef PCRE2_INFO_HASBACKSLASHC
DECL_U32_PATTERN_INFO(rx, hasbackslashc, HASBACKSLASHC)
#endif
DECL_U32_PATTERN_INFO(rx, hascrorlf, HASCRORLF)
#ifdef PCRE2_INFO_HEAPLIMIT
DECL_U32_PATTERN_INFO(rx, heaplimit, HEAPLIMIT)
#endif
DECL_U32_PATTERN_INFO(rx, jchanged, JCHANGED)
DECL_U32_PATTERN_INFO(rx, lastcodetype, LASTCODETYPE)
DECL_U32_PATTERN_INFO(rx, lastcodeunit, LASTCODEUNIT)
DECL_U32_PATTERN_INFO(rx, matchempty, MATCHEMPTY)
DECL_U32_PATTERN_INFO(rx, matchlimit, MATCHLIMIT)
DECL_U32_PATTERN_INFO(rx, maxlookbehind, MAXLOOKBEHIND)
DECL_U32_PATTERN_INFO(rx, minlength, MINLENGTH)
DECL_U32_PATTERN_INFO(rx, namecount, NAMECOUNT)
DECL_U32_PATTERN_INFO(rx, nameentrysize, NAMEENTRYSIZE)
DECL_U32_PATTERN_INFO(rx, newline, NEWLINE)
DECL_U32_PATTERN_INFO(rx, recursionlimit, RECURSIONLIMIT)
DECL_UV_PATTERN_INFO(rx, size, SIZE)
DECL_UV_PATTERN_INFO(rx, jitsize, JITSIZE)
#ifdef PCRE2_INFO_FRAMESIZE
DECL_UV_PATTERN_INFO(rx, framesize, FRAMESIZE)
#endif
MODULE = re::engine::PCRE2 PACKAGE = re::engine::PCRE2 PREFIX = PCRE2_
PROTOTYPES: ENABLE
void
PCRE2_ENGINE(...)
PROTOTYPE:
PPCODE:
mXPUSHs(newSViv(PTR2IV(&pcre2_engine)));
# pattern options
#if 0
void
debug(REGEXP *rx, bool print_lengths=1)
CODE:
regexp *re = RegSV(rx);
pcre2_code *ri = (pcre2_code *)re->pprivate;
FILE *f = stdout;
pcre2_printint_8(ri,f,print_lengths);
#endif
U32
PCRE2__alloptions(REGEXP *rx)
U32
PCRE2__argoptions(REGEXP *rx)
U32
PCRE2_backrefmax(REGEXP *rx)
U32
PCRE2_bsr(REGEXP *rx)
CODE:
RETVAL = PCRE2_bsr(rx);
if (RETVAL == (U32)-1)
XSRETURN_UNDEF;
OUTPUT:
RETVAL
U32
PCRE2_capturecount(REGEXP *rx)
# returns a 256-bit table
void
firstbitmap(REGEXP *rx)
CODE:
char* table;
regexp *re = RegSV(rx);
struct re_engine_pcre2_data *ridata = re->pprivate;
pcre2_code *ri = ridata->ri;
pcre2_pattern_info(ri, PCRE2_INFO_FIRSTBITMAP, &table);
if (table) {
ST(0) = sv_2mortal(newSVpvn(table, 256/8));
XSRETURN(1);
}
XSRETURN_UNDEF;
U32
PCRE2_firstcodetype(REGEXP *rx)
U32
PCRE2_firstcodeunit(REGEXP *rx)
void
PCRE2_framesize(REGEXP *rx)
PPCODE:
#ifdef PCRE2_INFO_FRAMESIZE
mXPUSHu(PCRE2_framesize(rx));
#else
PERL_UNUSED_VAR(rx);
XSRETURN_UNDEF;
#endif
void
PCRE2_hasbackslashc(REGEXP *rx)
PPCODE:
#ifdef PCRE2_INFO_HASBACKSLASHC
mXPUSHu(PCRE2_hasbackslashc(rx));
#else
XSRETURN_UNDEF;
#endif
U32
PCRE2_hascrorlf(REGEXP *rx)
void
heaplimit(REGEXP *rx, U32 value=0)
PPCODE:
#ifdef PCRE2_INFO_HEAPLIMIT
if (items == 2 && match_context)
pcre2_set_heap_limit(match_context, (PCRE2_SIZE)value);
mXPUSHu(PCRE2_heaplimit(rx));
#else
PERL_UNUSED_VAR(rx);
PERL_UNUSED_VAR(value);
XSRETURN_UNDEF;
#endif
U32
PCRE2_jchanged(REGEXP *rx)
UV
PCRE2_jitsize(REGEXP *rx)
UV
PCRE2_size(REGEXP *rx)
U32
PCRE2_lastcodetype(REGEXP *rx)
U32
PCRE2_lastcodeunit(REGEXP *rx)
U32
PCRE2_matchempty(REGEXP *rx)
U32
matchlimit(REGEXP *rx, U32 value=0)
CODE:
PERL_UNUSED_VAR(value);
if (items == 2)
croak("matchlimit setter nyi");
RETVAL = PCRE2_matchlimit(rx);
if (RETVAL == (U32)-1)
XSRETURN_UNDEF;
OUTPUT:
RETVAL
U32
PCRE2_maxlookbehind(REGEXP *rx)
U32
PCRE2_minlength(REGEXP *rx)
U32
PCRE2_namecount(REGEXP *rx)
U32
PCRE2_nameentrysize(REGEXP *rx)
#if 0
SV*
nametable(REGEXP *rx)
PROTOTYPE: $
PPCODE:
U8* table;
regexp *re = RegSV(rx);
struct re_engine_pcre2_data *ridata = re->pprivate;
pcre2_code *ri = ridata->ri;
pcre2_pattern_info(ri, PCRE2_INFO_NAMETABLE, &RETVAL);
if (table)
ST(0) = sv_2mortal(newSVpvn(table, strlen(table)));
#endif
U32
PCRE2_newline(REGEXP *rx)
U32
recursionlimit(REGEXP *rx, U32 value=0)
CODE:
if (items == 2 && match_context)
/* name changed from set_recursion_limit at Mar 12 2017 with 10.30 */
#if PCRE2_MINOR>=30 && defined(pcre2_code_copy_with_tables)
pcre2_set_depth_limit(match_context, (PCRE2_SIZE)value);
#else
pcre2_set_recursion_limit(match_context, (PCRE2_SIZE)value);
#endif
RETVAL = PCRE2_recursionlimit(rx);
if (RETVAL == (U32)-1)
XSRETURN_UNDEF;
OUTPUT:
RETVAL
# better check with rx->alloptions & PCRE2_USE_OFFSET_LIMIT
U32
offsetlimit(U32 value=0)
CODE:
if (match_context) {
if (items == 1)
pcre2_set_offset_limit(match_context, (PCRE2_SIZE)value);
#ifdef USE_MATCH_CONTEXT
RETVAL = match_context->offset_limit;
#endif
} else {
XSRETURN_UNDEF;
}
OUTPUT:
RETVAL
void
PCRE2_JIT(...)
PROTOTYPE:
PPCODE:
uint32_t jit;
if (pcre2_config(PCRE2_CONFIG_JIT, &jit) < 0)
XSRETURN_UNDEF;
mXPUSHi(jit ? 1 : 0);
XSRETURN(1);
#define RET_STR(name) \
if (strEQc(opt, #name)) { \
if (pcre2_config(PCRE2_CONFIG_##name, &retbuf) >= 0) { \
ST(0) = sv_2mortal(newSVpvn(retbuf, strlen(retbuf))); \
} else { \
XSRETURN_UNDEF; \
} \
XSRETURN(1); \
}
#define RET_INT(name) \
if (strEQc(opt, #name)) { \
if (pcre2_config(PCRE2_CONFIG_##name, &retint) >= 0) { \
ST(0) = sv_2mortal(newSViv(retint)); \
} else { \
XSRETURN_UNDEF; \
} \
XSRETURN(1); \
}
#define RET_NO(name) \
if (strEQc(opt, #name)) { \
XSRETURN_UNDEF; \
}
void
PCRE2_config(char* opt)
PROTOTYPE: $
PPCODE:
int retint;
RET_STR(JITTARGET) else
RET_STR(UNICODE_VERSION) else
RET_STR(VERSION) else
RET_INT(BSR) else
RET_INT(JIT) else
RET_INT(LINKSIZE) else
RET_INT(MATCHLIMIT) else
RET_INT(NEWLINE) else
RET_INT(PARENSLIMIT) else
RET_INT(UNICODE)
#ifdef PCRE2_CONFIG_DEPTHLIMIT
RET_INT(DEPTHLIMIT) else
#else
RET_NO(DEPTHLIMIT) else
#endif
#ifdef PCRE2_CONFIG_RECURSIONLIMIT
RET_INT(RECURSIONLIMIT) else /* Obsolete synonym */
#else
RET_NO(RECURSIONLIMIT) else
#endif
#ifdef PCRE2_CONFIG_STACKRECURSE
RET_INT(STACKRECURSE) else /* Obsolete. Always 0 in newer libs */
#else
RET_NO(STACKRECURSE) else
#endif
#ifdef PCRE2_CONFIG_HEAPLIMIT
RET_INT(HEAPLIMIT) else /* Since 10.30 only */
#else
RET_NO(HEAPLIMIT) else
#endif
Perl_croak(aTHX_ "Invalid config argument %s", opt);