Re: [PATCH] Tweaks so that miniperl.exe doesnt croak while building perl.exe

Message-ID: <9b18b3110703080120s41147a4fh4f4c1f9817079be3@mail.gmail.com>

p4raw-id: //depot/perl@30518

diff --git a/gv.c b/gv.c
index da1d3a6..6c664db 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -1190,47 +1190,32 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
            goto magicalize;
 
        case '!':
-       GvMULTI_on(gv);    
+           GvMULTI_on(gv);
            /* If %! has been used, automatically load Errno.pm. */
 
            sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
 
             /* magicalization must be done before require_tie_mod is called */
-           if (sv_type == SVt_PVHV)
+           if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
                require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
-            /* NOTE: Errno.pm does the tieing of %! itself when it is executed. 
-               This is different to the way %+ and %- are handled. */
 
            break;
        case '-':
        case '+':
        GvMULTI_on(gv); /* no used once warnings here */
         {
-            bool plus = (*name == '+');
-            SV *stashname = newSVpvs("Tie::Hash::NamedCapture");
             AV* const av = GvAVn(gv);
-           HV *const hv = GvHVn(gv);
-           HV *const hv_tie = newHV();
-            SV *tie = newRV_noinc((SV*)hv_tie);
+           SV* const avc = (*name == '+') ? (SV*)av : NULL;
 
-           sv_bless(tie, gv_stashsv(stashname, GV_ADD));
-           hv_magic(hv, (GV*)tie, PERL_MAGIC_tied);
-            sv_magic((SV*)av, (plus ? (SV*)av : NULL), PERL_MAGIC_regdata, NULL, 0);
+           sv_magic((SV*)av, avc, PERL_MAGIC_regdata, NULL, 0);
             sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
-        
-            /* NOTE: Tie::Hash::NamedCapture does NOT do the tie of %- or %+ itself. 
-               This is different to the way %! is handled. */
-            if (plus)
+            if (avc)
                 SvREADONLY_on(GvSVn(gv));
-            else
-                Perl_hv_store(aTHX_ hv_tie, STR_WITH_LEN("all"), newSViv(1), 0);
-
-            SvREADONLY_on(hv);
-            SvREADONLY_on(tie);
             SvREADONLY_on(av);
-            
-            require_tie_mod(gv, name, stashname, "FETCH", 0);
-           
+
+            if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
+                require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "FETCH", 0);
+
             break;
        }
        case '*':

diff --git a/lib/Tie/Hash/NamedCapture.pm b/lib/Tie/Hash/NamedCapture.pm
index 950adca..3383f16 100644 (file)
--- a/lib/Tie/Hash/NamedCapture.pm
+++ b/lib/Tie/Hash/NamedCapture.pm
@@ -3,17 +3,23 @@ package Tie::Hash::NamedCapture;
 use strict;
 use warnings;
 
-our $VERSION = "0.03";
+our $VERSION = "0.04";
 
 sub TIEHASH {
     my $classname = shift;
-    my $hash = {@_};
+    my %opts = @_;
 
-    if ($hash->{re} && !re::is_regexp($hash->{re})) {
-        die "'re' parameter to ",__PACKAGE__,"->TIEHASH must be a qr//"
+    if ($opts{re} && !re::is_regexp($opts{re})) {
+       require Carp;
+       Carp::croak("'re' parameter to " . __PACKAGE__
+           . "->TIEHASH must be a qr//.");
     }
 
-    return bless $hash, $classname;
+    my $self = bless {
+       all => $opts{all},
+       re  => $opts{re},
+    }, $classname;
+    return $self;
 }
 
 sub FETCH {
@@ -52,6 +58,9 @@ sub SCALAR {
     return scalar re::regnames($_[0]->{re},$_[0]->{all});
 }
 
+tie %+, __PACKAGE__;
+tie %-, __PACKAGE__, all => 1;
+
 1;
 
 __END__

diff --git a/t/op/regexp_namedcapture.t b/t/op/regexp_namedcapture.t
index d2db2d7..b9315cc 100644 (file)
--- a/t/op/regexp_namedcapture.t
+++ b/t/op/regexp_namedcapture.t
@@ -1,13 +1,20 @@
 #!./perl
-#
-# Tests to make sure the regexp engine doesn't run into limits too soon.
-#
 
 BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
 }
 
-print "1..1\n";
+# WARNING: Do not use anymodules as part of this test code.
+# We could get action at a distance that would invalidate the tests.
+
+print "1..2\n";
+
+# This tests whether glob assignment fails to load the tie.
 *X = *-;
-print eval '*X{HASH}{X} || 1' ? "ok\n" :"not ok\n";
+'X'=~/(?<X>X)/;
+print eval '*X{HASH}{X} || 1' ? "" :"not ","ok ",++$test,"\n";
+
+# And since its a similar case we check %! as well
+*Y = *!;
+print 0<keys(%Y) ? "" :"not ","ok ",++$test,"\n";