Commit | Line | Data |
0373380c |
1 | package MooseX::Antlers::RefTracker; |
2 | |
3 | use Moose; |
4 | use Scalar::Util qw(weaken refaddr); |
5 | use namespace::clean -except => 'meta'; |
6 | |
7 | extends 'Data::Visitor'; |
8 | |
9 | with 'MooseX::Antlers::Visitor::NameTracking'; |
10 | |
11 | # dump the lazy when we get a sensible version of D::V on the dev system |
12 | |
13 | has '_traced_refs' => (is => 'ro', lazy => 1, default => sub { {} }); |
14 | has '_traced_names' => (is => 'ro', lazy => 1, default => sub { {} }); |
15 | |
5ed50637 |
16 | sub trace_refs { |
17 | my ($class, $name, $refs) = @_; |
18 | my $self = $class->new({ root_name => $name }); |
19 | $self->visit($refs); |
20 | return $self->traced_ref_map; |
21 | } |
22 | |
0373380c |
23 | before visit_ref => sub { |
24 | my ($self, $data) = @_; |
25 | |
26 | # can't just rely on refaddr because it may get re-used if the data goes |
27 | # out of scope (we could play clever games with free magic on the wizard |
28 | # or whatever but KISS) - but we -can- keep a weak reference which will |
29 | # turn to undef if the variable disappears |
30 | |
31 | weaken($self->_traced_refs->{refaddr $data} = $data); |
32 | |
33 | $self->_traced_names->{refaddr $data} = $self->_current_trace_name; |
34 | }; |
35 | |
36 | sub traced_ref_map { |
37 | my $self = shift; |
38 | my $refs = $self->_traced_refs; |
39 | my $names = $self->_traced_names; |
40 | |
41 | # nuke keys where the traced refs entry is undef since they indicate |
42 | # "went out of scope" so the name is no longer valid. however if we |
43 | # do still have a refs entry we know the name is valid because if it |
44 | # didn't go out of scope that refaddr can't have been re-used. |
45 | # (NB: I don't care if this works under ithreads) |
46 | |
47 | delete @{$names}{grep !defined($refs->{$_}), keys %$names}; |
48 | $names; |
49 | } |
50 | |
51 | # force recursion into objects (Data::Visitor doesn't by default) |
52 | |
53 | sub visit_object { shift->visit_ref(@_) } |
54 | |
55 | 1; |