Commit | Line | Data |
3fea05b9 |
1 | package Parse::Method::Signatures; |
2 | |
3 | use Moose; |
4 | use MooseX::Types::Moose qw/ |
5 | ArrayRef HashRef ScalarRef CodeRef Int Str ClassName |
6 | /; |
7 | |
8 | use PPI; |
9 | use Moose::Util::TypeConstraints; |
10 | use Parse::Method::Signatures::ParamCollection; |
11 | use Parse::Method::Signatures::Types qw/ |
12 | PositionalParam NamedParam UnpackedParam |
13 | /; |
14 | |
15 | use Carp qw/croak/; |
16 | |
17 | use namespace::clean -except => 'meta'; |
18 | our $VERSION = '1.003012'; |
19 | our $ERROR_LEVEL = 0; |
20 | our %LEXTABLE; |
21 | our $DEBUG = $ENV{PMS_DEBUG} || 0; |
22 | |
23 | # Setup what we need for specific PPI subclasses |
24 | @PPI::Token::EOF::ISA = 'PPI::Token'; |
25 | |
26 | class_type "PPI::Document"; |
27 | class_type "PPI::Element"; |
28 | |
29 | has 'input' => ( |
30 | is => 'ro', |
31 | isa => Str, |
32 | required => 1 |
33 | ); |
34 | |
35 | has 'offset' => ( |
36 | is => 'rw', |
37 | isa => Int, |
38 | default => 0, |
39 | ); |
40 | |
41 | has 'signature_class' => ( |
42 | is => 'ro', |
43 | isa => Str, |
44 | default => 'Parse::Method::Signatures::Sig', |
45 | ); |
46 | |
47 | has 'param_class' => ( |
48 | is => 'ro', |
49 | isa => Str, |
50 | default => 'Parse::Method::Signatures::Param', |
51 | ); |
52 | |
53 | has 'type_constraint_class' => ( |
54 | is => 'ro', |
55 | isa => Str, |
56 | default => 'Parse::Method::Signatures::TypeConstraint', |
57 | ); |
58 | |
59 | has 'type_constraint_callback' => ( |
60 | is => 'ro', |
61 | isa => CodeRef, |
62 | predicate => 'has_type_constraint_callback', |
63 | ); |
64 | |
65 | has 'from_namespace' => ( |
66 | is => 'rw', |
67 | isa => ClassName, |
68 | predicate => 'has_from_namespace' |
69 | ); |
70 | |
71 | has 'ppi_doc' => ( |
72 | is => 'ro', |
73 | isa => 'PPI::Document', |
74 | lazy_build => 1, |
75 | builder => 'parse', |
76 | ); |
77 | |
78 | # A bit dirty, but we set this with local most of the time |
79 | has 'ppi' => ( |
80 | is => 'ro', |
81 | isa => 'PPI::Element', |
82 | lazy_build => 1, |
83 | writer => '_set_ppi' |
84 | ); |
85 | |
86 | sub BUILD { |
87 | my ($self) = @_; |
88 | |
89 | Class::MOP::load_class($_) |
90 | for map { $self->$_ } qw/ |
91 | signature_class |
92 | param_class |
93 | type_constraint_class |
94 | /; |
95 | |
96 | my $ppi = $self->ppi; |
97 | |
98 | # Skip leading whitespace |
99 | $self->consume_token |
100 | unless $ppi->significant; |
101 | } |
102 | |
103 | sub create_param { |
104 | my ($self, $args) = @_; |
105 | |
106 | my @traits; |
107 | push @traits, $args->{ variable_name } ? 'Bindable' : 'Placeholder' |
108 | if !exists $args->{unpacking}; |
109 | push @traits, $args->{ named } ? 'Named' : 'Positional'; |
110 | push @traits, 'Unpacked::' . $args->{unpacking} |
111 | if exists $args->{unpacking}; |
112 | |
113 | return $self->param_class->new_with_traits(traits => \@traits, %{ $args }); |
114 | } |
115 | |
116 | override BUILDARGS => sub { |
117 | my $class = shift; |
118 | |
119 | return { input => $_[0] } if @_ == 1 and !ref $_[0]; |
120 | |
121 | return super(); |
122 | }; |
123 | |
124 | sub parse { |
125 | my ($self) = @_; |
126 | |
127 | my $input = substr($self->input, $self->offset); |
128 | my $doc = PPI::Document->new(\$input); |
129 | |
130 | # Append the magic EOF Token |
131 | $doc->add_element(PPI::Token::EOF->new("")); |
132 | |
133 | # Annoyingly "m($x)" gets treated as a regex operator. This isn't what we |
134 | # want. so replace it with a Word, then a list. The way we do this is by |
135 | # taking the operator off the front, then reparsing the rest of the content |
136 | # This will look the same (so wont affect anything in a code block) but is |
137 | # just store different token wise. |
138 | $self->_replace_regexps($doc); |
139 | |
140 | # ($, $x) parses the $, as a single var. not what we want. FIX UP |
141 | # While we're att it lets fixup $: $? and $! |
142 | $self->_replace_magic($doc); |
143 | |
144 | # (Str :$x) yields a label of "Str :" |
145 | # (Foo Bar :$x) yields a label of "Bar :" |
146 | $self->_replace_labels($doc); |
147 | |
148 | # This one is actually a bug in PPI, rather than just an odity |
149 | # (Str $x = 0xfF) parses as "Oxf" and a word of "F" |
150 | $self->_fixup_hex($doc); |
151 | |
152 | return $doc; |
153 | } |
154 | |
155 | sub _replace_regexps { |
156 | my ($self, $doc) = @_; |
157 | |
158 | REGEXP: |
159 | foreach my $node ( @{ $doc->find('Token::Regexp') || [] } ) { |
160 | my $str = $node->content; |
161 | |
162 | next REGEXP unless defined $node->{operator}; |
163 | |
164 | # Rather annoyingly, there are *no* methods on Token::Regexp; |
165 | my ($word, $rest) = $str =~ /^(\Q@{[$node->{operator}]}\E)(.*)$/s; |
166 | |
167 | my $subdoc = PPI::Document->new(\$rest); |
168 | my @to_add = reverse map { $_->remove } $subdoc->children; |
169 | push @to_add, new PPI::Token::Word($word); |
170 | # insert_after restricts what you can insert. |
171 | # $node->insert_after($_) for @to_add; |
172 | $node->__insert_after($_) for @to_add; |
173 | |
174 | $node->delete; |
175 | } |
176 | } |
177 | |
178 | |
179 | sub _replace_magic { |
180 | my ($self, $doc) = @_; |
181 | |
182 | foreach my $node ( @{ $doc->find('Token::Magic') || [] } ) { |
183 | my ($op) = $node->content =~ /^\$([,?:!)])$/ or next; |
184 | |
185 | $node->insert_after(new PPI::Token::Operator($op)); |
186 | $node->insert_after(new PPI::Token::Cast('$')); |
187 | $node->delete; |
188 | } |
189 | } |
190 | |
191 | sub _replace_labels { |
192 | my ($self, $doc) = @_; |
193 | |
194 | foreach my $node ( @{ $doc->find('Token::Label') || [] } ) { |
195 | my ($word, $ws) = $node->content =~ /^(.*?)(\s+)?:$/s or next; |
196 | |
197 | $node->insert_after(new PPI::Token::Operator(':')); |
198 | $node->insert_after(new PPI::Token::Whitespace($ws)) if defined $ws; |
199 | $node->insert_after(new PPI::Token::Word($word)); |
200 | $node->delete; |
201 | } |
202 | } |
203 | |
204 | sub _fixup_hex { |
205 | my ($self, $doc) = @_; |
206 | |
207 | foreach my $node ( @{ $doc->find('Token::Number::Hex') || [] } ) { |
208 | my $next = $node->next_token; |
209 | next unless $next->isa('PPI::Token::Word') |
210 | && $next->content =~ /^[0-9a-f]+$/i; |
211 | |
212 | $node->add_content($next->content); |
213 | $next->delete; |
214 | } |
215 | } |
216 | |
217 | sub _build_ppi { |
218 | my ($self) = @_; |
219 | my $ppi = $self->ppi_doc->first_token; |
220 | |
221 | if ($ppi->class eq 'PPI::Token::Word' && exists $LEXTABLE{"$ppi"}) { |
222 | bless $ppi, "PPI::Token::LexSymbol"; |
223 | $ppi->{lex} = $LEXTABLE{"$ppi"}; |
224 | } |
225 | return $ppi; |
226 | } |
227 | |
228 | # signature: O_PAREN |
229 | # invocant |
230 | # params |
231 | # C_PAREN |
232 | # |
233 | # invocant: param ':' |
234 | # |
235 | # params: param COMMA params |
236 | # | param |
237 | # | /* NUL */ |
238 | sub signature { |
239 | my $self = shift; |
240 | |
241 | $self = $self->new(@_) unless blessed($self); |
242 | |
243 | $self->assert_token('('); |
244 | |
245 | my $args = {}; |
246 | my $params = []; |
247 | |
248 | my $param = $self->param; |
249 | |
250 | if ($param && $self->ppi->content eq ':') { |
251 | # That param was actualy the invocant |
252 | $args->{invocant} = $param; |
253 | croak "Invocant cannot be named" |
254 | if NamedParam->check($param); |
255 | croak "Invocant cannot be optional" |
256 | if !$param->required; |
257 | croak "Invocant cannot have a default value" |
258 | if $param->has_default_value; |
259 | |
260 | croak "Invocant must be a simple scalar" |
261 | if UnpackedParam->check($param) || $param->sigil ne '$'; |
262 | |
263 | $self->consume_token; |
264 | $param = $self->param; |
265 | |
266 | } |
267 | |
268 | if ($param) { |
269 | push @$params, $param; |
270 | |
271 | my $greedy = $param->sigil ne '$' ? $param : undef; |
272 | my $opt_pos_param = !$param->required; |
273 | |
274 | while ($self->ppi->content eq ',') { |
275 | $self->consume_token; |
276 | |
277 | my $err_ctx = $self->ppi; |
278 | $param = $self->param; |
279 | $self->error($err_ctx, "Parameter expected") |
280 | if !$param; |
281 | |
282 | my $is_named = NamedParam->check($param); |
283 | if (!$is_named) { |
284 | if ($param->required && $opt_pos_param) { |
285 | $self->error($err_ctx, "Invalid: Required positional param " . |
286 | " found after optional one"); |
287 | } |
288 | if ($greedy) { |
289 | croak "Invalid: Un-named parameter '" . $param->variable_name |
290 | . "' after greedy '" |
291 | . $greedy->variable_name . "'\n"; |
292 | } |
293 | } |
294 | |
295 | push @$params, $param; |
296 | $opt_pos_param = $opt_pos_param || !$param->required; |
297 | $greedy = $param->sigil ne '$' ? $param : undef; |
298 | } |
299 | } |
300 | |
301 | $self->assert_token(')'); |
302 | $args->{params} = $params; |
303 | |
304 | my $sig = $self->signature_class->new($args); |
305 | |
306 | return $sig; |
307 | } |
308 | |
309 | |
310 | # param: tc? |
311 | # var |
312 | # (OPTIONAL|REQUIRED)? |
313 | # default? |
314 | # where* |
315 | # trait* |
316 | # |
317 | # where: WHERE <code block> |
318 | # |
319 | # trait: TRAIT class |
320 | # |
321 | # var : COLON label '(' var_or_unpack ')' # label is classish, with only /a-z0-9_/i allowed |
322 | # | COLON VAR |
323 | # | var_or_unpack |
324 | # |
325 | # var_or_unpack : '[' param* ']' # should all be required + un-named |
326 | # | '{' param* '}' # Should all be named |
327 | # | VAR |
328 | # |
329 | # OPTIONAL: '?' |
330 | # REQUIRED: '!' |
331 | sub param { |
332 | my $self = shift; |
333 | my $class_meth; |
334 | unless (blessed($self)) { |
335 | $self = $self->new(@_) unless blessed($self); |
336 | $class_meth = 1; |
337 | } |
338 | |
339 | # Also used to check if a anything has been consumed |
340 | my $err_ctx = $self->ppi; |
341 | |
342 | my $param = { |
343 | required => 1, |
344 | }; |
345 | |
346 | $self->_param_typed($param); |
347 | |
348 | $self->_param_opt_or_req( |
349 | $self->_param_labeled($param) |
350 | || $self->_param_named($param) |
351 | || $self->_param_variable($param) |
352 | || $self->_unpacked_param($param) |
353 | ) or ($err_ctx == $self->ppi and return) |
354 | or $self->error($err_ctx); |
355 | |
356 | $self->_param_default($param); |
357 | $self->_param_constraint_or_traits($param); |
358 | |
359 | $param = $self->create_param($param); |
360 | |
361 | return !$class_meth |
362 | ? $param |
363 | : wantarray |
364 | ? ($param, $self->remaining_input) |
365 | : $param; |
366 | } |
367 | |
368 | sub _param_opt_or_req { |
369 | my ($self, $param) = @_; |
370 | |
371 | return unless $param; |
372 | |
373 | if ($self->ppi->class eq 'PPI::Token::Operator') { |
374 | my $c = $self->ppi->content; |
375 | if ($c eq '?') { |
376 | $param->{required} = 0; |
377 | $self->consume_token; |
378 | } elsif ($c eq '!') { |
379 | $param->{required} = 1; |
380 | $self->consume_token; |
381 | } |
382 | } |
383 | return $param; |
384 | |
385 | } |
386 | |
387 | sub _param_constraint_or_traits { |
388 | my ($self, $param) = @_; |
389 | |
390 | while ($self->_param_where($param) || |
391 | $self->_param_traits($param) ) { |
392 | # No op; |
393 | |
394 | } |
395 | return $param; |
396 | } |
397 | |
398 | sub _param_where { |
399 | my ($self, $param) = @_; |
400 | |
401 | return unless $self->ppi->isa('PPI::Token::LexSymbol') |
402 | && $self->ppi->lex eq 'WHERE'; |
403 | |
404 | $self->consume_token; |
405 | |
406 | $param->{constraints} ||= []; |
407 | |
408 | my $ppi = $self->ppi; |
409 | |
410 | $self->error($ppi, "Block expected after where") |
411 | unless $ppi->class eq 'PPI::Token::Structure' |
412 | && $ppi->content eq '{'; |
413 | |
414 | # Go from token to block |
415 | $ppi = $ppi->parent; |
416 | |
417 | $ppi->finish or $self->error($ppi, |
418 | "Runaway '" . $ppi->braces . "' in " . $self->_parsing_area(1), 1); |
419 | |
420 | push @{$param->{constraints}}, $ppi->content; |
421 | |
422 | $self->_set_ppi($ppi->finish); |
423 | $self->consume_token; |
424 | return $param; |
425 | } |
426 | |
427 | sub _param_traits { |
428 | my ($self, $param) = @_; |
429 | return unless $self->ppi->isa('PPI::Token::LexSymbol') |
430 | && $self->ppi->lex eq 'TRAIT'; |
431 | |
432 | my $op = $self->consume_token->content; |
433 | |
434 | $self->error($self->ppi, "Error parsing parameter trait") |
435 | unless $self->ppi->isa('PPI::Token::Word'); |
436 | |
437 | $param->{param_traits} ||= []; |
438 | |
439 | push @{$param->{param_traits}}, [$op, $self->consume_token->content]; |
440 | return $param; |
441 | } |
442 | |
443 | sub _param_labeled { |
444 | my ($self, $param) = @_; |
445 | |
446 | return unless |
447 | $self->ppi->content eq ':' && |
448 | $self->ppi->next_token->isa('PPI::Token::Word'); |
449 | |
450 | $self->consume_token; |
451 | |
452 | $self->error($self->ppi, "Invalid label") |
453 | if $self->ppi->content =~ /[^-\w]/; |
454 | |
455 | $param->{named} = 1; |
456 | $param->{required} = 0; |
457 | $param->{label} = $self->consume_token->content; |
458 | |
459 | $self->assert_token('('); |
460 | $self->_unpacked_param($param) |
461 | || $self->_param_variable($param) |
462 | || $self->error($self->ppi); |
463 | |
464 | $self->assert_token(')'); |
465 | |
466 | return $param; |
467 | } |
468 | |
469 | sub _unpacked_param { |
470 | my ($self, $param) = @_; |
471 | |
472 | return $self->bracketed('[', \&unpacked_array, $param) || |
473 | $self->bracketed('{', \&unpacked_hash, $param); |
474 | } |
475 | |
476 | sub _param_named { |
477 | my ($self, $param) = @_; |
478 | |
479 | return unless |
480 | $self->ppi->content eq ':' && |
481 | $self->ppi->next_token->isa('PPI::Token::Symbol'); |
482 | |
483 | $param->{required} = 0; |
484 | $param->{named} = 1; |
485 | $self->consume_token; |
486 | |
487 | my $err_ctx = $self->ppi; |
488 | $param = $self->_param_variable($param); |
489 | |
490 | $self->error($err_ctx, "Arrays or hashes cannot be named") |
491 | if $param->{sigil} ne '$'; |
492 | |
493 | return $param; |
494 | } |
495 | |
496 | sub _param_typed { |
497 | my ($self, $param) = @_; |
498 | |
499 | my $tc = $self->tc |
500 | or return; |
501 | |
502 | |
503 | $tc = $self->type_constraint_class->new( |
504 | ppi => $tc, |
505 | ( $self->has_type_constraint_callback |
506 | ? (tc_callback => $self->type_constraint_callback) |
507 | : () |
508 | ), |
509 | ( $self->has_from_namespace |
510 | ? ( from_namespace => $self->from_namespace ) |
511 | : () |
512 | ), |
513 | ); |
514 | $param->{type_constraints} = $tc; |
515 | |
516 | return $param; |
517 | } |
518 | |
519 | sub _param_default { |
520 | my ($self, $param) = @_; |
521 | |
522 | return unless $self->ppi->content eq '='; |
523 | |
524 | $self->consume_token; |
525 | |
526 | $param->{default_value} = |
527 | $self->_consume_if_isa(qw/ |
528 | PPI::Token::QuoteLike |
529 | PPI::Token::Number |
530 | PPI::Token::Quote |
531 | PPI::Token::Symbol |
532 | PPI::Token::Magic |
533 | PPI::Token::ArrayIndex |
534 | /) || |
535 | $self->bracketed('[') || |
536 | $self->bracketed('{') |
537 | or $self->error($self->ppi); |
538 | |
539 | $param->{default_value} = $param->{default_value}->content; |
540 | } |
541 | |
542 | |
543 | sub _param_variable { |
544 | my ($self, $param) = @_; |
545 | |
546 | my $ppi = $self->ppi; |
547 | my $class = $ppi->class; |
548 | return unless $class eq 'PPI::Token::Symbol' |
549 | || $class eq 'PPI::Token::Cast'; |
550 | |
551 | if ($class eq 'PPI::Token::Symbol') { |
552 | $ppi->symbol_type eq $ppi->raw_type or $self->error($ppi); |
553 | |
554 | $param->{sigil} = $ppi->raw_type; |
555 | $param->{variable_name} = $self->consume_token->content; |
556 | } else { |
557 | $param->{sigil} = $self->consume_token->content; |
558 | } |
559 | |
560 | return $param; |
561 | } |
562 | |
563 | sub unpacked_hash { |
564 | my ($self, $list, $param) = @_; |
565 | |
566 | my $params = []; |
567 | while ($self->ppi->content ne '}') { |
568 | my $errctx = $self->ppi; |
569 | my $p = $self->param |
570 | or $self->error($self->ppi); |
571 | |
572 | $self->error($errctx, "Cannot have positional parameters in an unpacked-array") |
573 | if $p->sigil eq '$' && PositionalParam->check($p); |
574 | push @$params, $p; |
575 | |
576 | last if $self->ppi->content eq '}'; |
577 | $self->assert_token(','); |
578 | } |
579 | $param->{params} = $params; |
580 | $param->{sigil} = '$'; |
581 | $param->{unpacking} = 'Hash'; |
582 | return $param; |
583 | } |
584 | |
585 | sub unpacked_array { |
586 | my ($self, $list, $param) = @_; |
587 | |
588 | my $params = []; |
589 | while ($self->ppi->content ne ']') { |
590 | my $watermark = $self->ppi; |
591 | my $param = $self->param |
592 | or $self->error($self->ppi); |
593 | |
594 | $self->error($watermark, "Cannot have named parameters in an unpacked-array") |
595 | if NamedParam->check($param); |
596 | |
597 | $self->error($watermark, "Cannot have optional parameters in an unpacked-array") |
598 | unless $param->required; |
599 | |
600 | push @$params, $param; |
601 | |
602 | last if $self->ppi->content eq ']'; |
603 | $self->assert_token(','); |
604 | } |
605 | $param->{params} = $params; |
606 | $param->{sigil} = '$'; |
607 | $param->{unpacking} = 'Array'; |
608 | return $param; |
609 | } |
610 | |
611 | sub tc { |
612 | my ($self, $required) = @_; |
613 | |
614 | my $ident = $self->_ident; |
615 | |
616 | $ident or ($required and $self->error($self->ppi)) or return; |
617 | |
618 | return $self->_tc_union( |
619 | $self->bracketed('[', \&_tc_params, $ident) |
620 | || $ident->clone |
621 | ); |
622 | } |
623 | |
624 | # Handle parameterized TCs. e.g.: |
625 | # ArrayRef[Str] |
626 | # Dict[Str => Str] |
627 | # Dict["foo bar", Baz] |
628 | sub _tc_params { |
629 | my ($self, $list, $tc) = @_; |
630 | |
631 | my $new = PPI::Statement::Expression::TCParams->new($tc->clone); |
632 | |
633 | return $new if $self->ppi->content eq ']'; |
634 | |
635 | $new->add_element($self->_tc_param); |
636 | |
637 | while ($self->ppi->content =~ /^,|=>$/ ) { |
638 | |
639 | my $op = $self->consume_token; |
640 | $self->_stringify_last($new) if $op->content eq '=>'; |
641 | |
642 | $new->add_element($self->tc(1)); |
643 | } |
644 | |
645 | return $new; |
646 | } |
647 | |
648 | # Valid token for individual component of parameterized TC |
649 | sub _tc_param { |
650 | my ($self) = @_; |
651 | |
652 | (my $class = $self->ppi->class) =~ s/^PPI:://; |
653 | return $self->consume_token->clone |
654 | if $class eq 'Token::Number' || |
655 | $class =~ /^Token::Quote::(?:Single|Double|Literal|Interpolate)/; |
656 | |
657 | return $self->tc(1); |
658 | } |
659 | |
660 | sub _tc_union { |
661 | my ($self, $tc) = @_; |
662 | |
663 | return $tc unless $self->ppi->content eq '|'; |
664 | |
665 | my $union = PPI::Statement::Expression::TCUnion->new; |
666 | $union->add_element($tc); |
667 | while ( $self->ppi->content eq '|' ) { |
668 | |
669 | $self->consume_token; |
670 | $union->add_element($self->tc(1)); |
671 | } |
672 | |
673 | return $union; |
674 | } |
675 | |
676 | # Stringify LHS of fat comma |
677 | sub _stringify_last { |
678 | my ($self, $list) = @_; |
679 | my $last = $list->last_token; |
680 | return unless $last->isa('PPI::Token::Word'); |
681 | |
682 | # Is this conditional on the content of the word? |
683 | bless $last, "PPI::Token::StringifiedWord"; |
684 | return $list; |
685 | } |
686 | |
687 | # Handle the boring bits of bracketed product, then call $code->($self, ...) |
688 | sub bracketed { |
689 | my ($self, $type, $code, @args) = @_; |
690 | |
691 | local $ERROR_LEVEL = $ERROR_LEVEL + 1; |
692 | my $ppi = $self->ppi; |
693 | return unless $ppi->content eq $type; |
694 | |
695 | $self->consume_token; # consume '['; |
696 | |
697 | # Get from the '[' token the to Strucure::Constructor |
698 | $ppi = $ppi->parent; |
699 | |
700 | $ppi->finish or $self->error($ppi, |
701 | "Runaway '" . $ppi->braces . "' in " . $self->_parsing_area(1), 1); |
702 | |
703 | |
704 | my $ret; |
705 | if ($code) { |
706 | my $list = PPI::Structure::Constructor->new($ppi->start->clone); |
707 | $ret = $code->($self, $list, @args); |
708 | |
709 | $self->error($self->ppi) |
710 | if $self->ppi != $ppi->finish; |
711 | |
712 | # There is no public way to do this as of PPI 1.204_06. I'll add one to the |
713 | # next release, 1.205 (or so) |
714 | $list->{finish} = $self->consume_token->clone; |
715 | } else { |
716 | # Just clone the entire [] or {} |
717 | $ret = $ppi->clone; |
718 | $self->_set_ppi($ppi->finish); |
719 | $self->consume_token; |
720 | } |
721 | |
722 | return $ret; |
723 | } |
724 | |
725 | # Work out what sort of production we are in for sane default error messages |
726 | sub _parsing_area { |
727 | shift; |
728 | my $height = shift || 0; |
729 | my (undef, undef, undef, $sub) = caller($height+$ERROR_LEVEL); |
730 | |
731 | return "type constraint" if $sub =~ /(?:\b|_)tc(?:\b|_)/; |
732 | return "unpacked parameter" |
733 | if $sub =~ /(?:\b|_)unpacked(?:\b|_)/; |
734 | return "parameter" if $sub =~ /(?:\b|_)param(?:\b|_)/; |
735 | return "signature" if $sub =~ /(?:\b|_)signature(?:\b|_)/; |
736 | |
737 | " unknown production ($sub)"; |
738 | } |
739 | |
740 | # error(PPI::Token $token, Str $msg?, Bool $no_in = 0) |
741 | sub error { |
742 | my ($self, $token, $msg, $no_in) = @_; |
743 | |
744 | $msg = "Error parsing " . $self->_parsing_area(2) |
745 | unless ($msg); |
746 | |
747 | |
748 | $msg = $msg . " near '$token'" . |
749 | ($no_in ? "" |
750 | : " in '" . $token->statement . "'" |
751 | ); |
752 | |
753 | if ($DEBUG) { |
754 | Carp::confess($msg); |
755 | } else { |
756 | Carp::croak($msg); |
757 | } |
758 | } |
759 | |
760 | sub assert_token { |
761 | my ($self, $need, $msg) = @_; |
762 | |
763 | if ($self->ppi->content ne $need) { |
764 | $self->error($self->ppi, "'$need' expected whilst parsing " . $self->_parsing_area(2)); |
765 | } |
766 | return $self->consume_token; |
767 | } |
768 | |
769 | |
770 | %LEXTABLE = ( |
771 | where => 'WHERE', |
772 | is => 'TRAIT', |
773 | does => 'TRAIT', |
774 | ); |
775 | |
776 | sub _ident { |
777 | my ($self) = @_; |
778 | |
779 | my $ppi = $self->ppi; |
780 | return $self->consume_token |
781 | if $ppi->class eq 'PPI::Token::Word'; |
782 | return undef; |
783 | } |
784 | |
785 | sub _consume_if_isa { |
786 | my ($self, @classes) = @_; |
787 | |
788 | for (@classes) { |
789 | return $self->consume_token |
790 | if $self->ppi->isa($_); |
791 | } |
792 | |
793 | } |
794 | |
795 | sub consume_token { |
796 | my ($self) = @_; |
797 | |
798 | my $ppi = $self->ppi; |
799 | my $ret = $ppi; |
800 | |
801 | while (!$ppi->isa('PPI::Token::EOF') ) { |
802 | $ppi = $ppi->next_token; |
803 | last if $ppi->significant; |
804 | } |
805 | |
806 | if ($ppi->class eq 'PPI::Token::Word' && exists $LEXTABLE{"$ppi"}) { |
807 | bless $ppi, "PPI::Token::LexSymbol"; |
808 | $ppi->{lex} = $LEXTABLE{"$ppi"}; |
809 | } |
810 | $self->_set_ppi( $ppi ); |
811 | return $ret; |
812 | } |
813 | |
814 | sub remaining_input { |
815 | my $tok = $_[0]->ppi; |
816 | my $buff; |
817 | |
818 | while ( !$tok->isa('PPI::Token::EOF') ) { |
819 | $buff .= $tok->content; |
820 | $tok = $tok->next_token; |
821 | } |
822 | return $buff; |
823 | } |
824 | |
825 | __PACKAGE__->meta->make_immutable; |
826 | |
827 | |
828 | # Extra PPI classes to represent what we want. |
829 | { package |
830 | PPI::Statement::Expression::TCUnion; |
831 | use base 'PPI::Statement::Expression'; |
832 | |
833 | sub content { |
834 | join('|', $_[0]->children ); |
835 | } |
836 | } |
837 | |
838 | { package |
839 | PPI::Statement::Expression::TCParams; |
840 | |
841 | use base 'PPI::Statement::Expression'; |
842 | use Moose; |
843 | |
844 | # $self->children stores everything so PPI cna track parents |
845 | # params just contains the keywords (not commas) inside the [] |
846 | has type => ( is => 'ro'); |
847 | has params => ( |
848 | is => 'ro', |
849 | default => sub { [] }, |
850 | ); |
851 | |
852 | sub new { |
853 | my ($class, $type) = @_; |
854 | |
855 | return $class->meta->new_object( |
856 | __INSTANCE__ => $class->SUPER::new($type), |
857 | type => $type |
858 | ); |
859 | }; |
860 | |
861 | override add_element => sub { |
862 | my ($self, $ele) = @_; |
863 | super(); |
864 | push @{$self->params}, $ele; |
865 | }; |
866 | |
867 | sub content { |
868 | $_[0]->type->content . '[' . join(',', @{$_[0]->params}) . ']' |
869 | } |
870 | |
871 | no Moose; |
872 | } |
873 | |
874 | { package |
875 | PPI::Token::LexSymbol; |
876 | use base 'PPI::Token::Word'; |
877 | |
878 | sub lex { |
879 | my ($self) = @_; |
880 | return $self->{lex} |
881 | } |
882 | } |
883 | |
884 | # Used for LHS of fat comma |
885 | { package |
886 | PPI::Token::StringifiedWord; |
887 | use base 'PPI::Token::Word'; |
888 | |
889 | use Moose; |
890 | override content => sub { |
891 | return '"' . super() . '"'; |
892 | }; |
893 | |
894 | sub string { |
895 | return $_[0]->PPI::Token::Word::content(); |
896 | } |
897 | no Moose; |
898 | } |
899 | |
900 | 1; |
901 | |
902 | __END__ |
903 | |
904 | =head1 NAME |
905 | |
906 | Parse::Method::Signatures - Perl6 like method signature parser |
907 | |
908 | =head1 DESCRIPTION |
909 | |
910 | Inspired by L<Perl6::Signature> but streamlined to just support the subset |
911 | deemed useful for L<TryCatch> and L<MooseX::Method::Signatures>. |
912 | |
913 | =head1 TODO |
914 | |
915 | =over |
916 | |
917 | =item * Document the parameter return types. |
918 | |
919 | =item * Probably lots of other things |
920 | |
921 | =back |
922 | |
923 | =head1 METHODS |
924 | |
925 | There are only two public methods to this module, both of which should be |
926 | called as class methods. Both methods accept either a single (non-ref) scalar |
927 | as the value for the L</input> attribute, or normal new style arguments (hash |
928 | or hash-ref). |
929 | |
930 | =head2 signature |
931 | |
932 | my $sig = Parse::Method::Signatures->signature( '(Str $foo)' ) |
933 | |
934 | Attempts to parse the (bracketed) method signature. Returns a value or croaks |
935 | on error. |
936 | |
937 | =head2 param |
938 | |
939 | my $param = Parse::Method::Signatures->param( 'Str $foo where { length($_) < 10 }') |
940 | |
941 | Attempts to parse the specification for a single parameter. Returns value or |
942 | croaks on error. |
943 | |
944 | =head1 ATTRIBUTES |
945 | |
946 | All the attributes on this class are read-only. |
947 | |
948 | =head2 input |
949 | |
950 | B<Type:> Str |
951 | |
952 | The string to parse. |
953 | |
954 | =head2 offset |
955 | |
956 | B<Type:> Int |
957 | |
958 | Offset into L</input> at which to start parsing. Useful for using with |
959 | Devel::Declare linestring |
960 | |
961 | =head2 signature_class |
962 | |
963 | B<Default:> Parse::Method::Signatures::Sig |
964 | |
965 | B<Type:> Str (loaded on demand class name) |
966 | |
967 | =head2 param_class |
968 | |
969 | B<Default:> Parse::Method::Signatures::Param |
970 | |
971 | B<Type:> Str (loaded on demand class name) |
972 | |
973 | =head2 type_constraint_class |
974 | |
975 | B<Default:> L<Parse::Method::Signatures::TypeConstraint> |
976 | |
977 | B<Type:> Str (loaded on demand class name) |
978 | |
979 | Class that is used to turn the parsed type constraint into an actual |
980 | L<Moose::Meta::TypeConstraint> object. |
981 | |
982 | =head2 from_namespace |
983 | |
984 | B<Type:> ClassName |
985 | |
986 | Let this module know which package it is parsing signatures form. This is |
987 | entirely optional, and the only effect is has is on parsing type constraints. |
988 | |
989 | If this attribute is set it is passed to L</type_constraint_class> which can |
990 | use it to introspect the package (commmonly for L<MooseX::Types> exported |
991 | types). See |
992 | L<Parse::Method::Signature::TypeConstraints/find_registered_constraint> for |
993 | more details. |
994 | |
995 | =head2 type_constraint_callback |
996 | |
997 | B<Type:> CodeRef |
998 | |
999 | Passed to the constructor of L</type_constraint_class>. Default implementation |
1000 | of this callback asks Moose for a type constrain matching the name passed in. |
1001 | If you have more complex requirements, such as parsing types created by |
1002 | L<MooseX::Types> then you will want a callback similar to this: |
1003 | |
1004 | # my $target_package defined elsewhere. |
1005 | my $tc_cb = sub { |
1006 | my ($pms_tc, $name) = @_; |
1007 | my $code = $target_package->can($name); |
1008 | $code ? eval { $code->() } |
1009 | : $pms_tc->find_registered_constraint($name); |
1010 | } |
1011 | |
1012 | Note that the above example is better provided by providing the |
1013 | L</from_namespace> attribute. |
1014 | |
1015 | =head1 CAVEATS |
1016 | |
1017 | Like Perl6::Signature, the parsing of certain constructs is currently only a |
1018 | 'best effort' - specifically default values and where code blocks might not |
1019 | successfully for certain complex cases. Patches/Failing tests welcome. |
1020 | |
1021 | Additionally, default value specifications are not evaluated which means that |
1022 | no such lexical or similar errors will not be produced by this module. |
1023 | Constant folding will also not be performed. |
1024 | |
1025 | There are certain constructs that are simply too much hassle to avoid when the |
1026 | work around is simple. Currently the only cases that are known to parse wrong |
1027 | are when using anonymous variables (i.e. just sigils) in unpacked arrays. Take |
1028 | the following example: |
1029 | |
1030 | method foo (ArrayRef [$, $], $some_value_we_care_about) { |
1031 | |
1032 | In this case the C<$]> is treated as one of perl's magic variables |
1033 | (specifically, the patch level of the Perl interpreter) rather than a C<$> |
1034 | followed by a C<]> as was almost certainly intended. The work around for this |
1035 | is simple: introduce a space between the charcters: |
1036 | |
1037 | method foo (ArrayRef [ $, $ ], $some_value_we_care_about) { |
1038 | |
1039 | The same applies |
1040 | |
1041 | =head1 AUTHOR |
1042 | |
1043 | Ash Berlin <ash@cpan.org>. |
1044 | |
1045 | Thanks to Florian Ragwitz <rafl@debian.org>. |
1046 | |
1047 | Many thanks to Piers Crawley to showing me the way to refactor my spaghetti |
1048 | code into something more manageable. |
1049 | |
1050 | =head1 SEE ALSO |
1051 | |
1052 | L<Devel::Declare> which is used by most modules that use this (currently by |
1053 | all modules known to the author.) |
1054 | |
1055 | L<http://github.com/ashb/trycatch/tree>. |
1056 | |
1057 | =head1 LICENSE |
1058 | |
1059 | Licensed under the same terms as Perl itself. |
1060 | |
1061 | This distribution copyright 2008-2009, Ash Berlin <ash@cpan.org> |
1062 | |