File Coverage

blib/lib/Mite/Trait/HasConstructor.pm
Criterion Covered Total %
statement 48 49 97.9
branch 8 10 80.0
condition n/a
subroutine 11 11 100.0
pod n/a
total 67 70 95.7


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;