pp.c - forbid localizing and aliasing readonly hash keys in restricted hashes

local $hash{key} and \$hash{key} = \$var are both conceptually modify operations which are forbidden when the hash is restricted and the value is readonly. Unfortunately prior to this commit they were still allowed operations. This patch corrects that oversight. Adds a bunch of tests to t/op/lvref.t to ensure that it is illegal to localize or ref-alias a readonly value in a restricted hash.

Author: demerphq

embed.fnc

@@ -1468,6 +1468,12 @@ AMbdp	|HE *	|hv_fetch_ent	|NULLOK HV *hv	\
 |NN SV *keysv	\
 |I32 lval	\
 |U32 hash
+Edm	|HE *	|hv_fetch_ent_for	\
+|NULLOK HV *hv	\
+|NN SV *keysv	\
+|I32 lval	\
+|U32 hash	\
+|U32 for_flags
 Cdop	|STRLEN |hv_fill	|NN HV * const hv
 Cp	|void	|hv_free_ent	|NULLOK HV *notused	\
 |NULLOK HE *entry
@@ -1518,6 +1524,12 @@ AMbdp	|HE *	|hv_store_ent	|NULLOK HV *hv	\
 |NULLOK SV *key	\
 |NULLOK SV *val	\
 |U32 hash
+Edm	|HE *	|hv_store_ent_for	\
+|NULLOK HV *hv	\
+|NULLOK SV *key	\
+|NULLOK SV *val	\
+|U32 hash	\
+|U32 for_flags
 AMbpx	|SV **	|hv_store_flags |NULLOK HV *hv	\
 |NULLOK const char *key	\
 |I32 klen	\

hv.c

@@ -396,6 +396,13 @@ C<hv_store> in preference to C<hv_store_ent>.
 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
 information on how to use this function on tied hashes.
 
+=for apidoc hv_store_ent_for
+
+Identical to C<hv_store_ent()> but accepting an additional parameter which allows
+the caller to signal what the store is for, typically HV_ACTION_ISLOCALIZE or
+HV_ACTION_ISALIAS. This additional data is passed into hv_common() in the
+C<action> field (B<not> the flags field). Intended for internal use only.
+
 =for apidoc hv_exists
 
 Returns a boolean indicating whether the specified hash key exists. The
@@ -442,6 +449,13 @@ store it somewhere.
 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
 information on how to use this function on tied hashes.
 
+=for apidoc hv_fetch_ent_for
+
+Identical to C<hv_fetch_ent()> but accepting an additional parameter which allows
+the caller to signal what the fetch is for, typically HV_ACTION_ISLOCALIZE or
+HV_ACTION_ISALIAS. This additional data is passed into hv_common() in the
+C<action> field (B<not> the flags field). Intended for internal use only.
+
 =cut
 */
 
@@ -878,6 +892,14 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
  }
  HeVAL(entry) = val;
  } else if (action & HV_FETCH_ISSTORE) {
+ if (SvREADONLY(hv) && SvREADONLY(HeVAL(entry))) {
+ hv_notallowed(flags, key, klen,
+ (action & HV_ACTION_ISLOCALIZE) ? "localize" :
+ (action & HV_ACTION_ISALIAS) ? "alias" : "modify",
+ "Attempt to %s readonly key %" SVf_QUOTEDPREFIX " in"
+ " restricted hash");
+ }
+
  SvREFCNT_dec(HeVAL(entry));
  HeVAL(entry) = val;
  }

hv.h

@@ -509,15 +509,24 @@ whether it is valid to call C<HvAUX()>.
  ->shared_he_he.he_valu.hent_refcount),	\
  hek)
 
+#define hv_store_ent_for(hv, keysv, val, hash, for_flags) \
+ ((HE *) hv_common((hv), (keysv), NULL, 0, 0, \
+ (HV_FETCH_ISSTORE | (for_flags)), (val), (hash)))
+
 #define hv_store_ent(hv, keysv, val, hash)	\
- ((HE *) hv_common((hv), (keysv), NULL, 0, 0, HV_FETCH_ISSTORE,	\
- (val), (hash)))
+ hv_store_ent_for(hv, keysv, val, hash, 0)
 
 #define hv_exists_ent(hv, keysv, hash)	\
  cBOOL(hv_common((hv), (keysv), NULL, 0, 0, HV_FETCH_ISEXISTS, 0, (hash)))
-#define hv_fetch_ent(hv, keysv, lval, hash)	\
+
+#define hv_fetch_ent_for(hv, keysv, lval, hash, for_flags) \
  ((HE *) hv_common((hv), (keysv), NULL, 0, 0,	\
- ((lval) ? HV_FETCH_LVALUE : 0), NULL, (hash)))
+ (((lval) ? HV_FETCH_LVALUE : 0)|(for_flags)), \
+ NULL, (hash)))
+
+#define hv_fetch_ent(hv, keysv, lval, hash) \
+ hv_fetch_ent_for(hv, keysv, lval, hash, 0)
+
 #define hv_delete_ent(hv, key, flags, hash)	\
  (MUTABLE_SV(hv_common((hv), (key), NULL, 0, 0, (flags) | HV_DELETE,	\
  NULL, (hash))))
