variabubble tracerification

[gitmo/MooseX-Antlers.git] / tracer.pl

BEGIN {

package Ref::Tracer;

use Moose;
use B qw(perlstring);
use Scalar::Util qw(weaken refaddr);
use namespace::clean -except => 'meta';

extends 'Data::Visitor';

has '_traced_refs' => (is => 'ro', lazy => 1, default => sub { {} });
has '_traced_names' => (is => 'ro', lazy => 1, default => sub { {} });
has '_current_trace_name' => (is => 'ro');
has 'root_name' => (is => 'ro');

before visit_ref => sub {
  my ($self, $data) = @_;

  # can't just rely on refaddr because it may get re-used if the data goes
  # out of scope (we could play clever games with free magic on the wizard
  # or whatever but KISS) - but we -can- keep a weak reference which will
  # turn to undef if the variable disappears

  weaken($self->_traced_refs->{refaddr $data} = $data);

  $self->_traced_names->{refaddr $data} = $self->_current_trace_name;
};

around visit => sub {
  my ($orig, $self) = (shift, shift);
  local $self->{_current_trace_name}
    = ($self->{_current_trace_name}||$self->root_name);
  return $self->$orig(@_);
};

around visit_hash_entry => sub {
  my ($orig, $self) = (shift, shift);
  my $key = $_[0]; # $key, $value
  local $self->{_current_trace_name}
    = $self->{_current_trace_name}.'->{'.(perlstring $key).'}';
  return $self->$orig(@_);
};

around visit_array_entry => sub {
  my ($orig, $self) = (shift, shift);
  my $index = $_[1]; # $value, $index
  local $self->{_current_trace_name}
    = $self->{_current_trace_name}.'->['.$index.']';
  return $self->$orig(@_);
};

around visit_scalar => sub {
  my ($orig, $self) = (shift, shift);
  local $self->{_current_trace_name} = '${'.$self->{_current_trace_name}.'}';
  return $self->$orig(@_);
};

sub traced_ref_map {
  my $self = shift;
  my $refs = $self->_traced_refs;
  my $names = $self->_traced_names;

  # nuke keys where the traced refs entry is undef since they indicate
  # "went out of scope" so the name is no longer valid. however if we
  # do still have a refs entry we know the name is valid because if it
  # didn't go out of scope that refaddr can't have been re-used.
  # (NB: I don't care if this works under ithreads)

  delete @{$names}{grep !defined($refs->{$_}), keys %$names};
  $names;
}

# force recursion into objects (Data::Visitor doesn't by default)

sub visit_object { shift->visit_ref(@_) }

#package Ref::Replacer;

#use Moose;
#use Variable::Magic qw(getdata);

}

use Test::More qw(no_plan);
use Scalar::Util qw(refaddr);

my $foo = {
  bar => { baz => [ 'quux', { fleem => 1 } ] },
  skald => \[ { hot => 'story' } ],
};

my @expect = split "\n", <<'EOEXPECT';
$foo
$foo->{"bar"}
$foo->{"skald"}
${$foo->{"skald"}}
${$foo->{"skald"}}->[0]
EOEXPECT

my $tracer = Ref::Tracer->new({ root_name => '$foo' });

$tracer->visit($foo);

delete $foo->{bar}{baz};

my $result = $tracer->traced_ref_map;

is_deeply(
  \@expect,
  [ sort { length($a) <=> length($b) } values %$result ],
  "Expected results present"
);

my %map = reverse %$result;

foreach my $e (@expect) {
  my $value = do {
    local $@;
    my $r = eval $e;
    die "Error $@ evaluating $e" if $@;
    $r;
  };
  is($map{$e},refaddr($value), "Result for ${e} ok");
}

=pod
  
use Data::Dumper; $Data::Dumper::Indent = 1;

warn Dumper($tracer->_traced_refs);
warn Dumper($tracer->_traced_names);

=pod

cmp_ok(
  scalar(@expect), '==', scalar(@{$tracer->_traced_refs}),
  'Right number of traced refs',
);

my $reflist = $tracer->_traced_refs;

foreach my $i (0 .. $#expect) {
  my $tail = "at list pos $i";
  is($e[$i], $reflist[$i], "Correct ref $e[$i] at $tail");
  my $data = getdata $reflist[$i], Trace::Constants::TRACE_WIZ;
  is($data->[0], 'Blue', "tag ok at $tail");
  cmp_ok($data->[1], '==', $i, "Index ok at $i");