Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | package Tk::Trace; |
2 | ||
3 | use vars qw($VERSION); | |
4 | $VERSION = '3.002'; # $Id: //depot/Tk8/Tk/Trace.pm#2 $ | |
5 | ||
6 | use Exporter; | |
7 | use base qw/Exporter/; | |
8 | @EXPORT = qw/traceVariable traceVdelete traceVinfo/; | |
9 | use Tie::Watch; | |
10 | use strict; | |
11 | ||
12 | my %trace; # watchpoints indexed by stringified ref | |
13 | my %op = ( # map Tcl op to tie function | |
14 | 'r' => ['-fetch', \&fetch], | |
15 | 'w' => ['-store', \&store], | |
16 | 'u' => ['-destroy', \&destroy], | |
17 | ); | |
18 | ||
19 | sub fetch { | |
20 | ||
21 | # fetch() wraps the user's callback with necessary tie() bookkeeping | |
22 | # and invokes the callback with the proper arguments. It expects: | |
23 | # | |
24 | # $_[0] = Tie::Watch object | |
25 | # $_[1] = undef for a scalar, an index/key for an array/hash | |
26 | # | |
27 | # The user's callback is passed these arguments: | |
28 | # | |
29 | # $_[0] = undef for a scalar, index/key for array/hash | |
30 | # $_[1] = current value | |
31 | # $_[2] = operation (r, w, or u) | |
32 | # $_[3 .. $#_] = optional user callback arguments | |
33 | # | |
34 | # The user callback returns the final value to assign the variable. | |
35 | ||
36 | my $self = shift; # Tie::Watch object | |
37 | my $val = $self->Fetch(@_); # get variable's current value | |
38 | my $aref = $self->Args(-fetch); # argument reference | |
39 | my $sub = shift @$aref; # user's callback | |
40 | unshift @_, undef if scalar @_ == 0; # undef "index" for a scalar | |
41 | my @args = @_; # save for post-callback work | |
42 | $args[1] = &$sub(@_, $val, 'r', @$aref); # invoke user callback | |
43 | shift @args unless defined $args[0]; # drop scalar "index" | |
44 | $self->Store(@args); # update variable's value | |
45 | ||
46 | } # end fetch | |
47 | ||
48 | sub store { | |
49 | ||
50 | # store() wraps the user's callback with necessary tie() bookkeeping | |
51 | # and invokes the callback with the proper arguments. It expects: | |
52 | # | |
53 | # $_[0] = Tie::Watch object | |
54 | # $_[1] = new value for a scalar, index/key for an array/hash | |
55 | # $_[2] = undef for a scalar, new value for an array/hash | |
56 | # | |
57 | # The user's callback is passed these arguments: | |
58 | # | |
59 | # $_[0] = undef for a scalar, index/key for array/hash | |
60 | # $_[1] = new value | |
61 | # $_[2] = operation (r, w, or u) | |
62 | # $_[3 .. $#_] = optional user callback arguments | |
63 | # | |
64 | # The user callback returns the final value to assign the variable. | |
65 | ||
66 | my $self = shift; # Tie::Watch object | |
67 | $self->Store(@_); # store variable's new value | |
68 | my $aref = $self->Args(-store); # argument reference | |
69 | my $sub = shift @$aref; # user's callback | |
70 | unshift @_, undef if scalar @_ == 1; # undef "index" for a scalar | |
71 | my @args = @_; # save for post-callback work | |
72 | $args[1] = &$sub(@_, 'w', @$aref); # invoke user callback | |
73 | shift @args unless defined $args[0]; # drop scalar "index" | |
74 | $self->Store(@args); # update variable's value | |
75 | ||
76 | } # end store | |
77 | ||
78 | sub destroy { | |
79 | my $self = shift; | |
80 | my $aref = $self->Args(-destroy); # argument reference | |
81 | my $sub = shift @$aref; # user's callback | |
82 | my $val = $self->Fetch(@_); # get final value | |
83 | &$sub(undef, $val, 'u', @$aref); # invoke user callback | |
84 | $self->Destroy(@_); # destroy variable | |
85 | } | |
86 | ||
87 | sub traceVariable { | |
88 | my($parent, $vref, $op, $callback) = @_; | |
89 | die "Illegal parent." unless ref $parent; | |
90 | die "Illegal variable." unless ref $vref; | |
91 | die "Illegal trace operation '$op'." unless $op; | |
92 | die "Illegal trace operation '$op'." if $op =~ /[^rwu]/; | |
93 | die "Illegal callback." unless $callback; | |
94 | ||
95 | # Need to add our internal callback to user's callback arg list | |
96 | # so we can call it first, followed by the user's callback and | |
97 | # any user arguments. | |
98 | ||
99 | my($fetch, $store, $destroy); | |
100 | if (ref $callback eq 'CODE') { | |
101 | $fetch = [\&fetch, $callback]; | |
102 | $store = [\&store, $callback]; | |
103 | $destroy = [\&destroy, $callback]; | |
104 | } else { # assume [] form | |
105 | $fetch = [\&fetch, @$callback]; | |
106 | $store = [\&store, @$callback]; | |
107 | $destroy = [\&destroy, @$callback]; | |
108 | } | |
109 | ||
110 | my @wargs; | |
111 | push @wargs, (-fetch => $fetch) if $op =~ /r/; | |
112 | push @wargs, (-store => $store) if $op =~ /w/; | |
113 | push @wargs, (-destroy => $destroy) if $op =~ /w/; | |
114 | my $watch = Tie::Watch->new( | |
115 | -variable => $vref, | |
116 | @wargs, | |
117 | ); | |
118 | ||
119 | $trace{$vref} = $watch; | |
120 | ||
121 | } # end traceVariable | |
122 | ||
123 | sub traceVdelete { | |
124 | my($parent, $vref, $op_not_honored, $callabck_not_honored) = @_; | |
125 | if (defined $trace{$vref}) { | |
126 | $trace{$vref}->Unwatch; | |
127 | delete $trace{$vref}; | |
128 | } | |
129 | } | |
130 | ||
131 | sub traceVinfo { | |
132 | my($parent, $vref) = @_; | |
133 | return (defined $trace{$vref}) ? $trace{$vref}->Info : undef; | |
134 | } | |
135 | ||
136 | =head1 NAME | |
137 | ||
138 | Tk::Trace - emulate Tcl/Tk B<trace> functions. | |
139 | ||
140 | =head1 SYNOPSIS | |
141 | ||
142 | use Tk::Trace | |
143 | ||
144 | $mw->traceVariable(\$v, 'wru' => [\&update_meter, $scale]); | |
145 | %vinfo = $mw->traceVinfo(\$v); | |
146 | print "Trace info :\n ", join("\n ", @{$vinfo{-legible}}), "\n"; | |
147 | $mw->traceVdelete(\$v); | |
148 | ||
149 | =head1 DESCRIPTION | |
150 | ||
151 | This class module emulates the Tcl/Tk B<trace> family of commands by | |
152 | binding subroutines of your devising to Perl variables using simple | |
153 | B<Tie::Watch> features. | |
154 | ||
155 | Callback format is patterned after the Perl/Tk scheme: supply either a | |
156 | code reference, or, supply an array reference and pass the callback | |
157 | code reference in the first element of the array, followed by callback | |
158 | arguments. | |
159 | ||
160 | User callbacks are passed these arguments: | |
161 | ||
162 | $_[0] = undef for a scalar, index/key for array/hash | |
163 | $_[1] = variable's current (read), new (write), final (undef) value | |
164 | $_[2] = operation (r, w, or u) | |
165 | $_[3 .. $#_] = optional user callback arguments | |
166 | ||
167 | As a Trace user, you have an important responsibility when writing your | |
168 | callback, since you control the final value assigned to the variable. | |
169 | A typical callback might look like: | |
170 | ||
171 | sub callback { | |
172 | my($index, $value, $op, @args) = @_; | |
173 | return if $op eq 'u'; | |
174 | # .... code which uses $value ... | |
175 | return $value; # variable's final value | |
176 | } | |
177 | ||
178 | Note that the callback's return value becomes the variable's final value, | |
179 | for either read or write traces. | |
180 | ||
181 | For write operations, the variable is updated with its new value before | |
182 | the callback is invoked. | |
183 | ||
184 | Only one callback can be attached to a variable, but read, write and undef | |
185 | operations can be traced simultaneously. | |
186 | ||
187 | =head1 METHODS | |
188 | ||
189 | =over 4 | |
190 | ||
191 | =item $mw->traceVariable(varRef, op => callback); | |
192 | ||
193 | B<varRef> is a reference to the scalar, array or hash variable you | |
194 | wish to trace. B<op> is the trace operation, and can be any combination | |
195 | of B<r> for read, B<w> for write, and B<u> for undef. B<callback> is a | |
196 | standard Perl/Tk callback, and is invoked, depending upon the value of | |
197 | B<op>, whenever the variable is read, written, or destroyed. | |
198 | ||
199 | =item %vinfo = $mw->traceVinfo(varRef); | |
200 | ||
201 | Returns a hash detailing the internals of the Trace object, with these | |
202 | keys: | |
203 | ||
204 | %vinfo = ( | |
205 | -variable => varRef | |
206 | -debug => '0' | |
207 | -shadow => '1' | |
208 | -value => 'HELLO SCALAR' | |
209 | -destroy => callback | |
210 | -fetch => callback | |
211 | -store => callback | |
212 | -legible => above data formatted as a list of string, for printing | |
213 | ); | |
214 | ||
215 | For array and hash Trace objects, the B<-value> key is replaced with a | |
216 | B<-ptr> key which is a reference to the parallel array or hash. | |
217 | Additionally, for an array or hash, there are key/value pairs for | |
218 | all the variable specific callbacks. | |
219 | ||
220 | =item $mw->traceVdelete(\$v); | |
221 | ||
222 | Stop tracing the variable. | |
223 | ||
224 | =back | |
225 | ||
226 | =head1 EXAMPLE | |
227 | ||
228 | use Tk; | |
229 | ||
230 | # Trace a Scale's variable and move a meter in unison. | |
231 | ||
232 | $pi = 3.1415926; | |
233 | $mw = MainWindow->new; | |
234 | $c = $mw->Canvas(qw/-width 200 -height 110 -bd 2 -relief sunken/)->grid; | |
235 | $c->createLine(qw/100 100 10 100 -tag meter/); | |
236 | $s = $mw->Scale(qw/-orient h -from 0 -to 100 -variable/ => \$v)->grid; | |
237 | $mw->Label(-text => 'Slide Me for 5 Seconds')->grid; | |
238 | ||
239 | $mw->traceVariable(\$v, 'w' => [\&update_meter, $s]); | |
240 | ||
241 | $mw->after(5000 => sub { | |
242 | print "Untrace time ...\n"; | |
243 | %vinfo = $s->traceVinfo(\$v); | |
244 | print "Watch info :\n ", join("\n ", @{$vinfo{-legible}}), "\n"; | |
245 | $c->traceVdelete(\$v); | |
246 | }); | |
247 | ||
248 | MainLoop; | |
249 | ||
250 | sub update_meter { | |
251 | my($index, $value, $op, @args) = @_; | |
252 | return if $op eq 'u'; | |
253 | $min = $s->cget(-from); | |
254 | $max = $s->cget(-to); | |
255 | $pos = $value / abs($max - $min); | |
256 | $x = 100.0 - 90.0 * (cos( $pos * $pi )); | |
257 | $y = 100.0 - 90.0 * (sin( $pos * $pi )); | |
258 | $c->coords(qw/meter 100 100/, $x, $y); | |
259 | return $value; | |
260 | } | |
261 | ||
262 | =head1 HISTORY | |
263 | ||
264 | Stephen.O.Lidie@Lehigh.EDU, Lehigh University Computing Center, 2000/08/01 | |
265 | . Version 1.0, for Tk800.022. | |
266 | ||
267 | =head1 COPYRIGHT | |
268 | ||
269 | Copyright (C) 2000 - 2000 Stephen O. Lidie. All rights reserved. | |
270 | ||
271 | This program is free software; you can redistribute it and/or modify it under | |
272 | the same terms as Perl itself. | |
273 | ||
274 | =cut | |
275 | ||
276 | 1; |