#!/usr/local/bin/perl -w
use strict;
use Tie::Watch;
use vars '$do_tk';
BEGIN {
$do_tk = 1;
eval "use Tk";
$do_tk = 0 if $@;
}
# Complete documentation on Watch is a pod in the module file. Watch works on
# plain scalars, arrays, or hashes. Do *NOT* Watch Tk widgets! But Watch does
# work OK with Tk otherwise.
my $demos = 'saht';
my $foo; # Watch variables
my @foo;
my %foo;
my %vinfo; # variable Watch information
my $date; # a changing time
my $w_scalar; # Watch objects
my $w_array;
my $w_hash;
my $fetch_scalar = sub {
my($self) = @_;
$self->Fetch;
};
my $store_scalar = sub {
my($self, $new_val) = @_;
$self->Store(uc $new_val);
};
my $fetch = sub {
my($self, $key) = @_;
my $val = $self->Fetch($key);
print "In fetch callback, key=$key, val=", $self->Say($val);
my $args = $self->Args(-fetch);
print ", args=('", join("', '", @$args), "')" if $args;
print ".\n";
$val;
};
my $store = sub {
my($self, $key, $new_val) = @_;
my $val = $self->Fetch($key);
$new_val = uc $new_val;
$self->Store($key, $new_val);
print "In store callback, key=$key, val=", $self->Say($val),
", new_val=", $self->Say($new_val);
my $args = $self->Args(-store);
print ", args=('", join("', '", @$args), "')" if $args;
print ".\n";
$new_val;
};
if ($demos =~ /s/) {
chomp($date = `date`); $date = substr $date, 11, 8;
$foo='frog';
$w_scalar = Tie::Watch->new(
-variable => \$foo,
-fetch => $fetch_scalar,
-store => $store_scalar,
-destroy => sub {print "Final value of \$foo=$foo.\n"},
-debug => 1,
);
$foo = "hello scalar";
print "Final value: $foo\n";
%vinfo = $w_scalar->Info;
print "Watch info :\n ", join("\n ", @{$vinfo{-legible}}), "\n";
$w_scalar->Unwatch;
sleep 1;
}
if ($demos =~ /a/) {
print "\n********** Test Watch Array **********\n";
chomp($date = `date`); $date = substr $date, 11, 8;
$w_array = Tie::Watch->new(
-variable => \@foo,
-fetch => $fetch,
-store => [$store, 'array write', $date],
);
@foo = ("hello", 'array');
my($a, $b) = ($foo[0], $foo[1]);
print "Final value: $a $b\n";
%vinfo = $w_array->Info;
print "Watch info :\n ", join("\n ", @{$vinfo{-legible}}), "\n";
$w_array->Unwatch;
sleep 1;
}
if ($demos =~ /h/) {
print "\n********** Test Watch Hash **********\n";
chomp($date = `date`); $date = substr $date, 11, 8;
$w_hash = Tie::Watch->new(
-variable => \%foo,
-fetch => [$fetch, 'hash read', $date],
-store => $store,
);
%foo = ('k1' => "hello", 'k2' => 'hash ');
my($a, $b) = ($foo{k1}, $foo{k2});
print "Final value: $a $b\n";
%vinfo = $w_hash->Info;
print "Watch info :\n ", join("\n ", @{$vinfo{-legible}}), "\n";
foreach (keys %foo) {
print "key=$_, value=$foo{$_}.\n";
}
if (exists $foo{k2}) {
print "k2 does exist\n";
} else {
print "k2 does not exists\n";
}
delete $foo{k2};
if (exists $foo{k2}) {
print "k2 does exist\n";
} else {
print "k2 does not exist\n";
}
print "keys=", join(', ', keys %foo), ".\n";
print "\n";
$w_hash->Unwatch
}
print "For a Tk example, run tktie.\n";