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 # better still, neither actually does the bloody cross refs properly - Dumper
  96 # emits them but the nature of the beast is that they don't eval back in
  97 # right, YAML::XS seems to make two aliases to one ref (Data::Alias-ish)
  98 # since when I weaken one both copies disappear on me. sigh.
  99 #
 100 # on the upside, we can use a really dumb dumper for the rest - JSON::XS
 101 # strikes me as an interesting possibility for speed reasons
 102
 103 use Moose;
 104 use Scalar::Util qw(refaddr isweak);
 105 use namespace::clean -except => 'meta';
 106
 107 extends 'Data::Visitor';
 108
 109 # we need name tracking but have to apply the role at the end of the file
 110 # so that our around modifiers end up within the name tracking around
 111 # instead of outside - otherwise e.g. array value weakening goes wrong
 112
 113 has 'external_mappings' => (is => 'ro', lazy => 1, default => sub { {} });
 114 has '_internal_mappings' => (is => 'ro', lazy => 1, default => sub { {} });
 115 has 'weaken_these' => (is => 'ro', lazy => 1, default => sub { {} });
 116 has 'map_these' => (is => 'ro', lazy => 1, default => sub { {} });
 117
 118 around visit => sub {
 119   my ($orig, $self) = (shift, shift);
 120   my $value = $_[0];
 121
 122   # note that we can't localize this one since it needs to be global
 123   # across the entire structure - we could consider a weakref based trick
 124   # like we use in the recorder but I don't -think- there's any need
 125
 126   # if we've already seen this reference, register a mapping for this
 127   # copy of it so we fix it up afterwards (see visit_ref for the same process
 128   # being used for references to be supplied externally at deserialize time
 129   # and the top of the class for notes on how much I love serializers)
 130
 131   if (ref($value) && (my $m = $self->_internal_mappings->{refaddr $value})) {
 132     $self->map_these->{$self->_current_trace_name} = $m;
 133     return undef;
 134   }
 135
 136   return $self->$orig(@_);
 137 };
 138
 139 around visit_ref => sub {
 140   my ($orig, $self) = (shift, shift);
 141   my $value = $_[0];
 142
 143   # if we've got a mapping for a reference (i.e. it's supplied from
 144   # somewhere else) then we need to record where we are and then
 145   # return undef for the fmap process so we serialize an undefined
 146   # value and the fixup puts the external reference back in later
 147
 148   if (my $m = $self->external_mappings->{refaddr $value}) {
 149     $self->map_these->{$self->_current_trace_name} = $m;
 150     return undef;
 151   }
 152
 153   $self->_internal_mappings->{refaddr $value} = $self->_current_trace_name;
 154
 155   return $self->$orig(@_);
 156 };
 157
 158 around visit_hash_value => sub {
 159   my ($orig, $self) = (shift, shift);
 160   my ($value, $key, $hash) = @_;
 161   if (isweak $hash->{$key}) {
 162     $self->weaken_these->{$self->_current_trace_name} = 1;
 163   }
 164   return $self->$orig(@_);
 165 };
 166
 167 around visit_array_entry => sub {
 168   my ($orig, $self) = (shift, shift);
 169   my ($value, $index, $array) = @_;
 170   if (isweak $array->[$index]) {
 171     $self->weaken_these->{$self->_current_trace_name} = 1;
 172   }
 173   return $self->$orig(@_);
 174 };
 175
 176 around visit_scalar => sub {
 177   my ($orig, $self) = (shift, shift);
 178   my $scalar = $_[0];
 179   if (isweak $$scalar) {
 180     $self->weaken_these->{$self->_current_trace_name} = 1;
 181   }
 182   return $self->$orig(@_);
 183 };
 184
 185 # now it's safe to apply the role
 186
 187 with 'Visitor::NameTracking';
 188
 189 sub fixup_code {
 190   my $self = shift;
 191   join("\n\n",
 192     grep defined,
 193       map $self->${\"_fixup_code_for_$_"},
 194         qw(externals weakrefs)
 195   );
 196 }
 197
 198 sub _fixup_code_for_externals {
 199   my $self = shift;
 200   my $ext = $self->map_these;
 201   return unless keys %$ext;
 202   join("\n",
 203     qq{# fixup code for external references},
 204     map {
 205       my ($l, $r) = ($_, $ext->{$_});
 206       # if the LHS is a scalarref deref then we actually
 207       # need to strip that bit off and push the enref to the RHS since
 208       # ${\undef} = "foo"
 209       # is an attempt to modify a readonly value and perl will burst into tears
 210       if ($l =~ m/^\${(.*)}$/) { $l = $1; $r = "\\".$r; }
 211       $l.' = '.$r.';';
 212     }
 213     sort keys %$ext
 214   );
 215 }
 216
 217 sub _fixup_code_for_weakrefs {
 218   my $self = shift;
 219   my $weaken = $self->weaken_these;
 220   return unless keys %$weaken;
 221   join("\n",
 222     qq{# fixup code for weak references},
 223     'use Scalar::Util ();',
 224     map {
 225       'Scalar::Util::weaken('.$_.');';
 226     }
 227     sort keys %$weaken
 228   );
 229 }
 230
 231 # force recursion into objects (Data::Visitor doesn't by default)
 232
 233 sub visit_object { shift->visit_ref(@_) }
 234
 235 }
 236
 237 use Test::More qw(no_plan);
 238 use Scalar::Util qw(refaddr weaken isweak);
 239 use YAML::XS;
 240
 241 my $foo = {
 242   bar => { baz => [ 'quux', { fleem => 1 } ] },
 243   skald => \[ { hot => 'story' } ],
 244 };
 245
 246 my @expect = split "\n", <<'EOEXPECT';
 247 $foo
 248 $foo->{"bar"}
 249 $foo->{"skald"}
 250 ${$foo->{"skald"}}
 251 ${$foo->{"skald"}}->[0]
 252 EOEXPECT
 253
 254 my $tracer = Ref::Tracer->new({ root_name => '$foo' });
 255
 256 $tracer->visit($foo);
 257
 258 delete $foo->{bar}{baz};
 259
 260 my $result = $tracer->traced_ref_map;
 261
 262 is_deeply(
 263   \@expect,
 264   [ sort { length($a) <=> length($b) } values %$result ],
 265   "Expected results present"
 266 );
 267
 268 my %map = reverse %$result;
 269
 270 foreach my $e (@expect) {
 271   my $value = do {
 272     local $@;
 273     my $r = eval $e;
 274     die "Error $@ evaluating $e" if $@;
 275     $r;
 276   };
 277   is($map{$e},refaddr($value), "Result for ${e} ok");
 278 }
 279
 280 my $flimflam = {
 281   one => { two => three },
 282   bard => $foo->{skald},
 283   bard_guts => ${$foo->{skald}},
 284   empty_now => $foo->{bar},
 285 };
 286
 287 weaken($flimflam->{weak_one} = $flimflam->{one});
 288 weaken($flimflam->{weak_member}[0] = $flimflam->{bard});
 289 weaken(${$flimflam->{weak_scalar}} = $flimflam->{bard_guts});
 290
 291 #use Data::Dumper; $Data::Dumper::Indent = 1;
 292
 293 #warn "Flimflam:\n".Dumper($flimflam);
 294
 295 my $replacer = Ref::Replacer->new({
 296   external_mappings => $result,
 297   root_name => '$final',
 298 });
 299
 300 my $copyflam = $replacer->visit($flimflam);
 301
 302 my $dump = Dump($copyflam);
 303 my $fixup = $replacer->fixup_code;
 304
 305 #warn "Dump:\n".$dump;
 306 #warn "Fixup:\n".$fixup;
 307
 308 my $final = Load($dump);
 309
 310 #warn "Unfixed final:\n".Dumper($final);
 311
 312 {
 313   local $@;
 314   eval $fixup;
 315   die "fixup code died: $@" if $@;
 316 }
 317
 318 #warn "Fixed final:\n".Dumper($final);
 319
 320 is_deeply($flimflam, $final, 'Structures deeply the same after fixup');
 321
 322 ok(isweak($final->{weak_one}), '$final->{weak_one} is a weak ref');
 323 ok(isweak($final->{weak_member}[0]), '$final->{weak_member}[0] is a weak ref');
 324 ok(isweak(${$final->{weak_scalar}}), '${$final->{weak_scalar}} is a weak ref');