Keep It Simple and Stupid version of readonly hash support.

 - Test for SvREAONLY(hv) at a few spots in hv.c
 - add the error message to perldiag.pod
 - (dubious) add access::readonly() to univeral.c
 - add test using above
 - fixup ext/B/t/stash.t to account for access:: existing

p4raw-id: //depot/perlio@12874

diff --git a/MANIFEST b/MANIFEST
index 1fca719..627c8f0 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -2021,6 +2021,7 @@ t/io/read.t                       See if read works
 t/io/tell.t                    See if file seeking works
 t/io/utf8.t                    See if file seeking works
 t/lib/1_compile.t              See if the various libraries and extensions compile
+t/lib/access.t                 See if access::readonly and readonly hashes work
 t/lib/commonsense.t            See if configuration meets basic needs
 t/lib/compmod.pl               Helper for 1_compile.t
 t/lib/dprof/test1_t            Perl code profiler tests

diff --git a/ext/B/t/stash.t b/ext/B/t/stash.t
index 88e4ca2..e0ac3e9 100755 (executable)
--- a/ext/B/t/stash.t
+++ b/ext/B/t/stash.t
@@ -37,7 +37,7 @@ $a =~ s/-uWin32,// if $^O eq 'MSWin32';
 $a =~ s/-uNetWare,// if $^O eq 'NetWare';
 $a =~ s/-u(Cwd|File|File::Copy|OS2),//g if $^O eq 'os2';
 $a =~ s/-uCwd,// if $^O eq 'cygwin';
-  $b = '-uCarp,-uCarp::Heavy,-uDB,-uExporter,-uExporter::Heavy,-uattributes,'
+  $b = '-uCarp,-uCarp::Heavy,-uDB,-uExporter,-uExporter::Heavy,-uaccess,-uattributes,'
      . '-umain,-ustrict,-uutf8,-uwarnings';
 if ($Is_VMS) {
     $a =~ s/-uFile,-uFile::Copy,//;

diff --git a/hv.c b/hv.c
index d3bb914..3a67c92 100644 (file)
--- a/hv.c
+++ b/hv.c
@@ -126,6 +126,25 @@ Perl_he_dup(pTHX_ HE *e, bool shared, CLONE_PARAMS* param)
 }
 #endif /* USE_ITHREADS */
 
+static void
+Perl_hv_notallowed(pTHX_ bool is_utf8, const char *key, I32 klen,
+                  const char *keysave)
+{
+    SV *sv = sv_newmortal();
+    if (key == keysave) {
+       sv_setpvn(sv, key, klen);
+    }
+    else {
+       /* Need to free saved eventually assign to mortal SV */
+       SV *sv = sv_newmortal();
+       sv_usepvn(sv, (char *) key, klen);
+    }
+    if (is_utf8) {
+       SvUTF8_on(sv);
+    }
+    Perl_croak(aTHX_ "Attempt to access to key '%_' in fixed hash",sv);
+}
+
 /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
  * contains an SV* */
 
@@ -237,6 +256,9 @@ Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen, I32 lval)
        }
     }
 #endif
+    if (SvREADONLY(hv)) {
+       Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
+    }
     if (lval) {                /* gonna assign to this, so it better be there */
        sv = NEWSV(61,0);
        if (key != keysave) { /* must be is_utf8 == 0 */
@@ -365,6 +387,9 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
        }
     }
 #endif
+    if (SvREADONLY(hv)) {
+       Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
+    }
     if (key != keysave)
        Safefree(key);
     if (lval) {                /* gonna assign to this, so it better be there */
@@ -482,6 +507,10 @@ Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, register U32 has
        return &HeVAL(entry);
     }
 
+    if (SvREADONLY(hv)) {
+       Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
+    }
+
     entry = new_HE();
     if (HvSHAREKEYS(hv))
        HeKEY_hek(entry) = share_hek(key, is_utf8?-klen:klen, hash);
@@ -596,6 +625,10 @@ Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash)
        return entry;
     }
 
+    if (SvREADONLY(hv)) {
+       Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
+    }
+
     entry = new_HE();
     if (HvSHAREKEYS(hv))
        HeKEY_hek(entry) = share_hek(key, is_utf8?-(I32)klen:klen, hash);
@@ -682,6 +715,10 @@ Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags)
        klen = tmplen;
     }
 
+    if (SvREADONLY(hv)) {
+       Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
+    }
+
     PERL_HASH(hash, key, klen);
 
     /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
@@ -782,6 +819,10 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
     if (is_utf8)
        key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
 
+    if (SvREADONLY(hv)) {
+       Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
+    }
+
     if (!hash)
        PERL_HASH(hash, key, klen);
 

diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 838b545..6c6655c 100644 (file)
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -187,6 +187,13 @@ know which context to supply to the right side.
 (F) When C<vec> is called in an lvalue context, the second argument must be
 greater than or equal to zero.
 
