beneficent winds and enmarvelorated satiation, success is come

[gitmo/MooseX-Antlers.git] / tracer.pl

diff --git a/tracer.pl b/tracer.pl
index fbc08e5..e50ef28 100644 (file)
--- a/tracer.pl
+++ b/tracer.pl
@@ -92,9 +92,13 @@ package Ref::Replacer;
 # 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
 #
-# I'm faintly curious to see if manual cross-ref-ification nad JSON::XS will
-# actually be faster for reconstructing structures but it's fairly academic
-# as yet
+# 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);
@@ -107,9 +111,31 @@ extends 'Data::Visitor';
 # 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];
@@ -124,6 +150,8 @@ around visit_ref => sub {
     return undef;
   }
 
+  $self->_internal_mappings->{refaddr $value} = $self->_current_trace_name;
+
   return $self->$orig(@_);
 };
 
@@ -174,7 +202,13 @@ sub _fixup_code_for_externals {
   join("\n",
     qq{# fixup code for external references},
     map {
-      $_.' = '.$ext->{$_}.';';
+      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
   );
@@ -201,7 +235,8 @@ sub visit_object { shift->visit_ref(@_) }
 }
 
 use Test::More qw(no_plan);
-use Scalar::Util qw(refaddr weaken);
+use Scalar::Util qw(refaddr weaken isweak);
+use YAML::XS;
 
 my $foo = {
   bar => { baz => [ 'quux', { fleem => 1 } ] },
@@ -253,6 +288,10 @@ 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',
@@ -260,8 +299,26 @@ my $replacer = Ref::Replacer->new({
 
 my $copyflam = $replacer->visit($flimflam);
 
-use Data::Dumper; $Data::Dumper::Indent = 1;
+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);
 
-warn Dumper($copyflam);
+is_deeply($flimflam, $final, 'Structures deeply the same after fixup');
 
-warn $replacer->fixup_code;
+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');