t/one.t

   1 use strict;
   2 use warnings FATAL => 'all';
   3 use MooseX::Antlers::Compiler;
   4 use lib 't/lib';
   5 use Test::More;
   6 use Test::Exception;
   7 use Class::Unload;
   8 use IO::All;
   9 use Data::Dumper::Concise;
  10 use Data::Dump::Streamer;
  11
  12 sub dump_meta {
  13   my $meta = $_[0];
  14   local $meta->{methods}{meta};
  15   join '', Dump($meta);
  16 }
  17
  18 sub foo_called {
  19   &cmp_ok(shift->get_called_foo, '==', @_); # cmp_ok has a $$$;$ proto
  20 }
  21
  22 sub test_One {
  23   my $class = shift;
  24
  25   ok($class->can('foo'), $class . ' foo accessor installed');
  26
  27   dies_ok { $class->new } $class . ' foo is required';
  28
  29   foo_called($class, 0 => $class . ' trigger not called yet');
  30
  31   my $i = $class->new(foo => 1);
  32
  33   foo_called($class, 1 => $class . ' trigger called once (constructor)');
  34
  35   cmp_ok($i->foo, '==', 1, $class . ' read ok');
  36
  37   foo_called($class, 1 => $class . ' trigger not called for read');
  38
  39   $i->foo(2);
  40
  41   foo_called($class, 2 => $class . ' trigger called for setter');
  42 }
  43
  44 test_class('One', \&test_One);
  45 test_class('Two', \&test_One);
  46 test_class('Three', \&test_One);
  47
  48 sub test_class {
  49     my ($class, $test) = @_;
  50
  51     my $compiler = MooseX::Antlers::Compiler->load_with_compiler($class);
  52
  53     # FIXME - foo
  54     my %orig_src = map +($_ => join '', Dump($class->can($_))), qw(new DESTROY foo);
  55
  56     $class->meta->get_method_list; # fill cache
  57
  58     my $orig_meta = dump_meta $class->meta;
  59
  60     $test->($class);
  61
  62     my $compiled = $compiler->compiled_source;
  63
  64     #warn $compiled; done_testing; exit 0;
  65
  66     Class::Unload->unload($class);
  67     Class::MOP::remove_metaclass_by_name($class);
  68
  69     io("/tmp/$class.pmc")->print($compiled);
  70
  71     require "/tmp/$class.pmc";
  72
  73     #eval "no warnings; $compiled";
  74
  75     #die "Shit. failed.\n\n${compiled}\n\nError: $@" if $@;
  76
  77     my %compiled_src = map +($_ => join '', Dump($class->can($_))), qw(new DESTROY foo);
  78
  79     # FIXME - foo
  80     foreach my $method (qw(new DESTROY foo)) {
  81         is($compiled_src{$method}, $orig_src{$method}, "${method} restored ok");
  82     }
  83
  84     my $compiled_meta = dump_meta $class->meta;
  85
  86     $test->($class);
  87
  88     #io('orig')->print($orig_meta);
  89     #io('comp')->print($compiled_meta);
  90
  91     is($orig_meta, $compiled_meta, $class . ' metaclass restored ok');
  92
  93     Class::Unload->unload($class);
  94     Class::MOP::remove_metaclass_by_name($class);
  95 }
  96
  97 done_testing;