From: Gurusamy Sarathy <gsar@cpan.org>
Date: Sun, 28 May 2000 06:39:53 +0000 (+0000)
Subject: change#2879 broke rvalue autovivification of magicals such as ${$num}
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c9d5ac959cdfa7a668b3bfbbc2b56923c316ef43;p=p5sagit%2Fp5-mst-13.2.git
change#2879 broke rvalue autovivification of magicals such as ${$num}
(reworked variant of patch suggested by Simon Cozens)
p4raw-link: @2879 on //depot/perl: 35cd451c5a1303394968903750cc3b3a1a6bc892
p4raw-id: //depot/perl@6126
---
diff --git a/embed.h b/embed.h
index b19115f..76ff0dc 100644
--- a/embed.h
+++ b/embed.h
@@ -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
diff --git a/embed.pl b/embed.pl
index bbea4dc..4b27a4b 100755
--- a/embed.pl
+++ b/embed.pl
@@ -1567,6 +1567,7 @@ p |U32 |intro_my
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
diff --git a/gv.c b/gv.c
index 5ab21b1..1868114 100644
--- a/gv.c
+++ b/gv.c
@@ -1580,3 +1580,110 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
}
}
}
+
+/*
+=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;
+}
diff --git a/pod/perlapi.pod b/pod/perlapi.pod
index 58e2951..cd467ba 100644
--- a/pod/perlapi.pod
+++ b/pod/perlapi.pod
@@ -165,9 +165,16 @@ the type. May fail on overlapping copies. See also C<Move>.
=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 @@ false, defined or undefined. Does not handle 'get' magic.
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>.
diff --git a/pod/perlintern.pod b/pod/perlintern.pod
index b0aab33..6d8d67d 100644
--- a/pod/perlintern.pod
+++ b/pod/perlintern.pod
@@ -12,6 +12,18 @@ B<they are not for use in extensions>!
=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
diff --git a/pp.c b/pp.c
index e148197..d0fe911 100644
--- a/pp.c
+++ b/pp.c
@@ -198,7 +198,7 @@ PP(pp_rv2gv)
else {
if (SvTYPE(sv) != SVt_PVGV) {
char *sym;
- STRLEN n_a;
+ STRLEN len;
if (SvGMAGICAL(sv)) {
mg_get(sv);
@@ -236,13 +236,17 @@ PP(pp_rv2gv)
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 @@ PP(pp_rv2sv)
else {
GV *gv = (GV*)sv;
char *sym;
- STRLEN n_a;
+ STRLEN len;
if (SvTYPE(gv) != SVt_PVGV) {
if (SvGMAGICAL(sv)) {
@@ -292,13 +296,17 @@ PP(pp_rv2sv)
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)
diff --git a/pp_hot.c b/pp_hot.c
index 2a8aa9b..6bec999 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -462,7 +462,7 @@ PP(pp_rv2av)
if (SvTYPE(sv) != SVt_PVGV) {
char *sym;
- STRLEN n_a;
+ STRLEN len;
if (SvGMAGICAL(sv)) {
mg_get(sv);
@@ -481,13 +481,17 @@ PP(pp_rv2av)
}
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 @@ PP(pp_rv2hv)
if (SvTYPE(sv) != SVt_PVGV) {
char *sym;
- STRLEN n_a;
+ STRLEN len;
if (SvGMAGICAL(sv)) {
mg_get(sv);
@@ -581,13 +585,17 @@ PP(pp_rv2hv)
}
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)
diff --git a/proto.h b/proto.h
index 3e0aaef..9fbefb0 100644
--- a/proto.h
+++ b/proto.h
@@ -331,6 +331,7 @@ PERL_CALLCONV U32 Perl_intro_my(pTHX);
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);
diff --git a/t/op/gv.t b/t/op/gv.t
index 04905cd..209f5eb 100755
--- a/t/op/gv.t
+++ b/t/op/gv.t
@@ -11,7 +11,7 @@ BEGIN {
use warnings;
-print "1..30\n";
+print "1..40\n";
# type coersion on assignment
$foo = 'foo';
@@ -128,6 +128,42 @@ print {*x{FILEHANDLE}} "ok 23\n";
++$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 @@ print {*x{FILEHANDLE}} "ok 23\n";
}
__END__
-ok 30
+ok 40