break tracer.pl out into multifarious manifoldly marvelous modules

[gitmo/MooseX-Antlers.git] / lib / MooseX / Antlers / Visitor / NameTracking.pm

diff --git a/lib/MooseX/Antlers/Visitor/NameTracking.pm b/lib/MooseX/Antlers/Visitor/NameTracking.pm
new file mode 100644 (file)
index 0000000..770da8b
--- /dev/null
+++ b/lib/MooseX/Antlers/Visitor/NameTracking.pm
@@ -0,0 +1,39 @@
+package MooseX::Antlers::Visitor::NameTracking;
+
+use Moose::Role;
+use B qw(perlstring);
+use namespace::clean -except => 'meta';
+
+has '_current_trace_name' => (is => 'ro');
+has 'root_name' => (is => 'ro');
+
+around visit => sub {
+  my ($orig, $self) = (shift, shift);
+  local $self->{_current_trace_name}
+    = ($self->{_current_trace_name}||$self->root_name);
+  return $self->$orig(@_);
+};
+
+around visit_hash_entry => sub {
+  my ($orig, $self) = (shift, shift);
+  my $key = $_[0]; # $key, $value
+  local $self->{_current_trace_name}
+    = $self->{_current_trace_name}.'->{'.(perlstring $key).'}';
+  return $self->$orig(@_);
+};
+
+around visit_array_entry => sub {
+  my ($orig, $self) = (shift, shift);
+  my $index = $_[1]; # $value, $index
+  local $self->{_current_trace_name}
+    = $self->{_current_trace_name}.'->['.$index.']';
+  return $self->$orig(@_);
+};
+
+around visit_scalar => sub {
+  my ($orig, $self) = (shift, shift);
+  local $self->{_current_trace_name} = '${'.$self->{_current_trace_name}.'}';
+  return $self->$orig(@_);
+};
+
+1;