develooper Front page | perl.perl5.porters | Postings from June 2000

Re: [ID 20000330.005] defined ${$n} broken in 5.6 when $n is a number

Thread Previous | Thread Next
From:
Gurusamy Sarathy
Date:
June 29, 2000 19:40
Subject:
Re: [ID 20000330.005] defined ${$n} broken in 5.6 when $n is a number
Message ID:
200006300239.TAA23829@molotok.activestate.com
On Thu, 30 Mar 2000 10:28:26 +0100, Graham Barr wrote:
>The following snippet shows the problem, with 5.005_03 it outputs
>
> a 3
> b 2
> c 1
>
>but with 5.6 it outputs the first 'a' and then loops forever.
>
>$str = "abc";
>$|=1;
>while($str =~ /(c)|(b)|(a)/g) {
>  my $paren = 1;
>  print "$+ ";
>  $paren++ until defined ${$paren};
>  print "$paren\n";
>}
>
>I know that in 5.6 I could use @- to do this, but I have this
>structure in code that is already in use and needs to continue
>to work with older versions of perl

Simon Cozens worked with me to fix this problem.  Thanks Simon!


Sarathy
gsar@ActiveState.com
-----------------------------------8<-----------------------------------
Change 6126 by gsar@auger on 2000/05/28 06:39:53

	change#2879 broke rvalue autovivification of magicals such as ${$num}
	(reworked variant of patch suggested by Simon Cozens)

Affected files ...

... //depot/perl/embed.h#173 edit
... //depot/perl/embed.pl#129 edit
... //depot/perl/gv.c#99 edit
... //depot/perl/pod/perlapi.pod#11 edit
... //depot/perl/pod/perlintern.pod#4 edit
... //depot/perl/pp.c#192 edit
... //depot/perl/pp_hot.c#170 edit
... //depot/perl/proto.h#207 edit
... //depot/perl/t/op/gv.t#13 edit

Differences ...

==== //depot/perl/embed.h#173 (text+w) ====
Index: perl/embed.h
--- perl/embed.h.~1~	Sat May 27 23:40:36 2000
+++ perl/embed.h	Sat May 27 23:40:36 2000
@@ -269,6 +269,7 @@
 #define instr			Perl_instr
 #define io_close		Perl_io_close
 #define invert			Perl_invert
+#define is_gv_magical		Perl_is_gv_magical
 #define is_uni_alnum		Perl_is_uni_alnum
 #define is_uni_alnumc		Perl_is_uni_alnumc
 #define is_uni_idfirst		Perl_is_uni_idfirst
@@ -1719,6 +1720,7 @@
 #define instr(a,b)		Perl_instr(aTHX_ a,b)
 #define io_close(a,b)		Perl_io_close(aTHX_ a,b)
 #define invert(a)		Perl_invert(aTHX_ a)
+#define is_gv_magical(a,b,c)	Perl_is_gv_magical(aTHX_ a,b,c)
 #define is_uni_alnum(a)		Perl_is_uni_alnum(aTHX_ a)
 #define is_uni_alnumc(a)	Perl_is_uni_alnumc(aTHX_ a)
 #define is_uni_idfirst(a)	Perl_is_uni_idfirst(aTHX_ a)
@@ -3367,6 +3369,8 @@
 #define io_close		Perl_io_close
 #define Perl_invert		CPerlObj::Perl_invert
 #define invert			Perl_invert
+#define Perl_is_gv_magical	CPerlObj::Perl_is_gv_magical
+#define is_gv_magical		Perl_is_gv_magical
 #define Perl_is_uni_alnum	CPerlObj::Perl_is_uni_alnum
 #define is_uni_alnum		Perl_is_uni_alnum
 #define Perl_is_uni_alnumc	CPerlObj::Perl_is_uni_alnumc

==== //depot/perl/embed.pl#129 (xtext) ====
Index: perl/embed.pl
--- perl/embed.pl.~1~	Sat May 27 23:40:36 2000
+++ perl/embed.pl	Sat May 27 23:40:36 2000
@@ -1567,6 +1567,7 @@
 Ap	|char*	|instr		|const char* big|const char* little
 p	|bool	|io_close	|IO* io|bool not_implicit
 p	|OP*	|invert		|OP* cmd
