t/one.t

   1 use strict;
   2 use warnings FATAL => 'all';
   3 use aliased 'MooseX::Antlers::EvalTracker';
   4 use aliased 'MooseX::Antlers::RefTracker';
   5 use aliased 'MooseX::Antlers::RefFilter';
   6 use B qw(perlstring);
   7 use lib 't/lib';
   8 use Test::More;
   9 use Test::Exception;
  10 use Class::Unload;
  11 use String::TT qw(tt strip);
  12 use IO::All qw(io);
  13
  14 my %attr_refs;
  15 my %attr_et;
  16 my $im_et;
  17
  18 {
  19   require Moose;
  20   my $orig_import = Moose->can('import');
  21   no warnings 'redefine';
  22   local *Moose::import = sub {
  23     my $targ = caller;
  24     Moose->$orig_import({ into => $targ });
  25     my $has = $targ->can('has');
  26     {
  27       no strict 'refs';
  28       *{"${targ}::has"} = sub {
  29         $attr_refs{$_[0]} = [
  30           map RefTracker->trace_refs( $_ => \@_ ),
  31             '(\@_)', '$has_args{'.perlstring($_[0]).'}'
  32         ];
  33         my $et = EvalTracker->new->enable;
  34         $has->(@_);
  35         $attr_et{$_[0]} = $et->disable;
  36         return;
  37       };
  38     }
  39   };
  40   my $orig_immutable = Moose::Meta::Class->can('make_immutable');
  41   local *Moose::Meta::Class::make_immutable = sub {
  42     my $et = EvalTracker->new->enable;
  43     $orig_immutable->(@_);
  44     $im_et = $et->disable;
  45     return;
  46   };
  47   require One;
  48 }
  49
  50 sub foo_called {
  51   &cmp_ok(One->get_called_foo, '==', @_); # cmp_ok has a $$$;$ proto
  52 }
  53
  54 sub test_One {
  55
  56   ok(One->can('foo'), 'foo accessor installed');
  57
  58   dies_ok { One->new } 'foo is required';
  59
  60   foo_called(0 => 'trigger not called yet');
  61
  62   my $one = One->new(foo => 1);
  63
  64   foo_called(1 => 'trigger called once (constructor)');
  65
  66   cmp_ok($one->foo, '==', 1, 'read ok');
  67
  68   foo_called(1 => 'trigger not called for read');
  69
  70   $one->foo(2);
  71
  72   foo_called(2 => 'trigger called for setter');
  73 }
  74
  75 my %orig_src = map +($_ => join '', Dump(One->can($_))), qw(new DESTROY one);
  76
  77 my $orig_foo_meta = Dump(One->meta);
  78
  79 test_One();
  80
  81 use Data::Dump::Streamer;
  82
  83 my $one_source_code = io($INC{'One.pm'})->all;
  84
  85 #warn $attr_et{'foo'}->serialized_construction($attr_refs{'foo'});
  86
  87 #my @has = (
  88
  89 my $foo_build = $attr_et{'foo'}->serialized_construction($attr_refs{'foo'}[0]);
  90
  91 my $im_build = $im_et->serialized_construction($attr_refs{'foo'}[1]);
  92
  93 my $preamble = strip tt q{
  94   my %replay_has;
  95   my %has_args;
  96   BEGIN {
  97     %replay_has = (
  98       foo => sub {
  99         [% foo_build %]
 100       }
 101     );
 102   }
 103   sub MooseX::Antlers::ImmutableHackFor::Foo::make_immutable {
 104 [% im_build %]
 105   }
 106   use MooseX::Antlers::StealImport
 107     Moose => {
 108       -do => sub {
 109         strict->import;
 110         warnings->import;
 111       },
 112       has => sub {
 113         $has_args{$_[0]} = \@_;
 114         ($replay_has{$_[0]}||die "Can't find replay for $_[0]")
 115           ->(@_);
 116       },
 117       meta => sub { 'MooseX::Antlers::ImmutableHackFor::Foo' }
 118     };
 119 };
 120
 121 my $postamble = strip q{
 122   no MooseX::Antlers::StealImport qw(Moose);
 123 };
 124
 125 my $compiled = join("\n", $preamble, $one_source_code, $postamble);
 126
 127 #warn $compiled; done_testing; exit 0;
 128
 129 Class::Unload->unload('One');
 130 Class::MOP::remove_metaclass_by_name('One');
 131
 132 eval $compiled; die "Shit. failed.\n\n${compiled}\n\nError: $@" if $@;
 133
 134 use Data::Dumper::Concise;
 135
 136 my %compiled_src = map +($_ => join '', Dump(One->can($_))), qw(new DESTROY one);
 137
 138 #foreach my $method (qw(new DESTROY one)) {
 139 #  is($compiled_src{$method}, $orig_src{$method}, "${method} restored ok");
 140 #}
 141
 142 test_One;
 143
 144 # write test_class method that checks method including call
 145 # Class::Unload One
 146 # build compiled source
 147 # eval compiled source
 148 # run test_class after that as well as before unload
 149
 150 #warn Dumper \%attr_refs;
 151 #warn Dumper \%attr_et;
 152 #warn Dumper $im_et;
 153
 154 done_testing;