Make hv_notallowed a static as suggested by Nicholas Clark;

and synchronize the nomenclature to talk about restricted
(not fixed) hashes.

p4raw-id: //depot/perl@15758

diff --git a/embed.fnc b/embed.fnc
index a5b29c2..d1a8185 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -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)

diff --git a/embed.h b/embed.h
index 6d0049f..3dc9e1f 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -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)

diff --git a/hv.c b/hv.c
index d9f640b..dd9353d 100644 (file)
--- a/hv.c
+++ b/hv.c
@@ -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 0fe3128..1046e32 100644 (file)
--- 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 6bcd87a..f22aa80 100644 (file)
--- 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
 

diff --git a/proto.h b/proto.h
index 7b41013..3bd1a61 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -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)