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 (file)
--- 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 (file)
--- a/ext/re/t/lexical_debug.t
+++ b/ext/re/t/lexical_debug.t
@@ -29,7 +29,7 @@ ok( $out =~ /EXACT <baz>/, "Expect 'baz'"    );
 ok( $out !~ /EXACT <bop>/, "No 'bop'"        );
 ok( $out =~ /EXACT <fip>/, "Expect 'fip'"    );
 ok( $out !~ /EXACT <fop>/, "No 'baz'"        );
-ok( $out =~ /<zil>/,       "Got 'zil'"       ); # in a TRIE so no EXACT
+ok( $out =~ /<liz>/,       "Got 'liz'"       ); # in a TRIE so no EXACT
 ok( $out =~ /<zoo>/,       "Got 'zoo'"       ); # in a TRIE so no EXACT
 ok( $out =~ /<zap>/,       "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 (file)
--- a/ext/re/t/regop.t
+++ b/ext/re/t/regop.t
@@ -155,12 +155,12 @@ minlen 3
 # Final program:
 #    1: EXACT <ABC>(3)
 #    3: TRIEC-EXACT<S:4/10 W:6 L:1/1 C:24/7>[A-EGP](20)
-#       <ABCP> 
-#       <ABCG> 
-#       <ABCE> 
-#       <ABCB> 
-#       <ABCA> 
-#       <ABCD> 
+#       <P> 
+#       <G> 
+#       <E> 
+#       <B> 
+#       <A> 
+#       <D> 
 #   20: END(0)
 # anchored "ABC" at 0 (checking anchored) minlen 4 
 # Offsets: [20]
@@ -174,7 +174,7 @@ minlen 3
 #    3 <ABC> <D>               |    State:    4 Accepted:    0 Charid:  7 CP:  44 After State:    a
 #    4 <ABCD> <>               |    State:    a Accepted:    1 Charid:  6 CP:   0 After State:    0
 #                                   got 1 possible matches
-#                                   only one match left: #6 <ABCD>
+#                                   only one match left: #6 <D>
 #    4 <ABCD> <>               | 20:END(0)
 # Match successful!
 # %MATCHED%
@@ -183,7 +183,7 @@ minlen 3
 EXACT <ABC>
 TRIEC-EXACT
 [A-EGP]
-only one match left: #6 <ABCD>
+only one match left: #6 <D>
 S:4/10
 W:6
 L:1/1

diff --git a/pp.sym b/pp.sym
index 146ef4a..e2bff2c 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (executable)
--- 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";
+    }
+}