Mastering Perl/Tk

Tk::Trace

The Tk::Trace module can be used to trace Perl/Tk variables. See Chapter 15 for explanation and demonstration.

$Tk::Trace::VERSION = '1.0'; package Tk::Trace; use Exporter; use base qw/Exporter/; @EXPORT = qw/traceVariable traceVdelete traceVinfo/; use Tie::Watch; use strict; my %trace; # watchpoints indexed by stringified ref my %op = ( # map Tcl op to tie function 'r' => ['-fetch', \&fetch], 'w' => ['-store', \&store], 'u' => ['-destroy', \&destroy], ); sub fetch { # fetch() wraps the user's callback with necessary tie( ) bookkeeping # and invokes the callback with the proper arguments. It expects: # # $_[0] = Tie::Watch object # $_[1] = undef for a scalar, an index/key for an array/hash # # The user's callback is passed these arguments: # # $_[0] = undef for a scalar, index/key for array/hash # $_[1] = current value # $_[2] = operation (r, w, or u) # $_[3 .. $#_] = optional user callback arguments # # The user callback returns the final value to assign the variable. my $self = shift; # Tie::Watch object my $val = $self->Fetch(@_); # get variable's current value my $aref = $self->Args(-fetch); # argument reference my $sub = shift @$aref; # user's callback unshift @_, undef if scalar @_ == 0; # undef "index" for a scalar my @args = @_; # save for post-callback work $args[1] = &$sub(@_, $val, 'r', @$aref); # invoke user callback shift @args unless defined $args[0]; # drop scalar "index" $self->Store(@args); # update variable's value } # end fetch sub store { # store() ...