diff options
| -rw-r--r-- | embed.fnc | 1 | ||||
| -rw-r--r-- | embed.h | 2 | ||||
| -rw-r--r-- | hv.c | 33 | ||||
| -rw-r--r-- | lib/feature.pm | 3 | ||||
| -rw-r--r-- | lib/sort.pm | 2 | ||||
| -rw-r--r-- | mg.c | 5 | ||||
| -rw-r--r-- | op.c | 3 | ||||
| -rw-r--r-- | proto.h | 3 | ||||
| -rw-r--r-- | scope.c | 22 | ||||
| -rw-r--r-- | scope.h | 2 | ||||
| -rw-r--r-- | t/lib/mypragma.pm | 1 |
11 files changed, 68 insertions, 9 deletions
@@ -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 @@ -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) @@ -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 4f03329802..d4975e411e 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 326724b0f8..529077ebe1 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 @@ -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); @@ -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; } @@ -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); @@ -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; @@ -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 d1f52c6c34..45244f6445 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 { |