Small optimisations, by Brandon Black

[p5sagit/p5-mst-13.2.git] / t / op / avhv.t

#!./perl

# This test was originally for pseudo-hashes.  It now exists to ensure
# they were properly removed in 5.9.

BEGIN {
    chdir 't' if -d 't';
    @INC = '../lib';
}

require Tie::Array;

package Tie::BasicArray;
@ISA = 'Tie::Array';
sub TIEARRAY  { bless [], $_[0] }
sub STORE     { $_[0]->[$_[1]] = $_[2] }
sub FETCH     { $_[0]->[$_[1]] }
sub FETCHSIZE { scalar(@{$_[0]})} 
sub STORESIZE { $#{$_[0]} = $_[1]+1 }

package main;

require './test.pl';
plan(tests => 40);

# Helper function to check the typical error message.
sub not_hash {
    my($err) = shift;
    like( $err, qr/^Not a HASH reference / ) ||
      printf STDERR "# at %s line %d.\n", (caller)[1,2];
}

# Something to place inside if blocks and while loops that won't get
# compiled out.
my $foo = 42;
sub no_op { $foo++ }


$sch = {
    'abc' => 1,
    'def' => 2,
    'jkl' => 3,
};

# basic normal array
$a = [];
$a->[0] = $sch;

eval {
    $a->{'abc'} = 'ABC';
};
not_hash($@);

eval {
    $a->{'def'} = 'DEF';
};
not_hash($@);

eval {
    $a->{'jkl'} = 'JKL';
};
not_hash($@);

eval {
    @keys = keys %$a;
};
not_hash($@);

eval {
    @values = values %$a;
};
not_hash($@);

eval {
    while( my($k,$v) = each %$a ) {
        no_op;
    }
};
not_hash($@);


# quick check with tied array
tie @fake, 'Tie::StdArray';
$a = \@fake;
$a->[0] = $sch;

eval {
    $a->{'abc'} = 'ABC';
};
not_hash($@);

eval {
    if ($a->{'abc'} eq 'ABC') { no_op(23) } else { no_op(42) }
};
not_hash($@);

# quick check with tied array
tie @fake, 'Tie::BasicArray';
$a = \@fake;
$a->[0] = $sch;

eval {
    $a->{'abc'} = 'ABC';
};
not_hash($@);

eval {
    if ($a->{'abc'} eq 'ABC') { no_op(23) } else { no_op(42) }
};
not_hash($@);

# quick check with tied array & tied hash
require Tie::Hash;
tie %fake, Tie::StdHash;
%fake = %$sch;
$a->[0] = \%fake;

eval {
    $a->{'abc'} = 'ABC';
};
not_hash($@);

eval {
    if ($a->{'abc'} eq 'ABC') { no_op(23) } else { no_op(42) }
};
not_hash($@);


# hash slice
eval {
    my $slice = join('', 'x',@$a{'abc','def'},'x');
};
not_hash($@);


# evaluation in scalar context
my $avhv = [{}];

eval {
    () = %$avhv;
};
not_hash($@);

push @$avhv, "a";
eval {
    () = %$avhv;
};
not_hash($@);

$avhv = [];
eval { $a = %$avhv };
not_hash($@);

$avhv = [{foo=>1, bar=>2}];
eval {
    %$avhv =~ m,^\d+/\d+,;
};
not_hash($@);

# check if defelem magic works
sub f {
    print "not " unless $_[0] eq 'a';
    $_[0] = 'b';
    print "ok 11\n";
}
$a = [{key => 1}, 'a'];
eval {
    f($a->{key});
};
not_hash($@);

# check if exists() is behaving properly
$avhv = [{foo=>1,bar=>2,pants=>3}];
eval {
    no_op if exists $avhv->{bar};
};
not_hash($@);

eval {
    $avhv->{pants} = undef;
};
not_hash($@);

eval {
    no_op if exists $avhv->{pants};
};
not_hash($@);

eval {
    no_op if exists $avhv->{bar};
};
not_hash($@);

eval {
    $avhv->{bar} = 10;
};
not_hash($@);

eval {
    no_op unless exists $avhv->{bar} and $avhv->{bar} == 10;
};
not_hash($@);

eval {
    $v = delete $avhv->{bar};
};
not_hash($@);

eval {
    no_op if exists $avhv->{bar};
};
not_hash($@);

eval {
    $avhv->{foo} = 'xxx';
};
not_hash($@);
eval {
    $avhv->{bar} = 'yyy';
};
not_hash($@);
eval {
    $avhv->{pants} = 'zzz';
};
not_hash($@);
eval {
    @x = delete @{$avhv}{'foo','pants'};
};
not_hash($@);
eval {
    no_op unless "$avhv->{bar}" eq "yyy";
};
not_hash($@);

# hash assignment
eval {
    %$avhv = ();
};
not_hash($@);

eval {
    %hv = %$avhv;
};
not_hash($@);

eval {
    %$avhv = (foo => 29, pants => 2, bar => 0);
};
not_hash($@);

my $extra;
my @extra;
eval {
    ($extra, %$avhv) = ("moo", foo => 42, pants => 53, bar => "HIKE!");
};
not_hash($@);

eval {
    %$avhv = ();
    (%$avhv, $extra) = (foo => 42, pants => 53, bar => "HIKE!");
};
not_hash($@);

eval {
    @extra = qw(whatever and stuff);
    %$avhv = ();
};
not_hash($@);
eval {
    (%$avhv, @extra) = (foo => 42, pants => 53, bar => "HIKE!");
};
not_hash($@);

eval {
    (@extra, %$avhv) = (foo => 42, pants => 53, bar => "HIKE!");
};
not_hash($@);

# Check hash slices (BUG ID 20010423.002)
$avhv = [{foo=>1, bar=>2}];
eval {
    @$avhv{"foo", "bar"} = (42, 53);
};
not_hash($@);