File Coverage

blib/lib/Type/Library/Compiler/Mite.pm
Criterion Covered Total %
statement 93 175 53.1
branch 24 76 31.5
condition 2 13 15.3
subroutine 20 39 51.2
pod 0 6 0.0
total 139 309 44.9


line stmt bran cond sub pod time code
1 1     1   13 use 5.008001;
  1         3  
2 1     1   5 use strict;
  1         1  
  1         17  
3 1     1   4 use warnings;
  1         2  
  1         193  
4              
5             # NOTE: Since the intention is to ship this file with a project, this file
6             # cannot have any non-core dependencies.
7              
8             package Type::Library::Compiler::Mite;
9              
10             # Constants
11             sub true () { !!1 }
12             sub false () { !!0 }
13             sub ro () { 'ro' }
14             sub rw () { 'rw' }
15             sub rwp () { 'rwp' }
16             sub lazy () { 'lazy' }
17             sub bare () { 'bare' }
18              
19             sub _error_handler {
20 0     0   0 my ( $func, $message, @args ) = @_;
21 0 0       0 if ( @args ) {
22 0         0 require Data::Dumper;
23 0         0 local $Data::Dumper::Terse = 1;
24 0         0 local $Data::Dumper::Indent = 0;
25             $message = sprintf $message, map {
26 0 0       0 ref($_) ? Data::Dumper::Dumper($_) : defined($_) ? $_ : '(undef)'
  0 0       0  
27             } @args;
28             }
29 1     1   7 my $next = do { no strict 'refs'; require Carp; \&{"Carp::$func"} };
  1         1  
  1         159  
  0         0  
  0         0  
  0         0  
  0         0  
30 0         0 @_ = ( $message );
31 0         0 goto $next;
32             }
33              
34 0     0 0 0 sub carp { unshift @_, 'carp' ; goto \&_error_handler }
  0         0  
35 0     0 0 0 sub croak { unshift @_, 'croak' ; goto \&_error_handler }
  0         0  
36 0     0 0 0 sub confess { unshift @_, 'confess'; goto \&_error_handler }
  0         0  
