File Coverage

blib/lib/Method/Signatures/Parameter.pm
Criterion Covered Total %
statement 111 118 94.0
branch 55 64 85.9
condition 12 12 100.0
subroutine 17 19 89.4
pod 1 7 14.2
total 196 220 89.0


line stmt bran cond sub pod time code
1             package Method::Signatures::Parameter;
2              
3 63     63   24835 use Mouse;
  63         1228250  
  63         246  
4 63     63   15346 use Carp;
  63         87  
  63         3830  
5 63     63   556 use Method::Signatures::Utils;
  63         77  
  63         7706  
6              
7             my $IDENTIFIER = qr{ [^\W\d] \w* }x;
8             my $VARIABLE = qr{ [\$\@%] $IDENTIFIER? }x;
9             my $TYPENAME = qr{ $IDENTIFIER (?: \:\: $IDENTIFIER )* }x;
10             our $PARAMETERIZED;
11 63     63   270 $PARAMETERIZED = do{ use re 'eval';
  63         80  
  63         95050  
12             qr{ $TYPENAME (?: \[ (??{$PARAMETERIZED}) \] )? }x;
13             };
14             my $TYPESPEC = qr{ ^ \s* $PARAMETERIZED (?: \s* \| \s* $PARAMETERIZED )* \s* }x;
15              
16             has original_code =>
17             is => 'ro',
18             isa => 'Str',
19             required => 1;
20              
21             # Note: Have to preparse with regexes up to traits
22             # because :, ! and ? in sigs confuse PPI
23             has ppi_clean_code =>
24             is => 'rw',
25             isa => 'Str',
26             ;
27              
28             has is_yadayada =>
29             is => 'ro',
30             isa => 'Bool',
31             lazy => 1,
32             default => sub {
33             my $self = shift;
34              
35             return $self->original_code =~ m{^ \s* (?:\Q...\E)|(?:@) \s* $}x;
36             };
37              
38             has is_hash_yadayada =>
39             is => 'ro',
40             isa => 'Bool',
41             lazy => 1,
42             default => sub {
43             my $self = shift;
44             return $self->original_code =~ m{^ \s* % \s* $}x;
45             };
46              
47             has type =>
48             is => 'rw',
49             isa => 'Str',
50             default => '';
51             ;
52              
53             has is_ref_alias =>
54             is => 'rw',
55             isa => 'Bool',
56             default => 0;
57              
58             has is_named =>
59             is => 'rw',
60             isa => 'Bool',
61             ;
62              
63             sub is_positional {
64 835     835 0 638 my $self = shift;
65              
66 835         2434 return !$self->is_named;
67             }
68              
69             has variable =>
70             is => 'rw',
71             isa => 'Str',
72             default => '';
73              
74             has is_placeholder =>
75             is => 'rw',
76             isa => 'Bool',
77             default => 0;
78              
79             has first_line_number =>
80             is => 'rw',
81             isa => 'Int';
82              
83             has position =>
84             is => 'rw',
85             isa => 'Maybe[Int]', # XXX 0 or positive int
86             trigger => sub {
87             my($self, $new_position, $old_position) = @_;
88              
89             if( $self->is_named ) {
90             croak("A named parameter cannot have a position")
91             if defined $new_position and length $new_position;
92             }
93             else { # positional parameter
94             croak("A positional parameter must have a position")
95             if !(defined $new_position and length $new_position);
96             }
97             };
98              
99             has sigil =>
100             is => 'rw',
101             isa => 'Str', # XXX [%$@*]
102             ;
103              
104             has variable_name =>
105             is => 'rw',
106             isa => 'Str',
107             ;
108              
109             has where =>
110             is => 'rw',
111             isa => 'ArrayRef',
112             default => sub { [] };
113              
114             sub has_where {
115 0     0 0 0 my $self = shift;
116              
117 0 0       0 return @{$self->where} ? 1 : 0;
  0         0  
118             }
119              
120             has traits =>
121             is => 'rw',
122             isa => 'HashRef[Int]',
123             default => sub { {} };
124              
125             sub has_traits {
126 0     0 0 0 my $self = shift;
127              
128 0 0       0 return keys %{$self->traits} ? 1 : 0;
  0         0  
129             }
130              
131             has default =>
132             is => 'rw',
133             isa => 'Maybe[Str]'
134             ;
135              
136             has default_when =>
137             is => 'rw',
138             isa => 'Str',
139             ;
140              
141             has passed_in =>
142             is => 'rw',
143             isa => 'Str',
144             ;
145              
146             has check_exists =>
147             is => 'rw',
148             isa => 'Str'
149             ;
150              
151             has is_slurpy =>
152             is => 'ro',
153             isa => 'Bool',
154             lazy => 1,
155             default => sub {
156             my $self = shift;
157              
158             return 0 if $self->is_ref_alias;
159             return 0 if !$self->sigil;
160              
161             return $self->sigil =~ m{ ^ [%\@] $ }x;
162             };
163              
164             has is_at_underscore =>
165             is => 'ro',
166             isa => 'Bool',
167             lazy => 1,
168             default => sub {
169             my $self = shift;
170              
171             return $self->variable eq '@_';
172             };
173              
174             has required_flag =>
175             is => 'rw',
176             isa => 'Str',
177             default => '';
178              
179             has is_required =>
180             is => 'rw',
181             isa => 'Bool',
182             ;
183              
184             # A PPI::Document representing the parameter
185             has ppi_doc =>
186             is => 'ro',
187             isa => 'PPI::Document',
188             lazy => 1,
189             default => sub {
190             my $code = $_[0]->ppi_clean_code;
191             return new_ppi_doc(\$code);
192             };
193              
194              
195             sub is_optional {
196 692     692 0 510 my $self = shift;
197              
198 692         2116 return !$self->is_required;
199             }
200              
201             sub BUILD {
202 341     341 1 346 my $self = shift;
203              
204 341 100       968 return if $self->is_yadayada;
205              
206 335         645 $self->_preparse_original_code_for_ppi;
207 334         563 $self->_parse_with_ppi;
208 333         548 $self->_init_split_variable;
209 333         474 $self->_init_is_required;
210              
211 333         722 return;
212             }
213              
214              
215             sub _init_is_required {
216 333     333   293 my $self = shift;
217              
218 333         483 $self->is_required( $self->_determine_is_required );
219             }
220              
221              
222             sub _determine_is_required {
223 333     333   268 my $self = shift;
224              
225 333 100       816 return 1 if $self->required_flag eq '!';
226              
227 324 100       692 return 0 if $self->required_flag eq '?';
228 310 100       448 return 0 if $self->has_default;
229 206 100       585 return 0 if $self->is_named;
230 165 100       496 return 0 if $self->is_slurpy;
231              
232 140         459 return 1;
233             }
234              
235              
236             sub has_default {
237 310     310 0 259 my $self = shift;
238              
239 310         986 return defined $self->default;
240             }
241              
242             sub _parse_with_ppi {
243 334     334   319 my $self = shift;
244              
245             # Nothing to parse.
246 334 100       913 return if $self->ppi_clean_code !~ /\S/;
247              
248             # Replace parameter var so as not to confuse PPI...
249 117         525 $self->ppi_clean_code($self->variable. " " .$self->ppi_clean_code);
250              
251             # Tokenize...
252 117         389 my $components = $self->ppi_doc;
253 117 50       303 my $statement = $components->find_first("PPI::Statement")
254 0         0 or sig_parsing_error("Could not understand parameter specification: @{[$self->ppi_clean_code]}");
255 117         17593 my $tokens = [ $statement->children ];
256              
257             # Re-remove parameter var
258 117         566 shift @$tokens;
259              
260             # Extract any 'where' constraints...
261 117         453 while ($self->_extract_leading(qr{^ where $}x, $tokens)) {
262 9 50       100 sig_parsing_error("'where' constraint only available under Perl 5.10 or later. Error")
263             if $] < 5.010;
264 9         12 push @{$self->where}, $self->_extract_until(qr{^ (?: where | is | = | //= ) $}x, $tokens);
  9         42  
265             }
266              
267             # Extract parameter traits...
268 117         904 while ($self->_extract_leading(qr{^ is $}x, $tokens)) {
269 25         341 $self->traits->{ $self->_extract_leading(qr{^ \S+ $}x, $tokens) }++;
270             }
271              
272             # Extract normal default specifier (if any)...
273 117 100       697 if ($self->_extract_leading(qr{^ = $}x, $tokens)) {
    100          
    100          
274 95         924 $self->default( $self->_extract_until(qr{^ when $}x, $tokens) );
275              
276             # Extract 'when' modifier (if any)...
277 95 100       267 if ($self->_extract_leading(qr{^ when $}x, $tokens)) {
278 44 50       369 sig_parsing_error("'when' modifier on default only available under Perl 5.10 or later. Error")
279             if $] < 5.010;
280 44         90 $self->default_when( join(q{}, @$tokens) );
281 44         469 $tokens = [];
282             }
283             }
284              
285             # Otherwise, extract undef-default specifier (if any)...
286             elsif ($self->_extract_leading(qr{^ //= $}x, $tokens)) {
287 10 50       90 sig_parsing_error("'//=' defaults only available under Perl 5.10 or later. Error")
288             if $] < 5.010;
289 10         35 $self->default_when('undef');
290 10         18 $self->default( join(q{}, @$tokens) );
291 10         90 $tokens = [];
292             }
293              
294             # Anything left over is an error...
295             elsif (my $trailing = $self->_extract_leading(qr{ \S }x, $tokens)) {
296 1         14 sig_parsing_error("Unexpected extra code after parameter specification: '",
297             $trailing . join(q{}, @$tokens), "'"
298             );
299             }
300              
301 116         245 return;
302             }
303              
304              
305             # Remove leading whitespace + token, if token matches the specified pattern...
306             sub _extract_leading {
307 539     539   775 my ($self, $selector_pat, $tokens) = @_;
308              
309 539   100     1350 while (@$tokens && $tokens->[0]->class eq 'PPI::Token::Whitespace') {
310 159         1067 shift @$tokens;
311             }
312              
313 539 100 100     2943 return @$tokens && $tokens->[0] =~ $selector_pat
314             ? "" . shift @$tokens
315             : undef;
316             }
317              
318              
319             # Remove tokens up to (but excluding) the first that matches the delimiter...
320             sub _extract_until {
321 104     104   112 my ($self, $delimiter_pat, $tokens) = @_;
322              
323 104         103 my $extracted = q{};
324              
325 104         192 while (@$tokens) {
326 330 100       1386 last if $tokens->[0] =~ $delimiter_pat;
327              
328 280         1760 my $token = shift @$tokens;
329              
330             # Flatten multi-line data structures into a single line which
331             # Devel::Declare can inject.
332 280 100   304   845 $token->prune(sub { !$_[1]->significant }) if $token->isa("PPI::Node");
  304         4948  
333              
334 280         1022 $extracted .= $token;
335             }
336              
337 104         1085 return $extracted;
338             }
339              
340              
341             sub _preparse_original_code_for_ppi {
342 335     335   296 my $self = shift;
343              
344 335         524 my $original_code = $self->original_code;
345              
346 335 100       34260 $self->type($1) if $original_code =~ s{^ ($TYPESPEC) \s+ }{}ox;
347              
348             # Extract ref-alias & named-arg markers, param var, and required/optional marker...
349 335 100       4142 $original_code =~ s{ ^ \s* ([\\:]*) \s* ($VARIABLE) \s* ([!?]?) }{}ox
350             or sig_parsing_error("Could not understand parameter specification: $original_code");
351 334         945 my ($premod, $var, $postmod) = ($1, $2, $3);
352              
353 334         644 $self->is_ref_alias ($premod =~ m{ \\ }x);
354 334         559 $self->is_named ($premod =~ m{ : }x);
355 334 100       579 $self->required_flag($postmod) if $postmod;
356              
357 334 50       541 if ($var) {
358 334 100       549 if ($var eq '$') {
359 8         296 $self->is_placeholder(1);
360 8         16 $self->variable('$tmp');
361             } else {
362 326         706 $self->variable($var);
363             }
364             }
365              
366 334         732 $self->ppi_clean_code($original_code);
367              
368 334         497 return;
369             }
370              
371              
372             sub _init_split_variable {
373 333     333   295 my $self = shift;
374              
375 333         932 $self->variable =~ /^(.) (.*)/x;
376              
377 333         994 $self->sigil ($1);
378 333         846 $self->variable_name($2);
379              
380 333         291 return;
381             }
382              
383              
384             # Check the integrity of one piece of the signature
385             sub check {
386 302     302 0 342 my($self, $signature) = @_;
387              
388 302 100       783 if( $self->is_slurpy ) {
389 33 100       88 sig_parsing_error("Signature can only have one slurpy parameter")
390             if $signature->num_slurpy >= 1;
391 29 100       92 sig_parsing_error("Slurpy parameter '@{[$self->variable]}' cannot be named; use a reference instead")
  2         16  
392             if $self->is_named;
393             }
394              
395 296 100       629 if( $self->is_named ) {
396 47 100       99 if( $signature->num_optional_positional ) {
397 2         11 my $pos_var = $signature->positional_parameters->[-1]->variable;
398 2         5 my $var = $self->variable;
399 2         8 sig_parsing_error("Named parameter '$var' mixed with optional positional '$pos_var'");
400             }
401             }
402             else { # is_positional
403 249 100       547 if( $signature->num_named ) {
404 3         11 my $named_var = $signature->named_parameters->[-1]->variable;
405 3         6 my $var = $self->variable;
406 3         14 sig_parsing_error("Positional parameter '$var' after named param '$named_var'");
407             }
408              
409             # Required positional after an optional.
410             # Required positional after a slurpy will be handled elsewhere.
411 246 100 100     857 if( $self->is_required && $signature->num_optional_positional &&
      100        
412             !$signature->num_slurpy
413             ) {
414 1         4 my $var = $self->variable;
415 1         4 my $opt_pos_var = $signature->optional_positional_parameters->[-1]
416             ->variable;
417 1         6 sig_parsing_error("Required positional parameter '$var' cannot follow an optional positional parameter '$opt_pos_var'");
418             }
419             }
420              
421 290         409 return 1;
422             }
423              
424             1;