[perl5.git] / lib / Hash / Util.t

#!/usr/bin/perl -Tw

BEGIN {
    if( $ENV{PERL_CORE} ) {
        @INC = '../lib';
        chdir 't';
    }
}
use Test::More tests => 155;
use strict;

my @Exported_Funcs;
BEGIN { 
    @Exported_Funcs = qw(lock_keys   unlock_keys
                         lock_value  unlock_value
                         lock_hash   unlock_hash
			 hash_seed
                        );
    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 restricted 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 restricted hash/ );

lock_value(%hash, 'locked');
eval { print "# oops" if $hash{four} };
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 restricted hash/,
                                               'wide hex key' );

eval { delete $hash{locked} };
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/,
                                           '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 restricted 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' );


{
    my %hash = ( foo => 42, locked => 23 );

    lock_keys(%hash);
    eval { %hash = ( wubble => 42 ) };  # we know this will bomb
    like( $@, qr/^Attempt to access disallowed key 'wubble'/ );
    unlock_keys(%hash);
}

{ 
    my %hash = (KEY => 'val', RO => 'val');
    lock_keys(%hash);
    lock_value(%hash, 'RO');

    eval { %hash = (KEY => 1) };
    like( $@, qr/^Attempt to delete readonly key 'RO' from a restricted hash/ );
}

{
    my %hash = (KEY => 1, RO => 2);
    lock_keys(%hash);
    eval { %hash = (KEY => 1, RO => 2) };
    is( $@, '');
}


{
    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 restricted 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 restricted 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 restricted hash/,   'locked %ENV');

{
    my %hash;

    lock_keys(%hash, 'first');

    is (scalar keys %hash, 0, "place holder isn't a key");
    $hash{first} = 1;
    is (scalar keys %hash, 1, "we now have a key");
    delete $hash{first};
    is (scalar keys %hash, 0, "now no key");

    unlock_keys(%hash);

    $hash{interregnum} = 1.5;
    is (scalar keys %hash, 1, "key again");
    delete $hash{interregnum};
    is (scalar keys %hash, 0, "no key again");

    lock_keys(%hash, 'second');

    is (scalar keys %hash, 0, "place holder isn't a key");

    eval {$hash{zeroeth} = 0};
    like ($@,
          qr/^Attempt to access disallowed key 'zeroeth' in a restricted hash/,
          'locked key never mentioned before should fail');
    eval {$hash{first} = -1};
    like ($@,
          qr/^Attempt to access disallowed key 'first' in a restricted hash/,
          'previously locked place holders should also fail');
    is (scalar keys %hash, 0, "and therefore there are no keys");
    $hash{second} = 1;
    is (scalar keys %hash, 1, "we now have just one key");
    delete $hash{second};
    is (scalar keys %hash, 0, "back to zero");

    unlock_keys(%hash); # We have deliberately left a placeholder.

    $hash{void} = undef;
    $hash{nowt} = undef;

    is (scalar keys %hash, 2, "two keys, values both undef");

    lock_keys(%hash);

    is (scalar keys %hash, 2, "still two keys after locking");

    eval {$hash{second} = -1};
    like ($@,
          qr/^Attempt to access disallowed key 'second' in a restricted hash/,
          'previously locked place holders should fail');

    is ($hash{void}, undef,
        "undef values should not be misunderstood as placeholders");
    is ($hash{nowt}, undef,
        "undef values should not be misunderstood as placeholders (again)");
}

