From: Matt S Trout <mst@shadowcat.co.uk>
Date: Sat, 20 Jun 2009 23:56:53 +0000 (-0400)
Subject: break tracer.pl out into multifarious manifoldly marvelous modules
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=0373380cd9656a6a2be0e85483348a66396fb192;p=gitmo%2FMooseX-Antlers.git

break tracer.pl out into multifarious manifoldly marvelous modules
---

diff --git a/lib/MooseX/Antlers/RefFilter.pm b/lib/MooseX/Antlers/RefFilter.pm
new file mode 100644
index 0000000..684d2b8
--- /dev/null
+++ b/lib/MooseX/Antlers/RefFilter.pm
@@ -0,0 +1,147 @@
+package MooseX::Antlers::RefFilter;
+
+# note: we actually handle weaken as well as external refs because I intend
+# to use Data::Dumper  as a first pass and YAML::XS as a second and neither
+# of them know how to deal with weak references
+#
+# better still, neither actually does the bloody cross refs properly - Dumper
+# emits them but the nature of the beast is that they don't eval back in
+# right, YAML::XS seems to make two aliases to one ref (Data::Alias-ish)
+# since when I weaken one both copies disappear on me. sigh.
+#
+# on the upside, we can use a really dumb dumper for the rest - JSON::XS
+# strikes me as an interesting possibility for speed reasons
+
+use Moose;
+use Scalar::Util qw(refaddr isweak);
+use namespace::clean -except => 'meta';
+
+extends 'Data::Visitor';
+
+# we need name tracking but have to apply the role at the end of the file
+# so that our around modifiers end up within the name tracking around
+# instead of outside - otherwise e.g. array value weakening goes wrong
+
+has 'external_mappings' => (is => 'ro', lazy => 1, default => sub { {} });
+has '_internal_mappings' => (is => 'ro', lazy => 1, default => sub { {} });
+has 'weaken_these' => (is => 'ro', lazy => 1, default => sub { {} });
+has 'map_these' => (is => 'ro', lazy => 1, default => sub { {} });
+
+around visit => sub {
+  my ($orig, $self) = (shift, shift);
+  my $value = $_[0];
+
+  # note that we can't localize this one since it needs to be global
+  # across the entire structure - we could consider a weakref based trick
+  # like we use in the recorder but I don't -think- there's any need
+
+  # if we've already seen this reference, register a mapping for this
+  # copy of it so we fix it up afterwards (see visit_ref for the same process
+  # being used for references to be supplied externally at deserialize time
+  # and the top of the class for notes on how much I love serializers)
+
+  if (ref($value) && (my $m = $self->_internal_mappings->{refaddr $value})) {
+    $self->map_these->{$self->_current_trace_name} = $m;
+    return undef;
+  }
+
+  return $self->$orig(@_);
+};
+
+around visit_ref => sub {
+  my ($orig, $self) = (shift, shift);
+  my $value = $_[0];
+
+  # if we've got a mapping for a reference (i.e. it's supplied from
+  # somewhere else) then we need to record where we are and then
+  # return undef for the fmap process so we serialize an undefined
+  # value and the fixup puts the external reference back in later
+
+  if (my $m = $self->external_mappings->{refaddr $value}) {
+    $self->map_these->{$self->_current_trace_name} = $m;
+    return undef;
+  }
+
+  $self->_internal_mappings->{refaddr $value} = $self->_current_trace_name;
+
+  return $self->$orig(@_);
+};
+
+around visit_hash_value => sub {
+  my ($orig, $self) = (shift, shift);
+  my ($value, $key, $hash) = @_;
+  if (isweak $hash->{$key}) {
+    $self->weaken_these->{$self->_current_trace_name} = 1;
+  }
+  return $self->$orig(@_);
+};
+
+around visit_array_entry => sub {
+  my ($orig, $self) = (shift, shift);
+  my ($value, $index, $array) = @_;
+  if (isweak $array->[$index]) {
+    $self->weaken_these->{$self->_current_trace_name} = 1;
+  }
+  return $self->$orig(@_);
+};
+
+around visit_scalar => sub {
+  my ($orig, $self) = (shift, shift);
+  my $scalar = $_[0];
+  if (isweak $$scalar) {
+    $self->weaken_these->{$self->_current_trace_name} = 1;
+  }
+  return $self->$orig(@_);
+};
+
+# now it's safe to apply the role
+
+with 'MooseX::Antlers::Visitor::NameTracking';
+
+sub fixup_code {
+  my $self = shift;
+  join("\n\n",
+    grep defined,
+      map $self->${\"_fixup_code_for_$_"},
+        qw(externals weakrefs)
+  );
+}
+
+sub _fixup_code_for_externals {
+  my $self = shift;
+  my $ext = $self->map_these;
+  return unless keys %$ext;
+  join("\n",
+    qq{# fixup code for external references},
+    map {
+      my ($l, $r) = ($_, $ext->{$_});
+      # if the LHS is a scalarref deref then we actually
+      # need to strip that bit off and push the enref to the RHS since
+      # ${\undef} = "foo"
+      # is an attempt to modify a readonly value and perl will burst into tears
+      if ($l =~ m/^\${(.*)}$/) { $l = $1; $r = "\\".$r; }
+      $l.' = '.$r.';';
+    }
+    sort keys %$ext
+  );
+}
+
+sub _fixup_code_for_weakrefs {
+  my $self = shift;
+  my $weaken = $self->weaken_these;
+  return unless keys %$weaken;
+  join("\n",
+    qq{# fixup code for weak references},
+    'use Scalar::Util ();',
+    map {
+      'Scalar::Util::weaken('.$_.');';
+    }
+    sort keys %$weaken
+  );
+}
+
+# force recursion into objects (Data::Visitor doesn't by default)
+
+sub visit_object { shift->visit_ref(@_) }
+
+1;
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;
diff --git a/lib/MooseX/Antlers/Visitor/NameTracking.pm b/lib/MooseX/Antlers/Visitor/NameTracking.pm
new file mode 100644
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;
diff --git a/t/refwalk.t b/t/refwalk.t
new file mode 100644
index 0000000..29b4a31
--- /dev/null
+++ b/t/refwalk.t
@@ -0,0 +1,90 @@
+use Test::More qw(no_plan);
+use Scalar::Util qw(refaddr weaken isweak);
+use YAML::XS;
+use aliased 'MooseX::Antlers::RefTracker';
+use aliased 'MooseX::Antlers::RefFilter';
+
+my $foo = {
+  bar => { baz => [ 'quux', { fleem => 1 } ] },
+  skald => \[ { hot => 'story' } ],
+};
+
+my @expect = split "\n", <<'EOEXPECT';
+$foo
+$foo->{"bar"}
+$foo->{"skald"}
+${$foo->{"skald"}}
+${$foo->{"skald"}}->[0]
+EOEXPECT
+
+my $tracker = RefTracker->new({ root_name => '$foo' });
+
+$tracker->visit($foo);
+
+delete $foo->{bar}{baz};
+
+my $result = $tracker->traced_ref_map;
+
+is_deeply(
+  \@expect,
+  [ sort { length($a) <=> length($b) } values %$result ],
+  "Expected results present"
+);
+
+my %map = reverse %$result;
+
+foreach my $e (@expect) {
+  my $value = do {
+    local $@;
+    my $r = eval $e;
+    die "Error $@ evaluating $e" if $@;
+    $r;
+  };
+  is($map{$e},refaddr($value), "Result for ${e} ok");
+}
+
+my $flimflam = {
+  one => { two => three },
+  bard => $foo->{skald},
+  bard_guts => ${$foo->{skald}},
+  empty_now => $foo->{bar},
+};
+
+weaken($flimflam->{weak_one} = $flimflam->{one});
+weaken($flimflam->{weak_member}[0] = $flimflam->{bard});
+weaken(${$flimflam->{weak_scalar}} = $flimflam->{bard_guts});
+
+#use Data::Dumper; $Data::Dumper::Indent = 1;
+
+#warn "Flimflam:\n".Dumper($flimflam);
+
+my $replacer = RefFilter->new({
+  external_mappings => $result,
+  root_name => '$final',
+});
+
+my $copyflam = $replacer->visit($flimflam);
+
+my $dump = Dump($copyflam);
+my $fixup = $replacer->fixup_code;
+
+#warn "Dump:\n".$dump;
+#warn "Fixup:\n".$fixup;
+
+my $final = Load($dump);
+
+#warn "Unfixed final:\n".Dumper($final);
+
+{
+  local $@;
+  eval $fixup;
+  die "fixup code died: $@" if $@;
+}
+
+#warn "Fixed final:\n".Dumper($final);
+
+is_deeply($flimflam, $final, 'Structures deeply the same after fixup');
+
+ok(isweak($final->{weak_one}), '$final->{weak_one} is a weak ref');
+ok(isweak($final->{weak_member}[0]), '$final->{weak_member}[0] is a weak ref');
+ok(isweak(${$final->{weak_scalar}}), '${$final->{weak_scalar}} is a weak ref');
diff --git a/tracer.pl b/tracer.pl
deleted file mode 100644
index e50ef28..0000000
--- a/tracer.pl
+++ /dev/null
@@ -1,324 +0,0 @@
-
-BEGIN {
-
-package 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(@_);
-};
-
-package Ref::Tracer;
-
-use Moose;
-use Scalar::Util qw(weaken refaddr);
-use namespace::clean -except => 'meta';
-
-extends 'Data::Visitor';
-
-with '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(@_) }
-
-package Ref::Replacer;
-
-# note: we actually handle weaken as well as external refs because I intend
-# to use Data::Dumper  as a first pass and YAML::XS as a second and neither
-# of them know how to deal with weak references
-#
-# better still, neither actually does the bloody cross refs properly - Dumper
-# emits them but the nature of the beast is that they don't eval back in
-# right, YAML::XS seems to make two aliases to one ref (Data::Alias-ish)
-# since when I weaken one both copies disappear on me. sigh.
-#
-# on the upside, we can use a really dumb dumper for the rest - JSON::XS
-# strikes me as an interesting possibility for speed reasons
-
-use Moose;
-use Scalar::Util qw(refaddr isweak);
-use namespace::clean -except => 'meta';
-
-extends 'Data::Visitor';
-
-# we need name tracking but have to apply the role at the end of the file
-# so that our around modifiers end up within the name tracking around
-# instead of outside - otherwise e.g. array value weakening goes wrong
-
-has 'external_mappings' => (is => 'ro', lazy => 1, default => sub { {} });
-has '_internal_mappings' => (is => 'ro', lazy => 1, default => sub { {} });
-has 'weaken_these' => (is => 'ro', lazy => 1, default => sub { {} });
-has 'map_these' => (is => 'ro', lazy => 1, default => sub { {} });
-
-around visit => sub {
-  my ($orig, $self) = (shift, shift);
-  my $value = $_[0];
-
-  # note that we can't localize this one since it needs to be global
-  # across the entire structure - we could consider a weakref based trick
-  # like we use in the recorder but I don't -think- there's any need
-
-  # if we've already seen this reference, register a mapping for this
-  # copy of it so we fix it up afterwards (see visit_ref for the same process
-  # being used for references to be supplied externally at deserialize time
-  # and the top of the class for notes on how much I love serializers)
-
-  if (ref($value) && (my $m = $self->_internal_mappings->{refaddr $value})) {
-    $self->map_these->{$self->_current_trace_name} = $m;
-    return undef;
-  }
-
-  return $self->$orig(@_);
-};
-
-around visit_ref => sub {
-  my ($orig, $self) = (shift, shift);
-  my $value = $_[0];
-
-  # if we've got a mapping for a reference (i.e. it's supplied from
-  # somewhere else) then we need to record where we are and then
-  # return undef for the fmap process so we serialize an undefined
-  # value and the fixup puts the external reference back in later
-
-  if (my $m = $self->external_mappings->{refaddr $value}) {
-    $self->map_these->{$self->_current_trace_name} = $m;
-    return undef;
-  }
-
-  $self->_internal_mappings->{refaddr $value} = $self->_current_trace_name;
-
-  return $self->$orig(@_);
-};
-
-around visit_hash_value => sub {
-  my ($orig, $self) = (shift, shift);
-  my ($value, $key, $hash) = @_;
-  if (isweak $hash->{$key}) {
-    $self->weaken_these->{$self->_current_trace_name} = 1;
-  }
-  return $self->$orig(@_);
-};
-
-around visit_array_entry => sub {
-  my ($orig, $self) = (shift, shift);
-  my ($value, $index, $array) = @_;
-  if (isweak $array->[$index]) {
-    $self->weaken_these->{$self->_current_trace_name} = 1;
-  }
-  return $self->$orig(@_);
-};
-
-around visit_scalar => sub {
-  my ($orig, $self) = (shift, shift);
-  my $scalar = $_[0];
-  if (isweak $$scalar) {
-    $self->weaken_these->{$self->_current_trace_name} = 1;
-  }
-  return $self->$orig(@_);
-};
-
-# now it's safe to apply the role
-
-with 'Visitor::NameTracking';
-
-sub fixup_code {
-  my $self = shift;
-  join("\n\n",
-    grep defined,
-      map $self->${\"_fixup_code_for_$_"},
-        qw(externals weakrefs)
-  );
-}
-
-sub _fixup_code_for_externals {
-  my $self = shift;
-  my $ext = $self->map_these;
-  return unless keys %$ext;
-  join("\n",
-    qq{# fixup code for external references},
-    map {
-      my ($l, $r) = ($_, $ext->{$_});
-      # if the LHS is a scalarref deref then we actually
-      # need to strip that bit off and push the enref to the RHS since
-      # ${\undef} = "foo"
-      # is an attempt to modify a readonly value and perl will burst into tears
-      if ($l =~ m/^\${(.*)}$/) { $l = $1; $r = "\\".$r; }
-      $l.' = '.$r.';';
-    }
-    sort keys %$ext
-  );
-}
-
-sub _fixup_code_for_weakrefs {
-  my $self = shift;
-  my $weaken = $self->weaken_these;
-  return unless keys %$weaken;
-  join("\n",
-    qq{# fixup code for weak references},
-    'use Scalar::Util ();',
-    map {
-      'Scalar::Util::weaken('.$_.');';
-    }
-    sort keys %$weaken
-  );
-}
-
-# force recursion into objects (Data::Visitor doesn't by default)
-
-sub visit_object { shift->visit_ref(@_) }
-
-}
-
-use Test::More qw(no_plan);
-use Scalar::Util qw(refaddr weaken isweak);
-use YAML::XS;
-
-my $foo = {
-  bar => { baz => [ 'quux', { fleem => 1 } ] },
-  skald => \[ { hot => 'story' } ],
-};
-
-my @expect = split "\n", <<'EOEXPECT';
-$foo
-$foo->{"bar"}
-$foo->{"skald"}
-${$foo->{"skald"}}
-${$foo->{"skald"}}->[0]
-EOEXPECT
-
-my $tracer = Ref::Tracer->new({ root_name => '$foo' });
-
-$tracer->visit($foo);
-
-delete $foo->{bar}{baz};
-
-my $result = $tracer->traced_ref_map;
-
-is_deeply(
-  \@expect,
-  [ sort { length($a) <=> length($b) } values %$result ],
-  "Expected results present"
-);
-
-my %map = reverse %$result;
-
-foreach my $e (@expect) {
-  my $value = do {
-    local $@;
-    my $r = eval $e;
-    die "Error $@ evaluating $e" if $@;
-    $r;
-  };
-  is($map{$e},refaddr($value), "Result for ${e} ok");
-}
-
-my $flimflam = {
-  one => { two => three },
-  bard => $foo->{skald},
-  bard_guts => ${$foo->{skald}},
-  empty_now => $foo->{bar},
-};
-
-weaken($flimflam->{weak_one} = $flimflam->{one});
-weaken($flimflam->{weak_member}[0] = $flimflam->{bard});
-weaken(${$flimflam->{weak_scalar}} = $flimflam->{bard_guts});
-
-#use Data::Dumper; $Data::Dumper::Indent = 1;
-
-#warn "Flimflam:\n".Dumper($flimflam);
-
-my $replacer = Ref::Replacer->new({
-  external_mappings => $result,
-  root_name => '$final',
-});
-
-my $copyflam = $replacer->visit($flimflam);
-
-my $dump = Dump($copyflam);
-my $fixup = $replacer->fixup_code;
-
-#warn "Dump:\n".$dump;
-#warn "Fixup:\n".$fixup;
-
-my $final = Load($dump);
-
-#warn "Unfixed final:\n".Dumper($final);
-
-{
-  local $@;
-  eval $fixup;
-  die "fixup code died: $@" if $@;
-}
-
-#warn "Fixed final:\n".Dumper($final);
-
-is_deeply($flimflam, $final, 'Structures deeply the same after fixup');
-
-ok(isweak($final->{weak_one}), '$final->{weak_one} is a weak ref');
-ok(isweak($final->{weak_member}[0]), '$final->{weak_member}[0] is a weak ref');
-ok(isweak(${$final->{weak_scalar}}), '${$final->{weak_scalar}} is a weak ref');