* regular-expression syntax might require a total rethink.
*/
#include "EXTERN.h"
+#define PERL_IN_REGCOMP_C
#include "perl.h"
#ifndef PERL_IN_XSUB_RE
* Forward declarations for pregcomp()'s friends.
*/
-#ifndef PERL_OBJECT
-static regnode *reg _((I32, I32 *));
-static regnode *reganode _((U8, U32));
-static regnode *regatom _((I32 *));
-static regnode *regbranch _((I32 *, I32));
-static void regc _((U8, char *));
-static void reguni _((UV, char *, I32*));
-static regnode *regclass _((void));
-static regnode *regclassutf8 _((void));
-STATIC I32 regcurly _((char *));
-static regnode *reg_node _((U8));
-static regnode *regpiece _((I32 *));
-static void reginsert _((U8, regnode *));
-static void regoptail _((regnode *, regnode *));
-static void regtail _((regnode *, regnode *));
-static char* regwhite _((char *, char *));
-static char* nextchar _((void));
-static void re_croak2 _((const char* pat1,const char* pat2,...)) __attribute__((noreturn));
-static char* regpposixcc _((I32 value));
-static void clear_re _((void *r));
-#endif
-
-/* Length of a variant. */
-
-#ifndef PERL_OBJECT
-typedef struct {
- I32 len_min;
- I32 len_delta;
- I32 pos_min; /* CC */
- I32 pos_delta; /* CC */
- SV *last_found;
- I32 last_end; /* min value, <0 unless valid. */
- I32 last_start_min; /* CC */
- I32 last_start_max; /* CC */
- SV **longest; /* Either &l_fixed, or &l_float. */
- SV *longest_fixed;
- I32 offset_fixed; /* CC */
- SV *longest_float;
- I32 offset_float_min; /* CC */
- I32 offset_float_max; /* CC */
- I32 flags;
-} scan_data_t;
-#endif
-
static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0 };
#define CHR_DIST(a,b) (UTF ? utf8_distance(a,b) : a - b)
STATIC void
-clear_re(void *r)
+S_clear_re(pTHX_ void *r)
{
ReREFCNT_dec((regexp *)r);
}
STATIC void
-scan_commit(scan_data_t *data)
+S_scan_commit(pTHX_ scan_data_t *data)
{
dTHR;
STRLEN l = CHR_SVLEN(data->last_found);
to the position after last scanned or to NULL. */
STATIC I32
-study_chunk(regnode **scanp, I32 *deltap, regnode *last, scan_data_t *data, U32 flags)
+S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *data, U32 flags)
/* scanp: Start here (read-write). */
/* deltap: Write maxlen-minlen here. */
/* last: Stop before this one. */
if (ckWARN(WARN_UNSAFE) && (minnext + deltanext == 0)
&& !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
&& maxcount <= REG_INFTY/3) /* Complement check for big count */
- warner(WARN_UNSAFE, "Strange *+?{} on zero-length expression");
+ Perl_warner(aTHX_ WARN_UNSAFE, "Strange *+?{} on zero-length expression");
min += minnext * mincount;
is_inf_internal |= (maxcount == REG_INFTY
&& (minnext + deltanext) > 0
}
STATIC I32
-add_data(I32 n, char *s)
+S_add_data(pTHX_ I32 n, char *s)
{
dTHR;
if (PL_regcomp_rx->data) {
}
void
-reginitcolors(void)
+Perl_reginitcolors(pTHX)
{
dTHR;
int i = 0;
* of the structure of the compiled regexp. [I'll say.]
*/
regexp *
-pregcomp(char *exp, char *xend, PMOP *pm)
+Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
{
dTHR;
register regexp *r;
r->refcnt = 1;
r->prelen = xend - exp;
r->precomp = PL_regprecomp;
- r->subbeg = r->subbase = NULL;
+ r->subbeg = NULL;
+ r->reganch = pm->op_pmflags & PMf_COMPILETIME;
r->nparens = PL_regnpar - 1; /* set early to validate backrefs */
r->substrs = 0; /* Useful during FAIL. */
return(NULL);
/* Dig out information for optimizations. */
- r->reganch = pm->op_pmflags & PMf_COMPILETIME;
+ r->reganch = pm->op_pmflags & PMf_COMPILETIME; /* Again? */
pm->op_pmflags = PL_regflags;
if (UTF)
r->reganch |= ROPT_UTF8;
|| (data.flags & SF_FL_BEFORE_EOL
&& (!(data.flags & SF_FL_BEFORE_MEOL)
|| (PL_regflags & PMf_MULTILINE)))) {
+ int t;
+
if (SvCUR(data.longest_fixed) /* ok to leave SvCUR */
&& data.offset_fixed == data.offset_float_min
&& SvCUR(data.longest_fixed) == SvCUR(data.longest_float))
r->float_substr = data.longest_float;
r->float_min_offset = data.offset_float_min;
r->float_max_offset = data.offset_float_max;
- fbm_compile(r->float_substr, 0);
- BmUSEFUL(r->float_substr) = 100;
- if (data.flags & SF_FL_BEFORE_EOL /* Cannot have SEOL and MULTI */
- && (!(data.flags & SF_FL_BEFORE_MEOL)
- || (PL_regflags & PMf_MULTILINE)))
- SvTAIL_on(r->float_substr);
+ t = (data.flags & SF_FL_BEFORE_EOL /* Can't have SEOL and MULTI */
+ && (!(data.flags & SF_FL_BEFORE_MEOL)
+ || (PL_regflags & PMf_MULTILINE)));
+ fbm_compile(r->float_substr, t ? FBMcf_TAIL : 0);
}
else {
remove_float:
|| (data.flags & SF_FIX_BEFORE_EOL /* Cannot have SEOL and MULTI */
&& (!(data.flags & SF_FIX_BEFORE_MEOL)
|| (PL_regflags & PMf_MULTILINE)))) {
+ int t;
+
r->anchored_substr = data.longest_fixed;
r->anchored_offset = data.offset_fixed;
- fbm_compile(r->anchored_substr, 0);
- BmUSEFUL(r->anchored_substr) = 100;
- if (data.flags & SF_FIX_BEFORE_EOL /* Cannot have SEOL and MULTI */
- && (!(data.flags & SF_FIX_BEFORE_MEOL)
- || (PL_regflags & PMf_MULTILINE)))
- SvTAIL_on(r->anchored_substr);
+ t = (data.flags & SF_FIX_BEFORE_EOL /* Can't have SEOL and MULTI */
+ && (!(data.flags & SF_FIX_BEFORE_MEOL)
+ || (PL_regflags & PMf_MULTILINE)));
+ fbm_compile(r->anchored_substr, t ? FBMcf_TAIL : 0);
}
else {
r->anchored_substr = Nullsv;
r->reganch |= ROPT_LOOKBEHIND_SEEN;
if (PL_regseen & REG_SEEN_EVAL)
r->reganch |= ROPT_EVAL_SEEN;
- Newz(1002, r->startp, PL_regnpar, char*);
- Newz(1002, r->endp, PL_regnpar, char*);
+ Newz(1002, r->startp, PL_regnpar, I32);
+ Newz(1002, r->endp, PL_regnpar, I32);
DEBUG_r(regdump(r));
return(r);
}
* follows makes it hard to avoid.
*/
STATIC regnode *
-reg(I32 paren, I32 *flagp)
+S_reg(pTHX_ I32 paren, I32 *flagp)
/* paren: Parenthesized? 0=top, 1=(, inside: changed to letter. */
{
dTHR;
* Implements the concatenation operator.
*/
STATIC regnode *
-regbranch(I32 *flagp, I32 first)
+S_regbranch(pTHX_ I32 *flagp, I32 first)
{
dTHR;
register regnode *ret;
* endmarker role is not redundant.
*/
STATIC regnode *
-regpiece(I32 *flagp)
+S_regpiece(pTHX_ I32 *flagp)
{
dTHR;
register regnode *ret;
}
nest_check:
if (ckWARN(WARN_UNSAFE) && !SIZE_ONLY && !(flags&HASWIDTH) && max > REG_INFTY/3) {
- warner(WARN_UNSAFE, "%.*s matches null string many times",
+ Perl_warner(aTHX_ WARN_UNSAFE, "%.*s matches null string many times",
PL_regcomp_parse - origparse, origparse);
}
* [Yes, it is worth fixing, some scripts can run twice the speed.]
*/
STATIC regnode *
-regatom(I32 *flagp)
+S_regatom(pTHX_ I32 *flagp)
{
dTHR;
register regnode *ret = 0;
/* FALL THROUGH */
default:
if (!SIZE_ONLY && ckWARN(WARN_UNSAFE) && isALPHA(*p))
- warner(WARN_UNSAFE,
+ Perl_warner(aTHX_ WARN_UNSAFE,
"/%.127s/: Unrecognized escape \\%c passed through",
PL_regprecomp,
*p);
}
STATIC char *
-regwhite(char *p, char *e)
+S_regwhite(pTHX_ char *p, char *e)
{
while (p < e) {
if (isSPACE(*p))
/* parse POSIX character classes like [[:foo:]] */
STATIC char*
-regpposixcc(I32 value)
+S_regpposixcc(pTHX_ I32 value)
{
dTHR;
char *posixcc = 0;
* The text between e.g. [: and :] would start
* at s + 1 and stop at regcomp_parse - 2. */
if (ckWARN(WARN_UNSAFE) && !SIZE_ONLY)
- warner(WARN_UNSAFE,
+ Perl_warner(aTHX_ WARN_UNSAFE,
"Character class syntax [%c %c] is reserved for future extensions", c, c);
PL_regcomp_parse++; /* skip over the ending ] */
posixcc = s + 1;
}
STATIC regnode *
-regclass(void)
+S_regclass(pTHX)
{
dTHR;
register char *opnd, *s;
}
STATIC regnode *
-regclassutf8(void)
+S_regclassutf8(pTHX)
{
register char *opnd, *e;
register U32 value;
if (LOC)
flags |= ANYOF_ALNUML;
- sv_catpvf(listsv, "+utf8::IsAlnum\n");
+ Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsAlnum\n");
}
lastvalue = 123456;
continue;
if (LOC)
flags |= ANYOF_NALNUML;
- sv_catpvf(listsv,
+ Perl_sv_catpvf(aTHX_ listsv,
"-utf8::IsAlpha\n-utf8::IsDigit\n0000\t%04x\n%04x\tffff\n",
'_' - 1,
'_' + 1);
if (!SIZE_ONLY) {
if (LOC)
flags |= ANYOF_SPACEL;
- sv_catpvf(listsv, "+utf8::IsSpace\n");
+ Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsSpace\n");
if (!PL_utf8_space)
is_utf8_space((U8*)" ");
}
if (!SIZE_ONLY) {
if (LOC)
flags |= ANYOF_NSPACEL;
- sv_catpvf(listsv,
+ Perl_sv_catpvf(aTHX_ listsv,
"!utf8::IsSpace\n");
if (!PL_utf8_space)
is_utf8_space((U8*)" ");
continue;
case 'd':
if (!SIZE_ONLY) {
- sv_catpvf(listsv, "+utf8::IsDigit\n");
+ Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsDigit\n");
}
lastvalue = 123456;
continue;
case 'D':
if (!SIZE_ONLY) {
- sv_catpvf(listsv,
+ Perl_sv_catpvf(aTHX_ listsv,
"!utf8::IsDigit\n");
}
lastvalue = 123456;
}
if (!SIZE_ONLY) {
if (value == 'p')
- sv_catpvf(listsv, "+utf8::%.*s\n", n, PL_regcomp_parse);
+ Perl_sv_catpvf(aTHX_ listsv, "+utf8::%.*s\n", n, PL_regcomp_parse);
else
- sv_catpvf(listsv,
+ Perl_sv_catpvf(aTHX_ listsv,
"!utf8::%.*s\n", n, PL_regcomp_parse);
}
PL_regcomp_parse = e + 1;
if (lastvalue > value)
FAIL("invalid [] range in regexp");
if (!SIZE_ONLY)
- sv_catpvf(listsv, "%04x\t%04x\n", lastvalue, value);
+ Perl_sv_catpvf(aTHX_ listsv, "%04x\t%04x\n", lastvalue, value);
lastvalue = value;
range = 0;
}
continue; /* do it next time */
}
if (!SIZE_ONLY)
- sv_catpvf(listsv, "%04x\n", value);
+ Perl_sv_catpvf(aTHX_ listsv, "%04x\n", value);
}
}
}
STATIC char*
-nextchar(void)
+S_nextchar(pTHX)
{
dTHR;
char* retval = PL_regcomp_parse++;
- reg_node - emit a node
*/
STATIC regnode * /* Location. */
-reg_node(U8 op)
+S_reg_node(pTHX_ U8 op)
{
dTHR;
register regnode *ret;
- reganode - emit a node with an argument
*/
STATIC regnode * /* Location. */
-reganode(U8 op, U32 arg)
+S_reganode(pTHX_ U8 op, U32 arg)
{
dTHR;
register regnode *ret;
- regc - emit (if appropriate) a Unicode character
*/
STATIC void
-reguni(UV uv, char* s, I32* lenp)
+S_reguni(pTHX_ UV uv, char* s, I32* lenp)
{
dTHR;
if (SIZE_ONLY) {
- regc - emit (if appropriate) a byte of code
*/
STATIC void
-regc(U8 b, char* s)
+S_regc(pTHX_ U8 b, char* s)
{
dTHR;
if (!SIZE_ONLY)
* Means relocating the operand.
*/
STATIC void
-reginsert(U8 op, regnode *opnd)
+S_reginsert(pTHX_ U8 op, regnode *opnd)
{
dTHR;
register regnode *src;
- regtail - set the next-pointer at the end of a node chain of p to val.
*/
STATIC void
-regtail(regnode *p, regnode *val)
+S_regtail(pTHX_ regnode *p, regnode *val)
{
dTHR;
register regnode *scan;
- regoptail - regtail on operand of first argument; nop if operandless
*/
STATIC void
-regoptail(regnode *p, regnode *val)
+S_regoptail(pTHX_ regnode *p, regnode *val)
{
dTHR;
/* "Operandless" and "op != BRANCH" are synonymous in practice. */
- regcurly - a little FSA that accepts {\d+,?\d*}
*/
STATIC I32
-regcurly(register char *s)
+S_regcurly(pTHX_ register char *s)
{
if (*s++ != '{')
return FALSE;
STATIC regnode *
-dumpuntil(regnode *start, regnode *node, regnode *last, SV* sv, I32 l)
+S_dumpuntil(pTHX_ regnode *start, regnode *node, regnode *last, SV* sv, I32 l)
{
#ifdef DEBUGGING
register char op = EXACT; /* Arbitrary non-END op. */
- regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
*/
void
-regdump(regexp *r)
+Perl_regdump(pTHX_ regexp *r)
{
#ifdef DEBUGGING
dTHR;
- regprop - printable representation of opcode
*/
void
-regprop(SV *sv, regnode *o)
+Perl_regprop(pTHX_ SV *sv, regnode *o)
{
#ifdef DEBUGGING
dTHR;
- register char *p = 0;
+ register int k;
sv_setpvn(sv, "", 0);
- switch (OP(o)) {
- case BOL:
- p = "BOL";
- break;
- case MBOL:
- p = "MBOL";
- break;
- case SBOL:
- p = "SBOL";
- break;
- case EOL:
- p = "EOL";
- break;
- case EOS:
- p = "EOS";
- break;
- case MEOL:
- p = "MEOL";
- break;
- case SEOL:
- p = "SEOL";
- break;
- case REG_ANY:
- p = "ANY";
- break;
- case SANY:
- p = "SANY";
- break;
- case ANYUTF8:
- p = "ANYUTF8";
- break;
- case SANYUTF8:
- p = "SANYUTF8";
- break;
- case ANYOFUTF8:
- p = "ANYOFUTF8";
- break;
- case ANYOF:
- p = "ANYOF";
- break;
- case BRANCH:
- p = "BRANCH";
- break;
- case EXACT:
- sv_catpvf(sv, "EXACT <%s%s%s>", PL_colors[0], OPERAND(o) + 1, PL_colors[1]);
- break;
- case EXACTF:
- sv_catpvf(sv, "EXACTF <%s%s%s>", PL_colors[0], OPERAND(o) + 1, PL_colors[1]);
- break;
- case EXACTFL:
- sv_catpvf(sv, "EXACTFL <%s%s%s>", PL_colors[0], OPERAND(o) + 1, PL_colors[1]);
- break;
- case NOTHING:
- p = "NOTHING";
- break;
- case TAIL:
- p = "TAIL";
- break;
- case BACK:
- p = "BACK";
- break;
- case END:
- p = "END";
- break;
- case BOUND:
- p = "BOUND";
- break;
- case BOUNDL:
- p = "BOUNDL";
- break;
- case NBOUND:
- p = "NBOUND";
- break;
- case NBOUNDL:
- p = "NBOUNDL";
- break;
- case CURLY:
- sv_catpvf(sv, "CURLY {%d,%d}", ARG1(o), ARG2(o));
- break;
- case CURLYM:
- sv_catpvf(sv, "CURLYM[%d] {%d,%d}", o->flags, ARG1(o), ARG2(o));
- break;
- case CURLYN:
- sv_catpvf(sv, "CURLYN[%d] {%d,%d}", o->flags, ARG1(o), ARG2(o));
- break;
- case CURLYX:
- sv_catpvf(sv, "CURLYX {%d,%d}", ARG1(o), ARG2(o));
- break;
- case REF:
- sv_catpvf(sv, "REF%d", ARG(o));
- break;
- case REFF:
- sv_catpvf(sv, "REFF%d", ARG(o));
- break;
- case REFFL:
- sv_catpvf(sv, "REFFL%d", ARG(o));
- break;
- case OPEN:
- sv_catpvf(sv, "OPEN%d", ARG(o));
- break;
- case CLOSE:
- sv_catpvf(sv, "CLOSE%d", ARG(o));
- p = NULL;
- break;
- case STAR:
- p = "STAR";
- break;
- case PLUS:
- p = "PLUS";
- break;
- case MINMOD:
- p = "MINMOD";
- break;
- case GPOS:
- p = "GPOS";
- break;
- case UNLESSM:
- sv_catpvf(sv, "UNLESSM[-%d]", o->flags);
- break;
- case IFMATCH:
- sv_catpvf(sv, "IFMATCH[-%d]", o->flags);
- break;
- case SUCCEED:
- p = "SUCCEED";
- break;
- case WHILEM:
- p = "WHILEM";
- break;
- case DIGIT:
- p = "DIGIT";
- break;
- case NDIGIT:
- p = "NDIGIT";
- break;
- case ALNUM:
- p = "ALNUM";
- break;
- case NALNUM:
- p = "NALNUM";
- break;
- case SPACE:
- p = "SPACE";
- break;
- case NSPACE:
- p = "NSPACE";
- break;
- case ALNUML:
- p = "ALNUML";
- break;
- case NALNUML:
- p = "NALNUML";
- break;
- case SPACEL:
- p = "SPACEL";
- break;
- case NSPACEL:
- p = "NSPACEL";
- break;
- case EVAL:
- p = "EVAL";
- break;
- case LONGJMP:
- p = "LONGJMP";
- break;
- case BRANCHJ:
- p = "BRANCHJ";
- break;
- case IFTHEN:
- p = "IFTHEN";
- break;
- case GROUPP:
- sv_catpvf(sv, "GROUPP%d", ARG(o));
- break;
- case LOGICAL:
- sv_catpvf(sv, "LOGICAL[%d]", o->flags);
- break;
- case SUSPEND:
- p = "SUSPEND";
- break;
- case RENUM:
- p = "RENUM";
- break;
- case OPTIMIZED:
- p = "OPTIMIZED";
- break;
- default:
+ if (OP(o) >= reg_num) /* regnode.type is unsigned */
FAIL("corrupted regexp opcode");
+ sv_catpv(sv, (char*)reg_name[OP(o)]); /* Take off const! */
+
+ k = PL_regkind[(U8)OP(o)];
+
+ if (k == EXACT)
+ Perl_sv_catpvf(aTHX_ sv, " <%s%s%s>", PL_colors[0], OPERAND(o) + 1, PL_colors[1]);
+ else if (k == CURLY) {
+ if (OP(o) == CURLYM || OP(o) == CURLYN)
+ Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
+ Perl_sv_catpvf(aTHX_ sv, " {%d,%d}", ARG1(o), ARG2(o));
}
- if (p)
- sv_catpv(sv, p);
+ else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP )
+ Perl_sv_catpvf(aTHX_ sv, "%d", ARG(o)); /* Parenth number */
+ else if (k == LOGICAL)
+ Perl_sv_catpvf(aTHX_ sv, "[%d]", ARG(o)); /* 2: embedded, otherwise 1 */
+ else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
+ Perl_sv_catpvf(aTHX_ sv, "[-%d]", o->flags);
#endif /* DEBUGGING */
}
void
-pregfree(struct regexp *r)
+Perl_pregfree(pTHX_ struct regexp *r)
{
dTHR;
if (!r || (--r->refcnt > 0))
return;
if (r->precomp)
Safefree(r->precomp);
- if (r->subbase)
- Safefree(r->subbase);
+ if (RX_MATCH_COPIED(r))
+ Safefree(r->subbeg);
if (r->substrs) {
if (r->anchored_substr)
SvREFCNT_dec(r->anchored_substr);
break;
case 'o':
if (new_comppad == NULL)
- croak("panic: pregfree comppad");
+ Perl_croak(aTHX_ "panic: pregfree comppad");
old_comppad = PL_comppad;
old_curpad = PL_curpad;
PL_comppad = new_comppad;
* that bypass this code for speed.]
*/
regnode *
-regnext(register regnode *p)
+Perl_regnext(pTHX_ register regnode *p)
{
dTHR;
register I32 offset;
}
STATIC void
-re_croak2(const char* pat1,const char* pat2,...)
+S_re_croak2(pTHX_ const char* pat1,const char* pat2,...)
{
va_list args;
STRLEN l1 = strlen(pat1);
l1 = 512;
Copy(message, buf, l1 , char);
buf[l1] = '\0'; /* Overwrite \n */
- croak("%s", buf);
+ Perl_croak(aTHX_ "%s", buf);
}
/* XXX Here's a total kludge. But we need to re-enter for swash routines. */
void
-save_re_context(void)
+Perl_save_re_context(pTHX)
{
dTHR;
SAVEPPTR(PL_bostr);