<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">#----------------------------------------------------------------------
package Monitor;
#----------------------------------------------------------------------
# 
# This package monitors accesses to variables like this:
#   monitor (\$x, "x");
# Now, if you access $x, a trace message will be printed
#

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-&gt;unmonitor($r_var);
   } elsif ($type =~ /ARRAY/) {
       Monitor::Array-&gt;unmonitor($r_var);
   } elsif ($type =~ /HASH/) {
       Monitor::Hash-&gt;unmonitor($r_var);
   } else {
       print STDERR "require ref. to scalar, array or hash" unless $type;
   } 
}

#------------------------------------------------------------------------
# Internal functions

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-&gt;[1];
   print STDERR 'Read    $', $obj-&gt;[0], " ... $val \n";
   return $val;
}
sub STORE {
   my ($obj, $val) = @_;
   print STDERR 'Wrote   $', $obj-&gt;[0], " ... $val \n";
   $obj-&gt;[1] = $val;
   return $val;
}

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

sub DESTROY {
   my ($obj) = @_;
   if ($obj-&gt;[0] ne '_UNMONITORED_') {
      print STDERR 'Died    $', $obj-&gt;[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-&gt;[1]-&gt;[$index];
   print STDERR 'Read    $', $obj-&gt;[0], "[$index] ... $val\n";
   return $val;
}

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


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

sub unmonitor {
   my ($pkg, $r_var) = @_;
   my $r_array;
   {
      my $obj = tied @$r_var;
      $r_array = $obj-&gt;[1];
      $obj-&gt;[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-&gt;[0], "\n";
}

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

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

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

if (!caller) {
   #TEST DRIVER : To test this package, invoke as "perl Monitor.pm"

   package main;

   print "TESTING Scalar Monitor\n\n";
   my $x;  my $a;
   Monitor::monitor (\$x, "x");
   $x = 10;
   $a = $x;
   Monitor::unmonitor(\$x);
   print "\$x ===&gt; $x\n";
   
   print "\nTESTING Array Monitor\n\n";
   my @x = (1, 2, 3);
   Monitor::monitor (\@x, "x");
   $x [3] = 100;
   Monitor::unmonitor(\@x);
   print "\@x ===&gt; @x\n";
 
   print "\nTESTING Hash Monitor\n\n";
   my %x ;
   Monitor::monitor (\%x, "hash");
   $x{"India"} = "N. Delhi";
   $x{"USA"} = "Washington";
   Monitor::unmonitor(\%x);
   $, = " ";
   print "\%x ===&gt; ", %x, "\n";
}

1;
</pre></body></html>