File Coverage

blib/lib/Mite/Attribute/SHV/CodeGen.pm
Criterion Covered Total %
statement 29 36 80.5
branch 11 16 68.7
condition 7 14 50.0
subroutine 4 4 100.0
pod n/a
total 51 70 72.8


line stmt bran cond sub pod time code
1 3     3   79 use 5.010001;
  3         12  
2 3     3   17 use strict;
  3         7  
  3         71  
3 3     3   18 use warnings;
  3         8  
  3         2020  
4              
5             package Mite::Attribute::SHV::CodeGen;
6              
7             # SHV uses Mite, so cannot be required by Mite during bootstrapping
8             require Mite::Shim;
9             if ( not Mite::Shim::_is_compiling() ) {
10             require Sub::HandlesVia::CodeGenerator;
11             our @ISA = 'Sub::HandlesVia::CodeGenerator';
12             }
13              
14             sub _handle_sigcheck {
15 6     6   185 my ( $self, $method_name, $handler, $env, $code, $state ) = @_;
16              
17             # If there's a proper signature for the method...
18             #
19 6 100       10 if ( @{ $handler->signature || [] } ) {
  6 100       47  
20            
21             # Generate code using Type::Params to check the signature.
22             # We also need to close over the signature.
23             #
24 1         525 require Mite::Signature::Compiler;
25            
26             my $compiler = 'Mite::Signature::Compiler'->new_from_compile(
27             positional => {
28             package => $self->target,
29             subname => $method_name,
30             is_wrapper => !!0,
31             mite_signature => $self->{mite_attribute}, # HasMethods['class']
32             },
33             $state->{shifted_self}
34 0         0 ? @{ $handler->signature }
35 1 50       32 : ( Types::Standard::Object(), @{ $handler->signature } ),
  1         19  
36             );
37            
38 1         1285 my $sigcode = $compiler->coderef->code;
39 1         252 $sigcode =~ s/^\s+|\s+$//gs;
40 1 50       14 if ( $sigcode =~ /return/ ) {
41 0         0 push @$code, sprintf '$__signature ||= %s;', $sigcode;
42 0         0 push @$code, '@_ = &$__signature;';
43 0         0 $env->{'$__signature'} = \0;
44             }
45             else {
46 1         5 $sigcode =~ s/^sub/do/;
47 1         4 push @$code, sprintf '@_ = %s;', $sigcode;
48             }
49            
50             # As we've now inserted a signature check, we can stop worrying
51             # about signature checks.
52             #
53 1         29 $state->{signature_check_needed} = 0;
54             }
55             # There is no proper signature, but there's still check the
56             # arity of the method.
57             #
58             else {
59             # What is the arity?
60             #
61 5   50     17 my $min_args = $handler->min_args || 0;
62 5         93 my $max_args = $handler->max_args;
63            
64 5         72 my $plus = 1;
65 5 50       20 if ( $state->{shifted_self} ) {
66 0         0 $plus = 0;
67             }
68            
69             # What usage message do we want to print if wrong arity?
70             #
71             my $usg = sprintf(
72             '%s("Wrong number of parameters in signature for %s; usage: ".%s)',
73             $self->{mite_attribute}->_function_for_croak,
74 5         23 $method_name,
75             B::perlstring( $self->generate_usage_string( $method_name, $handler->usage ) ),
76             );
77            
78             # Insert the check into the code.
79             #
80 5 100 66     326 if (defined $min_args and defined $max_args and $min_args==$max_args) {
    50 66        
    50 33        
      33        
81 1         6 push @$code, sprintf('@_==%d or %s;', $min_args + $plus, $usg);
82             }
83             elsif (defined $min_args and defined $max_args) {
84 0         0 push @$code, sprintf('(@_ >= %d and @_ <= %d) or %s;', $min_args + $plus, $max_args + $plus, $usg);
85             }
86             elsif (defined $min_args and $min_args > 0) {
87 0         0 push @$code, sprintf('@_ >= %d or %s;', $min_args + $plus, $usg);
88             }
89            
90             # We are still lacking a proper signature check though, so note
91             # that in the state. The information can be used by
92             # additional_validation coderefs.
93             #
94 5         17 $state->{signature_check_needed} = !!1;
95             }
96            
97 6         39 return $self;
98             }
99              
100             1;