/usr/share/perl5/Method/Signatures/Parser.pm is in libmethod-signatures-perl 20131010-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 | package Method::Signatures::Parser;
use strict;
use warnings;
use Carp;
use base qw(Exporter);
our @EXPORT = qw(split_proto split_parameter extract_invocant sig_parsing_error carp_location_for);
sub split_proto {
my $proto = shift;
return unless $proto =~ /\S/;
local $@ = undef;
my $ppi = __PACKAGE__->new_ppi_doc(\$proto);
$ppi->prune('PPI::Token::Comment');
my $statement = $ppi->find_first("PPI::Statement");
sig_parsing_error("Could not understand parameter list specification: $proto")
unless $statement;
my $token = $statement->first_token;
my @proto = ('');
do {
if( $token->class eq "PPI::Token::Operator" and $token->content eq ',' ) {
push @proto, '';
}
else {
$proto[-1] .= $token->content;
}
$token = $token->class eq 'PPI::Token::Label' ? $token->next_token : $token->next_sibling;
} while( $token );
strip_ws($_) for @proto;
# Remove blank entries due to trailing comma.
@proto = grep { /\S/ } @proto;
return @proto;
}
# Extract an invocant, if one is present...
my $IDENTIFIER = qr{ [^\W\d] \w* }x;
sub extract_invocant {
my ($param_ref) = @_;
if ($$param_ref =~ s{ ^ (\$ $IDENTIFIER) \s* : \s* }{}x) {
return $1;
}
return;
}
sub strip_ws {
$_[0] =~ s{^\s+}{};
$_[0] =~ s{\s+$}{};
}
# Generate cleaner error messages...
sub carp_location_for {
my ($class, $target) = @_;
$target = qr{(?!)} if !$target;
# using @CARP_NOT here even though we're not using Carp
# who knows? maybe someday Carp will be capable of doing what we want
# until then, we're rolling our own, but @CARP_NOT is still serving roughly the same purpose
our @CARP_NOT;
local @CARP_NOT;
push @CARP_NOT, 'Method::Signatures';
push @CARP_NOT, $class unless $class =~ /^${\__PACKAGE__}(::|$)/;
push @CARP_NOT, qw< Class::MOP Moose Mouse Devel::Declare >;
# Skip any package in the @CARP_NOT list or their sub packages.
my $carp_not_list_re = join '|', @CARP_NOT;
my $skip = qr/^ $carp_not_list_re (?: :: | $ ) /x;
my $level = 0;
my ($pack, $file, $line, $method);
do {
($pack, $file, $line, $method) = caller(++$level);
} while $method !~ $target and $method =~ /$skip/ or $pack =~ /$skip/;
return ($file, $line, $method);
}
sub new_ppi_doc {
my $class = shift;
my $source = shift;
require PPI;
my $ppi = PPI::Document->new($source) or
sig_parsing_error("source '$$source' cannot be parsed by PPI: " . PPI::Document->errstr);
return $ppi;
}
sub sig_parsing_error {
my ($file, $line) = carp_location_for(__PACKAGE__, 'Devel::Declare::linestr_callback');
my $msg = join('', @_, " in declaration at $file line $line.\n");
die($msg);
}
1;
|