From: Andreas König Date: Sun, 19 Nov 2006 05:41:53 +0000 (+0100) Subject: Patch by Yves Orton to fix the regression reported in : X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=de734bd5c0f518849c823cf9035c5583d1cd8d67;p=p5sagit%2Fp5-mst-13.2.git Patch by Yves Orton to fix the regression reported in : Subject: 28325/6 break DateTime::Format::Strptime Message-ID: <877ixs6oa6.fsf@k75.linux.bogus> p4raw-id: //depot/perl@29324 --- diff --git a/ext/re/t/lexical_debug.pl b/ext/re/t/lexical_debug.pl index 6cdfa49..3ec7455 100644 --- a/ext/re/t/lexical_debug.pl +++ b/ext/re/t/lexical_debug.pl @@ -21,7 +21,7 @@ no re 'debug'; /fop/ and $count++; use re 'debug'; -my $var='zoo|zil|zap'; +my $var='zoo|liz|zap'; /($var)/ or $count++; print "Count=$count\n"; diff --git a/ext/re/t/lexical_debug.t b/ext/re/t/lexical_debug.t index b6a3dcb..3c3f7ba 100644 --- a/ext/re/t/lexical_debug.t +++ b/ext/re/t/lexical_debug.t @@ -29,7 +29,7 @@ ok( $out =~ /EXACT /, "Expect 'baz'" ); ok( $out !~ /EXACT /, "No 'bop'" ); ok( $out =~ /EXACT /, "Expect 'fip'" ); ok( $out !~ /EXACT /, "No 'baz'" ); -ok( $out =~ //, "Got 'zil'" ); # in a TRIE so no EXACT +ok( $out =~ //, "Got 'liz'" ); # in a TRIE so no EXACT ok( $out =~ //, "Got 'zoo'" ); # in a TRIE so no EXACT ok( $out =~ //, "Got 'zap'" ); # in a TRIE so no EXACT ok( $out =~ /Count=7\n/, "Count is 7") diff --git a/ext/re/t/regop.t b/ext/re/t/regop.t index f586d22..3fa7669 100644 --- a/ext/re/t/regop.t +++ b/ext/re/t/regop.t @@ -155,12 +155,12 @@ minlen 3 # Final program: # 1: EXACT (3) # 3: TRIEC-EXACT[A-EGP](20) -# -# -# -# -# -# +#

