[Chapter 9] 9.5 Example: Monitoring Variables

9.5 Example: Monitoring Variables

tie makes it really convenient to monitor a variable. In this section, we will develop a module called Monitor.pm that prints out a message on STDERR whenever a variable of your choice is accessed. [2]

[2] This is a lightweight version of a CPAN module called Tie::Watch, written by Stephen Lidie. Tie::Watch is used to invoke user-defined callbacks when certain variables are accessed.

use Monitor;
monitor(\$x, 'x');
monitor(\%y, 'y');

Whenever $x or %y is changed, this module prints out something like this on STDERR:

Wrote   : $x ... 10
Read    : $x ... 10
Died    : $x
Wrote   : $y{a} ... 1
Cleared : %y

This module is useful while debugging, where it is not clear at what point a certain variable is changing, especially when it changes indirectly through a reference. This module can be enhanced to support watch expressions such as print 'ahhh' when $array[5] > 10. Given Perl's support for eval, this is a reasonably simple task.

monitor takes a variable by reference and a name to be used when it prints out its messages. The first parameter is used to do a tie on the variable. tie has the unfortunate property that it hides the original value held by the variable. (The value is restored upon untie.) Clearly, we don't want Heisenberg's Uncertainty Principle to creep in here - our act of monitoring should not affect the user's view of that variable. For this reason, we store away the original value as an attribute of the tied object and have FETCH and STORE use this copy. Finally, when we are not interested in the variable any more, we use unmonitor, which calls untie internally.

Monitor, shown in Example 9.3, delegates responsibility to a nested module dedicated to each type of value (scalar, array, hash). The tie constructors in these modules return a blessed anonymous array (the tied object), which stores the name supplied by the user (the second parameter of monitor) and the current value of the variable.

Example 9.3: Monitor.pm

#----------------------------------------------------------------------
package Monitor;
require Exporter;
@ISA = ("Exporter");
@EXPORT = qw(monitor unmonitor);
use strict;

sub monitor {
   my ($r_var, $name) = @_;
   my ($type) = ref($r_var);
   if ($type =~ /SCALAR/) {
       return tie $$r_var, 'Monitor::Scalar', $r_var, $name;
   } elsif ($type =~ /ARRAY/) {
       return tie @$r_var, 'Monitor::Array', $r_var, $name;
   } elsif ($type =~ /HASH/) {
       return tie %$r_var, 'Monitor::Hash', $r_var, $name;
   } else {
       print STDERR "require ref. to scalar, array or hash" unless $type;
   }
}
sub unmonitor {
   my ($r_var) = @_;
   my ($type) = ref($r_var);
   my $obj;
   if ($type =~ /SCALAR/) {
       Monitor::Scalar->unmonitor($r_var);
   } elsif ($type =~ /ARRAY/) {
       Monitor::Array->unmonitor($r_var);
   } elsif ($type =~ /HASH/) {
       Monitor::Hash->unmonitor($r_var);
   } else {
       print STDERR "require ref. to scalar, array or hash" unless $type;
   } 
}
#------------------------------------------------------------------------
package Monitor::Scalar;

sub TIESCALAR {
   my ($pkg, $rval, $name) = @_;
   my $obj = [$name, $$rval];
   bless $obj, $pkg;
   return $obj;
}

sub FETCH {
   my ($obj) = @_;
   my $val = $obj->[1];
   print STDERR 'Read    $', $obj->[0], " ... $val \n";
   return $val;
}
sub STORE {
   my ($obj, $val) = @_;
   print STDERR 'Wrote   $', $obj->[0], " ... $val \n";
   $obj->[1] = $val;
   return $val;
}

sub unmonitor {
   my ($pkg, $r_var) = @_;
   my $val;
   {
      my $obj = tied $$r_var;
      $val = $obj->[1];
      $obj->[0] = "_UNMONITORED_";
   }
   untie $$r_var;
   $$r_var = $val;
}

sub DESTROY {
   my ($obj) = @_;
   if ($obj->[0] ne '_UNMONITORED_') {
      print STDERR 'Died    $', $obj->[0];
   }
}
#------------------------------------------------------------------------
package Monitor::Array;

sub TIEARRAY {
   my ($pkg, $rarray, $name) = @_;
   my $obj = [$name, [@$rarray]];
   bless $obj, $pkg;
   return $obj;
}

sub FETCH {
   my ($obj, $index) = @_;
   my $val = $obj->[1]->[$index];
   print STDERR 'Read    $', $obj->[0], "[$index] ... $val\n";
   return $val;
}

sub STORE {
   my ($obj, $index, $val) = @_;
   print STDERR 'Wrote   $', $obj->[0], "[$index] ... $val\n";
   $obj->[1]->[$index] = $val;
   return $val;
}


sub DESTROY {
   my ($obj) = @_;
   if ($obj->[0] ne '_UNMONITORED_') {
      print STDERR 'Died    %', $obj->[0];
   }
}

sub unmonitor {
   my ($pkg, $r_var) = @_;
   my $r_array;
   {
      my $obj = tied @$r_var;
      $r_array = $obj->[1];
      $obj->[0] = "_UNMONITORED_";
   }
   untie @$r_var;
   @$r_var = @$r_array;
}
#------------------------------------------------------------------------
package Monitor::Hash;
sub TIEHASH {
   my ($pkg, $rhash, $name) = @_;
   my $obj = [$name, {%$rhash}];
   return (bless $obj, $pkg);
}

sub CLEAR {
   my ($obj) = @_;
   print STDERR 'Cleared %', $obj->[0], "\n";
}

sub FETCH {
   my ($obj, $index) = @_;
   my $val = $obj->[1]->{$index};
   print STDERR 'Read    $', $obj->[0], "{$index} ... $val\n";
   return $val;
}

sub STORE {
   my ($obj, $index, $val) = @_;
   print STDERR 'Wrote   $', $obj->[0], "{$index} ... $val\n";
   $obj->[1]->{$index} = $val;
   return $val;
}

sub DESTROY {
   my ($obj) = @_;
   if ($obj->[0] ne '_UNMONITORED_') {
      print STDERR 'Died    %', $obj->[0];
   }
}
sub unmonitor {
   my ($pkg, $r_var) = @_;
   my $r_hash;
   {
      my $obj = tied %$r_var;
      $r_hash = $obj->[1];
      $obj->[0] = "_UNMONITORED_";
   }
   untie %$r_var;
   %$r_var = %$r_hash;
}
1;

unmonitor is slightly tricky. We want to do an untie, but Perl restores the variable's value to that held by it just before tie was invoked. Clearly, this is undesirable. We want this operation to go on without the variable's user being affected in any way. Since we have the variable's current value as an attribute of the tied object, we can attempt to restore the value after the untie. Unfortunately, the following code doesn't quite work:

# For a tied scalar 
my $obj = tied $$r_var;         # Get the object tied to the variable
$latest_value = $obj->[1];      # Extract the latest value
untie $$r_var;                  # untie 
$$r_var = $latest_value;        # Restore the variable to the latest 
                                # value

Perl complains, "Can't untie: 1 inner references still exist ..." if the -w flag is turned on. The problem is that the local variable $obj bumps up the reference count of the tied object, so an untie is not able to DESTROY the tied object. The solution is fairly straightforward: extract the value in an inner block and let $obj go out of scope, like this:

my $latest_value;
{
    my $obj = tied $$r_var;
    $latest_value = $obj->[1]; # Extract the latest value.
                               # Note that $latest_value is defined
                               # outside this inner block
}
# $obj is no longer in scope, so we can peacefully untie.
untie $$r_var;
$$r_var = $latest_value;