Change 15201 by jhi@alpha on 2002/03/12 15:41:23
Move the readonly interface back to universal.c,
(new name: Internals::SvREADONLY), remove Data::Util,
move Hash::Util to lib, also introduce refcnt interface
(Internals::SvREADONLY). Make both the new interfaces
to be more sane so that if they set the value, they return
the new value, not the old one.
Affected files ...
.... //depot/perl/MANIFEST#768 edit
.... //depot/perl/ext/B/t/stash.t#8 edit
.... //depot/perl/ext/Data/Util/Changes#2 delete
.... //depot/perl/ext/Data/Util/Makefile.PL#2 delete
.... //depot/perl/ext/Data/Util/Util.xs#2 delete
.... //depot/perl/ext/Data/Util/lib/Data/Util.pm#2 delete
.... //depot/perl/ext/Data/Util/lib/Hash/Util.pm#2 delete
.... //depot/perl/ext/Data/Util/t/Data.t#2 delete
.... //depot/perl/ext/Data/Util/t/Hash.t#2 delete
.... //depot/perl/lib/Hash/Util.pm#1 add
.... //depot/perl/lib/Hash/Util.t#1 add
.... //depot/perl/lib/Internals.t#1 add
.... //depot/perl/universal.c#47 edit
Differences ...
==== //depot/perl/MANIFEST#768 (text) ====
Index: perl/MANIFEST
--- perl/MANIFEST.~1~ Tue Mar 12 08:45:05 2002
+++ perl/MANIFEST Tue Mar 12 08:45:05 2002
@@ -127,13 +127,6 @@
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
@@ -1087,6 +1080,8 @@
lib/getopts.pl Perl library supporting option parsing
lib/h2ph.t See if h2ph works like it should
lib/h2xs.t See if h2xs produces expected lists of files
+lib/Hash/Util.pm Hash::Util
+lib/Hash/Util.t See if Hash::Util works
lib/hostname.pl Old hostname code
lib/I18N/Collate.pm Routines to do strxfrm-based collation
lib/I18N/Collate.t See if I18N::Collate works
@@ -1100,6 +1095,7 @@
lib/importenv.pl Perl routine to get environment into variables
lib/integer.pm For "use integer"
lib/integer.t For "use integer" testing
+lib/Internals.t For Internals::* testing
lib/IPC/Open2.pm Open a two-ended pipe
lib/IPC/Open2.t See if IPC::Open2 works
lib/IPC/Open3.pm Open a three-ended pipe!
@@ -2064,8 +2060,8 @@
Porting/config.sh Sample config.sh
Porting/config_H Sample config.h
Porting/Contract Social contract for contributed modules in Perl core
+Porting/findrfuncs Find reentrant variants of functions used in an executable
Porting/findvars Find occurrences of words
-Porting/findrfuncs Find reentrant variants of functions used in an executable
Porting/fixCORE Find and fix modules that generate warnings
Porting/fixvars Find undeclared variables with C compiler and fix em
Porting/genlog Generate formatted changelogs by querying p4d
==== //depot/perl/ext/B/t/stash.t#8 (xtext) ====
Index: perl/ext/B/t/stash.t
--- perl/ext/B/t/stash.t.~1~ Tue Mar 12 08:45:05 2002
+++ perl/ext/B/t/stash.t Tue Mar 12 08:45:05 2002
@@ -66,7 +66,7 @@
$got = "@got";
-my $expected = "attributes Carp Carp::Heavy DB Exporter Exporter::Heavy main utf8
warnings";
+my $expected = "attributes Carp Carp::Heavy DB Exporter Exporter::Heavy Internals
+main utf8 warnings";
{
no strict 'vars';
==== //depot/perl/universal.c#47 (text) ====
Index: perl/universal.c
--- perl/universal.c.~1~ Tue Mar 12 08:45:05 2002
+++ perl/universal.c Tue Mar 12 08:45:05 2002
@@ -167,6 +167,8 @@
XS(XS_utf8_downgrade);
XS(XS_utf8_unicode_to_native);
XS(XS_utf8_native_to_unicode);
+XS(XS_Internals_SvREADONLY);
+XS(XS_Internals_SvREFCNT);
void
Perl_boot_core_UNIVERSAL(pTHX)
@@ -183,6 +185,8 @@
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("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
+ newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
}
@@ -458,3 +462,39 @@
XSRETURN(1);
}
+XS(XS_Internals_SvREADONLY)
+{
+ dXSARGS;
+ SV *sv = SvRV(ST(0));
+ if (items == 1) {
+ if (SvREADONLY(sv))
+ XSRETURN_YES;
+ else
+ XSRETURN_NO;
+ }
+ else if (items == 2) {
+ if (SvTRUE(ST(1))) {
+ SvREADONLY_on(sv);
+ XSRETURN_YES;
+ }
+ else {
+ SvREADONLY_off(sv);
+ XSRETURN_NO;
+ }
+ }
+ XSRETURN_UNDEF;
+}
+
+XS(XS_Internals_SvREFCNT)
+{
+ dXSARGS;
+ SV *sv = SvRV(ST(0));
+ if (items == 1)
+ XSRETURN_IV(SvREFCNT(sv) - 1); /* minus the SvRV above */
+ else if (items == 2) {
+ SvREFCNT(sv) = SvIV(ST(1));
+ XSRETURN_IV(SvREFCNT(sv));
+ }
+ XSRETURN_UNDEF;
+}
+
==== //depot/perl/lib/Hash/Util.pm#1 (text) ====
Index: perl/lib/Hash/Util.pm
--- perl/lib/Hash/Util.pm.~1~ Tue Mar 12 08:45:05 2002
+++ perl/lib/Hash/Util.pm Tue Mar 12 08:45:05 2002
@@ -0,0 +1,190 @@
+package Hash::Util;
+
+require 5.007003;
+use strict;
+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};
+ }
+ Internals::SvREADONLY %$hash, 1;
+
+ foreach my $k (@keys) {
+ delete $hash->{$k} unless $original_keys{$k};
+ }
+ }
+ else {
+ Internals::SvREADONLY %$hash, 1;
+ }
+
+ return undef;
+}
+
+sub unlock_keys (\%) {
+ my($hash) = shift;
+
+ Internals::SvREADONLY %$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 Internals::SvREADONLY %$hash;
+ Internals::SvREADONLY $hash->{$key}, 1;
+}
+
+sub unlock_value (\%$) {
+ my($hash, $key) = @_;
+ Internals::SvREADONLY $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 <[EMAIL PROTECTED]> 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;
==== //depot/perl/lib/Hash/Util.t#1 (text) ====
Index: perl/lib/Hash/Util.t
--- perl/lib/Hash/Util.t.~1~ Tue Mar 12 08:45:05 2002
+++ perl/lib/Hash/Util.t Tue Mar 12 08:45:05 2002
@@ -0,0 +1,170 @@
+#!/usr/bin/perl -Tw
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ @INC = '../lib';
+ chdir 't';
+ }
+}
+use Test::More tests => 45;
+
+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( Internals::SvREADONLY(%hash) );
+ ok( Internals::SvREADONLY($hash{foo}) );
+ ok( Internals::SvREADONLY($hash{bar}) );
+
+ unlock_hash ( %hash );
+
+ ok( !Internals::SvREADONLY(%hash) );
+ ok( !Internals::SvREADONLY($hash{foo}) );
+ ok( !Internals::SvREADONLY($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');
==== //depot/perl/lib/Internals.t#1 (text) ====
Index: perl/lib/Internals.t
--- perl/lib/Internals.t.~1~ Tue Mar 12 08:45:05 2002
+++ perl/lib/Internals.t Tue Mar 12 08:45:05 2002
@@ -0,0 +1,51 @@
+#!/usr/bin/perl -Tw
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ @INC = '../lib';
+ chdir 't';
+ }
+}
+
+use Test::More tests => 29;
+
+my $foo;
+
+ok( !Internals::SvREADONLY $foo );
+ok( Internals::SvREADONLY $foo, 1 );
+ok( Internals::SvREADONLY $foo );
+ok( !Internals::SvREADONLY $foo, 0 );
+ok( !Internals::SvREADONLY $foo );
+
+ok( !Internals::SvREADONLY @foo );
+ok( Internals::SvREADONLY @foo, 1 );
+ok( Internals::SvREADONLY @foo );
+ok( !Internals::SvREADONLY @foo, 0 );
+ok( !Internals::SvREADONLY @foo );
+
+ok( !Internals::SvREADONLY $foo[2] );
+ok( Internals::SvREADONLY $foo[2], 1 );
+ok( Internals::SvREADONLY $foo[2] );
+ok( !Internals::SvREADONLY $foo[2], 0 );
+ok( !Internals::SvREADONLY $foo[2] );
+
+ok( !Internals::SvREADONLY %foo );
+ok( Internals::SvREADONLY %foo, 1 );
+ok( Internals::SvREADONLY %foo );
+ok( !Internals::SvREADONLY %foo, 0 );
+ok( !Internals::SvREADONLY %foo );
+
+ok( !Internals::SvREADONLY $foo{foo} );
+ok( Internals::SvREADONLY $foo{foo}, 1 );
+ok( Internals::SvREADONLY $foo{foo} );
+ok( !Internals::SvREADONLY $foo{foo}, 0 );
+ok( !Internals::SvREADONLY $foo{foo} );
+
+is( Internals::SvREFCNT($foo), 1 );
+{
+ my $bar = \$foo;
+ is( Internals::SvREFCNT($foo), 2 );
+ is( Internals::SvREFCNT($bar), 1 );
+}
+is( Internals::SvREFCNT($foo), 1 );
+
End of Patch.
