Commit | Line | Data |
e4d56f95 |
1 | |
2 | BEGIN { |
3 | |
db1fc20b |
4 | package Visitor::NameTracking; |
e4d56f95 |
5 | |
db1fc20b |
6 | use Moose::Role; |
e4d56f95 |
7 | use B qw(perlstring); |
e4d56f95 |
8 | use namespace::clean -except => 'meta'; |
9 | |
e4d56f95 |
10 | has '_current_trace_name' => (is => 'ro'); |
11 | has 'root_name' => (is => 'ro'); |
12 | |
e4d56f95 |
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 | |
db1fc20b |
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 | |
3aa08904 |
52 | # dump the lazy when we get a sensible version of D::V on the dev system |
53 | |
db1fc20b |
54 | has '_traced_refs' => (is => 'ro', lazy => 1, default => sub { {} }); |
55 | has '_traced_names' => (is => 'ro', lazy => 1, default => sub { {} }); |
56 | |
57 | before visit_ref => sub { |
58 | my ($self, $data) = @_; |
59 | |
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 |
64 | |
65 | weaken($self->_traced_refs->{refaddr $data} = $data); |
66 | |
67 | $self->_traced_names->{refaddr $data} = $self->_current_trace_name; |
68 | }; |
69 | |
e4d56f95 |
70 | sub traced_ref_map { |
71 | my $self = shift; |
72 | my $refs = $self->_traced_refs; |
73 | my $names = $self->_traced_names; |
74 | |
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) |
80 | |
81 | delete @{$names}{grep !defined($refs->{$_}), keys %$names}; |
82 | $names; |
83 | } |
84 | |
85 | # force recursion into objects (Data::Visitor doesn't by default) |
86 | |
87 | sub visit_object { shift->visit_ref(@_) } |
88 | |
db1fc20b |
89 | package Ref::Replacer; |
90 | |
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 |
94 | # |
95 | # I'm faintly curious to see if manual cross-ref-ification nad JSON::XS will |
96 | # actually be faster for reconstructing structures but it's fairly academic |
97 | # as yet |
e4d56f95 |
98 | |
3aa08904 |
99 | use Moose; |
3aa08904 |
100 | use Scalar::Util qw(refaddr isweak); |
101 | use namespace::clean -except => 'meta'; |
102 | |
103 | extends 'Data::Visitor'; |
104 | |
9b97c7a2 |
105 | # we need name tracking but have to apply the role at the end of the file |
106 | # so that our around modifiers end up within the name tracking around |
107 | # instead of outside - otherwise e.g. array value weakening goes wrong |
3aa08904 |
108 | |
109 | has 'external_mappings' => (is => 'ro', lazy => 1, default => sub { {} }); |
110 | has 'weaken_these' => (is => 'ro', lazy => 1, default => sub { {} }); |
111 | has 'map_these' => (is => 'ro', lazy => 1, default => sub { {} }); |
112 | |
9b97c7a2 |
113 | around visit_ref => sub { |
114 | my ($orig, $self) = (shift, shift); |
115 | my $value = $_[0]; |
3aa08904 |
116 | |
117 | # if we've got a mapping for a reference (i.e. it's supplied from |
118 | # somewhere else) then we need to record where we are and then |
119 | # return undef for the fmap process so we serialize an undefined |
120 | # value and the fixup puts the external reference back in later |
121 | |
9b97c7a2 |
122 | if (my $m = $self->external_mappings->{refaddr $value}) { |
3aa08904 |
123 | $self->map_these->{$self->_current_trace_name} = $m; |
124 | return undef; |
125 | } |
126 | |
9b97c7a2 |
127 | return $self->$orig(@_); |
128 | }; |
129 | |
130 | around visit_hash_value => sub { |
131 | my ($orig, $self) = (shift, shift); |
132 | my ($value, $key, $hash) = @_; |
133 | if (isweak $hash->{$key}) { |
134 | $self->weaken_these->{$self->_current_trace_name} = 1; |
135 | } |
136 | return $self->$orig(@_); |
137 | }; |
3aa08904 |
138 | |
9b97c7a2 |
139 | around visit_array_entry => sub { |
140 | my ($orig, $self) = (shift, shift); |
141 | my ($value, $index, $array) = @_; |
142 | if (isweak $array->[$index]) { |
143 | $self->weaken_these->{$self->_current_trace_name} = 1; |
144 | } |
145 | return $self->$orig(@_); |
146 | }; |
147 | |
148 | around visit_scalar => sub { |
149 | my ($orig, $self) = (shift, shift); |
150 | my $scalar = $_[0]; |
151 | if (isweak $$scalar) { |
152 | $self->weaken_these->{$self->_current_trace_name} = 1; |
153 | } |
154 | return $self->$orig(@_); |
155 | }; |
156 | |
157 | # now it's safe to apply the role |
158 | |
159 | with 'Visitor::NameTracking'; |
d8576cdc |
160 | |
161 | sub fixup_code { |
162 | my $self = shift; |
163 | join("\n\n", |
164 | grep defined, |
165 | map $self->${\"_fixup_code_for_$_"}, |
166 | qw(externals weakrefs) |
167 | ); |
168 | } |
169 | |
170 | sub _fixup_code_for_externals { |
171 | my $self = shift; |
172 | my $ext = $self->map_these; |
173 | return unless keys %$ext; |
174 | join("\n", |
175 | qq{# fixup code for external references}, |
176 | map { |
177 | $_.' = '.$ext->{$_}.';'; |
178 | } |
179 | sort keys %$ext |
180 | ); |
181 | } |
182 | |
183 | sub _fixup_code_for_weakrefs { |
184 | my $self = shift; |
185 | my $weaken = $self->weaken_these; |
186 | return unless keys %$weaken; |
187 | join("\n", |
188 | qq{# fixup code for weak references}, |
189 | 'use Scalar::Util ();', |
190 | map { |
191 | 'Scalar::Util::weaken('.$_.');'; |
192 | } |
193 | sort keys %$weaken |
194 | ); |
195 | } |
196 | |
3aa08904 |
197 | # force recursion into objects (Data::Visitor doesn't by default) |
198 | |
199 | sub visit_object { shift->visit_ref(@_) } |
e4d56f95 |
200 | |
201 | } |
202 | |
203 | use Test::More qw(no_plan); |
d8576cdc |
204 | use Scalar::Util qw(refaddr weaken); |
e4d56f95 |
205 | |
206 | my $foo = { |
207 | bar => { baz => [ 'quux', { fleem => 1 } ] }, |
208 | skald => \[ { hot => 'story' } ], |
209 | }; |
210 | |
211 | my @expect = split "\n", <<'EOEXPECT'; |
212 | $foo |
213 | $foo->{"bar"} |
214 | $foo->{"skald"} |
215 | ${$foo->{"skald"}} |
216 | ${$foo->{"skald"}}->[0] |
217 | EOEXPECT |
218 | |
219 | my $tracer = Ref::Tracer->new({ root_name => '$foo' }); |
220 | |
221 | $tracer->visit($foo); |
222 | |
223 | delete $foo->{bar}{baz}; |
224 | |
225 | my $result = $tracer->traced_ref_map; |
226 | |
227 | is_deeply( |
228 | \@expect, |
229 | [ sort { length($a) <=> length($b) } values %$result ], |
230 | "Expected results present" |
231 | ); |
232 | |
233 | my %map = reverse %$result; |
234 | |
235 | foreach my $e (@expect) { |
236 | my $value = do { |
237 | local $@; |
238 | my $r = eval $e; |
239 | die "Error $@ evaluating $e" if $@; |
240 | $r; |
241 | }; |
242 | is($map{$e},refaddr($value), "Result for ${e} ok"); |
243 | } |
244 | |
d8576cdc |
245 | my $flimflam = { |
246 | one => { two => three }, |
247 | bard => $foo->{skald}, |
248 | bard_guts => ${$foo->{skald}}, |
249 | empty_now => $foo->{bar}, |
250 | }; |
251 | |
252 | weaken($flimflam->{weak_one} = $flimflam->{one}); |
9b97c7a2 |
253 | weaken($flimflam->{weak_member}[0] = $flimflam->{bard}); |
254 | weaken(${$flimflam->{weak_scalar}} = $flimflam->{bard_guts}); |
d8576cdc |
255 | |
256 | my $replacer = Ref::Replacer->new({ |
257 | external_mappings => $result, |
258 | root_name => '$final', |
259 | }); |
260 | |
261 | my $copyflam = $replacer->visit($flimflam); |
262 | |
263 | use Data::Dumper; $Data::Dumper::Indent = 1; |
264 | |
265 | warn Dumper($copyflam); |
266 | |
267 | warn $replacer->fixup_code; |