+=item Attempt to access to key '%_' in fixed hash
+
+(F) A hash has been marked as READONLY at the C level to turn it
+into a "record" with a fixed set of keys. The failing code
+has attempted to get or set the value of a key which does not
+exist or to delete a key.
+
 =item Attempt to bless into a reference
 
 (F) The CLASSNAME argument to the bless() operator is expected to be
@@ -3968,15 +3975,15 @@ program.
 =item Using a hash as a reference is deprecated
 
 (D deprecated) You tried to use a hash as a reference, as in
-C<< %foo->{"bar"} >> or C<< %$ref->{"hello"} >>.  Versions of perl <= 5.6.1 
-used to allow this syntax, but shouldn't have. It is now deprecated, and will 
+C<< %foo->{"bar"} >> or C<< %$ref->{"hello"} >>.  Versions of perl <= 5.6.1
+used to allow this syntax, but shouldn't have. It is now deprecated, and will
 be removed in a future version.
 
 =item Using an array as a reference is deprecated
 
 (D deprecated) You tried to use an array as a reference, as in
-C<< @foo->[23] >> or C<< @$ref->[99] >>.  Versions of perl <= 5.6.1 used to 
-allow this syntax, but shouldn't have. It is now deprecated, and will be 
+C<< @foo->[23] >> or C<< @$ref->[99] >>.  Versions of perl <= 5.6.1 used to
+allow this syntax, but shouldn't have. It is now deprecated, and will be
 removed in a future version.
 
 =item Value of %s can be "0"; test with defined()
@@ -4152,7 +4159,7 @@ Use a filename instead.
 
 (F) And you probably never will, because you probably don't have the
 sources to your kernel, and your vendor probably doesn't give a rip
-about what you want.  Your best bet is to put a setuid C wrapper around 
+about what you want.  Your best bet is to put a setuid C wrapper around
 your script.
 
 =item You need to quote "%s"

diff --git a/t/lib/access.t b/t/lib/access.t
new file mode 100644 (file)
index 0000000..b82b3e9
--- /dev/null
+++ b/t/lib/access.t
@@ -0,0 +1,71 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+}
+
+$| = 1;
+print "1..15\n";
+
+my $t = 1;
+
+sub ok
+{
+ my $val = shift;
+ if ($val)
+  {
+   print "ok $t\n";
+  }
+ else
+  {
+   my ($pack,$file,$line) = caller;
+   print "not ok $t # $file:$line\n";
+  }
+ $t++;
+}
+
+my %hash = ( one => 1, two => 2);;
+ok(!access::readonly(%hash));
+
+ok(!access::readonly(%hash,1));
+
+eval { $hash{'three'} = 3 };
+#warn "$@";
+ok($@ =~ /^Attempt to access to key 'three' in fixed hash/);
+
+eval { print "# oops"  if $hash{'four'}};
+#warn "$@";
+ok($@ =~ /^Attempt to access to key 'four' in fixed hash/);
+
+eval { $hash{"\x{2323}"} = 3 };
+#warn "$@";
+ok($@ =~ /^Attempt to access to key '(.*)' in fixed hash/);
+#ok(ord($1) == 0x2323);
+
+eval { delete $hash{'one'}};
+#warn "$@";
+ok($@ =~ /^Attempt to access to key 'one' in fixed hash/);
+
+ok(exists $hash{'one'});
+
+ok(!exists $hash{'three'});
+
+ok(access::readonly(%hash,0));
+
+ok(!access::readonly(%hash));
+
+my $scalar = 1;
+ok(!access::readonly($scalar));
+
+ok(!access::readonly($scalar,1));
+
+eval { $scalar++ };
+#warn $@;
+ok($@ =~ /^Modification of a read-only value attempted/);
+
+ok(access::readonly($scalar,0));
+
+ok(!access::readonly($scalar));
+
+

diff --git a/universal.c b/universal.c
index a2a3e4d..868fe55 100644 (file)
--- a/universal.c
+++ b/universal.c
@@ -142,6 +142,7 @@ XS(XS_utf8_upgrade);
 XS(XS_utf8_downgrade);
 XS(XS_utf8_unicode_to_native);
 XS(XS_utf8_native_to_unicode);
+XS(XS_access_readonly);
 
 void
 Perl_boot_core_UNIVERSAL(pTHX)
@@ -158,6 +159,7 @@ Perl_boot_core_UNIVERSAL(pTHX)
     newXS("utf8::downgrade", XS_utf8_downgrade, file);
     newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
     newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
+    newXSproto("access::readonly",XS_access_readonly, file, "\\[$%@];$");
 }
 
 
@@ -425,4 +427,22 @@ XS(XS_utf8_unicode_to_native)
  XSRETURN(1);
 }
 
+XS(XS_access_readonly)
+{
+    dXSARGS;
+    SV *sv = SvRV(ST(0));
+    IV old = SvREADONLY(sv);
+    if (items == 2) {
+       if (SvTRUE(ST(1))) {
+           SvREADONLY_on(sv);
+       }
+       else {
+           SvREADONLY_off(sv);
+       }
+    }
+    if (old)
+       XSRETURN_YES;
+    else
+       XSRETURN_NO;
+}