From: Nicholas Clark <nick@ccl4.org>
Date: Sat, 1 Apr 2006 21:17:46 +0000 (+0000)
Subject: Automatically set HINT_LOCALIZE_HH whenever %^H is modified.
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5b9c067131ee63b4afa00d1d71c771377deb6ff9;p=p5sagit%2Fp5-mst-13.2.git
Automatically set HINT_LOCALIZE_HH whenever %^H is modified.
p4raw-id: //depot/perl@27666
---
diff --git a/embed.fnc b/embed.fnc
index af21a14..d3cb75d 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -285,6 +285,7 @@ Apd |HV* |gv_stashpv |NN const char* name|I32 create
Apd |HV* |gv_stashpvn |NN const char* name|U32 namelen|I32 create
Apd |HV* |gv_stashsv |NULLOK SV* sv|I32 create
Apd |void |hv_clear |NULLOK HV* tb
+poM |HV * |hv_copy_hints_hv|NN HV *const ohv
Ap |void |hv_delayfree_ent|NN HV* hv|NULLOK HE* entry
Apd |SV* |hv_delete |NULLOK HV* tb|NN const char* key|I32 klen|I32 flags
Apd |SV* |hv_delete_ent |NULLOK HV* tb|NN SV* key|I32 flags|U32 hash
diff --git a/embed.h b/embed.h
index b8c279f..febc317 100644
--- a/embed.h
+++ b/embed.h
@@ -2438,6 +2438,8 @@
#define gv_stashpvn(a,b,c) Perl_gv_stashpvn(aTHX_ a,b,c)
#define gv_stashsv(a,b) Perl_gv_stashsv(aTHX_ a,b)
#define hv_clear(a) Perl_hv_clear(aTHX_ a)
+#ifdef PERL_CORE
+#endif
#define hv_delayfree_ent(a,b) Perl_hv_delayfree_ent(aTHX_ a,b)
#define hv_delete(a,b,c,d) Perl_hv_delete(aTHX_ a,b,c,d)
#define hv_delete_ent(a,b,c,d) Perl_hv_delete_ent(aTHX_ a,b,c,d)
diff --git a/hv.c b/hv.c
index 4565cc0..fe74e87 100644
--- a/hv.c
+++ b/hv.c
@@ -1491,6 +1491,39 @@ Perl_newHVhv(pTHX_ HV *ohv)
return hv;
}
+/* A rather specialised version of newHVhv for copying %^H, ensuring all the
+ magic stays on it. */
+HV *
+Perl_hv_copy_hints_hv(pTHX_ HV *const ohv)
+{
+ HV * const hv = newHV();
+ STRLEN hv_fill;
+
+ if (ohv && (hv_fill = HvFILL(ohv))) {
+ STRLEN hv_max = HvMAX(ohv);
+ HE *entry;
+ const I32 riter = HvRITER_get(ohv);
+ HE * const eiter = HvEITER_get(ohv);
+
+ while (hv_max && hv_max + 1 >= hv_fill * 2)
+ hv_max = hv_max / 2;
+ HvMAX(hv) = hv_max;
+
+ hv_iterinit(ohv);
+ while ((entry = hv_iternext_flags(ohv, 0))) {
+ SV *const sv = newSVsv(HeVAL(entry));
+ sv_magic(sv, NULL, PERL_MAGIC_hintselem,
+ (char *)newSVhek (HeKEY_hek(entry)), HEf_SVKEY);
+ hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
+ sv, HeHASH(entry), HeKFLAGS(entry));
+ }
+ HvRITER_set(ohv, riter);
+ HvEITER_set(ohv, eiter);
+ }
+ hv_magic(hv, NULL, PERL_MAGIC_hints);
+ return hv;
+}
+
void
Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
{
diff --git a/lib/feature.pm b/lib/feature.pm
index 4f03329..d4975e4 100644
--- a/lib/feature.pm
+++ b/lib/feature.pm
@@ -1,7 +1,6 @@
package feature;
our $VERSION = '1.00';
-$feature::hint_bits = 0x00020000; # HINT_LOCALIZE_HH
# (feature name) => (internal name, used in %^H)
my %feature = (
@@ -93,8 +92,6 @@ to C<use feature qw(switch ~~ say err)>.
=cut
sub import {
- $^H |= $feature::hint_bits; # Need this or %^H won't work
-
my $class = shift;
if (@_ == 0) {
require Carp;
diff --git a/lib/sort.pm b/lib/sort.pm
index 326724b..529077e 100644
--- a/lib/sort.pm
+++ b/lib/sort.pm
@@ -5,8 +5,6 @@ our $VERSION = '2.00';
# The hints for pp_sort are now stored in $^H{sort}; older versions
# of perl used the global variable $sort::hints. -- rjh 2005-12-19
-$sort::hint_bits = 0x00020000; # HINT_LOCALIZE_HH
-
$sort::quicksort_bit = 0x00000001;
$sort::mergesort_bit = 0x00000002;
$sort::sort_bits = 0x000000FF; # allow 256 different ones
diff --git a/mg.c b/mg.c
index 615a273..d8f4e0e 100644
--- a/mg.c
+++ b/mg.c
@@ -2857,6 +2857,10 @@ Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
it's NULL. If needed for threads, the alternative could lock a mutex,
or take other more complex action. */
+ /* Something changed in %^H, so it will need to be restored on scope exit.
+ Doing this here saves a lot of doing it manually in perl code (and
+ forgetting to do it, and consequent subtle errors. */
+ PL_hints |= HINT_LOCALIZE_HH;
PL_compiling.cop_hints
= Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints,
(SV *)mg->mg_ptr, newSVsv(sv));
@@ -2876,6 +2880,7 @@ Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
dVAR;
assert(mg->mg_len == HEf_SVKEY);
+ PL_hints |= HINT_LOCALIZE_HH;
PL_compiling.cop_hints
= Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints,
(SV *)mg->mg_ptr, &PL_sv_placeholder);
diff --git a/op.c b/op.c
index 0d77f62..31b8e8d 100644
--- a/op.c
+++ b/op.c
@@ -5937,7 +5937,8 @@ Perl_ck_eval(pTHX_ OP *o)
o->op_targ = (PADOFFSET)PL_hints;
if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
/* Store a copy of %^H that pp_entereval can pick up */
- OP *hhop = newSVOP(OP_CONST, 0, (SV*)newHVhv(GvHV(PL_hintgv)));
+ OP *hhop = newSVOP(OP_CONST, 0,
+ (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
cUNOPo->op_first->op_sibling = hhop;
o->op_private |= OPpEVAL_HAS_HH;
}
diff --git a/proto.h b/proto.h
index 2be599e..e9a2a7b 100644
--- a/proto.h
+++ b/proto.h
@@ -657,6 +657,9 @@ PERL_CALLCONV HV* Perl_gv_stashpvn(pTHX_ const char* name, U32 namelen, I32 crea
PERL_CALLCONV HV* Perl_gv_stashsv(pTHX_ SV* sv, I32 create);
PERL_CALLCONV void Perl_hv_clear(pTHX_ HV* tb);
+PERL_CALLCONV HV * Perl_hv_copy_hints_hv(pTHX_ HV *const ohv)
+ __attribute__nonnull__(pTHX_1);
+
PERL_CALLCONV void Perl_hv_delayfree_ent(pTHX_ HV* hv, HE* entry)
__attribute__nonnull__(pTHX_1);
diff --git a/scope.c b/scope.c
index 5e4193a..b4ecd65 100644
--- a/scope.c
+++ b/scope.c
@@ -895,8 +895,28 @@ Perl_leave_scope(pTHX_ I32 base)
if (PL_hints & HINT_LOCALIZE_HH) {
SvREFCNT_dec((SV*)GvHV(PL_hintgv));
GvHV(PL_hintgv) = (HV*)SSPOPPTR;
+ assert(GvHV(PL_hintgv));
+ } else if (!GvHV(PL_hintgv)) {
+ /* Need to add a new one manually, else gv_fetchpv() can
+ add one in this code:
+
+ if (SvTYPE(gv) == SVt_PVGV) {
+ if (add) {
+ GvMULTI_on(gv);
+ gv_init_sv(gv, sv_type);
+ if (*name=='!' && sv_type == SVt_PVHV && len==1)
+ require_errno(gv);
+ }
+ return gv;
+ }
+
+ and it won't have the magic set. */
+
+ HV *const hv = newHV();
+ hv_magic(hv, NULL, PERL_MAGIC_hints);
+ GvHV(PL_hintgv) = hv;
}
-
+ assert(GvHV(PL_hintgv));
break;
case SAVEt_COMPPAD:
PL_comppad = (PAD*)SSPOPPTR;
diff --git a/scope.h b/scope.h
index debae28..74ab22b 100644
--- a/scope.h
+++ b/scope.h
@@ -153,7 +153,7 @@ Closing bracket on a callback. See C<ENTER> and L<perlcall>.
SSCHECK(4); \
if (PL_hints & HINT_LOCALIZE_HH) { \
SSPUSHPTR(GvHV(PL_hintgv)); \
- GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv)); \
+ GvHV(PL_hintgv) = Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)); \
} \
if (PL_compiling.cop_hints) { \
PL_compiling.cop_hints->refcounted_he_refcnt++; \
diff --git a/t/lib/mypragma.pm b/t/lib/mypragma.pm
index d1f52c6..45244f6 100644
--- a/t/lib/mypragma.pm
+++ b/t/lib/mypragma.pm
@@ -31,7 +31,6 @@ use warnings;
sub import {
$^H{mypragma} = 1;
- $^H |= 0x00020000;
}
sub unimport {