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; |
100 | # ensure we have next::method available - just because Moose loads it |
101 | # as a side effect doesn't mean it's clever to rely on that |
102 | use MRO::Compat (); |
103 | use Scalar::Util qw(refaddr isweak); |
104 | use namespace::clean -except => 'meta'; |
105 | |
106 | extends 'Data::Visitor'; |
107 | |
108 | with 'Visitor::NameTracking'; |
109 | |
110 | has 'external_mappings' => (is => 'ro', lazy => 1, default => sub { {} }); |
111 | has 'weaken_these' => (is => 'ro', lazy => 1, default => sub { {} }); |
112 | has 'map_these' => (is => 'ro', lazy => 1, default => sub { {} }); |
113 | |
114 | # fairly sure an around modifier will get severely fucked up here |
115 | # in that the copying of @_ will lose the weakness we need to check |
116 | |
117 | sub visit_ref { |
118 | my $self = shift; |
119 | |
120 | # have to test $_[0] directly since copying a weak ref gives a strong ref |
121 | |
122 | if (isweak $_[0]) { |
123 | $self->weaken_these->{$self->_current_trace_name} = 1; |
124 | } |
125 | |
126 | # if we've got a mapping for a reference (i.e. it's supplied from |
127 | # somewhere else) then we need to record where we are and then |
128 | # return undef for the fmap process so we serialize an undefined |
129 | # value and the fixup puts the external reference back in later |
130 | |
131 | if (my $m = $self->external_mappings->{refaddr $_[0]}) { |
132 | $self->map_these->{$self->_current_trace_name} = $m; |
133 | return undef; |
134 | } |
135 | |
136 | return $self->next::method(@_); |
137 | } |
138 | |
139 | # force recursion into objects (Data::Visitor doesn't by default) |
140 | |
141 | sub visit_object { shift->visit_ref(@_) } |
e4d56f95 |
142 | |
143 | } |
144 | |
145 | use Test::More qw(no_plan); |
146 | use Scalar::Util qw(refaddr); |
147 | |
148 | my $foo = { |
149 | bar => { baz => [ 'quux', { fleem => 1 } ] }, |
150 | skald => \[ { hot => 'story' } ], |
151 | }; |
152 | |
153 | my @expect = split "\n", <<'EOEXPECT'; |
154 | $foo |
155 | $foo->{"bar"} |
156 | $foo->{"skald"} |
157 | ${$foo->{"skald"}} |
158 | ${$foo->{"skald"}}->[0] |
159 | EOEXPECT |
160 | |
161 | my $tracer = Ref::Tracer->new({ root_name => '$foo' }); |
162 | |
163 | $tracer->visit($foo); |
164 | |
165 | delete $foo->{bar}{baz}; |
166 | |
167 | my $result = $tracer->traced_ref_map; |
168 | |
169 | is_deeply( |
170 | \@expect, |
171 | [ sort { length($a) <=> length($b) } values %$result ], |
172 | "Expected results present" |
173 | ); |
174 | |
175 | my %map = reverse %$result; |
176 | |
177 | foreach my $e (@expect) { |
178 | my $value = do { |
179 | local $@; |
180 | my $r = eval $e; |
181 | die "Error $@ evaluating $e" if $@; |
182 | $r; |
183 | }; |
184 | is($map{$e},refaddr($value), "Result for ${e} ok"); |
185 | } |
186 | |
187 | =pod |
188 | |
189 | use Data::Dumper; $Data::Dumper::Indent = 1; |
190 | |
191 | warn Dumper($tracer->_traced_refs); |
192 | warn Dumper($tracer->_traced_names); |
193 | |
194 | =pod |
195 | |
196 | cmp_ok( |
197 | scalar(@expect), '==', scalar(@{$tracer->_traced_refs}), |
198 | 'Right number of traced refs', |
199 | ); |
200 | |
201 | my $reflist = $tracer->_traced_refs; |
202 | |
203 | foreach my $i (0 .. $#expect) { |
204 | my $tail = "at list pos $i"; |
205 | is($e[$i], $reflist[$i], "Correct ref $e[$i] at $tail"); |
206 | my $data = getdata $reflist[$i], Trace::Constants::TRACE_WIZ; |
207 | is($data->[0], 'Blue', "tag ok at $tail"); |
208 | cmp_ok($data->[1], '==', $i, "Index ok at $i"); |