+dp	|bool	|is_gv_magical	|char *name|STRLEN len|U32 flags
 Ap	|bool	|is_uni_alnum	|U32 c
 Ap	|bool	|is_uni_alnumc	|U32 c
 Ap	|bool	|is_uni_idfirst	|U32 c

==== //depot/perl/gv.c#99 (text) ====
Index: perl/gv.c
--- perl/gv.c.~1~	Sat May 27 23:40:36 2000
+++ perl/gv.c	Sat May 27 23:40:36 2000
@@ -1580,3 +1580,110 @@
     }
   }
 }
+
+/*
+=for apidoc is_gv_magical
+
+Returns C<TRUE> if given the name of a magical GV.
+
+Currently only useful internally when determining if a GV should be
+created even in rvalue contexts.
+
+C<flags> is not used at present but available for future extension to
+allow selecting particular classes of magical variable.
+
+=cut
+*/
+bool
+Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
+{
+    if (!len)
+	return FALSE;
+
+    switch (*name) {
+    case 'I':
+	if (len == 3 && strEQ(name, "ISA"))
+	    goto yes;
+	break;
+    case 'O':
+	if (len == 8 && strEQ(name, "OVERLOAD"))
+	    goto yes;
+	break;
+    case 'S':
+	if (len == 3 && strEQ(name, "SIG"))
+	    goto yes;
+	break;
+    case '\027':   /* $^W & $^WARNING_BITS */
+	if (len == 1
+	    || (len == 12 && strEQ(name, "\027ARNING_BITS"))
+	    || (len == 17 && strEQ(name, "\027IDE_SYSTEM_CALLS")))
+	{
+	    goto yes;
+	}
+	break;
+
+    case '&':
+    case '`':
+    case '\'':
+    case ':':
+    case '?':
+    case '!':
+    case '-':
+    case '#':
+    case '*':
+    case '[':
+    case '^':
+    case '~':
+    case '=':
+    case '%':
+    case '.':
+    case '(':
+    case ')':
+    case '<':
+    case '>':
+    case ',':
+    case '\\':
+    case '/':
+    case '|':
+    case '+':
+    case ';':
+    case ']':
+    case '\001':   /* $^A */
+    case '\003':   /* $^C */
+    case '\004':   /* $^D */
+    case '\005':   /* $^E */
+    case '\006':   /* $^F */
+    case '\010':   /* $^H */
+    case '\011':   /* $^I, NOT \t in EBCDIC */
+    case '\014':   /* $^L */
+    case '\017':   /* $^O */
+    case '\020':   /* $^P */
+    case '\023':   /* $^S */
+    case '\024':   /* $^T */
+    case '\026':   /* $^V */
+	if (len == 1)
+	    goto yes;
+	break;
+    case '1':
+    case '2':
+    case '3':
+    case '4':
+    case '5':
+    case '6':
+    case '7':
+    case '8':
+    case '9':
+	if (len > 1) {
+	    char *end = name + len;
+	    while (--end > name) {
+		if (!isDIGIT(*end))
+		    return FALSE;
+	    }
+	}
+    yes:
+	return TRUE;
+    default:
+	break;
+    }
+    return FALSE;
+}

==== //depot/perl/pod/perlapi.pod#11 (text+w) ====
Index: perl/pod/perlapi.pod
--- perl/pod/perlapi.pod.~1~	Sat May 27 23:40:36 2000
+++ perl/pod/perlapi.pod	Sat May 27 23:40:36 2000
@@ -165,9 +165,16 @@
 
 =item croak
 
-This is the XSUB-writer's interface to Perl's C<die> function.  Use this
-function the same way you use the C C<printf> function.  See
-C<warn>.
+This is the XSUB-writer's interface to Perl's C<die> function.
+Normally use this function the same way you use the C C<printf>
+function.  See C<warn>.
+
+If you want to throw an exception object, assign the object to
+C<$@> and then pass C<Nullch> to croak():
+
+   errsv = get_sv("@", TRUE);
+   sv_setsv(errsv, exception_object);
+   croak(Nullch);
 
 	void	croak(const char* pat, ...)
 
