line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
108
|
|
|
108
|
|
2253
|
use 5.010001; |
|
108
|
|
|
|
|
383
|
|
2
|
108
|
|
|
108
|
|
546
|
use strict; |
|
108
|
|
|
|
|
215
|
|
|
108
|
|
|
|
|
2348
|
|
3
|
108
|
|
|
108
|
|
721
|
use warnings; |
|
108
|
|
|
|
|
562
|
|
|
108
|
|
|
|
|
5591
|
|
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
use Mite::Miteception -role, -all; |
6
|
108
|
|
|
108
|
|
627
|
|
|
108
|
|
|
|
|
237
|
|
|
108
|
|
|
|
|
889
|
|
7
|
|
|
|
|
|
|
our $AUTHORITY = 'cpan:TOBYINK'; |
8
|
|
|
|
|
|
|
our $VERSION = '0.010008'; |
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
requires qw( |
11
|
|
|
|
|
|
|
linear_isa |
12
|
|
|
|
|
|
|
_get_parent |
13
|
|
|
|
|
|
|
_compile_meta |
14
|
|
|
|
|
|
|
); |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
around compilation_stages => sub { |
17
|
|
|
|
|
|
|
my ( $next, $self ) = ( shift, shift ); |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
# Check if we are inheriting from a Mite class in this project |
20
|
|
|
|
|
|
|
my $inherit_from_mite = do { |
21
|
|
|
|
|
|
|
# First parent |
22
|
|
|
|
|
|
|
my $first_isa = do { |
23
|
|
|
|
|
|
|
my @isa = $self->linear_isa; |
24
|
|
|
|
|
|
|
shift @isa; |
25
|
|
|
|
|
|
|
shift @isa; |
26
|
|
|
|
|
|
|
}; |
27
|
|
|
|
|
|
|
!! ( $first_isa and $self->_get_parent( $first_isa ) ); |
28
|
|
|
|
|
|
|
}; |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
my @stages = $self->$next( @_ ); |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
# Need a constructor if we're not inheriting from Mite, |
33
|
|
|
|
|
|
|
# or if we define any new attributes. |
34
|
|
|
|
|
|
|
push @stages, '_compile_new' |
35
|
|
|
|
|
|
|
if !$inherit_from_mite |
36
|
|
|
|
|
|
|
|| keys %{ $self->attributes }; |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
# Only need these stages if not already inheriting from Mite |
39
|
|
|
|
|
|
|
push @stages, qw( |
40
|
|
|
|
|
|
|
_compile_buildall_method |
41
|
|
|
|
|
|
|
) unless $inherit_from_mite; |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
return @stages; |
44
|
|
|
|
|
|
|
}; |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
my $self = shift; |
47
|
|
|
|
|
|
|
my @vars = ('$class', '$self', '$args', '$meta'); |
48
|
108
|
|
|
108
|
|
294
|
|
49
|
108
|
|
|
|
|
488
|
return sprintf <<'CODE', $self->_compile_meta(@vars), $self->_compile_bless(@vars), $self->_compile_buildargs(@vars), $self->_compile_init_attributes(@vars), $self->_compile_buildall(@vars, '$no_build'), $self->_compile_strict_constructor(@vars); |
50
|
|
|
|
|
|
|
# Standard Moose/Moo-style constructor |
51
|
108
|
|
|
|
|
516
|
sub new { |
52
|
|
|
|
|
|
|
my $class = ref($_[0]) ? ref(shift) : shift; |
53
|
|
|
|
|
|
|
my $meta = %s; |
54
|
|
|
|
|
|
|
my $self = %s; |
55
|
|
|
|
|
|
|
my $args = %s; |
56
|
|
|
|
|
|
|
my $no_build = delete $args->{__no_BUILD__}; |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
%s |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
# Call BUILD methods |
61
|
|
|
|
|
|
|
%s |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
# Unrecognized parameters |
64
|
|
|
|
|
|
|
%s |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
return $self; |
67
|
|
|
|
|
|
|
} |
68
|
|
|
|
|
|
|
CODE |
69
|
|
|
|
|
|
|
} |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
my ( $self, $classvar, $selfvar, $argvar, $metavar ) = @_; |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
my $simple_bless = "bless {}, $classvar"; |
74
|
108
|
|
|
108
|
|
406
|
|
75
|
|
|
|
|
|
|
# Force parents to be loaded |
76
|
108
|
|
|
|
|
339
|
$self->parents; |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
# First parent with &new |
79
|
108
|
|
|
|
|
616
|
my ( $first_isa ) = do { |
80
|
|
|
|
|
|
|
my @isa = $self->linear_isa; |
81
|
|
|
|
|
|
|
shift @isa; |
82
|
108
|
|
|
|
|
222
|
no strict 'refs'; |
83
|
108
|
|
|
|
|
412
|
grep +(defined &{$_.'::new'}), @isa; |
84
|
108
|
|
|
|
|
292
|
}; |
85
|
108
|
|
|
108
|
|
787
|
|
|
108
|
|
|
|
|
235
|
|
|
108
|
|
|
|
|
50969
|
|
86
|
108
|
|
|
|
|
346
|
# If we're not inheriting from anything with a constructor: simple case |
|
24
|
|
|
|
|
179
|
|
87
|
|
|
|
|
|
|
$first_isa or return $simple_bless; |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
# Inheriting from a Mite class in this project: simple case |
90
|
108
|
100
|
|
|
|
800
|
my $first_parent = $self->_get_parent( $first_isa ) |
91
|
|
|
|
|
|
|
and return $simple_bless; |
92
|
|
|
|
|
|
|
|
93
|
2
|
50
|
|
|
|
8
|
# Inheriting from a Moose/Moo/Mite/Class::Tiny class: |
94
|
|
|
|
|
|
|
# call buildargs |
95
|
|
|
|
|
|
|
# set $args->{__no_BUILD__} |
96
|
|
|
|
|
|
|
# call parent class constructor |
97
|
|
|
|
|
|
|
if ( $first_isa->can( 'BUILDALL' ) ) { |
98
|
|
|
|
|
|
|
return sprintf 'do { my %s = %s; %s->{__no_BUILD__} = 1; %s->SUPER::new( %s ) }', |
99
|
|
|
|
|
|
|
$argvar, $self->_compile_buildargs($classvar, $selfvar, $argvar, $metavar), $argvar, $classvar, $argvar; |
100
|
2
|
100
|
|
|
|
45
|
} |
101
|
1
|
|
|
|
|
6
|
|
102
|
|
|
|
|
|
|
# Inheriting from some random class |
103
|
|
|
|
|
|
|
# call FOREIGNBUILDARGS if it exists |
104
|
|
|
|
|
|
|
# pass return value or @_ to parent class constructor |
105
|
|
|
|
|
|
|
return sprintf '%s->SUPER::new( %s->{HAS_FOREIGNBUILDARGS} ? %s->FOREIGNBUILDARGS( @_ ) : @_ )', |
106
|
|
|
|
|
|
|
$classvar, $metavar, $classvar; |
107
|
|
|
|
|
|
|
} |
108
|
1
|
|
|
|
|
11
|
|
109
|
|
|
|
|
|
|
my ( $self, $classvar, $selfvar, $argvar, $metavar ) = @_; |
110
|
|
|
|
|
|
|
return sprintf '%s->{HAS_BUILDARGS} ? %s->BUILDARGS( @_ ) : { ( @_ == 1 ) ? %%{$_[0]} : @_ }', |
111
|
|
|
|
|
|
|
$metavar, $classvar; |
112
|
|
|
|
|
|
|
} |
113
|
109
|
|
|
109
|
|
413
|
|
114
|
109
|
|
|
|
|
888
|
my ( $self, $classvar, $selfvar, $argvar, $metavar ) = @_; |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
my @allowed = |
117
|
|
|
|
|
|
|
grep { defined $_ } |
118
|
|
|
|
|
|
|
map { ( $_->init_arg, $_->_all_aliases ) } |
119
|
108
|
|
|
108
|
|
371
|
values %{ $self->all_attributes }; |
120
|
|
|
|
|
|
|
my $check = do { |
121
|
|
|
|
|
|
|
local $Type::Tiny::AvoidCallbacks = 1; |
122
|
133
|
|
|
|
|
464
|
my $enum = Enum->of( @allowed ); |
123
|
130
|
|
|
|
|
391
|
$enum->can( '_regexp' ) # not part of official API |
124
|
108
|
|
|
|
|
298
|
? sprintf( '/\\A%s\\z/', $enum->_regexp ) |
|
108
|
|
|
|
|
2391
|
|
125
|
108
|
|
|
|
|
290
|
: $enum->inline_check( '$_' ); |
126
|
108
|
|
|
|
|
358
|
}; |
127
|
108
|
|
|
|
|
691
|
|
128
|
108
|
100
|
|
|
|
109990
|
my $code = sprintf 'my @unknown = grep not( %s ), keys %%{%s}; @unknown and %s( "Unexpected keys in constructor: " . join( q[, ], sort @unknown ) );', |
129
|
|
|
|
|
|
|
$check, $argvar, $self->_function_for_croak; |
130
|
|
|
|
|
|
|
if ( my $autolax = $self->autolax ) { |
131
|
|
|
|
|
|
|
$code = "if ( $autolax ) { $code }"; |
132
|
|
|
|
|
|
|
} |
133
|
108
|
|
|
|
|
25892
|
return $code; |
134
|
|
|
|
|
|
|
} |
135
|
108
|
50
|
|
|
|
845
|
|
136
|
0
|
|
|
|
|
0
|
my ( $self, $classvar, $selfvar, $argvar, $metavar, $nobuildvar ) = @_; |
137
|
|
|
|
|
|
|
return sprintf '%s->BUILDALL( %s ) if ( ! %s and @{ %s->{BUILD} || [] } );', |
138
|
108
|
|
|
|
|
5092
|
$selfvar, $argvar, $nobuildvar, $metavar; |
139
|
|
|
|
|
|
|
} |
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
my $self = shift; |
142
|
108
|
|
|
108
|
|
464
|
|
143
|
108
|
|
|
|
|
841
|
return sprintf <<'CODE', $self->_compile_meta( '$class', '$_[0]', '$_[1]', '$meta' ), |
144
|
|
|
|
|
|
|
# Used by constructor to call BUILD methods |
145
|
|
|
|
|
|
|
sub BUILDALL { |
146
|
|
|
|
|
|
|
my $class = ref( $_[0] ); |
147
|
|
|
|
|
|
|
my $meta = %s; |
148
|
93
|
|
|
93
|
|
240
|
$_->( @_ ) for @{ $meta->{BUILD} || [] }; |
149
|
|
|
|
|
|
|
} |
150
|
93
|
|
|
|
|
428
|
CODE |
151
|
|
|
|
|
|
|
} |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
1; |