File Coverage

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

Criterion	Covered	Total	%
statement	19	108	17.5
branch	0	68	0.0
condition	0	14	0.0
subroutine	7	33	21.2
pod	9	12	75.0
total	35	235	14.8

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

use strict;
use JSON ();
use Carp ();

##############################################################################

package JSON::RPC::Legacy::Client;

$JSON::RPC::Legacy::Client::VERSION = '0.93';

use LWP::UserAgent;


BEGIN {
    for my $method (qw/uri ua json content_type version id allow_call status_line/) {
        eval qq|
            sub $method {
                \$_[0]->{$method} = \$_[1] if defined \$_[1];
                \$_[0]->{$method};
            }
        |;
    }
}



sub AUTOLOAD {
    my $self   = shift;
    my $method = $JSON::RPC::Legacy::Client::AUTOLOAD;

    $method =~ s/.*:://;

    return if ($method eq 'DESTROY');

    $method =~ s/^__(\w+)__$/$1/;  # avoid to call built-in methods (ex. __VERSION__ => VERSION)

    unless ( exists $self->allow_call->{ $method } ) {
        Carp::croak("Can't call the method not allowed by prepare().");
    }

    my @params = @_;
    my $obj = {
        method => $method,
        params => (ref $_[0] ? $_[0] : [@_]),
    };

    my $ret = $self->call($self->uri, $obj);

    if ( $ret and $ret->is_success ) {
        return $ret->result;
    }
    else {
        Carp::croak ( $ret ? '(Procedure error) ' . $ret->error_message : $self->status_line );
    }

}


sub create_json_coder {
    JSON->new->allow_nonref->utf8;
}


sub new {
    my $proto = shift;
    my $self  = bless {}, (ref $proto ? ref $proto : $proto);

    my $ua  = LWP::UserAgent->new(
        agent   => 'JSON::RPC::Legacy::Client/' . $JSON::RPC::Legacy::Client::VERSION . ' beta ',
        timeout => 10,
    );

    $self->ua($ua);
    $self->json( $proto->create_json_coder );
    $self->version('1.1');
    $self->content_type('application/json');

    return $self;
}


sub prepare {
    my ($self, $uri, $procedures) = @_;
    $self->uri($uri);
    $self->allow_call({ map { ($_ => 1) } @$procedures  });
}


sub call {
    my ($self, $uri, $obj) = @_;
    my $result;

    if ($uri =~ /\?/) {
       $result = $self->_get($uri);
    }
    else {
        Carp::croak "not hashref." unless (ref $obj eq 'HASH');
        $result = $self->_post($uri, $obj);
    }

    my $service = $obj->{method} =~ /^system\./ if ( $obj );

    $self->status_line($result->status_line);

    if ($result->is_success) {

        return unless($result->content); # notification?

        if ($service) {
            return JSON::RPC::Legacy::ServiceObject->new($result, $self->json);
        }

        return JSON::RPC::Legacy::ReturnObject->new($result, $self->json);
    }
    else {
        return;
    }
}


sub _post {
    my ($self, $uri, $obj) = @_;
    my $json = $self->json;

    $obj->{version} ||= $self->{version} || '1.1';

    if ($obj->{version} eq '1.0') {
        delete $obj->{version};
        if (exists $obj->{id}) {
            $self->id($obj->{id}) if ($obj->{id}); # if undef, it is notification.
        }
        else {
            $obj->{id} = $self->id || ($self->id('JSON::RPC::Legacy::Client'));
        }
    }
    else {
        $obj->{id} = $self->id if (defined $self->id);
    }

    my $content = $json->encode($obj);

    $self->ua->post(
        $uri,
        Content_Type   => $self->{content_type},
        Content        => $content,
        Accept         => 'application/json',
    );
}


sub _get {
    my ($self, $uri) = @_;
    $self->ua->get(
        $uri,
        Accept         => 'application/json',
    );
}



##############################################################################

package JSON::RPC::Legacy::ReturnObject;

$JSON::RPC::Legacy::ReturnObject::VERSION = $JSON::RPC::Legacy::VERSION;

BEGIN {
    for my $method (qw/is_success content jsontext version/) {
        eval qq|
            sub $method {
                \$_[0]->{$method} = \$_[1] if defined \$_[1];
                \$_[0]->{$method};
            }
        |;
    }
}


sub new {
    my ($class, $obj, $json) = @_;
    my $content = ( $json || JSON->new->utf8 )->decode( $obj->content );

    my $self = bless {
        jsontext  => $obj->content,
        content   => $content,
    }, $class;

    $content->{error} ? $self->is_success(0) : $self->is_success(1);

    $content->{version} ? $self->version(1.1) : $self->version(0) ;

    $self;
}


sub is_error { !$_[0]->is_success; }

sub error_message {
    $_[0]->version ? $_[0]->{content}->{error}->{message} : $_[0]->{content}->{error};
}


sub result {
    $_[0]->{content}->{result};
}


##############################################################################

package JSON::RPC::Legacy::ServiceObject;

use base qw(JSON::RPC::Legacy::ReturnObject);


sub sdversion {
    $_[0]->{content}->{sdversion} || '';
}


sub name {
    $_[0]->{content}->{name} || '';
}


sub result {
    $_[0]->{content}->{summary} || '';
}



1;
__END__