Commit | Line | Data |
a39b801f |
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; |
064721e6 |
9 | use Test::Exception; |
10 | use Class::Unload; |
11 | use String::TT qw(tt strip); |
12 | use IO::All qw(io); |
a39b801f |
13 | |
14 | my %attr_refs; |
064721e6 |
15 | my %attr_et; |
16 | my $im_et; |
a39b801f |
17 | |
18 | { |
19 | require Moose; |
064721e6 |
20 | my $orig_import = Moose->can('import'); |
a39b801f |
21 | no warnings 'redefine'; |
22 | local *Moose::import = sub { |
23 | my $targ = caller; |
064721e6 |
24 | Moose->$orig_import({ into => $targ }); |
a39b801f |
25 | my $has = $targ->can('has'); |
26 | { |
27 | no strict 'refs'; |
28 | *{"${targ}::has"} = sub { |
064721e6 |
29 | $attr_refs{$_[0]} = [ |
30 | map RefTracker->trace_refs( $_ => \@_ ), |
31 | '(\@_)', '$has_args{'.perlstring($_[0]).'}' |
32 | ]; |
a39b801f |
33 | my $et = EvalTracker->new->enable; |
34 | $has->(@_); |
064721e6 |
35 | $attr_et{$_[0]} = $et->disable; |
36 | return; |
a39b801f |
37 | }; |
38 | } |
39 | }; |
064721e6 |
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 | }; |
a39b801f |
47 | require One; |
48 | } |
49 | |
064721e6 |
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(); |
a39b801f |
80 | |
81 | use Data::Dump::Streamer; |
82 | |
064721e6 |
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; |
a39b801f |
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 | |
a39b801f |
150 | #warn Dumper \%attr_refs; |
064721e6 |
151 | #warn Dumper \%attr_et; |
152 | #warn Dumper $im_et; |
a39b801f |
153 | |
154 | done_testing; |