The London Perl and Raku Workshop takes place on 26th Oct 2024. If your company depends on Perl, please consider sponsoring and/or attending.
#!/usr/local/bin/bin/perl -w
 
use Tie::Watch;
use vars qw/$watch/;

print "1..33\n";

my $aa = 1;
$watch = new Tie::Watch(-variable => \$aa);
$aa = 3;			# test scalar STORE
print $aa == 3 ? "ok 1\n" : "not ok \n"; # test scalar FETCH
$watch->Unwatch;
print $aa == 3 ? "ok 2\n" : "not ok 2\n"; # test -shadow

my %aa = (1,11,2,22);
$watch = new Tie::Watch(-variable => \%aa);
$aa{3} = 33;			# test hash STORE
print $aa{3} == 33 ? "ok 3\n" : "not ok 3\n"; # test hash FETCH
$watch->Unwatch;
print $aa{3} == 33 ? "ok 4\n" : "not ok 4\n"; # test -shadow
$watch = new Tie::Watch(-variable => \%aa);
print exists $aa{3} ? "ok 5\n" : "not ok 5\n"; # test hash EXISTS
$d = delete $aa{3};
print exists $aa{3} ? "not ok 6\n" : "ok 6\n"; # test hash DELETE
print $d == 33 ? "ok 7\n" : "not ok 7\n";
$aa{3} = 333; $aa{4} = 444; $aa{5} = 555;
while ( ($key, $val) = each %aa) {
    last if $key == 3;
}
print $val == 333 ? "ok 8\n" : "not ok 8\n"; # test HASH FIRSTKEY
while ( ($key, $val) = each %aa) {
    $last_val = $val;
}
print $last_val == 555 ? "ok 9\n" : "not ok 9\n"; # test hash NEXTKEY
($key, $val) = each %aa;
# dumb test
print $val == $val ? "ok 10\n" : "not ok 10\n";
print scalar(keys %aa) == 5 ? "ok 11\n" : "not ok 11\n";
@aa=();
print $#aa == -1 ? "ok 12\n" : "not ok 12\n"; # test hash CLEAR

my @aa = (1,2);
$watch = new Tie::Watch(-variable => \@aa);
$aa[2] = 3;			# test array STORE
print scalar(@aa) == 3 ? "ok 13\n" : "not ok 13\n"; # test array FETCHSIZE
print $#aa == 2 ? "ok 14\n" : "not ok 14\n"; # test array FETCHSIZE
print $aa[2] == 3 ? "ok 15\n" : "not ok 15\n"; # test array FETCH
$watch->Unwatch;
print $aa[2] == 3 ? "ok 16\n" : "not ok 16\n"; # test -shadow
$watch = new Tie::Watch(-variable => \@aa);
push @aa, ('frog', 'cow');	# test array PUSH
$#aa = 5;			# extend, fill with 1 undef
my $pop = pop @aa;		# get undef
print defined($pop) ? "not ok 17\n" : "ok 17\n";
$pop = pop @aa;			# should be 'cow'
print $pop eq 'cow' ? "ok 18\n" : "not ok 18\n"; # test array POP
unshift @aa, (-2, -1, 0);
print scalar(@aa) == 7 ? "ok 19\n" : "not ok 19\n"; # test array UNSHIFT
my $shift = shift @aa;
print $shift == -2 ? "ok 20\n" : "not ok 20\n";	# test array SHIFT
@splice = splice @aa, 1, 1, (-0.5, 0, +0.5);
print $splice[0] == 0 ? "ok 21\n" : "not ok 21\n"; # test array SPLICE
@should_be = (-1, -0.5, 0, 0.5, 1, 2, 3, 'frog');
$ok = 1;
for($i = 0; $i <= $#aa; $i++) {
    next if $aa[$i] eq $should_be[$i];
    $ok = 0;
}
print $ok ? "ok 22\n" : "not ok 22\n";
my $delete = delete $aa[$#aa];
$ok = $delete eq 'frog';
print $ok ? "ok 23\n" : "not ok 23: array delete() failure\n";
$aa[ $#aa + 1 ] = 'frog';
$delete = delete $aa[5];
$ok = $delete == 2;
print $ok ? "ok 24\n" : "not ok 24: array delete failure\n";
$aa[5] = $delete;
my $exists = exists $aa[$#aa];
print $exists ? "ok 25\n" : "not ok 25: array exists() failure\n";
@splice = splice @aa, 2,2;
$ok = ($splice[0] == 0 and $splice[1] == 0.5);
print $ok ? "ok 26\n" : "not ok 26\n";
@splice = splice @aa, 4,1,(qw/a b c/);
$ok = ($aa[3] == 2 and join('',@aa[4..$#aa]) eq 'abcfrog');
print $ok ? "ok 27\n" : "not ok 27\n";
print $splice[0] == 3 ? "ok 28\n" : "not ok 28\n";
@splice = splice @aa, 5;
print join('',@splice) eq 'bcfrog' ? "ok 29\n" : "not ok 29\n";
%aa = ();
print scalar(keys %aa) == 0 ? "ok 30\n" : "not ok 30\n"; # test array CLEAR
$watch->Unwatch;
print defined($watch) ? "not ok 31\n" : "ok 31\n";

$aa = \[1];
$watch = new Tie::Watch(-variable => \$aa);
$$aa->[0] = 3;			# test scalar STORE
print $$aa->[0] == 3 ? "ok 32\n" : "not ok 32\n"; # test scalar FETCH
$watch->Unwatch;
print $$aa->[0] == 3 ? "ok 33\n" : "not ok 33\n"; # test -shadow