pp.c/pp_hot.c - prevent aliasing or localizing read only value in a restricted hash

dist/Storable/t/downgrade.t

@@ -109,7 +109,7 @@ sub test_locked_hash {
  'trying to change a locked key' );
  is ($hash->{$key}, $value, "hash should not change?");
  eval {$hash->{use} = 'perl'};
- like( $@, "/^Attempt to access disallowed key 'use' in a restricted hash/",
+ like( $@, q{/^Attempt to access disallowed key ["']use["'] in(?: a)? restricted hash/},
  'trying to add another key' );
  ok (eq_array([keys %$hash], \@keys), "Still the same keys?");
 }
@@ -123,7 +123,7 @@ sub test_restricted_hash {
  'trying to change a restricted key' );
  is ($hash->{$key}, reverse ($value), "hash should change");
  eval {$hash->{use} = 'perl'};
- like( $@, "/^Attempt to access disallowed key 'use' in a restricted hash/",
+ like( $@, q{/^Attempt to access disallowed key ["']use["'] in(?: a)? restricted hash/},
  'trying to add another key' );
  ok (eq_array([keys %$hash], \@keys), "Still the same keys?");
 }

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	\
@@ -4283,6 +4295,7 @@ ST	|void	|hv_magic_check |NN HV *hv	\
 Sr	|void	|hv_notallowed	|int flags	\
 |NN const char *key	\
 |I32 klen	\
+|NN const char *action	\
 |NN const char *msg
 S	|SV *	|refcounted_he_value	\
 |NN const struct refcounted_he *he

embed.h

@@ -1254,7 +1254,7 @@
 # define hv_free_ent_ret(a) S_hv_free_ent_ret(aTHX_ a)
 # define hv_free_entries(a) S_hv_free_entries(aTHX_ a)
 # define hv_magic_check S_hv_magic_check
-# define hv_notallowed(a,b,c,d)  S_hv_notallowed(aTHX_ a,b,c,d)
+# define hv_notallowed(a,b,c,d,e) S_hv_notallowed(aTHX_ a,b,c,d,e)
 # define refcounted_he_value(a) S_refcounted_he_value(aTHX_ a)
 # define save_hek_flags S_save_hek_flags
 # define share_hek_flags(a,b,c,d) S_share_hek_flags(aTHX_ a,b,c,d)

ext/Hash-Util/t/Util.t

@@ -56,7 +56,7 @@ foreach my $func (@Exported_Funcs) {
 my %hash = (foo => 42, bar => 23, locked => 'yep');
 lock_keys(%hash);
 eval { $hash{baz} = 99; };
-like( $@, qr/^Attempt to access disallowed key 'baz' in a restricted hash/,
+like( $@, qr/^Attempt to access disallowed key "baz" in restricted hash/,
  'lock_keys()');
 is( $hash{bar}, 23, '$hash{bar} == 23' );
 ok( !exists $hash{baz},'!exists $hash{baz}' );
@@ -67,28 +67,28 @@ $hash{bar} = 69;
 is( $hash{bar}, 69 ,'$hash{bar} == 69');
 
 eval { () = $hash{i_dont_exist} };
-like( $@, qr/^Attempt to access disallowed key 'i_dont_exist' in a restricted hash/,
+like( $@, qr/^Attempt to access disallowed key "i_dont_exist" in restricted hash/,
  'Disallowed 1' );
 
 lock_value(%hash, 'locked');
 eval { print "# oops" if $hash{four} };
-like( $@, qr/^Attempt to access disallowed key 'four' in a restricted hash/,
+like( $@, qr/^Attempt to access disallowed key "four" in restricted hash/,
  'Disallowed 2' );
 
 eval { $hash{"\x{2323}"} = 3 };
-like( $@, qr/^Attempt to access disallowed key '(.*)' in a restricted hash/,
+like( $@, qr/^Attempt to access disallowed key "(.*)" in restricted hash/,
  'wide hex key' );
 
 eval { delete $hash{locked} };
-like( $@, qr/^Attempt to delete readonly key 'locked' from a restricted hash/,
+like( $@, qr/^Attempt to delete readonly key "locked" in restricted hash/,
  'trying to delete a locked key' );
 eval { $hash{locked} = 42; };
 like( $@, qr/^Modification of a read-only value attempted/,
  'trying to change a locked key' );
 is( $hash{locked}, 'yep', '$hash{locked} is yep' );
 
 eval { delete $hash{I_dont_exist} };
-like( $@, qr/^Attempt to delete disallowed key 'I_dont_exist' from a restricted hash/,
+like( $@, qr/^Attempt to delete disallowed key "I_dont_exist" in restricted hash/,
  'trying to delete a key that doesnt exist' );
 
 ok( !exists $hash{I_dont_exist},'!exists $hash{I_dont_exist}' );
@@ -113,7 +113,7 @@ is( $hash{locked}, 42, 'unlock_value' );
 
  lock_keys(%hash);
  eval { %hash = ( wubble => 42 ) }; # we know this will bomb
- like( $@, qr/^Attempt to access disallowed key 'wubble'/,'Disallowed 3' );
+ like( $@, qr/^Attempt to access disallowed key "wubble"/,'Disallowed 3' );
  unlock_keys(%hash);
 }
 
@@ -123,7 +123,7 @@ is( $hash{locked}, 42, 'unlock_value' );
  lock_value(%hash, 'RO');
 
  eval { %hash = (KEY => 1) };
- like( $@, qr/^Attempt to delete readonly key 'RO' from a restricted hash/,
+ like( $@, qr/^Attempt to delete readonly key "RO" in restricted hash/,
  'attempt to delete readonly key from restricted hash' );
 }
 
@@ -141,7 +141,7 @@ is( $hash{locked}, 42, 'unlock_value' );
  $hash{foo} = 42;
  is( keys %hash, 1, '1 element in hash' );
  eval { $hash{wibble} = 42 };
- like( $@, qr/^Attempt to access disallowed key 'wibble' in a restricted hash/,
+ like( $@, qr/^Attempt to access disallowed key "wibble" in restricted hash/,
  'write threw error (locked)');
 
  unlock_keys(%hash);
@@ -159,7 +159,7 @@ is( $hash{locked}, 42, 'unlock_value' );
  is( $@, '','No error 1' );
 
  eval { $hash{wibble} = 23 };
- like( $@, qr/^Attempt to access disallowed key 'wibble' in a restricted hash/,
+ like( $@, qr/^Attempt to access disallowed key "wibble" in restricted hash/,
  'locked "wibble"' );
 }
 
@@ -203,7 +203,7 @@ lock_keys(%ENV);
 eval { () = $ENV{I_DONT_EXIST} };
 like(
  $@,
- qr/^Attempt to access disallowed key 'I_DONT_EXIST' in a restricted hash/,
+ qr/^Attempt to access disallowed key "I_DONT_EXIST" in restricted hash/,
  'locked %ENV'
 );
 unlock_keys(%ENV); # Test::Builder cannot print test failures otherwise
@@ -232,11 +232,11 @@ unlock_keys(%ENV); # Test::Builder cannot print test failures otherwise
 
  eval {$hash{zeroeth} = 0};
  like ($@,
- qr/^Attempt to access disallowed key 'zeroeth' in a restricted hash/,
+ qr/^Attempt to access disallowed key "zeroeth" in restricted hash/,
  'locked key never mentioned before should fail');
  eval {$hash{first} = -1};
  like ($@,
- qr/^Attempt to access disallowed key 'first' in a restricted hash/,
+ qr/^Attempt to access disallowed key "first" in restricted hash/,
  'previously locked place holders should also fail');
  is (scalar keys %hash, 0, "and therefore there are no keys");
  $hash{second} = 1;
@@ -257,7 +257,7 @@ unlock_keys(%ENV); # Test::Builder cannot print test failures otherwise
 
  eval {$hash{second} = -1};
  like ($@,
- qr/^Attempt to access disallowed key 'second' in a restricted hash/,
+ qr/^Attempt to access disallowed key "second" in restricted hash/,
  'previously locked place holders should fail');
 
  is ($hash{void}, undef,

hv.c

@@ -301,14 +301,14 @@ Perl_he_dup(pTHX_ const HE *e, bool shared, CLONE_PARAMS* param)
 
 static void
 S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen,
- const char *msg)
+ const char *action, const char *msg)
 {
+ PERL_ARGS_ASSERT_HV_NOTALLOWED;
+
  /* Straight to SVt_PVN here, as needed by sv_setpvn_fresh and
  * sv_usepvn would otherwise call it */
  SV * const sv = newSV_type_mortal(SVt_PV);
 
- PERL_ARGS_ASSERT_HV_NOTALLOWED;
-
  if (!(flags & HVhek_FREEKEY)) {
  sv_setpvn_fresh(sv, key, klen);
  }
@@ -320,7 +320,7 @@ S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen,
  if (flags & HVhek_UTF8) {
  SvUTF8_on(sv);
  }
- Perl_croak(aTHX_ msg, SVfARG(sv));
+ Perl_croak(aTHX_ msg, action, SVfARG(sv));
 }
 
 /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
@@ -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;
  }
@@ -912,9 +934,9 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
 #endif
 
  if (!entry && SvREADONLY(hv) && !(action & HV_FETCH_ISEXISTS)) {
- hv_notallowed(flags, key, klen,
- "Attempt to access disallowed key '%" SVf "' in"
- " a restricted hash");
+ hv_notallowed(flags, key, klen, "access",
+ "Attempt to %s disallowed key %" SVf_QUOTEDPREFIX " in"
+ " restricted hash");
  }
  if (!(action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE))) {
  /* Not doing some form of store, so return failure. */
@@ -1402,9 +1424,9 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
  return NULL;
  }
  if (SvREADONLY(hv) && sv && SvREADONLY(sv)) {
- hv_notallowed(k_flags, key, klen,
- "Attempt to delete readonly key '%" SVf "' from"
- " a restricted hash");
+ hv_notallowed(k_flags, key, klen, "delete",
+ "Attempt to %s readonly key %" SVf_QUOTEDPREFIX " in"
+ " restricted hash");
  }
 
  /*
@@ -1558,9 +1580,9 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
 
  not_found:
  if (SvREADONLY(hv)) {
- hv_notallowed(k_flags, key, klen,
- "Attempt to delete disallowed key '%" SVf "' from"
- " a restricted hash");
+ hv_notallowed(k_flags, key, klen, "delete",
+ "Attempt to %s disallowed key %" SVf_QUOTEDPREFIX " in"
+ " restricted hash");
  }
 
  if (k_flags & HVhek_FREEKEY)
@@ -2019,7 +2041,8 @@ Perl_hv_clear(pTHX_ HV *hv)
  if (SvREADONLY(HeVAL(entry))) {
  SV* const keysv = hv_iterkeysv(entry);
  Perl_croak_nocontext(
- "Attempt to delete readonly key '%" SVf "' from a restricted hash",
+ "Attempt to delete readonly key %" SVf_QUOTEDPREFIX
+ " in restricted hash",
  (void*)keysv);
  }
  SvREFCNT_dec_NN(HeVAL(entry));

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_ISSTORE	0x04
-#define HV_FETCH_ISEXISTS	0x08
-#define HV_FETCH_LVALUE	0x10
-#define HV_FETCH_JUST_SV	0x20
-#define HV_DELETE	0x40
-#define HV_FETCH_EMPTY_HE	0x80 /* 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

@@ -308,7 +308,7 @@ or
 (F) You wrote C<< require <file> >> when you should have written
 C<require 'file'>.
 
-=item Attempt to access disallowed key '%s' in a restricted hash
+=item Attempt to access disallowed key "%s" in restricted hash
 
 (F) The failing code has attempted to get or set a key which is not in
 the current set of allowed keys of a restricted hash.
@@ -351,12 +351,12 @@ Freed values are not supposed to be visible to Perl code. This
 can also happen if XS code calls C<av_clear> from a custom magic
 callback on the array.
 
-=item Attempt to delete disallowed key '%s' from a restricted hash
+=item Attempt to delete disallowed key "%s" in restricted hash
 
 (F) The failing code attempted to delete from a restricted hash a key
 which is not in its key set.
 
-=item Attempt to delete readonly key '%s' from a restricted hash
+=item Attempt to delete readonly key "%s" in restricted hash
 
 (F) The failing code attempted to delete a key whose value has been
 declared readonly from a restricted hash.
@@ -396,6 +396,16 @@ that SvREFCNT_inc() was called too few times, or that the SV was
 mortalized when it shouldn't have been, or that memory has been
 corrupted.
 
+=item Attempt to %s readonly key "%s" in restricted hash
+
+(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
+
+(F) The failing code has attempted to access or delete a key that
+is not registered as usable in a restricted hash.
+
 =item Attempt to pack pointer to temporary value
 
 (W pack) You tried to pass a temporary value (like the result of a