X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/5461259206276a3618e115d5d68776273bb41ca6..c86f7df56cc91b3d77b0e549030650319f540a6b:/regcomp.c diff --git a/regcomp.c b/regcomp.c index 6938954..4729780 100644 --- a/regcomp.c +++ b/regcomp.c @@ -57,7 +57,7 @@ **** Alterations to Henry's code are... **** **** Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - **** 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others + **** 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 by Larry Wall and others **** **** You may distribute under the terms of either the GNU General Public **** License or the Artistic License, as specified in the README file. @@ -102,27 +102,35 @@ typedef struct RExC_state_t { U32 flags; /* are we folding, multilining? */ char *precomp; /* uncompiled string. */ - regexp *rx; + regexp *rx; /* perl core regexp structure */ + regexp_internal *rxi; /* internal data for regexp object pprivate field */ char *start; /* Start of input for compile */ char *end; /* End of input for compile */ char *parse; /* Input-scan pointer. */ I32 whilem_seen; /* number of WHILEM in this expr */ regnode *emit_start; /* Start of emitted-code area */ + regnode *emit_bound; /* First regnode outside of the allocated space */ regnode *emit; /* Code-emit pointer; ®dummy = don't = compiling */ I32 naughty; /* How bad is this pattern? */ I32 sawback; /* Did we see \1, ...? */ U32 seen; I32 size; /* Code size. */ - I32 npar; /* () count. */ + I32 npar; /* Capture buffer count, (OPEN). */ + I32 cpar; /* Capture buffer count, (CLOSE). */ + I32 nestroot; /* root parens we are in - used by accept */ I32 extralen; I32 seen_zerolen; I32 seen_evals; regnode **open_parens; /* pointers to open parens */ regnode **close_parens; /* pointers to close parens */ regnode *opend; /* END node in program */ - I32 utf8; + I32 utf8; /* whether the pattern is utf8 or not */ + I32 orig_utf8; /* whether the pattern was originally in utf8 */ + /* XXX use this for future optimisation of case + * where pattern must be upgraded to utf8. */ HV *charnames; /* cache of named sequences */ HV *paren_names; /* Paren names */ + regnode **recurse; /* Recurse regops */ I32 recurse_count; /* Number of recurse regops */ #if ADD_TO_REGEXEC @@ -132,30 +140,38 @@ typedef struct RExC_state_t { #ifdef DEBUGGING const char *lastparse; I32 lastnum; + AV *paren_name_list; /* idx -> name */ #define RExC_lastparse (pRExC_state->lastparse) #define RExC_lastnum (pRExC_state->lastnum) +#define RExC_paren_name_list (pRExC_state->paren_name_list) #endif } RExC_state_t; #define RExC_flags (pRExC_state->flags) #define RExC_precomp (pRExC_state->precomp) #define RExC_rx (pRExC_state->rx) +#define RExC_rxi (pRExC_state->rxi) #define RExC_start (pRExC_state->start) #define RExC_end (pRExC_state->end) #define RExC_parse (pRExC_state->parse) #define RExC_whilem_seen (pRExC_state->whilem_seen) -#define RExC_offsets (pRExC_state->rx->offsets) /* I am not like the others */ +#ifdef RE_TRACK_PATTERN_OFFSETS +#define RExC_offsets (pRExC_state->rxi->u.offsets) /* I am not like the others */ +#endif #define RExC_emit (pRExC_state->emit) #define RExC_emit_start (pRExC_state->emit_start) +#define RExC_emit_bound (pRExC_state->emit_bound) #define RExC_naughty (pRExC_state->naughty) #define RExC_sawback (pRExC_state->sawback) #define RExC_seen (pRExC_state->seen) #define RExC_size (pRExC_state->size) #define RExC_npar (pRExC_state->npar) +#define RExC_nestroot (pRExC_state->nestroot) #define RExC_extralen (pRExC_state->extralen) #define RExC_seen_zerolen (pRExC_state->seen_zerolen) #define RExC_seen_evals (pRExC_state->seen_evals) #define RExC_utf8 (pRExC_state->utf8) +#define RExC_orig_utf8 (pRExC_state->orig_utf8) #define RExC_charnames (pRExC_state->charnames) #define RExC_open_parens (pRExC_state->open_parens) #define RExC_close_parens (pRExC_state->close_parens) @@ -164,6 +180,7 @@ typedef struct RExC_state_t { #define RExC_recurse (pRExC_state->recurse) #define RExC_recurse_count (pRExC_state->recurse_count) + #define ISMULT1(c) ((c) == '*' || (c) == '+' || (c) == '?') #define ISMULT2(s) ((*s) == '*' || (*s) == '+' || (*s) == '?' || \ ((*s) == '{' && regcurly(s))) @@ -175,10 +192,11 @@ typedef struct RExC_state_t { * Flags to be passed up and down. */ #define WORST 0 /* Worst case. */ -#define HASWIDTH 0x1 /* Known to match non-null strings. */ -#define SIMPLE 0x2 /* Simple enough to be STAR/PLUS operand. */ -#define SPSTART 0x4 /* Starts with * or +. */ -#define TRYAGAIN 0x8 /* Weeded out a declaration. */ +#define HASWIDTH 0x01 /* Known to match non-null strings. */ +#define SIMPLE 0x02 /* Simple enough to be STAR/PLUS operand. */ +#define SPSTART 0x04 /* Starts with * or +. */ +#define TRYAGAIN 0x08 /* Weeded out a declaration. */ +#define POSTPONED 0x10 /* (?1),(?&name), (??{...}) or similar */ #define REG_NODE_NUM(x) ((x) ? (int)((x)-RExC_emit_start) : -1) @@ -335,11 +353,11 @@ static const scan_data_t zero_scan_data = #define SCF_WHILEM_VISITED_POS 0x2000 #define SCF_TRIE_RESTUDY 0x4000 /* Do restudy? */ - +#define SCF_SEEN_ACCEPT 0x8000 #define UTF (RExC_utf8 != 0) -#define LOC ((RExC_flags & PMf_LOCALE) != 0) -#define FOLD ((RExC_flags & PMf_FOLD) != 0) +#define LOC ((RExC_flags & RXf_PMf_LOCALE) != 0) +#define FOLD ((RExC_flags & RXf_PMf_FOLD) != 0) #define OOB_UNICODE 12345678 #define OOB_NAMEDCLASS -1 @@ -366,7 +384,7 @@ static const scan_data_t zero_scan_data = * arg. Show regex, up to a maximum length. If it's too long, chop and add * "...". */ -#define FAIL(msg) STMT_START { \ +#define _FAIL(code) STMT_START { \ const char *ellipses = ""; \ IV len = RExC_end - RExC_precomp; \ \ @@ -377,10 +395,17 @@ static const scan_data_t zero_scan_data = len = RegexLengthToShowInErrorMessages - 10; \ ellipses = "..."; \ } \ - Perl_croak(aTHX_ "%s in regex m/%.*s%s/", \ - msg, (int)len, RExC_precomp, ellipses); \ + code; \ } STMT_END +#define FAIL(msg) _FAIL( \ + Perl_croak(aTHX_ "%s in regex m/%.*s%s/", \ + msg, (int)len, RExC_precomp, ellipses)) + +#define FAIL2(msg,arg) _FAIL( \ + Perl_croak(aTHX_ msg " in regex m/%.*s%s/", \ + arg, (int)len, RExC_precomp, ellipses)) + /* * Simple_vFAIL -- like FAIL, but marks the current location in the scan */ @@ -495,11 +520,25 @@ static const scan_data_t zero_scan_data = * Element 0 holds the number n. * Position is 1 indexed. */ - +#ifndef RE_TRACK_PATTERN_OFFSETS +#define Set_Node_Offset_To_R(node,byte) +#define Set_Node_Offset(node,byte) +#define Set_Cur_Node_Offset +#define Set_Node_Length_To_R(node,len) +#define Set_Node_Length(node,len) +#define Set_Node_Cur_Length(node) +#define Node_Offset(n) +#define Node_Length(n) +#define Set_Node_Offset_Length(node,offset,len) +#define ProgLen(ri) ri->u.proglen +#define SetProgLen(ri,x) ri->u.proglen = x +#else +#define ProgLen(ri) ri->u.offsets[0] +#define SetProgLen(ri,x) ri->u.offsets[0] = x #define Set_Node_Offset_To_R(node,byte) STMT_START { \ if (! SIZE_ONLY) { \ MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n", \ - __LINE__, (node), (int)(byte))); \ + __LINE__, (int)(node), (int)(byte))); \ if((node) < 0) { \ Perl_croak(aTHX_ "value of node is %d in Offset macro", (int)(node)); \ } else { \ @@ -538,23 +577,24 @@ static const scan_data_t zero_scan_data = Set_Node_Offset_To_R((node)-RExC_emit_start, (offset)); \ Set_Node_Length_To_R((node)-RExC_emit_start, (len)); \ } STMT_END - +#endif #if PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS #define EXPERIMENTAL_INPLACESCAN -#endif +#endif /*RE_TRACK_PATTERN_OFFSETS*/ -#define DEBUG_STUDYDATA(data,depth) \ -DEBUG_OPTIMISE_MORE_r(if(data){ \ +#define DEBUG_STUDYDATA(str,data,depth) \ +DEBUG_OPTIMISE_MORE_r(if(data){ \ PerlIO_printf(Perl_debug_log, \ - "%*s"/* Len:%"IVdf"/%"IVdf" */" Pos:%"IVdf"/%"IVdf \ - " Flags: %"IVdf" Whilem_c: %"IVdf" Lcp: %"IVdf" ", \ + "%*s" str "Pos:%"IVdf"/%"IVdf \ + " Flags: 0x%"UVXf" Whilem_c: %"IVdf" Lcp: %"IVdf" %s", \ (int)(depth)*2, "", \ (IV)((data)->pos_min), \ (IV)((data)->pos_delta), \ - (IV)((data)->flags), \ + (UV)((data)->flags), \ (IV)((data)->whilem_c), \ - (IV)((data)->last_closep ? *((data)->last_closep) : -1) \ + (IV)((data)->last_closep ? *((data)->last_closep) : -1), \ + is_inf ? "INF " : "" \ ); \ if ((data)->last_found) \ PerlIO_printf(Perl_debug_log, \ @@ -584,7 +624,7 @@ static void clear_re(pTHX_ void *r); floating substrings if needed. */ STATIC void -S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data, I32 *minlenp) +S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data, I32 *minlenp, int is_inf) { const STRLEN l = CHR_SVLEN(data->last_found); const STRLEN old_l = CHR_SVLEN(*data->longest); @@ -602,12 +642,12 @@ S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data, I32 *min data->minlen_fixed=minlenp; data->lookbehind_fixed=0; } - else { + else { /* *data->longest == data->longest_float */ data->offset_float_min = l ? data->last_start_min : data->pos_min; data->offset_float_max = (l ? data->last_start_max : data->pos_min + data->pos_delta); - if ((U32)data->offset_float_max > (U32)I32_MAX) + if (is_inf || (U32)data->offset_float_max > (U32)I32_MAX) data->offset_float_max = I32_MAX; if (data->flags & SF_BEFORE_EOL) data->flags @@ -629,7 +669,7 @@ S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data, I32 *min } data->last_end = -1; data->flags &= ~SF_BEFORE_EOL; - DEBUG_STUDYDATA(data,0); + DEBUG_STUDYDATA("commit: ",data,0); } /* Can match anything (initialization) */ @@ -785,9 +825,9 @@ S_cl_or(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl, con #ifdef DEBUGGING /* - dump_trie(trie) - dump_trie_interim_list(trie,next_alloc) - dump_trie_interim_table(trie,next_alloc) + dump_trie(trie,widecharmap,revcharmap) + dump_trie_interim_list(trie,widecharmap,revcharmap,next_alloc) + dump_trie_interim_table(trie,widecharmap,revcharmap,next_alloc) These routines dump out a trie in a somewhat readable format. The _interim_ variants are used for debugging the interim @@ -800,17 +840,17 @@ S_cl_or(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl, con */ /* - dump_trie(trie) Dumps the final compressed table form of the trie to Perl_debug_log. Used for debugging make_trie(). */ STATIC void -S_dump_trie(pTHX_ const struct _reg_trie_data *trie,U32 depth) +S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap, + AV *revcharmap, U32 depth) { U32 state; SV *sv=sv_newmortal(); - int colwidth= trie->widecharmap ? 6 : 4; + int colwidth= widecharmap ? 6 : 4; GET_RE_DEBUG_FLAGS_DECL; @@ -819,7 +859,7 @@ S_dump_trie(pTHX_ const struct _reg_trie_data *trie,U32 depth) "Match","Base","Ofs" ); for( state = 0 ; state < trie->uniquecharcount ; state++ ) { - SV ** const tmp = av_fetch( trie->revcharmap, state, 0); + SV ** const tmp = av_fetch( revcharmap, state, 0); if ( tmp ) { PerlIO_printf( Perl_debug_log, "%*s", colwidth, @@ -881,18 +921,19 @@ S_dump_trie(pTHX_ const struct _reg_trie_data *trie,U32 depth) } } /* - dump_trie_interim_list(trie,next_alloc) Dumps a fully constructed but uncompressed trie in list form. List tries normally only are used for construction when the number of possible chars (trie->uniquecharcount) is very high. Used for debugging make_trie(). */ STATIC void -S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie, U32 next_alloc,U32 depth) +S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie, + HV *widecharmap, AV *revcharmap, U32 next_alloc, + U32 depth) { U32 state; SV *sv=sv_newmortal(); - int colwidth= trie->widecharmap ? 6 : 4; + int colwidth= widecharmap ? 6 : 4; GET_RE_DEBUG_FLAGS_DECL; /* print out the table precompression. */ PerlIO_printf( Perl_debug_log, "%*sState :Word | Transition Data\n%*s%s", @@ -912,7 +953,7 @@ S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie, U32 next_alloc ); } for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) { - SV ** const tmp = av_fetch( trie->revcharmap, TRIE_LIST_ITEM(state,charid).forid, 0); + SV ** const tmp = av_fetch( revcharmap, TRIE_LIST_ITEM(state,charid).forid, 0); if ( tmp ) { PerlIO_printf( Perl_debug_log, "%*s:%3X=%4"UVXf" | ", colwidth, @@ -934,19 +975,20 @@ S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie, U32 next_alloc } /* - dump_trie_interim_table(trie,next_alloc) Dumps a fully constructed but uncompressed trie in table form. This is the normal DFA style state transition table, with a few twists to facilitate compression later. Used for debugging make_trie(). */ STATIC void -S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie, U32 next_alloc, U32 depth) +S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie, + HV *widecharmap, AV *revcharmap, U32 next_alloc, + U32 depth) { U32 state; U16 charid; SV *sv=sv_newmortal(); - int colwidth= trie->widecharmap ? 6 : 4; + int colwidth= widecharmap ? 6 : 4; GET_RE_DEBUG_FLAGS_DECL; /* @@ -957,7 +999,7 @@ S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie, U32 next_allo PerlIO_printf( Perl_debug_log, "%*sChar : ",(int)depth * 2 + 2,"" ); for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) { - SV ** const tmp = av_fetch( trie->revcharmap, charid, 0); + SV ** const tmp = av_fetch( revcharmap, charid, 0); if ( tmp ) { PerlIO_printf( Perl_debug_log, "%*s", colwidth, @@ -1124,7 +1166,7 @@ is the recommended Unicode-aware way of saying SV *tmp = newSVpvs(""); \ if (UTF) SvUTF8_on(tmp); \ Perl_sv_catpvf( aTHX_ tmp, "%c", (int)uvc ); \ - av_push( TRIE_REVCHARMAP(trie), tmp ); \ + av_push( revcharmap, tmp ); \ } STMT_END #define TRIE_READ_CHAR STMT_START { \ @@ -1184,14 +1226,14 @@ is the recommended Unicode-aware way of saying else \ tmp = newSVpvn( "", 0 ); \ if ( UTF ) SvUTF8_on( tmp ); \ - av_push( trie->words, tmp ); \ + av_push( trie_words, tmp ); \ }); \ \ curword++; \ \ if ( noper_next < tail ) { \ if (!trie->jump) \ - Newxz( trie->jump, word_count + 1, U16); \ + trie->jump = (U16 *) PerlMemShared_calloc( word_count + 1, sizeof(U16) ); \ trie->jump[curword] = (U16)(noper_next - convert); \ if (!jumper) \ jumper = noper_next; \ @@ -1205,7 +1247,8 @@ is the recommended Unicode-aware way of saying /* we only allocate the nextword buffer when there */\ /* a dupe, so first time we have to do the allocation */\ if (!trie->nextword) \ - Newxz( trie->nextword, word_count + 1, U16); \ + trie->nextword = (U16 *) \ + PerlMemShared_calloc( word_count + 1, sizeof(U16)); \ while ( trie->nextword[dupe] ) \ dupe= trie->nextword[dupe]; \ trie->nextword[dupe]= curword; \ @@ -1235,6 +1278,8 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs dVAR; /* first pass, loop through and scan words */ reg_trie_data *trie; + HV *widecharmap = NULL; + AV *revcharmap = newAV(); regnode *cur; const U32 uniflags = UTF8_ALLOW_DEFAULT; STRLEN len = 0; @@ -1253,32 +1298,33 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs ) ); - const U32 data_slot = add_data( pRExC_state, 1, "t" ); - SV *re_trie_maxbuff; -#ifndef DEBUGGING - /* these are only used during construction but are useful during - * debugging so we store them in the struct when debugging. +#ifdef DEBUGGING + const U32 data_slot = add_data( pRExC_state, 4, "tuuu" ); + AV *trie_words = NULL; + /* along with revcharmap, this only used during construction but both are + * useful during debugging so we store them in the struct when debugging. */ +#else + const U32 data_slot = add_data( pRExC_state, 2, "tu" ); STRLEN trie_charcount=0; - AV *trie_revcharmap; #endif + SV *re_trie_maxbuff; GET_RE_DEBUG_FLAGS_DECL; #ifndef DEBUGGING PERL_UNUSED_ARG(depth); #endif - Newxz( trie, 1, reg_trie_data ); + trie = (reg_trie_data *) PerlMemShared_calloc( 1, sizeof(reg_trie_data) ); trie->refcount = 1; trie->startstate = 1; trie->wordcount = word_count; - RExC_rx->data->data[ data_slot ] = (void*)trie; - Newxz( trie->charmap, 256, U16 ); + RExC_rxi->data->data[ data_slot ] = (void*)trie; + trie->charmap = (U16 *) PerlMemShared_calloc( 256, sizeof(U16) ); if (!(UTF && folder)) - Newxz( trie->bitmap, ANYOF_BITMAP_SIZE, char ); + trie->bitmap = (char *) PerlMemShared_calloc( ANYOF_BITMAP_SIZE, 1 ); DEBUG_r({ - trie->words = newAV(); + trie_words = newAV(); }); - TRIE_REVCHARMAP(trie) = newAV(); re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1); if (!SvIOK(re_trie_maxbuff)) { @@ -1333,16 +1379,17 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ]; const U8 *scan = (U8*)NULL; U32 wordlen = 0; /* required init */ - STRLEN chars=0; + STRLEN chars = 0; + bool set_bit = trie->bitmap ? 1 : 0; /*store the first char in the bitmap?*/ if (OP(noper) == NOTHING) { trie->minlen= 0; continue; } - if (trie->bitmap) { - TRIE_BITMAP_SET(trie,*uc); - if ( folder ) TRIE_BITMAP_SET(trie,folder[ *uc ]); - } + if ( set_bit ) /* bitmap only alloced when !(UTF&&Folding) */ + TRIE_BITMAP_SET(trie,*uc); /* store the raw first byte + regardless of encoding */ + for ( ; uc < e ; uc += len ) { TRIE_CHARCOUNT(trie)++; TRIE_READ_CHAR; @@ -1354,12 +1401,19 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs trie->charmap[ folder[ uvc ] ] = trie->charmap[ uvc ]; TRIE_STORE_REVCHAR; } + if ( set_bit ) { + /* store the codepoint in the bitmap, and if its ascii + also store its folded equivelent. */ + TRIE_BITMAP_SET(trie,uvc); + if ( folder ) TRIE_BITMAP_SET(trie,folder[ uvc ]); + set_bit = 0; /* We've done our bit :-) */ + } } else { SV** svpp; - if ( !trie->widecharmap ) - trie->widecharmap = newHV(); + if ( !widecharmap ) + widecharmap = newHV(); - svpp = hv_fetch( trie->widecharmap, (char*)&uvc, sizeof( UV ), 1 ); + svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 1 ); if ( !svpp ) Perl_croak( aTHX_ "error creating/fetching widecharmap entry for 0x%"UVXf, uvc ); @@ -1383,11 +1437,11 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs DEBUG_TRIE_COMPILE_r( PerlIO_printf( Perl_debug_log, "%*sTRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n", (int)depth * 2 + 2,"", - ( trie->widecharmap ? "UTF8" : "NATIVE" ), (int)word_count, + ( widecharmap ? "UTF8" : "NATIVE" ), (int)word_count, (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount, (int)trie->minlen, (int)trie->maxlen ) ); - Newxz( trie->wordlen, word_count, U32 ); + trie->wordlen = (U32 *) PerlMemShared_calloc( word_count, sizeof(U32) ); /* We now know what we are dealing with in terms of unique chars and @@ -1429,8 +1483,10 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log, "%*sCompiling trie using list compiler\n", (int)depth * 2 + 2, "")); - - Newxz( trie->states, TRIE_CHARCOUNT(trie) + 2, reg_trie_state ); + + trie->states = (reg_trie_state *) + PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2, + sizeof(reg_trie_state) ); TRIE_LIST_NEW(1); next_alloc = 2; @@ -1454,7 +1510,7 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs if ( uvc < 256 ) { charid = trie->charmap[ uvc ]; } else { - SV** const svpp = hv_fetch( trie->widecharmap, (char*)&uvc, sizeof( UV ), 0); + SV** const svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 0); if ( !svpp ) { charid = 0; } else { @@ -1494,14 +1550,19 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs /* next alloc is the NEXT state to be allocated */ trie->statecount = next_alloc; - Renew( trie->states, next_alloc, reg_trie_state ); + trie->states = (reg_trie_state *) + PerlMemShared_realloc( trie->states, + next_alloc + * sizeof(reg_trie_state) ); /* and now dump it out before we compress it */ - DEBUG_TRIE_COMPILE_MORE_r( - dump_trie_interim_list(trie,next_alloc,depth+1) + DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_list(trie, widecharmap, + revcharmap, next_alloc, + depth+1) ); - Newxz( trie->trans, transcount ,reg_trie_trans ); + trie->trans = (reg_trie_trans *) + PerlMemShared_calloc( transcount, sizeof(reg_trie_trans) ); { U32 state; U32 tp = 0; @@ -1532,7 +1593,10 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs } if ( transcount < tp + maxid - minid + 1) { transcount *= 2; - Renew( trie->trans, transcount, reg_trie_trans ); + trie->trans = (reg_trie_trans *) + PerlMemShared_realloc( trie->trans, + transcount + * sizeof(reg_trie_trans) ); Zero( trie->trans + (transcount / 2), transcount / 2 , reg_trie_trans ); } base = trie->uniquecharcount + tp - minid; @@ -1612,9 +1676,13 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs "%*sCompiling trie using table compiler\n", (int)depth * 2 + 2, "")); - Newxz( trie->trans, ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1, - reg_trie_trans ); - Newxz( trie->states, TRIE_CHARCOUNT(trie) + 2, reg_trie_state ); + trie->trans = (reg_trie_trans *) + PerlMemShared_calloc( ( TRIE_CHARCOUNT(trie) + 1 ) + * trie->uniquecharcount + 1, + sizeof(reg_trie_trans) ); + trie->states = (reg_trie_state *) + PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2, + sizeof(reg_trie_state) ); next_alloc = trie->uniquecharcount + 1; @@ -1642,7 +1710,7 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs if ( uvc < 256 ) { charid = trie->charmap[ uvc ]; } else { - SV* const * const svpp = hv_fetch( trie->widecharmap, (char*)&uvc, sizeof( UV ), 0); + SV* const * const svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 0); charid = svpp ? (U16)SvIV(*svpp) : 0; } if ( charid ) { @@ -1665,9 +1733,9 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs } /* end second pass */ /* and now dump it out before we compress it */ - DEBUG_TRIE_COMPILE_MORE_r( - dump_trie_interim_table(trie,next_alloc,depth+1) - ); + DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_table(trie, widecharmap, + revcharmap, + next_alloc, depth+1)); { /* @@ -1771,7 +1839,9 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs } } trie->lasttrans = pos + 1; - Renew( trie->states, laststate, reg_trie_state); + trie->states = (reg_trie_state *) + PerlMemShared_realloc( trie->states, laststate + * sizeof(reg_trie_state) ); DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log, "%*sAlloc: %d Orig: %"IVdf" elements, Final:%"IVdf". Savings of %%%5.2f\n", @@ -1791,12 +1861,12 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs (UV)trie->lasttrans) ); /* resize the trans array to remove unused space */ - Renew( trie->trans, trie->lasttrans, reg_trie_trans); + trie->trans = (reg_trie_trans *) + PerlMemShared_realloc( trie->trans, trie->lasttrans + * sizeof(reg_trie_trans) ); /* and now dump out the compressed format */ - DEBUG_TRIE_COMPILE_r( - dump_trie(trie,depth+1) - ); + DEBUG_TRIE_COMPILE_r(dump_trie(trie, widecharmap, revcharmap, depth+1)); { /* Modify the program and insert the new TRIE node*/ U8 nodetype =(U8)(flags & 0xFF); @@ -1804,9 +1874,12 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs #ifdef DEBUGGING regnode *optimize = NULL; +#ifdef RE_TRACK_PATTERN_OFFSETS + U32 mjd_offset = 0; U32 mjd_nodelen = 0; -#endif +#endif /* RE_TRACK_PATTERN_OFFSETS */ +#endif /* DEBUGGING */ /* This means we convert either the first branch or the first Exact, depending on whether the thing following (in 'last') is a branch @@ -1819,29 +1892,32 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs if ( first != startbranch || OP( last ) == BRANCH ) { /* branch sub-chain */ NEXT_OFF( first ) = (U16)(last - first); +#ifdef RE_TRACK_PATTERN_OFFSETS DEBUG_r({ mjd_offset= Node_Offset((convert)); mjd_nodelen= Node_Length((convert)); }); +#endif /* whole branch chain */ - } else { + } +#ifdef RE_TRACK_PATTERN_OFFSETS + else { DEBUG_r({ const regnode *nop = NEXTOPER( convert ); mjd_offset= Node_Offset((nop)); mjd_nodelen= Node_Length((nop)); }); } - DEBUG_OPTIMISE_r( PerlIO_printf(Perl_debug_log, "%*sMJD offset:%"UVuf" MJD length:%"UVuf"\n", (int)depth * 2 + 2, "", (UV)mjd_offset, (UV)mjd_nodelen) ); - +#endif /* But first we check to see if there is a common prefix we can split out as an EXACT and put in front of the TRIE node. */ trie->startstate= 1; - if ( trie->bitmap && !trie->widecharmap && !trie->jump ) { + if ( trie->bitmap && !widecharmap && !trie->jump ) { U32 state; for ( state = 1 ; state < trie->statecount-1 ; state++ ) { U32 ofs = 0; @@ -1858,7 +1934,7 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs trie->trans[ base + ofs - trie->uniquecharcount ].check == state ) { if ( ++count > 1 ) { - SV **tmp = av_fetch( TRIE_REVCHARMAP(trie), ofs, 0); + SV **tmp = av_fetch( revcharmap, ofs, 0); const U8 *ch = (U8*)SvPV_nolen_const( *tmp ); if ( state == 1 ) break; if ( count == 2 ) { @@ -1869,7 +1945,7 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs (int)depth * 2 + 2, "", (UV)state)); if (idx >= 0) { - SV ** const tmp = av_fetch( TRIE_REVCHARMAP(trie), idx, 0); + SV ** const tmp = av_fetch( revcharmap, idx, 0); const U8 * const ch = (U8*)SvPV_nolen_const( *tmp ); TRIE_BITMAP_SET(trie,*ch); @@ -1889,22 +1965,31 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs } } if ( count == 1 ) { - SV **tmp = av_fetch( TRIE_REVCHARMAP(trie), idx, 0); - const char *ch = SvPV_nolen_const( *tmp ); - DEBUG_OPTIMISE_r( + SV **tmp = av_fetch( revcharmap, idx, 0); + char *ch = SvPV_nolen( *tmp ); + DEBUG_OPTIMISE_r({ + SV *sv=sv_newmortal(); PerlIO_printf( Perl_debug_log, "%*sPrefix State: %"UVuf" Idx:%"UVuf" Char='%s'\n", (int)depth * 2 + 2, "", - (UV)state, (UV)idx, ch) - ); + (UV)state, (UV)idx, + pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 6, + PL_colors[0], PL_colors[1], + (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) | + PERL_PV_ESCAPE_FIRSTCHAR + ) + ); + }); if ( state==1 ) { OP( convert ) = nodetype; str=STRING(convert); STR_LEN(convert)=0; } - *str++=*ch; - STR_LEN(convert)++; - + while (*ch) { + *str++ = *ch++; + STR_LEN(convert)++; + } + } else { #ifdef DEBUGGING if (state>1) @@ -1921,11 +2006,21 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs trie->maxlen -= (state - 1); DEBUG_r({ regnode *fix = convert; + U32 word = trie->wordcount; mjd_nodelen++; Set_Node_Offset_Length(convert, mjd_offset, state - 1); while( ++fix < n ) { Set_Node_Offset_Length(fix, 0, 0); } + while (word--) { + SV ** const tmp = av_fetch( trie_words, word, 0 ); + if (tmp) { + if ( STR_LEN(convert) <= SvCUR(*tmp) ) + sv_chop(*tmp, SvPV_nolen(*tmp) + STR_LEN(convert)); + else + sv_chop(*tmp, SvPV_nolen(*tmp) + SvCUR(*tmp)); + } + } }); if (trie->maxlen) { convert = n; @@ -1952,7 +2047,7 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs { OP( convert ) = TRIEC; Copy(trie->bitmap, ((struct regnode_charclass *)convert)->bitmap, ANYOF_BITMAP_SIZE, char); - Safefree(trie->bitmap); + PerlMemShared_free(trie->bitmap); trie->bitmap= NULL; } else OP( convert ) = TRIE; @@ -1970,6 +2065,7 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs /* needed for dumping*/ DEBUG_r(if (optimize) { regnode *opt = convert; + while ( ++opt < optimize) { Set_Node_Offset_Length(opt,0,0); } @@ -1986,8 +2082,12 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs Set_Node_Offset_Length(convert,mjd_offset,mjd_nodelen); }); } /* end node insert */ -#ifndef DEBUGGING - SvREFCNT_dec(TRIE_REVCHARMAP(trie)); + RExC_rxi->data->data[ data_slot + 1 ] = (void*)widecharmap; +#ifdef DEBUGGING + RExC_rxi->data->data[ data_slot + TRIE_WORDS_OFFSET ] = (void*)trie_words; + RExC_rxi->data->data[ data_slot + 3 ] = (void*)revcharmap; +#else + SvREFCNT_dec(revcharmap); #endif return trie->jump ? MADE_JUMP_TRIE @@ -2017,7 +2117,8 @@ S_make_trie_failtable(pTHX_ RExC_state_t *pRExC_state, regnode *source, regnode try 'g' and succeed, prodceding to match 'cdgu'. */ /* add a fail transition */ - reg_trie_data *trie=(reg_trie_data *)RExC_rx->data->data[ARG(source)]; + const U32 trie_offset = ARG(source); + reg_trie_data *trie=(reg_trie_data *)RExC_rxi->data->data[trie_offset]; U32 *q; const U32 ucharcount = trie->uniquecharcount; const U32 numstates = trie->statecount; @@ -2036,13 +2137,13 @@ S_make_trie_failtable(pTHX_ RExC_state_t *pRExC_state, regnode *source, regnode ARG_SET( stclass, data_slot ); - Newxz( aho, 1, reg_ac_data ); - RExC_rx->data->data[ data_slot ] = (void*)aho; - aho->trie=trie; - aho->states=(reg_trie_state *)savepvn((const char*)trie->states, - numstates * sizeof(reg_trie_state)); + aho = (reg_ac_data *) PerlMemShared_calloc( 1, sizeof(reg_ac_data) ); + RExC_rxi->data->data[ data_slot ] = (void*)aho; + aho->trie=trie_offset; + aho->states=(reg_trie_state *)PerlMemShared_malloc( numstates * sizeof(reg_trie_state) ); + Copy( trie->states, aho->states, numstates, reg_trie_state ); Newxz( q, numstates, U32); - Newxz( aho->fail, numstates, U32 ); + aho->fail = (U32 *) PerlMemShared_calloc( numstates, sizeof(U32) ); aho->refcount = 1; fail = aho->fail; /* initialize fail[0..1] to be 1 so that we always have @@ -2089,8 +2190,9 @@ S_make_trie_failtable(pTHX_ RExC_state_t *pRExC_state, regnode *source, regnode */ fail[ 0 ] = fail[ 1 ] = 0; DEBUG_TRIE_COMPILE_r({ - PerlIO_printf(Perl_debug_log, "%*sStclass Failtable (%"UVuf" states): 0", - (int)(depth * 2), "", numstates + PerlIO_printf(Perl_debug_log, + "%*sStclass Failtable (%"UVuf" states): 0", + (int)(depth * 2), "", (UV)numstates ); for( q_read=1; q_read%3d: %s (%d)\n", \ (int)depth*2, "", REG_NODE_NUM(scan), SvPV_nolen_const(mysv),\ Next ? (REG_NODE_NUM(Next)) : 0 ); \ - }); + }}); @@ -2284,6 +2386,48 @@ S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, I32 *min, U32 flags Newx(and_withp,1,struct regnode_charclass_class); \ SAVEFREEPV(and_withp) +/* this is a chain of data about sub patterns we are processing that + need to be handled seperately/specially in study_chunk. Its so + we can simulate recursion without losing state. */ +struct scan_frame; +typedef struct scan_frame { + regnode *last; /* last node to process in this frame */ + regnode *next; /* next node to process when last is reached */ + struct scan_frame *prev; /*previous frame*/ + I32 stop; /* what stopparen do we use */ +} scan_frame; + + +#define SCAN_COMMIT(s, data, m) scan_commit(s, data, m, is_inf) + +#define CASE_SYNST_FNC(nAmE) \ +case nAmE: \ + if (flags & SCF_DO_STCLASS_AND) { \ + for (value = 0; value < 256; value++) \ + if (!is_ ## nAmE ## _cp(value)) \ + ANYOF_BITMAP_CLEAR(data->start_class, value); \ + } \ + else { \ + for (value = 0; value < 256; value++) \ + if (is_ ## nAmE ## _cp(value)) \ + ANYOF_BITMAP_SET(data->start_class, value); \ + } \ + break; \ +case N ## nAmE: \ + if (flags & SCF_DO_STCLASS_AND) { \ + for (value = 0; value < 256; value++) \ + if (is_ ## nAmE ## _cp(value)) \ + ANYOF_BITMAP_CLEAR(data->start_class, value); \ + } \ + else { \ + for (value = 0; value < 256; value++) \ + if (!is_ ## nAmE ## _cp(value)) \ + ANYOF_BITMAP_SET(data->start_class, value); \ + } \ + break + + + STATIC I32 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *minlenp, I32 *deltap, @@ -2311,7 +2455,11 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, scan_data_t data_fake; SV *re_trie_maxbuff = NULL; regnode *first_non_open = scan; + I32 stopmin = I32_MAX; + scan_frame *frame = NULL; + GET_RE_DEBUG_FLAGS_DECL; + #ifdef DEBUGGING StructCopy(&zero_scan_data, &data_fake, scan_data_t); #endif @@ -2322,9 +2470,10 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, } - while (scan && OP(scan) != END && scan < last) { + fake_study_recurse: + while ( scan && OP(scan) != END && scan < last ){ /* Peephole optimizer: */ - DEBUG_STUDYDATA(data,depth); + DEBUG_STUDYDATA("Peep:", data,depth); DEBUG_PEEP("Peep",scan,depth); JOIN_EXACT(scan,&min,0); @@ -2356,12 +2505,12 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, /* The principal pseudo-switch. Cannot be a switch, since we look into several different things. */ if (OP(scan) == BRANCH || OP(scan) == BRANCHJ - || OP(scan) == IFTHEN || OP(scan) == SUSPEND) { + || OP(scan) == IFTHEN) { next = regnext(scan); code = OP(scan); /* demq: the op(next)==code check is to see if we have "branch-branch" AFAICT */ - if (OP(next) == code || code == IFTHEN || code == SUSPEND) { + if (OP(next) == code || code == IFTHEN) { /* NOTE - There is similar code to this block below for handling TRIE nodes on a re-study. If you change stuff here check there too. */ @@ -2369,8 +2518,8 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, struct regnode_charclass_class accum; regnode * const startbranch=scan; - if (flags & SCF_DO_SUBSTR) /* XXXX Add !SUSPEND? */ - scan_commit(pRExC_state, data, minlenp); /* Cannot merge strings after this. */ + if (flags & SCF_DO_SUBSTR) + SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot merge strings after this. */ if (flags & SCF_DO_STCLASS) cl_init_zero(pRExC_state, &accum); @@ -2386,6 +2535,8 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, } else data_fake.last_closep = &fake; + + data_fake.pos_delta = delta; next = regnext(scan); scan = NEXTOPER(scan); if (code != BRANCH) @@ -2394,7 +2545,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, cl_init(pRExC_state, &this_class); data_fake.start_class = &this_class; f = SCF_DO_STCLASS_AND; - } + } if (flags & SCF_WHILEM_VISITED_POS) f |= SCF_WHILEM_VISITED_POS; @@ -2411,6 +2562,13 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, scan = next; if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR)) pars++; + if (data_fake.flags & SCF_SEEN_ACCEPT) { + if ( stopmin > minnext) + stopmin = min + min1; + flags &= ~SCF_DO_SUBSTR; + if (data) + data->flags |= SCF_SEEN_ACCEPT; + } if (data) { if (data_fake.flags & SF_HAS_EVAL) data->flags |= SF_HAS_EVAL; @@ -2418,8 +2576,6 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, } if (flags & SCF_DO_STCLASS) cl_or(pRExC_state, &accum, &this_class); - if (code == SUSPEND) - break; } if (code == IFTHEN && num < 2) /* Empty ELSE branch */ min1 = 0; @@ -2638,8 +2794,14 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, if ( ((made == MADE_EXACT_TRIE && startbranch == first) || ( first_non_open == first )) && - depth==0 ) + depth==0 ) { flags |= SCF_TRIE_RESTUDY; + if ( startbranch == first + && scan == tail ) + { + RExC_seen &=~REG_TOP_LEVEL_BRANCHES; + } + } #endif } } @@ -2652,6 +2814,63 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, } else /* single branch is optimized. */ scan = NEXTOPER(scan); continue; + } else if (OP(scan) == SUSPEND || OP(scan) == GOSUB || OP(scan) == GOSTART) { + scan_frame *newframe = NULL; + I32 paren; + regnode *start; + regnode *end; + + if (OP(scan) != SUSPEND) { + /* set the pointer */ + if (OP(scan) == GOSUB) { + paren = ARG(scan); + RExC_recurse[ARG2L(scan)] = scan; + start = RExC_open_parens[paren-1]; + end = RExC_close_parens[paren-1]; + } else { + paren = 0; + start = RExC_rxi->program + 1; + end = RExC_opend; + } + if (!recursed) { + Newxz(recursed, (((RExC_npar)>>3) +1), U8); + SAVEFREEPV(recursed); + } + if (!PAREN_TEST(recursed,paren+1)) { + PAREN_SET(recursed,paren+1); + Newx(newframe,1,scan_frame); + } else { + if (flags & SCF_DO_SUBSTR) { + SCAN_COMMIT(pRExC_state,data,minlenp); + data->longest = &(data->longest_float); + } + is_inf = is_inf_internal = 1; + if (flags & SCF_DO_STCLASS_OR) /* Allow everything */ + cl_anything(pRExC_state, data->start_class); + flags &= ~SCF_DO_STCLASS; + } + } else { + Newx(newframe,1,scan_frame); + paren = stopparen; + start = scan+2; + end = regnext(scan); + } + if (newframe) { + assert(start); + assert(end); + SAVEFREEPV(newframe); + newframe->next = regnext(scan); + newframe->last = last; + newframe->stop = stopparen; + newframe->prev = frame; + + frame = newframe; + scan = start; + stopparen = paren; + last = end; + + continue; + } } else if (OP(scan) == EXACT) { I32 l = STR_LEN(scan); @@ -2724,7 +2943,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, /* Search for fixed substrings supports EXACT only. */ if (flags & SCF_DO_SUBSTR) { assert(data); - scan_commit(pRExC_state, data, minlenp); + SCAN_COMMIT(pRExC_state, data, minlenp); } if (UTF) { const U8 * const s = (U8 *)STRING(scan); @@ -2803,7 +3022,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, is_inf = is_inf_internal = 1; scan = regnext(scan); if (flags & SCF_DO_SUBSTR) { - scan_commit(pRExC_state, data, minlenp); /* Cannot extend fixed substrings */ + SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot extend fixed substrings */ data->longest = &(data->longest_float); } goto optimize_curly_tail; @@ -2826,7 +3045,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, next_is_eval = (OP(scan) == EVAL); do_curly: if (flags & SCF_DO_SUBSTR) { - if (mincount == 0) scan_commit(pRExC_state,data,minlenp); /* Cannot extend fixed substrings */ + if (mincount == 0) SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot extend fixed substrings */ pos_before = data->pos_min; } if (data) { @@ -3097,7 +3316,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, if (mincount != maxcount) { /* Cannot extend fixed substrings found inside the group. */ - scan_commit(pRExC_state,data,minlenp); + SCAN_COMMIT(pRExC_state,data,minlenp); if (mincount && last_str) { SV * const sv = data->last_found; MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? @@ -3129,7 +3348,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, continue; default: /* REF and CLUMP only? */ if (flags & SCF_DO_SUBSTR) { - scan_commit(pRExC_state,data,minlenp); /* Cannot expect anything... */ + SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot expect anything... */ data->longest = &(data->longest_float); } is_inf = is_inf_internal = 1; @@ -3139,11 +3358,51 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, break; } } + else if (OP(scan) == LNBREAK) { + if (flags & SCF_DO_STCLASS) { + int value = 0; + data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */ + if (flags & SCF_DO_STCLASS_AND) { + for (value = 0; value < 256; value++) + if (!is_VERTWS_cp(value)) + ANYOF_BITMAP_CLEAR(data->start_class, value); + } + else { + for (value = 0; value < 256; value++) + if (is_VERTWS_cp(value)) + ANYOF_BITMAP_SET(data->start_class, value); + } + if (flags & SCF_DO_STCLASS_OR) + cl_and(data->start_class, and_withp); + flags &= ~SCF_DO_STCLASS; + } + min += 1; + delta += 1; + if (flags & SCF_DO_SUBSTR) { + SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot expect anything... */ + data->pos_min += 1; + data->pos_delta += 1; + data->longest = &(data->longest_float); + } + + } + else if (OP(scan) == FOLDCHAR) { + int d = ARG(scan)==0xDF ? 1 : 2; + flags &= ~SCF_DO_STCLASS; + min += 1; + delta += d; + if (flags & SCF_DO_SUBSTR) { + SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot expect anything... */ + data->pos_min += 1; + data->pos_delta += d; + data->longest = &(data->longest_float); + } + } else if (strchr((const char*)PL_simple,OP(scan))) { int value = 0; if (flags & SCF_DO_SUBSTR) { - scan_commit(pRExC_state,data,minlenp); + SCAN_COMMIT(pRExC_state,data,minlenp); data->pos_min++; } min++; @@ -3333,6 +3592,9 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, } } break; + CASE_SYNST_FNC(VERTWS); + CASE_SYNST_FNC(HORIZWS); + } if (flags & SCF_DO_STCLASS_OR) cl_and(data->start_class, and_withp); @@ -3367,6 +3629,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, } else data_fake.last_closep = &fake; + data_fake.pos_delta = delta; if ( flags & SCF_DO_STCLASS && !scan->flags && OP(scan) == IFMATCH ) { /* Lookahead */ cl_init(pRExC_state, &intrnl); @@ -3381,10 +3644,10 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, last, &data_fake, stopparen, recursed, NULL, f, depth+1); if (scan->flags) { if (deltanext) { - vFAIL("Variable length lookbehind not implemented"); + FAIL("Variable length lookbehind not implemented"); } else if (minnext > (I32)U8_MAX) { - vFAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX); + FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX); } scan->flags = (U8)minnext; } @@ -3431,13 +3694,14 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, if ((flags & SCF_DO_SUBSTR) && data->last_found) { f |= SCF_DO_SUBSTR; if (scan->flags) - scan_commit(pRExC_state, &data_fake,minlenp); + SCAN_COMMIT(pRExC_state, &data_fake,minlenp); data_fake.last_found=newSVsv(data->last_found); } } else data_fake.last_closep = &fake; data_fake.flags = 0; + data_fake.pos_delta = delta; if (is_inf) data_fake.flags |= SF_IS_INF; if ( flags & SCF_DO_STCLASS && !scan->flags @@ -3455,10 +3719,10 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, last, &data_fake, stopparen, recursed, NULL, f,depth+1); if (scan->flags) { if (deltanext) { - vFAIL("Variable length lookbehind not implemented"); + FAIL("Variable length lookbehind not implemented"); } else if (*minnextp > (I32)U8_MAX) { - vFAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX); + FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX); } scan->flags = (U8)*minnextp; } @@ -3481,7 +3745,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, if ((flags & SCF_DO_SUBSTR) && data_fake.last_found) { if (RExC_rx->minlen<*minnextp) RExC_rx->minlen=*minnextp; - scan_commit(pRExC_state, &data_fake, minnextp); + SCAN_COMMIT(pRExC_state, &data_fake, minnextp); SvREFCNT_dec(data_fake.last_found); if ( data_fake.minlen_fixed != minlenp ) @@ -3521,75 +3785,25 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, if (data) *(data->last_closep) = ARG(scan); } - else if (OP(scan) == GOSUB || OP(scan) == GOSTART) { - /* set the pointer */ - I32 paren; - regnode *start; - regnode *end; - if (OP(scan) == GOSUB) { - paren = ARG(scan); - RExC_recurse[ARG2L(scan)] = scan; - start = RExC_open_parens[paren-1]; - end = RExC_close_parens[paren-1]; - } else { - paren = 0; - start = RExC_rx->program + 1; - end = RExC_opend; - } - assert(start); - assert(end); - if (!recursed) { - Newxz(recursed, (((RExC_npar)>>3) +1), U8); - SAVEFREEPV(recursed); - } - if (!PAREN_TEST(recursed,paren+1)) { - I32 deltanext = 0; - PAREN_SET(recursed,paren+1); - - DEBUG_PEEP("goto",start,depth); - min += study_chunk( - pRExC_state, - &start, - minlenp, - &deltanext, - end+1, - data, - paren, - recursed, - and_withp, - flags,depth+1); - delta+=deltanext; - if (deltanext == I32_MAX) { - is_inf = is_inf_internal = 1; - delta=deltanext; - } - DEBUG_PEEP("rtrn",end,depth); - PAREN_UNSET(recursed,paren+1); - } else { - if (flags & SCF_DO_SUBSTR) { - scan_commit(pRExC_state,data,minlenp); - data->longest = &(data->longest_float); - } - is_inf = is_inf_internal = 1; - if (flags & SCF_DO_STCLASS_OR) /* Allow everything */ - cl_anything(pRExC_state, data->start_class); - flags &= ~SCF_DO_STCLASS; - } - } else if (OP(scan) == EVAL) { if (data) data->flags |= SF_HAS_EVAL; } - else if ( OP(scan)==OPFAIL ) { + else if ( PL_regkind[OP(scan)] == ENDLIKE ) { if (flags & SCF_DO_SUBSTR) { - scan_commit(pRExC_state,data,minlenp); + SCAN_COMMIT(pRExC_state,data,minlenp); flags &= ~SCF_DO_SUBSTR; } + if (data && OP(scan)==ACCEPT) { + data->flags |= SCF_SEEN_ACCEPT; + if (stopmin > min) + stopmin = min; + } } else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */ { if (flags & SCF_DO_SUBSTR) { - scan_commit(pRExC_state,data,minlenp); + SCAN_COMMIT(pRExC_state,data,minlenp); data->longest = &(data->longest_float); } is_inf = is_inf_internal = 1; @@ -3597,6 +3811,19 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, cl_anything(pRExC_state, data->start_class); flags &= ~SCF_DO_STCLASS; } + else if (OP(scan) == GPOS) { + if (!(RExC_rx->extflags & RXf_GPOS_FLOAT) && + !(delta || is_inf || (data && data->pos_delta))) + { + if (!(RExC_rx->extflags & RXf_ANCH) && (flags & SCF_DO_SUBSTR)) + RExC_rx->extflags |= RXf_ANCH_GPOS; + if (RExC_rx->gofs < (U32)min) + RExC_rx->gofs = min; + } else { + RExC_rx->extflags |= RXf_GPOS_FLOAT; + RExC_rx->gofs = 0; + } + } #ifdef TRIE_STUDY_OPT #ifdef FULL_TRIE_STUDY else if (PL_regkind[OP(scan)] == TRIE) { @@ -3605,12 +3832,12 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, check there too. */ regnode *trie_node= scan; regnode *tail= regnext(scan); - reg_trie_data *trie = (reg_trie_data*)RExC_rx->data->data[ ARG(scan) ]; + reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ]; I32 max1 = 0, min1 = I32_MAX; struct regnode_charclass_class accum; if (flags & SCF_DO_SUBSTR) /* XXXX Add !SUSPEND? */ - scan_commit(pRExC_state, data,minlenp); /* Cannot merge strings after this. */ + SCAN_COMMIT(pRExC_state, data,minlenp); /* Cannot merge strings after this. */ if (flags & SCF_DO_STCLASS) cl_init_zero(pRExC_state, &accum); @@ -3633,7 +3860,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, } else data_fake.last_closep = &fake; - + data_fake.pos_delta = delta; if (flags & SCF_DO_STCLASS) { cl_init(pRExC_state, &this_class); data_fake.start_class = &this_class; @@ -3666,7 +3893,13 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR)) pars++; - + if (data_fake.flags & SCF_SEEN_ACCEPT) { + if ( stopmin > min + min1) + stopmin = min + min1; + flags &= ~SCF_DO_SUBSTR; + if (data) + data->flags |= SCF_SEEN_ACCEPT; + } if (data) { if (data_fake.flags & SF_HAS_EVAL) data->flags |= SF_HAS_EVAL; @@ -3714,14 +3947,14 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, } #else else if (PL_regkind[OP(scan)] == TRIE) { - reg_trie_data *trie = (reg_trie_data*)RExC_rx->data->data[ ARG(scan) ]; + reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ]; U8*bang=NULL; min += trie->minlen; delta += (trie->maxlen - trie->minlen); flags &= ~SCF_DO_STCLASS; /* xxx */ if (flags & SCF_DO_SUBSTR) { - scan_commit(pRExC_state,data,minlenp); /* Cannot expect anything... */ + SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot expect anything... */ data->pos_min += trie->minlen; data->pos_delta += (trie->maxlen - trie->minlen); if (trie->maxlen != trie->minlen) @@ -3732,11 +3965,22 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, } #endif /* old or new */ #endif /* TRIE_STUDY_OPT */ + /* Else: zero-length, ignore. */ scan = regnext(scan); } + if (frame) { + last = frame->last; + scan = frame->next; + stopparen = frame->stop; + frame = frame->prev; + goto fake_study_recurse; + } finish: + assert(!frame); + DEBUG_STUDYDATA("pre-fin:",data,depth); + *scanp = scan; *deltap = is_inf_internal ? I32_MAX : delta; if (flags & SCF_DO_SUBSTR && is_inf) @@ -3756,32 +4000,29 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, if (flags & SCF_TRIE_RESTUDY) data->flags |= SCF_TRIE_RESTUDY; - DEBUG_STUDYDATA(data,depth); + DEBUG_STUDYDATA("post-fin:",data,depth); - return min; + return min < stopmin ? min : stopmin; } -STATIC I32 -S_add_data(RExC_state_t *pRExC_state, I32 n, const char *s) +STATIC U32 +S_add_data(RExC_state_t *pRExC_state, U32 n, const char *s) { - if (RExC_rx->data) { - const U32 count = RExC_rx->data->count; - Renewc(RExC_rx->data, - sizeof(*RExC_rx->data) + sizeof(void*) * (count + n - 1), - char, struct reg_data); - Renew(RExC_rx->data->what, count + n, U8); - RExC_rx->data->count += n; - } - else { - Newxc(RExC_rx->data, sizeof(*RExC_rx->data) + sizeof(void*) * (n - 1), - char, struct reg_data); - Newx(RExC_rx->data->what, n, U8); - RExC_rx->data->count = n; - } - Copy(s, RExC_rx->data->what + RExC_rx->data->count - n, n, U8); - return RExC_rx->data->count - n; + U32 count = RExC_rxi->data ? RExC_rxi->data->count : 0; + + Renewc(RExC_rxi->data, + sizeof(*RExC_rxi->data) + sizeof(void*) * (count + n - 1), + char, struct reg_data); + if(count) + Renew(RExC_rxi->data->what, count + n, U8); + else + Newx(RExC_rxi->data->what, n, U8); + RExC_rxi->data->count = count + n; + Copy(s, RExC_rxi->data->what + count, n, U8); + return count; } +/*XXX: todo make this not included in a non debugging perl */ #ifndef PERL_IN_XSUB_RE void Perl_reginitcolors(pTHX) @@ -3845,36 +4086,40 @@ Perl_reginitcolors(pTHX) extern const struct regexp_engine my_reg_engine; #define RE_ENGINE_PTR &my_reg_engine #endif -/* these make a few things look better, to avoid indentation */ -#define BEGIN_BLOCK { -#define END_BLOCK } - -regexp * -Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm) + +#ifndef PERL_IN_XSUB_RE +REGEXP * +Perl_pregcomp(pTHX_ const SV * const pattern, const U32 flags) { dVAR; - GET_RE_DEBUG_FLAGS_DECL; - DEBUG_r(if (!PL_colorset) reginitcolors()); -#ifndef PERL_IN_XSUB_RE - BEGIN_BLOCK + HV * const table = GvHV(PL_hintgv); /* Dispatch a request to compile a regexp to correct regexp engine. */ - HV * const table = GvHV(PL_hintgv); if (table) { SV **ptr= hv_fetchs(table, "regcomp", FALSE); + GET_RE_DEBUG_FLAGS_DECL; if (ptr && SvIOK(*ptr) && SvIV(*ptr)) { const regexp_engine *eng=INT2PTR(regexp_engine*,SvIV(*ptr)); DEBUG_COMPILE_r({ PerlIO_printf(Perl_debug_log, "Using engine %"UVxf"\n", SvIV(*ptr)); }); - return CALLREGCOMP_ENG(eng, exp, xend, pm); + return CALLREGCOMP_ENG(eng, pattern, flags); } } - END_BLOCK + return Perl_re_compile(aTHX_ pattern, flags); +} #endif - BEGIN_BLOCK - register regexp *r; + +REGEXP * +Perl_re_compile(pTHX_ const SV * const pattern, const U32 pm_flags) +{ + dVAR; + register REGEXP *r; + register regexp_internal *ri; + STRLEN plen; + char* exp = SvPV((SV*)pattern, plen); + char* xend = exp + plen; regnode *scan; regnode *first; I32 flags; @@ -3888,20 +4133,22 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm) int restudied= 0; RExC_state_t copyRExC_state; #endif - if (exp == NULL) - FAIL("NULL regexp argument"); + GET_RE_DEBUG_FLAGS_DECL; + DEBUG_r(if (!PL_colorset) reginitcolors()); - RExC_utf8 = pm->op_pmdynflags & PMdf_CMP_UTF8; + RExC_utf8 = RExC_orig_utf8 = pm_flags & RXf_UTF8; - RExC_precomp = exp; DEBUG_COMPILE_r({ SV *dsv= sv_newmortal(); RE_PV_QUOTED_DECL(s, RExC_utf8, - dsv, RExC_precomp, (xend - exp), 60); + dsv, exp, plen, 60); PerlIO_printf(Perl_debug_log, "%sCompiling REx%s %s\n", PL_colors[4],PL_colors[5],s); }); - RExC_flags = pm->op_pmflags; + +redo_first_pass: + RExC_precomp = exp; + RExC_flags = pm_flags; RExC_sawback = 0; RExC_seen = 0; @@ -3915,6 +4162,7 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm) RExC_end = xend; RExC_naughty = 0; RExC_npar = 1; + RExC_nestroot = 0; RExC_size = 0L; RExC_emit = &PL_regdummy; RExC_whilem_seen = 0; @@ -3923,6 +4171,9 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm) RExC_close_parens = NULL; RExC_opend = NULL; RExC_paren_names = NULL; +#ifdef DEBUGGING + RExC_paren_name_list = NULL; +#endif RExC_recurse = NULL; RExC_recurse_count = 0; @@ -3935,6 +4186,25 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm) RExC_precomp = NULL; return(NULL); } + if (RExC_utf8 && !RExC_orig_utf8) { + /* It's possible to write a regexp in ascii that represents unicode + codepoints outside of the byte range, such as via \x{100}. If we + detect such a sequence we have to convert the entire pattern to utf8 + and then recompile, as our sizing calculation will have been based + on 1 byte == 1 character, but we will need to use utf8 to encode + at least some part of the pattern, and therefore must convert the whole + thing. + XXX: somehow figure out how to make this less expensive... + -- dmq */ + STRLEN len = plen; + DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, + "UTF8 mismatch! Converting to utf8 for resizing and compile\n")); + exp = (char*)Perl_bytes_to_utf8(aTHX_ (U8*)exp, &len); + xend = exp + len; + RExC_orig_utf8 = RExC_utf8; + SAVEFREEPV(exp); + goto redo_first_pass; + } DEBUG_PARSE_r({ PerlIO_printf(Perl_debug_log, "Required size %"IVdf" nodes\n" @@ -3955,31 +4225,71 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm) /* Allocate space and zero-initialize. Note, the two step process of zeroing when in debug mode, thus anything assigned has to happen after that */ - Newxc(r, sizeof(regexp) + (unsigned)RExC_size * sizeof(regnode), - char, regexp); - if (r == NULL) + Newxz(r, 1, regexp); + Newxc(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode), + char, regexp_internal); + if ( r == NULL || ri == NULL ) FAIL("Regexp out of space"); #ifdef DEBUGGING /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */ - Zero(r, sizeof(regexp) + (unsigned)RExC_size * sizeof(regnode), char); + Zero(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode), char); +#else + /* bulk initialize base fields with 0. */ + Zero(ri, sizeof(regexp_internal), char); #endif - /* initialization begins here */ + + /* non-zero initialization begins here */ + RXi_SET( r, ri ); r->engine= RE_ENGINE_PTR; r->refcnt = 1; - r->prelen = xend - exp; - r->precomp = savepvn(RExC_precomp, r->prelen); - r->subbeg = NULL; -#ifdef PERL_OLD_COPY_ON_WRITE - r->saved_copy = NULL; -#endif - r->reganch = pm->op_pmflags & PMf_COMPILETIME; - r->nparens = RExC_npar - 1; /* set early to validate backrefs */ - r->lastparen = 0; /* mg.c reads this. */ + r->prelen = plen; + r->extflags = pm_flags; + { + bool has_k = ((r->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY); + bool has_minus = ((r->extflags & RXf_PMf_STD_PMMOD) != RXf_PMf_STD_PMMOD); + bool has_runon = ((RExC_seen & REG_SEEN_RUN_ON_COMMENT)==REG_SEEN_RUN_ON_COMMENT); + U16 reganch = (U16)((r->extflags & RXf_PMf_STD_PMMOD) >> 12); + const char *fptr = STD_PAT_MODS; /*"msix"*/ + char *p; + r->wraplen = r->prelen + has_minus + has_k + has_runon + + (sizeof(STD_PAT_MODS) - 1) + + (sizeof("(?:)") - 1); + + Newx(r->wrapped, r->wraplen + 1, char ); + p = r->wrapped; + *p++='('; *p++='?'; + if (has_k) + *p++ = KEEPCOPY_PAT_MOD; /*'k'*/ + { + char *r = p + (sizeof(STD_PAT_MODS) - 1) + has_minus - 1; + char *colon = r + 1; + char ch; + + while((ch = *fptr++)) { + if(reganch & 1) + *p++ = ch; + else + *r-- = ch; + reganch >>= 1; + } + if(has_minus) { + *r = '-'; + p = colon; + } + } + + *p++ = ':'; + Copy(RExC_precomp, p, r->prelen, char); + r->precomp = p; + p += r->prelen; + if (has_runon) + *p++ = '\n'; + *p++ = ')'; + *p = 0; + } - r->substrs = 0; /* Useful during FAIL. */ - r->startp = 0; /* Useful during FAIL. */ - r->endp = 0; - r->paren_names = 0; + r->intflags = 0; + r->nparens = RExC_npar - 1; /* set early to validate backrefs */ if (RExC_seen & REG_SEEN_RECURSE) { Newxz(RExC_open_parens, RExC_npar,regnode *); @@ -3989,29 +4299,30 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm) } /* Useful during FAIL. */ - Newxz(r->offsets, 2*RExC_size+1, U32); /* MJD 20001228 */ - if (r->offsets) { - r->offsets[0] = RExC_size; - } +#ifdef RE_TRACK_PATTERN_OFFSETS + Newxz(ri->u.offsets, 2*RExC_size+1, U32); /* MJD 20001228 */ DEBUG_OFFSETS_r(PerlIO_printf(Perl_debug_log, "%s %"UVuf" bytes for offset annotations.\n", - r->offsets ? "Got" : "Couldn't get", + ri->u.offsets ? "Got" : "Couldn't get", (UV)((2*RExC_size+1) * sizeof(U32)))); - +#endif + SetProgLen(ri,RExC_size); RExC_rx = r; + RExC_rxi = ri; /* Second pass: emit code. */ - RExC_flags = pm->op_pmflags; /* don't let top level (?i) bleed */ + RExC_flags = pm_flags; /* don't let top level (?i) bleed */ RExC_parse = exp; RExC_end = xend; RExC_naughty = 0; RExC_npar = 1; - RExC_emit_start = r->program; - RExC_emit = r->program; + RExC_emit_start = ri->program; + RExC_emit = ri->program; + RExC_emit_bound = ri->program + RExC_size + 1; + /* Store the count of eval-groups for security checks: */ - RExC_emit->next_off = (RExC_seen_evals > (I32)U16_MAX) ? U16_MAX : (U16)RExC_seen_evals; + RExC_rx->seen_evals = RExC_seen_evals; REGC((U8)REG_MAGIC, (char*) RExC_emit++); - r->data = 0; if (reg(pRExC_state, 0, &flags,1) == NULL) return(NULL); @@ -4029,8 +4340,14 @@ reStudy: #ifdef TRIE_STUDY_OPT if ( restudied ) { + U32 seen=RExC_seen; DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log,"Restudying\n")); - RExC_state=copyRExC_state; + + RExC_state = copyRExC_state; + if (seen & REG_TOP_LEVEL_BRANCHES) + RExC_seen |= REG_TOP_LEVEL_BRANCHES; + else + RExC_seen &= ~REG_TOP_LEVEL_BRANCHES; if (data.last_found) { SvREFCNT_dec(data.longest_fixed); SvREFCNT_dec(data.longest_float); @@ -4039,21 +4356,22 @@ reStudy: StructCopy(&zero_scan_data, &data, scan_data_t); } else { StructCopy(&zero_scan_data, &data, scan_data_t); - copyRExC_state=RExC_state; + copyRExC_state = RExC_state; } #else StructCopy(&zero_scan_data, &data, scan_data_t); #endif /* Dig out information for optimizations. */ - r->reganch = pm->op_pmflags & PMf_COMPILETIME; /* Again? */ - pm->op_pmflags = RExC_flags; + r->extflags = pm_flags; /* Again? */ + /*dmq: removed as part of de-PMOP: pm->op_pmflags = RExC_flags; */ + if (UTF) - r->reganch |= ROPT_UTF8; /* Unicode in it? */ - r->regstclass = NULL; + r->extflags |= RXf_UTF8; /* Unicode in it? */ + ri->regstclass = NULL; if (RExC_naughty >= 10) /* Probably an expensive pattern. */ - r->reganch |= ROPT_NAUGHTY; - scan = r->program + 1; /* First BRANCH. */ + r->intflags |= PREGf_NAUGHTY; + scan = ri->program + 1; /* First BRANCH. */ /* testing for BRANCH here tells us whether there is "must appear" data in the pattern. If there is then we can use it for optimisations */ @@ -4096,66 +4414,68 @@ reStudy: if (OP(first) == EXACT) NOOP; /* Empty, get anchored substr later. */ else if ((OP(first) == EXACTF || OP(first) == EXACTFL)) - r->regstclass = first; + ri->regstclass = first; } #ifdef TRIE_STCLASS else if (PL_regkind[OP(first)] == TRIE && - ((reg_trie_data *)r->data->data[ ARG(first) ])->minlen>0) + ((reg_trie_data *)ri->data->data[ ARG(first) ])->minlen>0) { regnode *trie_op; /* this can happen only on restudy */ if ( OP(first) == TRIE ) { - struct regnode_1 *trieop; - Newxz(trieop,1,struct regnode_1); + struct regnode_1 *trieop = (struct regnode_1 *) + PerlMemShared_calloc(1, sizeof(struct regnode_1)); StructCopy(first,trieop,struct regnode_1); trie_op=(regnode *)trieop; } else { - struct regnode_charclass *trieop; - Newxz(trieop,1,struct regnode_charclass); + struct regnode_charclass *trieop = (struct regnode_charclass *) + PerlMemShared_calloc(1, sizeof(struct regnode_charclass)); StructCopy(first,trieop,struct regnode_charclass); trie_op=(regnode *)trieop; } OP(trie_op)+=2; make_trie_failtable(pRExC_state, (regnode *)first, trie_op, 0); - r->regstclass = trie_op; + ri->regstclass = trie_op; } #endif else if (strchr((const char*)PL_simple,OP(first))) - r->regstclass = first; + ri->regstclass = first; else if (PL_regkind[OP(first)] == BOUND || PL_regkind[OP(first)] == NBOUND) - r->regstclass = first; + ri->regstclass = first; else if (PL_regkind[OP(first)] == BOL) { - r->reganch |= (OP(first) == MBOL - ? ROPT_ANCH_MBOL + r->extflags |= (OP(first) == MBOL + ? RXf_ANCH_MBOL : (OP(first) == SBOL - ? ROPT_ANCH_SBOL - : ROPT_ANCH_BOL)); + ? RXf_ANCH_SBOL + : RXf_ANCH_BOL)); first = NEXTOPER(first); goto again; } else if (OP(first) == GPOS) { - r->reganch |= ROPT_ANCH_GPOS; + r->extflags |= RXf_ANCH_GPOS; first = NEXTOPER(first); goto again; } - else if (!sawopen && (OP(first) == STAR && + else if ((!sawopen || !RExC_sawback) && + (OP(first) == STAR && PL_regkind[OP(NEXTOPER(first))] == REG_ANY) && - !(r->reganch & ROPT_ANCH) ) + !(r->extflags & RXf_ANCH) && !(RExC_seen & REG_SEEN_EVAL)) { /* turn .* into ^.* with an implied $*=1 */ const int type = (OP(NEXTOPER(first)) == REG_ANY) - ? ROPT_ANCH_MBOL - : ROPT_ANCH_SBOL; - r->reganch |= type | ROPT_IMPLICIT; + ? RXf_ANCH_MBOL + : RXf_ANCH_SBOL; + r->extflags |= type; + r->intflags |= PREGf_IMPLICIT; first = NEXTOPER(first); goto again; } if (sawplus && (!sawopen || !RExC_sawback) && !(RExC_seen & REG_SEEN_EVAL)) /* May examine pos and $& */ /* x+ must match at the 1st pos of run of x's */ - r->reganch |= ROPT_SKIP; + r->intflags |= PREGf_SKIP; /* Scan is after the zeroth branch, first is atomic matcher. */ #ifdef TRIE_STUDY_OPT @@ -4183,21 +4503,20 @@ reStudy: * it happens that c_offset_min has been invalidated, since the * earlier string may buy us something the later one won't.] */ - minlen = 0; - + data.longest_fixed = newSVpvs(""); data.longest_float = newSVpvs(""); data.last_found = newSVpvs(""); data.longest = &(data.longest_fixed); first = scan; - if (!r->regstclass) { + if (!ri->regstclass) { cl_init(pRExC_state, &ch_class); data.start_class = &ch_class; stclass_flag = SCF_DO_STCLASS_AND; } else /* XXXX Check for BOUND? */ stclass_flag = 0; data.last_closep = &last_close; - + minlen = study_chunk(pRExC_state, &first, &minlen, &fake, scan + RExC_size, /* Up to end */ &data, -1, NULL, NULL, SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag,0); @@ -4209,9 +4528,10 @@ reStudy: if ( RExC_npar == 1 && data.longest == &(data.longest_fixed) && data.last_start_min == 0 && data.last_end > 0 && !RExC_seen_zerolen - && (!(RExC_seen & REG_SEEN_GPOS) || (r->reganch & ROPT_ANCH_GPOS))) - r->reganch |= ROPT_CHECK_ALL; - scan_commit(pRExC_state, &data,&minlen); + && !(RExC_seen & REG_SEEN_VERBARG) + && (!(RExC_seen & REG_SEEN_GPOS) || (r->extflags & RXf_ANCH_GPOS))) + r->extflags |= RXf_CHECK_ALL; + scan_commit(pRExC_state, &data,&minlen,0); SvREFCNT_dec(data.last_found); /* Note that code very similar to this but for anchored string @@ -4222,7 +4542,7 @@ reStudy: if (longest_float_length || (data.flags & SF_FL_BEFORE_EOL && (!(data.flags & SF_FL_BEFORE_MEOL) - || (RExC_flags & PMf_MULTILINE)))) + || (RExC_flags & RXf_PMf_MULTILINE)))) { I32 t,ml; @@ -4256,7 +4576,7 @@ reStudy: t = (data.flags & SF_FL_BEFORE_EOL /* Can't have SEOL and MULTI */ && (!(data.flags & SF_FL_BEFORE_MEOL) - || (RExC_flags & PMf_MULTILINE))); + || (RExC_flags & RXf_PMf_MULTILINE))); fbm_compile(data.longest_float, t ? FBMcf_TAIL : 0); } else { @@ -4274,7 +4594,7 @@ reStudy: if (longest_fixed_length || (data.flags & SF_FIX_BEFORE_EOL /* Cannot have SEOL and MULTI */ && (!(data.flags & SF_FIX_BEFORE_MEOL) - || (RExC_flags & PMf_MULTILINE)))) + || (RExC_flags & RXf_PMf_MULTILINE)))) { I32 t,ml; @@ -4300,7 +4620,7 @@ reStudy: t = (data.flags & SF_FIX_BEFORE_EOL /* Can't have SEOL and MULTI */ && (!(data.flags & SF_FIX_BEFORE_MEOL) - || (RExC_flags & PMf_MULTILINE))); + || (RExC_flags & RXf_PMf_MULTILINE))); fbm_compile(data.longest_fixed, t ? FBMcf_TAIL : 0); } else { @@ -4308,23 +4628,23 @@ reStudy: SvREFCNT_dec(data.longest_fixed); longest_fixed_length = 0; } - if (r->regstclass - && (OP(r->regstclass) == REG_ANY || OP(r->regstclass) == SANY)) - r->regstclass = NULL; + if (ri->regstclass + && (OP(ri->regstclass) == REG_ANY || OP(ri->regstclass) == SANY)) + ri->regstclass = NULL; if ((!(r->anchored_substr || r->anchored_utf8) || r->anchored_offset) && stclass_flag && !(data.start_class->flags & ANYOF_EOS) && !cl_is_anything(data.start_class)) { - const I32 n = add_data(pRExC_state, 1, "f"); + const U32 n = add_data(pRExC_state, 1, "f"); - Newx(RExC_rx->data->data[n], 1, + Newx(RExC_rxi->data->data[n], 1, struct regnode_charclass_class); StructCopy(data.start_class, - (struct regnode_charclass_class*)RExC_rx->data->data[n], + (struct regnode_charclass_class*)RExC_rxi->data->data[n], struct regnode_charclass_class); - r->regstclass = (regnode*)RExC_rx->data->data[n]; - r->reganch &= ~ROPT_SKIP; /* Used in find_byclass(). */ + ri->regstclass = (regnode*)RExC_rxi->data->data[n]; + r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */ DEBUG_COMPILE_r({ SV *sv = sv_newmortal(); regprop(r, sv, (regnode*)data.start_class); PerlIO_printf(Perl_debug_log, @@ -4338,8 +4658,8 @@ reStudy: r->check_substr = r->anchored_substr; r->check_utf8 = r->anchored_utf8; r->check_offset_min = r->check_offset_max = r->anchored_offset; - if (r->reganch & ROPT_ANCH_SINGLE) - r->reganch |= ROPT_NOSCAN; + if (r->extflags & RXf_ANCH_SINGLE) + r->extflags |= RXf_NOSCAN; } else { r->check_end_shift = r->float_end_shift; @@ -4350,10 +4670,10 @@ reStudy: } /* XXXX Currently intuiting is not compatible with ANCH_GPOS. This should be changed ASAP! */ - if ((r->check_substr || r->check_utf8) && !(r->reganch & ROPT_ANCH_GPOS)) { - r->reganch |= RE_USE_INTUIT; + if ((r->check_substr || r->check_utf8) && !(r->extflags & RXf_ANCH_GPOS)) { + r->extflags |= RXf_USE_INTUIT; if (SvTAIL(r->check_substr ? r->check_substr : r->check_utf8)) - r->reganch |= RE_INTUIT_TAIL; + r->extflags |= RXf_INTUIT_TAIL; } /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere) if ( (STRLEN)minlen < longest_float_length ) @@ -4368,16 +4688,17 @@ reStudy: struct regnode_charclass_class ch_class; I32 last_close = 0; - DEBUG_COMPILE_r(PerlIO_printf(Perl_debug_log, "\n")); + DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "\nMulti Top Level\n")); - scan = r->program + 1; + scan = ri->program + 1; cl_init(pRExC_state, &ch_class); data.start_class = &ch_class; data.last_closep = &last_close; + minlen = study_chunk(pRExC_state, &scan, &minlen, &fake, scan + RExC_size, &data, -1, NULL, NULL, SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS,0); - + CHECK_RESTUDY_GOTO; r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8 @@ -4385,15 +4706,15 @@ reStudy: if (!(data.start_class->flags & ANYOF_EOS) && !cl_is_anything(data.start_class)) { - const I32 n = add_data(pRExC_state, 1, "f"); + const U32 n = add_data(pRExC_state, 1, "f"); - Newx(RExC_rx->data->data[n], 1, + Newx(RExC_rxi->data->data[n], 1, struct regnode_charclass_class); StructCopy(data.start_class, - (struct regnode_charclass_class*)RExC_rx->data->data[n], + (struct regnode_charclass_class*)RExC_rxi->data->data[n], struct regnode_charclass_class); - r->regstclass = (regnode*)RExC_rx->data->data[n]; - r->reganch &= ~ROPT_SKIP; /* Used in find_byclass(). */ + ri->regstclass = (regnode*)RExC_rxi->data->data[n]; + r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */ DEBUG_COMPILE_r({ SV* sv = sv_newmortal(); regprop(r, sv, (regnode*)data.start_class); PerlIO_printf(Perl_debug_log, @@ -4404,91 +4725,195 @@ reStudy: /* Guard against an embedded (?=) or (?<=) with a longer minlen than the "real" pattern. */ + DEBUG_OPTIMISE_r({ + PerlIO_printf(Perl_debug_log,"minlen: %"IVdf" r->minlen:%"IVdf"\n", + (IV)minlen, (IV)r->minlen); + }); + r->minlenret = minlen; if (r->minlen < minlen) r->minlen = minlen; if (RExC_seen & REG_SEEN_GPOS) - r->reganch |= ROPT_GPOS_SEEN; + r->extflags |= RXf_GPOS_SEEN; if (RExC_seen & REG_SEEN_LOOKBEHIND) - r->reganch |= ROPT_LOOKBEHIND_SEEN; + r->extflags |= RXf_LOOKBEHIND_SEEN; if (RExC_seen & REG_SEEN_EVAL) - r->reganch |= ROPT_EVAL_SEEN; + r->extflags |= RXf_EVAL_SEEN; if (RExC_seen & REG_SEEN_CANY) - r->reganch |= ROPT_CANY_SEEN; + r->extflags |= RXf_CANY_SEEN; + if (RExC_seen & REG_SEEN_VERBARG) + r->intflags |= PREGf_VERBARG_SEEN; + if (RExC_seen & REG_SEEN_CUTGROUP) + r->intflags |= PREGf_CUTGROUP_SEEN; if (RExC_paren_names) r->paren_names = (HV*)SvREFCNT_inc(RExC_paren_names); else r->paren_names = NULL; - + if (r->prelen == 3 && strnEQ("\\s+", r->precomp, 3)) /* precomp = "\\s+)" */ + r->extflags |= RXf_WHITE; + else if (r->prelen == 1 && r->precomp[0] == '^') + r->extflags |= RXf_START_ONLY; + +#ifdef DEBUGGING + if (RExC_paren_names) { + ri->name_list_idx = add_data( pRExC_state, 1, "p" ); + ri->data->data[ri->name_list_idx] = (void*)SvREFCNT_inc(RExC_paren_name_list); + } else +#endif + ri->name_list_idx = 0; + if (RExC_recurse_count) { for ( ; RExC_recurse_count ; RExC_recurse_count-- ) { const regnode *scan = RExC_recurse[RExC_recurse_count-1]; ARG2L_SET( scan, RExC_open_parens[ARG(scan)-1] - scan ); } } - Newxz(r->startp, RExC_npar, I32); - Newxz(r->endp, RExC_npar, I32); - - DEBUG_r( RX_DEBUG_on(r) ); + Newxz(r->offs, RExC_npar, regexp_paren_pair); + /* assume we don't need to swap parens around before we match */ + DEBUG_DUMP_r({ PerlIO_printf(Perl_debug_log,"Final program:\n"); regdump(r); }); - DEBUG_OFFSETS_r(if (r->offsets) { - const U32 len = r->offsets[0]; +#ifdef RE_TRACK_PATTERN_OFFSETS + DEBUG_OFFSETS_r(if (ri->u.offsets) { + const U32 len = ri->u.offsets[0]; U32 i; GET_RE_DEBUG_FLAGS_DECL; - PerlIO_printf(Perl_debug_log, "Offsets: [%"UVuf"]\n\t", (UV)r->offsets[0]); + PerlIO_printf(Perl_debug_log, "Offsets: [%"UVuf"]\n\t", (UV)ri->u.offsets[0]); for (i = 1; i <= len; i++) { - if (r->offsets[i*2-1] || r->offsets[i*2]) + if (ri->u.offsets[i*2-1] || ri->u.offsets[i*2]) PerlIO_printf(Perl_debug_log, "%"UVuf":%"UVuf"[%"UVuf"] ", - (UV)i, (UV)r->offsets[i*2-1], (UV)r->offsets[i*2]); + (UV)i, (UV)ri->u.offsets[i*2-1], (UV)ri->u.offsets[i*2]); } PerlIO_printf(Perl_debug_log, "\n"); }); +#endif return(r); - END_BLOCK } -#undef CORE_ONLY_BLOCK -#undef END_BLOCK #undef RE_ENGINE_PTR -#ifndef PERL_IN_XSUB_RE + SV* -Perl_reg_named_buff_sv(pTHX_ SV* namesv) +Perl_reg_named_buff_get(pTHX_ REGEXP * const rx, SV * const namesv, const U32 flags) { - I32 parno = 0; /* no match */ - if (PL_curpm) { - const REGEXP * const rx = PM_GETRE(PL_curpm); - if (rx && rx->paren_names) { - HE *he_str = hv_fetch_ent( rx->paren_names, namesv, 0, 0 ); - if (he_str) { - IV i; - SV* sv_dat=HeVAL(he_str); - I32 *nums=(I32*)SvPVX(sv_dat); - for ( i=0; ilastparen) >= nums[i] && - rx->endp[nums[i]] != -1) - { - parno = nums[i]; - break; - } + AV *retarray = NULL; + SV *ret; + if (flags & 1) + retarray=newAV(); + + if (rx && rx->paren_names) { + HE *he_str = hv_fetch_ent( rx->paren_names, namesv, 0, 0 ); + if (he_str) { + IV i; + SV* sv_dat=HeVAL(he_str); + I32 *nums=(I32*)SvPVX(sv_dat); + for ( i=0; inparens) >= nums[i] + && rx->offs[nums[i]].start != -1 + && rx->offs[nums[i]].end != -1) + { + ret = newSVpvs(""); + CALLREG_NUMBUF(rx,nums[i],ret); + if (!retarray) + return ret; + } else { + ret = newSVsv(&PL_sv_undef); + } + if (retarray) { + SvREFCNT_inc_simple_void(ret); + av_push(retarray, ret); } } + if (retarray) + return (SV*)retarray; } } - if ( !parno ) { - return 0; + return NULL; +} + +void +Perl_reg_numbered_buff_get(pTHX_ REGEXP * const rx, const I32 paren, SV * const sv) +{ + char *s = NULL; + I32 i = 0; + I32 s1, t1; + + if (!rx->subbeg) { + sv_setsv(sv,&PL_sv_undef); + return; + } + else + if (paren == -2 && rx->offs[0].start != -1) { + /* $` */ + i = rx->offs[0].start; + s = rx->subbeg; + } + else + if (paren == -1 && rx->offs[0].end != -1) { + /* $' */ + s = rx->subbeg + rx->offs[0].end; + i = rx->sublen - rx->offs[0].end; + } + else + if ( 0 <= paren && paren <= (I32)rx->nparens && + (s1 = rx->offs[paren].start) != -1 && + (t1 = rx->offs[paren].end) != -1) + { + /* $& $1 ... */ + i = t1 - s1; + s = rx->subbeg + s1; + } else { + sv_setsv(sv,&PL_sv_undef); + return; + } + assert(rx->sublen >= (s - rx->subbeg) + i ); + if (i >= 0) { + const int oldtainted = PL_tainted; + TAINT_NOT; + sv_setpvn(sv, s, i); + PL_tainted = oldtainted; + if ( (rx->extflags & RXf_CANY_SEEN) + ? (RX_MATCH_UTF8(rx) + && (!i || is_utf8_string((U8*)s, i))) + : (RX_MATCH_UTF8(rx)) ) + { + SvUTF8_on(sv); + } + else + SvUTF8_off(sv); + if (PL_tainting) { + if (RX_MATCH_TAINTED(rx)) { + if (SvTYPE(sv) >= SVt_PVMG) { + MAGIC* const mg = SvMAGIC(sv); + MAGIC* mgt; + PL_tainted = 1; + SvMAGIC_set(sv, mg->mg_moremagic); + SvTAINT(sv); + if ((mgt = SvMAGIC(sv))) { + mg->mg_moremagic = mgt; + SvMAGIC_set(sv, mg); + } + } else { + PL_tainted = 1; + SvTAINT(sv); + } + } else + SvTAINTED_off(sv); + } } else { - GV *gv_paren; - SV *sv= sv_newmortal(); - Perl_sv_setpvf(aTHX_ sv, "%"IVdf,(IV)parno); - gv_paren= Perl_gv_fetchsv(aTHX_ sv, GV_ADD, SVt_PVGV); - return GvSVn(gv_paren); + sv_setsv(sv,&PL_sv_undef); + return; } } -#endif + +SV* +Perl_reg_qr_package(pTHX_ REGEXP * const rx) +{ + PERL_UNUSED_ARG(rx); + return newSVpvs("Regexp"); +} /* Scans the name of a named buffer from the pattern. * If flags is REG_RSN_RETURN_NULL returns null. @@ -4505,17 +4930,19 @@ Perl_reg_named_buff_sv(pTHX_ SV* namesv) STATIC SV* S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags) { char *name_start = RExC_parse; - if ( UTF ) { - STRLEN numlen; - while( isIDFIRST_uni(utf8n_to_uvchr((U8*)RExC_parse, - RExC_end - RExC_parse, &numlen, UTF8_ALLOW_DEFAULT))) - { - RExC_parse += numlen; - } - } else { - while( isIDFIRST(*RExC_parse) ) - RExC_parse++; + + if (isIDFIRST_lazy_if(RExC_parse, UTF)) { + /* skip IDFIRST by using do...while */ + if (UTF) + do { + RExC_parse += UTF8SKIP(RExC_parse); + } while (isALNUM_utf8((U8*)RExC_parse)); + else + do { + RExC_parse++; + } while (isALNUM(*RExC_parse)); } + if ( flags ) { SV* sv_name = sv_2mortal(Perl_newSVpvn(aTHX_ name_start, (int)(RExC_parse - name_start))); @@ -4564,7 +4991,7 @@ S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags) { PerlIO_printf(Perl_debug_log,"%16s",""); \ \ if (SIZE_ONLY) \ - num=RExC_size; \ + num = RExC_size + 1; \ else \ num=REG_NODE_NUM(RExC_emit); \ if (RExC_lastnum!=num) \ @@ -4619,6 +5046,8 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) const I32 oregflags = RExC_flags; bool have_branch = 0; bool is_open = 0; + I32 freeze_paren = 0; + I32 after_freeze = 0; /* for (?g), (?gc), and (?o) warnings; warning about (?c) will warn about (?g) -- japhy */ @@ -4635,15 +5064,117 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) GET_RE_DEBUG_FLAGS_DECL; DEBUG_PARSE("reg "); - *flagp = 0; /* Tentatively. */ /* Make an OPEN node, if parenthesized. */ if (paren) { + if ( *RExC_parse == '*') { /* (*VERB:ARG) */ + char *start_verb = RExC_parse; + STRLEN verb_len = 0; + char *start_arg = NULL; + unsigned char op = 0; + int argok = 1; + int internal_argval = 0; /* internal_argval is only useful if !argok */ + while ( *RExC_parse && *RExC_parse != ')' ) { + if ( *RExC_parse == ':' ) { + start_arg = RExC_parse + 1; + break; + } + RExC_parse++; + } + ++start_verb; + verb_len = RExC_parse - start_verb; + if ( start_arg ) { + RExC_parse++; + while ( *RExC_parse && *RExC_parse != ')' ) + RExC_parse++; + if ( *RExC_parse != ')' ) + vFAIL("Unterminated verb pattern argument"); + if ( RExC_parse == start_arg ) + start_arg = NULL; + } else { + if ( *RExC_parse != ')' ) + vFAIL("Unterminated verb pattern"); + } + + switch ( *start_verb ) { + case 'A': /* (*ACCEPT) */ + if ( memEQs(start_verb,verb_len,"ACCEPT") ) { + op = ACCEPT; + internal_argval = RExC_nestroot; + } + break; + case 'C': /* (*COMMIT) */ + if ( memEQs(start_verb,verb_len,"COMMIT") ) + op = COMMIT; + break; + case 'F': /* (*FAIL) */ + if ( verb_len==1 || memEQs(start_verb,verb_len,"FAIL") ) { + op = OPFAIL; + argok = 0; + } + break; + case ':': /* (*:NAME) */ + case 'M': /* (*MARK:NAME) */ + if ( verb_len==0 || memEQs(start_verb,verb_len,"MARK") ) { + op = MARKPOINT; + argok = -1; + } + break; + case 'P': /* (*PRUNE) */ + if ( memEQs(start_verb,verb_len,"PRUNE") ) + op = PRUNE; + break; + case 'S': /* (*SKIP) */ + if ( memEQs(start_verb,verb_len,"SKIP") ) + op = SKIP; + break; + case 'T': /* (*THEN) */ + /* [19:06] :: is then */ + if ( memEQs(start_verb,verb_len,"THEN") ) { + op = CUTGROUP; + RExC_seen |= REG_SEEN_CUTGROUP; + } + break; + } + if ( ! op ) { + RExC_parse++; + vFAIL3("Unknown verb pattern '%.*s'", + verb_len, start_verb); + } + if ( argok ) { + if ( start_arg && internal_argval ) { + vFAIL3("Verb pattern '%.*s' may not have an argument", + verb_len, start_verb); + } else if ( argok < 0 && !start_arg ) { + vFAIL3("Verb pattern '%.*s' has a mandatory argument", + verb_len, start_verb); + } else { + ret = reganode(pRExC_state, op, internal_argval); + if ( ! internal_argval && ! SIZE_ONLY ) { + if (start_arg) { + SV *sv = newSVpvn( start_arg, RExC_parse - start_arg); + ARG(ret) = add_data( pRExC_state, 1, "S" ); + RExC_rxi->data->data[ARG(ret)]=(void*)sv; + ret->flags = 0; + } else { + ret->flags = 1; + } + } + } + if (!internal_argval) + RExC_seen |= REG_SEEN_VERBARG; + } else if ( start_arg ) { + vFAIL3("Verb pattern '%.*s' may not have an argument", + verb_len, start_verb); + } else { + ret = reg_node(pRExC_state, op); + } + nextchar(pRExC_state); + return ret; + } else if (*RExC_parse == '?') { /* (?...) */ - U32 posflags = 0, negflags = 0; - U32 *flagsp = &posflags; bool is_logical = 0; const char * const seqstart = RExC_parse; @@ -4652,10 +5183,48 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) ret = NULL; /* For look-ahead/behind. */ switch (paren) { - case '<': /* (?<...) */ + case 'P': /* (?P...) variants for those used to PCRE/Python */ + paren = *RExC_parse++; + if ( paren == '<') /* (?P<...>) named capture */ + goto named_capture; + else if (paren == '>') { /* (?P>name) named recursion */ + goto named_recursion; + } + else if (paren == '=') { /* (?P=...) named backref */ + /* this pretty much dupes the code for \k in regatom(), if + you change this make sure you change that */ + char* name_start = RExC_parse; + U32 num = 0; + SV *sv_dat = reg_scan_name(pRExC_state, + SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA); + if (RExC_parse == name_start || *RExC_parse != ')') + vFAIL2("Sequence %.3s... not terminated",parse_start); + + if (!SIZE_ONLY) { + num = add_data( pRExC_state, 1, "S" ); + RExC_rxi->data->data[num]=(void*)sv_dat; + SvREFCNT_inc_simple_void(sv_dat); + } + RExC_sawback = 1; + ret = reganode(pRExC_state, + (U8)(FOLD ? (LOC ? NREFFL : NREFF) : NREF), + num); + *flagp |= HASWIDTH; + + Set_Node_Offset(ret, parse_start+1); + Set_Node_Cur_Length(ret); /* MJD */ + + nextchar(pRExC_state); + return ret; + } + RExC_parse++; + vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart); + /*NOTREACHED*/ + case '<': /* (?<...) */ if (*RExC_parse == '!') paren = ','; else if (*RExC_parse != '=') + named_capture: { /* (?<...>) */ char *name_start; SV *svname; @@ -4666,8 +5235,11 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) SIZE_ONLY ? /* reverse test from the others */ REG_RSN_RETURN_NAME : REG_RSN_RETURN_NULL); - if (RExC_parse == name_start) - goto unknown; + if (RExC_parse == name_start) { + RExC_parse++; + vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart); + /*NOTREACHED*/ + } if (*RExC_parse != paren) vFAIL2("Sequence (?%c... not terminated", paren=='>' ? '<' : paren); @@ -4680,7 +5252,11 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) if (!RExC_paren_names) { RExC_paren_names= newHV(); sv_2mortal((SV*)RExC_paren_names); - } +#ifdef DEBUGGING + RExC_paren_name_list= newAV(); + sv_2mortal((SV*)RExC_paren_name_list); +#endif + } he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 ); if ( he_str ) sv_dat = HeVAL(he_str); @@ -4689,17 +5265,36 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) Perl_croak(aTHX_ "panic: paren_name hash element allocation failed"); } else if ( SvPOK(sv_dat) ) { - IV count=SvIV(sv_dat); - I32 *pv=(I32*)SvGROW(sv_dat,SvCUR(sv_dat)+sizeof(I32)+1); - SvCUR_set(sv_dat,SvCUR(sv_dat)+sizeof(I32)); - pv[count]=RExC_npar; - SvIVX(sv_dat)++; + /* (?|...) can mean we have dupes so scan to check + its already been stored. Maybe a flag indicating + we are inside such a construct would be useful, + but the arrays are likely to be quite small, so + for now we punt -- dmq */ + IV count = SvIV(sv_dat); + I32 *pv = (I32*)SvPVX(sv_dat); + IV i; + for ( i = 0 ; i < count ; i++ ) { + if ( pv[i] == RExC_npar ) { + count = 0; + break; + } + } + if ( count ) { + pv = (I32*)SvGROW(sv_dat, SvCUR(sv_dat) + sizeof(I32)+1); + SvCUR_set(sv_dat, SvCUR(sv_dat) + sizeof(I32)); + pv[count] = RExC_npar; + SvIVX(sv_dat)++; + } } else { (void)SvUPGRADE(sv_dat,SVt_PVNV); sv_setpvn(sv_dat, (char *)&(RExC_npar), sizeof(I32)); SvIOK_on(sv_dat); SvIVX(sv_dat)= 1; } +#ifdef DEBUGGING + if (!av_store(RExC_paren_name_list, RExC_npar, SvREFCNT_inc(svname))) + SvREFCNT_dec(svname); +#endif /*sv_dump(sv_dat);*/ } @@ -4711,40 +5306,22 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) RExC_parse++; case '=': /* (?=...) */ case '!': /* (?!...) */ - if (*RExC_parse == ')') - goto do_op_fail; RExC_seen_zerolen++; + if (*RExC_parse == ')') { + ret=reg_node(pRExC_state, OPFAIL); + nextchar(pRExC_state); + return ret; + } + break; + case '|': /* (?|...) */ + /* branch reset, behave like a (?:...) except that + buffers in alternations share the same numbers */ + paren = ':'; + after_freeze = freeze_paren = RExC_npar; + break; case ':': /* (?:...) */ case '>': /* (?>...) */ break; - case 'C': - if (RExC_parse[0] == 'O' && - RExC_parse[1] == 'M' && - RExC_parse[2] == 'M' && - RExC_parse[3] == 'I' && - RExC_parse[4] == 'T' && - RExC_parse[5] == ')') - { - RExC_parse+=5; - ret = reg_node(pRExC_state, COMMIT); - } else { - vFAIL("Sequence (?C... not terminated"); - } - nextchar(pRExC_state); - return ret; - break; - case 'F': - if (RExC_parse[0] == 'A' && - RExC_parse[1] == 'I' && - RExC_parse[2] == 'L') - RExC_parse+=3; - if (*RExC_parse != ')') - vFAIL("Sequence (?FAIL) or (?F) not terminated"); - do_op_fail: - ret = reg_node(pRExC_state, OPFAIL); - nextchar(pRExC_state); - return ret; - break; case '$': /* (?$...) */ case '@': /* (?@...) */ vFAIL2("Sequence (?%c...) not implemented", (int)paren); @@ -4762,14 +5339,15 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) if (*RExC_parse != ')') FAIL("Sequence (?R) not terminated"); ret = reg_node(pRExC_state, GOSTART); + *flagp |= POSTPONED; nextchar(pRExC_state); return ret; /*notreached*/ { /* named and numeric backreferences */ I32 num; - char * parse_start; case '&': /* (?&NAME) */ parse_start = RExC_parse - 1; + named_recursion: { SV *sv_dat = reg_scan_name(pRExC_state, SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA); @@ -4777,17 +5355,54 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) } goto gen_recurse_regop; /* NOT REACHED */ + case '+': + if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) { + RExC_parse++; + vFAIL("Illegal pattern"); + } + goto parse_recursion; + /* NOT REACHED*/ + case '-': /* (?-1) */ + if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) { + RExC_parse--; /* rewind to let it be handled later */ + goto parse_flags; + } + /*FALLTHROUGH */ case '1': case '2': case '3': case '4': /* (?1) */ case '5': case '6': case '7': case '8': case '9': RExC_parse--; + parse_recursion: num = atoi(RExC_parse); parse_start = RExC_parse - 1; /* MJD */ + if (*RExC_parse == '-') + RExC_parse++; while (isDIGIT(*RExC_parse)) RExC_parse++; if (*RExC_parse!=')') vFAIL("Expecting close bracket"); gen_recurse_regop: + if ( paren == '-' ) { + /* + Diagram of capture buffer numbering. + Top line is the normal capture buffer numbers + Botton line is the negative indexing as from + the X (the (?-2)) + + + 1 2 3 4 5 X 6 7 + /(a(x)y)(a(b(c(?-2)d)e)f)(g(h))/ + - 5 4 3 2 1 X x x + + */ + num = RExC_npar + num; + if (num < 1) { + RExC_parse++; + vFAIL("Reference to nonexistent group"); + } + } else if ( paren == '+' ) { + num = RExC_npar + num - 1; + } + ret = reganode(pRExC_state, GOSUB, num); if (!SIZE_ONLY) { if (num > (I32)RExC_rx->nparens) { @@ -4805,24 +5420,26 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) Set_Node_Length(ret, 1 + regarglen[OP(ret)]); /* MJD */ Set_Node_Offset(ret, parse_start); /* MJD */ + *flagp |= POSTPONED; nextchar(pRExC_state); return ret; } /* named and numeric backreferences */ /* NOT REACHED */ - case 'p': /* (?p...) */ - if (SIZE_ONLY && ckWARN2(WARN_DEPRECATED, WARN_REGEXP)) - vWARNdep(RExC_parse, "(?p{}) is deprecated - use (??{})"); - /* FALL THROUGH*/ case '?': /* (??...) */ is_logical = 1; - if (*RExC_parse != '{') - goto unknown; + if (*RExC_parse != '{') { + RExC_parse++; + vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart); + /*NOTREACHED*/ + } + *flagp |= POSTPONED; paren = *RExC_parse++; /* FALL THROUGH */ case '{': /* (?{...}) */ { - I32 count = 1, n = 0; + I32 count = 1; + U32 n = 0; char c; char *s = RExC_parse; @@ -4857,9 +5474,9 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) LEAVE; n = add_data(pRExC_state, 3, "nop"); - RExC_rx->data->data[n] = (void*)rop; - RExC_rx->data->data[n+1] = (void*)sop; - RExC_rx->data->data[n+2] = (void*)pad; + RExC_rxi->data->data[n] = (void*)rop; + RExC_rxi->data->data[n+1] = (void*)sop; + RExC_rxi->data->data[n+2] = (void*)pad; SvREFCNT_dec(sv); } else { /* First pass */ @@ -4911,7 +5528,7 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) { char ch = RExC_parse[0] == '<' ? '>' : '\''; char *name_start= RExC_parse++; - I32 num = 0; + U32 num = 0; SV *sv_dat=reg_scan_name(pRExC_state, SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA); if (RExC_parse == name_start || *RExC_parse != ch) @@ -4920,8 +5537,8 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) RExC_parse++; if (!SIZE_ONLY) { num = add_data( pRExC_state, 1, "S" ); - RExC_rx->data->data[num]=(void*)sv_dat; - SvREFCNT_inc(sv_dat); + RExC_rxi->data->data[num]=(void*)sv_dat; + SvREFCNT_inc_simple_void(sv_dat); } ret = reganode(pRExC_state,NGROUPP,num); goto insert_if_check_paren; @@ -4999,6 +5616,9 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) } else REGTAIL(pRExC_state, ret, ender); + RExC_size++; /* XXX WHY do we need this?!! + For large programs it seems to be required + but I can't figure out why. -- dmq*/ return ret; } else { @@ -5010,13 +5630,20 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) vFAIL("Sequence (? incomplete"); break; default: - --RExC_parse; - parse_flags: /* (?i) */ - while (*RExC_parse && strchr("iogcmsx", *RExC_parse)) { + --RExC_parse; + parse_flags: /* (?i) */ + { + U32 posflags = 0, negflags = 0; + U32 *flagsp = &posflags; + + while (*RExC_parse) { + /* && strchr("iogcmsx", *RExC_parse) */ /* (?g), (?gc) and (?o) are useless here and must be globally applied -- japhy */ - - if (*RExC_parse == 'o' || *RExC_parse == 'g') { + switch (*RExC_parse) { + CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp); + case 'o': + case 'g': if (SIZE_ONLY && ckWARN(WARN_REGEXP)) { const I32 wflagbit = *RExC_parse == 'o' ? WASTED_O : WASTED_G; if (! (wastedflags & wflagbit) ) { @@ -5031,8 +5658,9 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) ); } } - } - else if (*RExC_parse == 'c') { + break; + + case 'c': if (SIZE_ONLY && ckWARN(WARN_REGEXP)) { if (! (wastedflags & WASTED_C) ) { wastedflags |= WASTED_GC; @@ -5044,44 +5672,65 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) ); } } - } - else { pmflag(flagsp, *RExC_parse); } - - ++RExC_parse; - } - if (*RExC_parse == '-') { - flagsp = &negflags; - wastedflags = 0; /* reset so (?g-c) warns twice */ + break; + case 'k': + if (flagsp == &negflags) { + if (SIZE_ONLY && ckWARN(WARN_REGEXP)) + vWARN(RExC_parse + 1,"Useless use of (?-k)"); + } else { + *flagsp |= RXf_PMf_KEEPCOPY; + } + break; + case '-': + if (flagsp == &negflags) { + RExC_parse++; + vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart); + /*NOTREACHED*/ + } + flagsp = &negflags; + wastedflags = 0; /* reset so (?g-c) warns twice */ + break; + case ':': + paren = ':'; + /*FALLTHROUGH*/ + case ')': + RExC_flags |= posflags; + RExC_flags &= ~negflags; + nextchar(pRExC_state); + if (paren != ':') { + *flagp = TRYAGAIN; + return NULL; + } else { + ret = NULL; + goto parse_rest; + } + /*NOTREACHED*/ + default: + RExC_parse++; + vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart); + /*NOTREACHED*/ + } ++RExC_parse; - goto parse_flags; - } - RExC_flags |= posflags; - RExC_flags &= ~negflags; - if (*RExC_parse == ':') { - RExC_parse++; - paren = ':'; - break; - } - unknown: - if (*RExC_parse != ')') { - RExC_parse++; - vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart); } - nextchar(pRExC_state); - *flagp = TRYAGAIN; - return NULL; - } + }} /* one for the default block, one for the switch */ } else { /* (...) */ capturing_parens: parno = RExC_npar; RExC_npar++; + ret = reganode(pRExC_state, OPEN, parno); - if (!SIZE_ONLY && RExC_seen & REG_SEEN_RECURSE) { - DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log, + if (!SIZE_ONLY ){ + if (!RExC_nestroot) + RExC_nestroot = parno; + if (RExC_seen & REG_SEEN_RECURSE + && !RExC_open_parens[parno-1]) + { + DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log, "Setting open paren #%"IVdf" to %d\n", (IV)parno, REG_NODE_NUM(ret))); - RExC_open_parens[parno-1]= ret; + RExC_open_parens[parno-1]= ret; + } } Set_Node_Length(ret, 1); /* MJD */ Set_Node_Offset(ret, RExC_parse); /* MJD */ @@ -5090,7 +5739,8 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) } else /* ! paren */ ret = NULL; - + + parse_rest: /* Pick up the branches, linking them together. */ parse_start = RExC_parse; /* MJD */ br = regbranch(pRExC_state, &flags, 1,depth+1); @@ -5119,7 +5769,7 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) } else if (paren != '?') /* Not Conditional */ ret = br; - *flagp |= flags & (SPSTART | HASWIDTH); + *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED); lastbr = br; while (*RExC_parse == '|') { if (!SIZE_ONLY && RExC_extralen) { @@ -5129,15 +5779,18 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) if (SIZE_ONLY) RExC_extralen += 2; /* Account for LONGJMP. */ nextchar(pRExC_state); + if (freeze_paren) { + if (RExC_npar > after_freeze) + after_freeze = RExC_npar; + RExC_npar = freeze_paren; + } br = regbranch(pRExC_state, &flags, 0, depth+1); if (br == NULL) return(NULL); REGTAIL(pRExC_state, lastbr, br); /* BRANCH -> BRANCH. */ lastbr = br; - if (flags&HASWIDTH) - *flagp |= HASWIDTH; - *flagp |= flags&SPSTART; + *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED); } if (have_branch || paren != ':') { @@ -5153,6 +5806,8 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) "Setting close paren #%"IVdf" to %d\n", (IV)parno, REG_NODE_NUM(ender))); RExC_close_parens[parno-1]= ender; + if (RExC_nestroot == parno) + RExC_nestroot = 0; } Set_Node_Offset(ender,RExC_parse+1); /* MJD */ Set_Node_Length(ender,1); /* MJD */ @@ -5228,7 +5883,8 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) FAIL("Junk on end of regexp"); /* "Can't happen". */ /* NOTREACHED */ } - + if (after_freeze) + RExC_npar = after_freeze; return(ret); } @@ -5247,6 +5903,7 @@ S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth) I32 flags = 0, c = 0; GET_RE_DEBUG_FLAGS_DECL; DEBUG_PARSE("brnc"); + if (first) ret = NULL; else { @@ -5275,7 +5932,7 @@ S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth) } else if (ret == NULL) ret = latest; - *flagp |= flags&HASWIDTH; + *flagp |= flags&(HASWIDTH|POSTPONED); if (chain == NULL) /* First piece. */ *flagp |= flags&SPSTART; else { @@ -5457,7 +6114,7 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) goto do_curly; } nest_check: - if (!SIZE_ONLY && !(flags&HASWIDTH) && max > REG_INFTY/3 && ckWARN(WARN_REGEXP)) { + if (!SIZE_ONLY && !(flags&(HASWIDTH|POSTPONED)) && max > REG_INFTY/3 && ckWARN(WARN_REGEXP)) { vWARN3(RExC_parse, "%.*s matches null string many times", (int)(RExC_parse >= origparse ? RExC_parse - origparse : 0), @@ -5682,7 +6339,9 @@ S_reg_namedseq(pTHX_ RExC_state_t *pRExC_state, UV *valuep) char *s; char *p, *pend; STRLEN charlen = 1; +#ifdef DEBUGGING char * parse_start = name-3; /* needed for the offsets */ +#endif GET_RE_DEBUG_FLAGS_DECL; /* needed for the offsets */ ret = reg_node(pRExC_state, @@ -5760,18 +6419,60 @@ S_reg_namedseq(pTHX_ RExC_state_t *pRExC_state, UV *valuep) } - /* - - regatom - the lowest level + * reg_recode * - * Optimization: gobbles an entire sequence of ordinary characters so that - * it can turn them into a single node, which is smaller to store and - * faster to run. Backslashed characters are exceptions, each becoming a - * separate node; the code is simpler that way and it's not worth fixing. + * It returns the code point in utf8 for the value in *encp. + * value: a code value in the source encoding + * encp: a pointer to an Encode object * - * [Yes, it is worth fixing, some scripts can run twice the speed.] - * [It looks like its ok, as in S_study_chunk we merge adjacent EXACT nodes] + * If the result from Encode is not a single character, + * it returns U+FFFD (Replacement character) and sets *encp to NULL. */ +STATIC UV +S_reg_recode(pTHX_ const char value, SV **encp) +{ + STRLEN numlen = 1; + SV * const sv = sv_2mortal(newSVpvn(&value, numlen)); + const char * const s = *encp ? sv_recode_to_utf8(sv, *encp) : SvPVX(sv); + const STRLEN newlen = SvCUR(sv); + UV uv = UNICODE_REPLACEMENT; + + if (newlen) + uv = SvUTF8(sv) + ? utf8n_to_uvchr((U8*)s, newlen, &numlen, UTF8_ALLOW_DEFAULT) + : *(U8*)s; + + if (!newlen || numlen != newlen) { + uv = UNICODE_REPLACEMENT; + *encp = NULL; + } + return uv; +} + + +/* + - regatom - the lowest level + + Try to identify anything special at the start of the pattern. If there + is, then handle it as required. This may involve generating a single regop, + such as for an assertion; or it may involve recursing, such as to + handle a () structure. + + If the string doesn't start with something special then we gobble up + as much literal text as we can. + + Once we have been able to handle whatever type of thing started the + sequence, we return. + + Note: we have to be careful with escapes, as they can be both literal + and special, and in the case of \10 and friends can either, depending + on context. Specifically there are two seperate switches for handling + escape sequences, with the one for handling literal escapes requiring + a dummy entry for all of the special escapes that are actually handled + by the other. +*/ + STATIC regnode * S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) { @@ -5783,14 +6484,15 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) DEBUG_PARSE("atom"); *flagp = WORST; /* Tentatively. */ + tryagain: - switch (*RExC_parse) { + switch ((U8)*RExC_parse) { case '^': RExC_seen_zerolen++; nextchar(pRExC_state); - if (RExC_flags & PMf_MULTILINE) + if (RExC_flags & RXf_PMf_MULTILINE) ret = reg_node(pRExC_state, MBOL); - else if (RExC_flags & PMf_SINGLELINE) + else if (RExC_flags & RXf_PMf_SINGLELINE) ret = reg_node(pRExC_state, SBOL); else ret = reg_node(pRExC_state, BOL); @@ -5800,9 +6502,9 @@ tryagain: nextchar(pRExC_state); if (*RExC_parse) RExC_seen_zerolen++; - if (RExC_flags & PMf_MULTILINE) + if (RExC_flags & RXf_PMf_MULTILINE) ret = reg_node(pRExC_state, MEOL); - else if (RExC_flags & PMf_SINGLELINE) + else if (RExC_flags & RXf_PMf_SINGLELINE) ret = reg_node(pRExC_state, SEOL); else ret = reg_node(pRExC_state, EOL); @@ -5810,7 +6512,7 @@ tryagain: break; case '.': nextchar(pRExC_state); - if (RExC_flags & PMf_SINGLELINE) + if (RExC_flags & RXf_PMf_SINGLELINE) ret = reg_node(pRExC_state, SANY); else ret = reg_node(pRExC_state, REG_ANY); @@ -5845,7 +6547,7 @@ tryagain: } return(NULL); } - *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE); + *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED); break; case '|': case ')': @@ -5868,105 +6570,136 @@ tryagain: RExC_parse++; vFAIL("Quantifier follows nothing"); break; + case 0xDF: + case 0xC3: + case 0xCE: + if (!LOC && FOLD) { + U32 len,cp; + if ((cp = what_len_TRICKYFOLD_safe(RExC_parse,RExC_end,UTF,len))) { + *flagp |= HASWIDTH; /* could be SIMPLE too, but needs a handler in regexec.regrepeat */ + RExC_parse+=len-1; /* we get one from nextchar() as well. :-( */ + ret = reganode(pRExC_state, FOLDCHAR, cp); + Set_Node_Length(ret, 1); /* MJD */ + nextchar(pRExC_state); /* kill whitespace under /x */ + return ret; + } + } + goto outer_default; case '\\': + /* Special Escapes + + This switch handles escape sequences that resolve to some kind + of special regop and not to literal text. Escape sequnces that + resolve to literal text are handled below in the switch marked + "Literal Escapes". + + Every entry in this switch *must* have a corresponding entry + in the literal escape switch. However, the opposite is not + required, as the default for this switch is to jump to the + literal text handling code. + */ switch (*++RExC_parse) { + /* Special Escapes */ case 'A': RExC_seen_zerolen++; ret = reg_node(pRExC_state, SBOL); *flagp |= SIMPLE; - nextchar(pRExC_state); - Set_Node_Length(ret, 2); /* MJD */ - break; + goto finish_meta_pat; case 'G': ret = reg_node(pRExC_state, GPOS); RExC_seen |= REG_SEEN_GPOS; *flagp |= SIMPLE; - nextchar(pRExC_state); - Set_Node_Length(ret, 2); /* MJD */ - break; + goto finish_meta_pat; + case 'K': + RExC_seen_zerolen++; + ret = reg_node(pRExC_state, KEEPS); + *flagp |= SIMPLE; + goto finish_meta_pat; case 'Z': ret = reg_node(pRExC_state, SEOL); *flagp |= SIMPLE; RExC_seen_zerolen++; /* Do not optimize RE away */ - nextchar(pRExC_state); - break; + goto finish_meta_pat; case 'z': ret = reg_node(pRExC_state, EOS); *flagp |= SIMPLE; RExC_seen_zerolen++; /* Do not optimize RE away */ - nextchar(pRExC_state); - Set_Node_Length(ret, 2); /* MJD */ - break; + goto finish_meta_pat; case 'C': ret = reg_node(pRExC_state, CANY); RExC_seen |= REG_SEEN_CANY; *flagp |= HASWIDTH|SIMPLE; - nextchar(pRExC_state); - Set_Node_Length(ret, 2); /* MJD */ - break; + goto finish_meta_pat; case 'X': ret = reg_node(pRExC_state, CLUMP); *flagp |= HASWIDTH; - nextchar(pRExC_state); - Set_Node_Length(ret, 2); /* MJD */ - break; + goto finish_meta_pat; case 'w': ret = reg_node(pRExC_state, (U8)(LOC ? ALNUML : ALNUM)); *flagp |= HASWIDTH|SIMPLE; - nextchar(pRExC_state); - Set_Node_Length(ret, 2); /* MJD */ - break; + goto finish_meta_pat; case 'W': ret = reg_node(pRExC_state, (U8)(LOC ? NALNUML : NALNUM)); *flagp |= HASWIDTH|SIMPLE; - nextchar(pRExC_state); - Set_Node_Length(ret, 2); /* MJD */ - break; + goto finish_meta_pat; case 'b': RExC_seen_zerolen++; RExC_seen |= REG_SEEN_LOOKBEHIND; ret = reg_node(pRExC_state, (U8)(LOC ? BOUNDL : BOUND)); *flagp |= SIMPLE; - nextchar(pRExC_state); - Set_Node_Length(ret, 2); /* MJD */ - break; + goto finish_meta_pat; case 'B': RExC_seen_zerolen++; RExC_seen |= REG_SEEN_LOOKBEHIND; ret = reg_node(pRExC_state, (U8)(LOC ? NBOUNDL : NBOUND)); *flagp |= SIMPLE; - nextchar(pRExC_state); - Set_Node_Length(ret, 2); /* MJD */ - break; + goto finish_meta_pat; case 's': ret = reg_node(pRExC_state, (U8)(LOC ? SPACEL : SPACE)); *flagp |= HASWIDTH|SIMPLE; - nextchar(pRExC_state); - Set_Node_Length(ret, 2); /* MJD */ - break; + goto finish_meta_pat; case 'S': ret = reg_node(pRExC_state, (U8)(LOC ? NSPACEL : NSPACE)); *flagp |= HASWIDTH|SIMPLE; - nextchar(pRExC_state); - Set_Node_Length(ret, 2); /* MJD */ - break; + goto finish_meta_pat; case 'd': ret = reg_node(pRExC_state, DIGIT); *flagp |= HASWIDTH|SIMPLE; - nextchar(pRExC_state); - Set_Node_Length(ret, 2); /* MJD */ - break; + goto finish_meta_pat; case 'D': ret = reg_node(pRExC_state, NDIGIT); *flagp |= HASWIDTH|SIMPLE; + goto finish_meta_pat; + case 'R': + ret = reg_node(pRExC_state, LNBREAK); + *flagp |= HASWIDTH|SIMPLE; + goto finish_meta_pat; + case 'h': + ret = reg_node(pRExC_state, HORIZWS); + *flagp |= HASWIDTH|SIMPLE; + goto finish_meta_pat; + case 'H': + ret = reg_node(pRExC_state, NHORIZWS); + *flagp |= HASWIDTH|SIMPLE; + goto finish_meta_pat; + case 'v': + ret = reg_node(pRExC_state, VERTWS); + *flagp |= HASWIDTH|SIMPLE; + goto finish_meta_pat; + case 'V': + ret = reg_node(pRExC_state, NVERTWS); + *flagp |= HASWIDTH|SIMPLE; + finish_meta_pat: nextchar(pRExC_state); Set_Node_Length(ret, 2); /* MJD */ - break; + break; case 'p': case 'P': { char* const oldregxend = RExC_end; +#ifdef DEBUGGING char* parse_start = RExC_parse - 2; +#endif if (RExC_parse[1] == '{') { /* a lovely hack--pretend we saw [\pX] instead */ @@ -6006,70 +6739,89 @@ tryagain: ret= reg_namedseq(pRExC_state, NULL); break; case 'k': /* Handle \k and \k'NAME' */ + parse_named_seq: { char ch= RExC_parse[1]; - if (ch != '<' && ch != '\'') { - if (SIZE_ONLY) - vWARN( RExC_parse + 1, - "Possible broken named back reference treated as literal k"); - parse_start--; - goto defchar; + if (ch != '<' && ch != '\'' && ch != '{') { + RExC_parse++; + vFAIL2("Sequence %.2s... not terminated",parse_start); } else { + /* this pretty much dupes the code for (?P=...) in reg(), if + you change this make sure you change that */ char* name_start = (RExC_parse += 2); - I32 num = 0; + U32 num = 0; SV *sv_dat = reg_scan_name(pRExC_state, SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA); - ch= (ch == '<') ? '>' : '\''; - + ch= (ch == '<') ? '>' : (ch == '{') ? '}' : '\''; if (RExC_parse == name_start || *RExC_parse != ch) - vFAIL2("Sequence \\k%c... not terminated", - (ch == '>' ? '<' : ch)); - + vFAIL2("Sequence %.3s... not terminated",parse_start); + + if (!SIZE_ONLY) { + num = add_data( pRExC_state, 1, "S" ); + RExC_rxi->data->data[num]=(void*)sv_dat; + SvREFCNT_inc_simple_void(sv_dat); + } + RExC_sawback = 1; ret = reganode(pRExC_state, (U8)(FOLD ? (LOC ? NREFFL : NREFF) : NREF), num); *flagp |= HASWIDTH; - - - if (!SIZE_ONLY) { - num = add_data( pRExC_state, 1, "S" ); - ARG_SET(ret,num); - RExC_rx->data->data[num]=(void*)sv_dat; - SvREFCNT_inc(sv_dat); - } + /* override incorrect value set in reganode MJD */ Set_Node_Offset(ret, parse_start+1); Set_Node_Cur_Length(ret); /* MJD */ nextchar(pRExC_state); - + } break; - } - case 'n': - case 'r': - case 't': - case 'f': - case 'e': - case 'a': - case 'x': - case 'c': - case '0': - goto defchar; + } + case 'g': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': { - const I32 num = atoi(RExC_parse); - - if (num > 9 && num >= RExC_npar) + I32 num; + bool isg = *RExC_parse == 'g'; + bool isrel = 0; + bool hasbrace = 0; + if (isg) { + RExC_parse++; + if (*RExC_parse == '{') { + RExC_parse++; + hasbrace = 1; + } + if (*RExC_parse == '-') { + RExC_parse++; + isrel = 1; + } + if (hasbrace && !isDIGIT(*RExC_parse)) { + if (isrel) RExC_parse--; + RExC_parse -= 2; + goto parse_named_seq; + } } + num = atoi(RExC_parse); + if (isrel) { + num = RExC_npar - num; + if (num < 1) + vFAIL("Reference to nonexistent or unclosed group"); + } + if (!isg && num > 9 && num >= RExC_npar) goto defchar; else { char * const parse_start = RExC_parse - 1; /* MJD */ while (isDIGIT(*RExC_parse)) RExC_parse++; - - if (!SIZE_ONLY && num > (I32)RExC_rx->nparens) - vFAIL("Reference to nonexistent group"); + if (parse_start == RExC_parse - 1) + vFAIL("Unterminated \\g... pattern"); + if (hasbrace) { + if (*RExC_parse != '}') + vFAIL("Unterminated \\g{...} pattern"); + RExC_parse++; + } + if (!SIZE_ONLY) { + if (num > (I32)RExC_rx->nparens) + vFAIL("Reference to nonexistent group"); + } RExC_sawback = 1; ret = reganode(pRExC_state, (U8)(FOLD ? (LOC ? REFFL : REFF) : REF), @@ -6097,15 +6849,14 @@ tryagain: break; case '#': - if (RExC_flags & PMf_EXTENDED) { - while (RExC_parse < RExC_end && *RExC_parse != '\n') - RExC_parse++; - if (RExC_parse < RExC_end) + if (RExC_flags & RXf_PMf_EXTENDED) { + if ( reg_skipcomment( pRExC_state ) ) goto tryagain; } /* FALL THROUGH */ - default: { + default: + outer_default:{ register STRLEN len; register UV ender; register char *p; @@ -6128,9 +6879,14 @@ tryagain: { char * const oldp = p; - if (RExC_flags & PMf_EXTENDED) - p = regwhite(p, RExC_end); - switch (*p) { + if (RExC_flags & RXf_PMf_EXTENDED) + p = regwhite( pRExC_state, p ); + switch ((U8)*p) { + case 0xDF: + case 0xC3: + case 0xCE: + if (LOC || !FOLD || !is_TRICKYFOLD_safe(p,RExC_end,UTF)) + goto normal_default; case '^': case '$': case '.': @@ -6140,26 +6896,42 @@ tryagain: case '|': goto loopdone; case '\\': + /* Literal Escapes Switch + + This switch is meant to handle escape sequences that + resolve to a literal character. + + Every escape sequence that represents something + else, like an assertion or a char class, is handled + in the switch marked 'Special Escapes' above in this + routine, but also has an entry here as anything that + isn't explicitly mentioned here will be treated as + an unescaped equivalent literal. + */ + switch (*++p) { - case 'A': - case 'C': - case 'X': - case 'G': - case 'Z': - case 'z': - case 'w': - case 'W': - case 'b': - case 'B': - case 's': - case 'S': - case 'd': - case 'D': - case 'p': - case 'P': - case 'N': + /* These are all the special escapes. */ + case 'A': /* Start assertion */ + case 'b': case 'B': /* Word-boundary assertion*/ + case 'C': /* Single char !DANGEROUS! */ + case 'd': case 'D': /* digit class */ + case 'g': case 'G': /* generic-backref, pos assertion */ + case 'h': case 'H': /* HORIZWS */ + case 'k': case 'K': /* named backref, keep marker */ + case 'N': /* named char sequence */ + case 'p': case 'P': /* unicode property */ + case 'R': /* LNBREAK */ + case 's': case 'S': /* space class */ + case 'v': case 'V': /* VERTWS */ + case 'w': case 'W': /* word class */ + case 'X': /* eXtended Unicode "combining character sequence" */ + case 'z': case 'Z': /* End of line/string assertion */ --p; goto loopdone; + + /* Anything after here is an escape that resolves to a + literal. (Except digits, which may or may not) + */ case 'n': ender = '\n'; p++; @@ -6208,6 +6980,8 @@ tryagain: ender = grok_hex(p, &numlen, &flags, NULL); p += numlen; } + if (PL_encoding && ender < 0x100) + goto recode_encoding; break; case 'c': p++; @@ -6227,6 +7001,17 @@ tryagain: --p; goto loopdone; } + if (PL_encoding && ender < 0x100) + goto recode_encoding; + break; + recode_encoding: + { + SV* enc = PL_encoding; + ender = reg_recode((const char)(U8)ender, &enc); + if (!enc && SIZE_ONLY && ckWARN(WARN_REGEXP)) + vWARN(p, "Invalid escape in the specified encoding"); + RExC_utf8 = 1; + } break; case '\0': if (p >= RExC_end) @@ -6250,13 +7035,13 @@ tryagain: ender = *p++; break; } - if (RExC_flags & PMf_EXTENDED) - p = regwhite(p, RExC_end); + if ( RExC_flags & RXf_PMf_EXTENDED) + p = regwhite( pRExC_state, p ); if (UTF && FOLD) { /* Prime the casefolded buffer. */ ender = toFOLD_uni(ender, tmpbuf, &foldlen); } - if (ISMULT2(p)) { /* Back off on ?+*. */ + if (p < RExC_end && ISMULT2(p)) { /* Back off on ?+*. */ if (len) p = oldp; else if (UTF) { @@ -6354,46 +7139,26 @@ tryagain: break; } - /* If the encoding pragma is in effect recode the text of - * any EXACT-kind nodes. */ - if (ret && PL_encoding && PL_regkind[OP(ret)] == EXACT) { - const STRLEN oldlen = STR_LEN(ret); - SV * const sv = sv_2mortal(newSVpvn(STRING(ret), oldlen)); - - if (RExC_utf8) - SvUTF8_on(sv); - if (sv_utf8_downgrade(sv, TRUE)) { - const char * const s = sv_recode_to_utf8(sv, PL_encoding); - const STRLEN newlen = SvCUR(sv); - - if (SvUTF8(sv)) - RExC_utf8 = 1; - if (!SIZE_ONLY) { - GET_RE_DEBUG_FLAGS_DECL; - DEBUG_COMPILE_r(PerlIO_printf(Perl_debug_log, "recode %*s to %*s\n", - (int)oldlen, STRING(ret), - (int)newlen, s)); - Copy(s, STRING(ret), newlen, char); - STR_LEN(ret) += newlen - oldlen; - RExC_emit += STR_SZ(newlen) - STR_SZ(oldlen); - } else - RExC_size += STR_SZ(newlen) - STR_SZ(oldlen); - } - } - return(ret); } STATIC char * -S_regwhite(char *p, const char *e) +S_regwhite( RExC_state_t *pRExC_state, char *p ) { + const char *e = RExC_end; while (p < e) { if (isSPACE(*p)) ++p; else if (*p == '#') { + bool ended = 0; do { - p++; - } while (p < e && *p != '\n'); + if (*p++ == '\n') { + ended = 1; + break; + } + } while (p < e); + if (!ended) + RExC_seen |= REG_SEEN_RUN_ON_COMMENT; } else break; @@ -6556,19 +7321,61 @@ S_checkposixcc(pTHX_ RExC_state_t *pRExC_state) } +#define _C_C_T_(NAME,TEST,WORD) \ +ANYOF_##NAME: \ + if (LOC) \ + ANYOF_CLASS_SET(ret, ANYOF_##NAME); \ + else { \ + for (value = 0; value < 256; value++) \ + if (TEST) \ + ANYOF_BITMAP_SET(ret, value); \ + } \ + yesno = '+'; \ + what = WORD; \ + break; \ +case ANYOF_N##NAME: \ + if (LOC) \ + ANYOF_CLASS_SET(ret, ANYOF_N##NAME); \ + else { \ + for (value = 0; value < 256; value++) \ + if (!TEST) \ + ANYOF_BITMAP_SET(ret, value); \ + } \ + yesno = '!'; \ + what = WORD; \ + break + +#define _C_C_T_NOLOC_(NAME,TEST,WORD) \ +ANYOF_##NAME: \ + for (value = 0; value < 256; value++) \ + if (TEST) \ + ANYOF_BITMAP_SET(ret, value); \ + yesno = '+'; \ + what = WORD; \ + break; \ +case ANYOF_N##NAME: \ + for (value = 0; value < 256; value++) \ + if (!TEST) \ + ANYOF_BITMAP_SET(ret, value); \ + yesno = '!'; \ + what = WORD; \ + break + /* parse a class specification and produce either an ANYOF node that - matches the pattern. If the pattern matches a single char only and - that char is < 256 then we produce an EXACT node instead. + matches the pattern or if the pattern matches a single char only and + that char is < 256 and we are case insensitive then we produce an + EXACT node instead. */ + STATIC regnode * S_regclass(pTHX_ RExC_state_t *pRExC_state, U32 depth) { dVAR; - register UV value = 0; register UV nextvalue; register IV prevvalue = OOB_UNICODE; register IV range = 0; + UV value = 0; /* XXX:dmq: needs to be referenceable (unfortunately) */ register regnode *ret; STRLEN numlen; IV namedclass; @@ -6671,6 +7478,10 @@ parseit: case 'S': namedclass = ANYOF_NSPACE; break; case 'd': namedclass = ANYOF_DIGIT; break; case 'D': namedclass = ANYOF_NDIGIT; break; + case 'v': namedclass = ANYOF_VERTWS; break; + case 'V': namedclass = ANYOF_NVERTWS; break; + case 'h': namedclass = ANYOF_HORIZWS; break; + case 'H': namedclass = ANYOF_NHORIZWS; break; case 'N': /* Handle \N{NAME} in class */ { /* We only pay attention to the first char of @@ -6751,6 +7562,8 @@ parseit: value = grok_hex(RExC_parse, &numlen, &flags, NULL); RExC_parse += numlen; } + if (PL_encoding && value < 0x100) + goto recode_encoding; break; case 'c': value = UCHARAT(RExC_parse++); @@ -6758,13 +7571,24 @@ parseit: break; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': - { - I32 flags = 0; - numlen = 3; - value = grok_oct(--RExC_parse, &numlen, &flags, NULL); - RExC_parse += numlen; - break; - } + { + I32 flags = 0; + numlen = 3; + value = grok_oct(--RExC_parse, &numlen, &flags, NULL); + RExC_parse += numlen; + if (PL_encoding && value < 0x100) + goto recode_encoding; + break; + } + recode_encoding: + { + SV* enc = PL_encoding; + value = reg_recode((const char)(U8)value, &enc); + if (!enc && SIZE_ONLY && ckWARN(WARN_REGEXP)) + vWARN(RExC_parse, + "Invalid escape in the specified encoding"); + break; + } default: if (!SIZE_ONLY && isALPHA(value) && ckWARN(WARN_REGEXP)) vWARN2(RExC_parse, @@ -6810,6 +7634,8 @@ parseit: range = 0; /* this was not a true range */ } + + if (!SIZE_ONLY) { const char *what = NULL; char yesno = 0; @@ -6821,72 +7647,21 @@ parseit: * A similar issue a little earlier when switching on value. * --jhi */ switch ((I32)namedclass) { - case ANYOF_ALNUM: - if (LOC) - ANYOF_CLASS_SET(ret, ANYOF_ALNUM); - else { - for (value = 0; value < 256; value++) - if (isALNUM(value)) - ANYOF_BITMAP_SET(ret, value); - } - yesno = '+'; - what = "Word"; - break; - case ANYOF_NALNUM: - if (LOC) - ANYOF_CLASS_SET(ret, ANYOF_NALNUM); - else { - for (value = 0; value < 256; value++) - if (!isALNUM(value)) - ANYOF_BITMAP_SET(ret, value); - } - yesno = '!'; - what = "Word"; - break; - case ANYOF_ALNUMC: - if (LOC) - ANYOF_CLASS_SET(ret, ANYOF_ALNUMC); - else { - for (value = 0; value < 256; value++) - if (isALNUMC(value)) - ANYOF_BITMAP_SET(ret, value); - } - yesno = '+'; - what = "Alnum"; - break; - case ANYOF_NALNUMC: - if (LOC) - ANYOF_CLASS_SET(ret, ANYOF_NALNUMC); - else { - for (value = 0; value < 256; value++) - if (!isALNUMC(value)) - ANYOF_BITMAP_SET(ret, value); - } - yesno = '!'; - what = "Alnum"; - break; - case ANYOF_ALPHA: - if (LOC) - ANYOF_CLASS_SET(ret, ANYOF_ALPHA); - else { - for (value = 0; value < 256; value++) - if (isALPHA(value)) - ANYOF_BITMAP_SET(ret, value); - } - yesno = '+'; - what = "Alpha"; - break; - case ANYOF_NALPHA: - if (LOC) - ANYOF_CLASS_SET(ret, ANYOF_NALPHA); - else { - for (value = 0; value < 256; value++) - if (!isALPHA(value)) - ANYOF_BITMAP_SET(ret, value); - } - yesno = '!'; - what = "Alpha"; - break; + case _C_C_T_(ALNUM, isALNUM(value), "Word"); + case _C_C_T_(ALNUMC, isALNUMC(value), "Alnum"); + case _C_C_T_(ALPHA, isALPHA(value), "Alpha"); + case _C_C_T_(BLANK, isBLANK(value), "Blank"); + case _C_C_T_(CNTRL, isCNTRL(value), "Cntrl"); + case _C_C_T_(GRAPH, isGRAPH(value), "Graph"); + case _C_C_T_(LOWER, isLOWER(value), "Lower"); + case _C_C_T_(PRINT, isPRINT(value), "Print"); + case _C_C_T_(PSXSPC, isPSXSPC(value), "Space"); + case _C_C_T_(PUNCT, isPUNCT(value), "Punct"); + case _C_C_T_(SPACE, isSPACE(value), "SpacePerl"); + case _C_C_T_(UPPER, isUPPER(value), "Upper"); + case _C_C_T_(XDIGIT, isXDIGIT(value), "XDigit"); + case _C_C_T_NOLOC_(VERTWS, is_VERTWS_latin1(&value), "VertSpace"); + case _C_C_T_NOLOC_(HORIZWS, is_HORIZWS_latin1(&value), "HorizSpace"); case ANYOF_ASCII: if (LOC) ANYOF_CLASS_SET(ret, ANYOF_ASCII); @@ -6920,51 +7695,7 @@ parseit: } yesno = '!'; what = "ASCII"; - break; - case ANYOF_BLANK: - if (LOC) - ANYOF_CLASS_SET(ret, ANYOF_BLANK); - else { - for (value = 0; value < 256; value++) - if (isBLANK(value)) - ANYOF_BITMAP_SET(ret, value); - } - yesno = '+'; - what = "Blank"; - break; - case ANYOF_NBLANK: - if (LOC) - ANYOF_CLASS_SET(ret, ANYOF_NBLANK); - else { - for (value = 0; value < 256; value++) - if (!isBLANK(value)) - ANYOF_BITMAP_SET(ret, value); - } - yesno = '!'; - what = "Blank"; - break; - case ANYOF_CNTRL: - if (LOC) - ANYOF_CLASS_SET(ret, ANYOF_CNTRL); - else { - for (value = 0; value < 256; value++) - if (isCNTRL(value)) - ANYOF_BITMAP_SET(ret, value); - } - yesno = '+'; - what = "Cntrl"; - break; - case ANYOF_NCNTRL: - if (LOC) - ANYOF_CLASS_SET(ret, ANYOF_NCNTRL); - else { - for (value = 0; value < 256; value++) - if (!isCNTRL(value)) - ANYOF_BITMAP_SET(ret, value); - } - yesno = '!'; - what = "Cntrl"; - break; + break; case ANYOF_DIGIT: if (LOC) ANYOF_CLASS_SET(ret, ANYOF_DIGIT); @@ -6988,185 +7719,9 @@ parseit: } yesno = '!'; what = "Digit"; - break; - case ANYOF_GRAPH: - if (LOC) - ANYOF_CLASS_SET(ret, ANYOF_GRAPH); - else { - for (value = 0; value < 256; value++) - if (isGRAPH(value)) - ANYOF_BITMAP_SET(ret, value); - } - yesno = '+'; - what = "Graph"; - break; - case ANYOF_NGRAPH: - if (LOC) - ANYOF_CLASS_SET(ret, ANYOF_NGRAPH); - else { - for (value = 0; value < 256; value++) - if (!isGRAPH(value)) - ANYOF_BITMAP_SET(ret, value); - } - yesno = '!'; - what = "Graph"; - break; - case ANYOF_LOWER: - if (LOC) - ANYOF_CLASS_SET(ret, ANYOF_LOWER); - else { - for (value = 0; value < 256; value++) - if (isLOWER(value)) - ANYOF_BITMAP_SET(ret, value); - } - yesno = '+'; - what = "Lower"; - break; - case ANYOF_NLOWER: - if (LOC) - ANYOF_CLASS_SET(ret, ANYOF_NLOWER); - else { - for (value = 0; value < 256; value++) - if (!isLOWER(value)) - ANYOF_BITMAP_SET(ret, value); - } - yesno = '!'; - what = "Lower"; - break; - case ANYOF_PRINT: - if (LOC) - ANYOF_CLASS_SET(ret, ANYOF_PRINT); - else { - for (value = 0; value < 256; value++) - if (isPRINT(value)) - ANYOF_BITMAP_SET(ret, value); - } - yesno = '+'; - what = "Print"; - break; - case ANYOF_NPRINT: - if (LOC) - ANYOF_CLASS_SET(ret, ANYOF_NPRINT); - else { - for (value = 0; value < 256; value++) - if (!isPRINT(value)) - ANYOF_BITMAP_SET(ret, value); - } - yesno = '!'; - what = "Print"; - break; - case ANYOF_PSXSPC: - if (LOC) - ANYOF_CLASS_SET(ret, ANYOF_PSXSPC); - else { - for (value = 0; value < 256; value++) - if (isPSXSPC(value)) - ANYOF_BITMAP_SET(ret, value); - } - yesno = '+'; - what = "Space"; - break; - case ANYOF_NPSXSPC: - if (LOC) - ANYOF_CLASS_SET(ret, ANYOF_NPSXSPC); - else { - for (value = 0; value < 256; value++) - if (!isPSXSPC(value)) - ANYOF_BITMAP_SET(ret, value); - } - yesno = '!'; - what = "Space"; - break; - case ANYOF_PUNCT: - if (LOC) - ANYOF_CLASS_SET(ret, ANYOF_PUNCT); - else { - for (value = 0; value < 256; value++) - if (isPUNCT(value)) - ANYOF_BITMAP_SET(ret, value); - } - yesno = '+'; - what = "Punct"; - break; - case ANYOF_NPUNCT: - if (LOC) - ANYOF_CLASS_SET(ret, ANYOF_NPUNCT); - else { - for (value = 0; value < 256; value++) - if (!isPUNCT(value)) - ANYOF_BITMAP_SET(ret, value); - } - yesno = '!'; - what = "Punct"; - break; - case ANYOF_SPACE: - if (LOC) - ANYOF_CLASS_SET(ret, ANYOF_SPACE); - else { - for (value = 0; value < 256; value++) - if (isSPACE(value)) - ANYOF_BITMAP_SET(ret, value); - } - yesno = '+'; - what = "SpacePerl"; - break; - case ANYOF_NSPACE: - if (LOC) - ANYOF_CLASS_SET(ret, ANYOF_NSPACE); - else { - for (value = 0; value < 256; value++) - if (!isSPACE(value)) - ANYOF_BITMAP_SET(ret, value); - } - yesno = '!'; - what = "SpacePerl"; - break; - case ANYOF_UPPER: - if (LOC) - ANYOF_CLASS_SET(ret, ANYOF_UPPER); - else { - for (value = 0; value < 256; value++) - if (isUPPER(value)) - ANYOF_BITMAP_SET(ret, value); - } - yesno = '+'; - what = "Upper"; - break; - case ANYOF_NUPPER: - if (LOC) - ANYOF_CLASS_SET(ret, ANYOF_NUPPER); - else { - for (value = 0; value < 256; value++) - if (!isUPPER(value)) - ANYOF_BITMAP_SET(ret, value); - } - yesno = '!'; - what = "Upper"; - break; - case ANYOF_XDIGIT: - if (LOC) - ANYOF_CLASS_SET(ret, ANYOF_XDIGIT); - else { - for (value = 0; value < 256; value++) - if (isXDIGIT(value)) - ANYOF_BITMAP_SET(ret, value); - } - yesno = '+'; - what = "XDigit"; - break; - case ANYOF_NXDIGIT: - if (LOC) - ANYOF_CLASS_SET(ret, ANYOF_NXDIGIT); - else { - for (value = 0; value < 256; value++) - if (!isXDIGIT(value)) - ANYOF_BITMAP_SET(ret, value); - } - yesno = '!'; - what = "XDigit"; - break; - case ANYOF_MAX: - /* this is to handle \p and \P */ + break; + case ANYOF_MAX: + /* this is to handle \p and \P */ break; default: vFAIL("Invalid [::] class"); @@ -7345,7 +7900,7 @@ parseit: return ret; /****** !SIZE_ONLY AFTER HERE *********/ - if( stored == 1 && value < 256 + if( stored == 1 && (value < 128 || (value < 256 && !UTF)) && !( ANYOF_FLAGS(ret) & ( ANYOF_FLAGS_ALL ^ ANYOF_FOLD ) ) ) { /* optimize single char class to an EXACT node @@ -7398,11 +7953,56 @@ parseit: av_store(av, 2, (SV*)unicode_alternate); rv = newRV_noinc((SV*)av); n = add_data(pRExC_state, 1, "s"); - RExC_rx->data->data[n] = (void*)rv; + RExC_rxi->data->data[n] = (void*)rv; ARG_SET(ret, n); } return ret; } +#undef _C_C_T_ + + +/* reg_skipcomment() + + Absorbs an /x style # comments from the input stream. + Returns true if there is more text remaining in the stream. + Will set the REG_SEEN_RUN_ON_COMMENT flag if the comment + terminates the pattern without including a newline. + + Note its the callers responsibility to ensure that we are + actually in /x mode + +*/ + +STATIC bool +S_reg_skipcomment(pTHX_ RExC_state_t *pRExC_state) +{ + bool ended = 0; + while (RExC_parse < RExC_end) + if (*RExC_parse++ == '\n') { + ended = 1; + break; + } + if (!ended) { + /* we ran off the end of the pattern without ending + the comment, so we have to add an \n when wrapping */ + RExC_seen |= REG_SEEN_RUN_ON_COMMENT; + return 0; + } else + return 1; +} + +/* nextchar() + + Advance that parse position, and optionall absorbs + "whitespace" from the inputstream. + + Without /x "whitespace" means (?#...) style comments only, + with /x this means (?#...) and # comments and whitespace proper. + + Returns the RExC_parse point from BEFORE the scan occurs. + + This is the /x friendly way of saying RExC_parse++. +*/ STATIC char* S_nextchar(pTHX_ RExC_state_t *pRExC_state) @@ -7420,15 +8020,14 @@ S_nextchar(pTHX_ RExC_state_t *pRExC_state) RExC_parse++; continue; } - if (RExC_flags & PMf_EXTENDED) { + if (RExC_flags & RXf_PMf_EXTENDED) { if (isSPACE(*RExC_parse)) { RExC_parse++; continue; } else if (*RExC_parse == '#') { - while (RExC_parse < RExC_end) - if (*RExC_parse++ == '\n') break; - continue; + if ( reg_skipcomment( pRExC_state ) ) + continue; } } return retval; @@ -7451,13 +8050,17 @@ S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op) RExC_size += 1; return(ret); } + if (RExC_emit >= RExC_emit_bound) + Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d", op); + NODE_ALIGN_FILL(ret); ptr = ret; FILL_ADVANCE_NODE(ptr, op); +#ifdef RE_TRACK_PATTERN_OFFSETS if (RExC_offsets) { /* MJD */ MJD_OFFSET_DEBUG(("%s:%d: (op %s) %s %"UVuf" (len %"UVuf") (max %"UVuf").\n", "reg_node", __LINE__, - reg_name[op], + PL_reg_name[op], (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] ? "Overwriting end of array!\n" : "OK", (UV)(RExC_emit - RExC_emit_start), @@ -7465,9 +8068,8 @@ S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op) (UV)RExC_offsets[0])); Set_Node_Offset(RExC_emit, RExC_parse + (op == END)); } - +#endif RExC_emit = ptr; - return(ret); } @@ -7501,15 +8103,18 @@ S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg) */ return(ret); } + if (RExC_emit >= RExC_emit_bound) + Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d", op); NODE_ALIGN_FILL(ret); ptr = ret; FILL_ADVANCE_NODE_ARG(ptr, op, arg); +#ifdef RE_TRACK_PATTERN_OFFSETS if (RExC_offsets) { /* MJD */ MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n", "reganode", __LINE__, - reg_name[op], + PL_reg_name[op], (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] ? "Overwriting end of array!\n" : "OK", (UV)(RExC_emit - RExC_emit_start), @@ -7517,9 +8122,8 @@ S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg) (UV)RExC_offsets[0])); Set_Cur_Node_Offset; } - +#endif RExC_emit = ptr; - return(ret); } @@ -7548,8 +8152,9 @@ S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth) const int offset = regarglen[(U8)op]; const int size = NODE_STEP_REGNODE + offset; GET_RE_DEBUG_FLAGS_DECL; + PERL_UNUSED_ARG(depth); /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */ - DEBUG_PARSE_FMT("inst"," - %s",reg_name[op]); + DEBUG_PARSE_FMT("inst"," - %s",PL_reg_name[op]); if (SIZE_ONLY) { RExC_size += size; return; @@ -7560,30 +8165,31 @@ S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth) dst = RExC_emit; if (RExC_open_parens) { int paren; - DEBUG_PARSE_FMT("inst"," - %d",RExC_npar); + /*DEBUG_PARSE_FMT("inst"," - %"IVdf, (IV)RExC_npar);*/ for ( paren=0 ; paren < RExC_npar ; paren++ ) { if ( RExC_open_parens[paren] >= opnd ) { - DEBUG_PARSE_FMT("open"," - %d",size); + /*DEBUG_PARSE_FMT("open"," - %d",size);*/ RExC_open_parens[paren] += size; } else { - DEBUG_PARSE_FMT("open"," - %s","ok"); + /*DEBUG_PARSE_FMT("open"," - %s","ok");*/ } if ( RExC_close_parens[paren] >= opnd ) { - DEBUG_PARSE_FMT("close"," - %d",size); + /*DEBUG_PARSE_FMT("close"," - %d",size);*/ RExC_close_parens[paren] += size; } else { - DEBUG_PARSE_FMT("close"," - %s","ok"); + /*DEBUG_PARSE_FMT("close"," - %s","ok");*/ } } } while (src > opnd) { StructCopy(--src, --dst, regnode); +#ifdef RE_TRACK_PATTERN_OFFSETS if (RExC_offsets) { /* MJD 20010112 */ MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s copy %"UVuf" -> %"UVuf" (max %"UVuf").\n", "reg_insert", __LINE__, - reg_name[op], + PL_reg_name[op], (UV)(dst - RExC_emit_start) > RExC_offsets[0] ? "Overwriting end of array!\n" : "OK", (UV)(src - RExC_emit_start), @@ -7592,15 +8198,17 @@ S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth) Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src)); Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src)); } +#endif } place = opnd; /* Op node, where operand used to be. */ +#ifdef RE_TRACK_PATTERN_OFFSETS if (RExC_offsets) { /* MJD */ MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n", "reginsert", __LINE__, - reg_name[op], + PL_reg_name[op], (UV)(place - RExC_emit_start) > RExC_offsets[0] ? "Overwriting end of array!\n" : "OK", (UV)(place - RExC_emit_start), @@ -7609,6 +8217,7 @@ S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth) Set_Node_Offset(place, RExC_parse); Set_Node_Length(place, 1); } +#endif src = NEXTOPER(place); FILL_ADVANCE_NODE(place, op); Zero(src, offset, regnode); @@ -7643,7 +8252,7 @@ S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 de PerlIO_printf(Perl_debug_log, "~ %s (%d) %s %s\n", SvPV_nolen_const(mysv), REG_NODE_NUM(scan), (temp == NULL ? "->" : ""), - (temp == NULL ? reg_name[OP(val)] : "") + (temp == NULL ? PL_reg_name[OP(val)] : "") ); }); if (temp == NULL) @@ -7724,7 +8333,7 @@ S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val, PerlIO_printf(Perl_debug_log, "~ %s (%d) -> %s\n", SvPV_nolen_const(mysv), REG_NODE_NUM(scan), - reg_name[exact]); + PL_reg_name[exact]); }); if (temp == NULL) break; @@ -7734,10 +8343,10 @@ S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val, SV * const mysv_val=sv_newmortal(); DEBUG_PARSE_MSG(""); regprop(RExC_rx, mysv_val, val); - PerlIO_printf(Perl_debug_log, "~ attach to %s (%d) offset to %d\n", - SvPV_nolen_const(mysv_val), - REG_NODE_NUM(val), - val - scan + PerlIO_printf(Perl_debug_log, "~ attach to %s (%"IVdf") offset to %"IVdf"\n", + SvPV_nolen_const(mysv_val), + (IV)REG_NODE_NUM(val), + (IV)(val - scan) ); }); if (reg_off_by_arg[OP(scan)]) { @@ -7783,8 +8392,9 @@ Perl_regdump(pTHX_ const regexp *r) dVAR; SV * const sv = sv_newmortal(); SV *dsv= sv_newmortal(); + RXi_GET_DECL(r,ri); - (void)dumpuntil(r, r->program, r->program + 1, NULL, NULL, sv, 0, 0); + (void)dumpuntil(r, ri->program, ri->program + 1, NULL, NULL, sv, 0, 0); /* Header fields of interest. */ if (r->anchored_substr) { @@ -7823,37 +8433,37 @@ Perl_regdump(pTHX_ const regexp *r) (r->check_substr == r->float_substr && r->check_utf8 == r->float_utf8 ? "(checking floating" : "(checking anchored")); - if (r->reganch & ROPT_NOSCAN) + if (r->extflags & RXf_NOSCAN) PerlIO_printf(Perl_debug_log, " noscan"); - if (r->reganch & ROPT_CHECK_ALL) + if (r->extflags & RXf_CHECK_ALL) PerlIO_printf(Perl_debug_log, " isall"); if (r->check_substr || r->check_utf8) PerlIO_printf(Perl_debug_log, ") "); - if (r->regstclass) { - regprop(r, sv, r->regstclass); + if (ri->regstclass) { + regprop(r, sv, ri->regstclass); PerlIO_printf(Perl_debug_log, "stclass %s ", SvPVX_const(sv)); } - if (r->reganch & ROPT_ANCH) { + if (r->extflags & RXf_ANCH) { PerlIO_printf(Perl_debug_log, "anchored"); - if (r->reganch & ROPT_ANCH_BOL) + if (r->extflags & RXf_ANCH_BOL) PerlIO_printf(Perl_debug_log, "(BOL)"); - if (r->reganch & ROPT_ANCH_MBOL) + if (r->extflags & RXf_ANCH_MBOL) PerlIO_printf(Perl_debug_log, "(MBOL)"); - if (r->reganch & ROPT_ANCH_SBOL) + if (r->extflags & RXf_ANCH_SBOL) PerlIO_printf(Perl_debug_log, "(SBOL)"); - if (r->reganch & ROPT_ANCH_GPOS) + if (r->extflags & RXf_ANCH_GPOS) PerlIO_printf(Perl_debug_log, "(GPOS)"); PerlIO_putc(Perl_debug_log, ' '); } - if (r->reganch & ROPT_GPOS_SEEN) - PerlIO_printf(Perl_debug_log, "GPOS "); - if (r->reganch & ROPT_SKIP) + if (r->extflags & RXf_GPOS_SEEN) + PerlIO_printf(Perl_debug_log, "GPOS:%"UVuf" ", (UV)r->gofs); + if (r->intflags & PREGf_SKIP) PerlIO_printf(Perl_debug_log, "plus "); - if (r->reganch & ROPT_IMPLICIT) + if (r->intflags & PREGf_IMPLICIT) PerlIO_printf(Perl_debug_log, "implicit "); - PerlIO_printf(Perl_debug_log, "minlen %ld ", (long) r->minlen); - if (r->reganch & ROPT_EVAL_SEEN) + PerlIO_printf(Perl_debug_log, "minlen %"IVdf" ", (IV)r->minlen); + if (r->extflags & RXf_EVAL_SEEN) PerlIO_printf(Perl_debug_log, "with eval "); PerlIO_printf(Perl_debug_log, "\n"); #else @@ -7871,14 +8481,17 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o) #ifdef DEBUGGING dVAR; register int k; + RXi_GET_DECL(prog,progi); GET_RE_DEBUG_FLAGS_DECL; + sv_setpvn(sv, "", 0); + if (OP(o) > REGNODE_MAX) /* regnode.type is unsigned */ /* It would be nice to FAIL() here, but this may be called from regexec.c, and it would be hard to supply pRExC_state. */ Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(o), (int)REGNODE_MAX); - sv_catpv(sv, reg_name[OP(o)]); /* Take off const! */ + sv_catpv(sv, PL_reg_name[OP(o)]); /* Take off const! */ k = PL_regkind[OP(o)]; @@ -7898,17 +8511,16 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o) Perl_sv_catpvf(aTHX_ sv, " %s", s ); } else if (k == TRIE) { /* print the details of the trie in dumpuntil instead, as - * prog->data isn't available here */ + * progi->data isn't available here */ const char op = OP(o); - const I32 n = ARG(o); + const U32 n = ARG(o); const reg_ac_data * const ac = IS_TRIE_AC(op) ? - (reg_ac_data *)prog->data->data[n] : + (reg_ac_data *)progi->data->data[n] : NULL; - const reg_trie_data * const trie = !IS_TRIE_AC(op) ? - (reg_trie_data*)prog->data->data[n] : - ac->trie; + const reg_trie_data * const trie + = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie]; - Perl_sv_catpvf(aTHX_ sv, "-%s",reg_name[o->flags]); + Perl_sv_catpvf(aTHX_ sv, "-%s",PL_reg_name[o->flags]); DEBUG_TRIE_COMPILE_r( Perl_sv_catpvf(aTHX_ sv, "", @@ -7952,12 +8564,40 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o) } else if (k == WHILEM && o->flags) /* Ordinal/of */ Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4); - else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP) + else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP || OP(o)==ACCEPT) { Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o)); /* Parenth number */ - else if (k == GOSUB) + if ( prog->paren_names ) { + if ( k != REF || OP(o) < NREF) { + AV *list= (AV *)progi->data->data[progi->name_list_idx]; + SV **name= av_fetch(list, ARG(o), 0 ); + if (name) + Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name)); + } + else { + AV *list= (AV *)progi->data->data[ progi->name_list_idx ]; + SV *sv_dat=(SV*)progi->data->data[ ARG( o ) ]; + I32 *nums=(I32*)SvPVX(sv_dat); + SV **name= av_fetch(list, nums[0], 0 ); + I32 n; + if (name) { + for ( n=0; nflags) + Perl_sv_catpvf(aTHX_ sv, ":%"SVf, + SVfARG((SV*)progi->data->data[ ARG( o ) ])); + } else if (k == LOGICAL) Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* 2: embedded, otherwise 1 */ + else if (k == FOLDCHAR) + Perl_sv_catpvf(aTHX_ sv, "[0x%"UVXf"]",ARG(o) ); else if (k == ANYOF) { int i, rangestart = -1; const U8 flags = ANYOF_FLAGS(o); @@ -8108,7 +8748,7 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o) } SV * -Perl_re_intuit_string(pTHX_ regexp *prog) +Perl_re_intuit_string(pTHX_ REGEXP * const prog) { /* Assume that RE_INTUIT is set */ dVAR; GET_RE_DEBUG_FLAGS_DECL; @@ -8134,72 +8774,158 @@ Perl_re_intuit_string(pTHX_ regexp *prog) } /* - pregfree - free a regexp + pregfree() - See regdupe below if you change anything here. + handles refcounting and freeing the perl core regexp structure. When + it is necessary to actually free the structure the first thing it + does is call the 'free' method of the regexp_engine associated to to + the regexp, allowing the handling of the void *pprivate; member + first. (This routine is not overridable by extensions, which is why + the extensions free is called first.) + + See regdupe and regdupe_internal if you change anything here. */ - +#ifndef PERL_IN_XSUB_RE void Perl_pregfree(pTHX_ struct regexp *r) { dVAR; - GET_RE_DEBUG_FLAGS_DECL; if (!r || (--r->refcnt > 0)) return; + if (r->mother_re) { + ReREFCNT_dec(r->mother_re); + } else { + CALLREGFREE_PVT(r); /* free the private data */ + if (r->paren_names) + SvREFCNT_dec(r->paren_names); + Safefree(r->wrapped); + } + if (r->substrs) { + if (r->anchored_substr) + SvREFCNT_dec(r->anchored_substr); + if (r->anchored_utf8) + SvREFCNT_dec(r->anchored_utf8); + if (r->float_substr) + SvREFCNT_dec(r->float_substr); + if (r->float_utf8) + SvREFCNT_dec(r->float_utf8); + Safefree(r->substrs); + } + RX_MATCH_COPY_FREE(r); +#ifdef PERL_OLD_COPY_ON_WRITE + if (r->saved_copy) + SvREFCNT_dec(r->saved_copy); +#endif + Safefree(r->swap); + Safefree(r->offs); + Safefree(r); +} + +/* reg_temp_copy() + + This is a hacky workaround to the structural issue of match results + being stored in the regexp structure which is in turn stored in + PL_curpm/PL_reg_curpm. The problem is that due to qr// the pattern + could be PL_curpm in multiple contexts, and could require multiple + result sets being associated with the pattern simultaneously, such + as when doing a recursive match with (??{$qr}) + + The solution is to make a lightweight copy of the regexp structure + when a qr// is returned from the code executed by (??{$qr}) this + lightweight copy doesnt actually own any of its data except for + the starp/end and the actual regexp structure itself. + +*/ + + +regexp * +Perl_reg_temp_copy (pTHX_ struct regexp *r) { + regexp *ret; + register const I32 npar = r->nparens+1; + (void)ReREFCNT_inc(r); + Newx(ret, 1, regexp); + StructCopy(r, ret, regexp); + Newx(ret->offs, npar, regexp_paren_pair); + Copy(r->offs, ret->offs, npar, regexp_paren_pair); + ret->refcnt = 1; + if (r->substrs) { + Newx(ret->substrs, 1, struct reg_substr_data); + StructCopy(r->substrs, ret->substrs, struct reg_substr_data); + + SvREFCNT_inc_void(ret->anchored_substr); + SvREFCNT_inc_void(ret->anchored_utf8); + SvREFCNT_inc_void(ret->float_substr); + SvREFCNT_inc_void(ret->float_utf8); + + /* check_substr and check_utf8, if non-NULL, point to either their + anchored or float namesakes, and don't hold a second reference. */ + } + RX_MATCH_COPIED_off(ret); +#ifdef PERL_OLD_COPY_ON_WRITE + ret->saved_copy = NULL; +#endif + ret->mother_re = r; + ret->swap = NULL; + + return ret; +} +#endif + +/* regfree_internal() + + Free the private data in a regexp. This is overloadable by + extensions. Perl takes care of the regexp structure in pregfree(), + this covers the *pprivate pointer which technically perldoesnt + know about, however of course we have to handle the + regexp_internal structure when no extension is in use. + + Note this is called before freeing anything in the regexp + structure. + */ + +void +Perl_regfree_internal(pTHX_ struct regexp *r) +{ + dVAR; + RXi_GET_DECL(r,ri); + GET_RE_DEBUG_FLAGS_DECL; + DEBUG_COMPILE_r({ if (!PL_colorset) reginitcolors(); - if (RX_DEBUG(r)){ - SV *dsv= sv_newmortal(); - RE_PV_QUOTED_DECL(s, (r->reganch & ROPT_UTF8), + { + SV *dsv= sv_newmortal(); + RE_PV_QUOTED_DECL(s, (r->extflags & RXf_UTF8), dsv, r->precomp, r->prelen, 60); PerlIO_printf(Perl_debug_log,"%sFreeing REx:%s %s\n", PL_colors[4],PL_colors[5],s); } }); - - /* gcov results gave these as non-null 100% of the time, so there's no - optimisation in checking them before calling Safefree */ - Safefree(r->precomp); - Safefree(r->offsets); /* 20010421 MJD */ - RX_MATCH_COPY_FREE(r); -#ifdef PERL_OLD_COPY_ON_WRITE - if (r->saved_copy) - SvREFCNT_dec(r->saved_copy); +#ifdef RE_TRACK_PATTERN_OFFSETS + if (ri->u.offsets) + Safefree(ri->u.offsets); /* 20010421 MJD */ #endif - if (r->substrs) { - if (r->anchored_substr) - SvREFCNT_dec(r->anchored_substr); - if (r->anchored_utf8) - SvREFCNT_dec(r->anchored_utf8); - if (r->float_substr) - SvREFCNT_dec(r->float_substr); - if (r->float_utf8) - SvREFCNT_dec(r->float_utf8); - Safefree(r->substrs); - } - if (r->paren_names) - SvREFCNT_dec(r->paren_names); - if (r->data) { - int n = r->data->count; + if (ri->data) { + int n = ri->data->count; PAD* new_comppad = NULL; PAD* old_comppad; PADOFFSET refcnt; while (--n >= 0) { /* If you add a ->what type here, update the comment in regcomp.h */ - switch (r->data->what[n]) { + switch (ri->data->what[n]) { case 's': case 'S': - SvREFCNT_dec((SV*)r->data->data[n]); + case 'u': + SvREFCNT_dec((SV*)ri->data->data[n]); break; case 'f': - Safefree(r->data->data[n]); + Safefree(ri->data->data[n]); break; case 'p': - new_comppad = (AV*)r->data->data[n]; + new_comppad = (AV*)ri->data->data[n]; break; case 'o': if (new_comppad == NULL) @@ -8209,10 +8935,10 @@ Perl_pregfree(pTHX_ struct regexp *r) (SvTYPE(new_comppad) == SVt_PVAV) ? new_comppad : NULL ); OP_REFCNT_LOCK; - refcnt = OpREFCNT_dec((OP_4tree*)r->data->data[n]); + refcnt = OpREFCNT_dec((OP_4tree*)ri->data->data[n]); OP_REFCNT_UNLOCK; if (!refcnt) - op_free((OP_4tree*)r->data->data[n]); + op_free((OP_4tree*)ri->data->data[n]); PAD_RESTORE_LOCAL(old_comppad); SvREFCNT_dec((SV*)new_comppad); @@ -8224,17 +8950,16 @@ Perl_pregfree(pTHX_ struct regexp *r) { /* Aho Corasick add-on structure for a trie node. Used in stclass optimization only */ U32 refcount; - reg_ac_data *aho=(reg_ac_data*)r->data->data[n]; + reg_ac_data *aho=(reg_ac_data*)ri->data->data[n]; OP_REFCNT_LOCK; refcount = --aho->refcount; OP_REFCNT_UNLOCK; if ( !refcount ) { - Safefree(aho->states); - Safefree(aho->fail); - aho->trie=NULL; /* not necessary to free this as it is - handled by the 't' case */ - Safefree(r->data->data[n]); /* do this last!!!! */ - Safefree(r->regstclass); + PerlMemShared_free(aho->states); + PerlMemShared_free(aho->fail); + /* do this last!!!! */ + PerlMemShared_free(ri->data->data[n]); + PerlMemShared_free(ri->regstclass); } } break; @@ -8242,46 +8967,36 @@ Perl_pregfree(pTHX_ struct regexp *r) { /* trie structure. */ U32 refcount; - reg_trie_data *trie=(reg_trie_data*)r->data->data[n]; + reg_trie_data *trie=(reg_trie_data*)ri->data->data[n]; OP_REFCNT_LOCK; refcount = --trie->refcount; OP_REFCNT_UNLOCK; if ( !refcount ) { - Safefree(trie->charmap); - if (trie->widecharmap) - SvREFCNT_dec((SV*)trie->widecharmap); - Safefree(trie->states); - Safefree(trie->trans); + PerlMemShared_free(trie->charmap); + PerlMemShared_free(trie->states); + PerlMemShared_free(trie->trans); if (trie->bitmap) - Safefree(trie->bitmap); + PerlMemShared_free(trie->bitmap); if (trie->wordlen) - Safefree(trie->wordlen); + PerlMemShared_free(trie->wordlen); if (trie->jump) - Safefree(trie->jump); + PerlMemShared_free(trie->jump); if (trie->nextword) - Safefree(trie->nextword); -#ifdef DEBUGGING - if (RX_DEBUG(r)) { - if (trie->words) - SvREFCNT_dec((SV*)trie->words); - if (trie->revcharmap) - SvREFCNT_dec((SV*)trie->revcharmap); - } -#endif - Safefree(r->data->data[n]); /* do this last!!!! */ + PerlMemShared_free(trie->nextword); + /* do this last!!!! */ + PerlMemShared_free(ri->data->data[n]); } } break; default: - Perl_croak(aTHX_ "panic: regfree data code '%c'", r->data->what[n]); + Perl_croak(aTHX_ "panic: regfree data code '%c'", ri->data->what[n]); } } - Safefree(r->data->what); - Safefree(r->data); + Safefree(ri->data->what); + Safefree(ri->data); } - Safefree(r->startp); - Safefree(r->endp); - Safefree(r); + + Safefree(ri); } #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t)) @@ -8290,22 +9005,26 @@ Perl_pregfree(pTHX_ struct regexp *r) #define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL) /* - regdupe - duplicate a regexp. - - This routine is called by sv.c's re_dup and is expected to clone a - given regexp structure. It is a no-op when not under USE_ITHREADS. - (Originally this *was* re_dup() for change history see sv.c) + re_dup - duplicate a regexp. - See pregfree() above if you change anything here. + This routine is expected to clone a given regexp structure. It is not + compiler under USE_ITHREADS. + + After all of the core data stored in struct regexp is duplicated + the regexp_engine.dupe method is used to copy any private data + stored in the *pprivate pointer. This allows extensions to handle + any duplication it needs to do. + + See pregfree() and regfree_internal() if you change anything here. */ #if defined(USE_ITHREADS) +#ifndef PERL_IN_XSUB_RE regexp * -Perl_regdupe(pTHX_ const regexp *r, CLONE_PARAMS *param) +Perl_re_dup(pTHX_ const regexp *r, CLONE_PARAMS *param) { dVAR; - REGEXP *ret; - int i, len, npar; - struct reg_substr_datum *s; + regexp *ret; + I32 npar; if (!r) return (REGEXP *)NULL; @@ -8313,30 +9032,105 @@ Perl_regdupe(pTHX_ const regexp *r, CLONE_PARAMS *param) if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r))) return ret; - len = r->offsets[0]; + npar = r->nparens+1; + Newx(ret, 1, regexp); + StructCopy(r, ret, regexp); + Newx(ret->offs, npar, regexp_paren_pair); + Copy(r->offs, ret->offs, npar, regexp_paren_pair); + if(ret->swap) { + /* no need to copy these */ + Newx(ret->swap, npar, regexp_paren_pair); + } - Newxc(ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp); - Copy(r->program, ret->program, len+1, regnode); - - Newx(ret->startp, npar, I32); - Copy(r->startp, ret->startp, npar, I32); - Newx(ret->endp, npar, I32); - Copy(r->startp, ret->startp, npar, I32); - - Newx(ret->substrs, 1, struct reg_substr_data); - for (s = ret->substrs->data, i = 0; i < 3; i++, s++) { - s->min_offset = r->substrs->data[i].min_offset; - s->max_offset = r->substrs->data[i].max_offset; - s->end_shift = r->substrs->data[i].end_shift; - s->substr = sv_dup_inc(r->substrs->data[i].substr, param); - s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param); + if (ret->substrs) { + /* Do it this way to avoid reading from *r after the StructCopy(). + That way, if any of the sv_dup_inc()s dislodge *r from the L1 + cache, it doesn't matter. */ + const bool anchored = r->check_substr == r->anchored_substr; + Newx(ret->substrs, 1, struct reg_substr_data); + StructCopy(r->substrs, ret->substrs, struct reg_substr_data); + + ret->anchored_substr = sv_dup_inc(ret->anchored_substr, param); + ret->anchored_utf8 = sv_dup_inc(ret->anchored_utf8, param); + ret->float_substr = sv_dup_inc(ret->float_substr, param); + ret->float_utf8 = sv_dup_inc(ret->float_utf8, param); + + /* check_substr and check_utf8, if non-NULL, point to either their + anchored or float namesakes, and don't hold a second reference. */ + + if (ret->check_substr) { + if (anchored) { + assert(r->check_utf8 == r->anchored_utf8); + ret->check_substr = ret->anchored_substr; + ret->check_utf8 = ret->anchored_utf8; + } else { + assert(r->check_substr == r->float_substr); + assert(r->check_utf8 == r->float_utf8); + ret->check_substr = ret->float_substr; + ret->check_utf8 = ret->float_utf8; + } + } } - ret->regstclass = NULL; - if (r->data) { + ret->wrapped = SAVEPVN(ret->wrapped, ret->wraplen+1); + ret->precomp = ret->wrapped + (ret->precomp - ret->wrapped); + ret->paren_names = hv_dup_inc(ret->paren_names, param); + + if (ret->pprivate) + RXi_SET(ret,CALLREGDUPE_PVT(ret,param)); + + if (RX_MATCH_COPIED(ret)) + ret->subbeg = SAVEPVN(ret->subbeg, ret->sublen); + else + ret->subbeg = NULL; +#ifdef PERL_OLD_COPY_ON_WRITE + ret->saved_copy = NULL; +#endif + + ret->mother_re = NULL; + ret->gofs = 0; + ret->seen_evals = 0; + + ptr_table_store(PL_ptr_table, r, ret); + return ret; +} +#endif /* PERL_IN_XSUB_RE */ + +/* + regdupe_internal() + + This is the internal complement to regdupe() which is used to copy + the structure pointed to by the *pprivate pointer in the regexp. + This is the core version of the extension overridable cloning hook. + The regexp structure being duplicated will be copied by perl prior + to this and will be provided as the regexp *r argument, however + with the /old/ structures pprivate pointer value. Thus this routine + may override any copying normally done by perl. + + It returns a pointer to the new regexp_internal structure. +*/ + +void * +Perl_regdupe_internal(pTHX_ REGEXP * const r, CLONE_PARAMS *param) +{ + dVAR; + regexp_internal *reti; + int len, npar; + RXi_GET_DECL(r,ri); + + npar = r->nparens+1; + len = ProgLen(ri); + + Newxc(reti, sizeof(regexp_internal) + (len+1)*sizeof(regnode), char, regexp_internal); + Copy(ri->program, reti->program, len+1, regnode); + + + reti->regstclass = NULL; + + if (ri->data) { struct reg_data *d; - const int count = r->data->count; + const int count = ri->data->count; int i; Newxc(d, sizeof(struct reg_data) + count*sizeof(void *), @@ -8345,93 +9139,113 @@ Perl_regdupe(pTHX_ const regexp *r, CLONE_PARAMS *param) d->count = count; for (i = 0; i < count; i++) { - d->what[i] = r->data->what[i]; + d->what[i] = ri->data->what[i]; switch (d->what[i]) { - /* legal options are one of: sfpont + /* legal options are one of: sSfpontTu see also regcomp.h and pregfree() */ case 's': case 'S': - d->data[i] = sv_dup_inc((SV *)r->data->data[i], param); - break; - case 'p': - d->data[i] = av_dup_inc((AV *)r->data->data[i], param); + case 'p': /* actually an AV, but the dup function is identical. */ + case 'u': /* actually an HV, but the dup function is identical. */ + d->data[i] = sv_dup_inc((SV *)ri->data->data[i], param); break; case 'f': /* This is cheating. */ Newx(d->data[i], 1, struct regnode_charclass_class); - StructCopy(r->data->data[i], d->data[i], + StructCopy(ri->data->data[i], d->data[i], struct regnode_charclass_class); - ret->regstclass = (regnode*)d->data[i]; + reti->regstclass = (regnode*)d->data[i]; break; case 'o': - /* Compiled op trees are readonly, and can thus be - shared without duplication. */ - OP_REFCNT_LOCK; - d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]); - OP_REFCNT_UNLOCK; - break; - case 'n': - d->data[i] = r->data->data[i]; - break; - case 't': - d->data[i] = r->data->data[i]; + /* Compiled op trees are readonly and in shared memory, + and can thus be shared without duplication. */ OP_REFCNT_LOCK; - ((reg_trie_data*)d->data[i])->refcount++; + d->data[i] = (void*)OpREFCNT_inc((OP*)ri->data->data[i]); OP_REFCNT_UNLOCK; break; case 'T': - d->data[i] = r->data->data[i]; - OP_REFCNT_LOCK; - ((reg_ac_data*)d->data[i])->refcount++; - OP_REFCNT_UNLOCK; /* Trie stclasses are readonly and can thus be shared * without duplication. We free the stclass in pregfree * when the corresponding reg_ac_data struct is freed. */ - ret->regstclass= r->regstclass; + reti->regstclass= ri->regstclass; + /* Fall through */ + case 't': + OP_REFCNT_LOCK; + ((reg_trie_data*)ri->data->data[i])->refcount++; + OP_REFCNT_UNLOCK; + /* Fall through */ + case 'n': + d->data[i] = ri->data->data[i]; break; default: - Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", r->data->what[i]); + Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", ri->data->what[i]); } } - ret->data = d; + reti->data = d; } else - ret->data = NULL; + reti->data = NULL; - Newx(ret->offsets, 2*len+1, U32); - Copy(r->offsets, ret->offsets, 2*len+1, U32); + reti->name_list_idx = ri->name_list_idx; - ret->precomp = SAVEPVN(r->precomp, r->prelen); - ret->refcnt = r->refcnt; - ret->minlen = r->minlen; - ret->prelen = r->prelen; - ret->nparens = r->nparens; - ret->lastparen = r->lastparen; - ret->lastcloseparen = r->lastcloseparen; - ret->reganch = r->reganch; +#ifdef RE_TRACK_PATTERN_OFFSETS + if (ri->u.offsets) { + Newx(reti->u.offsets, 2*len+1, U32); + Copy(ri->u.offsets, reti->u.offsets, 2*len+1, U32); + } +#else + SetProgLen(reti,len); +#endif - ret->sublen = r->sublen; + return (void*)reti; +} - ret->engine = r->engine; - - ret->paren_names = hv_dup_inc(r->paren_names, param); +#endif /* USE_ITHREADS */ - if (RX_MATCH_COPIED(ret)) - ret->subbeg = SAVEPVN(r->subbeg, r->sublen); - else - ret->subbeg = NULL; -#ifdef PERL_OLD_COPY_ON_WRITE - ret->saved_copy = NULL; -#endif +/* + reg_stringify() + + converts a regexp embedded in a MAGIC struct to its stringified form, + caching the converted form in the struct and returns the cached + string. - ptr_table_store(PL_ptr_table, r, ret); - return ret; + If lp is nonnull then it is used to return the length of the + resulting string + + If flags is nonnull and the returned string contains UTF8 then + (*flags & 1) will be true. + + If haseval is nonnull then it is used to return whether the pattern + contains evals. + + Normally called via macro: + + CALLREG_STRINGIFY(mg,&len,&utf8); + + And internally with + + CALLREG_AS_STR(mg,&lp,&flags,&haseval) + + See sv_2pv_flags() in sv.c for an example of internal usage. + + */ +#ifndef PERL_IN_XSUB_RE + +char * +Perl_reg_stringify(pTHX_ MAGIC *mg, STRLEN *lp, U32 *flags, I32 *haseval ) { + dVAR; + const regexp * const re = (regexp *)mg->mg_obj; + if (haseval) + *haseval = re->seen_evals; + if (flags) + *flags = ((re->extflags & RXf_UTF8) ? 1 : 0); + if (lp) + *lp = re->wraplen; + return re->wrapped; } -#endif -#ifndef PERL_IN_XSUB_RE /* - regnext - dig the "next" pointer out of a node */ @@ -8441,7 +9255,7 @@ Perl_regnext(pTHX_ register regnode *p) dVAR; register I32 offset; - if (p == &PL_regdummy) + if (!p) return(NULL); offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p)); @@ -8562,7 +9376,7 @@ S_put_byte(pTHX_ SV *sv, int c) #define CLEAR_OPTSTART \ if (optstart) STMT_START { \ - DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log, " (%d nodes)\n", node - optstart)); \ + DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log, " (%"IVdf" nodes)\n", (IV)(node - optstart))); \ optstart=NULL; \ } STMT_END @@ -8577,8 +9391,10 @@ S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node, register U8 op = PSEUDO; /* Arbitrary non-END op. */ register const regnode *next; const regnode *optstart= NULL; + + RXi_GET_DECL(r,ri); GET_RE_DEBUG_FLAGS_DECL; - + #ifdef DEBUG_DUMPUNTIL PerlIO_printf(Perl_debug_log, "--- %d : %d - %d - %d\n",indent,node-start, last ? last-start : 0,plast ? plast-start : 0); @@ -8589,13 +9405,12 @@ S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node, while (PL_regkind[op] != END && (!last || node < last)) { /* While that wasn't END last time... */ - NODE_ALIGN(node); op = OP(node); - if (op == CLOSE) + if (op == CLOSE || op == WHILEM) indent--; next = regnext((regnode *)node); - + /* Where, what. */ if (OP(node) == OPTIMIZED) { if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE)) @@ -8604,23 +9419,21 @@ S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node, goto after_print; } else CLEAR_OPTSTART; - + regprop(r, sv, node); PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start), (int)(2*indent + 1), "", SvPVX_const(sv)); - - if (OP(node) != OPTIMIZED) { - if (next == NULL) /* Next ptr. */ - PerlIO_printf(Perl_debug_log, "(0)"); - else if (PL_regkind[(U8)op] == BRANCH && PL_regkind[OP(next)] != BRANCH ) - PerlIO_printf(Perl_debug_log, "(FAIL)"); - else - PerlIO_printf(Perl_debug_log, "(%"IVdf")", (IV)(next - start)); - - /*if (PL_regkind[(U8)op] != TRIE)*/ - (void)PerlIO_putc(Perl_debug_log, '\n'); - } - + + if (OP(node) != OPTIMIZED) { + if (next == NULL) /* Next ptr. */ + PerlIO_printf(Perl_debug_log, " (0)"); + else if (PL_regkind[(U8)op] == BRANCH && PL_regkind[OP(next)] != BRANCH ) + PerlIO_printf(Perl_debug_log, " (FAIL)"); + else + PerlIO_printf(Perl_debug_log, " (%"IVdf")", (IV)(next - start)); + (void)PerlIO_putc(Perl_debug_log, '\n'); + } + after_print: if (PL_regkind[(U8)op] == BRANCHJ) { assert(next); @@ -8640,18 +9453,20 @@ S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node, else if ( PL_regkind[(U8)op] == TRIE ) { const regnode *this_trie = node; const char op = OP(node); - const I32 n = ARG(node); + const U32 n = ARG(node); const reg_ac_data * const ac = op>=AHOCORASICK ? - (reg_ac_data *)r->data->data[n] : + (reg_ac_data *)ri->data->data[n] : NULL; - const reg_trie_data * const trie = opdata->data[n] : - ac->trie; + const reg_trie_data * const trie = + (reg_trie_data*)ri->data->data[optrie]; +#ifdef DEBUGGING + AV *const trie_words = (AV *) ri->data->data[n + TRIE_WORDS_OFFSET]; +#endif const regnode *nextbranch= NULL; I32 word_idx; sv_setpvn(sv, "", 0); for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) { - SV ** const elem_ptr = av_fetch(trie->words,word_idx,0); + SV ** const elem_ptr = av_fetch(trie_words,word_idx,0); PerlIO_printf(Perl_debug_log, "%*s%s ", (int)(2*(indent+3)), "", @@ -8665,11 +9480,11 @@ S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node, ); if (trie->jump) { U16 dist= trie->jump[word_idx+1]; - PerlIO_printf(Perl_debug_log, "(%u)\n", - (dist ? this_trie + dist : next) - start); + PerlIO_printf(Perl_debug_log, "(%"UVuf")\n", + (UV)((dist ? this_trie + dist : next) - start)); if (dist) { if (!nextbranch) - nextbranch = this_trie + trie->jump[0]; + nextbranch= this_trie + trie->jump[0]; DUMPUNTIL(this_trie + dist, nextbranch); } if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH) @@ -8711,12 +9526,10 @@ S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node, } if (op == CURLYX || op == OPEN) indent++; - else if (op == WHILEM) - indent--; } CLEAR_OPTSTART; #ifdef DEBUG_DUMPUNTIL - PerlIO_printf(Perl_debug_log, "--- %d\n",indent); + PerlIO_printf(Perl_debug_log, "--- %d\n", (int)indent); #endif return node; }