Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | package Tie::Watch; |
2 | ||
3 | use vars qw($VERSION); | |
4 | $VERSION = '3.002'; # $Id: //depot/Tk8/lib/Tie/Watch.pm#2 $ | |
5 | ||
6 | =head1 NAME | |
7 | ||
8 | Tie::Watch - place watchpoints on Perl variables. | |
9 | ||
10 | =head1 SYNOPSIS | |
11 | ||
12 | use Tie::Watch; | |
13 | ||
14 | $watch = Tie::Watch->new( | |
15 | -variable => \$frog, | |
16 | -debug => 1, | |
17 | -shadow => 0, | |
18 | -fetch => [\&fetch, 'arg1', 'arg2', ..., 'argn'], | |
19 | -store => \&store, | |
20 | -destroy => sub {print "Final value=$frog.\n"}, | |
21 | } | |
22 | %vinfo = $watch->Info; | |
23 | $args = $watch->Args(-fetch); | |
24 | $val = $watch->Fetch; | |
25 | print "val=", $watch->Say($val), ".\n"; | |
26 | $watch->Store('Hello'); | |
27 | $watch->Unwatch; | |
28 | ||
29 | =head1 DESCRIPTION | |
30 | ||
31 | This class module binds one or more subroutines of your devising to a | |
32 | Perl variable. All variables can have B<FETCH>, B<STORE> and | |
33 | B<DESTROY> callbacks. Additionally, arrays can define B<CLEAR>, B<EXTEND>, | |
34 | B<FETCHSIZE>, B<POP>, B<PUSH>, B<SHIFT>, B<SPLICE>, B<STORESIZE> and | |
35 | B<UNSHIFT> callbacks, and hashes can define B<CLEAR>, B<DELETE>, B<EXISTS>, | |
36 | B<FIRSTKEY> and B<NEXTKEY> callbacks. If these term are unfamiliar to you, | |
37 | I I<really> suggest you read L<perltie>. | |
38 | ||
39 | With Tie::Watch you can: | |
40 | ||
41 | . alter a variable's value | |
42 | . prevent a variable's value from being changed | |
43 | . invoke a Perl/Tk callback when a variable changes | |
44 | . trace references to a variable | |
45 | ||
46 | Callback format is patterned after the Perl/Tk scheme: supply either a | |
47 | code reference, or, supply an array reference and pass the callback | |
48 | code reference in the first element of the array, followed by callback | |
49 | arguments. (See examples in the Synopsis, above.) | |
50 | ||
51 | Tie::Watch provides default callbacks for any that you fail to | |
52 | specify. Other than negatively impacting performance, they perform | |
53 | the standard action that you'd expect, so the variable behaves | |
54 | "normally". Once you override a default callback, perhaps to insert | |
55 | debug code like print statements, your callback normally finishes by | |
56 | calling the underlying (overridden) method. But you don't have to! | |
57 | ||
58 | To map a tied method name to a default callback name simply lowercase | |
59 | the tied method name and uppercase its first character. So FETCH | |
60 | becomes Fetch, NEXTKEY becomes Nextkey, etcetera. | |
61 | ||
62 | Here are two callbacks for a scalar. The B<FETCH> (read) callback does | |
63 | nothing other than illustrate the fact that it returns the value to | |
64 | assign the variable. The B<STORE> (write) callback uppercases the | |
65 | variable and returns it. In all cases the callback I<must> return the | |
66 | correct read or write value - typically, it does this by invoking the | |
67 | underlying method. | |
68 | ||
69 | my $fetch_scalar = sub { | |
70 | my($self) = @_; | |
71 | $self->Fetch; | |
72 | }; | |
73 | ||
74 | my $store_scalar = sub { | |
75 | my($self, $new_val) = @_; | |
76 | $self->Store(uc $new_val); | |
77 | }; | |
78 | ||
79 | Here are B<FETCH> and B<STORE> callbacks for either an array or hash. | |
80 | They do essentially the same thing as the scalar callbacks, but | |
81 | provide a little more information. | |
82 | ||
83 | my $fetch = sub { | |
84 | my($self, $key) = @_; | |
85 | my $val = $self->Fetch($key); | |
86 | print "In fetch callback, key=$key, val=", $self->Say($val); | |
87 | my $args = $self->Args(-fetch); | |
88 | print ", args=('", join("', '", @$args), "')" if $args; | |
89 | print ".\n"; | |
90 | $val; | |
91 | }; | |
92 | ||
93 | my $store = sub { | |
94 | my($self, $key, $new_val) = @_; | |
95 | my $val = $self->Fetch($key); | |
96 | $new_val = uc $new_val; | |
97 | $self->Store($key, $new_val); | |
98 | print "In store callback, key=$key, val=", $self->Say($val), | |
99 | ", new_val=", $self->Say($new_val); | |
100 | my $args = $self->Args(-store); | |
101 | print ", args=('", join("', '", @$args), "')" if $args; | |
102 | print ".\n"; | |
103 | $new_val; | |
104 | }; | |
105 | ||
106 | In all cases, the first parameter is a reference to the Watch object, | |
107 | used to invoke the following class methods. | |
108 | ||
109 | =head1 METHODS | |
110 | ||
111 | =over 4 | |
112 | ||
113 | =item $watch = Tie::Watch->new(-options => values); | |
114 | ||
115 | The watchpoint constructor method that accepts option/value pairs to | |
116 | create and configure the Watch object. The only required option is | |
117 | B<-variable>. | |
118 | ||
119 | B<-variable> is a I<reference> to a scalar, array or hash variable. | |
120 | ||
121 | B<-debug> (default 0) is 1 to activate debug print statements internal | |
122 | to Tie::Watch. | |
123 | ||
124 | B<-shadow> (default 1) is 0 to disable array and hash shadowing. To | |
125 | prevent infinite recursion Tie::Watch maintains parallel variables for | |
126 | arrays and hashes. When the watchpoint is created the parallel shadow | |
127 | variable is initialized with the watched variable's contents, and when | |
128 | the watchpoint is deleted the shadow variable is copied to the original | |
129 | variable. Thus, changes made during the watch process are not lost. | |
130 | Shadowing is on my default. If you disable shadowing any changes made | |
131 | to an array or hash are lost when the watchpoint is deleted. | |
132 | ||
133 | Specify any of the following relevant callback parameters, in the | |
134 | format described above: B<-fetch>, B<-store>, B<-destroy>. | |
135 | Additionally for arrays: B<-clear>, B<-extend>, B<-fetchsize>, | |
136 | B<-pop>, B<-push>, B<-shift>, B<-splice>, B<-storesize> and | |
137 | B<-unshift>. Additionally for hashes: B<-clear>, B<-delete>, | |
138 | B<-exists>, B<-firstkey> and B<-nextkey>. | |
139 | ||
140 | =item $args = $watch->Args(-fetch); | |
141 | ||
142 | Returns a reference to a list of arguments for the specified callback, | |
143 | or undefined if none. | |
144 | ||
145 | =item $watch->Fetch(); $watch->Fetch($key); | |
146 | ||
147 | Returns a variable's current value. $key is required for an array or | |
148 | hash. | |
149 | ||
150 | =item %vinfo = $watch->Info(); | |
151 | ||
152 | Returns a hash detailing the internals of the Watch object, with these | |
153 | keys: | |
154 | ||
155 | %vinfo = { | |
156 | -variable => SCALAR(0x200737f8) | |
157 | -debug => '0' | |
158 | -shadow => '1' | |
159 | -value => 'HELLO SCALAR' | |
160 | -destroy => ARRAY(0x200f86cc) | |
161 | -fetch => ARRAY(0x200f8558) | |
162 | -store => ARRAY(0x200f85a0) | |
163 | -legible => above data formatted as a list of string, for printing | |
164 | } | |
165 | ||
166 | For array and hash Watch objects, the B<-value> key is replaced with a | |
167 | B<-ptr> key which is a reference to the parallel array or hash. | |
168 | Additionally, for an array or hash, there are key/value pairs for | |
169 | all the variable specific callbacks. | |
170 | ||
171 | =item $watch->Say($val); | |
172 | ||
173 | Used mainly for debugging, it returns $val in quotes if required, or | |
174 | the string "undefined" for undefined values. | |
175 | ||
176 | =item $watch->Store($new_val); $watch->Store($key, $new_val); | |
177 | ||
178 | Store a variable's new value. $key is required for an array or hash. | |
179 | ||
180 | =item $watch->Unwatch(); | |
181 | ||
182 | Stop watching the variable. | |
183 | ||
184 | =back | |
185 | ||
186 | =head1 EFFICIENCY CONSIDERATIONS | |
187 | ||
188 | If you can live using the class methods provided, please do so. You | |
189 | can meddle with the object hash directly and improved watch | |
190 | performance, at the risk of your code breaking in the future. | |
191 | ||
192 | =head1 AUTHOR | |
193 | ||
194 | Stephen.O.Lidie@Lehigh.EDU | |
195 | ||
196 | =head1 HISTORY | |
197 | ||
198 | lusol@Lehigh.EDU, LUCC, 96/05/30 | |
199 | . Original version 0.92 release, based on the Trace module from Hans Mulder, | |
200 | and ideas from Tim Bunce. | |
201 | ||
202 | lusol@Lehigh.EDU, LUCC, 96/12/25 | |
203 | . Version 0.96, release two inner references detected by Perl 5.004. | |
204 | ||
205 | lusol@Lehigh.EDU, LUCC, 97/01/11 | |
206 | . Version 0.97, fix Makefile.PL and MANIFEST (thanks Andreas Koenig). | |
207 | Make sure test.pl doesn't fail if Tk isn't installed. | |
208 | ||
209 | Stephen.O.Lidie@Lehigh.EDU, Lehigh University Computing Center, 97/10/03 | |
210 | . Version 0.98, implement -shadow option for arrays and hashes. | |
211 | ||
212 | Stephen.O.Lidie@Lehigh.EDU, Lehigh University Computing Center, 98/02/11 | |
213 | . Version 0.99, finally, with Perl 5.004_57, we can completely watch arrays. | |
214 | With tied array support this module is essentially complete, so its been | |
215 | optimized for speed at the expense of clarity - sorry about that. The | |
216 | Delete() method has been renamed Unwatch() because it conflicts with the | |
217 | builtin delete(). | |
218 | ||
219 | Stephen.O.Lidie@Lehigh.EDU, Lehigh University Computing Center, 99/04/04 | |
220 | . Version 1.0, for Perl 5.005_03, update Makefile.PL for ActiveState, and | |
221 | add two examples (one for Perl/Tk). | |
222 | ||
223 | =head1 COPYRIGHT | |
224 | ||
225 | Copyright (C) 1996 - 1999 Stephen O. Lidie. All rights reserved. | |
226 | ||
227 | This program is free software; you can redistribute it and/or modify it under | |
228 | the same terms as Perl itself. | |
229 | ||
230 | =cut | |
231 | ||
232 | use 5.004_57; | |
233 | use Carp; | |
234 | use strict; | |
235 | use subs qw/normalize_callbacks/; | |
236 | use vars qw/@array_callbacks @hash_callbacks @scalar_callbacks/; | |
237 | ||
238 | @array_callbacks = qw/-clear -destroy -extend -fetch -fetchsize -pop -push | |
239 | -shift -splice -store -storesize -unshift/; | |
240 | @hash_callbacks = qw/-clear -delete -destroy -exists -fetch -firstkey | |
241 | -nextkey -store/; | |
242 | @scalar_callbacks = qw/-destroy -fetch -store/; | |
243 | ||
244 | sub new { | |
245 | ||
246 | # Watch constructor. The *real* constructor is Tie::Watch->base_watch(), | |
247 | # invoked by methods in other Watch packages, depending upon the variable's | |
248 | # type. Here we supply defaulted parameter values and then verify them, | |
249 | # normalize all callbacks and bind the variable to the appropriate package. | |
250 | ||
251 | my($class, %args) = @_; | |
252 | my $version = $Tie::Watch::VERSION; | |
253 | my (%arg_defaults) = (-debug => 0, -shadow => 1); | |
254 | my $variable = $args{-variable}; | |
255 | croak "Tie::Watch::new(): -variable is required." if not defined $variable; | |
256 | ||
257 | my($type, $watch_obj) = (ref $variable, undef); | |
258 | if ($type =~ /SCALAR/) { | |
259 | @arg_defaults{@scalar_callbacks} = ( | |
260 | [\&Tie::Watch::Scalar::Destroy], [\&Tie::Watch::Scalar::Fetch], | |
261 | [\&Tie::Watch::Scalar::Store]); | |
262 | } elsif ($type =~ /ARRAY/) { | |
263 | @arg_defaults{@array_callbacks} = ( | |
264 | [\&Tie::Watch::Array::Clear], [\&Tie::Watch::Array::Destroy], | |
265 | [\&Tie::Watch::Array::Extend], [\&Tie::Watch::Array::Fetch], | |
266 | [\&Tie::Watch::Array::Fetchsize], [\&Tie::Watch::Array::Pop], | |
267 | [\&Tie::Watch::Array::Push], [\&Tie::Watch::Array::Shift], | |
268 | [\&Tie::Watch::Array::Splice], [\&Tie::Watch::Array::Store], | |
269 | [\&Tie::Watch::Array::Storesize], [\&Tie::Watch::Array::Unshift]); | |
270 | } elsif ($type =~ /HASH/) { | |
271 | @arg_defaults{@hash_callbacks} = ( | |
272 | [\&Tie::Watch::Hash::Clear], [\&Tie::Watch::Hash::Delete], | |
273 | [\&Tie::Watch::Hash::Destroy], [\&Tie::Watch::Hash::Exists], | |
274 | [\&Tie::Watch::Hash::Fetch], [\&Tie::Watch::Hash::Firstkey], | |
275 | [\&Tie::Watch::Hash::Nextkey], [\&Tie::Watch::Hash::Store]); | |
276 | } else { | |
277 | croak "Tie::Watch::new() - not a variable reference."; | |
278 | } | |
279 | my(@margs, %ahsh, $args, @args); | |
280 | @margs = grep ! defined $args{$_}, keys %arg_defaults; | |
281 | %ahsh = %args; # argument hash | |
282 | @ahsh{@margs} = @arg_defaults{@margs}; # fill in missing values | |
283 | normalize_callbacks \%ahsh; | |
284 | ||
285 | if ($type =~ /SCALAR/) { | |
286 | $watch_obj = tie $$variable, 'Tie::Watch::Scalar', %ahsh; | |
287 | } elsif ($type =~ /ARRAY/) { | |
288 | $watch_obj = tie @$variable, 'Tie::Watch::Array', %ahsh; | |
289 | } elsif ($type =~ /HASH/) { | |
290 | $watch_obj = tie %$variable, 'Tie::Watch::Hash', %ahsh; | |
291 | } | |
292 | $watch_obj; | |
293 | ||
294 | } # end new, Watch constructor | |
295 | ||
296 | sub Args { | |
297 | ||
298 | # Return a reference to a list of callback arguments, or undef if none. | |
299 | # | |
300 | # $_[0] = self | |
301 | # $_[1] = callback type | |
302 | ||
303 | defined $_[0]->{$_[1]}->[1] ? [@{$_[0]->{$_[1]}}[1 .. $#{$_[0]->{$_[1]}}]] | |
304 | : undef; | |
305 | ||
306 | } # end Args | |
307 | ||
308 | sub Info { | |
309 | ||
310 | # Info() method subclassed by other Watch modules. | |
311 | # | |
312 | # $_[0] = self | |
313 | # @_[1 .. $#_] = optional callback types | |
314 | ||
315 | my(%vinfo, @results); | |
316 | my(@info) = (qw/-variable -debug -shadow/); | |
317 | push @info, @_[1 .. $#_] if scalar @_ >= 2; | |
318 | foreach my $type (@info) { | |
319 | push @results, sprintf('%-10s: ', substr $type, 1) . | |
320 | $_[0]->Say($_[0]->{$type}); | |
321 | $vinfo{$type} = $_[0]->{$type}; | |
322 | } | |
323 | $vinfo{-legible} = [@results]; | |
324 | %vinfo; | |
325 | ||
326 | } # end Info | |
327 | ||
328 | sub Say { | |
329 | ||
330 | # For debugging, mainly. | |
331 | # | |
332 | # $_[0] = self | |
333 | # $_[1] = value | |
334 | ||
335 | defined $_[1] ? (ref($_[1]) ne '' ? $_[1] : "'$_[1]'") : "undefined"; | |
336 | ||
337 | } # end Say | |
338 | ||
339 | sub Unwatch { | |
340 | ||
341 | # Stop watching a variable by releasing the last reference and untieing it. | |
342 | # Update the original variable with its shadow, if appropriate. | |
343 | # | |
344 | # $_[0] = self | |
345 | ||
346 | my $variable = $_[0]->{-variable}; | |
347 | my $type = ref $variable; | |
348 | my $copy = $_[0]->{-ptr} if $type !~ /SCALAR/; | |
349 | my $shadow = $_[0]->{-shadow}; | |
350 | undef $_[0]; | |
351 | if ($type =~ /SCALAR/) { | |
352 | untie $$variable; | |
353 | } elsif ($type =~ /ARRAY/) { | |
354 | untie @$variable; | |
355 | @$variable = @$copy if $shadow; | |
356 | } elsif ($type =~ /HASH/) { | |
357 | untie %$variable; | |
358 | %$variable = %$copy if $shadow; | |
359 | } else { | |
360 | croak "Tie::Watch::Delete() - not a variable reference."; | |
361 | } | |
362 | ||
363 | } # end Unwatch | |
364 | ||
365 | # Watch private methods. | |
366 | ||
367 | sub base_watch { | |
368 | ||
369 | # Watch base class constructor invoked by other Watch modules. | |
370 | ||
371 | my($class, %args) = @_; | |
372 | my $watch_obj = {%args}; | |
373 | $watch_obj; | |
374 | ||
375 | } # end base_watch | |
376 | ||
377 | sub callback { | |
378 | ||
379 | # Execute a Watch callback, either the default or user specified. | |
380 | # Note that the arguments are those supplied by the tied method, | |
381 | # not those (if any) specified by the user when the watch object | |
382 | # was instantiated. This is for performance reasons, and why the | |
383 | # Args() method exists. | |
384 | # | |
385 | # $_[0] = self | |
386 | # $_[1] = callback type | |
387 | # $_[2] through $#_ = tied arguments | |
388 | ||
389 | &{$_[0]->{$_[1]}->[0]} ($_[0], @_[2 .. $#_]); | |
390 | ||
391 | } # end callback | |
392 | ||
393 | sub normalize_callbacks { | |
394 | ||
395 | # Ensure all callbacks are normalized in [\&code, @args] format. | |
396 | ||
397 | my($args_ref) = @_; | |
398 | my($cb, $ref); | |
399 | foreach my $arg (keys %$args_ref) { | |
400 | next if $arg =~ /variable|debug|shadow/; | |
401 | $cb = $args_ref->{$arg}; | |
402 | $ref = ref $cb; | |
403 | if ($ref =~ /CODE/) { | |
404 | $args_ref->{$arg} = [$cb]; | |
405 | } elsif ($ref !~ /ARRAY/) { | |
406 | croak "Tie::Watch: malformed callback $arg=$cb."; | |
407 | } | |
408 | } | |
409 | ||
410 | } # end normalize_callbacks | |
411 | ||
412 | ############################################################################### | |
413 | ||
414 | package Tie::Watch::Scalar; | |
415 | ||
416 | use Carp; | |
417 | @Tie::Watch::Scalar::ISA = qw/Tie::Watch/; | |
418 | ||
419 | sub TIESCALAR { | |
420 | ||
421 | my($class, %args) = @_; | |
422 | my $variable = $args{-variable}; | |
423 | my $watch_obj = Tie::Watch->base_watch(%args); | |
424 | $watch_obj->{-value} = $$variable; | |
425 | print "WatchScalar new: $variable created, \@_=", join(',', @_), "!\n" | |
426 | if $watch_obj->{-debug}; | |
427 | bless $watch_obj, $class; | |
428 | ||
429 | } # end TIESCALAR | |
430 | ||
431 | sub Info {$_[0]->SUPER::Info('-value', @Tie::Watch::scalar_callbacks)} | |
432 | ||
433 | # Default scalar callbacks. | |
434 | ||
435 | sub Destroy {undef %{$_[0]}} | |
436 | sub Fetch {$_[0]->{-value}} | |
437 | sub Store {$_[0]->{-value} = $_[1]} | |
438 | ||
439 | # Scalar access methods. | |
440 | ||
441 | sub DESTROY {$_[0]->callback(-destroy)} | |
442 | sub FETCH {$_[0]->callback(-fetch)} | |
443 | sub STORE {$_[0]->callback(-store, $_[1])} | |
444 | ||
445 | ############################################################################### | |
446 | ||
447 | package Tie::Watch::Array; | |
448 | ||
449 | use Carp; | |
450 | @Tie::Watch::Array::ISA = qw/Tie::Watch/; | |
451 | ||
452 | sub TIEARRAY { | |
453 | ||
454 | my($class, %args) = @_; | |
455 | my($variable, $shadow) = @args{-variable, -shadow}; | |
456 | my @copy = @$variable if $shadow; # make a private copy of user's array | |
457 | $args{-ptr} = $shadow ? \@copy : []; | |
458 | my $watch_obj = Tie::Watch->base_watch(%args); | |
459 | print "WatchArray new: $variable created, \@_=", join(',', @_), "!\n" | |
460 | if $watch_obj->{-debug}; | |
461 | bless $watch_obj, $class; | |
462 | ||
463 | } # end TIEARRAY | |
464 | ||
465 | sub Info {$_[0]->SUPER::Info('-ptr', @Tie::Watch::array_callbacks)} | |
466 | ||
467 | # Default array callbacks. | |
468 | ||
469 | sub Clear {$_[0]->{-ptr} = ()} | |
470 | sub Destroy {undef %{$_[0]}} | |
471 | sub Extend {} | |
472 | sub Fetch {$_[0]->{-ptr}->[$_[1]]} | |
473 | sub Fetchsize {scalar @{$_[0]->{-ptr}}} | |
474 | sub Pop {pop @{$_[0]->{-ptr}}} | |
475 | sub Push {push @{$_[0]->{-ptr}}, @_[1 .. $#_]} | |
476 | sub Shift {shift @{$_[0]->{-ptr}}} | |
477 | sub Splice { | |
478 | my $n = scalar @_; # splice() is wierd! | |
479 | return splice @{$_[0]->{-ptr}}, $_[1] if $n == 2; | |
480 | return splice @{$_[0]->{-ptr}}, $_[1], $_[2] if $n == 3; | |
481 | return splice @{$_[0]->{-ptr}}, $_[1], $_[2], @_[3 .. $#_] if $n >= 4; | |
482 | } | |
483 | sub Store {$_[0]->{-ptr}->[$_[1]] = $_[2]} | |
484 | sub Storesize {$#{@{$_[0]->{-ptr}}} = $_[1] - 1} | |
485 | sub Unshift {unshift @{$_[0]->{-ptr}}, @_[1 .. $#_]} | |
486 | ||
487 | # Array access methods. | |
488 | ||
489 | sub CLEAR {$_[0]->callback(-clear)} | |
490 | sub DESTROY {$_[0]->callback(-destroy)} | |
491 | sub EXTEND {$_[0]->callback(-extend, $_[1])} | |
492 | sub FETCH {$_[0]->callback(-fetch, $_[1])} | |
493 | sub FETCHSIZE {$_[0]->callback(-fetchsize)} | |
494 | sub POP {$_[0]->callback('-pop')} | |
495 | sub PUSH {$_[0]->callback('-push', @_[1 .. $#_])} | |
496 | sub SHIFT {$_[0]->callback('-shift')} | |
497 | sub SPLICE {$_[0]->callback('-splice', @_[1 .. $#_])} | |
498 | sub STORE {$_[0]->callback(-store, $_[1], $_[2])} | |
499 | sub STORESIZE {$_[0]->callback(-storesize, $_[1])} | |
500 | sub UNSHIFT {$_[0]->callback('-unshift', @_[1 .. $#_])} | |
501 | ||
502 | ############################################################################### | |
503 | ||
504 | package Tie::Watch::Hash; | |
505 | ||
506 | use Carp; | |
507 | @Tie::Watch::Hash::ISA = qw/Tie::Watch/; | |
508 | ||
509 | sub TIEHASH { | |
510 | ||
511 | my($class, %args) = @_; | |
512 | my($variable, $shadow) = @args{-variable, -shadow}; | |
513 | my %copy = %$variable if $shadow; # make a private copy of user's hash | |
514 | $args{-ptr} = $shadow ? \%copy : {}; | |
515 | my $watch_obj = Tie::Watch->base_watch(%args); | |
516 | print "WatchHash new: $variable created, \@_=", join(',', @_), "!\n" | |
517 | if $watch_obj->{-debug}; | |
518 | bless $watch_obj, $class; | |
519 | ||
520 | } # end TIEHASH | |
521 | ||
522 | sub Info {$_[0]->SUPER::Info('-ptr', @Tie::Watch::hash_callbacks)} | |
523 | ||
524 | # Default hash callbacks. | |
525 | ||
526 | sub Clear {$_[0]->{-ptr} = ()} | |
527 | sub Delete {delete $_[0]->{-ptr}->{$_[1]}} | |
528 | sub Destroy {undef %{$_[0]}} | |
529 | sub Exists {exists $_[0]->{-ptr}->{$_[1]}} | |
530 | sub Fetch {$_[0]->{-ptr}->{$_[1]}} | |
531 | sub Firstkey {my $c = keys %{$_[0]->{-ptr}}; each %{$_[0]->{-ptr}}} | |
532 | sub Nextkey {each %{$_[0]->{-ptr}}} | |
533 | sub Store {$_[0]->{-ptr}->{$_[1]} = $_[2]} | |
534 | ||
535 | # Hash access methods. | |
536 | ||
537 | sub CLEAR {$_[0]->callback(-clear)} | |
538 | sub DELETE {$_[0]->callback('-delete', $_[1])} | |
539 | sub DESTROY {$_[0]->callback(-destroy)} | |
540 | sub EXISTS {$_[0]->callback('-exists', $_[1])} | |
541 | sub FETCH {$_[0]->callback(-fetch, $_[1])} | |
542 | sub FIRSTKEY {$_[0]->callback(-firstkey)} | |
543 | sub NEXTKEY {$_[0]->callback(-nextkey)} | |
544 | sub STORE {$_[0]->callback(-store, $_[1], $_[2])} | |
545 | ||
546 | 1; |