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 # dump the lazy when we get a sensible version of D::V on the dev system
54 has '_traced_refs' => (is => 'ro', lazy => 1, default => sub { {} });
55 has '_traced_names' => (is => 'ro', lazy => 1, default => sub { {} });
57 before visit_ref => sub {
58 my ($self, $data) = @_;
60 # can't just rely on refaddr because it may get re-used if the data goes
61 # out of scope (we could play clever games with free magic on the wizard
62 # or whatever but KISS) - but we -can- keep a weak reference which will
63 # turn to undef if the variable disappears
65 weaken($self->_traced_refs->{refaddr $data} = $data);
67 $self->_traced_names->{refaddr $data} = $self->_current_trace_name;
72 my $refs = $self->_traced_refs;
73 my $names = $self->_traced_names;
75 # nuke keys where the traced refs entry is undef since they indicate
76 # "went out of scope" so the name is no longer valid. however if we
77 # do still have a refs entry we know the name is valid because if it
78 # didn't go out of scope that refaddr can't have been re-used.
79 # (NB: I don't care if this works under ithreads)
81 delete @{$names}{grep !defined($refs->{$_}), keys %$names};
85 # force recursion into objects (Data::Visitor doesn't by default)
87 sub visit_object { shift->visit_ref(@_) }
89 package Ref::Replacer;
91 # note: we actually handle weaken as well as external refs because I intend
92 # to use Data::Dumper as a first pass and YAML::XS as a second and neither
93 # of them know how to deal with weak references
95 # better still, neither actually does the bloody cross refs properly - Dumper
96 # emits them but the nature of the beast is that they don't eval back in
97 # right, YAML::XS seems to make two aliases to one ref (Data::Alias-ish)
98 # since when I weaken one both copies disappear on me. sigh.
100 # on the upside, we can use a really dumb dumper for the rest - JSON::XS
101 # strikes me as an interesting possibility for speed reasons
104 use Scalar::Util qw(refaddr isweak);
105 use namespace::clean -except => 'meta';
107 extends 'Data::Visitor';
109 # we need name tracking but have to apply the role at the end of the file
110 # so that our around modifiers end up within the name tracking around
111 # instead of outside - otherwise e.g. array value weakening goes wrong
113 has 'external_mappings' => (is => 'ro', lazy => 1, default => sub { {} });
114 has '_internal_mappings' => (is => 'ro', lazy => 1, default => sub { {} });
115 has 'weaken_these' => (is => 'ro', lazy => 1, default => sub { {} });
116 has 'map_these' => (is => 'ro', lazy => 1, default => sub { {} });
118 around visit => sub {
119 my ($orig, $self) = (shift, shift);
122 # note that we can't localize this one since it needs to be global
123 # across the entire structure - we could consider a weakref based trick
124 # like we use in the recorder but I don't -think- there's any need
126 # if we've already seen this reference, register a mapping for this
127 # copy of it so we fix it up afterwards (see visit_ref for the same process
128 # being used for references to be supplied externally at deserialize time
129 # and the top of the class for notes on how much I love serializers)
131 if (ref($value) && (my $m = $self->_internal_mappings->{refaddr $value})) {
132 $self->map_these->{$self->_current_trace_name} = $m;
136 return $self->$orig(@_);
139 around visit_ref => sub {
140 my ($orig, $self) = (shift, shift);
143 # if we've got a mapping for a reference (i.e. it's supplied from
144 # somewhere else) then we need to record where we are and then
145 # return undef for the fmap process so we serialize an undefined
146 # value and the fixup puts the external reference back in later
148 if (my $m = $self->external_mappings->{refaddr $value}) {
149 $self->map_these->{$self->_current_trace_name} = $m;
153 $self->_internal_mappings->{refaddr $value} = $self->_current_trace_name;
155 return $self->$orig(@_);
158 around visit_hash_value => sub {
159 my ($orig, $self) = (shift, shift);
160 my ($value, $key, $hash) = @_;
161 if (isweak $hash->{$key}) {
162 $self->weaken_these->{$self->_current_trace_name} = 1;
164 return $self->$orig(@_);
167 around visit_array_entry => sub {
168 my ($orig, $self) = (shift, shift);
169 my ($value, $index, $array) = @_;
170 if (isweak $array->[$index]) {
171 $self->weaken_these->{$self->_current_trace_name} = 1;
173 return $self->$orig(@_);
176 around visit_scalar => sub {
177 my ($orig, $self) = (shift, shift);
179 if (isweak $$scalar) {
180 $self->weaken_these->{$self->_current_trace_name} = 1;
182 return $self->$orig(@_);
185 # now it's safe to apply the role
187 with 'Visitor::NameTracking';
193 map $self->${\"_fixup_code_for_$_"},
194 qw(externals weakrefs)
198 sub _fixup_code_for_externals {
200 my $ext = $self->map_these;
201 return unless keys %$ext;
203 qq{# fixup code for external references},
205 my ($l, $r) = ($_, $ext->{$_});
206 # if the LHS is a scalarref deref then we actually
207 # need to strip that bit off and push the enref to the RHS since
209 # is an attempt to modify a readonly value and perl will burst into tears
210 if ($l =~ m/^\${(.*)}$/) { $l = $1; $r = "\\".$r; }
217 sub _fixup_code_for_weakrefs {
219 my $weaken = $self->weaken_these;
220 return unless keys %$weaken;
222 qq{# fixup code for weak references},
223 'use Scalar::Util ();',
225 'Scalar::Util::weaken('.$_.');';
231 # force recursion into objects (Data::Visitor doesn't by default)
233 sub visit_object { shift->visit_ref(@_) }
237 use Test::More qw(no_plan);
238 use Scalar::Util qw(refaddr weaken isweak);
242 bar => { baz => [ 'quux', { fleem => 1 } ] },
243 skald => \[ { hot => 'story' } ],
246 my @expect = split "\n", <<'EOEXPECT';
251 ${$foo->{"skald"}}->[0]
254 my $tracer = Ref::Tracer->new({ root_name => '$foo' });
256 $tracer->visit($foo);
258 delete $foo->{bar}{baz};
260 my $result = $tracer->traced_ref_map;
264 [ sort { length($a) <=> length($b) } values %$result ],
265 "Expected results present"
268 my %map = reverse %$result;
270 foreach my $e (@expect) {
274 die "Error $@ evaluating $e" if $@;
277 is($map{$e},refaddr($value), "Result for ${e} ok");
281 one => { two => three },
282 bard => $foo->{skald},
283 bard_guts => ${$foo->{skald}},
284 empty_now => $foo->{bar},
287 weaken($flimflam->{weak_one} = $flimflam->{one});
288 weaken($flimflam->{weak_member}[0] = $flimflam->{bard});
289 weaken(${$flimflam->{weak_scalar}} = $flimflam->{bard_guts});
291 #use Data::Dumper; $Data::Dumper::Indent = 1;
293 #warn "Flimflam:\n".Dumper($flimflam);
295 my $replacer = Ref::Replacer->new({
296 external_mappings => $result,
297 root_name => '$final',
300 my $copyflam = $replacer->visit($flimflam);
302 my $dump = Dump($copyflam);
303 my $fixup = $replacer->fixup_code;
305 #warn "Dump:\n".$dump;
306 #warn "Fixup:\n".$fixup;
308 my $final = Load($dump);
310 #warn "Unfixed final:\n".Dumper($final);
315 die "fixup code died: $@" if $@;
318 #warn "Fixed final:\n".Dumper($final);
320 is_deeply($flimflam, $final, 'Structures deeply the same after fixup');
322 ok(isweak($final->{weak_one}), '$final->{weak_one} is a weak ref');
323 ok(isweak($final->{weak_member}[0]), '$final->{weak_member}[0] is a weak ref');
324 ok(isweak(${$final->{weak_scalar}}), '${$final->{weak_scalar}} is a weak ref');