t/track_eval.t

   1 use strict;
   2 use warnings;
   3 use aliased 'MooseX::Antlers::EvalTracker';
   4 use aliased 'MooseX::Antlers::RefTracker';
   5 use aliased 'MooseX::Antlers::RefFilter';
   6 use Moose ();
   7 use B qw(perlstring);
   8 use Scalar::Util qw(refaddr);
   9
  10 my @trap;
  11
  12 {
  13   my $orig = Moose::Meta::Class->can('add_attribute');
  14   no warnings 'redefine';
  15   *Moose::Meta::Class::add_attribute = sub {
  16     my ($self, $name) = @_;
  17     my $root_name =
  18       '$add_attribute{'.perlstring($self->name).'}'
  19                    .'{'.perlstring($name).'}';
  20     my $tracker = RefTracker->new({ root_name => $root_name });
  21     $tracker->visit(\@_);
  22     my $refs = $tracker->traced_ref_map;
  23     push(@trap, [ $root_name, $name, $refs ]);
  24     return $orig->(@_);
  25   };
  26 }
  27
  28 my $et = EvalTracker->new;
  29
  30 $et->enable;
  31
  32 {
  33   package Foo;
  34
  35   use Moose;
  36
  37   has 'test' => (is => 'rw', trigger => sub { warn "trigger!\n" });
  38 }
  39
  40 use Data::Dumper; $Data::Dumper::Indent = 1;
  41
  42 my $attr_root = '$meta->{attributes}{'.perlstring($trap[0][1]).'}';
  43
  44 my $filter_attr = RefFilter->new({
  45   external_mappings => $trap[0][2],
  46   root_name => $attr_root,
  47 });
  48
  49 $trap[0][2]{refaddr(Foo->meta)} = '$meta';
  50 my $cr = $et->recorded_coderefs->[0][0];
  51 $trap[0][2]{refaddr($cr)} = '$coderefs[0]';
  52
  53 my $attr_object = Foo->meta->{attributes}{$trap[0][1]};
  54
  55 my $record = $filter_attr->visit($attr_object);
  56
  57 my $tracker = RefTracker->new({
  58   root_name => $attr_root,
  59 });
  60
  61 $tracker->visit($record);
  62
  63 my $filter_captures = RefFilter->new({
  64   external_mappings => {
  65     %{$tracker->traced_ref_map}, %{$trap[0][2]},
  66     refaddr($attr_object) => $attr_root,
  67   },
  68   root_name => '$captures',
  69 });
  70
  71 my $captures_record = $filter_captures->visit($et->recorded_coderefs->[0][1]);
  72
  73 warn Data::Dumper->Dump([$record],[$attr_root]);
  74
  75 warn 'my '.Data::Dumper->Dump([$captures_record],['$captures']);
  76
  77 warn $filter_captures->fixup_code;
  78
  79 warn 'my @coderefs = ('."\n".$et->_generate_coderef_constructor($et->recorded_coderefs->[0])."->(\$captures)\n);\n";
  80
  81 warn $filter_attr->fixup_code;
  82
  83 #warn %{$trap[0]};