37              
38             BEGIN {
39 1 50   1   4 *_HAS_AUTOCLEAN = eval { require namespace::autoclean }
  1         253  
40             ? \&true
41             : \&false
42             };
43              
44             if ( $] < 5.009005 ) {
45             require MRO::Compat;
46             }
47             else {
48             require mro;
49             }
50              
51             defined ${^GLOBAL_PHASE}
52             or eval { require Devel::GlobalDestruction; 1 }
53             or do {
54             carp( "WARNING: Devel::GlobalDestruction recommended!" );
55             *Devel::GlobalDestruction::in_global_destruction = sub { undef; };
56             };
57              
58             {
59 1     1   6 no strict 'refs';
  1         1  
  1         522  
60             my $GUARD_PACKAGE = __PACKAGE__ . '::Guard';
61 0 0   0   0 *{"$GUARD_PACKAGE\::DESTROY"} = sub { $_[0][1]->() unless $_[0][0] };
62 0     0   0 *{"$GUARD_PACKAGE\::restore"} = sub { $_[0]->DESTROY; $_[0][0] = 1 };
  0         0  
63 0     0   0 *{"$GUARD_PACKAGE\::dismiss"} = sub { $_[0][0] = 1 };
64 0     0   0 *{"$GUARD_PACKAGE\::peek"} = sub { $_[0][2] };
65 0     0   0 *guard = sub (&) { bless [ 0, @_ ] => $GUARD_PACKAGE };
66             }
67              
68             my $parse_mm_args = sub {
69             my $coderef = pop;
70             my $names = [ map { ref($_) ? @$_ : $_ } @_ ];
71             ( $names, $coderef );
72             };
73              
74             sub _is_compiling {
75 1     1   3 return !! $ENV{MITE_COMPILE};
76             }
77              
78             sub import {
79 1     1   2 my $class = shift;
80 1         2 my %arg = map { lc($_) => true } @_;
  1         5  
81 1         3 my ( $caller, $file ) = caller;
82              
83             # Turn on warnings and strict in the caller
84 1         12 warnings->import;
85 1         6 strict->import;
86              
87 1 50       4 my $kind = $arg{'-role'} ? 'role' : 'class';
88              
89 1 50       2 if( _is_compiling() ) {
90 0         0 require Mite::Project;
91 0         0 Mite::Project->default->inject_mite_functions(
92             package => $caller,
93             file => $file,
94             arg => \%arg,
95             kind => $kind,
96             shim => $class,
97             );
98             }
99             else {
100             # Changes to this filename must be coordinated with Mite::Compiled
101 1         2 my $mite_file = $file . ".mite.pm";
102 1 50       18 if( !-e $mite_file ) {
103 0         0 croak "Compiled Mite file ($mite_file) for $file is missing";
104             }
105              
106             {
107 1         2 local @INC = ('.', @INC);
  1         5  
108 1         352 require $mite_file;
109             }
110              
111 1         5 $class->_inject_mite_functions( $caller, $file, $kind, \%arg );
112             }
113              
114 1         31 if ( _HAS_AUTOCLEAN and not $arg{'-unclean'} ) {
115             'namespace::autoclean'->import( -cleanee => $caller );
116             }
117             }
118              
119             sub _inject_mite_functions {
120 1     1   4 my ( $class, $caller, $file, $kind, $arg ) = ( shift, @_ );
121 1 50   8   3 my $requested = sub { $arg->{$_[0]} ? true : $arg->{'!'.$_[0]} ? false : $arg->{'-all'} ? true : $_[1]; };
  8 50       38  
    50          
122              
123 1     1   6 no strict 'refs';
  1         3  
  1         329  
124 1         3 my $has = $class->_make_has( $caller, $file, $kind );
125 1 50       2 *{"$caller\::has"} = $has if $requested->( has => true );
  1         7  
126 1 50       3 *{"$caller\::param"} = $has if $requested->( param => false );
  1         5  
127 1 50       2 *{"$caller\::field"} = $has if $requested->( field => false );
  1         4  
128              
129 1 50       2 *{"$caller\::with"} = $class->_make_with( $caller, $file, $kind )
  1         5  
130             if $requested->( with => true );
131              
132 1     0   15 *{"$caller\::extends"} = sub {}
133 1 50 33     5 if $kind eq 'class' && $requested->( extends => true );
134 0     0   0 *{"$caller\::requires"} = sub {}
135 1 50 33     5 if $kind eq 'role' && $requested->( requires => true );
136              
137 1 50       3 my $MM = ( $kind eq 'class' ) ? [] : \@{"$caller\::METHOD_MODIFIERS"};
  0         0  
138              
139 1         2 for my $modifier ( qw/ before after around / ) {
140 3 50       7 next unless $requested->( $modifier => true );
141              
142 3 50       7 if ( $kind eq 'class' ) {
143 3         23 *{"$caller\::$modifier"} = sub {
144 1     1   4 $class->$modifier( $caller, @_ );
145 1         2 return;
146 3         9 };
147             }
148             else {
149 0         0 *{"$caller\::$modifier"} = sub {
150 0     0   0 my ( $names, $coderef ) = &$parse_mm_args;
151 0         0 push @$MM, [ $modifier, $names, $coderef ];
152 0         0 return;
153 0         0 };
154             }
155             }
156             }
157              
158             sub _make_has {
159 1     1   2 my ( $class, $caller, $file, $kind ) = @_;
160              
161 1     1   6 no strict 'refs';
  1         2  
  1         841  
162             return sub {
163 5     5   7 my $names = shift;
164 5 50       12 if ( @_ % 2 ) {
165 0         0 my $default = shift;
166 0 0       0 unshift @_, ( 'CODE' eq ref( $default ) )
167             ? ( is => lazy, builder => $default )
168             : ( is => ro, default => $default );
169             }
170 5         14 my %spec = @_;
171 5         6 my $code;
172              
173 5 50       9 for my $name ( ref($names) ? @$names : $names ) {
174 5         7 $name =~ s/^\+//;
175              
176             'CODE' eq ref( $code = $spec{default} )
177 5 50       9 and ${"$caller\::__$name\_DEFAULT__"} = $code;
  0         0  
178              
179             'CODE' eq ref( $code = $spec{builder} )
180 5 100       11 and *{"$caller\::_build_$name"} = $code;
  3         19  
181              
182             'CODE' eq ref( $code = $spec{trigger} )
183 5 50       10 and *{"$caller\::_trigger_$name"} = $code;
  0         0  
184              
185             'CODE' eq ref( $code = $spec{clone} )
186 5 50       10 and *{"$caller\::_clone_$name"} = $code;
  0         0  
187             }
188              
189 5         12 return;
190 1         4 };
191             }
192              
193             sub _make_with {
194 1     1   2 my ( $class, $caller, $file, $kind ) = @_;
195              
196             return sub {
197 0     0   0 while ( @_ ) {
198 0         0 my $role = shift;
199 0 0       0 my $args = ref($_[0]) ? shift : undef;
200 0 0 0     0 if ( $INC{'Role/Tiny.pm'} and 'Role::Tiny'->is_role( $role ) ) {
201 0         0 $class->_finalize_application_roletiny( $role, $caller, $args );
202             }
203             else {
204 0         0 $role->__FINALIZE_APPLICATION__( $caller, $args );
205             }
206             }
207 0         0 return;
208 1         3 };
209             }
210              
211             {
212             my ( $cb_before, $cb_after );
213             sub _finalize_application_roletiny {
214 0     0   0 my ( $class, $role, $caller, $args ) = @_;
215              
216 0 0       0 if ( $INC{'Role/Hooks.pm'} ) {
217 0   0     0 $cb_before ||= \%Role::Hooks::CALLBACKS_BEFORE_APPLY;
218 0   0     0 $cb_after ||= \%Role::Hooks::CALLBACKS_AFTER_APPLY;
219             }
220 0 0       0 if ( $cb_before ) {
221 0 0       0 $_->( $role, $caller ) for @{ $cb_before->{$role} || [] };
  0         0  
222             }
223              
224 0         0 'Role::Tiny'->_check_requires( $caller, $role );
225              
226 0         0 my $info = $Role::Tiny::INFO{$role};
227 0 0       0 for ( @{ $info->{modifiers} || [] } ) {
  0         0  
228 0         0 my @args = @$_;
229 0         0 my $kind = shift @args;
230 0         0 $class->$kind( $caller, @args );
231             }
232              
233 0 0       0 if ( $cb_after ) {
234 0 0       0 $_->( $role, $caller ) for @{ $cb_after->{$role} || [] };
  0         0  
235             }
236              
237 0         0 return;
238             }
239             }
240              
241             {
242             my $get_orig = sub {
243             my ( $caller, $name ) = @_;
244              
245             my $orig = $caller->can( $name );
246             return $orig if $orig;
247              
248             croak "Cannot modify method $name in $caller: no such method";
249             };
250              
251             sub before {
252 0     0 0 0 my ( $me, $caller ) = ( shift, shift );
253 0         0 my ( $names, $coderef ) = &$parse_mm_args;
254 0         0 for my $name ( @$names ) {
255 0         0 my $orig = $get_orig->( $caller, $name );
256 0         0 local $@;
257 0 0       0 eval <<"BEFORE" or die $@;
258             package $caller;
259             no warnings 'redefine';
260             sub $name {
261             \$coderef->( \@_ );
262             \$orig->( \@_ );
263             }
264             1;
265             BEFORE
266             }
267 0         0 return;
268             }
269              
270             sub after {
271 0     0 0 0 my ( $me, $caller ) = ( shift, shift );
272 0         0 my ( $names, $coderef ) = &$parse_mm_args;
273 0         0 for my $name ( @$names ) {
274 0         0 my $orig = $get_orig->( $caller, $name );
275 0         0 local $@;
276 0 0       0 eval <<"AFTER" or die $@;
277             package $caller;
278             no warnings 'redefine';
279             sub $name {
280             my \@r;
281             if ( wantarray ) {
282             \@r = \$orig->( \@_ );
283             }
284             elsif ( defined wantarray ) {
285             \@r = scalar \$orig->( \@_ );
286             }
287             else {
288             \$orig->( \@_ );
289             1;
290             }
291             \$coderef->( \@_ );
292             wantarray ? \@r : \$r[0];
293             }
294             1;
295             AFTER
296             }
297 0         0 return;
298             }
299              
300             sub around {
301 1     1 0 3 my ( $me, $caller ) = ( shift, shift );
302 1         2 my ( $names, $coderef ) = &$parse_mm_args;
303 1         2 for my $name ( @$names ) {
304 3         24 my $orig = $get_orig->( $caller, $name );
305 3         5 local $@;
306 1 50   1   6 eval <<"AROUND" or die $@;
  1     1   1  
  1     1   51  
  1     0   6  
  1     0   2  
  1     0   38  
  1         6  
  1         2  
  1         49  
  3         192  
  0            
  0            
  0            
307             package $caller;
308             no warnings 'redefine';
309             sub $name {
310             \$coderef->( \$orig, \@_ );
311             }
312             1;
313             AROUND
314             }
315 1         3 return;
316             }
317             }
318              
319             1;
320             __END__