@@ -1597,17 +1604,17 @@
 
 	bool	SvTRUE(SV* sv)
 
-=item svtype
-
-An enum of flags for Perl types.  These are found in the file B<sv.h> 
-in the C<svtype> enum.  Test these flags with the C<SvTYPE> macro.
-
 =item SvTYPE
 
 Returns the type of the SV.  See C<svtype>.
 
 	svtype	SvTYPE(SV* sv)
 
+=item svtype
+
+An enum of flags for Perl types.  These are found in the file B<sv.h> 
+in the C<svtype> enum.  Test these flags with the C<SvTYPE> macro.
+
 =item SVt_IV
 
 Integer type flag for scalars.  See C<svtype>.

==== //depot/perl/pod/perlintern.pod#4 (text+w) ====
Index: perl/pod/perlintern.pod
--- perl/pod/perlintern.pod.~1~	Sat May 27 23:40:36 2000
+++ perl/pod/perlintern.pod	Sat May 27 23:40:36 2000
@@ -12,6 +12,18 @@
 
 =over 8
 
+=item is_gv_magical
+
+Returns C<TRUE> if given the name of a magical GV.
+
+Currently only useful internally when determining if a GV should be
+created even in rvalue contexts.
+
+C<flags> is not used at present but available for future extension to
+allow selecting particular classes of magical variable.
+
+	bool	is_gv_magical(char *name, STRLEN len, U32 flags)
+
 =back
 
 =head1 AUTHORS

