X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMooseX-Antlers.git;a=blobdiff_plain;f=lib%2FMooseX%2FAntlers%2FRefTracker.pm;fp=lib%2FMooseX%2FAntlers%2FRefTracker.pm;h=26473c1c43a29a5f0abe39d5fc61087a8a703077;hp=0000000000000000000000000000000000000000;hb=0373380cd9656a6a2be0e85483348a66396fb192;hpb=9831d16561549202379d782f8905b9d2f7b70cd9

diff --git a/lib/MooseX/Antlers/RefTracker.pm b/lib/MooseX/Antlers/RefTracker.pm
new file mode 100644
index 0000000..26473c1
--- /dev/null
+++ b/lib/MooseX/Antlers/RefTracker.pm
@@ -0,0 +1,48 @@
+package MooseX::Antlers::RefTracker;
+
+use Moose;
+use Scalar::Util qw(weaken refaddr);
+use namespace::clean -except => 'meta';
+
+extends 'Data::Visitor';
+
+with 'MooseX::Antlers::Visitor::NameTracking';
+
+# dump the lazy when we get a sensible version of D::V on the dev system
+
+has '_traced_refs' => (is => 'ro', lazy => 1, default => sub { {} });
+has '_traced_names' => (is => 'ro', lazy => 1, default => sub { {} });
+
+before visit_ref => sub {
+  my ($self, $data) = @_;
+
+  # can't just rely on refaddr because it may get re-used if the data goes
+  # out of scope (we could play clever games with free magic on the wizard
+  # or whatever but KISS) - but we -can- keep a weak reference which will
+  # turn to undef if the variable disappears
+
+  weaken($self->_traced_refs->{refaddr $data} = $data);
+
+  $self->_traced_names->{refaddr $data} = $self->_current_trace_name;
+};
+
+sub traced_ref_map {
+  my $self = shift;
+  my $refs = $self->_traced_refs;
+  my $names = $self->_traced_names;
+
+  # nuke keys where the traced refs entry is undef since they indicate
+  # "went out of scope" so the name is no longer valid. however if we
+  # do still have a refs entry we know the name is valid because if it
+  # didn't go out of scope that refaddr can't have been re-used.
+  # (NB: I don't care if this works under ithreads)
+
+  delete @{$names}{grep !defined($refs->{$_}), keys %$names};
+  $names;
+}
+
+# force recursion into objects (Data::Visitor doesn't by default)
+
+sub visit_object { shift->visit_ref(@_) }
+
+1;