local-lib5/lib/perl5/Parse/Method/Signatures.pm

   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