4 package Visitor::NameTracking;
8 use namespace::clean -except => 'meta';
10 has '_current_trace_name' => (is => 'ro');
11 has 'root_name' => (is => 'ro');
14 my ($orig, $self) = (shift, shift);
15 local $self->{_current_trace_name}
16 = ($self->{_current_trace_name}||$self->root_name);
17 return $self->$orig(@_);
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(@_);
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(@_);
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(@_);
45 use Scalar::Util qw(weaken refaddr);
46 use namespace::clean -except => 'meta';
48 extends 'Data::Visitor';
50 with 'Visitor::NameTracking';
52 has '_traced_refs' => (is => 'ro', lazy => 1, default => sub { {} });
53 has '_traced_names' => (is => 'ro', lazy => 1, default => sub { {} });
55 before visit_ref => sub {
56 my ($self, $data) = @_;
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
63 weaken($self->_traced_refs->{refaddr $data} = $data);
65 $self->_traced_names->{refaddr $data} = $self->_current_trace_name;
70 my $refs = $self->_traced_refs;
71 my $names = $self->_traced_names;
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)
79 delete @{$names}{grep !defined($refs->{$_}), keys %$names};
83 # force recursion into objects (Data::Visitor doesn't by default)
85 sub visit_object { shift->visit_ref(@_) }
87 package Ref::Replacer;
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
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
98 #use Variable::Magic qw(getdata);
102 use Test::More qw(no_plan);
103 use Scalar::Util qw(refaddr);
106 bar => { baz => [ 'quux', { fleem => 1 } ] },
107 skald => \[ { hot => 'story' } ],
110 my @expect = split "\n", <<'EOEXPECT';
115 ${$foo->{"skald"}}->[0]
118 my $tracer = Ref::Tracer->new({ root_name => '$foo' });
120 $tracer->visit($foo);
122 delete $foo->{bar}{baz};
124 my $result = $tracer->traced_ref_map;
128 [ sort { length($a) <=> length($b) } values %$result ],
129 "Expected results present"
132 my %map = reverse %$result;
134 foreach my $e (@expect) {
138 die "Error $@ evaluating $e" if $@;
141 is($map{$e},refaddr($value), "Result for ${e} ok");
146 use Data::Dumper; $Data::Dumper::Indent = 1;
148 warn Dumper($tracer->_traced_refs);
149 warn Dumper($tracer->_traced_names);
154 scalar(@expect), '==', scalar(@{$tracer->_traced_refs}),
155 'Right number of traced refs',
158 my $reflist = $tracer->_traced_refs;
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");