beneficent winds and enmarvelorated satiation, success is come

[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
#
# 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 '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(@_) }

}

use Test::More qw(no_plan);
use Scalar::Util qw(refaddr weaken isweak);
use YAML::XS;

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

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

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

is_deeply($flimflam, $final, 'Structures deeply the same after fixup');

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