File Coverage

blib/lib/Data/Tie/Watch.pm
Criterion Covered Total %
statement 91 179 50.8
branch 23 60 38.3
condition n/a
subroutine 26 73 35.6
pod 7 7 100.0
total 147 319 46.0


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