#!./perl


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

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 main;

print "1..36\n";                   
my $test = 1;

{my @ary;

{ my $ob = tie @ary,'Implement',3,2,1;
  print "not " unless $ob;
  print "ok ", $test++,"\n";
  print "not " unless tied(@ary) == $ob;
  print "ok ", $test++,"\n";
}


print "not " unless @ary == 3;
print "ok ", $test++,"\n";

print "not " unless $#ary == 2;
print "ok ", $test++,"\n";

print "not " unless join(':',@ary) eq '3:2:1';
print "ok ", $test++,"\n";         

print "not " unless $seen{'FETCH'} >= 3;
print "ok ", $test++,"\n";

@ary = (1,2,3);

print "not " unless $seen{'STORE'} >= 3;
print "ok ", $test++,"\n";
print "not " unless join(':',@ary) eq '1:2:3';
print "ok ", $test++,"\n";         

{my @thing = @ary;
print "not " unless join(':',@thing) eq '1:2:3';
print "ok ", $test++,"\n";         

tie @thing,'Implement';
@thing = @ary;
print "not " unless join(':',@thing) eq '1:2:3';
print "ok ", $test++,"\n";
} 

print "not " unless pop(@ary) == 3;
print "ok ", $test++,"\n";
print "not " unless $seen{'POP'} == 1;
print "ok ", $test++,"\n";
print "not " unless join(':',@ary) eq '1:2';
print "ok ", $test++,"\n";

push(@ary,4);
print "not " unless $seen{'PUSH'} == 1;
print "ok ", $test++,"\n";
print "not " unless join(':',@ary) eq '1:2:4';
print "ok ", $test++,"\n";

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


print "not " unless $seen{'SPLICE'} == 1;
print "ok ", $test++,"\n";

print "not " unless @x == 1;
print "ok ", $test++,"\n";
print "not " unless $x[0] == 2;
print "ok ", $test++,"\n";
print "not " unless join(':',@ary) eq '1:7:4';
print "ok ", $test++,"\n";             

print "not " unless shift(@ary) == 1;
print "ok ", $test++,"\n";
print "not " unless $seen{'SHIFT'} == 1;
print "ok ", $test++,"\n";
print "not " unless join(':',@ary) eq '7:4';
print "ok ", $test++,"\n";             

my $n = unshift(@ary,5,6);
print "not " unless $seen{'UNSHIFT'} == 1;
print "ok ", $test++,"\n";
print "not " unless $n == 4;
print "ok ", $test++,"\n";
print "not " unless join(':',@ary) eq '5:6:7:4';
print "ok ", $test++,"\n";

@ary = split(/:/,'1:2:3');
print "not " unless join(':',@ary) eq '1:2:3';
print "ok ", $test++,"\n";         

  
my $t = 0;
foreach $n (@ary)
 {
  print "not " unless $n == ++$t;
  print "ok ", $test++,"\n";         
 }

# (30-33) 20020303 mjd-perl-patch+@plover.com
@ary = ();
$seen{POP} = 0;
pop @ary;                       # this didn't used to call POP at all
print "not " unless $seen{POP} == 1;
print "ok ", $test++,"\n";         
$seen{SHIFT} = 0;
shift @ary;                     # this didn't used to call SHIFT at  all
print "not " unless $seen{SHIFT} == 1;
print "ok ", $test++,"\n";         
$seen{PUSH} = 0;
push @ary;                       # this didn't used to call PUSH at all
print "not " unless $seen{PUSH} == 1;
print "ok ", $test++,"\n";         
$seen{UNSHIFT} = 0;
unshift @ary;                   # this didn't used to call UNSHIFT at all
print "not " unless $seen{UNSHIFT} == 1;
print "ok ", $test++,"\n";         

@ary = qw(3 2 1);
print "not " unless join(':',@ary) eq '3:2:1';
print "ok ", $test++,"\n";         

untie @ary;   

}

# 20020401 mjd-perl-patch+@plover.com
# Thanks to Dave Mitchell for the small test case
{ require './test.pl';
  local $::TODO = 'Not fixed yet';
  fresh_perl_is(<<'End_of_Test', "ok", {}, "Core dump in 'leavetry'");
######## [ID 20020301.011] Core dump in 'leavetry' in 5.7.2
  my @a;
  
  sub X::TIEARRAY { bless {}, 'X' }

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

  tie @a, 'X';
  eval { splice(@a) };
  print "ok\n"
End_of_Test
}
                           
print "not " unless $seen{'DESTROY'} == 2;
print "ok ", $test++,"\n";