==== //depot/perl/pp.c#192 (text) ====
Index: perl/pp.c
--- perl/pp.c.~1~	Sat May 27 23:40:36 2000
+++ perl/pp.c	Sat May 27 23:40:36 2000
@@ -198,7 +198,7 @@
     else {
 	if (SvTYPE(sv) != SVt_PVGV) {
 	    char *sym;
-	    STRLEN n_a;
+	    STRLEN len;
 
 	    if (SvGMAGICAL(sv)) {
 		mg_get(sv);
@@ -236,13 +236,17 @@
 		    report_uninit();
 		RETSETUNDEF;
 	    }
-	    sym = SvPV(sv, n_a);
+	    sym = SvPV(sv,len);
 	    if ((PL_op->op_flags & OPf_SPECIAL) &&
 		!(PL_op->op_flags & OPf_MOD))
 	    {
 		sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
-		if (!sv)
+		if (!sv
+		    && (!is_gv_magical(sym,len,0)
+			|| !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
+		{
 		    RETSETUNDEF;
+		}
 	    }
 	    else {
 		if (PL_op->op_private & HINT_STRICT_REFS)
@@ -276,7 +280,7 @@
     else {
 	GV *gv = (GV*)sv;
 	char *sym;
-	STRLEN n_a;
+	STRLEN len;
 
 	if (SvTYPE(gv) != SVt_PVGV) {
 	    if (SvGMAGICAL(sv)) {
@@ -292,13 +296,17 @@
 		    report_uninit();
 		RETSETUNDEF;
 	    }
-	    sym = SvPV(sv, n_a);
+	    sym = SvPV(sv, len);
 	    if ((PL_op->op_flags & OPf_SPECIAL) &&
 		!(PL_op->op_flags & OPf_MOD))
 	    {
 		gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
-		if (!gv)
+		if (!gv
+		    && (!is_gv_magical(sym,len,0)
+			|| !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
+		{
 		    RETSETUNDEF;
+		}
 	    }
 	    else {
 		if (PL_op->op_private & HINT_STRICT_REFS)

==== //depot/perl/pp_hot.c#170 (text) ====
Index: perl/pp_hot.c
--- perl/pp_hot.c.~1~	Sat May 27 23:40:36 2000
+++ perl/pp_hot.c	Sat May 27 23:40:36 2000
@@ -462,7 +462,7 @@
 	    
 	    if (SvTYPE(sv) != SVt_PVGV) {
 		char *sym;
-		STRLEN n_a;
+		STRLEN len;
 
 		if (SvGMAGICAL(sv)) {
 		    mg_get(sv);
@@ -481,13 +481,17 @@
 		    }
 		    RETSETUNDEF;
 		}
-		sym = SvPV(sv,n_a);
+		sym = SvPV(sv,len);
 		if ((PL_op->op_flags & OPf_SPECIAL) &&
 		    !(PL_op->op_flags & OPf_MOD))
 		{
 		    gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV);
-		    if (!gv)
+		    if (!gv
+			&& (!is_gv_magical(sym,len,0)
+			    || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV))))
+		    {
 			RETSETUNDEF;
+		    }
 		}
 		else {
 		    if (PL_op->op_private & HINT_STRICT_REFS)
@@ -562,7 +566,7 @@
 	    
 	    if (SvTYPE(sv) != SVt_PVGV) {
 		char *sym;
-		STRLEN n_a;
+		STRLEN len;
 
 		if (SvGMAGICAL(sv)) {
 		    mg_get(sv);
@@ -581,13 +585,17 @@
 		    }
 		    RETSETUNDEF;
 		}
-		sym = SvPV(sv,n_a);
+		sym = SvPV(sv,len);
 		if ((PL_op->op_flags & OPf_SPECIAL) &&
 		    !(PL_op->op_flags & OPf_MOD))
 		{
 		    gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV);
-		    if (!gv)
+		    if (!gv
+			&& (!is_gv_magical(sym,len,0)
+			    || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV))))
+		    {
 			RETSETUNDEF;
+		    }
 		}
 		else {
 		    if (PL_op->op_private & HINT_STRICT_REFS)

==== //depot/perl/proto.h#207 (text+w) ====
Index: perl/proto.h
--- perl/proto.h.~1~	Sat May 27 23:40:36 2000
+++ perl/proto.h	Sat May 27 23:40:36 2000
@@ -331,6 +331,7 @@
 PERL_CALLCONV char*	Perl_instr(pTHX_ const char* big, const char* little);
 PERL_CALLCONV bool	Perl_io_close(pTHX_ IO* io, bool not_implicit);
 PERL_CALLCONV OP*	Perl_invert(pTHX_ OP* cmd);
+PERL_CALLCONV bool	Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags);
 PERL_CALLCONV bool	Perl_is_uni_alnum(pTHX_ U32 c);
 PERL_CALLCONV bool	Perl_is_uni_alnumc(pTHX_ U32 c);
 PERL_CALLCONV bool	Perl_is_uni_idfirst(pTHX_ U32 c);

==== //depot/perl/t/op/gv.t#13 (xtext) ====
Index: perl/t/op/gv.t
--- perl/t/op/gv.t.~1~	Sat May 27 23:40:36 2000
+++ perl/t/op/gv.t	Sat May 27 23:40:36 2000
@@ -11,7 +11,7 @@
 
 use warnings;
 
-print "1..30\n";
+print "1..40\n";
 
 # type coersion on assignment
 $foo = 'foo';
@@ -128,6 +128,42 @@
     ++$test; &{$a};
 }
 
+# although it *should* if you're talking about magicals
+
+{
+    my $test = 29;
+
+    my $a = "]";
+    print "not " unless defined ${$a};
+    ++$test; print "ok $test\n";
+    print "not " unless defined *{$a};
+    ++$test; print "ok $test\n";
+
+    $a = "1";
+    "o" =~ /(o)/;
+    print "not " unless ${$a};
+    ++$test; print "ok $test\n";
+    print "not " unless defined *{$a};
+    ++$test; print "ok $test\n";
+    $a = "2";
+    print "not " if ${$a};
+    ++$test; print "ok $test\n";
+    print "not " unless defined *{$a};
+    ++$test; print "ok $test\n";
+    $a = "1x";
+    print "not " if defined ${$a};
+    ++$test; print "ok $test\n";
+    print "not " if defined *{$a};
+    ++$test; print "ok $test\n";
+    $a = "11";
+    "o" =~ /(((((((((((o)))))))))))/;
+    print "not " unless ${$a};
+    ++$test; print "ok $test\n";
+    print "not " unless defined *{$a};
+    ++$test; print "ok $test\n";
+}
+
+
 # does pp_readline() handle glob-ness correctly?
 
 {
@@ -137,4 +173,4 @@
 }
 
 __END__
-ok 30
+ok 40
End of Patch.

Thread Previous | Thread Next


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