+# +# +# +# +# # 20: END(0) # anchored "ABC" at 0 (checking anchored) minlen 4 # Offsets: [20] @@ -174,7 +174,7 @@ minlen 3 # 3 | State: 4 Accepted: 0 Charid: 7 CP: 44 After State: a # 4 <> | State: a Accepted: 1 Charid: 6 CP: 0 After State: 0 # got 1 possible matches -# only one match left: #6 +# only one match left: #6 # 4 <> | 20:END(0) # Match successful! # %MATCHED% @@ -183,7 +183,7 @@ minlen 3 EXACT TRIEC-EXACT [A-EGP] -only one match left: #6 +only one match left: #6 S:4/10 W:6 L:1/1 diff --git a/pp.sym b/pp.sym index 146ef4a..e2bff2c 100644 --- a/pp.sym +++ b/pp.sym @@ -286,23 +286,23 @@ Perl_pp_fteread Perl_pp_ftewrite Perl_pp_fteexec Perl_pp_ftis -Perl_pp_fteowned -Perl_pp_ftrowned -Perl_pp_ftzero Perl_pp_ftsize Perl_pp_ftmtime Perl_pp_ftatime Perl_pp_ftctime +Perl_pp_ftrowned +Perl_pp_fteowned +Perl_pp_ftzero Perl_pp_ftsock Perl_pp_ftchr Perl_pp_ftblk Perl_pp_ftfile Perl_pp_ftdir Perl_pp_ftpipe -Perl_pp_ftlink Perl_pp_ftsuid Perl_pp_ftsgid Perl_pp_ftsvtx +Perl_pp_ftlink Perl_pp_fttty Perl_pp_fttext Perl_pp_ftbinary @@ -349,9 +349,9 @@ Perl_pp_msgget Perl_pp_msgctl Perl_pp_msgsnd Perl_pp_msgrcv +Perl_pp_semop Perl_pp_semget Perl_pp_semctl -Perl_pp_semop Perl_pp_require Perl_pp_dofile Perl_pp_entereval diff --git a/pp_proto.h b/pp_proto.h index 08e9ad7..f6cfb74 100644 --- a/pp_proto.h +++ b/pp_proto.h @@ -287,23 +287,23 @@ PERL_PPDEF(Perl_pp_fteread) PERL_PPDEF(Perl_pp_ftewrite) PERL_PPDEF(Perl_pp_fteexec) PERL_PPDEF(Perl_pp_ftis) -PERL_PPDEF(Perl_pp_fteowned) -PERL_PPDEF(Perl_pp_ftrowned) -PERL_PPDEF(Perl_pp_ftzero) PERL_PPDEF(Perl_pp_ftsize) PERL_PPDEF(Perl_pp_ftmtime) PERL_PPDEF(Perl_pp_ftatime) PERL_PPDEF(Perl_pp_ftctime) +PERL_PPDEF(Perl_pp_ftrowned) +PERL_PPDEF(Perl_pp_fteowned) +PERL_PPDEF(Perl_pp_ftzero) PERL_PPDEF(Perl_pp_ftsock) PERL_PPDEF(Perl_pp_ftchr) PERL_PPDEF(Perl_pp_ftblk) PERL_PPDEF(Perl_pp_ftfile) PERL_PPDEF(Perl_pp_ftdir) PERL_PPDEF(Perl_pp_ftpipe) -PERL_PPDEF(Perl_pp_ftlink) PERL_PPDEF(Perl_pp_ftsuid) PERL_PPDEF(Perl_pp_ftsgid) PERL_PPDEF(Perl_pp_ftsvtx) +PERL_PPDEF(Perl_pp_ftlink) PERL_PPDEF(Perl_pp_fttty) PERL_PPDEF(Perl_pp_fttext) PERL_PPDEF(Perl_pp_ftbinary) @@ -350,9 +350,9 @@ PERL_PPDEF(Perl_pp_msgget) PERL_PPDEF(Perl_pp_msgctl) PERL_PPDEF(Perl_pp_msgsnd) PERL_PPDEF(Perl_pp_msgrcv) +PERL_PPDEF(Perl_pp_semop) PERL_PPDEF(Perl_pp_semget) PERL_PPDEF(Perl_pp_semctl) -PERL_PPDEF(Perl_pp_semop) PERL_PPDEF(Perl_pp_require) PERL_PPDEF(Perl_pp_dofile) PERL_PPDEF(Perl_pp_entereval) diff --git a/regcomp.c b/regcomp.c index 409ed24..15f1feb 100644 --- a/regcomp.c +++ b/regcomp.c @@ -1894,21 +1894,30 @@ 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( + 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) @@ -1925,11 +1934,21 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs trie->maxlen -= (state - 1); DEBUG_r({ regnode *fix = convert; + U32 word = trie->wordcount; mjd_nodelen++; Set_Node_Offset_Length(convert, mjd_offset, state - 1); while( ++fix < n ) { Set_Node_Offset_Length(fix, 0, 0); } + while (word--) { + SV ** const tmp = av_fetch( trie->words, word, 0 ); + if (tmp) { + if ( STR_LEN(convert) <= SvCUR(*tmp) ) + sv_chop(*tmp, SvPV_nolen(*tmp) + STR_LEN(convert)); + else + sv_chop(*tmp, SvPV_nolen(*tmp) + SvCUR(*tmp)); + } + } }); if (trie->maxlen) { convert = n; @@ -8983,7 +9002,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); @@ -9102,8 +9121,6 @@ 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 diff --git a/regexec.c b/regexec.c index 8abe220..e505fb4 100644 --- a/regexec.c +++ b/regexec.c @@ -2935,11 +2935,17 @@ S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog) = (reg_trie_data*)rex->data->data[ ARG(ST.me) ]; SV ** const tmp = av_fetch( trie->words, ST.accept_buff[ 0 ].wordnum-1, 0 ); + SV *sv= tmp ? sv_newmortal() : NULL; + PerlIO_printf( Perl_debug_log, "%*s %sonly one match left: #%d <%s>%s\n", REPORT_CODE_OFF+depth*2, "", PL_colors[4], ST.accept_buff[ 0 ].wordnum, - tmp ? SvPV_nolen_const( *tmp ) : "not compiled under -Dr", + tmp ? pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 0, + PL_colors[0], PL_colors[1], + (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) + ) + : "not compiled under -Dr", PL_colors[5] ); }); PL_reginput = (char *)ST.accept_buff[ 0 ].endpos; @@ -3013,11 +3019,16 @@ S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog) regnode *nextop=(!ST.jump || !ST.jump[ST.accept_buff[best].wordnum]) ? ST.B : ST.me + ST.jump[ST.accept_buff[best].wordnum]; + SV *sv= tmp ? sv_newmortal() : NULL; + PerlIO_printf( Perl_debug_log, "%*s %strying alternation #%d <%s> at node #%d %s\n", REPORT_CODE_OFF+depth*2, "", PL_colors[4], ST.accept_buff[best].wordnum, - tmp ? SvPV_nolen_const( *tmp ) : "not compiled under -Dr", + tmp ? pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 0, + PL_colors[0], PL_colors[1], + (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) + ) : "not compiled under -Dr", REG_NODE_NUM(nextop), PL_colors[5] ); }); diff --git a/t/op/pat.t b/t/op/pat.t index e206af7..774acf7 100755 --- a/t/op/pat.t +++ b/t/op/pat.t @@ -12,7 +12,7 @@ BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } -our $Message = "Line"; +our $Message = "Noname test"; eval 'use Config'; # Defaults assumed if this fails @@ -875,9 +875,7 @@ $foo='aabbccddeeffgg'; pos($foo)=1; $foo=~/.\G(..)/g; -print "not " unless($1 eq 'ab'); -print "ok $test\n"; -$test++; +iseq($1,'ab'); pos($foo) += 1; $foo=~/.\G(..)/g; @@ -1048,9 +1046,7 @@ $test++; @b = grep(/\w/,@a); @c = grep(/[\w]/,@a); -print "not " if "@b" ne "@c"; -print "ok $test\n"; -$test++; +iseq("@b","@c"); # see if backtracking optimization works correctly "\n\n" =~ /\n $ \n/x or print "not "; @@ -2039,7 +2035,7 @@ sub ok ($;$) { my($ok, $name) = @_; printf "%sok %d - %s\n", ($ok ? "" : "not "), $test, - $name||"$Message:".((caller)[2]); + ($name||$Message)."\tLine ".((caller)[2]); printf "# Failed test at line %d\n", (caller)[2] unless $ok; @@ -3676,7 +3672,7 @@ sub iseq($$;$) { my $ok= $got eq $expect; printf "%sok %d - %s\n", ($ok ? "" : "not "), $test, - $name||"$Message:".((caller)[2]); + ($name||$Message)."\tLine ".((caller)[2]); printf "# Failed test at line %d\n". "# expected: %s\n". @@ -4088,6 +4084,16 @@ for my $c ("z", "\0", "!", chr(254), chr(256)) { iseq($text,' word2 word4 word6 '); } +{ + # From Message-ID: <877ixs6oa6.fsf@k75.linux.bogus> + my $dow_name= "nada"; + my $parser = "(\$dow_name) = \$time_string =~ /(D\x{e9}\\ C\x{e9}adaoin|D\x{e9}\\ Sathairn|\\w+|\x{100})/"; + my $time_string = "D\x{e9} C\x{e9}adaoin"; + eval $parser; + ok(!$@,"Test Eval worked"); + iseq($dow_name,$time_string,"UTF8 trie common prefix extraction"); +} + # Test counter is at bottom of file. Put new tests above here. #------------------------------------------------------------------- # Keep the following tests last -- they may crash perl @@ -4133,4 +4139,12 @@ ok((q(a)x 100) =~ /^(??{'(.)'x 100})/, # Put new tests above the dotted line about a page above this comment # Don't forget to update this! -BEGIN { print "1..1365\n" }; +BEGIN { + $::TestCount = 1367; + print "1..$::TestCount\n"; +} +END { + if ($::TestCount != $::count) { + warn "#\n### Got $::count test reports, but expected $::TestCount\n#\n"; + } +}