diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rwxr-xr-x | ext/B/t/stash.t | 2 | ||||
| -rw-r--r-- | hv.c | 41 | ||||
| -rw-r--r-- | pod/perldiag.pod | 17 | ||||
| -rw-r--r-- | t/lib/access.t | 71 | ||||
| -rw-r--r-- | universal.c | 20 |
6 files changed, 146 insertions, 6 deletions
@@ -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 88e4ca2492..e0ac3e9ff9 100755 --- 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,//; @@ -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 838b54554d..6c6655c2da 100644 --- 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 index 0000000000..b82b3e9271 --- /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 a2a3e4d781..868fe55140 100644 --- 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; +} |