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