{
  # perl #18651 - tim@consultix-inc.com found a rather nasty data dependant
  # bug whereby hash iterators could lose hash keys (and values, as the code
  # is common) for restricted hashes.

  my @keys = qw(small medium large);

  # There should be no difference whether it is restricted or not
  foreach my $lock (0, 1) {
    # Try setting all combinations of the 3 keys
    foreach my $usekeys (0..7) {
      my @usekeys;
      for my $bits (0,1,2) {
	push @usekeys, $keys[$bits] if $usekeys & (1 << $bits);
      }
      my %clean = map {$_ => length $_} @usekeys;
      my %target;
      lock_keys ( %target, @keys ) if $lock;

      while (my ($k, $v) = each %clean) {
	$target{$k} = $v;
      }

      my $message
	= ($lock ? 'locked' : 'not locked') . ' keys ' . join ',', @usekeys;

      is (scalar keys %target, scalar keys %clean, "scalar keys for $message");
      is (scalar values %target, scalar values %clean,
	  "scalar values for $message");
      # Yes. All these sorts are necessary. Even for "identical hashes"
      # Because the data dependency of the test involves two of the strings
      # colliding on the same bucket, so the iterator order (output of keys,
      # values, each) depends on the addition order in the hash. And locking
      # the keys of the hash involves behind the scenes key additions.
      is_deeply( [sort keys %target] , [sort keys %clean],
		 "list keys for $message");
      is_deeply( [sort values %target] , [sort values %clean],
		 "list values for $message");

      is_deeply( [sort %target] , [sort %clean],
		 "hash in list context for $message");

      my (@clean, @target);
      while (my ($k, $v) = each %clean) {
	push @clean, $k, $v;
      }
      while (my ($k, $v) = each %target) {
	push @target, $k, $v;
      }

      is_deeply( [sort @target] , [sort @clean],
		 "iterating with each for $message");
    }
  }
}
Commit	Line	Data
49293501 MS	1	#!/usr/bin/perl -Tw
	2
	3	BEGIN {
	4	if( $ENV{PERL_CORE} ) {
	5	@INC = '../lib';
	6	chdir 't';
	7	}
	8	}
e67b9e52	9	use Test::More tests => 155;
0cd24ecf	10	use strict;
49293501 MS	11
	12	my @Exported_Funcs;
	13	BEGIN {
	14	@Exported_Funcs = qw(lock_keys unlock_keys
	15	lock_value unlock_value
	16	lock_hash unlock_hash
c910b28a	17	hash_seed
49293501 MS	18	);
	19	use_ok 'Hash::Util', @Exported_Funcs;
	20	}
	21	foreach my $func (@Exported_Funcs) {
	22	can_ok __PACKAGE__, $func;
	23	}
	24
	25	my %hash = (foo => 42, bar => 23, locked => 'yep');
	26	lock_keys(%hash);
	27	eval { $hash{baz} = 99; };
2393f1b9	28	like( $@, qr/^Attempt to access disallowed key 'baz' in a restricted hash/,
49293501 MS	29	'lock_keys()');
	30	is( $hash{bar}, 23 );
	31	ok( !exists $hash{baz} );
	32
	33	delete $hash{bar};
	34	ok( !exists $hash{bar} );
	35	$hash{bar} = 69;
	36	is( $hash{bar}, 69 );
	37
	38	eval { () = $hash{i_dont_exist} };
2393f1b9	39	like( $@, qr/^Attempt to access disallowed key 'i_dont_exist' in a restricted hash/ );
49293501 MS	40
	41	lock_value(%hash, 'locked');
	42	eval { print "# oops" if $hash{four} };
2393f1b9	43	like( $@, qr/^Attempt to access disallowed key 'four' in a restricted hash/ );
49293501 MS	44
49293501 MS	45	eval { $hash{"\x{2323}"} = 3 };
2393f1b9	46	like( $@, qr/^Attempt to access disallowed key '(.*)' in a restricted hash/,
49293501 MS	47	'wide hex key' );
	48
	49	eval { delete $hash{locked} };
2393f1b9	50	like( $@, qr/^Attempt to delete readonly key 'locked' from a restricted hash/,
49293501 MS	51	'trying to delete a locked key' );
	52	eval { $hash{locked} = 42; };
	53	like( $@, qr/^Modification of a read-only value attempted/,
	54	'trying to change a locked key' );
	55	is( $hash{locked}, 'yep' );
	56
	57	eval { delete $hash{I_dont_exist} };
2393f1b9	58	like( $@, qr/^Attempt to delete disallowed key 'I_dont_exist' from a restricted hash/,
49293501 MS	59	'trying to delete a key that doesnt exist' );
	60
	61	ok( !exists $hash{I_dont_exist} );
	62
	63	unlock_keys(%hash);
	64	$hash{I_dont_exist} = 42;
	65	is( $hash{I_dont_exist}, 42, 'unlock_keys' );
	66
	67	eval { $hash{locked} = 42; };
	68	like( $@, qr/^Modification of a read-only value attempted/,
	69	' individual key still readonly' );
	70	eval { delete $hash{locked} },
	71	is( $@, '', ' but can be deleted :(' );
	72
	73	unlock_value(%hash, 'locked');
	74	$hash{locked} = 42;
	75	is( $hash{locked}, 42, 'unlock_value' );
	76
	77