@@ -681,18 +690,20 @@ instead of a string/length pair, and no precomputed hash.
 /* Hash actions
  * Passed in PERL_MAGIC_uvar calls
  */
-#define HV_DISABLE_UVAR_XKEY0x01
+#define HV_DISABLE_UVAR_XKEY 0x001
 /* We need to ensure that these don't clash with G_DISCARD, which is 2, as it
  is documented as being passed to hv_delete(). */
-#define HV_FETCH_ISSTORE0x04
-#define HV_FETCH_ISEXISTS0x08
-#define HV_FETCH_LVALUE0x10
-#define HV_FETCH_JUST_SV0x20
-#define HV_DELETE0x40
-#define HV_FETCH_EMPTY_HE0x80 /* Leave HeVAL null. */
+#define HV_FETCH_ISSTORE 0x004
+#define HV_FETCH_ISEXISTS 0x008
+#define HV_FETCH_LVALUE 0x010
+#define HV_FETCH_JUST_SV 0x020
+#define HV_DELETE 0x040
+#define HV_FETCH_EMPTY_HE 0x080 /* Leave HeVAL null. */
+#define HV_ACTION_ISLOCALIZE 0x100
+#define HV_ACTION_ISALIAS 0x200
 
 /* Must not conflict with HVhek_UTF8 */
