lewd warnication brings proof positive of lost weakness. ceci n'est pas un haiku

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

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
#
# 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

use Moose;
# ensure we have next::method available - just because Moose loads it
# as a side effect doesn't mean it's clever to rely on that
use MRO::Compat ();
use Scalar::Util qw(refaddr isweak);
use namespace::clean -except => 'meta';

extends 'Data::Visitor';

with 'Visitor::NameTracking';

has 'external_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 { {} });

# fairly sure an around modifier will get severely fucked up here
# in that the copying of @_ will lose the weakness we need to check

sub visit_ref {
  my $self = shift;

  # have to test $_[0] directly since copying a weak ref gives a strong ref

warn $self->_current_trace_name;
warn $_[0];
  if (isweak $_[0]) {
warn "got here";
    $self->weaken_these->{$self->_current_trace_name} = 1;
  }

  # 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 $_[0]}) {
    $self->map_these->{$self->_current_trace_name} = $m;
    return undef;
  }

  return $self->next::method(@_);
}

sub _register_mapping { $_[2] }

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 {
      $_.' = '.$ext->{$_}.';';
    }
    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);

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});

my $replacer = Ref::Replacer->new({
  external_mappings => $result,
  root_name => '$final',
});

my $copyflam = $replacer->visit($flimflam);

use Data::Dumper; $Data::Dumper::Indent = 1;

warn Dumper($copyflam);

warn $replacer->fixup_code;