34c3c4e3	78	{
49293501 MS	79	my %hash = ( foo => 42, locked => 23 );
	80
	81	lock_keys(%hash);
49293501	82	eval { %hash = ( wubble => 42 ) }; # we know this will bomb
34c3c4e3	83	like( $@, qr/^Attempt to access disallowed key 'wubble'/ );
49293501 MS	84	unlock_keys(%hash);
	85	}
	86
	87	{
	88	my %hash = (KEY => 'val', RO => 'val');
	89	lock_keys(%hash);
	90	lock_value(%hash, 'RO');
	91
	92	eval { %hash = (KEY => 1) };
34c3c4e3	93	like( $@, qr/^Attempt to delete readonly key 'RO' from a restricted hash/ );
49293501 MS	94	}
49293501 MS	95
49293501 MS	96	{
	97	my %hash = (KEY => 1, RO => 2);
	98	lock_keys(%hash);
	99	eval { %hash = (KEY => 1, RO => 2) };
34c3c4e3	100	is( $@, '');
49293501 MS	101	}
	102
	103
	104
	105	{
	106	my %hash = ();
	107	lock_keys(%hash, qw(foo bar));
	108	is( keys %hash, 0, 'lock_keys() w/keyset shouldnt add new keys' );
	109	$hash{foo} = 42;
	110	is( keys %hash, 1 );
	111	eval { $hash{wibble} = 42 };
2393f1b9	112	like( $@, qr/^Attempt to access disallowed key 'wibble' in a restricted hash/,
49293501 MS	113	' locked');
	114
	115	unlock_keys(%hash);
	116	eval { $hash{wibble} = 23; };
	117	is( $@, '', 'unlock_keys' );
	118	}
	119
	120
	121	{
	122	my %hash = (foo => 42, bar => undef, baz => 0);
	123	lock_keys(%hash, qw(foo bar baz up down));
	124	is( keys %hash, 3, 'lock_keys() w/keyset didnt add new keys' );
	125	is_deeply( \%hash, { foo => 42, bar => undef, baz => 0 } );
	126
	127	eval { $hash{up} = 42; };
	128	is( $@, '' );
	129
	130	eval { $hash{wibble} = 23 };
2393f1b9	131	like( $@, qr/^Attempt to access disallowed key 'wibble' in a restricted hash/, ' locked' );
49293501 MS	132	}
	133
	134
	135	{
	136	my %hash = (foo => 42, bar => undef);
	137	eval { lock_keys(%hash, qw(foo baz)); };
	138	is( $@, sprintf("Hash has key 'bar' which is not in the new key ".
	139	"set at %s line %d\n", __FILE__, __LINE__ - 2) );
	140	}
	141
	142
	143	{
	144	my %hash = (foo => 42, bar => 23);
	145	lock_hash( %hash );
	146
29569577 JH	147	ok( Internals::SvREADONLY(%hash) );
	148	ok( Internals::SvREADONLY($hash{foo}) );
	149	ok( Internals::SvREADONLY($hash{bar}) );
49293501 MS	150
	151	unlock_hash ( %hash );
	152
29569577 JH	153	ok( !Internals::SvREADONLY(%hash) );
	154	ok( !Internals::SvREADONLY($hash{foo}) );
	155	ok( !Internals::SvREADONLY($hash{bar}) );
49293501 MS	156	}
	157
	158
	159	lock_keys(%ENV);
	160	eval { () = $ENV{I_DONT_EXIST} };
