From: Nicholas Clark Date: Thu, 9 Jun 2005 19:02:43 +0000 (+0000) Subject: Fixes the case of $a = \$#{[]}; and then accessing $$a X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=83bf042f79af6208af0620b081ee65543ecfed9f;p=p5sagit%2Fp5-mst-13.2.git Fixes the case of $a = \$#{[]}; and then accessing $$a (but not \$#a after local @a or my @a leave a block) p4raw-id: //depot/perl@24783 --- diff --git a/av.c b/av.c index 695ebc7..e5cbe2f 100644 --- a/av.c +++ b/av.c @@ -504,10 +504,8 @@ Perl_av_undef(pTHX_ register AV *av) AvALLOC(av) = 0; SvPV_set(av, (char*)0); AvMAX(av) = AvFILLp(av) = -1; - if (AvARYLEN(av)) { - SvREFCNT_dec(AvARYLEN(av)); - AvARYLEN(av) = 0; - } + /* It's in magic - it must already be gone. */ + assert (!AvARYLEN(av)); } /* @@ -949,6 +947,14 @@ Perl_av_arylen_p(pTHX_ AV *av) { } /* sv_magicext won't set this for us because we pass in a NULL obj */ mg->mg_flags |= MGf_REFCOUNTED; + + /* This is very naughty, but we don't want SvRMAGICAL() set on the + hash, because it slows down all accesses. If we pass in a vtable + to sv_magicext then it is (correctly) set for us. However, the only + entry in our vtable is for free, and mg_free always calls the free + vtable entry irrespective of the flags, so it doesn't actually + matter that the R flag is off. */ + mg->mg_virtual = &PL_vtbl_arylen_p; } return &(mg->mg_obj); } diff --git a/dump.c b/dump.c index bfa6727..fed067d 100644 --- a/dump.c +++ b/dump.c @@ -970,6 +970,7 @@ Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 else if (v == &PL_vtbl_amagicelem) s = "amagicelem"; else if (v == &PL_vtbl_backref) s = "backref"; else if (v == &PL_vtbl_utf8) s = "utf8"; + else if (v == &PL_vtbl_arylen_p) s = "arylen_p"; if (s) Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", s); else diff --git a/embed.fnc b/embed.fnc index 408e44f..2ad5e07 100644 --- a/embed.fnc +++ b/embed.fnc @@ -411,6 +411,7 @@ pr |int |magic_regdatum_set|SV* sv|MAGIC* mg p |int |magic_set |SV* sv|MAGIC* mg p |int |magic_setamagic|SV* sv|MAGIC* mg p |int |magic_setarylen|SV* sv|MAGIC* mg +p |int |magic_freearylen_p|SV* sv|MAGIC* mg p |int |magic_setbm |SV* sv|MAGIC* mg p |int |magic_setdbline|SV* sv|MAGIC* mg p |int |magic_setdefelem|SV* sv|MAGIC* mg diff --git a/embed.h b/embed.h index 7b39af5..dacff84 100644 --- a/embed.h +++ b/embed.h @@ -421,6 +421,7 @@ #define magic_set Perl_magic_set #define magic_setamagic Perl_magic_setamagic #define magic_setarylen Perl_magic_setarylen +#define magic_freearylen_p Perl_magic_freearylen_p #define magic_setbm Perl_magic_setbm #define magic_setdbline Perl_magic_setdbline #define magic_setdefelem Perl_magic_setdefelem @@ -2420,6 +2421,7 @@ #define magic_set(a,b) Perl_magic_set(aTHX_ a,b) #define magic_setamagic(a,b) Perl_magic_setamagic(aTHX_ a,b) #define magic_setarylen(a,b) Perl_magic_setarylen(aTHX_ a,b) +#define magic_freearylen_p(a,b) Perl_magic_freearylen_p(aTHX_ a,b) #define magic_setbm(a,b) Perl_magic_setbm(aTHX_ a,b) #define magic_setdbline(a,b) Perl_magic_setdbline(aTHX_ a,b) #define magic_setdefelem(a,b) Perl_magic_setdefelem(aTHX_ a,b) diff --git a/mg.c b/mg.c index 4b31e4b..4c01018 100644 --- a/mg.c +++ b/mg.c @@ -1647,14 +1647,42 @@ Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_getarylen(pTHX_ SV *sv, MAGIC *mg) { - sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + PL_curcop->cop_arybase); + AV *obj = (AV*)mg->mg_obj; + if (obj) { + sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase); + } else { + SvOK_off(sv); + } return 0; } int Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg) { - av_fill((AV*)mg->mg_obj, SvIV(sv) - PL_curcop->cop_arybase); + AV *obj = (AV*)mg->mg_obj; + if (obj) { + av_fill(obj, SvIV(sv) - PL_curcop->cop_arybase); + } else { + if (ckWARN(WARN_MISC)) + Perl_warner(aTHX_ packWARN(WARN_MISC), + "Attempt to set length of freed array"); + } + return 0; +} + +int +Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg) +{ + mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen); + + if (mg) { + /* arylen scalar holds a pointer back to the array, but doesn't own a + reference. Hence the we (the array) are about to go away with it + still pointing at us. Clear its pointer, else it would be pointing + at free memory. See the comment in sv_magic about reference loops, + and why it can't own a reference to us. */ + mg->mg_obj = 0; + } return 0; } diff --git a/perl.h b/perl.h index 3df67eb..5eff7de 100644 --- a/perl.h +++ b/perl.h @@ -3805,7 +3805,8 @@ enum { /* pass one of these to get_vtbl */ want_vtbl_regdatum, want_vtbl_backref, want_vtbl_utf8, - want_vtbl_symtab + want_vtbl_symtab, + want_vtbl_arylen_p }; /* Note: the lowest 8 bits are reserved for @@ -4165,6 +4166,17 @@ MGVTBL_SET( ); MGVTBL_SET( + PL_vtbl_arylen_p, + NULL, + NULL, + NULL, + NULL, + MEMBER_TO_FPTR(Perl_magic_freearylen_p), + NULL, + NULL +); + +MGVTBL_SET( PL_vtbl_glob, MEMBER_TO_FPTR(Perl_magic_getglob), MEMBER_TO_FPTR(Perl_magic_setglob), diff --git a/proto.h b/proto.h index 6ac3d69..64adf53 100644 --- a/proto.h +++ b/proto.h @@ -762,6 +762,7 @@ PERL_CALLCONV int Perl_magic_regdatum_set(pTHX_ SV* sv, MAGIC* mg) PERL_CALLCONV int Perl_magic_set(pTHX_ SV* sv, MAGIC* mg); PERL_CALLCONV int Perl_magic_setamagic(pTHX_ SV* sv, MAGIC* mg); PERL_CALLCONV int Perl_magic_setarylen(pTHX_ SV* sv, MAGIC* mg); +PERL_CALLCONV int Perl_magic_freearylen_p(pTHX_ SV* sv, MAGIC* mg); PERL_CALLCONV int Perl_magic_setbm(pTHX_ SV* sv, MAGIC* mg); PERL_CALLCONV int Perl_magic_setdbline(pTHX_ SV* sv, MAGIC* mg); PERL_CALLCONV int Perl_magic_setdefelem(pTHX_ SV* sv, MAGIC* mg); diff --git a/t/op/array.t b/t/op/array.t index c003ffe..16a3df5 100755 --- a/t/op/array.t +++ b/t/op/array.t @@ -7,7 +7,7 @@ BEGIN { require 'test.pl'; -plan (85); +plan (88); # # @foo, @bar, and @ary are also used from tie-stdarray after tie-ing them @@ -277,3 +277,13 @@ is ($got, ''); like($@, qr/Modification of non-creatable array value attempted, subscript -1/, "\$a[-1] = 0"); } +{ + local $^W = 1; + my $a = \$#{[]}; + is ($$a, undef, "\$# on freed array is undef"); + my @warn; + local $SIG{__WARN__} = sub {push @warn, "@_"}; + $$a = 1000; + is (scalar @warn, 1); + like ($warn[0], qr/^Attempt to set length of freed array/); +}