expand comment

[gitmo/MooseX-Antlers.git] / lib / MooseX / Antlers / RefFilter.pm

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
      # $whatever = \"foo"
      # is ok so if the match succeeds switch it to that
      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;