variabubble tracerification

diff --git a/tracer.pl b/tracer.pl
new file mode 100644 (file)
index 0000000..dda089b
--- /dev/null
+++ b/tracer.pl
@@ -0,0 +1,149 @@
+
+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");