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

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;