home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _2ce0af0128570702f0592ee72f56a918 < prev    next >
Text File  |  2004-06-01  |  13KB  |  406 lines
  1. package Tk::Trace;
  2.  
  3. use vars qw($VERSION);
  4. $VERSION = sprintf '4.%03d', q$Revision: #7 $ =~ /\D(\d+)\s*$/;
  5.  
  6. use Carp;
  7. use Tie::Watch;
  8. use strict;
  9.  
  10. # The %TRACE hash is indexed by stringified variable reference. Each hash
  11. # bucket contains an array reference having two elements:
  12. #
  13. # ->[0] = a reference to the variable's Tie::Watch object
  14. # ->[1] = a hash reference with these keys: -fetch, -store, -destroy
  15. #         ->{key} = [ active flag, [ callback list ] ]
  16. #         where each callback is a normalized callback array reference
  17. #
  18. # Thus, each trace type (r w u ) may have multiple traces.
  19.  
  20. my %TRACE;                      # watchpoints indexed by stringified ref
  21.  
  22. my %OP = (            # trace to Tie::Watch operation map
  23.     r => '-fetch',
  24.     w => '-store',
  25.     u => '-destroy',
  26. );
  27.  
  28. sub fetch {
  29.  
  30.     # fetch() wraps the user's callback with necessary tie() bookkeeping
  31.     # and invokes the callback with the proper arguments. It expects:
  32.     #
  33.     # $_[0] = Tie::Watch object
  34.     # $_[1] = undef for a scalar, an index/key for an array/hash
  35.     #
  36.     # The user's callback is passed these arguments:
  37.     #
  38.     #   $_[0]        = undef for a scalar, index/key for array/hash
  39.     #   $_[1]        = current value
  40.     #   $_[2]        = operation 'r'
  41.     #   $_[3 .. $#_] = optional user callback arguments
  42.     #
  43.     # The user callback returns the final value to assign the variable.
  44.  
  45.     my $self = shift;                          # Tie::Watch object
  46.     my $val  = $self->Fetch(@_);               # get variable's current value
  47.     my $aref = $self->Args('-fetch');          # argument reference
  48.     my $call = $TRACE{$aref->[0]}->[1]->{-fetch}; # active flag/callbacks
  49.     return $val unless $call->[0];             # if fetch inactive
  50.  
  51.     my $final_val;
  52.     foreach my $aref (reverse  @$call[ 1 .. $#{@$call} ] ) {
  53.         my ( @args_copy ) = @$aref;
  54.         my $sub = shift @args_copy;            # user's callback
  55.         unshift @_, undef if scalar @_ == 0;   # undef "index" for a scalar
  56.         my @args = @_;                         # save for post-callback work
  57.         $args[1] = &$sub(@_, $val, 'r', @args_copy); # invoke user callback
  58.         shift @args unless defined $args[0];   # drop scalar "index"
  59.         $final_val = $self->Store(@args);      # update variable's value
  60.     }
  61.     $final_val;
  62.  
  63. } # end fetch
  64.  
  65. sub store {
  66.  
  67.     # store() wraps the user's callback with necessary tie() bookkeeping
  68.     # and invokes the callback with the proper arguments. It expects:
  69.     #
  70.     # $_[0] = Tie::Watch object
  71.     # $_[1] = new value for a scalar, index/key for an array/hash
  72.     # $_[2] = undef for a scalar, new value for an array/hash
  73.     #
  74.     # The user's callback is passed these arguments:
  75.     #
  76.     #   $_[0]        = undef for a scalar, index/key for array/hash
  77.     #   $_[1]        = new value
  78.     #   $_[2]        = operation 'w'
  79.     #   $_[3 .. $#_] = optional user callback arguments
  80.     #
  81.     # The user callback returns the final value to assign the variable.
  82.  
  83.     my $self = shift;                          # Tie::Watch object
  84.     my $val  = $self->Store(@_);               # store variable's new value
  85.     my $aref = $self->Args('-store');          # argument reference
  86.     my $call = $TRACE{$aref->[0]}->[1]->{-store}; # active flag/callbacks
  87.     return $val unless $call->[0];             # if store inactive
  88.  
  89.     foreach my $aref ( reverse @$call[ 1 .. $#{@$call} ] ) {
  90.         my ( @args_copy ) = @$aref;
  91.         my $sub = shift @args_copy;            # user's callback
  92.         unshift @_, undef if scalar @_ == 1;   # undef "index" for a scalar
  93.         my @args = @_;                         # save for post-callback work
  94.         $args[1] = &$sub(@_, 'w', @args_copy); # invoke user callback
  95.         shift @args unless defined $args[0];   # drop scalar "index"
  96.         $self->Store(@args);                   # update variable's value
  97.     }
  98.  
  99. } # end store
  100.  
  101. sub destroy {
  102.  
  103.     # destroy() wraps the user's callback with necessary tie() bookkeeping
  104.     # and invokes the callback with the proper arguments. It expects:
  105.     #
  106.     # $_[0] = Tie::Watch object
  107.     #
  108.     # The user's callback is passed these arguments:
  109.     #
  110.     #   $_[0]        = undef for a scalar, index/key for array/hash
  111.     #   $_[1]        = final value
  112.     #   $_[2]        = operation 'u'
  113.     #   $_[3 .. $#_] = optional user callback arguments
  114.  
  115.     my $self = shift;                          # Tie::Watch object
  116.     my $val  = $self->Fetch(@_);               # variable's final value
  117.     my $aref = $self->Args('-destroy');        # argument reference
  118.     my $call = $TRACE{$aref->[0]}->[1]->{-destroy}; # active flag/callbacks
  119.     return $val unless $call->[0];             # if destroy inactive
  120.  
  121.     foreach my $aref ( reverse @$call[ 1 .. $#{@$call} ] ) {
  122.         my ( @args_copy ) = @$aref;
  123.         my $sub = shift @args_copy;            # user's callback
  124.         my $val = $self->Fetch(@_);            # get final value
  125.         &$sub(undef, $val, 'u', @args_copy);   # invoke user callback
  126.         $self->Destroy(@_);                    # destroy variable
  127.     }
  128.  
  129. } # end destroy
  130.  
  131. sub Tk::Widget::traceVariable {
  132.  
  133.     my( $parent, $vref, $op, $callback ) = @_;
  134.  
  135.     {
  136.     $^W = 0;
  137.     croak "Illegal parent '$parent', not a widget" unless ref $parent;
  138.     croak "Illegal variable '$vref', not a reference" unless ref $vref;
  139.     croak "Illegal trace operation '$op'" unless $op;
  140.     croak "Illegal trace operation '$op'" if $op =~ /[^rwu]/;
  141.     croak "Illegal callback ($callback)" unless $callback;
  142.     }
  143.  
  144.     # Need to add our internal callback to user's callback arg list
  145.     # so we can call ours first, followed by the user's callback and
  146.     # any user arguments. Trace callbacks are activated as requied.
  147.  
  148.     my $trace = $TRACE{$vref};
  149.     if ( not defined $trace ) {
  150.         my $watch = Tie::Watch->new(
  151.             -variable => $vref,
  152.             -fetch    => [ \&fetch,   $vref ],
  153.             -store    => [ \&store,   $vref ],
  154.             -destroy  => [ \&destroy, $vref ],
  155.         );
  156.         $trace = $TRACE{$vref} =
  157.             [$watch,
  158.              {
  159.                  -fetch   => [ 0 ],
  160.                  -store   => [ 0 ],
  161.                  -destroy => [ 0 ],
  162.              }
  163.             ];
  164.     }
  165.  
  166.     $callback =  [ $callback ] if ref $callback eq 'CODE';
  167.  
  168.     foreach my $o (split '', $op) {
  169.     push @{$trace->[1]->{$OP{$o}}}, $callback;
  170.     $trace->[1]->{$OP{$o}}->[0] = 1; # activate
  171.     }
  172.  
  173.     return $trace;        # for peeking
  174.  
  175. } # end traceVariable
  176.  
  177. sub Tk::Widget::traceVdelete {
  178.  
  179.     my ( $parent, $vref, $op_not_honored, $callabck_not_honored ) = @_;
  180.  
  181.     if ( defined $TRACE{$vref}->[0] ) {
  182.         $$vref = $TRACE{$vref}->[0]->Fetch;
  183.         $TRACE{$vref}->[0]->Unwatch;
  184.         delete $TRACE{$vref};
  185.     }
  186.  
  187. } # end traceVdelete
  188.  
  189. sub Tk::Widget::traceVinfo {
  190.  
  191.     my ( $parent, $vref ) = @_;
  192.  
  193.     return ( defined $TRACE{$vref}->[0] ) ? $TRACE{$vref}->[0]->Info : undef;
  194.  
  195. } # end traceVinfo
  196.  
  197. =head1 NAME
  198.  
  199. Tk::Trace - emulate Tcl/Tk B<trace> functions.
  200.  
  201. =head1 SYNOPSIS
  202.  
  203.  use Tk::Trace
  204.  
  205.  $mw->traceVariable(\$v, 'wru' => [\&update_meter, $scale]);
  206.  %vinfo = $mw->traceVinfo(\$v);
  207.  print "Trace info  :\n  ", join("\n  ", @{$vinfo{-legible}}), "\n";
  208.  $mw->traceVdelete(\$v);
  209.  
  210. =head1 DESCRIPTION
  211.  
  212. This class module emulates the Tcl/Tk B<trace> family of commands by
  213. binding subroutines of your devising to Perl variables using simple
  214. B<Tie::Watch> features.
  215.  
  216. Callback format is patterned after the Perl/Tk scheme: supply either a
  217. code reference, or, supply an array reference and pass the callback
  218. code reference in the first element of the array, followed by callback
  219. arguments.
  220.  
  221. User callbacks are passed these arguments:
  222.  
  223.  $_[0]        = undef for a scalar, index/key for array/hash
  224.  $_[1]        = variable's current (read), new (write), final (undef) value
  225.  $_[2]        = operation (r, w, or u)
  226.  $_[3 .. $#_] = optional user callback arguments
  227.  
  228. As a Trace user, you have an important responsibility when writing your
  229. callback, since you control the final value assigned to the variable.
  230. A typical callback might look like:
  231.  
  232.  sub callback {
  233.     my($index, $value, $op, @args) = @_;
  234.     return if $op eq 'u';
  235.     # .... code which uses $value ...
  236.     return $value;     # variable's final value
  237.  }
  238.  
  239. Note that the callback's return value becomes the variable's final value,
  240. for either read or write traces.
  241.  
  242. For write operations, the variable is updated with its new value before
  243. the callback is invoked.
  244.  
  245. Multiple read, write and undef callbacks can be attached to a variable,
  246. which are invoked in reverse order of creation.
  247.  
  248. =head1 METHODS
  249.  
  250. =over 4
  251.  
  252. =item $mw->traceVariable(varRef, op => callback);
  253.  
  254. B<varRef> is a reference to the scalar, array or hash variable you
  255. wish to trace.  B<op> is the trace operation, and can be any combination
  256. of B<r> for read, B<w> for write, and B<u> for undef.  B<callback> is a
  257. standard Perl/Tk callback, and is invoked, depending upon the value of
  258. B<op>, whenever the variable is read, written, or destroyed.
  259.  
  260. =item %vinfo = $mw->traceVinfo(varRef);
  261.  
  262. Returns a hash detailing the internals of the Trace object, with these
  263. keys:
  264.  
  265.  %vinfo = (
  266.      -variable =>  varRef
  267.      -debug    =>  '0'
  268.      -shadow   =>  '1'
  269.      -value    =>  'HELLO SCALAR'
  270.      -destroy  =>  callback
  271.      -fetch    =>  callback
  272.      -store    =>  callback
  273.      -legible  =>  above data formatted as a list of string, for printing
  274.  );
  275.  
  276. For array and hash Trace objects, the B<-value> key is replaced with a
  277. B<-ptr> key which is a reference to the parallel array or hash.
  278. Additionally, for an array or hash, there are key/value pairs for
  279. all the variable specific callbacks.
  280.  
  281. =item $mw->traceVdelete(\$v);
  282.  
  283. Stop tracing the variable.
  284.  
  285. =back
  286.  
  287. =head1 EXAMPLES
  288.  
  289.  # Trace a Scale's variable and move a meter in unison.
  290.  
  291.  use Tk;
  292.  use Tk::widgets qw/Trace/;
  293.  
  294.  $pi = 3.1415926;
  295.  $mw = MainWindow->new;
  296.  $c = $mw->Canvas( qw/-width 200 -height 110 -bd 2 -relief sunken/ )->grid;
  297.  $c->createLine( qw/100 100 10 100 -tag meter -arrow last -width 5/ );
  298.  $s = $mw->Scale( qw/-orient h -from 0 -to 100 -variable/ => \$v )->grid;
  299.  $mw->Label( -text => 'Slide Me for 5 Seconds' )->grid;
  300.  
  301.  $mw->traceVariable( \$v, 'w' => [ \&update_meter, $s ] );
  302.  
  303.  $mw->after( 5000 => sub {
  304.      print "Untrace time ...\n";
  305.      %vinfo = $s->traceVinfo( \$v );
  306.      print "Watch info  :\n  ", join("\n  ", @{$vinfo{-legible}}), "\n";
  307.      $c->traceVdelete( \$v );
  308.  });
  309.  
  310.  MainLoop;
  311.  
  312.  sub update_meter {
  313.      my( $index, $value, $op, @args ) = @_;
  314.      return if $op eq 'u';
  315.      $min = $s->cget( -from );
  316.      $max = $s->cget( -to );
  317.      $pos = $value / abs( $max - $min );
  318.      $x = 100.0 - 90.0 * ( cos( $pos * $pi ) );
  319.      $y = 100.0 - 90.0 * ( sin( $pos * $pi ) );
  320.      $c->coords( qw/meter 100 100/, $x, $y );
  321.      return $value;
  322.  }
  323.  
  324.  # Predictive text entry.
  325.  
  326.  use Tk;
  327.  use Tk::widgets qw/ LabEntry Trace /;
  328.  use strict;
  329.  
  330.  my @words =  qw/radio television telephone turntable microphone/;
  331.  
  332.  my $mw = MainWindow->new;
  333.  
  334.  my $e = $mw->LabEntry(
  335.      qw/ -label Thing -width 40 /,
  336.      -labelPack    => [ qw/ -side left / ],
  337.      -textvariable => \my $thing,
  338.  );
  339.  my $t = $mw->Text( qw/ -height 10 -width 50 / );;
  340.  
  341.  $t->pack( $e, qw/ -side top / );
  342.  
  343.  $e->focus;
  344.  $e->traceVariable( \$thing, 'w', [ \&trace_thing, $e, $t ] );
  345.  
  346.  foreach my $k ( 1 .. 12 ) {
  347.      $e->bind( "<F${k}>" => [ \&ins, $t, Ev('K') ] );
  348.  }
  349.  $e->bind( '<Return>' =>
  350.            sub {
  351.                print "$thing\n";
  352.                $_[0]->delete( 0, 'end' );
  353.            }
  354.  );
  355.  
  356.  MainLoop;
  357.  
  358.  sub trace_thing {
  359.  
  360.      my( $index, $value, $op, $e, $t ) = @_;
  361.  
  362.      return unless $value;
  363.  
  364.      $t->delete( qw/ 1.0 end / );
  365.      foreach my $w ( @words ) {
  366.          if ( $w =~ /^$value/ ) {
  367.              $t->insert( 'end', "$w\n" );
  368.          }
  369.      }
  370.  
  371.      return $value;
  372.  
  373.  } # end trace_thing
  374.  
  375.  sub ins {
  376.  
  377.      my( $e, $t, $K ) = @_;
  378.  
  379.      my( $index ) = $K =~ /^F(\d+)$/;
  380.  
  381.      $e->delete( 0, 'end' );
  382.      $e->insert( 'end', $t->get( "$index.0", "$index.0 lineend" ) );
  383.      $t->delete( qw/ 1.0 end / );
  384.  
  385.  } # end ins
  386.  
  387. =head1 HISTORY
  388.  
  389.  Stephen.O.Lidie@Lehigh.EDU, Lehigh University Computing Center, 2000/08/01
  390.  . Version 1.0, for Tk800.022.
  391.  
  392.  sol0@Lehigh.EDU, Lehigh University Computing Center, 2003/09/22
  393.  . Version 1.1, for Tk804.025, add support for multiple traces of the same
  394.    type on the same variable.
  395.  
  396. =head1 COPYRIGHT
  397.  
  398. Copyright (C) 2000 - 2003 Stephen O. Lidie. All rights reserved.
  399.  
  400. This program is free software; you can redistribute it and/or modify it under
  401. the same terms as Perl itself.
  402.  
  403. =cut
  404.  
  405. 1;
  406.