X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=regcomp.c;h=30b066050dd69ef5928c86e41055a0510e4f344d;hb=99ed40ffbc554c06cacea00522b9ea0d8190ec46;hp=2c2064b97c1e82ca7fc8458f7aeda80cd3c7967f;hpb=f46cb337096cfda46c854c48504fd7ed3e250166;p=p5sagit%2Fp5-mst-13.2.git diff --git a/regcomp.c b/regcomp.c index 2c2064b..30b0660 100644 --- a/regcomp.c +++ b/regcomp.c @@ -102,7 +102,8 @@ 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. */ @@ -113,11 +114,20 @@ typedef struct RExC_state_t { 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; + 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 char *starttry; /* -Dr: where regtry was called. */ #define RExC_starttry (pRExC_state->starttry) @@ -133,11 +143,12 @@ typedef struct 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 */ +#define RExC_offsets (pRExC_state->rxi->offsets) /* I am not like the others */ #define RExC_emit (pRExC_state->emit) #define RExC_emit_start (pRExC_state->emit_start) #define RExC_naughty (pRExC_state->naughty) @@ -145,10 +156,18 @@ typedef struct RExC_state_t { #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_charnames (pRExC_state->charnames) +#define RExC_open_parens (pRExC_state->open_parens) +#define RExC_close_parens (pRExC_state->close_parens) +#define RExC_opend (pRExC_state->opend) +#define RExC_paren_names (pRExC_state->paren_names) +#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) == '?' || \ @@ -176,6 +195,14 @@ typedef struct RExC_state_t { #endif + +#define PBYTE(u8str,paren) ((U8*)(u8str))[(paren) >> 3] +#define PBITVAL(paren) (1 << ((paren) & 7)) +#define PAREN_TEST(u8str,paren) ( PBYTE(u8str,paren) & PBITVAL(paren)) +#define PAREN_SET(u8str,paren) PBYTE(u8str,paren) |= PBITVAL(paren) +#define PAREN_UNSET(u8str,paren) PBYTE(u8str,paren) &= (~PBITVAL(paren)) + + /* About scan_data_t. During optimisation we recurse through the regexp program performing @@ -313,11 +340,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 @@ -344,7 +371,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; \ \ @@ -355,10 +382,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 */ @@ -477,7 +511,7 @@ static const scan_data_t zero_scan_data = #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 { \ @@ -523,9 +557,9 @@ static const scan_data_t zero_scan_data = #endif #define DEBUG_STUDYDATA(data,depth) \ -DEBUG_OPTIMISE_r(if(data){ \ +DEBUG_OPTIMISE_MORE_r(if(data){ \ PerlIO_printf(Perl_debug_log, \ - "%*s"/* Len:%"IVdf"/%"IVdf" */" Pos:%"IVdf"/%"IVdf \ + "%*s"/* Len:%"IVdf"/%"IVdf" */"Pos:%"IVdf"/%"IVdf \ " Flags: %"IVdf" Whilem_c: %"IVdf" Lcp: %"IVdf" ", \ (int)(depth)*2, "", \ (IV)((data)->pos_min), \ @@ -662,6 +696,8 @@ STATIC void S_cl_and(struct regnode_charclass_class *cl, const struct regnode_charclass_class *and_with) { + + assert(and_with->type == ANYOF); if (!(and_with->flags & ANYOF_CLASS) && !(cl->flags & ANYOF_CLASS) && (and_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE) @@ -761,9 +797,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 @@ -776,17 +812,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; @@ -795,7 +831,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, @@ -814,7 +850,7 @@ S_dump_trie(pTHX_ const struct _reg_trie_data *trie,U32 depth) PerlIO_printf( Perl_debug_log, "%.*s", colwidth, "--------"); PerlIO_printf( Perl_debug_log, "\n"); - for( state = 1 ; state < trie->laststate ; state++ ) { + for( state = 1 ; state < trie->statecount ; state++ ) { const U32 base = trie->states[ state ].trans.base; PerlIO_printf( Perl_debug_log, "%*s#%4"UVXf"|", (int)depth * 2 + 2,"", (UV)state); @@ -857,18 +893,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", @@ -888,7 +925,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, @@ -897,29 +934,33 @@ S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie, U32 next_alloc (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) | PERL_PV_ESCAPE_FIRSTCHAR ) , - TRIE_LIST_ITEM(state,charid).forid, - (UV)TRIE_LIST_ITEM(state,charid).newstate - ); - } + TRIE_LIST_ITEM(state,charid).forid, + (UV)TRIE_LIST_ITEM(state,charid).newstate + ); + if (!(charid % 10)) + PerlIO_printf(Perl_debug_log, "\n%*s| ", + (int)((depth * 2) + 14), ""); + } } PerlIO_printf( Perl_debug_log, "\n"); } } /* - 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; /* @@ -930,7 +971,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, @@ -1092,11 +1133,12 @@ is the recommended Unicode-aware way of saying *(d++) = uv; */ -#define TRIE_STORE_REVCHAR \ +#define TRIE_STORE_REVCHAR \ STMT_START { \ - SV *tmp = Perl_newSVpvf_nocontext( "%c", (int)uvc ); \ + SV *tmp = newSVpvs(""); \ if (UTF) SvUTF8_on(tmp); \ - av_push( TRIE_REVCHARMAP(trie), tmp ); \ + Perl_sv_catpvf( aTHX_ tmp, "%c", (int)uvc ); \ + av_push( revcharmap, tmp ); \ } STMT_END #define TRIE_READ_CHAR STMT_START { \ @@ -1127,9 +1169,8 @@ is the recommended Unicode-aware way of saying #define TRIE_LIST_PUSH(state,fid,ns) STMT_START { \ if ( TRIE_LIST_CUR( state ) >=TRIE_LIST_LEN( state ) ) { \ - TRIE_LIST_LEN( state ) *= 2; \ - Renew( trie->states[ state ].trans.list, \ - TRIE_LIST_LEN( state ), reg_trie_trans_le ); \ + U32 ging = TRIE_LIST_LEN( state ) *= 2; \ + Renew( trie->states[ state ].trans.list, ging, reg_trie_trans_le ); \ } \ TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).forid = fid; \ TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).newstate = ns; \ @@ -1157,15 +1198,15 @@ 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[curword] = (U16)(tail - noper_next); \ + trie->jump = PerlMemShared_calloc( word_count + 1, sizeof(U16) ); \ + trie->jump[curword] = (U16)(noper_next - convert); \ if (!jumper) \ jumper = noper_next; \ if (!nextbranch) \ @@ -1178,7 +1219,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 = \ + PerlMemShared_calloc( word_count + 1, sizeof(U16)); \ while ( trie->nextword[dupe] ) \ dupe= trie->nextword[dupe]; \ trie->nextword[dupe]= curword; \ @@ -1208,6 +1250,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; @@ -1216,6 +1260,7 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs U32 next_alloc = 0; regnode *jumper = NULL; regnode *nextbranch = NULL; + regnode *convert = NULL; /* we just use folder as a flag in utf8 */ const U8 * const folder = ( flags == EXACTF ? PL_fold @@ -1225,32 +1270,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 = 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 = PerlMemShared_calloc( 256, sizeof(U16) ); if (!(UTF && folder)) - Newxz( trie->bitmap, ANYOF_BITMAP_SIZE, char ); + trie->bitmap = 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)) { @@ -1264,6 +1310,16 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs REG_NODE_NUM(last), REG_NODE_NUM(tail), (int)depth); }); + + /* Find the node we are going to overwrite */ + if ( first == startbranch && OP( last ) != BRANCH ) { + /* whole branch chain */ + convert = first; + } else { + /* branch sub-chain */ + convert = NEXTOPER( first ); + } + /* -- First loop and Setup -- We first traverse the branches and scan each word to determine if it @@ -1318,10 +1374,10 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs } } 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 ); @@ -1345,11 +1401,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 = PerlMemShared_calloc( word_count, sizeof(U32) ); /* We now know what we are dealing with in terms of unique chars and @@ -1388,7 +1444,12 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs STRLEN transcount = 1; - Newxz( trie->states, TRIE_CHARCOUNT(trie) + 2, reg_trie_state ); + DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log, + "%*sCompiling trie using list compiler\n", + (int)depth * 2 + 2, "")); + + trie->states = PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2, + sizeof(reg_trie_state) ); TRIE_LIST_NEW(1); next_alloc = 2; @@ -1412,7 +1473,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 { @@ -1450,15 +1511,19 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs } /* end second pass */ - trie->laststate = next_alloc; - Renew( trie->states, next_alloc, reg_trie_state ); + /* next alloc is the NEXT state to be allocated */ + trie->statecount = next_alloc; + trie->states = 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 + = PerlMemShared_calloc( transcount, sizeof(reg_trie_trans) ); { U32 state; U32 tp = 0; @@ -1489,7 +1554,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 + = PerlMemShared_realloc( trie->trans, + transcount + * sizeof(reg_trie_trans) ); Zero( trie->trans + (transcount / 2), transcount / 2 , reg_trie_trans ); } base = trie->uniquecharcount + tp - minid; @@ -1565,11 +1633,15 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs use TRIE_NODENUM() to convert. */ - - - Newxz( trie->trans, ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1, - reg_trie_trans ); - Newxz( trie->states, TRIE_CHARCOUNT(trie) + 2, reg_trie_state ); + DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log, + "%*sCompiling trie using table compiler\n", + (int)depth * 2 + 2, "")); + + trie->trans = PerlMemShared_calloc( ( TRIE_CHARCOUNT(trie) + 1 ) + * trie->uniquecharcount + 1, + sizeof(reg_trie_trans) ); + trie->states = PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2, + sizeof(reg_trie_state) ); next_alloc = trie->uniquecharcount + 1; @@ -1597,7 +1669,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 ) { @@ -1620,9 +1692,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)); { /* @@ -1689,7 +1761,7 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs const U32 laststate = TRIE_NODENUM( next_alloc ); U32 state, charid; U32 pos = 0, zp=0; - trie->laststate = laststate; + trie->statecount = laststate; for ( state = 1 ; state < laststate ; state++ ) { U8 flag = 0; @@ -1726,7 +1798,8 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs } } trie->lasttrans = pos + 1; - Renew( trie->states, laststate + 1, reg_trie_state); + trie->states = 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", @@ -1739,23 +1812,27 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs } /* end table compress */ } + DEBUG_TRIE_COMPILE_MORE_r( + PerlIO_printf(Perl_debug_log, "%*sStatecount:%"UVxf" Lasttrans:%"UVxf"\n", + (int)depth * 2 + 2, "", + (UV)trie->statecount, + (UV)trie->lasttrans) + ); /* resize the trans array to remove unused space */ - Renew( trie->trans, trie->lasttrans, reg_trie_trans); + 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*/ - regnode *convert; U8 nodetype =(U8)(flags & 0xFF); char *str=NULL; #ifdef DEBUGGING - - U32 mjd_offset; - U32 mjd_nodelen; + regnode *optimize = NULL; + U32 mjd_offset = 0; + U32 mjd_nodelen = 0; #endif /* This means we convert either the first branch or the first Exact, @@ -1766,23 +1843,22 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs the whole branch sequence, including the first. */ /* Find the node we are going to overwrite */ - if ( first == startbranch && OP( last ) != BRANCH ) { - /* whole branch chain */ - convert = first; - DEBUG_r({ - const regnode *nop = NEXTOPER( convert ); - mjd_offset= Node_Offset((nop)); - mjd_nodelen= Node_Length((nop)); - }); - } else { + if ( first != startbranch || OP( last ) == BRANCH ) { /* branch sub-chain */ - convert = NEXTOPER( first ); NEXT_OFF( first ) = (U16)(last - first); DEBUG_r({ mjd_offset= Node_Offset((convert)); mjd_nodelen= Node_Length((convert)); }); + /* whole branch chain */ + } 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, "", @@ -1792,14 +1868,9 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs /* 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; - DEBUG_OPTIMISE_r( - PerlIO_printf(Perl_debug_log, "%*sLaststate:%"UVuf"\n", - (int)depth * 2 + 2, "", - (UV)trie->laststate) - ); - for ( state = 1 ; state < trie->laststate-1 ; state++ ) { + for ( state = 1 ; state < trie->statecount-1 ; state++ ) { U32 ofs = 0; I32 idx = -1; U32 count = 0; @@ -1814,7 +1885,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 ) { @@ -1825,7 +1896,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); @@ -1845,22 +1916,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) @@ -1877,19 +1957,32 @@ 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; } else { NEXT_OFF(convert) = (U16)(tail - convert); + DEBUG_r(optimize= n); } } } + if (!jumper) + jumper = last; if ( trie->maxlen ) { NEXT_OFF( convert ) = (U16)(tail - convert); ARG_SET( convert, data_slot ); @@ -1897,31 +1990,33 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs jump[0], which is otherwise unused by the jump logic. We use this when dumping a trie and during optimisation. */ if (trie->jump) - trie->jump[0] = (U16)(tail - nextbranch); - if (!jumper) - jumper = last; + trie->jump[0] = (U16)(nextbranch - convert); + /* XXXX */ if ( !trie->states[trie->startstate].wordnum && trie->bitmap && ( (char *)jumper - (char *)convert) >= (int)sizeof(struct regnode_charclass) ) { 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; /* store the type in the flags */ convert->flags = nodetype; - /* XXX We really should free up the resource in trie now, as we wont use them */ + DEBUG_r({ + optimize = convert + + NODE_STEP_REGNODE + + regarglen[ OP( convert ) ]; + }); + /* XXX We really should free up the resource in trie now, + as we won't use them - (which resources?) dmq */ } /* needed for dumping*/ - DEBUG_r({ - regnode *optimize = convert - + NODE_STEP_REGNODE - + regarglen[ OP( convert ) ]; + DEBUG_r(if (optimize) { regnode *opt = convert; - while (++optdata->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 @@ -1968,10 +2067,11 @@ 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->laststate; + const U32 numstates = trie->statecount; const U32 ubound = trie->lasttrans + ucharcount; U32 q_read = 0; U32 q_write = 0; @@ -1987,13 +2087,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, - (trie->laststate+1)*sizeof(reg_trie_state)); + aho = 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 = PerlMemShared_calloc( numstates, sizeof(U32) ); aho->refcount = 1; fail = aho->fail; /* initialize fail[0..1] to be 1 so that we always have @@ -2040,7 +2140,10 @@ 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: 0", (int)(depth * 2), ""); + 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", \ + PerlIO_printf(Perl_debug_log, "%*s" str ">%3d: %s (%d)\n", \ (int)depth*2, "", REG_NODE_NUM(scan), SvPV_nolen_const(mysv),\ Next ? (REG_NODE_NUM(Next)) : 0 ); \ - }); + }}); @@ -2228,15 +2331,38 @@ S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, I32 *min, U32 flags /* Stops at toplevel WHILEM as well as at "last". At end *scanp is set to the position after last scanned or to NULL. */ - +#define INIT_AND_WITHP \ + assert(!and_withp); \ + 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; STATIC I32 -S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, +S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *minlenp, I32 *deltap, - regnode *last, scan_data_t *data, U32 flags, U32 depth) + regnode *last, + scan_data_t *data, + I32 stopparen, + U8* recursed, + struct regnode_charclass_class *and_withp, + U32 flags, U32 depth) /* scanp: Start here (read-write). */ /* deltap: Write maxlen-minlen here. */ /* last: Stop before this one. */ + /* data: string data about the pattern */ + /* stopparen: treat close N as END */ + /* recursed: which subroutines have we recursed into */ + /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */ { dVAR; I32 min = 0, pars = 0, code; @@ -2246,22 +2372,25 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, int is_inf_internal = 0; /* The studied chunk is infinite */ I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0; scan_data_t data_fake; - struct regnode_charclass_class and_with; /* Valid if flags & SCF_DO_STCLASS_OR */ 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); + StructCopy(&zero_scan_data, &data_fake, scan_data_t); #endif + if ( depth == 0 ) { - while (first_non_open && OP(first_non_open) == OPEN) + while (first_non_open && OP(first_non_open) == OPEN) first_non_open=regnext(first_non_open); } - while (scan && OP(scan) != END && scan < last) { + fake_study_recurse: + while ( scan && OP(scan) != END && scan < last ){ /* Peephole optimizer: */ DEBUG_STUDYDATA(data,depth); DEBUG_PEEP("Peep",scan,depth); @@ -2295,12 +2424,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. */ @@ -2308,7 +2437,7 @@ 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? */ + 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); @@ -2319,12 +2448,14 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, num++; data_fake.flags = 0; - if (data) { + if (data) { data_fake.whilem_c = data->whilem_c; data_fake.last_closep = data->last_closep; } else data_fake.last_closep = &fake; + + data_fake.pos_delta = delta; next = regnext(scan); scan = NEXTOPER(scan); if (code != BRANCH) @@ -2333,13 +2464,14 @@ 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; /* we suppose the run is continuous, last=next...*/ minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext, - next, &data_fake, f,depth+1); + next, &data_fake, + stopparen, recursed, NULL, f,depth+1); if (min1 > minnext) min1 = minnext; if (max1 < minnext + deltanext) @@ -2349,6 +2481,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; @@ -2356,8 +2495,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; @@ -2372,7 +2509,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, if (flags & SCF_DO_STCLASS_OR) { cl_or(pRExC_state, data->start_class, &accum); if (min1) { - cl_and(data->start_class, &and_with); + cl_and(data->start_class, and_withp); flags &= ~SCF_DO_STCLASS; } } @@ -2384,7 +2521,8 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, else { /* Switch to OR mode: cache the old value of * data->start_class */ - StructCopy(data->start_class, &and_with, + INIT_AND_WITHP; + StructCopy(data->start_class, and_withp, struct regnode_charclass_class); flags &= ~SCF_DO_STCLASS_AND; StructCopy(&accum, data->start_class, @@ -2504,7 +2642,9 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, /* dont use tail as the end marker for this traverse */ for ( cur = startbranch ; cur != scan ; cur = regnext( cur ) ) { regnode * const noper = NEXTOPER( cur ); +#if defined(DEBUGGING) || defined(NOJUMPTRIE) regnode * const noper_next = regnext( noper ); +#endif DEBUG_OPTIMISE_r({ regprop(RExC_rx, mysv, cur); @@ -2573,8 +2713,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 } } @@ -2587,6 +2733,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); @@ -2648,7 +2851,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, else data->start_class->flags |= ANYOF_UNICODE_ALL; data->start_class->flags &= ~ANYOF_EOS; - cl_and(data->start_class, &and_with); + cl_and(data->start_class, and_withp); } flags &= ~SCF_DO_STCLASS; } @@ -2696,7 +2899,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, ANYOF_BITMAP_SET(data->start_class, uc); data->start_class->flags &= ~ANYOF_EOS; } - cl_and(data->start_class, &and_with); + cl_and(data->start_class, and_withp); } flags &= ~SCF_DO_STCLASS; } @@ -2743,8 +2946,15 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, } goto optimize_curly_tail; case CURLY: - mincount = ARG1(scan); - maxcount = ARG2(scan); + if (stopparen>0 && (OP(scan)==CURLYN || OP(scan)==CURLYM) + && (scan->flags == stopparen)) + { + mincount = 1; + maxcount = 1; + } else { + mincount = ARG1(scan); + maxcount = ARG2(scan); + } next = regnext(scan); if (OP(scan) == CURLYX) { I32 lp = (data ? *(data->last_closep) : 0); @@ -2780,7 +2990,8 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, f &= ~SCF_WHILEM_VISITED_POS; /* This will finish on WHILEM, setting scan, or on NULL: */ - minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext, last, data, + minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext, + last, data, stopparen, recursed, NULL, (mincount == 0 ? (f & ~SCF_DO_SUBSTR) : f),depth+1); @@ -2793,7 +3004,8 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, else if (flags & SCF_DO_STCLASS_AND) { /* Switch to OR mode: cache the old value of * data->start_class */ - StructCopy(data->start_class, &and_with, + INIT_AND_WITHP; + StructCopy(data->start_class, and_withp, struct regnode_charclass_class); flags &= ~SCF_DO_STCLASS_AND; StructCopy(&this_class, data->start_class, @@ -2804,7 +3016,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, } else { /* Non-zero len */ if (flags & SCF_DO_STCLASS_OR) { cl_or(pRExC_state, data->start_class, &this_class); - cl_and(data->start_class, &and_with); + cl_and(data->start_class, and_withp); } else if (flags & SCF_DO_STCLASS_AND) cl_and(data->start_class, &this_class); @@ -2854,10 +3066,15 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, nxt = regnext(nxt); if (OP(nxt) != CLOSE) goto nogo; + if (RExC_open_parens) { + RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/ + RExC_close_parens[ARG(nxt1)-1]=nxt+2; /*close->while*/ + } /* Now we know that nxt2 is the only contents: */ oscan->flags = (U8)ARG(nxt); OP(oscan) = CURLYN; OP(nxt1) = NOTHING; /* was OPEN. */ + #ifdef DEBUGGING OP(nxt1 + 1) = OPTIMIZED; /* was count. */ NEXT_OFF(nxt1+ 1) = 0; /* just for consistancy. */ @@ -2894,8 +3111,13 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, if (OP(nxt) != CLOSE) FAIL("Panic opt close"); oscan->flags = (U8)ARG(nxt); + if (RExC_open_parens) { + RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/ + RExC_close_parens[ARG(nxt1)-1]=nxt2+1; /*close->NOTHING*/ + } OP(nxt1) = OPTIMIZED; /* was OPEN. */ OP(nxt) = OPTIMIZED; /* was CLOSE. */ + #ifdef DEBUGGING OP(nxt1 + 1) = OPTIMIZED; /* was count. */ OP(nxt + 1) = OPTIMIZED; /* was count. */ @@ -2919,7 +3141,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, #endif /* Optimize again: */ study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt, - NULL, 0,depth+1); + NULL, stopparen, recursed, NULL, 0,depth+1); } else oscan->flags = 0; @@ -3251,7 +3473,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, break; } if (flags & SCF_DO_STCLASS_OR) - cl_and(data->start_class, &and_with); + cl_and(data->start_class, and_withp); flags &= ~SCF_DO_STCLASS; } } @@ -3283,6 +3505,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); @@ -3293,13 +3516,14 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, f |= SCF_WHILEM_VISITED_POS; next = regnext(scan); nscan = NEXTOPER(NEXTOPER(scan)); - minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext, last, &data_fake, f,depth+1); + minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext, + 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; } @@ -3353,6 +3577,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, 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 @@ -3365,28 +3590,28 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, f |= SCF_WHILEM_VISITED_POS; next = regnext(scan); nscan = NEXTOPER(NEXTOPER(scan)); - - *minnextp = study_chunk(pRExC_state, &nscan, minnextp, &deltanext, last, &data_fake, f,depth+1); + + *minnextp = study_chunk(pRExC_state, &nscan, minnextp, &deltanext, + 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; } - + *minnextp += min; - - + if (f & SCF_DO_STCLASS_AND) { const int was = (data->start_class->flags & ANYOF_EOS); cl_and(data->start_class, &intrnl); if (was) data->start_class->flags |= ANYOF_EOS; - } + } if (data) { if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR)) pars++; @@ -3420,9 +3645,13 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, #endif } else if (OP(scan) == OPEN) { - pars++; + if (stopparen != (I32)ARG(scan)) + pars++; } else if (OP(scan) == CLOSE) { + if (stopparen == (I32)ARG(scan)) { + break; + } if ((I32)ARG(scan) == is_par) { next = regnext(scan); @@ -3436,7 +3665,19 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, if (data) data->flags |= SF_HAS_EVAL; } - else if (OP(scan) == LOGICAL && scan->flags == 2) { /* Embedded follows */ + else if ( PL_regkind[OP(scan)] == ENDLIKE ) { + if (flags & SCF_DO_SUBSTR) { + 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); data->longest = &(data->longest_float); @@ -3446,14 +3687,28 @@ 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 +#ifdef FULL_TRIE_STUDY else if (PL_regkind[OP(scan)] == TRIE) { /* NOTE - There is similar code to this block above for handling - BRANCH nodes on the initial study. If you change stuff here + BRANCH nodes on the initial study. If you change stuff here 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; @@ -3481,7 +3736,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; @@ -3492,14 +3747,15 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, if (trie->jump[word]) { if (!nextbranch) - nextbranch = tail - trie->jump[0]; - scan= tail - trie->jump[word]; + nextbranch = trie_node + trie->jump[0]; + scan= trie_node + trie->jump[word]; /* We go from the jump point to the branch that follows it. Note this means we need the vestigal unused branches even though they arent otherwise used. */ - minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext, - (regnode *)nextbranch, &data_fake, f,depth+1); + minnext = study_chunk(pRExC_state, &scan, minlenp, + &deltanext, (regnode *)nextbranch, &data_fake, + stopparen, recursed, NULL, f,depth+1); } if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH) nextbranch= regnext((regnode*)nextbranch); @@ -3513,7 +3769,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; @@ -3534,7 +3796,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, if (flags & SCF_DO_STCLASS_OR) { cl_or(pRExC_state, data->start_class, &accum); if (min1) { - cl_and(data->start_class, &and_with); + cl_and(data->start_class, and_withp); flags &= ~SCF_DO_STCLASS; } } @@ -3546,7 +3808,8 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, else { /* Switch to OR mode: cache the old value of * data->start_class */ - StructCopy(data->start_class, &and_with, + INIT_AND_WITHP; + StructCopy(data->start_class, and_withp, struct regnode_charclass_class); flags &= ~SCF_DO_STCLASS_AND; StructCopy(&accum, data->start_class, @@ -3560,7 +3823,7 @@ 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; @@ -3581,8 +3844,17 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, /* 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); + *scanp = scan; *deltap = is_inf_internal ? I32_MAX : delta; if (flags & SCF_DO_SUBSTR && is_inf) @@ -3598,33 +3870,30 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, data->flags &= ~SF_IN_PAR; } if (flags & SCF_DO_STCLASS_OR) - cl_and(data->start_class, &and_with); + cl_and(data->start_class, and_withp); if (flags & SCF_TRIE_RESTUDY) data->flags |= SCF_TRIE_RESTUDY; DEBUG_STUDYDATA(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) { - Renewc(RExC_rx->data, - sizeof(*RExC_rx->data) + sizeof(void*) * (RExC_rx->data->count + n - 1), - char, struct reg_data); - Renew(RExC_rx->data->what, RExC_rx->data->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; } #ifndef PERL_IN_XSUB_RE @@ -3665,6 +3934,7 @@ Perl_reginitcolors(pTHX) #else #define CHECK_RESTUDY_GOTO #endif + /* - pregcomp - compile a regular expression into internal code * @@ -3680,11 +3950,46 @@ Perl_reginitcolors(pTHX) * Beware that the optimization-preparation code in here knows about some * of the structure of the compiled regexp. [I'll say.] */ + + + +#ifndef PERL_IN_XSUB_RE +#define RE_ENGINE_PTR &PL_core_reg_engine +#else +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) { dVAR; + GET_RE_DEBUG_FLAGS_DECL; + DEBUG_r(if (!PL_colorset) reginitcolors()); +#ifndef PERL_IN_XSUB_RE + BEGIN_BLOCK + /* 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); + 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); + } + } + END_BLOCK +#endif + BEGIN_BLOCK register regexp *r; + register regexp_internal *ri; regnode *scan; regnode *first; I32 flags; @@ -3698,16 +4003,12 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm) int restudied= 0; RExC_state_t copyRExC_state; #endif - - GET_RE_DEBUG_FLAGS_DECL; - if (exp == NULL) FAIL("NULL regexp argument"); RExC_utf8 = pm->op_pmdynflags & PMdf_CMP_UTF8; RExC_precomp = exp; - DEBUG_r(if (!PL_colorset) reginitcolors()); DEBUG_COMPILE_r({ SV *dsv= sv_newmortal(); RE_PV_QUOTED_DECL(s, RExC_utf8, @@ -3729,9 +4030,18 @@ 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; + RExC_charnames = NULL; + RExC_open_parens = NULL; + RExC_close_parens = NULL; + RExC_opend = NULL; + RExC_paren_names = NULL; + RExC_recurse = NULL; + RExC_recurse_count = 0; + #if 0 /* REGC() is (currently) a NOP at the first pass. * Clever compilers notice this and complain. --jhi */ REGC((U8)REG_MAGIC, (char*)RExC_emit); @@ -3741,15 +4051,14 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm) RExC_precomp = NULL; return(NULL); } - DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "Required ")); - DEBUG_COMPILE_r(PerlIO_printf(Perl_debug_log, "size %"IVdf" nodes ", (IV)RExC_size)); - DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "\nStarting second pass (creation)\n")); DEBUG_PARSE_r({ + PerlIO_printf(Perl_debug_log, + "Required size %"IVdf" nodes\n" + "Starting second pass (creation)\n", + (IV)RExC_size); RExC_lastnum=0; RExC_lastparse=NULL; }); - - /* Small enough for pointer-storage convention? If extralen==0, this means that we will not need long jumps. */ if (RExC_size >= 0x10000L && RExC_extralen) @@ -3759,41 +4068,56 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm) if (RExC_whilem_seen > 15) RExC_whilem_seen = 15; - /* Allocate space and initialize. */ - Newxc(r, sizeof(regexp) + (unsigned)RExC_size * sizeof(regnode), - char, regexp); - if (r == NULL) - FAIL("Regexp out of space"); +#ifdef DEBUGGING + /* Make room for a sentinel value at the end of the program */ + RExC_size++; +#endif + /* Allocate space and zero-initialize. Note, the two step process + of zeroing when in debug mode, thus anything assigned has to + happen after that */ + 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 + + /* 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->extflags = pm->op_pmflags & RXf_PMf_COMPILETIME; + r->intflags = 0; r->nparens = RExC_npar - 1; /* set early to validate backrefs */ - r->lastparen = 0; /* mg.c reads this. */ - - r->substrs = 0; /* Useful during FAIL. */ - r->startp = 0; /* Useful during FAIL. */ - r->endp = 0; /* Useful during FAIL. */ + + if (RExC_seen & REG_SEEN_RECURSE) { + Newxz(RExC_open_parens, RExC_npar,regnode *); + SAVEFREEPV(RExC_open_parens); + Newxz(RExC_close_parens,RExC_npar,regnode *); + SAVEFREEPV(RExC_close_parens); + } - Newxz(r->offsets, 2*RExC_size+1, U32); /* MJD 20001228 */ - if (r->offsets) { - r->offsets[0] = RExC_size; + /* Useful during FAIL. */ + Newxz(ri->offsets, 2*RExC_size+1, U32); /* MJD 20001228 */ + if (ri->offsets) { + ri->offsets[0] = RExC_size; } DEBUG_OFFSETS_r(PerlIO_printf(Perl_debug_log, "%s %"UVuf" bytes for offset annotations.\n", - r->offsets ? "Got" : "Couldn't get", + ri->offsets ? "Got" : "Couldn't get", (UV)((2*RExC_size+1) * sizeof(U32)))); RExC_rx = r; + RExC_rxi = ri; /* Second pass: emit code. */ RExC_flags = pm->op_pmflags; /* don't let top level (?i) bleed */ @@ -3801,49 +4125,68 @@ Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm) 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; +#ifdef DEBUGGING + /* put a sentinal on the end of the program so we can check for + overwrites */ + ri->program[RExC_size].type = 255; +#endif /* 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; REGC((U8)REG_MAGIC, (char*) RExC_emit++); - r->data = 0; if (reg(pRExC_state, 0, &flags,1) == NULL) return(NULL); + /* XXXX To minimize changes to RE engine we always allocate 3-units-long substrs field. */ Newx(r->substrs, 1, struct reg_substr_data); + if (RExC_recurse_count) { + Newxz(RExC_recurse,RExC_recurse_count,regnode *); + SAVEFREEPV(RExC_recurse); + } reStudy: r->minlen = minlen = sawplus = sawopen = 0; Zero(r->substrs, 1, struct reg_substr_data); - StructCopy(&zero_scan_data, &data, scan_data_t); #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); SvREFCNT_dec(data.last_found); } + StructCopy(&zero_scan_data, &data, scan_data_t); } else { - copyRExC_state=RExC_state; + StructCopy(&zero_scan_data, &data, scan_data_t); + 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? */ + r->extflags = pm->op_pmflags & RXf_PMf_COMPILETIME; /* Again? */ 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 */ - if (OP(scan) != BRANCH) { /* Only one top-level choice. */ + if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES)) { /* Only one top-level choice. */ I32 fake; STRLEN longest_float_length, longest_fixed_length; struct regnode_charclass_class ch_class; /* pointed to by data */ @@ -3882,76 +4225,78 @@ 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 = + 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 = + 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 - DEBUG_COMPILE_r( + DEBUG_PARSE_r( if (!restudied) PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n", (IV)(first - scan + 1)) ); #else - DEBUG_COMPILE_r( + DEBUG_PARSE_r( PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n", (IV)(first - scan + 1)) ); @@ -3969,23 +4314,23 @@ 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, SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag,0); + &data, -1, NULL, NULL, + SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag,0); CHECK_RESTUDY_GOTO; @@ -3994,8 +4339,8 @@ 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; + && (!(RExC_seen & REG_SEEN_GPOS) || (r->extflags & RXf_ANCH_GPOS))) + r->extflags |= RXf_CHECK_ALL; scan_commit(pRExC_state, &data,&minlen); SvREFCNT_dec(data.last_found); @@ -4007,7 +4352,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; @@ -4041,7 +4386,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 { @@ -4059,7 +4404,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; @@ -4085,7 +4430,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 { @@ -4093,23 +4438,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, @@ -4123,8 +4468,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; @@ -4135,10 +4480,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 ) @@ -4153,16 +4498,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, SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS,0); - + &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 @@ -4170,15 +4516,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, @@ -4189,40 +4535,154 @@ 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 (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); + /* assume we don't need to swap parens around before we match */ - DEBUG_r( RX_DEBUG_on(r) ); 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]; + DEBUG_OFFSETS_r(if (ri->offsets) { + const U32 len = ri->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->offsets[0]); for (i = 1; i <= len; i++) { - if (r->offsets[i*2-1] || r->offsets[i*2]) + if (ri->offsets[i*2-1] || ri->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->offsets[i*2-1], (UV)ri->offsets[i*2]); } PerlIO_printf(Perl_debug_log, "\n"); }); 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) +{ + 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; + } + } + } + } + } + if ( !parno ) { + return 0; + } 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); + } +} +#endif + +/* Scans the name of a named buffer from the pattern. + * If flags is REG_RSN_RETURN_NULL returns null. + * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name + * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding + * to the parsed name as looked up in the RExC_paren_names hash. + * If there is an error throws a vFAIL().. type exception. + */ + +#define REG_RSN_RETURN_NULL 0 +#define REG_RSN_RETURN_NAME 1 +#define REG_RSN_RETURN_DATA 2 + +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 ( flags ) { + SV* sv_name = sv_2mortal(Perl_newSVpvn(aTHX_ name_start, + (int)(RExC_parse - name_start))); + if (UTF) + SvUTF8_on(sv_name); + if ( flags == REG_RSN_RETURN_NAME) + return sv_name; + else if (flags==REG_RSN_RETURN_DATA) { + HE *he_str = NULL; + SV *sv_dat = NULL; + if ( ! sv_name ) /* should not happen*/ + Perl_croak(aTHX_ "panic: no svname in reg_scan_name"); + if (RExC_paren_names) + he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 ); + if ( he_str ) + sv_dat = HeVAL(he_str); + if ( ! sv_dat ) + vFAIL("Reference to nonexistent named group"); + return sv_dat; + } + else { + Perl_croak(aTHX_ "panic: bad flag in reg_scan_name"); + } + /* NOT REACHED */ + } + return NULL; +} #define DEBUG_PARSE_MSG(funcname) DEBUG_PARSE_r({ \ int rem=(int)(RExC_end - RExC_parse); \ @@ -4248,9 +4708,9 @@ reStudy: else \ num=REG_NODE_NUM(RExC_emit); \ if (RExC_lastnum!=num) \ - PerlIO_printf(Perl_debug_log,"|%4d",num); \ + PerlIO_printf(Perl_debug_log,"|%4d",num); \ else \ - PerlIO_printf(Perl_debug_log,"|%4s",""); \ + PerlIO_printf(Perl_debug_log,"|%4s",""); \ PerlIO_printf(Perl_debug_log,"|%*s%-4s", \ (int)((depth*2)), "", \ (funcname) \ @@ -4265,6 +4725,10 @@ reStudy: DEBUG_PARSE_MSG((funcname)); \ PerlIO_printf(Perl_debug_log,"%4s","\n"); \ }) +#define DEBUG_PARSE_FMT(funcname,fmt,args) DEBUG_PARSE_r({ \ + DEBUG_PARSE_MSG((funcname)); \ + PerlIO_printf(Perl_debug_log,fmt "\n",args); \ +}) /* - reg - regular expression, i.e. main body or parenthesized thing * @@ -4281,6 +4745,10 @@ reStudy: #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1) #endif +/* this idea is borrowed from STR_WITH_LEN in handy.h */ +#define CHECK_WORD(s,v,l) \ + (((sizeof(s)-1)==(l)) && (strnEQ(start_verb, (s ""), (sizeof(s)-1)))) + STATIC regnode * S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) /* paren: Parenthesized? 0=top, 1=(, inside: changed to letter. */ @@ -4317,6 +4785,111 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) /* 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 ( CHECK_WORD("ACCEPT",start_verb,verb_len) ) { + op = ACCEPT; + internal_argval = RExC_nestroot; + } + break; + case 'C': /* (*COMMIT) */ + if ( CHECK_WORD("COMMIT",start_verb,verb_len) ) + op = COMMIT; + break; + case 'F': /* (*FAIL) */ + if ( verb_len==1 || CHECK_WORD("FAIL",start_verb,verb_len) ) { + op = OPFAIL; + argok = 0; + } + break; + case ':': /* (*:NAME) */ + case 'M': /* (*MARK:NAME) */ + if ( verb_len==0 || CHECK_WORD("MARK",start_verb,verb_len) ) { + op = MARKPOINT; + argok = -1; + } + break; + case 'P': /* (*PRUNE) */ + if ( CHECK_WORD("PRUNE",start_verb,verb_len) ) + op = PRUNE; + break; + case 'S': /* (*SKIP) */ + if ( CHECK_WORD("SKIP",start_verb,verb_len) ) + op = SKIP; + break; + case 'T': /* (*THEN) */ + /* [19:06] :: is then */ + if ( CHECK_WORD("THEN",start_verb,verb_len) ) { + 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; @@ -4327,16 +4900,72 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) paren = *RExC_parse++; ret = NULL; /* For look-ahead/behind. */ switch (paren) { + case '<': /* (?<...) */ - RExC_seen |= REG_SEEN_LOOKBEHIND; if (*RExC_parse == '!') paren = ','; - if (*RExC_parse != '=' && *RExC_parse != '!') - goto unknown; + else if (*RExC_parse != '=') + { /* (?<...>) */ + char *name_start; + SV *svname; + paren= '>'; + case '\'': /* (?'...') */ + name_start= RExC_parse; + svname = reg_scan_name(pRExC_state, + 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 != paren) + vFAIL2("Sequence (?%c... not terminated", + paren=='>' ? '<' : paren); + if (SIZE_ONLY) { + HE *he_str; + SV *sv_dat = NULL; + if (!svname) /* shouldnt happen */ + Perl_croak(aTHX_ + "panic: reg_scan_name returned NULL"); + if (!RExC_paren_names) { + RExC_paren_names= newHV(); + sv_2mortal((SV*)RExC_paren_names); + } + he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 ); + if ( he_str ) + sv_dat = HeVAL(he_str); + if ( ! sv_dat ) { + /* croak baby croak */ + 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)++; + } else { + (void)SvUPGRADE(sv_dat,SVt_PVNV); + sv_setpvn(sv_dat, (char *)&(RExC_npar), sizeof(I32)); + SvIOK_on(sv_dat); + SvIVX(sv_dat)= 1; + } + + /*sv_dump(sv_dat);*/ + } + nextchar(pRExC_state); + paren = 1; + goto capturing_parens; + } + RExC_seen |= REG_SEEN_LOOKBEHIND; RExC_parse++; case '=': /* (?=...) */ case '!': /* (?!...) */ RExC_seen_zerolen++; + if (*RExC_parse == ')') { + ret=reg_node(pRExC_state, OPFAIL); + nextchar(pRExC_state); + return ret; + } case ':': /* (?:...) */ case '>': /* (?>...) */ break; @@ -4352,6 +4981,96 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) nextchar(pRExC_state); *flagp = TRYAGAIN; return NULL; + case '0' : /* (?0) */ + case 'R' : /* (?R) */ + if (*RExC_parse != ')') + FAIL("Sequence (?R) not terminated"); + ret = reg_node(pRExC_state, GOSTART); + nextchar(pRExC_state); + return ret; + /*notreached*/ + { /* named and numeric backreferences */ + I32 num; + char * parse_start; + case '&': /* (?&NAME) */ + parse_start = RExC_parse - 1; + { + SV *sv_dat = reg_scan_name(pRExC_state, + SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA); + num = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0; + } + 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) { + RExC_parse++; + vFAIL("Reference to nonexistent group"); + } + ARG2L_SET( ret, RExC_recurse_count++); + RExC_emit++; + DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log, + "Recurse #%"UVuf" to %"IVdf"\n", (UV)ARG(ret), (IV)ARG2L(ret))); + } else { + RExC_size++; + } + RExC_seen |= REG_SEEN_RECURSE; + Set_Node_Length(ret, 1 + regarglen[OP(ret)]); /* MJD */ + Set_Node_Offset(ret, parse_start); /* MJD */ + + 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 (??{})"); @@ -4364,7 +5083,8 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) /* FALL THROUGH */ case '{': /* (?{...}) */ { - I32 count = 1, n = 0; + I32 count = 1; + U32 n = 0; char c; char *s = RExC_parse; @@ -4399,9 +5119,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 */ @@ -4434,6 +5154,7 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) } case '(': /* (?(?{...})...) and (?(?=...)...) */ { + int is_define= 0; if (RExC_parse[0] == '?') { /* (?(?...)) */ if (RExC_parse[1] == '=' || RExC_parse[1] == '!' || RExC_parse[1] == '<' @@ -4447,6 +5168,55 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) goto insert_if; } } + else if ( RExC_parse[0] == '<' /* (?()...) */ + || RExC_parse[0] == '\'' ) /* (?('NAME')...) */ + { + char ch = RExC_parse[0] == '<' ? '>' : '\''; + 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 != ch) + vFAIL2("Sequence (?(%c... not terminated", + (ch == '>' ? '<' : ch)); + RExC_parse++; + if (!SIZE_ONLY) { + num = add_data( pRExC_state, 1, "S" ); + RExC_rxi->data->data[num]=(void*)sv_dat; + SvREFCNT_inc(sv_dat); + } + ret = reganode(pRExC_state,NGROUPP,num); + goto insert_if_check_paren; + } + else if (RExC_parse[0] == 'D' && + RExC_parse[1] == 'E' && + RExC_parse[2] == 'F' && + RExC_parse[3] == 'I' && + RExC_parse[4] == 'N' && + RExC_parse[5] == 'E') + { + ret = reganode(pRExC_state,DEFINEP,0); + RExC_parse +=6 ; + is_define = 1; + goto insert_if_check_paren; + } + else if (RExC_parse[0] == 'R') { + RExC_parse++; + parno = 0; + if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) { + parno = atoi(RExC_parse++); + while (isDIGIT(*RExC_parse)) + RExC_parse++; + } else if (RExC_parse[0] == '&') { + SV *sv_dat; + RExC_parse++; + sv_dat = reg_scan_name(pRExC_state, + SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA); + parno = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0; + } + ret = reganode(pRExC_state,INSUBP,parno); + goto insert_if_check_paren; + } else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) { /* (?(1)...) */ char c; @@ -4456,6 +5226,7 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) RExC_parse++; ret = reganode(pRExC_state, GROUPP, parno); + insert_if_check_paren: if ((c = *nextchar(pRExC_state)) != ')') vFAIL("Switch condition not recognized"); insert_if: @@ -4469,6 +5240,8 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) if (flags&HASWIDTH) *flagp |= HASWIDTH; if (c == '|') { + if (is_define) + vFAIL("(?(DEFINE)....) does not allow branches"); lastbr = reganode(pRExC_state, IFTHEN, 0); /* Fake one for optimizer. */ regbranch(pRExC_state, &flags, 1,depth+1); REGTAIL(pRExC_state, ret, lastbr); @@ -4562,9 +5335,21 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) } } else { /* (...) */ + capturing_parens: parno = RExC_npar; RExC_npar++; + ret = reganode(pRExC_state, OPEN, parno); + if (!SIZE_ONLY ){ + if (!RExC_nestroot) + RExC_nestroot = parno; + if (RExC_seen & REG_SEEN_RECURSE) { + 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; + } + } Set_Node_Length(ret, 1); /* MJD */ Set_Node_Offset(ret, RExC_parse); /* MJD */ is_open = 1; @@ -4582,10 +5367,10 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) return(NULL); if (*RExC_parse == '|') { if (!SIZE_ONLY && RExC_extralen) { - reginsert(pRExC_state, BRANCHJ, br); + reginsert(pRExC_state, BRANCHJ, br, depth+1); } else { /* MJD */ - reginsert(pRExC_state, BRANCH, br); + reginsert(pRExC_state, BRANCH, br, depth+1); Set_Node_Length(br, paren != 0); Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start); } @@ -4630,6 +5415,14 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) break; case 1: ender = reganode(pRExC_state, CLOSE, parno); + if (!SIZE_ONLY && RExC_seen & REG_SEEN_RECURSE) { + DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log, + "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 */ break; @@ -4644,11 +5437,18 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) break; case 0: ender = reg_node(pRExC_state, END); + if (!SIZE_ONLY) { + assert(!RExC_opend); /* there can only be one! */ + RExC_opend = ender; + } break; } - REGTAIL_STUDY(pRExC_state, lastbr, ender); + REGTAIL(pRExC_state, lastbr, ender); if (have_branch && !SIZE_ONLY) { + if (depth==1) + RExC_seen |= REG_TOP_LEVEL_BRANCHES; + /* Hook the tails of the branches to the closing node. */ for (br = ret; br; br = regnext(br)) { const U8 op = PL_regkind[OP(br)]; @@ -4672,7 +5472,7 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) if (paren == '>') node = SUSPEND, flag = 0; - reginsert(pRExC_state, node,ret); + reginsert(pRExC_state, node,ret, depth+1); Set_Node_Cur_Length(ret); Set_Node_Offset(ret, parse_start + 1); ret->flags = flag; @@ -4833,7 +5633,7 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) do_curly: if ((flags&SIMPLE)) { RExC_naughty += 2 + RExC_naughty / 2; - reginsert(pRExC_state, CURLY, ret); + reginsert(pRExC_state, CURLY, ret, depth+1); Set_Node_Offset(ret, parse_start+1); /* MJD */ Set_Node_Cur_Length(ret); } @@ -4843,11 +5643,11 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) w->flags = 0; REGTAIL(pRExC_state, ret, w); if (!SIZE_ONLY && RExC_extralen) { - reginsert(pRExC_state, LONGJMP,ret); - reginsert(pRExC_state, NOTHING,ret); + reginsert(pRExC_state, LONGJMP,ret, depth+1); + reginsert(pRExC_state, NOTHING,ret, depth+1); NEXT_OFF(ret) = 3; /* Go over LONGJMP. */ } - reginsert(pRExC_state, CURLYX,ret); + reginsert(pRExC_state, CURLYX,ret, depth+1); /* MJD hk */ Set_Node_Offset(ret, parse_start+1); Set_Node_Length(ret, @@ -4904,7 +5704,7 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH); if (op == '*' && (flags&SIMPLE)) { - reginsert(pRExC_state, STAR, ret); + reginsert(pRExC_state, STAR, ret, depth+1); ret->flags = 0; RExC_naughty += 4; } @@ -4913,7 +5713,7 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) goto do_curly; } else if (op == '+' && (flags&SIMPLE)) { - reginsert(pRExC_state, PLUS, ret); + reginsert(pRExC_state, PLUS, ret, depth+1); ret->flags = 0; RExC_naughty += 3; } @@ -4933,12 +5733,27 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) origparse); } - if (*RExC_parse == '?') { + if (RExC_parse < RExC_end && *RExC_parse == '?') { nextchar(pRExC_state); - reginsert(pRExC_state, MINMOD, ret); + reginsert(pRExC_state, MINMOD, ret, depth+1); REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE); } - if (ISMULT2(RExC_parse)) { +#ifndef REG_ALLOW_MINMOD_SUSPEND + else +#endif + if (RExC_parse < RExC_end && *RExC_parse == '+') { + regnode *ender; + nextchar(pRExC_state); + ender = reg_node(pRExC_state, SUCCEED); + REGTAIL(pRExC_state, ret, ender); + reginsert(pRExC_state, SUSPEND, ret, depth+1); + ret->flags = 0; + ender = reg_node(pRExC_state, TAIL); + REGTAIL(pRExC_state, ret, ender); + /*ret= ender;*/ + } + + if (RExC_parse < RExC_end && ISMULT2(RExC_parse)) { RExC_parse++; vFAIL("Nested quantifiers"); } @@ -4946,6 +5761,308 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) return(ret); } + +/* reg_namedseq(pRExC_state,UVp) + + This is expected to be called by a parser routine that has + recognized'\N' and needs to handle the rest. RExC_parse is + expected to point at the first char following the N at the time + of the call. + + If valuep is non-null then it is assumed that we are parsing inside + of a charclass definition and the first codepoint in the resolved + string is returned via *valuep and the routine will return NULL. + In this mode if a multichar string is returned from the charnames + handler a warning will be issued, and only the first char in the + sequence will be examined. If the string returned is zero length + then the value of *valuep is undefined and NON-NULL will + be returned to indicate failure. (This will NOT be a valid pointer + to a regnode.) + + If value is null then it is assumed that we are parsing normal text + and inserts a new EXACT node into the program containing the resolved + string and returns a pointer to the new node. If the string is + zerolength a NOTHING node is emitted. + + On success RExC_parse is set to the char following the endbrace. + Parsing failures will generate a fatal errorvia vFAIL(...) + + NOTE: We cache all results from the charnames handler locally in + the RExC_charnames hash (created on first use) to prevent a charnames + handler from playing silly-buggers and returning a short string and + then a long string for a given pattern. Since the regexp program + size is calculated during an initial parse this would result + in a buffer overrun so we cache to prevent the charname result from + changing during the course of the parse. + + */ +STATIC regnode * +S_reg_namedseq(pTHX_ RExC_state_t *pRExC_state, UV *valuep) +{ + char * name; /* start of the content of the name */ + char * endbrace; /* endbrace following the name */ + SV *sv_str = NULL; + SV *sv_name = NULL; + STRLEN len; /* this has various purposes throughout the code */ + bool cached = 0; /* if this is true then we shouldn't refcount dev sv_str */ + regnode *ret = NULL; + + if (*RExC_parse != '{') { + vFAIL("Missing braces on \\N{}"); + } + name = RExC_parse+1; + endbrace = strchr(RExC_parse, '}'); + if ( ! endbrace ) { + RExC_parse++; + vFAIL("Missing right brace on \\N{}"); + } + RExC_parse = endbrace + 1; + + + /* RExC_parse points at the beginning brace, + endbrace points at the last */ + if ( name[0]=='U' && name[1]=='+' ) { + /* its a "unicode hex" notation {U+89AB} */ + I32 fl = PERL_SCAN_ALLOW_UNDERSCORES + | PERL_SCAN_DISALLOW_PREFIX + | (SIZE_ONLY ? PERL_SCAN_SILENT_ILLDIGIT : 0); + UV cp; + len = (STRLEN)(endbrace - name - 2); + cp = grok_hex(name + 2, &len, &fl, NULL); + if ( len != (STRLEN)(endbrace - name - 2) ) { + cp = 0xFFFD; + } + if (cp > 0xff) + RExC_utf8 = 1; + if ( valuep ) { + *valuep = cp; + return NULL; + } + sv_str= Perl_newSVpvf_nocontext("%c",(int)cp); + } else { + /* fetch the charnames handler for this scope */ + HV * const table = GvHV(PL_hintgv); + SV **cvp= table ? + hv_fetchs(table, "charnames", FALSE) : + NULL; + SV *cv= cvp ? *cvp : NULL; + HE *he_str; + int count; + /* create an SV with the name as argument */ + sv_name = newSVpvn(name, endbrace - name); + + if (!table || !(PL_hints & HINT_LOCALIZE_HH)) { + vFAIL2("Constant(\\N{%s}) unknown: " + "(possibly a missing \"use charnames ...\")", + SvPVX(sv_name)); + } + if (!cvp || !SvOK(*cvp)) { /* when $^H{charnames} = undef; */ + vFAIL2("Constant(\\N{%s}): " + "$^H{charnames} is not defined",SvPVX(sv_name)); + } + + + + if (!RExC_charnames) { + /* make sure our cache is allocated */ + RExC_charnames = newHV(); + sv_2mortal((SV*)RExC_charnames); + } + /* see if we have looked this one up before */ + he_str = hv_fetch_ent( RExC_charnames, sv_name, 0, 0 ); + if ( he_str ) { + sv_str = HeVAL(he_str); + cached = 1; + } else { + dSP ; + + ENTER ; + SAVETMPS ; + PUSHMARK(SP) ; + + XPUSHs(sv_name); + + PUTBACK ; + + count= call_sv(cv, G_SCALAR); + + if (count == 1) { /* XXXX is this right? dmq */ + sv_str = POPs; + SvREFCNT_inc_simple_void(sv_str); + } + + SPAGAIN ; + PUTBACK ; + FREETMPS ; + LEAVE ; + + if ( !sv_str || !SvOK(sv_str) ) { + vFAIL2("Constant(\\N{%s}): Call to &{$^H{charnames}} " + "did not return a defined value",SvPVX(sv_name)); + } + if (hv_store_ent( RExC_charnames, sv_name, sv_str, 0)) + cached = 1; + } + } + if (valuep) { + char *p = SvPV(sv_str, len); + if (len) { + STRLEN numlen = 1; + if ( SvUTF8(sv_str) ) { + *valuep = utf8_to_uvchr((U8*)p, &numlen); + if (*valuep > 0x7F) + RExC_utf8 = 1; + /* XXXX + We have to turn on utf8 for high bit chars otherwise + we get failures with + + "ss" =~ /[\N{LATIN SMALL LETTER SHARP S}]/i + "SS" =~ /[\N{LATIN SMALL LETTER SHARP S}]/i + + This is different from what \x{} would do with the same + codepoint, where the condition is > 0xFF. + - dmq + */ + + + } else { + *valuep = (UV)*p; + /* warn if we havent used the whole string? */ + } + if (numlen 0) { + const STRLEN unilen = reguni(pRExC_state, uvc, s); + s += unilen; + len += unilen; + /* In EBCDIC the numlen + * and unilen can differ. */ + foldbuf += numlen; + if (numlen >= foldlen) + break; + } + else + break; /* "Can't happen." */ + } + } else { + const STRLEN unilen = reguni(pRExC_state, uvc, s); + if (unilen > 0) { + s += unilen; + len += unilen; + } + } + } else { + len++; + REGC(*p, s++); + } + } + if (SIZE_ONLY) { + RExC_size += STR_SZ(len); + } else { + STR_LEN(ret) = len; + RExC_emit += STR_SZ(len); + } + Set_Node_Cur_Length(ret); /* MJD */ + RExC_parse--; + nextchar(pRExC_state); + } else { + ret = reg_node(pRExC_state,NOTHING); + } + if (!cached) { + SvREFCNT_dec(sv_str); + } + if (sv_name) { + SvREFCNT_dec(sv_name); + } + return ret; + +} + + +/* + * reg_recode + * + * 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 + * + * 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 && *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; + if (encp) + *encp = NULL; + } + return uv; +} + + /* - regatom - the lowest level * @@ -4973,9 +6090,9 @@ tryagain: 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); @@ -4985,9 +6102,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); @@ -4995,7 +6112,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); @@ -5182,6 +6299,55 @@ tryagain: *flagp |= HASWIDTH|SIMPLE; } break; + case 'N': + /* Handle \N{NAME} here and not below because it can be + multicharacter. join_exact() will join them up later on. + Also this makes sure that things like /\N{BLAH}+/ and + \N{BLAH} being multi char Just Happen. dmq*/ + ++RExC_parse; + ret= reg_namedseq(pRExC_state, NULL); + break; + case 'k': /* Handle \k and \k'NAME' */ + { + 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; + } else { + char* name_start = (RExC_parse += 2); + U32 num = 0; + SV *sv_dat = reg_scan_name(pRExC_state, + SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA); + ch= (ch == '<') ? '>' : '\''; + + if (RExC_parse == name_start || *RExC_parse != ch) + vFAIL2("Sequence \\k%c... not terminated", + (ch == '>' ? '<' : ch)); + + 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_rxi->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': @@ -5192,11 +6358,20 @@ tryagain: case 'c': case '0': goto defchar; + case 'R': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': { - const I32 num = atoi(RExC_parse); - + I32 num; + bool isrel=(*RExC_parse=='R'); + if (isrel) + RExC_parse++; + num = atoi(RExC_parse); + if (isrel) { + num = RExC_npar - num; + if (num < 1) + vFAIL("Reference to nonexistent or unclosed group"); + } if (num > 9 && num >= RExC_npar) goto defchar; else { @@ -5204,8 +6379,10 @@ tryagain: while (isDIGIT(*RExC_parse)) RExC_parse++; - if (!SIZE_ONLY && num > (I32)RExC_rx->nparens) - vFAIL("Reference to nonexistent group"); + 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), @@ -5233,7 +6410,7 @@ tryagain: break; case '#': - if (RExC_flags & PMf_EXTENDED) { + if (RExC_flags & RXf_PMf_EXTENDED) { while (RExC_parse < RExC_end && *RExC_parse != '\n') RExC_parse++; if (RExC_parse < RExC_end) @@ -5264,7 +6441,7 @@ tryagain: { char * const oldp = p; - if (RExC_flags & PMf_EXTENDED) + if (RExC_flags & RXf_PMf_EXTENDED) p = regwhite(p, RExC_end); switch (*p) { case '^': @@ -5293,6 +6470,9 @@ tryagain: case 'D': case 'p': case 'P': + case 'N': + case 'R': + case 'k': --p; goto loopdone; case 'n': @@ -5343,6 +6523,8 @@ tryagain: ender = grok_hex(p, &numlen, &flags, NULL); p += numlen; } + if (PL_encoding && ender < 0x100) + goto recode_encoding; break; case 'c': p++; @@ -5362,6 +6544,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) @@ -5385,7 +6578,7 @@ tryagain: ender = *p++; break; } - if (RExC_flags & PMf_EXTENDED) + if (RExC_flags & RXf_PMf_EXTENDED) p = regwhite(p, RExC_end); if (UTF && FOLD) { /* Prime the casefolded buffer. */ @@ -5489,33 +6682,6 @@ tryagain: break; } - /* If the encoding pragma is in effect recode the text of - * any EXACT-kind nodes. */ - if (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); } @@ -5700,7 +6866,7 @@ STATIC regnode * S_regclass(pTHX_ RExC_state_t *pRExC_state, U32 depth) { dVAR; - register UV value; + register UV value = 0; register UV nextvalue; register IV prevvalue = OOB_UNICODE; register IV range = 0; @@ -5764,6 +6930,7 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, U32 depth) if (UCHARAT(RExC_parse) == ']') goto charclassloop; +parseit: while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != ']') { charclassloop: @@ -5805,6 +6972,20 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, U32 depth) case 'S': namedclass = ANYOF_NSPACE; break; case 'd': namedclass = ANYOF_DIGIT; break; case 'D': namedclass = ANYOF_NDIGIT; break; + case 'N': /* Handle \N{NAME} in class */ + { + /* We only pay attention to the first char of + multichar strings being returned. I kinda wonder + if this makes sense as it does change the behaviour + from earlier versions, OTOH that behaviour was broken + as well. */ + UV v; /* value is register so we cant & it /grrr */ + if (reg_namedseq(pRExC_state, &v)) { + goto parseit; + } + value= v; + } + break; case 'p': case 'P': { @@ -5871,6 +7052,8 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, U32 depth) 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++); @@ -5878,13 +7061,24 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, U32 depth) 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, @@ -6518,7 +7712,7 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, U32 depth) 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; @@ -6540,7 +7734,7 @@ 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; @@ -6571,6 +7765,11 @@ S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op) RExC_size += 1; return(ret); } +#ifdef DEBUGGING + if (OP(RExC_emit) == 255) + Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %s: %d ", + reg_name[op], OP(RExC_emit)); +#endif NODE_ALIGN_FILL(ret); ptr = ret; FILL_ADVANCE_NODE(ptr, op); @@ -6587,7 +7786,6 @@ S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op) } RExC_emit = ptr; - return(ret); } @@ -6605,9 +7803,26 @@ S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg) if (SIZE_ONLY) { SIZE_ALIGN(RExC_size); RExC_size += 2; + /* + We can't do this: + + assert(2==regarglen[op]+1); + + Anything larger than this has to allocate the extra amount. + If we changed this to be: + + RExC_size += (1 + regarglen[op]); + + then it wouldn't matter. Its not clear what side effect + might come from that so its not done so far. + -- dmq + */ return(ret); } - +#ifdef DEBUGGING + if (OP(RExC_emit) == 255) + Perl_croak(aTHX_ "panic: reganode overwriting end of allocated program space"); +#endif NODE_ALIGN_FILL(ret); ptr = ret; FILL_ADVANCE_NODE_ARG(ptr, op, arg); @@ -6625,7 +7840,6 @@ S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg) } RExC_emit = ptr; - return(ret); } @@ -6645,24 +7859,44 @@ S_reguni(pTHX_ const RExC_state_t *pRExC_state, UV uv, char* s) * Means relocating the operand. */ STATIC void -S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd) +S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth) { dVAR; register regnode *src; register regnode *dst; register regnode *place; const int offset = regarglen[(U8)op]; + const int size = NODE_STEP_REGNODE + offset; GET_RE_DEBUG_FLAGS_DECL; /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */ - + DEBUG_PARSE_FMT("inst"," - %s",reg_name[op]); if (SIZE_ONLY) { - RExC_size += NODE_STEP_REGNODE + offset; + RExC_size += size; return; } src = RExC_emit; - RExC_emit += NODE_STEP_REGNODE + offset; + RExC_emit += size; dst = RExC_emit; + if (RExC_open_parens) { + int paren; + 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); + RExC_open_parens[paren] += size; + } else { + DEBUG_PARSE_FMT("open"," - %s","ok"); + } + if ( RExC_close_parens[paren] >= opnd ) { + DEBUG_PARSE_FMT("close"," - %d",size); + RExC_close_parens[paren] += size; + } else { + DEBUG_PARSE_FMT("close"," - %s","ok"); + } + } + } + while (src > opnd) { StructCopy(--src, --dst, regnode); if (RExC_offsets) { /* MJD 20010112 */ @@ -6726,8 +7960,11 @@ S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 de SV * const mysv=sv_newmortal(); DEBUG_PARSE_MSG((scan==p ? "tail" : "")); regprop(RExC_rx, mysv, scan); - PerlIO_printf(Perl_debug_log, "~ %s (%d)\n", - SvPV_nolen_const(mysv), REG_NODE_NUM(scan)); + 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)] : "") + ); }); if (temp == NULL) break; @@ -6804,10 +8041,10 @@ S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val, SV * const mysv=sv_newmortal(); DEBUG_PARSE_MSG((scan==p ? "tsdy" : "")); regprop(RExC_rx, mysv, scan); - PerlIO_printf(Perl_debug_log, "~ %s (%s) (%d)\n", + PerlIO_printf(Perl_debug_log, "~ %s (%d) -> %s\n", SvPV_nolen_const(mysv), - reg_name[exact], - REG_NODE_NUM(scan)); + REG_NODE_NUM(scan), + reg_name[exact]); }); if (temp == NULL) break; @@ -6817,10 +8054,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)]) { @@ -6866,8 +8103,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) { @@ -6906,37 +8144,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 @@ -6954,13 +8192,16 @@ 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) >= reg_num) /* regnode.type is unsigned */ + + 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"); + Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(o), (int)REGNODE_MAX); sv_catpv(sv, reg_name[OP(o)]); /* Take off const! */ k = PL_regkind[OP(o)]; @@ -6981,22 +8222,21 @@ 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 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]); DEBUG_TRIE_COMPILE_r( Perl_sv_catpvf(aTHX_ sv, "", (UV)trie->startstate, - (IV)trie->laststate-1, + (IV)trie->statecount-1, /* -1 because of the unused 0 element */ (UV)trie->wordcount, (UV)trie->minlen, (UV)trie->maxlen, @@ -7035,9 +8275,15 @@ 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 == LOGICAL) + else if (k == GOSUB) + Perl_sv_catpvf(aTHX_ sv, "%d[%+d]", (int)ARG(o),(int)ARG2L(o)); /* Paren and offset */ + else if (k == VERB) { + if (!o->flags) + Perl_sv_catpvf(aTHX_ sv, ":%"SVf, + (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 == ANYOF) { int i, rangestart = -1; @@ -7214,11 +8460,17 @@ Perl_re_intuit_string(pTHX_ regexp *prog) return prog->check_substr ? prog->check_substr : prog->check_utf8; } +/* + pregfree - free a regexp + + See regdupe below if you change anything here. +*/ + void Perl_pregfree(pTHX_ struct regexp *r) { dVAR; - + RXi_GET_DECL(r,ri); GET_RE_DEBUG_FLAGS_DECL; if (!r || (--r->refcnt > 0)) @@ -7226,9 +8478,9 @@ Perl_pregfree(pTHX_ struct regexp *r) 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); @@ -7238,7 +8490,7 @@ Perl_pregfree(pTHX_ struct regexp *r) /* 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 */ + Safefree(ri->offsets); /* 20010421 MJD */ RX_MATCH_COPY_FREE(r); #ifdef PERL_OLD_COPY_ON_WRITE if (r->saved_copy) @@ -7255,23 +8507,27 @@ Perl_pregfree(pTHX_ struct regexp *r) SvREFCNT_dec(r->float_utf8); Safefree(r->substrs); } - if (r->data) { - int n = r->data->count; + if (r->paren_names) + SvREFCNT_dec(r->paren_names); + 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': - SvREFCNT_dec((SV*)r->data->data[n]); + case 'S': + 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) @@ -7281,10 +8537,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); @@ -7296,17 +8552,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; @@ -7314,48 +8569,306 @@ 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); + if (ri->swap) { + Safefree(ri->swap->startp); + Safefree(ri->swap->endp); + Safefree(ri->swap); + } + Safefree(ri); Safefree(r); } +#define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t)) +#define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t)) +#define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t)) +#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) + + See pregfree() above if you change anything here. +*/ +#if defined(USE_ITHREADS) +regexp * +Perl_regdupe(pTHX_ const regexp *r, CLONE_PARAMS *param) +{ + dVAR; + regexp *ret; + regexp_internal *reti; + int i, len, npar; + struct reg_substr_datum *s; + RXi_GET_DECL(r,ri); + + if (!r) + return (REGEXP *)NULL; + + if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r))) + return ret; + + len = ri->offsets[0]; + npar = r->nparens+1; + + Newxz(ret, 1, regexp); + Newxc(reti, sizeof(regexp_internal) + (len+1)*sizeof(regnode), char, regexp_internal); + RXi_SET(ret,reti); + Copy(ri->program, reti->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); + if(ri->swap) { + Newx(reti->swap, 1, regexp_paren_ofs); + /* no need to copy these */ + Newx(reti->swap->startp, npar, I32); + Newx(reti->swap->endp, npar, I32); + } else { + reti->swap = NULL; + } + + 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); + } + + reti->regstclass = NULL; + if (ri->data) { + struct reg_data *d; + const int count = ri->data->count; + int i; + + Newxc(d, sizeof(struct reg_data) + count*sizeof(void *), + char, struct reg_data); + Newx(d->what, count, U8); + + d->count = count; + for (i = 0; i < count; i++) { + d->what[i] = ri->data->what[i]; + switch (d->what[i]) { + /* legal options are one of: sSfpontTu + see also regcomp.h and pregfree() */ + case 's': + case 'S': + 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(ri->data->data[i], d->data[i], + struct regnode_charclass_class); + reti->regstclass = (regnode*)d->data[i]; + break; + case 'o': + /* Compiled op trees are readonly and in shared memory, + and can thus be shared without duplication. */ + OP_REFCNT_LOCK; + d->data[i] = (void*)OpREFCNT_inc((OP*)ri->data->data[i]); + OP_REFCNT_UNLOCK; + break; + case 'T': + /* 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. + */ + 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'", ri->data->what[i]); + } + } + + reti->data = d; + } + else + reti->data = NULL; + + Newx(reti->offsets, 2*len+1, U32); + Copy(ri->offsets, reti->offsets, 2*len+1, U32); + + ret->precomp = SAVEPVN(r->precomp, r->prelen); + ret->refcnt = r->refcnt; + ret->minlen = r->minlen; + ret->minlenret = r->minlenret; + ret->prelen = r->prelen; + ret->nparens = r->nparens; + ret->lastparen = r->lastparen; + ret->lastcloseparen = r->lastcloseparen; + ret->intflags = r->intflags; + ret->extflags = r->extflags; + + ret->sublen = r->sublen; + + ret->engine = r->engine; + + ret->paren_names = hv_dup_inc(r->paren_names, param); + + 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 + + ptr_table_store(PL_ptr_table, r, ret); + return ret; +} +#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. + + 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,0,0); + + And internally with + + CALLREG_AS_STR(mg,lp,flags,haseval) + + See sv_2pv_flags() in sv.c for an example of internal usage. + + */ + +char * +Perl_reg_stringify(pTHX_ MAGIC *mg, STRLEN *lp, U32 *flags, I32 *haseval ) { + dVAR; + const regexp * const re = (regexp *)mg->mg_obj; + RXi_GET_DECL(re,ri); + + if (!mg->mg_ptr) { + const char *fptr = "msix"; + char reflags[6]; + char ch; + int left = 0; + int right = 4; + bool need_newline = 0; + U16 reganch = (U16)((re->extflags & RXf_PMf_COMPILETIME) >> 12); + + while((ch = *fptr++)) { + if(reganch & 1) { + reflags[left++] = ch; + } + else { + reflags[right--] = ch; + } + reganch >>= 1; + } + if(left != 4) { + reflags[left] = '-'; + left = 5; + } + + mg->mg_len = re->prelen + 4 + left; + /* + * If /x was used, we have to worry about a regex ending with a + * comment later being embedded within another regex. If so, we don't + * want this regex's "commentization" to leak out to the right part of + * the enclosing regex, we must cap it with a newline. + * + * So, if /x was used, we scan backwards from the end of the regex. If + * we find a '#' before we find a newline, we need to add a newline + * ourself. If we find a '\n' first (or if we don't find '#' or '\n'), + * we don't need to add anything. -jfriedl + */ + if (PMf_EXTENDED & re->extflags) { + const char *endptr = re->precomp + re->prelen; + while (endptr >= re->precomp) { + const char c = *(endptr--); + if (c == '\n') + break; /* don't need another */ + if (c == '#') { + /* we end while in a comment, so we need a newline */ + mg->mg_len++; /* save space for it */ + need_newline = 1; /* note to add it */ + break; + } + } + } + + Newx(mg->mg_ptr, mg->mg_len + 1 + left, char); + mg->mg_ptr[0] = '('; + mg->mg_ptr[1] = '?'; + Copy(reflags, mg->mg_ptr+2, left, char); + *(mg->mg_ptr+left+2) = ':'; + Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char); + if (need_newline) + mg->mg_ptr[mg->mg_len - 2] = '\n'; + mg->mg_ptr[mg->mg_len - 1] = ')'; + mg->mg_ptr[mg->mg_len] = 0; + } + if (haseval) + *haseval = ri->program[0].next_off; + if (flags) + *flags = ((re->extflags & RXf_UTF8) ? 1 : 0); + + if (lp) + *lp = mg->mg_len; + return mg->mg_ptr; +} + + #ifndef PERL_IN_XSUB_RE /* - regnext - dig the "next" pointer out of a node @@ -7366,7 +8879,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)); @@ -7487,7 +9000,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 @@ -7502,6 +9015,7 @@ 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 @@ -7517,7 +9031,7 @@ S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node, NODE_ALIGN(node); op = OP(node); - if (op == CLOSE) + if (op == CLOSE || op == WHILEM) indent--; next = regnext((regnode *)node); @@ -7563,19 +9077,22 @@ S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node, DUMPUNTIL(NEXTOPER(node), next); } else if ( PL_regkind[(U8)op] == TRIE ) { + const regnode *this_trie = node; const char op = OP(node); const I32 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)), "", @@ -7583,18 +9100,19 @@ S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node, PL_colors[0], PL_colors[1], (SvUTF8(*elem_ptr) ? PERL_PV_ESCAPE_UNI : 0) | PERL_PV_PRETTY_ELIPSES | - PERL_PV_PRETTY_LTGT + PERL_PV_PRETTY_LTGT ) : "???" ); if (trie->jump) { U16 dist= trie->jump[word_idx+1]; - PerlIO_printf(Perl_debug_log, "(%u)\n",(next - dist) - start); + PerlIO_printf(Perl_debug_log, "(%"UVuf")\n", + (UV)((dist ? this_trie + dist : next) - start)); if (dist) { if (!nextbranch) - nextbranch= next - trie->jump[0]; - DUMPUNTIL(next - dist, nextbranch); - } + nextbranch= this_trie + trie->jump[0]; + DUMPUNTIL(this_trie + dist, nextbranch); + } if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH) nextbranch= regnext((regnode *)nextbranch); } else { @@ -7634,12 +9152,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; }