lib/MooseX/Antlers/RefFilter.pm

   1 package MooseX::Antlers::RefFilter;
   2
   3 # note: we actually handle weaken as well as external refs because I intend
   4 # to use Data::Dumper  as a first pass and YAML::XS as a second and neither
   5 # of them know how to deal with weak references
   6 #
   7 # better still, neither actually does the bloody cross refs properly - Dumper
   8 # emits them but the nature of the beast is that they don't eval back in
   9 # right, YAML::XS seems to make two aliases to one ref (Data::Alias-ish)
  10 # since when I weaken one both copies disappear on me. sigh.
  11 #
  12 # on the upside, we can use a really dumb dumper for the rest - JSON::XS
  13 # strikes me as an interesting possibility for speed reasons
  14
  15 use Moose;
  16 use Scalar::Util qw(refaddr isweak);
  17 use namespace::clean -except => 'meta';
  18
  19 extends 'Data::Visitor';
  20
  21 # we need name tracking but have to apply the role at the end of the file
  22 # so that our around modifiers end up within the name tracking around
  23 # instead of outside - otherwise e.g. array value weakening goes wrong
  24
  25 has 'external_mappings' => (is => 'ro', lazy => 1, default => sub { {} });
  26 has '_internal_mappings' => (is => 'ro', lazy => 1, default => sub { {} });
  27 has 'weaken_these' => (is => 'ro', lazy => 1, default => sub { {} });
  28 has 'map_these' => (is => 'ro', lazy => 1, default => sub { {} });
  29
  30 around visit => sub {
  31   my ($orig, $self) = (shift, shift);
  32   my $value = $_[0];
  33
  34   # note that we can't localize this one since it needs to be global
  35   # across the entire structure - we could consider a weakref based trick
  36   # like we use in the recorder but I don't -think- there's any need
  37
  38   # if we've already seen this reference, register a mapping for this
  39   # copy of it so we fix it up afterwards (see visit_ref for the same process
  40   # being used for references to be supplied externally at deserialize time
  41   # and the top of the class for notes on how much I love serializers)
  42
  43   if (ref($value) && (my $m = $self->_internal_mappings->{refaddr $value})) {
  44     $self->map_these->{$self->_current_trace_name} = $m;
  45     return undef;
  46   }
  47
  48   return $self->$orig(@_);
  49 };
  50
  51 around visit_ref => sub {
  52   my ($orig, $self) = (shift, shift);
  53   my $value = $_[0];
  54
  55   # if we've got a mapping for a reference (i.e. it's supplied from
  56   # somewhere else) then we need to record where we are and then
  57   # return undef for the fmap process so we serialize an undefined
  58   # value and the fixup puts the external reference back in later
  59
  60   if (my $m = $self->external_mappings->{refaddr $value}) {
  61     $self->map_these->{$self->_current_trace_name} = $m;
  62     return undef;
  63   }
  64
  65   $self->_internal_mappings->{refaddr $value} = $self->_current_trace_name;
  66
  67   return $self->$orig(@_);
  68 };
  69
  70 around visit_hash_value => sub {
  71   my ($orig, $self) = (shift, shift);
  72   my ($value, $key, $hash) = @_;
  73   if (isweak $hash->{$key}) {
  74     $self->weaken_these->{$self->_current_trace_name} = 1;
  75   }
  76   return $self->$orig(@_);
  77 };
  78
  79 around visit_array_entry => sub {
  80   my ($orig, $self) = (shift, shift);
  81   my ($value, $index, $array) = @_;
  82   if (isweak $array->[$index]) {
  83     $self->weaken_these->{$self->_current_trace_name} = 1;
  84   }
  85   return $self->$orig(@_);
  86 };
  87
  88 around visit_scalar => sub {
  89   my ($orig, $self) = (shift, shift);
  90   my $scalar = $_[0];
  91   if (isweak $$scalar) {
  92     $self->weaken_these->{$self->_current_trace_name} = 1;
  93   }
  94   return $self->$orig(@_);
  95 };
  96
  97 # now it's safe to apply the role
  98
  99 with 'MooseX::Antlers::Visitor::NameTracking';
 100
 101 sub fixup_code {
 102   my $self = shift;
 103   join("\n\n",
 104     grep defined,
 105       map $self->${\"_fixup_code_for_$_"},
 106         qw(externals weakrefs)
 107   );
 108 }
 109
 110 sub _fixup_code_for_externals {
 111   my $self = shift;
 112   my $ext = $self->map_these;
 113   return unless keys %$ext;
 114   join("\n",
 115     qq{# fixup code for external references},
 116     map {
 117       my ($l, $r) = ($_, $ext->{$_});
 118       # if the LHS is a scalarref deref then we actually
 119       # need to strip that bit off and push the enref to the RHS since
 120       # ${\undef} = "foo"
 121       # is an attempt to modify a readonly value and perl will burst into tears
 122       # $whatever = \"foo"
 123       # is ok so if the match succeeds switch it to that
 124       if ($l =~ m/^\${(.*)}$/) { $l = $1; $r = "\\".$r; }
 125       $l.' = '.$r.';';
 126     }
 127     sort keys %$ext
 128   );
 129 }
 130
 131 sub _fixup_code_for_weakrefs {
 132   my $self = shift;
 133   my $weaken = $self->weaken_these;
 134   return unless keys %$weaken;
 135   join("\n",
 136     qq{# fixup code for weak references},
 137     'use Scalar::Util ();',
 138     map {
 139       'Scalar::Util::weaken('.$_.');';
 140     }
 141     sort keys %$weaken
 142   );
 143 }
 144
 145 # force recursion into objects (Data::Visitor doesn't by default)
 146
 147 sub visit_object { shift->visit_ref(@_) }
 148
 149 1;