package Tk::Trace;
use vars qw($VERSION);
$VERSION = '3.002'; # $Id: //depot/Tk8/Tk/Trace.pm#2 $
use Exporter;
use base qw/Exporter/;
@EXPORT=qw/traceVariable traceVdelete traceVinfo/;
use Tie::Watch;
use strict;
my%trace;
my%op=('r'=>['-fetch',\&fetch],'w'=>['-store',\&store],'u'=>['-destroy',\&destroy],);
sub fetch{my$self=shift;
my$val=$self->Fetch(@_);
my$aref=$self->Args(-fetch);
my$sub=shift@$aref;
unshift@_,undef if scalar@_==0;
my@args=@_;
$args[1]=&$sub(@_,$val,'r',@$aref);
shift@args unless defined$args[0];
$self->Store(@args);}sub store{my$self=shift;
$self->Store(@_);
my$aref=$self->Args(-store);
my$sub=shift@$aref;
unshift@_,undef if scalar@_==1;
my@args=@_;
$args[1]=&$sub(@_,'w',@$aref);
shift@args unless defined$args[0];
$self->Store(@args);}sub destroy{my$self=shift;
my$aref=$self->Args(-destroy);
my$sub=shift@$aref;
my$val=$self->Fetch(@_);
&$sub(undef,$val,'u',@$aref);
$self->Destroy(@_);}sub traceVariable{my($parent,$vref,$op,$callback)=@_;
die"Illegal parent." unless ref$parent;
die"Illegal variable." unless ref$vref;
die"Illegal trace operation '$op'." unless$op;
die"Illegal trace operation '$op'." if$op=~/[^rwu]/;
die"Illegal callback." unless$callback;
my($fetch,$store,$destroy);
if(ref$callback eq 'CODE'){$fetch=[\&fetch,$callback];
$store=[\&store,$callback];
$destroy=[\&destroy,$callback];}else{$fetch=[\&fetch,@$callback];
$store=[\&store,@$callback];
$destroy=[\&destroy,@$callback];}my@wargs;
push@wargs,(-fetch=>$fetch)if$op=~/r/;
push@wargs,(-store=>$store)if$op=~/w/;
push@wargs,(-destroy=>$destroy)if$op=~/w/;
my$watch=Tie::Watch->new(-variable=>$vref,@wargs,);
$trace{$vref}=$watch;}sub traceVdelete{my($parent,$vref,$op_not_honored,$callabck_not_honored)=@_;
if(defined$trace{$vref}){$trace{$vref}->Unwatch;
delete$trace{$vref};}}sub traceVinfo{my($parent,$vref)=@_;
return(defined$trace{$vref})?$trace{$vref}->Info:undef;}1;
