tracer.pl

   1
   2 BEGIN {
   3
   4 package Visitor::NameTracking;
   5
   6 use Moose::Role;
   7 use B qw(perlstring);
   8 use namespace::clean -except => 'meta';
   9
  10 has '_current_trace_name' => (is => 'ro');
  11 has 'root_name' => (is => 'ro');
  12
  13 around visit => sub {
  14   my ($orig, $self) = (shift, shift);
  15   local $self->{_current_trace_name}
  16     = ($self->{_current_trace_name}||$self->root_name);
  17   return $self->$orig(@_);
  18 };
  19
  20 around visit_hash_entry => sub {
  21   my ($orig, $self) = (shift, shift);
  22   my $key = $_[0]; # $key, $value
  23   local $self->{_current_trace_name}
  24     = $self->{_current_trace_name}.'->{'.(perlstring $key).'}';
  25   return $self->$orig(@_);
  26 };
  27
  28 around visit_array_entry => sub {
  29   my ($orig, $self) = (shift, shift);
  30   my $index = $_[1]; # $value, $index
  31   local $self->{_current_trace_name}
  32     = $self->{_current_trace_name}.'->['.$index.']';
  33   return $self->$orig(@_);
  34 };
  35
  36 around visit_scalar => sub {
  37   my ($orig, $self) = (shift, shift);
  38   local $self->{_current_trace_name} = '${'.$self->{_current_trace_name}.'}';
  39   return $self->$orig(@_);
  40 };
  41
  42 package Ref::Tracer;
  43
  44 use Moose;
  45 use Scalar::Util qw(weaken refaddr);
  46 use namespace::clean -except => 'meta';
  47
  48 extends 'Data::Visitor';
  49
  50 with 'Visitor::NameTracking';
  51
  52 # dump the lazy when we get a sensible version of D::V on the dev system
  53
  54 has '_traced_refs' => (is => 'ro', lazy => 1, default => sub { {} });
  55 has '_traced_names' => (is => 'ro', lazy => 1, default => sub { {} });
  56
  57 before visit_ref => sub {
  58   my ($self, $data) = @_;
  59
  60   # can't just rely on refaddr because it may get re-used if the data goes
  61   # out of scope (we could play clever games with free magic on the wizard
  62   # or whatever but KISS) - but we -can- keep a weak reference which will
  63   # turn to undef if the variable disappears
  64
  65   weaken($self->_traced_refs->{refaddr $data} = $data);
  66
  67   $self->_traced_names->{refaddr $data} = $self->_current_trace_name;
  68 };
  69
  70 sub traced_ref_map {
  71   my $self = shift;
  72   my $refs = $self->_traced_refs;
  73   my $names = $self->_traced_names;
  74
  75   # nuke keys where the traced refs entry is undef since they indicate
  76   # "went out of scope" so the name is no longer valid. however if we
  77   # do still have a refs entry we know the name is valid because if it
  78   # didn't go out of scope that refaddr can't have been re-used.
  79   # (NB: I don't care if this works under ithreads)
  80
  81   delete @{$names}{grep !defined($refs->{$_}), keys %$names};
  82   $names;
  83 }
  84
  85 # force recursion into objects (Data::Visitor doesn't by default)
  86
  87 sub visit_object { shift->visit_ref(@_) }
  88
  89 package Ref::Replacer;
  90
  91 # note: we actually handle weaken as well as external refs because I intend
  92 # to use Data::Dumper  as a first pass and YAML::XS as a second and neither
  93 # of them know how to deal with weak references
  94 #
  95 # I'm faintly curious to see if manual cross-ref-ification nad JSON::XS will
  96 # actually be faster for reconstructing structures but it's fairly academic
  97 # as yet
  98
  99 use Moose;
 100 # ensure we have next::method available - just because Moose loads it
 101 # as a side effect doesn't mean it's clever to rely on that
 102 use MRO::Compat ();
 103 use Scalar::Util qw(refaddr isweak);
 104 use namespace::clean -except => 'meta';
 105
 106 extends 'Data::Visitor';
 107
 108 with 'Visitor::NameTracking';
 109
 110 has 'external_mappings' => (is => 'ro', lazy => 1, default => sub { {} });
 111 has 'weaken_these' => (is => 'ro', lazy => 1, default => sub { {} });
 112 has 'map_these' => (is => 'ro', lazy => 1, default => sub { {} });
 113
 114 # fairly sure an around modifier will get severely fucked up here
 115 # in that the copying of @_ will lose the weakness we need to check
 116
 117 sub visit_ref {
 118   my $self = shift;
 119
 120   # have to test $_[0] directly since copying a weak ref gives a strong ref
 121
 122 warn $self->_current_trace_name;
 123 warn $_[0];
 124   if (isweak $_[0]) {
 125 warn "got here";
 126     $self->weaken_these->{$self->_current_trace_name} = 1;
 127   }
 128
 129   # if we've got a mapping for a reference (i.e. it's supplied from
 130   # somewhere else) then we need to record where we are and then
 131   # return undef for the fmap process so we serialize an undefined
 132   # value and the fixup puts the external reference back in later
 133
 134   if (my $m = $self->external_mappings->{refaddr $_[0]}) {
 135     $self->map_these->{$self->_current_trace_name} = $m;
 136     return undef;
 137   }
 138
 139   return $self->next::method(@_);
 140 }
 141
 142 sub _register_mapping { $_[2] }
 143
 144 sub fixup_code {
 145   my $self = shift;
 146   join("\n\n",
 147     grep defined,
 148       map $self->${\"_fixup_code_for_$_"},
 149         qw(externals weakrefs)
 150   );
 151 }
 152
 153 sub _fixup_code_for_externals {
 154   my $self = shift;
 155   my $ext = $self->map_these;
 156   return unless keys %$ext;
 157   join("\n",
 158     qq{# fixup code for external references},
 159     map {
 160       $_.' = '.$ext->{$_}.';';
 161     }
 162     sort keys %$ext
 163   );
 164 }
 165
 166 sub _fixup_code_for_weakrefs {
 167   my $self = shift;
 168   my $weaken = $self->weaken_these;
 169   return unless keys %$weaken;
 170   join("\n",
 171     qq{# fixup code for weak references},
 172     'use Scalar::Util ();',
 173     map {
 174       'Scalar::Util::weaken('.$_.');';
 175     }
 176     sort keys %$weaken
 177   );
 178 }
 179
 180 # force recursion into objects (Data::Visitor doesn't by default)
 181
 182 sub visit_object { shift->visit_ref(@_) }
 183
 184 }
 185
 186 use Test::More qw(no_plan);
 187 use Scalar::Util qw(refaddr weaken);
 188
 189 my $foo = {
 190   bar => { baz => [ 'quux', { fleem => 1 } ] },
 191   skald => \[ { hot => 'story' } ],
 192 };
 193
 194 my @expect = split "\n", <<'EOEXPECT';
 195 $foo
 196 $foo->{"bar"}
 197 $foo->{"skald"}
 198 ${$foo->{"skald"}}
 199 ${$foo->{"skald"}}->[0]
 200 EOEXPECT
 201
 202 my $tracer = Ref::Tracer->new({ root_name => '$foo' });
 203
 204 $tracer->visit($foo);
 205
 206 delete $foo->{bar}{baz};
 207
 208 my $result = $tracer->traced_ref_map;
 209
 210 is_deeply(
 211   \@expect,
 212   [ sort { length($a) <=> length($b) } values %$result ],
 213   "Expected results present"
 214 );
 215
 216 my %map = reverse %$result;
 217
 218 foreach my $e (@expect) {
 219   my $value = do {
 220     local $@;
 221     my $r = eval $e;
 222     die "Error $@ evaluating $e" if $@;
 223     $r;
 224   };
 225   is($map{$e},refaddr($value), "Result for ${e} ok");
 226 }
 227
 228 my $flimflam = {
 229   one => { two => three },
 230   bard => $foo->{skald},
 231   bard_guts => ${$foo->{skald}},
 232   empty_now => $foo->{bar},
 233 };
 234
 235 weaken($flimflam->{weak_one} = $flimflam->{one});
 236
 237 my $replacer = Ref::Replacer->new({
 238   external_mappings => $result,
 239   root_name => '$final',
 240 });
 241
 242 my $copyflam = $replacer->visit($flimflam);
 243
 244 use Data::Dumper; $Data::Dumper::Indent = 1;
 245
 246 warn Dumper($copyflam);
 247
 248 warn $replacer->fixup_code;