File Coverage

blib/lib/Salvation/Method/Signatures.pm
Criterion Covered Total %
statement 72 75 96.0
branch 13 16 81.2
condition n/a
subroutine 11 11 100.0
pod 4 4 100.0
total 100 106 94.3


line stmt bran cond sub pod time code
1             package Salvation::Method::Signatures;
2              
3             =head1 NAME
4              
5             Salvation::Method::Signatures - Реализация сигнатур для методов
6              
7             =head1 SYNOPSIS
8              
9             package Some::Package;
10              
11             use Salvation::Method::Signatures;
12             # use Test::More tests => 3;
13              
14             method process( ArrayRef[ArrayRef[Str]] :flags!, ArrayRef[HashRef(Int :id!)] :data! ) {
15              
16             # isa_ok( $self, 'Some::Package' );
17             # is_deeply( $flags, [ [ 'something' ] ] );
18             # is_deeply( $data, [ { id => 1 } ] );
19              
20             ...
21             }
22              
23             package main;
24              
25             Some::Package -> process(
26             flags => [ [ 'something' ] ],
27             data => [ { id => 1 } ],
28             );
29              
30             =head1 DESCRIPTION
31              
32             Делает то же, что делают другие реализации сигнатур: проверяет тип аргументов
33             метода, само разбирает C<@_> и инжектит переменные в блок.
34              
35             =head1 SEE ALSO
36              
37             http://perlcabal.org/syn/S06.html#Signatures
38             L
39             L
40              
41             =cut
42              
43 1     1   379 use strict;
  1         1  
  1         22  
44 1     1   3 use warnings;
  1         1  
  1         14  
45 1     1   332 use boolean;
  1         2295  
  1         4  
46              
47 1     1   563 use Module::Load 'load';
  1         707  
  1         3  
48              
49 1     1   40 use base 'Devel::Declare::MethodInstaller::Simple';
  1         2  
  1         427  
