tracer.pl

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