File Coverage

blib/lib/Method/Signatures/Simple/ParseKeyword.pm

Criterion	Covered	Total	%
statement	167	207	80.6
branch	27	66	40.9
condition	20	29	68.9
subroutine	25	27	92.5
pod	0	6	0.0
total	239	335	71.3

package Method::Signatures::Simple::ParseKeyword;
$Method::Signatures::Simple::ParseKeyword::VERSION = '1.12';
use warnings;
use strict;

=head1 NAME

Method::Signatures::Simple::ParseKeyword - method and func keywords using Parse::Keyword

=cut

use base 'Exporter';
use Carp qw(croak);
use Sub::Name 'subname';
use Parse::Keyword {};
our @EXPORT;
our %MAP;

sub import {
    my $caller = caller;
    my $class = shift;
    my %args = @_;

    my %kwds;

    my $into = delete $args{into} || $caller;
    my $inv = delete $args{invocant} || '$self';
    my $meth = delete $args{name} || delete $args{method_keyword};
    my $func = delete $args{function_keyword};

    # if no options are provided at all, then we supply defaults
    unless (defined $meth || defined $func) {
        $meth = 'method';
        $func = 'func';
    }

    # input validation
    $inv =~ m/^ \s* \$ [\p{ID_Start}_] \p{ID_Continue}* \s* $/x
        or croak "invocant must be a valid scalar identifier >$inv<";

    if ($func) {
        $func =~ m/^ \s* [\p{ID_Start}_] \p{ID_Continue}* \s* $/x
            or croak "function_keyword must be a valid identifier >$func<";
        no strict 'refs';
        *$func = sub { @_ ? $_[0] : () };
        my $parse = "parse_$func";
        *$parse = sub { my ($kw) = @_; parse_mode($kw); };
        $MAP{$func} = undef;
        $kwds{ $func } = \&$parse;
        push @EXPORT, $func;
    }
    if ($meth) {
        $meth =~ m/^ \s* [\p{ID_Start}_] \p{ID_Continue}* \s* $/x
            or croak "method_keyword must be a valid identifier >$meth<";
        no strict 'refs';
        *$meth = sub { @_ ? $_[0] : () };
        my $parse = "parse_$meth";
        *$parse = sub { my ($kw) = @_; parse_mode($kw); };
        $MAP{$meth} = $inv;
        @kwds{ $meth } = \&$parse;
        push @EXPORT, $meth;
    }

    Parse::Keyword->import(\%kwds);
    for my $e (@EXPORT) {
        my $n = $e =~ s/[$%@]//r;
        my $fn = $into. '::' . $n;
        no strict 'refs';
        *$fn = $e;
        my $k = *$fn; # avoid 'once' warning
    }
}

sub parse_mode {
    my ($keyword, $invocant) = @_;
    $invocant ||= $MAP{$keyword};

    my $name = parse_name();
    my $sig  = parse_signature($invocant);
    my $attr = parse_attributes();
    my $body = parse_body($sig);

    if (defined $name) {
        my $full_name = join('::', compiling_package, $name);
        {
            no strict 'refs';
            *$full_name = subname $full_name, $body;
            if ($attr) {
                use attributes ();
                attributes->import(compiling_package, $body, $_) for @$attr;
            }
        }
        return (sub {}, 1);
    }
    else {
        return (sub { $body }, 0);
    }
}

my $start_rx = qr/^[\p{ID_Start}_]$/;
my $cont_rx  = qr/^\p{ID_Continue}$/;

sub parse_name {
    my $name = '';

    lex_read_space;

    my $char_rx = $start_rx;

    while (1) {
        my $char = lex_peek;
        last unless length $char;
        if ($char =~ $char_rx) {
            $name .= $char;
            lex_read;
            $char_rx = $cont_rx;
        }
        else {
            last;
        }
    }

    return length($name) ? $name : undef;
}

sub parse_signature {
    my ($invocant) = @_;
    lex_read_space;

    my @vars = $invocant ? ({ index => 0, name => $invocant }) : ();
    return \@vars unless lex_peek eq '(';

    my @attr = ();

    lex_read;
    lex_read_space;

    if (lex_peek eq ')') {
        lex_read;
        return \@vars;
    }

    my $seen_slurpy;
    while ((my $sigil = lex_peek) ne ')') {
        my $var = {};
        die "syntax error"
            unless $sigil eq '$' || $sigil eq '@' || $sigil eq '%';
        die "Can't declare parameters after a slurpy parameter"
            if $seen_slurpy;

        $seen_slurpy = 1 if $sigil eq '@' || $sigil eq '%';

        lex_read;
        lex_read_space;
        my $name = parse_name(0);
        lex_read_space;

        $var->{name} = "$sigil$name";

        if (lex_peek eq '=') {
            lex_read;
            lex_read_space;
            $var->{default} = parse_arithexpr;
        }

        $var->{index} = @vars - 1;

        if (lex_peek eq ':') {
            $vars[0] = $var;
            lex_read;
            lex_read_space;
            next;
        }

        push @vars, $var;

        die "syntax error"
            unless lex_peek eq ')' || lex_peek eq ',';

        if (lex_peek eq ',') {
            lex_read;
            lex_read_space;
        }
    }

    lex_read;

    return \@vars;
}

# grabbed these two functions from
# https://metacpan.org/release/PEVANS/XS-Parse-Keyword-0.22/source/hax/lexer-additions.c.inc#L74
sub parse_attribute {
    my $name = parse_name;
    if (lex_peek ne '(') {
        return $name;
    }
    $name .= lex_peek;
    lex_read;
    my $count = 1;
    my $c = lex_peek;
    while($count && length $c) {
        if($c eq '(') {
            $count++;
        }
        if($c eq ')') {
            $count--;
        }
        if($c eq '\\') {
            # The next char does not bump count even if it is ( or );
            # the \\ is still captured
            #
            $name .= $c;
            lex_read;
            $c = lex_peek;
            if(! length $c) {
                goto unterminated;
            }
        }

        # Don't append final closing ')' on split name/val
        $name .= $c;
        lex_read;

        $c = lex_peek;
    }

    if(!length $c) {
        return;
    }

    return $name;

unterminated:
    croak("Unterminated attribute parameter in attribute list");
    return;
}

sub parse_attributes {
    lex_read_space;
    return unless lex_peek eq ':';
    lex_read;
    lex_read_space;
    my @attrs;
    while (my $attr = parse_attribute) {
        push @attrs, $attr;
        lex_read_space;
        if (lex_peek eq ':') {
            lex_read;
            lex_read_space;
        }
    }

    return \@attrs;
}

sub parse_body {
    my ($sigs) = @_;
    my $body;

    lex_read_space;

    if (lex_peek eq '{') {
        local $CAPRPK::{'DEFAULTS::'};
        if ($sigs) {
            lex_read;

            my $preamble = '{';

            # arguments / query params
            my @names = map { $_->{name} } @$sigs;
            $preamble .= 'my (' . join(', ', @names) . ') = @_;';

            my $index = 0;
            for my $var (grep { defined $_->{default} } @$sigs) {
                {
                    no strict 'refs';
                    *{ 'CAPRPK::DEFAULTS::default_' . $index } = sub () {
                        $var->{default}
                    };
                }
                $preamble .= $var->{name} . ' = CAPRPK::DEFAULTS::default_' . $index . '->()' . ' unless ' . $var->{name} . ';';

                $index++;
            }

            $preamble .= "; ();"; # fix for empty method body
            lex_stuff($preamble);
        }
        $body = parse_block;
    }
    else {
        die "syntax error";
    }
    return $body;
}

1;

__END__