view release on metacpan or  search on metacpan

lib/Devel/TrackGlobalScalar.pm  view on Meta::CPAN

package Devel::TrackGlobalScalar;
use strict;
use warnings;
use Carp;
eval "use Carp::Heavy;";
require Tie::Scalar;
our @ISA = qw(Tie::StdScalar);

our $VERSION = '0.03';

our %opt = (
  track_source => 1,
  report_write_access => 0,
);

our %globals;

sub import {
  my $class = shift;
  my $globals = shift;
  die if not defined $globals;
  $globals = [$globals] if not ref $globals;

  my %args = @_;
  $opt{$_} = $args{$_} for keys %args;

  foreach my $global (@$globals) {
    my $global_esc = $global;
    $global_esc =~ s/\\/\\\\/g;
    $global_esc =~ s/'/\\'/g;

    my $rv;
    my $code = "\$rv = tie($global, __PACKAGE__, \\$global, '$global_esc'); 1";
    eval $code or die "Failed to tie global '$global': $@";
  }
}



sub TIESCALAR {
  my $class = shift;
  my $instance = shift || undef;
  my $name = shift;

  my $o = bless [\$instance, $name] => $class;
  $globals{$name} = $o;
  return $o;
}

sub FETCH {
  #_report($_[0], 'FETCH');
  return ${$_[0][0]};
}

sub STORE {
  _report($_[0], 'STORE');
  ${$_[0][0]} = $_[1];
}

sub DESTROY {
  _report($_[0], 'DESTROY');
  undef ${$_[0][0]};
}

sub _report {
  my $obj = shift;
  my $action = shift;

  my $global_name = $obj->[1];

  my $msg = Carp::longmess("${action}ing global '$global_name' at");
  if ($opt{track_source}) {
    $obj->[2] = $msg;
  }
  if ($opt{report_write_access}) {
    print STDERR $msg . "\n";
  }
}

sub get_source {
  my $self = shift;
  my $key = shift;
  print STDERR "Source tracking not enabled. Pass the track_source => 1 option when loading TrackGlobalScalar to enable\n"
    if not $opt{track_source};
  return '' if not @{$self} > 2;
  return $self->[2];
}

sub dump_all_sources {
  my $class = shift;
  print STDERR "Source tracking not enabled. Pass the track_source => 1 option when loading TrackGlobalScalar to enable\n"
    if not $opt{track_source};

  my $sources = \%globals;
  foreach my $key (keys %$sources) {
    if (defined ($sources->{$key}->[2])) {
      print STDERR "$key was last set at:\n" . $sources->{$key}->[2] . "\n\n";
    }
  }
}

1;

__END__