From: Zefram Date: Thu, 20 Aug 2009 23:49:14 +0000 (+0200) Subject: Add clear magic to %^H so that the HE chain is reset when you empty it. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f747ebd621ca5f8cd5605b35b81db4ac486f68f9;p=p5sagit%2Fp5-mst-13.2.git Add clear magic to %^H so that the HE chain is reset when you empty it. This fixes [perl #68590] : %^H not lexical enough. --- diff --git a/MANIFEST b/MANIFEST index 2fb8ee0..a5daf74 100644 --- a/MANIFEST +++ b/MANIFEST @@ -3929,6 +3929,7 @@ t/comp/cmdopt.t See if command optimization works t/comp/colon.t See if colons are parsed correctly t/comp/decl.t See if declarations work t/comp/fold.t See if constant folding works +t/comp/hints.aux Auxillary file for %^H test t/comp/hints.t See if %^H works t/comp/multiline.t See if multiline strings work t/comp/opsubs.t See if q() etc. are not parsed as functions diff --git a/cop.h b/cop.h index fc19494..3633e9d 100644 --- a/cop.h +++ b/cop.h @@ -246,12 +246,17 @@ struct cop { #define CopARYBASE_set(c, b) STMT_START { \ if (b || ((c)->cop_hints & HINT_ARYBASE)) { \ (c)->cop_hints |= HINT_ARYBASE; \ - if ((c) == &PL_compiling) \ - PL_hints |= HINT_LOCALIZE_HH | HINT_ARYBASE; \ - (c)->cop_hints_hash \ - = Perl_refcounted_he_new(aTHX_ (c)->cop_hints_hash, \ + if ((c) == &PL_compiling) { \ + SV *val = newSViv(b); \ + (void)hv_stores(GvHV(PL_hintgv), "$[", val); \ + mg_set(val); \ + PL_hints |= HINT_ARYBASE; \ + } else { \ + (c)->cop_hints_hash \ + = Perl_refcounted_he_new(aTHX_ (c)->cop_hints_hash, \ newSVpvs_flags("$[", SVs_TEMP), \ sv_2mortal(newSViv(b))); \ + } \ } \ } STMT_END diff --git a/dump.c b/dump.c index e7f5a1d..c891b2f 100644 --- a/dump.c +++ b/dump.c @@ -1261,6 +1261,7 @@ Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 else if (v == &PL_vtbl_utf8) s = "utf8"; else if (v == &PL_vtbl_arylen_p) s = "arylen_p"; else if (v == &PL_vtbl_hintselem) s = "hintselem"; + else if (v == &PL_vtbl_hints) s = "hints"; else s = NULL; if (s) Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", s); diff --git a/embed.fnc b/embed.fnc index 67a79f5..33774c7 100644 --- a/embed.fnc +++ b/embed.fnc @@ -535,6 +535,7 @@ Apd |UV |grok_oct |NN const char* start|NN STRLEN* len_p|NN I32* flags|NULLOK NV p |int |magic_clearenv |NN SV* sv|NN MAGIC* mg p |int |magic_clear_all_env|NN SV* sv|NN MAGIC* mg dp |int |magic_clearhint|NN SV* sv|NN MAGIC* mg +dp |int |magic_clearhints|NN SV* sv|NN MAGIC* mg p |int |magic_clearisa |NULLOK SV* sv|NN MAGIC* mg p |int |magic_clearpack|NN SV* sv|NN MAGIC* mg p |int |magic_clearsig |NN SV* sv|NN MAGIC* mg diff --git a/embed.h b/embed.h index b042886..5968fb6 100644 --- a/embed.h +++ b/embed.h @@ -423,6 +423,7 @@ #define magic_clearenv Perl_magic_clearenv #define magic_clear_all_env Perl_magic_clear_all_env #define magic_clearhint Perl_magic_clearhint +#define magic_clearhints Perl_magic_clearhints #define magic_clearisa Perl_magic_clearisa #define magic_clearpack Perl_magic_clearpack #define magic_clearsig Perl_magic_clearsig @@ -2759,6 +2760,7 @@ #define magic_clearenv(a,b) Perl_magic_clearenv(aTHX_ a,b) #define magic_clear_all_env(a,b) Perl_magic_clear_all_env(aTHX_ a,b) #define magic_clearhint(a,b) Perl_magic_clearhint(aTHX_ a,b) +#define magic_clearhints(a,b) Perl_magic_clearhints(aTHX_ a,b) #define magic_clearisa(a,b) Perl_magic_clearisa(aTHX_ a,b) #define magic_clearpack(a,b) Perl_magic_clearpack(aTHX_ a,b) #define magic_clearsig(a,b) Perl_magic_clearsig(aTHX_ a,b) diff --git a/mg.c b/mg.c index 5cfa8cb..c15119f 100644 --- a/mg.c +++ b/mg.c @@ -2391,31 +2391,23 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) const char *const start = SvPV(sv, len); const char *out = (const char*)memchr(start, '\0', len); SV *tmp; - struct refcounted_he *tmp_he; PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT; - PL_hints - |= HINT_LOCALIZE_HH | HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT; + PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT; /* Opening for input is more common than opening for output, so ensure that hints for input are sooner on linked list. */ tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1, - SVs_TEMP | SvUTF8(sv)) - : newSVpvs_flags("", SVs_TEMP | SvUTF8(sv)); + SvUTF8(sv)) + : newSVpvs_flags("", SvUTF8(sv)); + (void)hv_stores(GvHV(PL_hintgv), "open>", tmp); + mg_set(tmp); - tmp_he - = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash, - newSVpvs_flags("open>", SVs_TEMP), - tmp); - - /* The UTF-8 setting is carried over */ - sv_setpvn(tmp, start, out ? (STRLEN)(out - start) : len); - - PL_compiling.cop_hints_hash - = Perl_refcounted_he_new(aTHX_ tmp_he, - newSVpvs_flags("open<", SVs_TEMP), - tmp); + tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len, + SvUTF8(sv)); + (void)hv_stores(GvHV(PL_hintgv), "open<", tmp); + mg_set(tmp); } break; case '\020': /* ^P */ @@ -3096,6 +3088,26 @@ Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg) } /* +=for apidoc magic_clearhints + +Triggered by clearing %^H, resets C. + +=cut +*/ +int +Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg) +{ + PERL_ARGS_ASSERT_MAGIC_CLEARHINTS; + PERL_UNUSED_ARG(sv); + PERL_UNUSED_ARG(mg); + if (PL_compiling.cop_hints_hash) { + Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash); + PL_compiling.cop_hints_hash = NULL; + } + return 0; +} + +/* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 diff --git a/perl.h b/perl.h index 75c52e7..136bd53 100644 --- a/perl.h +++ b/perl.h @@ -4645,7 +4645,8 @@ enum { /* pass one of these to get_vtbl */ want_vtbl_utf8, want_vtbl_symtab, want_vtbl_arylen_p, - want_vtbl_hintselem + want_vtbl_hintselem, + want_vtbl_hints }; @@ -4950,7 +4951,6 @@ MGVTBL_SET( 0 ); -/* For now, hints magic will also use vtbl_sig, because it is all 0 */ MGVTBL_SET( PL_vtbl_sig, 0, @@ -5315,6 +5315,18 @@ MGVTBL_SET( 0 ); +MGVTBL_SET( + PL_vtbl_hints, + 0, + 0, + 0, + MEMBER_TO_FPTR(Perl_magic_clearhints), + 0, + 0, + 0, + 0 +); + #include "overload.h" END_EXTERN_C diff --git a/pod/perlguts.pod b/pod/perlguts.pod index 2b6fd8c..afc69ae 100644 --- a/pod/perlguts.pod +++ b/pod/perlguts.pod @@ -1038,7 +1038,7 @@ The current kinds of Magic Virtual Tables are: e PERL_MAGIC_envelem vtbl_envelem %ENV hash element f PERL_MAGIC_fm vtbl_fm Formline ('compiled' format) g PERL_MAGIC_regex_global vtbl_mglob m//g target / study()ed string - H PERL_MAGIC_hints vtbl_sig %^H hash + H PERL_MAGIC_hints vtbl_hints %^H hash h PERL_MAGIC_hintselem vtbl_hintselem %^H hash element I PERL_MAGIC_isa vtbl_isa @ISA array i PERL_MAGIC_isaelem vtbl_isaelem @ISA array element diff --git a/pp_ctl.c b/pp_ctl.c index 35e3436..0eb513f 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -3568,10 +3568,7 @@ PP(pp_require) SAVEHINTS(); PL_hints = 0; - if (PL_compiling.cop_hints_hash) { - Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash); - PL_compiling.cop_hints_hash = NULL; - } + hv_clear(GvHV(PL_hintgv)); SAVECOMPILEWARNINGS(); if (PL_dowarn & G_WARN_ALL_ON) diff --git a/proto.h b/proto.h index 1b93673..5fe779a 100644 --- a/proto.h +++ b/proto.h @@ -1504,6 +1504,12 @@ PERL_CALLCONV int Perl_magic_clearhint(pTHX_ SV* sv, MAGIC* mg) #define PERL_ARGS_ASSERT_MAGIC_CLEARHINT \ assert(sv); assert(mg) +PERL_CALLCONV int Perl_magic_clearhints(pTHX_ SV* sv, MAGIC* mg) + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2); +#define PERL_ARGS_ASSERT_MAGIC_CLEARHINTS \ + assert(sv); assert(mg) + PERL_CALLCONV int Perl_magic_clearisa(pTHX_ SV* sv, MAGIC* mg) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_MAGIC_CLEARISA \ diff --git a/sv.c b/sv.c index b8daf81..b9f682c 100644 --- a/sv.c +++ b/sv.c @@ -5096,8 +5096,6 @@ Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how, case PERL_MAGIC_qr: vtable = &PL_vtbl_regexp; break; - case PERL_MAGIC_hints: - /* As this vtable is all NULL, we can reuse it. */ case PERL_MAGIC_sig: vtable = &PL_vtbl_sig; break; @@ -5140,6 +5138,9 @@ Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how, case PERL_MAGIC_hintselem: vtable = &PL_vtbl_hintselem; break; + case PERL_MAGIC_hints: + vtable = &PL_vtbl_hints; + break; case PERL_MAGIC_ext: /* Reserved for use by extensions not perl internals. */ /* Useful for attaching extension internal data to perl vars. */ diff --git a/t/comp/hints.aux b/t/comp/hints.aux new file mode 100644 index 0000000..79b6dee --- /dev/null +++ b/t/comp/hints.aux @@ -0,0 +1,5 @@ +our($ra1, $ri1, $rf1, $rfe1); +$ra1 = $[; +BEGIN { $ri1 = $^H; $rf1 = $^H{foo}; $rfe1 = exists($^H{foo}); } + +1; diff --git a/t/comp/hints.t b/t/comp/hints.t index 55aeb71..b19fc5f 100644 --- a/t/comp/hints.t +++ b/t/comp/hints.t @@ -8,7 +8,7 @@ BEGIN { } -BEGIN { print "1..17\n"; } +BEGIN { print "1..32\n"; } BEGIN { print "not " if exists $^H{foo}; print "ok 1 - \$^H{foo} doesn't exist initially\n"; @@ -38,7 +38,7 @@ BEGIN { } BEGIN { print "not " if $^H{foo} ne "a"; - print "ok 6 - \$H^{foo} restored to 'a'\n"; + print "ok 6 - \$^H{foo} restored to 'a'\n"; } # The pragma settings disappear after compilation # (test at CHECK-time and at run-time) @@ -95,14 +95,52 @@ print "# got: $result\n" if length $result; { BEGIN{$^H{x}=1}; - for(1..2) { + for my $tno (16..17) { eval q( - print $^H{x}==1 && !$^H{y} ? "ok\n" : "not ok\n"; + print $^H{x}==1 && !$^H{y} ? "ok $tno\n" : "not ok $tno\n"; $^H{y} = 1; ); if ($@) { (my $str = $@)=~s/^/# /gm; - print "not ok\n$str\n"; + print "not ok $tno\n$str\n"; } } } + +{ + $[ = 11; + print +($[ == 11 ? "" : "not "), "ok 18 - setting \$[ affects \$[\n"; + our $t11; BEGIN { $t11 = $^H{'$['} } + print +($t11 == 11 ? "" : "not "), "ok 19 - setting \$[ affects \$^H{'\$['}\n"; + + BEGIN { $^H{'$['} = 22 } + print +($[ == 22 ? "" : "not "), "ok 20 - setting \$^H{'\$['} affects \$[\n"; + our $t22; BEGIN { $t22 = $^H{'$['} } + print +($t22 == 22 ? "" : "not "), "ok 21 - setting \$^H{'\$['} affects \$^H{'\$['}\n"; + + BEGIN { %^H = () } + print +($[ == 0 ? "" : "not "), "ok 22 - clearing \%^H affects \$[\n"; + our $t0; BEGIN { $t0 = $^H{'$['} } + print +($t0 == 0 ? "" : "not "), "ok 23 - clearing \%^H affects \$^H{'\$['}\n"; +} + +{ + $[ = 13; + BEGIN { $^H |= 0x04000000; $^H{foo} = "z"; } + + our($ri0, $rf0); BEGIN { $ri0 = $^H; $rf0 = $^H{foo}; } + print +($[ == 13 ? "" : "not "), "ok 24 - \$[ correct before require\n"; + print +($ri0 & 0x04000000 ? "" : "not "), "ok 25 - \$^H correct before require\n"; + print +($rf0 eq "z" ? "" : "not "), "ok 26 - \$^H{foo} correct before require\n"; + + our($ra1, $ri1, $rf1, $rfe1); + BEGIN { require "comp/hints.aux"; } + print +($ra1 == 0 ? "" : "not "), "ok 27 - \$[ cleared for require\n"; + print +(!($ri1 & 0x04000000) ? "" : "not "), "ok 28 - \$^H cleared for require\n"; + print +(!defined($rf1) && !$rfe1 ? "" : "not "), "ok 29 - \$^H{foo} cleared for require\n"; + + our($ri2, $rf2); BEGIN { $ri2 = $^H; $rf2 = $^H{foo}; } + print +($[ == 13 ? "" : "not "), "ok 30 - \$[ correct after require\n"; + print +($ri2 & 0x04000000 ? "" : "not "), "ok 31 - \$^H correct after require\n"; + print +($rf2 eq "z" ? "" : "not "), "ok 32 - \$^H{foo} correct after require\n"; +}