path: root/t/op/tiearray.t

#!./perl

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

my %seen;

package Implement;

sub TIEARRAY
{
 $seen{'TIEARRAY'}++;
 my ($class,@val) = @_;
 return bless \@val,$class;
}

sub STORESIZE
{        
 $seen{'STORESIZE'}++;
 my ($ob,$sz) = @_; 
 return $#{$ob} = $sz-1;
}

sub EXTEND
{        
 $seen{'EXTEND'}++;
 my ($ob,$sz) = @_; 
 return @$ob = $sz;
}

sub FETCHSIZE
{        
 $seen{'FETCHSIZE'}++;
 return scalar(@{$_[0]});
}

sub FETCH
{
 $seen{'FETCH'}++;
 my ($ob,$id) = @_;
 return $ob->[$id]; 
}

sub STORE
{
 $seen{'STORE'}++;
 my ($ob,$id,$val) = @_;
 $ob->[$id] = $val; 
}                 

sub UNSHIFT
{
 $seen{'UNSHIFT'}++;
 my $ob = shift;
 unshift(@$ob,@_);
}                 

sub PUSH
{
 $seen{'PUSH'}++;
 my $ob = shift;;
 push(@$ob,@_);
}                 

sub CLEAR
{
 $seen{'CLEAR'}++;
 @{$_[0]} = ();
}

sub DESTROY
{
 $seen{'DESTROY'}++;
}

sub POP
{
 $seen{'POP'}++;
 my ($ob) = @_;
 return pop(@$ob);
}

sub SHIFT
{
 $seen{'SHIFT'}++;
 my ($ob) = @_;
 return shift(@$ob);
}

sub SPLICE
{
 $seen{'SPLICE'}++;
 my $ob  = shift;                    
 my $off = @_ ? shift : 0;
 my $len = @_ ? shift : @$ob-1;
 return splice(@$ob,$off,$len,@_);
}

package NegIndex;               # 20020220 MJD
@ISA = 'Implement';

# simulate indices -2 .. 2
my $offset = 2;
$NegIndex::NEGATIVE_INDICES = 1;

sub FETCH {
  my ($ob,$id) = @_;
#  print "# FETCH @_\n";
  $id += $offset;
  $ob->[$id];
}

sub STORE {
  my ($ob,$id,$value) = @_;
#  print "# STORE @_\n";
  $id += $offset;
  $ob->[$id] = $value;
}

sub DELETE {
  my ($ob,$id) = @_;
#  print "# DELETE @_\n";
  $id += $offset;
  delete $ob->[$id];
}

sub EXISTS {
  my ($ob,$id) = @_;
#  print "# EXISTS @_\n";
  $id += $offset;
  exists $ob->[$id];
}

#
# Returning -1 from FETCHSIZE used to get casted to U32 causing a
# segfault
#

package NegFetchsize;

sub TIEARRAY  { bless [] }
sub FETCH     { }
sub FETCHSIZE { -1 }

package main;
  
plan(tests => 69);

{my @ary;

{ my $ob = tie @ary,'Implement',3,2,1;
  ok($ob);
  is(tied(@ary), $ob);
}

is(@ary, 3);
is($#ary, 2);
is(join(':',@ary), '3:2:1');
cmp_ok($seen{'FETCH'}, '>=', 3);

@ary = (1,2,3);

cmp_ok($seen{'STORE'}, '>=', 3);
is(join(':',@ary), '1:2:3');

{my @thing = @ary;
is(join(':',@thing), '1:2:3');

tie @thing,'Implement';
@thing = @ary;
is(join(':',@thing), '1:2:3');
} 

is(pop(@ary), 3);
is($seen{'POP'}, 1);
is(join(':',@ary), '1:2');

is(push(@ary,4), 3);
is($seen{'PUSH'}, 1);
is(join(':',@ary), '1:2:4');

my @x = splice(@ary,1,1,7);

is($seen{'SPLICE'}, 1);
is(@x, 1);
is($x[0], 2);
is(join(':',@ary), '1:7:4');

is(shift(@ary), 1);
is($seen{'SHIFT'}, 1);
is(join(':',@ary), '7:4');

my $n = unshift(@ary,5,6);
is($seen{'UNSHIFT'}, 1);
is($n, 4);
is(join(':',@ary), '5:6:7:4');

@ary = split(/:/,'1:2:3');
is(join(':',@ary), '1:2:3');

my $t = 0;
foreach $n (@ary)
 {
     is($n, ++$t);
 }

# (30-33) 20020303 mjd-perl-patch+@plover.com
@ary = ();
$seen{POP} = 0;
pop @ary;                       # this didn't used to call POP at all
is($seen{POP}, 1);
$seen{SHIFT} = 0;
shift @ary;                     # this didn't used to call SHIFT at  all
is($seen{SHIFT}, 1);
$seen{PUSH} = 0;
my $got = push @ary;            # this didn't used to call PUSH at all
is($got, 0);
is($seen{PUSH}, 1);
$seen{UNSHIFT} = 0;
$got = unshift @ary;            # this didn't used to call UNSHIFT at all
is($got, 0);
is($seen{UNSHIFT}, 1);

@ary = qw(3 2 1);
is(join(':',@ary), '3:2:1');

$#ary = 1;
is($seen{'STORESIZE'}, 1, 'seen STORESIZE');
is(join(':',@ary), '3:2');

sub arysize :lvalue { $#ary }
arysize()--;
is($seen{'STORESIZE'}, 2, 'seen STORESIZE');
is(join(':',@ary), '3');

untie @ary;   

}

# 20020401 mjd-perl-patch+@plover.com
# Thanks to Dave Mitchell for the small test case and the fix
{
  my @a;
  
  sub X::TIEARRAY { bless {}, 'X' }

  sub X::SPLICE {
    do '/dev/null';
    die;
  }

  tie @a, 'X';
  eval { splice(@a) };
  # If we survived this far.
  pass();
}

{ # 20020220 mjd-perl-patch+@plover.com
  my @n;
  tie @n => 'NegIndex', ('A' .. 'E');

  # FETCH
  is($n[0], 'C');
  is($n[1], 'D');
  is($n[2], 'E');
  is($n[-1], 'B');
  is($n[-2], 'A');

  # STORE
  $n[-2] = 'a';
  is($n[-2], 'a');
  $n[-1] = 'b';
  is($n[-1], 'b');
  $n[0] = 'c';
  is($n[0], 'c');
  $n[1] = 'd';
  is($n[1], 'd');
  $n[2] = 'e';
  is($n[2], 'e');

  # DELETE and EXISTS
  for (-2 .. 2) {
    ok($n[$_]);
    delete $n[$_];
    is(defined($n[$_]), '');
    is(exists($n[$_]), '');
  }
}

{
    tie my @dummy, "NegFetchsize";
    eval { "@dummy"; };
    like($@, qr/^FETCHSIZE returned a negative value/,
	 " - croak on negative FETCHSIZE");
}

is($seen{'DESTROY'}, 3);