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__ |