diff options
| -rw-r--r-- | embed.fnc | 1 | ||||
| -rw-r--r-- | embed.h | 14 | ||||
| -rw-r--r-- | hv.c | 59 | ||||
| -rw-r--r-- | lib/Hash/Util.t | 24 | ||||
| -rw-r--r-- | pod/perldiag.pod | 19 | ||||
| -rw-r--r-- | proto.h | 7 |
6 files changed, 70 insertions, 54 deletions
@@ -994,6 +994,7 @@ s |SV** |hv_store_flags |HV* tb|const char* key|I32 klen|SV* val \ |U32 hash|int flags s |SV** |hv_fetch_flags |HV* tb|const char* key|I32 klen|I32 lval \ |int flags +s |void |hv_notallowed |int flags|const char *key|I32 klen|const char *msg #endif #if defined(PERL_IN_MG_C) || defined(PERL_DECL_PROT) @@ -922,8 +922,13 @@ #define more_he S_more_he #define new_he S_new_he #define del_he S_del_he -#define save_hek S_save_hek +#define save_hek_flags S_save_hek_flags #define hv_magic_check S_hv_magic_check +#define unshare_hek_or_pvn S_unshare_hek_or_pvn +#define share_hek_flags S_share_hek_flags +#define hv_store_flags S_hv_store_flags +#define hv_fetch_flags S_hv_fetch_flags +#define hv_notallowed S_hv_notallowed #endif #if defined(PERL_IN_MG_C) || defined(PERL_DECL_PROT) #define save_magic S_save_magic @@ -2471,8 +2476,13 @@ #define more_he() S_more_he(aTHX) #define new_he() S_new_he(aTHX) #define del_he(a) S_del_he(aTHX_ a) -#define save_hek(a,b,c) S_save_hek(aTHX_ a,b,c) +#define save_hek_flags(a,b,c,d) S_save_hek_flags(aTHX_ a,b,c,d) #define hv_magic_check(a,b,c) S_hv_magic_check(aTHX_ a,b,c) +#define unshare_hek_or_pvn(a,b,c,d) S_unshare_hek_or_pvn(aTHX_ a,b,c,d) +#define share_hek_flags(a,b,c,d) S_share_hek_flags(aTHX_ a,b,c,d) +#define hv_store_flags(a,b,c,d,e,f) S_hv_store_flags(aTHX_ a,b,c,d,e,f) +#define hv_fetch_flags(a,b,c,d,e) S_hv_fetch_flags(aTHX_ a,b,c,d,e) +#define hv_notallowed(a,b,c,d) S_hv_notallowed(aTHX_ a,b,c,d) #endif #if defined(PERL_IN_MG_C) || defined(PERL_DECL_PROT) #define save_magic(a,b) S_save_magic(aTHX_ a,b) @@ -121,10 +121,10 @@ Perl_he_dup(pTHX_ HE *e, bool shared, CLONE_PARAMS* param) #endif /* USE_ITHREADS */ static void -Perl_hv_notallowed(pTHX_ int flags, const char *key, I32 klen, - const char *msg) +S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen, + const char *msg) { - SV *sv = sv_newmortal(); + SV *sv = sv_newmortal(), *esv = sv_newmortal(); if (!(flags & HVhek_FREEKEY)) { sv_setpvn(sv, key, klen); } @@ -136,7 +136,8 @@ Perl_hv_notallowed(pTHX_ int flags, const char *key, I32 klen, if (flags & HVhek_UTF8) { SvUTF8_on(sv); } - Perl_croak(aTHX_ msg, sv); + Perl_sv_setpvf(aTHX_ esv, "Attempt to %s a restricted hash", msg); + Perl_croak(aTHX_ SvPVX(esv), sv); } /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot @@ -305,9 +306,9 @@ S_hv_fetch_flags(pTHX_ HV *hv, const char *key, I32 klen, I32 lval, int flags) } #endif if (!entry && SvREADONLY(hv)) { - Perl_hv_notallowed(aTHX_ flags, key, klen, - "Attempt to access disallowed key '%"SVf"' in a fixed hash" - ); + S_hv_notallowed(aTHX_ flags, key, klen, + "access disallowed key '%"SVf"' in" + ); } if (lval) { /* gonna assign to this, so it better be there */ sv = NEWSV(61,0); @@ -458,9 +459,9 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash) } #endif if (!entry && SvREADONLY(hv)) { - Perl_hv_notallowed(aTHX_ flags, key, klen, - "Attempt to access disallowed key '%"SVf"' in a fixed hash" - ); + S_hv_notallowed(aTHX_ flags, key, klen, + "access disallowed key '%"SVf"' in" + ); } if (flags & HVhek_FREEKEY) Safefree(key); @@ -621,9 +622,9 @@ S_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val, } if (SvREADONLY(hv)) { - Perl_hv_notallowed(aTHX_ flags, key, klen, - "Attempt to access disallowed key '%"SVf"' to a fixed hash" - ); + S_hv_notallowed(aTHX_ flags, key, klen, + "access disallowed key '%"SVf"' to" + ); } entry = new_HE(); @@ -768,9 +769,9 @@ Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, U32 hash) } if (SvREADONLY(hv)) { - Perl_hv_notallowed(aTHX_ flags, key, klen, - "Attempt to access disallowed key '%"SVf"' to a fixed hash" - ); + S_hv_notallowed(aTHX_ flags, key, klen, + "access disallowed key '%"SVf"' to" + ); } entry = new_HE(); @@ -903,9 +904,9 @@ Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags) } } else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) { - Perl_hv_notallowed(aTHX_ k_flags, key, klen, - "Attempt to delete readonly key '%"SVf"' from a fixed hash" - ); + S_hv_notallowed(aTHX_ k_flags, key, klen, + "delete readonly key '%"SVf"' from" + ); } if (flags & G_DISCARD) @@ -941,9 +942,9 @@ Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags) return sv; } if (SvREADONLY(hv)) { - Perl_hv_notallowed(aTHX_ k_flags, key, klen, - "Attempt to access disallowed key '%"SVf"' from a fixed hash" - ); + S_hv_notallowed(aTHX_ k_flags, key, klen, + "access disallowed key '%"SVf"' from" + ); } if (k_flags & HVhek_FREEKEY) @@ -1059,9 +1060,9 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash) return Nullsv; } else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) { - Perl_hv_notallowed(aTHX_ k_flags, key, klen, - "Attempt to delete readonly key '%"SVf"' from a fixed hash" - ); + S_hv_notallowed(aTHX_ k_flags, key, klen, + "delete readonly key '%"SVf"' from" + ); } if (flags & G_DISCARD) @@ -1097,9 +1098,9 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash) return sv; } if (SvREADONLY(hv)) { - Perl_hv_notallowed(aTHX_ k_flags, key, klen, - "Attempt to delete disallowed key '%"SVf"' from a fixed hash" - ); + S_hv_notallowed(aTHX_ k_flags, key, klen, + "delete disallowed key '%"SVf"' from" + ); } if (k_flags & HVhek_FREEKEY) @@ -1619,7 +1620,7 @@ Perl_hv_clear(pTHX_ HV *hv) return; if(SvREADONLY(hv)) { - Perl_croak(aTHX_ "Attempt to clear a fixed hash"); + Perl_croak(aTHX_ "Attempt to clear a restricted hash"); } xhv = (XPVHV*)SvANY(hv); diff --git a/lib/Hash/Util.t b/lib/Hash/Util.t index 0fe3128172..1046e32c54 100644 --- a/lib/Hash/Util.t +++ b/lib/Hash/Util.t @@ -23,7 +23,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 fixed hash/, +like( $@, qr/^Attempt to access disallowed key 'baz' in a restricted hash/, 'lock_keys()'); is( $hash{bar}, 23 ); ok( !exists $hash{baz} ); @@ -34,18 +34,18 @@ $hash{bar} = 69; is( $hash{bar}, 69 ); eval { () = $hash{i_dont_exist} }; -like( $@, qr/^Attempt to access disallowed key 'i_dont_exist' in a fixed hash/ ); +like( $@, qr/^Attempt to access disallowed key 'i_dont_exist' in a restricted hash/ ); lock_value(%hash, 'locked'); eval { print "# oops" if $hash{four} }; -like( $@, qr/^Attempt to access disallowed key 'four' in a fixed hash/ ); +like( $@, qr/^Attempt to access disallowed key 'four' in a restricted hash/ ); eval { $hash{"\x{2323}"} = 3 }; -like( $@, qr/^Attempt to access disallowed key '(.*)' in a fixed hash/, +like( $@, qr/^Attempt to access disallowed key '(.*)' in a restricted hash/, 'wide hex key' ); eval { delete $hash{locked} }; -like( $@, qr/^Attempt to delete readonly key 'locked' from a fixed hash/, +like( $@, qr/^Attempt to delete readonly key 'locked' from a restricted hash/, 'trying to delete a locked key' ); eval { $hash{locked} = 42; }; like( $@, qr/^Modification of a read-only value attempted/, @@ -53,7 +53,7 @@ like( $@, qr/^Modification of a read-only value attempted/, is( $hash{locked}, 'yep' ); eval { delete $hash{I_dont_exist} }; -like( $@, qr/^Attempt to delete disallowed key 'I_dont_exist' from a fixed hash/, +like( $@, qr/^Attempt to delete disallowed key 'I_dont_exist' from a restricted hash/, 'trying to delete a key that doesnt exist' ); ok( !exists $hash{I_dont_exist} ); @@ -81,7 +81,7 @@ TODO: { lock_keys(%hash); lock_value(%hash, 'locked'); eval { %hash = ( wubble => 42 ) }; # we know this will bomb - like( $@, qr/^Attempt to clear a fixed hash/ ); + like( $@, qr/^Attempt to clear a restricted hash/ ); eval { unlock_value(%hash, 'locked') }; # but this shouldn't is( $@, '', 'unlock_value() after denied assignment' ); @@ -97,7 +97,7 @@ TODO: { lock_value(%hash, 'RO'); eval { %hash = (KEY => 1) }; - like( $@, qr/^Attempt to clear a fixed hash/ ); + like( $@, qr/^Attempt to clear a restricted hash/ ); } # TODO: This should be allowed but it might require putting extra @@ -106,7 +106,7 @@ TODO: { my %hash = (KEY => 1, RO => 2); lock_keys(%hash); eval { %hash = (KEY => 1, RO => 2) }; - like( $@, qr/^Attempt to clear a fixed hash/ ); + like( $@, qr/^Attempt to clear a restricted hash/ ); } @@ -118,7 +118,7 @@ TODO: { $hash{foo} = 42; is( keys %hash, 1 ); eval { $hash{wibble} = 42 }; - like( $@, qr/^Attempt to access disallowed key 'wibble' in a fixed hash/, + like( $@, qr/^Attempt to access disallowed key 'wibble' in a restricted hash/, ' locked'); unlock_keys(%hash); @@ -137,7 +137,7 @@ TODO: { is( $@, '' ); eval { $hash{wibble} = 23 }; - like( $@, qr/^Attempt to access disallowed key 'wibble' in a fixed hash/, ' locked' ); + like( $@, qr/^Attempt to access disallowed key 'wibble' in a restricted hash/, ' locked' ); } @@ -167,4 +167,4 @@ TODO: { lock_keys(%ENV); eval { () = $ENV{I_DONT_EXIST} }; -like( $@, qr/^Attempt to access disallowed key 'I_DONT_EXIST' in a fixed hash/, 'locked %ENV'); +like( $@, qr/^Attempt to access disallowed key 'I_DONT_EXIST' in a restricted hash/, 'locked %ENV'); diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 6bcd87a46e..f22aa80f75 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -1,4 +1,3 @@ -//depot/perl/pod/perldiag.pod#272 - edit change 14824 (text) =head1 NAME perldiag - various Perl diagnostics @@ -183,26 +182,26 @@ spots. This is now heavily deprecated. must either both be scalars or both be lists. Otherwise Perl won't know which context to supply to the right side. -=item Attempt to access disallowed key '%s' in a fixed hash +=item Attempt to access disallowed key '%s' in a 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 fixed hash. +the current set of allowed keys of a restricted hash. -=item Attempt to clear a fixed hash +=item Attempt to clear a restricted hash -(F) It is currently not allowed to clear a fixed hash, even if the +(F) It is currently not allowed to clear a restricted hash, even if the new hash would contain the same keys as before. This may change in the future. -=item Attempt to delete readonly key '%s' from a fixed hash +=item Attempt to delete readonly key '%s' from a restricted hash (F) The failing code attempted to delete a key whose value has been -declared readonly from a fixed hash. +declared readonly from a restricted hash. -=item Attempt to delete disallowed key '%s' from a fixed hash +=item Attempt to delete disallowed key '%s' from a restricted hash -(F) The failing code attempted to delete from a fixed hash a key which -is not in its key set. +(F) The failing code attempted to delete from a restricted hash a key +which is not in its key set. =item Attempt to bless into a reference @@ -1033,8 +1033,13 @@ STATIC void S_hfreeentries(pTHX_ HV *hv); STATIC void S_more_he(pTHX); STATIC HE* S_new_he(pTHX); STATIC void S_del_he(pTHX_ HE *p); -STATIC HEK* S_save_hek(pTHX_ const char *str, I32 len, U32 hash); +STATIC HEK* S_save_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags); STATIC void S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store); +STATIC void S_unshare_hek_or_pvn(pTHX_ HEK* hek, const char* sv, I32 len, U32 hash); +STATIC HEK* S_share_hek_flags(pTHX_ const char* sv, I32 len, U32 hash, int flags); +STATIC SV** S_hv_store_flags(pTHX_ HV* tb, const char* key, I32 klen, SV* val, U32 hash, int flags); +STATIC SV** S_hv_fetch_flags(pTHX_ HV* tb, const char* key, I32 klen, I32 lval, int flags); +STATIC void S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen, const char *msg); #endif #if defined(PERL_IN_MG_C) || defined(PERL_DECL_PROT) |