develooper Front page | perl.perl5.porters | Postings from March 2003

Some bugs/fixes.

From:
Enache Adrian
Date:
March 15, 2003 14:06
Subject:
Some bugs/fixes.
Message ID:
20030315220847.GA20241@ratsnest.hole
I already sent them in different threads, but I got no answer.
Should I open a ticket for each of them ?

Below is an updated patch that fixes them all, anyway.

I don't know where a test for 1) (as for [perl #21347] too) should go.

1. warn in UNIVERSAL::DESTROY method segfaults

$ perl -e 'sub UNIVERSAL::DESTROY { warn "w\n" } ; bless \$a, ITCH'
(segfaults in 5.6.1, 5.8.0 and bleadperl)
http://nntp.perl.org/group/perl.perl5.porters/72848

2. regexp caching and '(?{ ... })' constructs.

$ perl -e 'split /(?{ split "" })/,"abc"'
(segfaults in 5.6.1, 5.8.0 and bleadperl)

3. better fix for [perl #21411]

$ perl -e 'split /(?{"FOO"})/,"abcde";print @_'
(prints 'FOObcde' in 5.8.0 & 5.6.1, and still does something
 naughty in blead)

http://nntp.perl.org/group/perl.perl5.porters/72788

Regards
Adi

----------------------------------------------------------------
diff -rup /arc/perl-current/pp.c perl-current/pp.c
--- /arc/perl-current/pp.c	2003-03-07 08:35:43.000000000 +0200
+++ perl-current/pp.c	2003-03-15 22:14:49.000000000 +0200
@@ -4647,13 +4647,13 @@ PP(pp_split)
     }
     else {
 	maxiters += slen * rx->nparens;
-	while (s < strend && --limit
-/*	       && (!rx->check_substr
-		   || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
-						 0, NULL))))
-*/	       && CALLREGEXEC(aTHX_ rx, s, strend, orig,
-			      1 /* minend */, sv, NULL, 0))
+	while (s < strend && --limit)
 	{
+	    PUTBACK;
+	    i = CALLREGEXEC(aTHX_ rx, s, strend, orig, 1 , sv, NULL, 0);
+	    SPAGAIN;
+	    if (i == 0)
+		break;
 	    TAINT_IF(RX_MATCH_TAINTED(rx));
 	    if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
 		m = s;
@@ -4692,7 +4692,6 @@ PP(pp_split)
 		}
 	    }
 	    s = rx->endp[0] + orig;
-	    PUTBACK;
 	}
     }
 
diff -rup /arc/perl-current/regexec.c perl-current/regexec.c
--- /arc/perl-current/regexec.c	2003-03-09 14:07:31.000000000 +0200
+++ perl-current/regexec.c	2003-03-15 22:10:59.000000000 +0200
@@ -2834,6 +2834,7 @@ S_regmatch(pTHX_ regnode *prog)
 	    COP *ocurcop = PL_curcop;
 	    PAD *old_comppad;
 	    SV *ret;
+	    struct regexp *oreg = PL_reg_re;
 	
 	    n = ARG(scan);
 	    PL_op = (OP_4tree*)PL_regdata->data[n];
@@ -2966,8 +2967,10 @@ S_regmatch(pTHX_ regnode *prog)
 		sw = SvTRUE(ret);
 		logical = 0;
 	    }
-	    else
+	    else {
 		sv_setsv(save_scalar(PL_replgv), ret);
+		cache_re(oreg);
+	    }
 	    break;
 	}
 	case OPEN:
diff -rup /arc/perl-current/t/op/pat.t perl-current/t/op/pat.t
--- /arc/perl-current/t/op/pat.t	2003-03-09 14:42:37.000000000 +0200
+++ perl-current/t/op/pat.t	2003-03-15 22:59:28.000000000 +0200
@@ -6,7 +6,7 @@
 
 $| = 1;
 
-print "1..996\n";
+print "1..998\n";
 
 BEGIN {
     chdir 't' if -d 't';
@@ -3142,7 +3142,10 @@ ok("bbbbac" =~ /$pattern/ && $1 eq 'a', 
 {
     my $i;
     ok('-1-3-5-' eq join('', split /((??{$i++}))/, '-1-3-5-'),
-	"[perl #21411] (??{ .. }) corrupts split's stack")
+	"[perl #21411] (??{ .. }) corrupts split's stack");
+    split /(?{'WOW'})/, 'abc';
+    ok('a|b|c' eq join ('|', @_),
+       "[perl #21411] (?{ .. }) version of the above");
 }
 
 {
@@ -3159,4 +3162,9 @@ ok("bbbbac" =~ /$pattern/ && $1 eq 'a', 
     ok(join(":", /\b(.)\x{100}/g) eq "a:/", "re_intuit_start and PL_bostr");
 }
 
-# last test 996
+{
+    split /(?{ split "" })/, "abc";
+    ok(1,'cache_re & "(?{": it dumps core in 5.6.1 & 5.8.0');
+}
+
+# last test 998
diff -rup /arc/perl-current/util.c perl-current/util.c
--- /arc/perl-current/util.c	2003-03-09 13:57:26.000000000 +0200
+++ perl-current/util.c	2003-03-15 22:08:47.000000000 +0200
@@ -1246,7 +1246,7 @@ Perl_vwarn(pTHX_ const char* pat, va_lis
     }
 
     /* if STDERR is tied, use it instead */
-    if (PL_stderrgv && (io = GvIOp(PL_stderrgv))
+    if (PL_stderrgv && SvREFCNT(PL_stderrgv) && (io = GvIOp(PL_stderrgv))
 	&& (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
 	dSP; ENTER;
 	PUSHMARK(SP);



nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About