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(One->get_called_foo, '==', @_); # cmp_ok has a $$$;$ proto
  20 }
  21
  22 sub test_One {
  23
  24   ok(One->can('foo'), 'foo accessor installed');
  25
  26   dies_ok { One->new } 'foo is required';
  27
  28   foo_called(0 => 'trigger not called yet');
  29
  30   my $one = One->new(foo => 1);
  31
  32   foo_called(1 => 'trigger called once (constructor)');
  33
  34   cmp_ok($one->foo, '==', 1, 'read ok');
  35
  36   foo_called(1 => 'trigger not called for read');
  37
  38   $one->foo(2);
  39
  40   foo_called(2 => 'trigger called for setter');
  41 }
  42
  43 my $class = 'One';
  44 test_class($class, \&test_One);
  45
  46 sub test_class {
  47     my ($class, $test) = @_;
  48
  49     my $compiler = MooseX::Antlers::Compiler->load_with_compiler($class);
  50
  51     # FIXME - foo
  52     my %orig_src = map +($_ => join '', Dump($class->can($_))), qw(new DESTROY foo);
  53
  54     $class->meta->get_method_list; # fill cache
  55
  56     my $orig_meta = dump_meta $class->meta;
  57
  58     $test->($class);
  59
  60     my $compiled = $compiler->compiled_source;
  61
  62     #warn $compiled; done_testing; exit 0;
  63
  64     Class::Unload->unload($class);
  65     Class::MOP::remove_metaclass_by_name($class);
  66
  67     io("/tmp/$class.pmc")->print($compiled);
  68
  69     require "/tmp/$class.pmc";
  70
  71     #eval "no warnings; $compiled";
  72
  73     #die "Shit. failed.\n\n${compiled}\n\nError: $@" if $@;
  74
  75     my %compiled_src = map +($_ => join '', Dump($class->can($_))), qw(new DESTROY foo);
  76
  77     # FIXME - foo
  78     foreach my $method (qw(new DESTROY foo)) {
  79         is($compiled_src{$method}, $orig_src{$method}, "${method} restored ok");
  80     }
  81
  82     my $compiled_meta = dump_meta $class->meta;
  83
  84     $test->($class);
  85
  86     #io('orig')->print($orig_meta);
  87     #io('comp')->print($compiled_meta);
  88
  89     is($orig_meta, $compiled_meta, 'metaclass restored ok');
  90
  91     Class::Unload->unload($class);
  92     Class::MOP::remove_metaclass_by_name($class);
  93 }
  94
  95 done_testing;