50              
51             our $VERSION = 0.02;
52              
53             =head1 METHODS
54              
55             =cut
56              
57             =head2 type_system_class()
58              
59             =cut
60              
61             sub type_system_class {
62              
63 8     8 1 25 return 'Salvation::TC';
64             }
65              
66             =head2 token_str()
67              
68             =cut
69              
70             sub token_str {
71              
72 1     1 1 6 return 'method';
73             }
74              
75             =head2 self_var_name()
76              
77             =cut
78              
79             sub self_var_name {
80              
81 8     8 1 12 return '$self';
82             }
83              
84             =head2 import()
85              
86             Экспортирует магическое ключевое слово.
87              
88             Подробнее: L.
89              
90             =cut
91              
92             sub import {
93              
94 1     1   7 my ( $self ) = @_;
95 1         2 my $caller = caller();
96              
97 1         3 $self -> install_methodhandler(
98             name => $self -> token_str(),
99             into => $caller,
100             );
101              
102 1         189 return;
103             }
104              
105             =head2 parse_proto( Str $str )
106              
107             Разбирает прототип метода, генерирует код и инжектит этот код в метод.
108              
109             Подробнее: L.
110              
111             =cut
112              
113             sub parse_proto {
114              
115 8     8 1 15686 my ( $self, $str ) = @_;
116 8         16 load my $type_system_class = $self -> type_system_class();
117 8         75821 my $type_parser = $type_system_class -> get_type_parser();
118 8 100       64 my $sig = ( ( $str =~ m/^\s*$/ ) ? [] : $type_parser -> tokenize_signature_str( "(${str})", {} ) );
119              
120 8         1876 my @positional_vars = ( $self -> self_var_name() );
121 8         10 my $code = '';
122 8         6 my $pos = 0;
123 8         15 my $prev_was_optional = false;
124              
125             my $wrap_check = sub {
126              
127 15     15   9 my ( $code, $param_name ) = @_;
128              
129 15         33 return sprintf(
130             '( eval{ local $Carp::CarpLevel = 2; %s } || die( "Validation for parameter \"%s\" failed because:\n$@" ) )',
131             $code,
132             $param_name,
133             );
134 8         32 };
135              
136 8         20 while( defined( my $item = shift( @$sig ) ) ) {
137              
138 13 100       24 if( $item -> { 'param' } -> { 'named' } ) {
139              
140 3 50       12 if( $prev_was_optional ) {
141              
142 0         0 die( "Error at signature (${str}): named parameter can't follow optional positional parameter" );
143             }
144              
145 3         13 unshift( @$sig, $item );
146 3         3 last;
147             }
148              
149 10         21 my $type = $type_system_class -> materialize_type( $item -> { 'type' } );
150 10         116 my $arg = $item -> { 'param' };
151              
152 10         13 my $var = sprintf( '$%s', $arg -> { 'name' } );
153              
154 10         10 push( @positional_vars, $var );
155              
156 10         22 my $check = sprintf( '%s -> assert( %s, \'%s\' )', $type_system_class, $var, $type -> name() );
157              
158 10         41 $check = $wrap_check -> ( $check, $arg -> { 'name' } );
159              
160 10 100       20 if( $arg -> { 'optional' } ) {
    50          
161              
162 3         13 $prev_was_optional = true;
163              
164 3         11 $check = sprintf( '( ( scalar( @_ ) > %d ) ? %s : 1 )', 1 + $pos, $check );
165              
166             } elsif( $prev_was_optional ) {
167              
168 0         0 die( "Error at signature (${str}): required positional parameter can't follow optional one" );
169             }
170              
171 10         38 $code .= $check;
172 10         9 $code .= ';';
173              
174 10         15 $type_system_class -> get( $type -> name() ); # прогрев кэша
175              
176 10         294 ++$pos;
177             }
178              
179 8         10 my @named_vars = ();
180 8         5 my @named_params = ();
181 8         9 my $named_checks = '';
182              
183 8         12 while( defined( my $item = shift( @$sig ) ) ) {
184              
185 5 50       9 if( $item -> { 'param' } -> { 'positional' } ) {
186              
187 0         0 die( "Error at signature (${str}): positional parameter can't follow named parameter" );
188             }
189              
190 5         11 my $type = $type_system_class -> materialize_type( $item -> { 'type' } );
191 5         57 my $arg = $item -> { 'param' };
192              
193 5         10 push( @named_vars, sprintf( '$%s', $arg -> { 'name' } ) );
194 5         6 push( @named_params, sprintf( '\'%s\'', $arg -> { 'name' } ) );
195              
196 5         10 my $check = sprintf( '%s -> assert( $args{ \'%s\' }, \'%s\' )', $type_system_class, $arg -> { 'name' }, $type -> name() );
197              
198 5         20 $check = $wrap_check -> ( $check, $arg -> { 'name' } );
199              
200 5 100       9 if( $arg -> { 'optional' } ) {
201              
202 3         14 $prev_was_optional = true;
203              
204 3         8 $check = sprintf( '( exists( $args{ \'%s\' } ) ? %s : 1 )', $arg -> { 'name' }, $check );
205             }
206              
207 5         7 $named_checks .= $check;
208 5         14 $named_checks .= ';';
209             }
210              
211 8 100       27 my $named_vars_code = ( $named_checks ? sprintf( '( my ( %s ) = do {
212              
213             no warnings \'syntax\';
214              
215             my %%args = @_[ %d .. $#_ ]; %s @args{ %s };
216              
217             } );', join( ', ', @named_vars ), scalar( @positional_vars ), $named_checks, join( ', ', @named_params ) ) : '' );
218              
219 8         26 $code = sprintf( 'my ( %s ) = @_; %s %s local @_ = ();', join( ', ', @positional_vars ), $code, $named_vars_code );
220              
221 8         20 $code =~ s/\n/ /g;
222 8         78 $code =~ s/\s{2,}/ /g;
223              
224 8         42 return $code;
225             }
226              
227             1;
228              
229             __END__