summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl0/lib/Tk/Trace.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl0/lib/Tk/Trace.pm')
-rwxr-xr-xMaster/tlpkg/tlperl0/lib/Tk/Trace.pm405
1 files changed, 405 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl0/lib/Tk/Trace.pm b/Master/tlpkg/tlperl0/lib/Tk/Trace.pm
new file mode 100755
index 00000000000..d4bd5600438
--- /dev/null
+++ b/Master/tlpkg/tlperl0/lib/Tk/Trace.pm
@@ -0,0 +1,405 @@
+package Tk::Trace;
+
+use vars qw($VERSION);
+$VERSION = '4.008'; # was: sprintf '4.%03d', q$Revision: #7 $ =~ /\D(\d+)\s*$/;
+
+use Carp;
+use Tie::Watch;
+use strict;
+
+# The %TRACE hash is indexed by stringified variable reference. Each hash
+# bucket contains an array reference having two elements:
+#
+# ->[0] = a reference to the variable's Tie::Watch object
+# ->[1] = a hash reference with these keys: -fetch, -store, -destroy
+# ->{key} = [ active flag, [ callback list ] ]
+# where each callback is a normalized callback array reference
+#
+# Thus, each trace type (r w u ) may have multiple traces.
+
+my %TRACE; # watchpoints indexed by stringified ref
+
+my %OP = ( # trace to Tie::Watch operation map
+ r => '-fetch',
+ w => '-store',
+ u => '-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'
+ # $_[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 $call = $TRACE{$aref->[0]}->[1]->{-fetch}; # active flag/callbacks
+ return $val unless $call->[0]; # if fetch inactive
+
+ my $final_val;
+ foreach my $aref (reverse @$call[ 1 .. $#{$call} ] ) {
+ my ( @args_copy ) = @$aref;
+ my $sub = shift @args_copy; # 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', @args_copy); # invoke user callback
+ shift @args unless defined $args[0]; # drop scalar "index"
+ $final_val = $self->Store(@args); # update variable's value
+ }
+ $final_val;
+
+} # end fetch
+
+sub store {
+
+ # store() wraps the user's callback with necessary tie() bookkeeping
+ # and invokes the callback with the proper arguments. It expects:
+ #
+ # $_[0] = Tie::Watch object
+ # $_[1] = new value for a scalar, index/key for an array/hash
+ # $_[2] = undef for a scalar, new value for an array/hash
+ #
+ # The user's callback is passed these arguments:
+ #
+ # $_[0] = undef for a scalar, index/key for array/hash
+ # $_[1] = new value
+ # $_[2] = operation 'w'
+ # $_[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->Store(@_); # store variable's new value
+ my $aref = $self->Args('-store'); # argument reference
+ my $call = $TRACE{$aref->[0]}->[1]->{-store}; # active flag/callbacks
+ return $val unless $call->[0]; # if store inactive
+
+ foreach my $aref ( reverse @$call[ 1 .. $#{$call} ] ) {
+ my ( @args_copy ) = @$aref;
+ my $sub = shift @args_copy; # user's callback
+ unshift @_, undef if scalar @_ == 1; # undef "index" for a scalar
+ my @args = @_; # save for post-callback work
+ $args[1] = &$sub(@_, 'w', @args_copy); # invoke user callback
+ shift @args unless defined $args[0]; # drop scalar "index"
+ $self->Store(@args); # update variable's value
+ }
+
+} # end store
+
+sub destroy {
+
+ # destroy() wraps the user's callback with necessary tie() bookkeeping
+ # and invokes the callback with the proper arguments. It expects:
+ #
+ # $_[0] = Tie::Watch object
+ #
+ # The user's callback is passed these arguments:
+ #
+ # $_[0] = undef for a scalar, index/key for array/hash
+ # $_[1] = final value
+ # $_[2] = operation 'u'
+ # $_[3 .. $#_] = optional user callback arguments
+
+ my $self = shift; # Tie::Watch object
+ my $val = $self->Fetch(@_); # variable's final value
+ my $aref = $self->Args('-destroy'); # argument reference
+ my $call = $TRACE{$aref->[0]}->[1]->{-destroy}; # active flag/callbacks
+ return $val unless $call->[0]; # if destroy inactive
+
+ foreach my $aref ( reverse @$call[ 1 .. $#{$call} ] ) {
+ my ( @args_copy ) = @$aref;
+ my $sub = shift @args_copy; # user's callback
+ my $val = $self->Fetch(@_); # get final value
+ &$sub(undef, $val, 'u', @args_copy); # invoke user callback
+ $self->Destroy(@_); # destroy variable
+ }
+
+} # end destroy
+
+sub Tk::Widget::traceVariable {
+
+ my( $parent, $vref, $op, $callback ) = @_;
+
+ {
+ $^W = 0;
+ croak "Illegal parent '$parent', not a widget" unless ref $parent;
+ croak "Illegal variable '$vref', not a reference" unless ref $vref;
+ croak "Illegal trace operation '$op'" unless $op;
+ croak "Illegal trace operation '$op'" if $op =~ /[^rwu]/;
+ croak "Illegal callback ($callback)" unless $callback;
+ }
+
+ # Need to add our internal callback to user's callback arg list
+ # so we can call ours first, followed by the user's callback and
+ # any user arguments. Trace callbacks are activated as requied.
+
+ my $trace = $TRACE{$vref};
+ if ( not defined $trace ) {
+ my $watch = Tie::Watch->new(
+ -variable => $vref,
+ -fetch => [ \&fetch, $vref ],
+ -store => [ \&store, $vref ],
+ -destroy => [ \&destroy, $vref ],
+ );
+ $trace = $TRACE{$vref} =
+ [$watch,
+ {
+ -fetch => [ 0 ],
+ -store => [ 0 ],
+ -destroy => [ 0 ],
+ }
+ ];
+ }
+
+ $callback = [ $callback ] if ref $callback eq 'CODE';
+
+ foreach my $o (split '', $op) {
+ push @{$trace->[1]->{$OP{$o}}}, $callback;
+ $trace->[1]->{$OP{$o}}->[0] = 1; # activate
+ }
+
+ return $trace; # for peeking
+
+} # end traceVariable
+
+sub Tk::Widget::traceVdelete {
+
+ my ( $parent, $vref, $op_not_honored, $callabck_not_honored ) = @_;
+
+ if ( defined $TRACE{$vref}->[0] ) {
+ $$vref = $TRACE{$vref}->[0]->Fetch;
+ $TRACE{$vref}->[0]->Unwatch;
+ delete $TRACE{$vref};
+ }
+
+} # end traceVdelete
+
+sub Tk::Widget::traceVinfo {
+
+ my ( $parent, $vref ) = @_;
+
+ return ( defined $TRACE{$vref}->[0] ) ? $TRACE{$vref}->[0]->Info : undef;
+
+} # end traceVinfo
+
+=head1 NAME
+
+Tk::Trace - emulate Tcl/Tk B<trace> functions.
+
+=head1 SYNOPSIS
+
+ use Tk::Trace
+
+ $mw->traceVariable(\$v, 'wru' => [\&update_meter, $scale]);
+ %vinfo = $mw->traceVinfo(\$v);
+ print "Trace info :\n ", join("\n ", @{$vinfo{-legible}}), "\n";
+ $mw->traceVdelete(\$v);
+
+=head1 DESCRIPTION
+
+This class module emulates the Tcl/Tk B<trace> family of commands by
+binding subroutines of your devising to Perl variables using simple
+B<Tie::Watch> features.
+
+Callback format is patterned after the Perl/Tk scheme: supply either a
+code reference, or, supply an array reference and pass the callback
+code reference in the first element of the array, followed by callback
+arguments.
+
+User callbacks are passed these arguments:
+
+ $_[0] = undef for a scalar, index/key for array/hash
+ $_[1] = variable's current (read), new (write), final (undef) value
+ $_[2] = operation (r, w, or u)
+ $_[3 .. $#_] = optional user callback arguments
+
+As a Trace user, you have an important responsibility when writing your
+callback, since you control the final value assigned to the variable.
+A typical callback might look like:
+
+ sub callback {
+ my($index, $value, $op, @args) = @_;
+ return if $op eq 'u';
+ # .... code which uses $value ...
+ return $value; # variable's final value
+ }
+
+Note that the callback's return value becomes the variable's final value,
+for either read or write traces.
+
+For write operations, the variable is updated with its new value before
+the callback is invoked.
+
+Multiple read, write and undef callbacks can be attached to a variable,
+which are invoked in reverse order of creation.
+
+=head1 METHODS
+
+=over 4
+
+=item $mw->traceVariable(varRef, op => callback);
+
+B<varRef> is a reference to the scalar, array or hash variable you
+wish to trace. B<op> is the trace operation, and can be any combination
+of B<r> for read, B<w> for write, and B<u> for undef. B<callback> is a
+standard Perl/Tk callback, and is invoked, depending upon the value of
+B<op>, whenever the variable is read, written, or destroyed.
+
+=item %vinfo = $mw->traceVinfo(varRef);
+
+Returns a hash detailing the internals of the Trace object, with these
+keys:
+
+ %vinfo = (
+ -variable => varRef
+ -debug => '0'
+ -shadow => '1'
+ -value => 'HELLO SCALAR'
+ -destroy => callback
+ -fetch => callback
+ -store => callback
+ -legible => above data formatted as a list of string, for printing
+ );
+
+For array and hash Trace objects, the B<-value> key is replaced with a
+B<-ptr> key which is a reference to the parallel array or hash.
+Additionally, for an array or hash, there are key/value pairs for
+all the variable specific callbacks.
+
+=item $mw->traceVdelete(\$v);
+
+Stop tracing the variable.
+
+=back
+
+=head1 EXAMPLES
+
+ # Trace a Scale's variable and move a meter in unison.
+
+ use Tk;
+ use Tk::widgets qw/Trace/;
+
+ $pi = 3.1415926;
+ $mw = MainWindow->new;
+ $c = $mw->Canvas( qw/-width 200 -height 110 -bd 2 -relief sunken/ )->grid;
+ $c->createLine( qw/100 100 10 100 -tag meter -arrow last -width 5/ );
+ $s = $mw->Scale( qw/-orient h -from 0 -to 100 -variable/ => \$v )->grid;
+ $mw->Label( -text => 'Slide Me for 5 Seconds' )->grid;
+
+ $mw->traceVariable( \$v, 'w' => [ \&update_meter, $s ] );
+
+ $mw->after( 5000 => sub {
+ print "Untrace time ...\n";
+ %vinfo = $s->traceVinfo( \$v );
+ print "Watch info :\n ", join("\n ", @{$vinfo{-legible}}), "\n";
+ $c->traceVdelete( \$v );
+ });
+
+ MainLoop;
+
+ sub update_meter {
+ my( $index, $value, $op, @args ) = @_;
+ return if $op eq 'u';
+ $min = $s->cget( -from );
+ $max = $s->cget( -to );
+ $pos = $value / abs( $max - $min );
+ $x = 100.0 - 90.0 * ( cos( $pos * $pi ) );
+ $y = 100.0 - 90.0 * ( sin( $pos * $pi ) );
+ $c->coords( qw/meter 100 100/, $x, $y );
+ return $value;
+ }
+
+ # Predictive text entry.
+
+ use Tk;
+ use Tk::widgets qw/ LabEntry Trace /;
+ use strict;
+
+ my @words = qw/radio television telephone turntable microphone/;
+
+ my $mw = MainWindow->new;
+
+ my $e = $mw->LabEntry(
+ qw/ -label Thing -width 40 /,
+ -labelPack => [ qw/ -side left / ],
+ -textvariable => \my $thing,
+ );
+ my $t = $mw->Text( qw/ -height 10 -width 50 / );;
+
+ $t->pack( $e, qw/ -side top / );
+
+ $e->focus;
+ $e->traceVariable( \$thing, 'w', [ \&trace_thing, $e, $t ] );
+
+ foreach my $k ( 1 .. 12 ) {
+ $e->bind( "<F${k}>" => [ \&ins, $t, Ev('K') ] );
+ }
+ $e->bind( '<Return>' =>
+ sub {
+ print "$thing\n";
+ $_[0]->delete( 0, 'end' );
+ }
+ );
+
+ MainLoop;
+
+ sub trace_thing {
+
+ my( $index, $value, $op, $e, $t ) = @_;
+
+ return unless $value;
+
+ $t->delete( qw/ 1.0 end / );
+ foreach my $w ( @words ) {
+ if ( $w =~ /^$value/ ) {
+ $t->insert( 'end', "$w\n" );
+ }
+ }
+
+ return $value;
+
+ } # end trace_thing
+
+ sub ins {
+
+ my( $e, $t, $K ) = @_;
+
+ my( $index ) = $K =~ /^F(\d+)$/;
+
+ $e->delete( 0, 'end' );
+ $e->insert( 'end', $t->get( "$index.0", "$index.0 lineend" ) );
+ $t->delete( qw/ 1.0 end / );
+
+ } # end ins
+
+=head1 HISTORY
+
+ Stephen.O.Lidie@Lehigh.EDU, Lehigh University Computing Center, 2000/08/01
+ . Version 1.0, for Tk800.022.
+
+ sol0@Lehigh.EDU, Lehigh University Computing Center, 2003/09/22
+ . Version 1.1, for Tk804.025, add support for multiple traces of the same
+ type on the same variable.
+
+=head1 COPYRIGHT
+
+Copyright (C) 2000 - 2003 Stephen O. Lidie. All rights reserved.
+
+This program is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
+
+1;