File Coverage

blib/lib/Mite/Signature.pm
Criterion Covered Total %
statement 54 63 85.7
branch 27 40 67.5
condition 16 29 55.1
subroutine 12 12 100.0
pod 0 3 0.0
total 109 147 74.1


line stmt bran cond sub pod time code
1 12     12   266 use 5.010001;
  12         40  
2 12     12   64 use strict;
  12         24  
  12         283  
3 12     12   60 use warnings;
  12         23  
  12         502  
4              
5             use Mite::Miteception -all;
6 12     12   78  
  12         22  
  12         110  
7             our $AUTHORITY = 'cpan:TOBYINK';
8             our $VERSION = '0.010008';
9              
10             has class =>
11             is => ro,
12             isa => MitePackage,
13             weak_ref => true;
14              
15             has compiling_class =>
16             init_arg => undef,
17             is => rw,
18             isa => MitePackage,
19             local_writer => true;
20              
21             has method_name =>
22             is => ro,
23             isa => Str,
24             required => true;
25              
26             has named =>
27             is => ro,
28             isa => ArrayRef->plus_coercions( HashRef, q([%$_]) ),
29             predicate => 'is_named';
30              
31             has positional =>
32             is => ro,
33             isa => ArrayRef,
34             alias => 'pos',
35             predicate => 'is_positional';
36              
37             has method =>
38             is => 'ro',
39             isa => Bool,
40             default => true;
41              
42             has head =>
43             is => lazy,
44             isa => ArrayRef | Int,
45             builder => sub { shift->method ? [ Defined, { name => 'invocant' } ] : [] };
46 8 100   8   70  
47             has tail =>
48             is => ro,
49             isa => ArrayRef | Int;
50              
51             has named_to_list =>
52             is => ro,
53             isa => Bool | ArrayRef,
54             default => false;
55              
56             has compiler =>
57             init_arg => undef,
58             is => lazy,
59             isa => Object,
60             builder => true,
61             handles => [ qw( has_head has_tail has_slurpy ) ];
62              
63             has should_bless =>
64             init_arg => undef,
65             is => lazy,
66             isa => Bool,
67             builder => sub { !!( $_[0]->is_named && !$_[0]->named_to_list ) };
68 9   100 9   85  
69             my $self = shift;
70              
71 9     9 0 15 croak 'Method cannot be both named and positional'
72             if $self->is_named && $self->is_positional;
73 9 50 66     116 }
74              
75             my $self = shift;
76              
77             my $class = $self->compiling_class || $self->class;
78 9     9 0 19 return if not $class;
79             return if not eval { $class->project->config->data->{autolax} };
80 9   66     31 return sprintf '%s::STRICT', $class->project->config->data->{shim};
81 9 50       27 }
82 9 50       18  
  9         40  
83 0         0 my $self = shift;
84              
85             local $Type::Tiny::AvoidCallbacks = 1;
86             local $Type::Tiny::SafePackage = sprintf( 'package %s;', $self->class->shim_name );
87 9     9   16  
88             require Mite::Signature::Compiler;
89 9         16 my $c = 'Mite::Signature::Compiler'->new_from_compile(
90 9         52 $self->is_named ? 'named' : 'positional',
91             {
92 9         3074 package => $self->class->name,
93             subname => $self->method_name,
94             ( $self->head ? ( head => $self->head ) : () ),
95             ( $self->tail ? ( tail => $self->tail ) : () ),
96             named_to_list => $self->named_to_list,
97             strictness => scalar( $self->autolax // 1 ),
98             goto_next => true,
99             mite_signature => $self,
100             $self->should_bless
101             ? ( bless => sprintf '%s::__NAMED_ARGUMENTS__::%s', $self->class->name, $self->method_name )
102             : (),
103             },
104             $self->is_named
105             ? @{ $self->named }
106             : @{ $self->positional },
107             );
108              
109 6         63 $c->coderef;
110 9 100 50     151  
  3 50       38  
    50          
    100          
    100          
111             if ( keys %{ $c->coderef->{env} } ) {
112             croak "Signature could not be inlined properly; bailing out";
113 9         8678 }
114              
115 9 50       1099 return $c;
  9         31  
116 0         0 }
117              
118             my $self = shift;
119 9         82  
120             if ( $self->compiling_class and $self->compiling_class != $self->class ) {
121             return sprintf( '$%s::SIGNATURE_FOR{%s}', $self->class->name, B::perlstring( $self->method_name ) );
122             }
123 10     10   25  
124             my $code = $self->compiler->coderef->code;
125 10 100 66     36 $code =~ s/^\s+|\s+$//gs;
126 1         11  
127             return $code;
128             }
129 9         50  
130 9         1484 my $self = shift;
131              
132 9         146 if ( $self->compiling_class and $self->compiling_class != $self->class ) {
133             return;
134             }
135              
136 10     10   22 return unless $self->should_bless;
137             return $self->compiler->make_class_pp_code;
138 10 100 66     32 }
139 1         7  
140             my ( $self, %args ) = @_;
141              
142 9 100       37 # alias
143 5         18 $args{positional} = $args{pos} if exists $args{pos};
144              
145             if ( $self->has_slurpy and $args{positional} ) {
146             croak "Cannot add new positional parameters when extending an existing signature with a slurpy parameter";
147 1     1 0 4 }
148             elsif ( $self->has_slurpy and $args{named} ) {
149             croak "Cannot add new named parameters when extending an existing signature with a slurpy parameter";
150 1 50       4 }
151             elsif ( $self->is_named and $args{positional} ) {
152 1 50 33     3 croak "Cannot add positional parameters when extending an existing signature which has named parameters";
    50 33        
    50 33        
    50 33        
153 0         0 }
154             elsif ( !$self->is_named and $args{named} ) {
155             croak "Cannot add named parameters when extending an existing signature which has positional parameters";
156 0         0 }
157              
158             if ( $args{positional} ) {
159 0         0 $args{positional} = [ @{ $self->positional }, @{ $args{positional} } ];
160             }
161              
162 0         0 if ( $args{named} ) {
163             $args{named} = [ @{ $self->named }, @{ $args{named} } ];
164             }
165 1 50       25  
166 0         0 my %new_args = ( %$self, %args );
  0         0  
  0         0  
167              
168             # Rebuild these
169 1 50       7 delete $new_args{compiler};
170 1         2 delete $new_args{should_bless};
  1         4  
  1         4  
171              
172             return __PACKAGE__->new( %new_args );
173 1         8 }
174              
175             1;