#######################################################################
# This software has been created by Genome Research Limited (GRL).    # 
# GRL hereby grants permission to use, copy, modify and distribute    # 
# this software and its documentation for non-commercial purposes     # 
# without fee at the user's own risk on the basis set out below.      #
# GRL neither undertakes nor accepts any duty whether contractual or  # 
# otherwise in connection with the software, its use or the use of    # 
# any derivative, and makes no representations or warranties, express #
# or implied, concerning the software, its suitability, fitness for   #
# a particular purpose or non-infringement.                           #
# In no event shall the authors of the software or GRL be responsible # 
# or liable for any loss or damage whatsoever arising in any way      # 
# directly or indirectly out of the use of this software or its       # 
# derivatives, even if advised of the possibility of such damage.     #
# Our software can be freely distributed under the conditions set out # 
# above, and must contain this copyright notice.                      #
#######################################################################

#----------------------------------------
# dn1... monitoring vars
#----------------------------------------
require Exporter;
@var_monitor::ISA = qw(Exporter);
@var_monitor::EXPORT = qw(monitor unmonitor);

use strict;

package var_monitor;

sub monitor {
    my ($r_var, $name, $coderef) = @_;
    my ($type) = ref($r_var);
    if ($type =~ /SCALAR/){
	return tie $$r_var, 'Monitor::Scalar', $r_var, $name, $coderef;
    } else {
	print STDERR "var_monitor.pm only supports scalars at present";
    }
}

sub unmonitor {
    my ($r_var) = @_;
    my ($type) = ref($r_var);
    my $obj;
    if ($type =~ /SCALAR/){
      Monitor::Scalar->unmonitor($r_var);
    } else {
	print STDERR "var_monitor.pm only supports scalars at present";
    }
}

#----------------------------------------

package Monitor::Scalar;

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

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

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

    # Can we execute some code here >?<
    &{$obj->[2]};


    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 SDTERR "Died var-";
	#print STDERR "$obj->[0] ";
    }
}

#-----------------------------------------
   
1;





