tracer.pl

   1
   2 BEGIN {
   3
   4 package Ref::Tracer;
   5
   6 use Moose;
   7 use B qw(perlstring);
   8 use Scalar::Util qw(weaken refaddr);
   9 use namespace::clean -except => 'meta';
  10
  11 extends 'Data::Visitor';
  12
  13 has '_traced_refs' => (is => 'ro', lazy => 1, default => sub { {} });
  14 has '_traced_names' => (is => 'ro', lazy => 1, default => sub { {} });
  15 has '_current_trace_name' => (is => 'ro');
  16 has 'root_name' => (is => 'ro');
  17
  18 before visit_ref => sub {
  19   my ($self, $data) = @_;
  20
  21   # can't just rely on refaddr because it may get re-used if the data goes
  22   # out of scope (we could play clever games with free magic on the wizard
  23   # or whatever but KISS) - but we -can- keep a weak reference which will
  24   # turn to undef if the variable disappears
  25
  26   weaken($self->_traced_refs->{refaddr $data} = $data);
  27
  28   $self->_traced_names->{refaddr $data} = $self->_current_trace_name;
  29 };
  30
  31 around visit => sub {
  32   my ($orig, $self) = (shift, shift);
  33   local $self->{_current_trace_name}
  34     = ($self->{_current_trace_name}||$self->root_name);
  35   return $self->$orig(@_);
  36 };
  37
  38 around visit_hash_entry => sub {
  39   my ($orig, $self) = (shift, shift);
  40   my $key = $_[0]; # $key, $value
  41   local $self->{_current_trace_name}
  42     = $self->{_current_trace_name}.'->{'.(perlstring $key).'}';
  43   return $self->$orig(@_);
  44 };
  45
  46 around visit_array_entry => sub {
  47   my ($orig, $self) = (shift, shift);
  48   my $index = $_[1]; # $value, $index
  49   local $self->{_current_trace_name}
  50     = $self->{_current_trace_name}.'->['.$index.']';
  51   return $self->$orig(@_);
  52 };
  53
  54 around visit_scalar => sub {
  55   my ($orig, $self) = (shift, shift);
  56   local $self->{_current_trace_name} = '${'.$self->{_current_trace_name}.'}';
  57   return $self->$orig(@_);
  58 };
  59
  60 sub traced_ref_map {
  61   my $self = shift;
  62   my $refs = $self->_traced_refs;
  63   my $names = $self->_traced_names;
  64
  65   # nuke keys where the traced refs entry is undef since they indicate
  66   # "went out of scope" so the name is no longer valid. however if we
  67   # do still have a refs entry we know the name is valid because if it
  68   # didn't go out of scope that refaddr can't have been re-used.
  69   # (NB: I don't care if this works under ithreads)
  70
  71   delete @{$names}{grep !defined($refs->{$_}), keys %$names};
  72   $names;
  73 }
  74
  75 # force recursion into objects (Data::Visitor doesn't by default)
  76
  77 sub visit_object { shift->visit_ref(@_) }
  78
  79 #package Ref::Replacer;
  80
  81 #use Moose;
  82 #use Variable::Magic qw(getdata);
  83
  84 }
  85
  86 use Test::More qw(no_plan);
  87 use Scalar::Util qw(refaddr);
  88
  89 my $foo = {
  90   bar => { baz => [ 'quux', { fleem => 1 } ] },
  91   skald => \[ { hot => 'story' } ],
  92 };
  93
  94 my @expect = split "\n", <<'EOEXPECT';
  95 $foo
  96 $foo->{"bar"}
  97 $foo->{"skald"}
  98 ${$foo->{"skald"}}
  99 ${$foo->{"skald"}}->[0]
 100 EOEXPECT
 101
 102 my $tracer = Ref::Tracer->new({ root_name => '$foo' });
 103
 104 $tracer->visit($foo);
 105
 106 delete $foo->{bar}{baz};
 107
 108 my $result = $tracer->traced_ref_map;
 109
 110 is_deeply(
 111   \@expect,
 112   [ sort { length($a) <=> length($b) } values %$result ],
 113   "Expected results present"
 114 );
 115
 116 my %map = reverse %$result;
 117
 118 foreach my $e (@expect) {
 119   my $value = do {
 120     local $@;
 121     my $r = eval $e;
 122     die "Error $@ evaluating $e" if $@;
 123     $r;
 124   };
 125   is($map{$e},refaddr($value), "Result for ${e} ok");
 126 }
 127
 128 =pod
 129
 130 use Data::Dumper; $Data::Dumper::Indent = 1;
 131
 132 warn Dumper($tracer->_traced_refs);
 133 warn Dumper($tracer->_traced_names);
 134
 135 =pod
 136
 137 cmp_ok(
 138   scalar(@expect), '==', scalar(@{$tracer->_traced_refs}),
 139   'Right number of traced refs',
 140 );
 141
 142 my $reflist = $tracer->_traced_refs;
 143
 144 foreach my $i (0 .. $#expect) {
 145   my $tail = "at list pos $i";
 146   is($e[$i], $reflist[$i], "Correct ref $e[$i] at $tail");
 147   my $data = getdata $reflist[$i], Trace::Constants::TRACE_WIZ;
 148   is($data->[0], 'Blue', "tag ok at $tail");
 149   cmp_ok($data->[1], '==', $i, "Index ok at $i");