ext/Data/Dumper/t/dumper.t See if Data::Dumper works
ext/Data/Dumper/t/overload.t See if Data::Dumper works for overloaded data
ext/Data/Dumper/Todo Data pretty printer, futures
+ext/Data/Util/Changes Data/Hash::Util, Change log
+ext/Data/Util/Makefile.PL Data/Hash::Util, Makefile.PL
+ext/Data/Util/Util.xs Data/Hash::Util, Data::Util XS code
+ext/Data/Util/lib/Data/Util.pm Data/Hash::Util, Data::Util
+ext/Data/Util/lib/Hash/Util.pm Data/Hash::Util, Hash::Util
+ext/Data/Util/t/Data.t Data/Hash::Util, Data::Util test
+ext/Data/Util/t/Hash.t Data/Hash::Util, Hash::Util test
ext/DB_File/Changes Berkeley DB extension change log
ext/DB_File/dbinfo Berkeley DB database version checker
ext/DB_File/DB_File.pm Berkeley DB extension Perl module
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
--- /dev/null
+0.04 Sun Mar 10 13:37:08 EST 2002
+ * Bugs in the restricted hash implementation have been fixed. All
+ tests should pass on a perl sometime after about 15160
+ * Minimum version is now 5.7.3
+ - Changed diagnostic expecations to match new restricted hash
+ diagnostics.
+
+0.03 Sat Mar 9 20:11:00 EST 2002
+ *** NOTE *** There are known failures in t/Hash.t. These are
+ due to bugs in perl's restricted hash implementation. They have
+ been left failing so Those That Know How To Fix It know where
+ the bugs are.
+
+ * Data::Util::readonly() is now sv_readonly_flag() to make its
+ function less ambiguous.
+ * Hash::Util::lock_key/unlock_key is now lock_value/unlock_value
+ to make its functionality less ambiguous. It also takes
+ somewhat different arguments.
+ * Added lock_hash(), unlock_hash().
+
+0.02 Wed Feb 27 23:35:58 EST 2002
+ * lock_keys(%hash, @keys) implemented
+ * tarball name changed to the somewhat more proper Data-Hash-Utils
+
+0.01 Tue Feb 26 23:18:03 EST 2002
+ - First released version
+ - There are some failures at the end of Hash.t
--- /dev/null
+# A template for Makefile.PL.
+# - Set the $PACKAGE variable to the name of your module.
+# - Set $LAST_API_CHANGE to reflect the last version you changed the API
+# of your module.
+# - Fill in your dependencies in PREREQ_PM
+# Alternatively, you can say the hell with this and use h2xs.
+
+require 5.007003;
+
+use ExtUtils::MakeMaker;
+
+$PACKAGE = 'Data::Util';
+($PACKAGE_FILE = $PACKAGE) =~ s|::|/|g;
+$LAST_API_CHANGE = 0.03;
+
+eval "require $PACKAGE";
+
+unless ($@) { # Make sure we did find the module.
+ print <<"CHANGE_WARN" if ${$PACKAGE.'::VERSION'} < $LAST_API_CHANGE;
+
+NOTE: There have been API changes between this version and any older
+than version $LAST_API_CHANGE! Please read the Changes file if you
+are upgrading from a version older than $LAST_API_CHANGE.
+
+CHANGE_WARN
+}
+
+WriteMakefile(
+ NAME => $PACKAGE,
+ DISTNAME => 'Data-Hash-Utils',
+ VERSION_FROM => "lib/$PACKAGE_FILE.pm", # finds $VERSION
+ PREREQ_PM => { },
+);
+
+
+{
+ package MY;
+
+ sub test_via_harness {
+ my($self, $orig_perl, $tests) = @_;
+
+ my @perls = ($orig_perl);
+ push @perls, qw(bleadperl)
+ if $ENV{PERL_TEST_ALL};
+
+ my $out;
+ foreach my $perl (@perls) {
+ $out .= $self->SUPER::test_via_harness($perl, $tests);
+ }
+
+ return $out;
+ }
+}
--- /dev/null
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+
+MODULE=Data::Util PACKAGE=Data::Util
+
+int
+sv_readonly_flag(...)
+PROTOTYPE: \[$%@];$
+CODE:
+{
+ 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;
+}
+
--- /dev/null
+package Data::Util;
+
+require Exporter;
+require DynaLoader;
+
+our @ISA = qw(Exporter DynaLoader);
+our @EXPORT_OK = qw(sv_readonly_flag);
+our $VERSION = 0.04;
+
+bootstrap Data::Util $VERSION;
+
+1;
+
+__END__
+
+=head1 NAME
+
+Data::Util - A selection of general-utility data subroutines
+
+=head1 SYNOPSIS
+
+ use Data::Util qw(sv_readonly_flag);
+
+ my $sv_readonly = sv_readonly_flag(%some_data);
+
+ sv_readonly_flag(@some_data, 1); # Set the sv_readonly flag on
+ # @some_data to true.
+
+=head1 DESCRIPTION
+
+C<Data::Util> contains a selection of subroutines which are useful on
+scalars, hashes and lists (and thus wouldn't fit into Scalar, Hash or
+List::Util). All of the routines herein will work equally well on a
+scalar, hash, list or even hash & list elements.
+
+ sv_readonly_flag($some_data);
+ sv_readonly_flag(@some_data);
+ sv_readonly_flag(%some_data);
+ sv_readonly_flag($some_data{key});
+ sv_readonly_flag($some_data[3]);
+
+We'll just refer to the conglomeration as "DATA".
+
+By default C<Data::Util> does not export any subroutines. You can ask
+for...
+
+=over 4
+
+=item sv_readonly_flag
+
+ my $sv_readonly = sv_readonly_flag(DATA);
+ sv_readonly_flag(DATA, 1); # set sv_readonly true
+ sv_readonly_flag(DATA, 0); # set sv_readonly false
+
+This gets/sets the sv_readonly flag on the given DATA. When setting
+it returns the previous state of the flag. This is intended for
+people I<that know what they're doing.>
+
+The exact behavior exhibited by a piece of DATA when sv_readonly is
+set depends on what type of data it is. B<It doesn't even necessarily
+make the data readonly!> Look for specific functions in Scalar::Util,
+List::Util and Hash::Util for making those respective types readonly.
+
+=head1 AUTHOR
+
+Michael G Schwern <schwern@pobox.com> using XS code by Nick Ing-Simmons.
+
+=head1 SEE ALSO
+
+L<Scalar::Util>, L<List::Util>, L<Hash::Util>
+
+=cut
+
--- /dev/null
+package Hash::Util;
+
+require 5.007003;
+use strict;
+use Data::Util qw(sv_readonly_flag);
+use Carp;
+
+require Exporter;
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw(lock_keys unlock_keys lock_value unlock_value
+ lock_hash unlock_hash
+ );
+our $VERSION = 0.04;
+
+
+=head1 NAME
+
+Hash::Util - A selection of general-utility hash subroutines
+
+=head1 SYNOPSIS
+
+ use Hash::Util qw(lock_keys unlock_keys
+ lock_value unlock_value
+ lock_hash unlock_hash
+ );
+
+ %hash = (foo => 42, bar => 23);
+ lock_keys(%hash);
+ lock_keys(%hash, @keyset);
+ unlock_keys(%hash);
+
+ lock_value (%hash, 'foo');
+ unlock_value(%hash, 'foo');
+
+ lock_hash (%hash);
+ unlock_hash(%hash);
+
+
+=head1 DESCRIPTION
+
+C<Hash::Util> contains special functions for manipulating hashes that
+don't really warrant a keyword.
+
+By default C<Hash::Util> does not export anything.
+
+=head2 Restricted hashes
+
+5.8.0 introduces the ability to restrict a hash to a certain set of
+keys. No keys outside of this set can be added. It also introduces
+the ability to lock an individual key so it cannot be deleted and the
+value cannot be changed.
+
+This is intended to largely replace the deprecated pseudo-hashes.
+
+=over 4
+
+=item lock_keys
+
+=item unlock_keys
+
+ lock_keys(%hash);
+ lock_keys(%hash, @keys);
+
+ unlock_keys(%hash;)
+
+Restricts the given %hash's set of keys to @keys. If @keys is not
+given it restricts it to its current keyset. No more keys can be
+added. delete() and exists() will still work, but it does not effect
+the set of allowed keys.
+
+Removes the restriction on the %hash's keyset.
+
+=cut
+
+sub lock_keys (\%;@) {
+ my($hash, @keys) = @_;
+
+ if( @keys ) {
+ my %keys = map { ($_ => 1) } @keys;
+ my %original_keys = map { ($_ => 1) } keys %$hash;
+ foreach my $k (keys %original_keys) {
+ die sprintf "Hash has key '$k' which is not in the new key ".
+ "set at %s line %d\n", (caller)[1,2]
+ unless $keys{$k};
+ }
+
+ foreach my $k (@keys) {
+ $hash->{$k} = undef unless exists $hash->{$k};
+ }
+ sv_readonly_flag %$hash, 1;
+
+ foreach my $k (@keys) {
+ delete $hash->{$k} unless $original_keys{$k};
+ }
+ }
+ else {
+ sv_readonly_flag %$hash, 1;
+ }
+
+ return undef;
+}
+
+sub unlock_keys (\%) {
+ my($hash) = shift;
+
+ sv_readonly_flag %$hash, 0;
+ return undef;
+}
+
+=item lock_value
+
+=item unlock_value
+
+ lock_key (%hash, $key);
+ unlock_key(%hash, $key);
+
+Locks and unlocks an individual key of a hash. The value of a locked
+key cannot be changed.
+
+%hash must have already been locked for this to have useful effect.
+
+=cut
+
+sub lock_value (\%$) {
+ my($hash, $key) = @_;
+ carp "Cannot usefully lock values in an unlocked hash"
+ unless sv_readonly_flag %$hash;
+ sv_readonly_flag $hash->{$key}, 1;
+}
+
+sub unlock_value (\%$) {
+ my($hash, $key) = @_;
+ sv_readonly_flag $hash->{$key}, 0;
+}
+
+
+=item B<lock_hash>
+
+=item B<unlock_hash>
+
+ lock_hash(%hash);
+ unlock_hash(%hash);
+
+lock_hash() locks an entire hash, making all keys and values readonly.
+No value can be changed, no keys can be added or deleted.
+
+unlock_hash() does the opposite. All keys and values are made
+read/write. All values can be changed and keys can be added and
+deleted.
+
+=cut
+
+sub lock_hash (\%) {
+ my($hash) = shift;
+
+ lock_keys(%$hash);
+
+ foreach my $key (keys %$hash) {
+ lock_value(%$hash, $key);
+ }
+
+ return 1;
+}
+
+sub unlock_hash (\%) {
+ my($hash) = shift;
+
+ foreach my $key (keys %$hash) {
+ unlock_value(%$hash, $key);
+ }
+
+ unlock_keys(%$hash);
+
+ return 1;
+}
+
+
+=back
+
+=head1 AUTHOR
+
+Michael G Schwern <schwern@pobox.com> on top of code by Nick
+Ing-Simmons and Jeffrey Friedl.
+
+=head1 SEE ALSO
+
+L<Scalar::Util>, L<List::Util>, L<Hash::Util>
+
+=cut
+
+1;
--- /dev/null
+#!/usr/bin/perl -Tw
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ @INC = '../lib';
+ chdir 't';
+ }
+}
+use Test::More tests => 26;
+
+use Data::Util;
+BEGIN { use_ok 'Data::Util', qw(sv_readonly_flag); }
+
+ok( !sv_readonly_flag $foo );
+ok( !sv_readonly_flag $foo, 1 );
+ok( sv_readonly_flag $foo );
+ok( sv_readonly_flag $foo, 0 );
+ok( !sv_readonly_flag $foo );
+
+ok( !sv_readonly_flag @foo );
+ok( !sv_readonly_flag @foo, 1 );
+ok( sv_readonly_flag @foo );
+ok( sv_readonly_flag @foo, 0 );
+ok( !sv_readonly_flag @foo );
+
+ok( !sv_readonly_flag $foo[2] );
+ok( !sv_readonly_flag $foo[2], 1 );
+ok( sv_readonly_flag $foo[2] );
+ok( sv_readonly_flag $foo[2], 0 );
+ok( !sv_readonly_flag $foo[2] );
+
+ok( !sv_readonly_flag %foo );
+ok( !sv_readonly_flag %foo, 1 );
+ok( sv_readonly_flag %foo );
+ok( sv_readonly_flag %foo, 0 );
+ok( !sv_readonly_flag %foo );
+
+ok( !sv_readonly_flag $foo{foo} );
+ok( !sv_readonly_flag $foo{foo}, 1 );
+ok( sv_readonly_flag $foo{foo} );
+ok( sv_readonly_flag $foo{foo}, 0 );
+ok( !sv_readonly_flag $foo{foo} );
--- /dev/null
+#!/usr/bin/perl -Tw
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ @INC = '../lib';
+ chdir 't';
+ }
+}
+use Test::More tests => 45;
+use Data::Util qw(sv_readonly_flag);
+
+my @Exported_Funcs;
+BEGIN {
+ @Exported_Funcs = qw(lock_keys unlock_keys
+ lock_value unlock_value
+ lock_hash unlock_hash
+ );
+ use_ok 'Hash::Util', @Exported_Funcs;
+}
+foreach my $func (@Exported_Funcs) {
+ can_ok __PACKAGE__, $func;
+}
+
+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/,
+ 'lock_keys()');
+is( $hash{bar}, 23 );
+ok( !exists $hash{baz} );
+
+delete $hash{bar};
+ok( !exists $hash{bar} );
+$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/ );
+
+lock_value(%hash, 'locked');
+eval { print "# oops" if $hash{four} };
+like( $@, qr/^Attempt to access disallowed key 'four' in a fixed hash/ );
+
+eval { $hash{"\x{2323}"} = 3 };
+like( $@, qr/^Attempt to access disallowed key '(.*)' in a fixed hash/,
+ 'wide hex key' );
+
+eval { delete $hash{locked} };
+like( $@, qr/^Attempt to delete readonly key 'locked' from a fixed 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' );
+
+eval { delete $hash{I_dont_exist} };
+like( $@, qr/^Attempt to delete disallowed key 'I_dont_exist' from a fixed hash/,
+ 'trying to delete a key that doesnt exist' );
+
+ok( !exists $hash{I_dont_exist} );
+
+unlock_keys(%hash);
+$hash{I_dont_exist} = 42;
+is( $hash{I_dont_exist}, 42, 'unlock_keys' );
+
+eval { $hash{locked} = 42; };
+like( $@, qr/^Modification of a read-only value attempted/,
+ ' individual key still readonly' );
+eval { delete $hash{locked} },
+is( $@, '', ' but can be deleted :(' );
+
+unlock_value(%hash, 'locked');
+$hash{locked} = 42;
+is( $hash{locked}, 42, 'unlock_value' );
+
+
+TODO: {
+# local $TODO = 'assigning to a hash screws with locked keys';
+
+ my %hash = ( foo => 42, locked => 23 );
+
+ lock_keys(%hash);
+ lock_value(%hash, 'locked');
+ eval { %hash = ( wubble => 42 ) }; # we know this will bomb
+ like( $@, qr/^Attempt to clear a fixed hash/ );
+
+ eval { unlock_value(%hash, 'locked') }; # but this shouldn't
+ is( $@, '', 'unlock_value() after denied assignment' );
+
+ is_deeply( \%hash, { foo => 42, locked => 23 },
+ 'hash should not be altered by denied assignment' );
+ unlock_keys(%hash);
+}
+
+{
+ my %hash = (KEY => 'val', RO => 'val');
+ lock_keys(%hash);
+ lock_value(%hash, 'RO');
+
+ eval { %hash = (KEY => 1) };
+ like( $@, qr/^Attempt to clear a fixed hash/ );
+}
+
+# TODO: This should be allowed but it might require putting extra
+# code into aassign.
+{
+ my %hash = (KEY => 1, RO => 2);
+ lock_keys(%hash);
+ eval { %hash = (KEY => 1, RO => 2) };
+ like( $@, qr/^Attempt to clear a fixed hash/ );
+}
+
+
+
+{
+ my %hash = ();
+ lock_keys(%hash, qw(foo bar));
+ is( keys %hash, 0, 'lock_keys() w/keyset shouldnt add new keys' );
+ $hash{foo} = 42;
+ is( keys %hash, 1 );
+ eval { $hash{wibble} = 42 };
+ like( $@, qr/^Attempt to access disallowed key 'wibble' in a fixed hash/,
+ ' locked');
+
+ unlock_keys(%hash);
+ eval { $hash{wibble} = 23; };
+ is( $@, '', 'unlock_keys' );
+}
+
+
+{
+ my %hash = (foo => 42, bar => undef, baz => 0);
+ lock_keys(%hash, qw(foo bar baz up down));
+ is( keys %hash, 3, 'lock_keys() w/keyset didnt add new keys' );
+ is_deeply( \%hash, { foo => 42, bar => undef, baz => 0 } );
+
+ eval { $hash{up} = 42; };
+ is( $@, '' );
+
+ eval { $hash{wibble} = 23 };
+ like( $@, qr/^Attempt to access disallowed key 'wibble' in a fixed hash/, ' locked' );
+}
+
+
+{
+ my %hash = (foo => 42, bar => undef);
+ eval { lock_keys(%hash, qw(foo baz)); };
+ is( $@, sprintf("Hash has key 'bar' which is not in the new key ".
+ "set at %s line %d\n", __FILE__, __LINE__ - 2) );
+}
+
+
+{
+ my %hash = (foo => 42, bar => 23);
+ lock_hash( %hash );
+
+ ok( sv_readonly_flag(%hash) );
+ ok( sv_readonly_flag($hash{foo}) );
+ ok( sv_readonly_flag($hash{bar}) );
+
+ unlock_hash ( %hash );
+
+ ok( !sv_readonly_flag(%hash) );
+ ok( !sv_readonly_flag($hash{foo}) );
+ ok( !sv_readonly_flag($hash{bar}) );
+}
+
+
+lock_keys(%ENV);
+eval { () = $ENV{I_DONT_EXIST} };
+like( $@, qr/^Attempt to access disallowed key 'I_DONT_EXIST' in a fixed hash/, 'locked %ENV');
static void
Perl_hv_notallowed(pTHX_ bool is_utf8, const char *key, I32 klen,
- const char *keysave)
+ const char *keysave, const char *msg)
{
SV *sv = sv_newmortal();
if (key == keysave) {
if (is_utf8) {
SvUTF8_on(sv);
}
- Perl_croak(aTHX_ "Attempt to access key '%"SVf"' in fixed hash",sv);
+ Perl_croak(aTHX_ msg, sv);
}
/* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
}
#endif
if (!entry && SvREADONLY(hv)) {
- Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
+ Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave,
+ "Attempt to access disallowed key '%"SVf"' in a fixed hash"
+ );
}
if (lval) { /* gonna assign to this, so it better be there */
sv = NEWSV(61,0);
}
#endif
if (!entry && SvREADONLY(hv)) {
- Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
+ Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave,
+ "Attempt to access disallowed key '%"SVf"' in a fixed hash"
+ );
}
if (key != keysave)
Safefree(key);
}
if (SvREADONLY(hv)) {
- Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
+ Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave,
+ "Attempt to access disallowed key '%"SVf"' to a fixed hash"
+ );
}
entry = new_HE();
}
if (SvREADONLY(hv)) {
- Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
+ Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave,
+ "Attempt to access disallowed key '%"SVf"' to a fixed hash"
+ );
}
entry = new_HE();
}
}
else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
- Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
+ Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave,
+ "Attempt to delete readonly key '%"SVf"' from a fixed hash"
+ );
}
if (flags & G_DISCARD)
return sv;
}
if (SvREADONLY(hv)) {
- Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
+ Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave,
+ "Attempt to access disallowed key '%"SVf"' from a fixed hash"
+ );
}
if (key != keysave)
return Nullsv;
}
else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
- Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
+ Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave,
+ "Attempt to delete readonly key '%"SVf"' from a fixed hash"
+ );
}
if (flags & G_DISCARD)
return sv;
}
if (SvREADONLY(hv)) {
- Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
+ Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave,
+ "Attempt to delete disallowed key '%"SVf"' from a fixed hash"
+ );
}
if (key != keysave)
register XPVHV* xhv;
if (!hv)
return;
+
+ if(SvREADONLY(hv)) {
+ Perl_croak(aTHX_ "Attempt to clear a fixed hash");
+ }
+
xhv = (XPVHV*)SvANY(hv);
hfreeentries(hv);
xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
cleanup();
-find({wanted => sub { print "ok 1\n" if $_ eq 'access.t'; } },
+find({wanted => sub { print "ok 1\n" if $_ eq '1_compile.t'; } },
File::Spec->curdir);
-finddepth({wanted => sub { print "ok 2\n" if $_ eq 'access.t'; } },
+finddepth({wanted => sub { print "ok 2\n" if $_ eq '1_compile.t'; } },
File::Spec->curdir);
cleanup();
my $found;
-find({wanted => sub { $found = 1 if ($_ eq 'access.t') },
+find({wanted => sub { $found = 1 if ($_ eq '1_compile.t') },
untaint => 1, untaint_pattern => qr|^(.+)$|}, File::Spec->curdir);
-ok($found, 'access.t found');
+ok($found, '1_compile.t found');
$found = 0;
-finddepth({wanted => sub { $found = 1 if $_ eq 'access.t'; },
+finddepth({wanted => sub { $found = 1 if $_ eq '1_compile.t'; },
untaint => 1, untaint_pattern => qr|^(.+)$|}, File::Spec->curdir);
-ok($found, 'access.t found again');
+ok($found, '1_compile.t found again');
my $case = 2;
my $FastFileTests_OK = 0;
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 key '%_' in fixed hash
+=item Attempt to access disallowed key '%s' in a 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.
+(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.
+
+=item Attempt to clear a fixed hash
+
+(F) It is currently not allowed to clear a fixed 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
+
+(F) The failing code attempted to delete a key whose value has been
+declared readonly from a fixed hash.
+
+=item Attempt to delete disallowed key '%s' from a fixed hash
+
+(F) The failing code attempted to delete from a fixed hash a key which
+is not in its key set.
=item Attempt to bless into a reference
needs to be displayed with %vd, make v-strings (readonly) objects
(class "vstring"?) with a stringify overload.
+=head2 Allow restricted hash assignment
+
+Currently you're not allowed to assign to a restricted hash at all,
+even with the same keys.
+
+ %restricted = (foo => 42); # error
+
+This should be allowed if the new keyset is a subset of the old
+keyset. May require more extra code than we'd like in pp_aassign.
+
=head1 Vague ideas
Ideas which have been discussed, and which may or may not happen.
+++ /dev/null
-#!./perl
-
-BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
-}
-
-$| = 1;
-print "1..19\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));
-
-ok(!access::readonly($hash{two},1));
-
-eval { $hash{'three'} = 3 };
-#warn "$@";
-ok($@ =~ /^Attempt to access key 'three' in fixed hash/);
-
-eval { print "# oops" if $hash{'four'}};
-#warn "$@";
-ok($@ =~ /^Attempt to access key 'four' in fixed hash/);
-
-eval { $hash{"\x{2323}"} = 3 };
-#warn "$@";
-ok($@ =~ /^Attempt to access key '(.*)' in fixed hash/);
-#ok(ord($1) == 0x2323);
-
-eval { delete $hash{'two'}};
-#warn "$@";
-ok($@);
-
-eval { delete $hash{'one'}};
-ok(not $@);
-
-ok($hash{two} == 2);
-
-eval { delete $hash{'four'}};
-#warn "$@";
-ok($@ =~ /^Attempt to access key 'four' in fixed hash/);
-
-ok(not 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));
-
-
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)
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, "\\[$%@];$");
}
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;
-}
-
projects / p5sagit/p5-mst-13.2.git / commitdiff