File Coverage

blib/lib/JSON/RPC/Legacy/Procedure.pm

Criterion	Covered	Total	%
statement	9	39	23.0
branch	0	16	0.0
condition	0	5	0.0
subroutine	3	7	42.8
pod	1	1	100.0
total	13	68	19.1

package JSON::RPC::Legacy::Procedure;

#
# http://json-rpc.org/wd/JSON-RPC-1-1-WD-20060807.html
#

$JSON::RPC::Legacy::Procedure::VERSION = '1.04';

use strict;
use attributes;
use Carp ();

my $Procedure = {};


sub check { $Procedure->{$_[0]} ? attributes::get($_[1]) : {}; }


sub FETCH_CODE_ATTRIBUTES {
    my ($pkg, $code) = @_;
    my $procedure = $Procedure->{$pkg}{$code} || { return_type => undef, argument_type => undef };

    return {
        return_type   => $procedure->{return_type},
        argument_type => $procedure->{argument_type},
    };
}


sub MODIFY_CODE_ATTRIBUTES {
    my ($pkg, $code, $attr) = @_;
    my ($ret_type, $args);

    if ($attr =~ /^([A-Z][a-z]+)(?:\(\s*([^)]*)\s*\))?$/) {
        $ret_type = $1 if (defined $1);
        $args     = $2 if (defined $2);
    }

    unless ($ret_type =~ /^Private|Public|Arr|Obj|Bit|Bool|Num|Str|Nil|None/) {
        Carp::croak("Invalid type '$attr'. Specify 'Parivate' or 'Public' or One of JSONRPC Return Types.");
    }

    if ($ret_type ne 'Private' and defined $args) {
        $Procedure->{$pkg}{$code}{argument_type} = _parse_argument_type($args);
    }

    $Procedure->{$pkg}{$code}{return_type} = $ret_type;

    return;
}



sub _parse_argument_type {
    my $text = shift;

    my $declaration;
    my $pos;
    my $name;

    $text =~ /^([,: a-zA-Z0-9]*)?$/;

    unless ( defined($declaration = $1) ) {
        Carp::croak("Invalid argument type.");
    }

    my @args = split/\s*,\s*/, $declaration;

    my $i = 0;

    $pos  = [];
    $name = {};

    for my $arg (@args) {
        if ($arg =~ /([_0-9a-zA-Z]+)(?::([a-z]+))?/) {
            push @$pos, $1;
            $name->{$1} = $2;
        }
    }

    return {
        position    => $pos,
        names       => $name,
    };
}



1;
__END__