2393f1b9	161	like( $@, qr/^Attempt to access disallowed key 'I_DONT_EXIST' in a restricted hash/, 'locked %ENV');
dfd4ef2f NC	162
	163	{
	164	my %hash;
	165
	166	lock_keys(%hash, 'first');
	167
	168	is (scalar keys %hash, 0, "place holder isn't a key");
	169	$hash{first} = 1;
	170	is (scalar keys %hash, 1, "we now have a key");
	171	delete $hash{first};
	172	is (scalar keys %hash, 0, "now no key");
	173
	174	unlock_keys(%hash);
	175
	176	$hash{interregnum} = 1.5;
	177	is (scalar keys %hash, 1, "key again");
	178	delete $hash{interregnum};
	179	is (scalar keys %hash, 0, "no key again");
	180
	181	lock_keys(%hash, 'second');
	182
	183	is (scalar keys %hash, 0, "place holder isn't a key");
	184
	185	eval {$hash{zeroeth} = 0};
	186	like ($@,
	187	qr/^Attempt to access disallowed key 'zeroeth' in a restricted hash/,
	188	'locked key never mentioned before should fail');
	189	eval {$hash{first} = -1};
	190	like ($@,
	191	qr/^Attempt to access disallowed key 'first' in a restricted hash/,
	192	'previously locked place holders should also fail');
	193	is (scalar keys %hash, 0, "and therefore there are no keys");
	194	$hash{second} = 1;
	195	is (scalar keys %hash, 1, "we now have just one key");
0cd24ecf NC	196	delete $hash{second};
	197	is (scalar keys %hash, 0, "back to zero");
	198
	199	unlock_keys(%hash); # We have deliberately left a placeholder.
	200
	201	$hash{void} = undef;
	202	$hash{nowt} = undef;
	203
	204	is (scalar keys %hash, 2, "two keys, values both undef");
	205
	206	lock_keys(%hash);
	207
	208	is (scalar keys %hash, 2, "still two keys after locking");
	209
	210	eval {$hash{second} = -1};
	211	like ($@,
	212	qr/^Attempt to access disallowed key 'second' in a restricted hash/,
	213	'previously locked place holders should fail');
	214
	215	is ($hash{void}, undef,
	216	"undef values should not be misunderstood as placeholders");
	217	is ($hash{nowt}, undef,
	218	"undef values should not be misunderstood as placeholders (again)");
dfd4ef2f	219	}
015a5f36 NC	220
	221	{
	222	# perl #18651 - tim@consultix-inc.com found a rather nasty data dependant
	223	# bug whereby hash iterators could lose hash keys (and values, as the code
	224	# is common) for restricted hashes.
	225
	226	my @keys = qw(small medium large);
	227
	228	# There should be no difference whether it is restricted or not
	229	foreach my $lock (0, 1) {
	230	# Try setting all combinations of the 3 keys
	231	foreach my $usekeys (0..7) {
	232	my @usekeys;
	233	for my $bits (0,1,2) {
	234	push @usekeys, $keys[$bits] if $usekeys & (1 << $bits);
	235	}
	236	my %clean = map {$_ => length $_} @usekeys;
	237	my %target;
	238	lock_keys ( %target, @keys ) if $lock;
	239
	240	while (my ($k, $v) = each %clean) {
	241	$target{$k} = $v;
	242	}
	243
	244	my $message
	245	= ($lock ? 'locked' : 'not locked') . ' keys ' . join ',', @usekeys;
	246
	247	is (scalar keys %target, scalar keys %clean, "scalar keys for $message");
	248	is (scalar values %target, scalar values %clean,
	249	"scalar values for $message");
	250	# Yes. All these sorts are necessary. Even for "identical hashes"
	251	# Because the data dependency of the test involves two of the strings
	252	# colliding on the same bucket, so the iterator order (output of keys,
	253	# values, each) depends on the addition order in the hash. And locking
	254	# the keys of the hash involves behind the scenes key additions.
	255	is_deeply( [sort keys %target] , [sort keys %clean],
	256	"list keys for $message");
	257	is_deeply( [sort values %target] , [sort values %clean],
	258	"list values for $message");
	259
	260	is_deeply( [sort %target] , [sort %clean],
	261	"hash in list context for $message");
	262
	263	my (@clean, @target);
	264	while (my ($k, $v) = each %clean) {
	265	push @clean, $k, $v;
	266	}
	267	while (my ($k, $v) = each %target) {
	268	push @target, $k, $v;
	269	}
	270
	271	is_deeply( [sort @target] , [sort @clean],
	272	"iterating with each for $message");
	273	}
	274	}
	275	}
c910b28a	276