-#define HV_NAME_SETALL0x02
+#define HV_NAME_SETALL 0x002
 
 /*
 =for apidoc newHV

pod/perldiag.pod

@@ -398,7 +398,7 @@ corrupted.
 
 =item Attempt to %s readonly key "%s" in restricted hash
 
-(F) The failing code has attempted to modify or
+(F) The failing code has attempted to localize, alias, modify or
 delete a key with a readonly value in a restricted hash.
 
 =item Attempt to %s disallowed key "%s" in restricted hash

pp.c

@@ -6915,13 +6915,19 @@ S_localise_aelem_lval(pTHX_ AV * const av, SV * const keysv,
 
 static void
 S_localise_helem_lval(pTHX_ HV * const hv, SV * const keysv,
- const bool can_preserve)
+ const bool can_preserve, U32 for_flags)
 {
  if (can_preserve ? hv_exists_ent(hv, keysv, 0) : TRUE) {
- HE * const he = hv_fetch_ent(hv, keysv, 1, 0);
+ HE * const he = hv_fetch_ent_for(hv, keysv, 1, 0, for_flags);
  SV ** const svp = he ? &HeVAL(he) : NULL;
  if (!svp || !*svp)
  Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(keysv));
+ if (SvREADONLY(hv) && SvREADONLY(*svp)) {
+ croak("Attempt to %s readonly key %" SVf_QUOTEDPREFIX
+ " in restricted hash",
+ (for_flags & HV_ACTION_ISLOCALIZE) ? "localize" : "alias",
+ keysv);
+ }
  save_helem_flags(hv, keysv, svp, 0);
  }
  else
@@ -7006,12 +7012,16 @@ PP(pp_refassign)
  av_store((AV *)left, SvIV(key), SvREFCNT_inc_simple_NN(SvRV(sv)));
  break;
  case SVt_PVHV:
- if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
- assert(key);
- S_localise_helem_lval(aTHX_ (HV *)left, key,
- SvCANEXISTDELETE(left));
+ {
+ HV *hv = (HV *)left;
+ if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
+ assert(key);
+ S_localise_helem_lval(aTHX_ hv, key,
+ SvCANEXISTDELETE(left), HV_ACTION_ISALIAS);
+ }
+ (void)hv_store_ent_for(hv, key,
+ SvREFCNT_inc_simple_NN(SvRV(sv)), 0, HV_ACTION_ISALIAS);
  }
- (void)hv_store_ent((HV *)left, key, SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
  }
  if (PL_op->op_flags & OPf_MOD)
  SETs(sv_2mortal(newSVsv(sv)));
@@ -7043,7 +7053,7 @@ PP(pp_lvref)
  if (SvTYPE(arg) == SVt_PVAV)
  S_localise_aelem_lval(aTHX_ (AV *)arg, elem, can_preserve);
  else
- S_localise_helem_lval(aTHX_ (HV *)arg, elem, can_preserve);
+ S_localise_helem_lval(aTHX_ (HV *)arg, elem, can_preserve, 0);
  }
  }
  else if (arg) {
@@ -7090,7 +7100,7 @@ PP(pp_lvrefslice)
  if (SvTYPE(av) == SVt_PVAV)
  S_localise_aelem_lval(aTHX_ av, elemsv, can_preserve);
  else
- S_localise_helem_lval(aTHX_ (HV *)av, elemsv, can_preserve);
+ S_localise_helem_lval(aTHX_ (HV *)av, elemsv, can_preserve, 0);
  }
  *MARK = newSV_type_mortal(SVt_PVMG);
  sv_magic(*MARK,(SV *)av,PERL_MAGIC_lvref,(char *)elemsv,HEf_SVKEY);

pp_hot.c

@@ -4011,6 +4011,10 @@ PP(pp_multideref)
  }
  else {
  if (localizing) {
+ if (SvREADONLY(hv) && SvREADONLY(*svp))
+ croak("Attempt to %s readonly key %"
+ SVf_QUOTEDPREFIX " in restricted hash",
+ "localize", keysv);
  if (HvNAME_get(hv) && isGV_or_RVCV(sv))
  save_gp(MUTABLE_GV(sv),
  !(PL_op->op_flags & OPf_SPECIAL));

proto.h

@@ -5,7 +5,7 @@ BEGIN {
  set_up_inc("../lib");
 }
 
-plan 167;
+plan 188;
 
 eval '\$x = \$y';
 like $@, qr/^Experimental aliasing via reference not enabled/,
@@ -651,3 +651,55 @@ pass("RT #123821");
  is("$h{one} $h{two} $h{three}", "102 200 301", "rt #133538 %h still aliased");
 
 }
+{
+ use feature 'refaliasing', 'declared_refs';
+ no warnings 'experimental::declared_refs';
+ my %hash = ( locked => "k1", normal => "k2" );
+ Internals::SvREADONLY(%hash, 1);
+ Internals::SvREADONLY($hash{locked}, 1);
+ my $href = \%hash;
+ my $val = "val";
+ ok(!eval { \$hash{locked} = \$val; 1},
+ "Eval alias of readonly hash key in restricted hash died");
+ like($@,qr/Attempt to alias readonly key "locked" in restricted hash at/,
+ "Got the error we expected");
+ ok(!eval { local \$hash{locked} = \$val; 1},
+ "Eval local alias of readonly hash key in restricted hash died");
+ like($@,qr/Attempt to alias readonly key "locked" in restricted hash at/,
+ "Got the error we expected");
+ ok(!eval { local $hash{locked} = $val; 1},
+ "Eval localization of readonly hash key in restricted hash died");
+ like($@,qr/Attempt to localize readonly key "locked" in restricted hash at/,
+ "Got the error we expected");
+ ok(!eval { \$href->{locked} = \$val; 1},
+ "Eval alias of readonly hashref key in restricted hash died");
+ like($@,qr/Attempt to alias readonly key "locked" in restricted hash at/,
+ "Got the error we expected");
+ ok(!eval { local \$href->{locked} = \$val; 1},
+ "Eval local alias of readonly hashref key in restricted hash died");
+ like($@,qr/Attempt to alias readonly key "locked" in restricted hash at/,
+ "Got the error we expected");
+ ok(!eval { local $href->{locked} = $val; 1},
+ "Eval localization of readonly hashref key in restricted hash died");
+ like($@,qr/Attempt to localize readonly key "locked" in restricted hash at/,
+ "Got the error we expected");
+ ok(eval { { local \$hash{normal} = \1; } 1},
+ "Eval unlocalization of aliased readonly hash key should not die");
+ ok(eval { { local $hash{normal} = 1; Internals::SvREADONLY($hash{normal},1); } 1},
+ "Eval unlocalization of readonly hash key should not die");
+ ok(eval { { local $hash{normal} = 1; Internals::SvREADONLY($hash{normal},1); } 1},
+ "Eval unlocalization of readonly hash key should not die");
+ ok(eval { { local \$hash->{normal} = \1; } 1},
+ "Eval unlocalization of aliased readonly hashref key should not die");
+ ok(eval { { local $hash->{normal} = 1; Internals::SvREADONLY($hash{normal},1); } 1},
+ "Eval unlocalization of readonly hashref key should not die");
+ ok(!eval { { local \$hash{normal} = \1; local \$hash{normal} = \2; } 1},
+ "Eval aliased localization of localized aliased readonly hash key should die");
+ like($@,qr/Attempt to alias readonly key \"normal\" in restricted hash/,
+ "Got the error we expected");
+ ok(!eval { { local $hash{normal} = 1; Internals::SvREADONLY($hash{normal},1);
+ local $hash{normal} = 2; } 1},
+ "Eval localization of localized readonly hash key should die");
+ like($@,qr/Attempt to localize readonly key \"normal\" in restricted hash/,
+ "Got the error we expected");
+}