JSON-RPC-1.03/000755 000765 000024 00000000000 11766777510 013441 5ustar00daisukestaff000000 000000 JSON-RPC-1.03/Changes000644 000765 000024 00000006145 11766777464 014752 0ustar00daisukestaff000000 000000 Changes ======= 1.03 2012 Jun 15 - Allow die \%hash from handlers (ka2u) 1.02 2012 Jun 14 - Fix the finalization of the response (0xAF) 1.01 2011 Dec 01 - Use require instead of Class::Load. Subclass in your app if you need that kind of ability, but it seems unlikely that we'd need anything more than eval require here. 1.00 2011 Nov 22 - No code change. 1.00_02 2011 Nov 16 - JSON::RPC::Dispatcher already existed on CPAN. s/Dispatcher/Dispatch/g 1.00_01 2011 Nov 16 - New maintainer, completely new code for PSGI apps and JSON RPC 2.0 - If you are using old JSON::RPC code (up to 0.96), DO NOT EXPECT YOUR CODE TO WORK. THIS VERSION IS BACKWARDS INCOMPATIBLE ---------- Old Change Log ----------- Revision history for Perl extension JSON::RPC. ###### In the next large version up ###################################### * JSON::RPC::Server::Apache will be renamed to JSON::RPC::Server::Apache2 and split into another distribution. * JSON::RPC::Server::Apache really supports apache 1.3x and the maintainer will be changed. ########################################################################## 0.96 Mon Feb 25 11:06:25 2008 - JSON::RPC::Server::FastCGI was split into the independent distribution. the new maintainer is Faiz Kazi. - JSON::RPC::Server::Apache was renamed to JSON::RPC::Server::Apache2 it will split into another distribution. - added and updated docs. 0.95 Fri Feb 15 16:01:04 2008 - sample codes were indexed...! fixed package for avoiding the indexer. 0.94 Fri Feb 15 15:16:32 2008 - no change but examples was forgotten. 0.93 Fri Feb 15 14:46:17 2008 - added example codes. - now AUTOLOAD method after prepare() can support built-in methods. $client -> __VERSION__ ( => $client calls the name 'VERSION' procedure ) - Your application can set subroutines allowable by allowable_procedure(). (Thanks to seagull's suggestion) - JSON::RPC::Server::Apache config supports 'return_die_message'. - require LWP::UserAgent 2.001 or later. 0.92 Thu Feb 14 13:12:40 2008 - modified the JSON::RPC::Client prepare mode to check response errors. (Thanks to Colin Meyer) - fixed retrieve_json_from_get in JSON::RPC::Server::CGI. - implemented JSON::RPC::Server::Apache to support the GET method call. - fixed JSON::RPC::ReturnObject decoding JSON data with utf8 mode. ($client -> call() ->result will return Unicode characters (if contained).) - added some descriptions to the JSON::RPC::Client pod. 0.91 Wed Dec 19 15:51:53 2007 - JSON::RPC::Client used JSON::PP. - added create_json_coder() to JSON::RPC::Client. 0.90 Wed Dec 19 13:26:15 2007 - Now default JSON coder is JSON! (1.99 or later) - added JSON::RPC::Server::FastCGI written by Faiz Kazi, thanks! - added JSONRPC for guide to this distribution. - cleaned up JSON::RPC::Server::CGI - added create_json_coder() to JSON::RPC::Server. - modified J::R::Server::* as base.pm does not work well in Perl 5.005 0.01 Mon May 21 14:18:33 2007 - original versionJSON-RPC-1.03/inc/000755 000765 000024 00000000000 11766777510 014212 5ustar00daisukestaff000000 000000 JSON-RPC-1.03/lib/000755 000765 000024 00000000000 11766777510 014207 5ustar00daisukestaff000000 000000 JSON-RPC-1.03/Makefile.PL000644 000765 000024 00000004075 11766402703 015406 0ustar00daisukestaff000000 000000 BEGIN { my @modules = qw( inc::Module::Install Module::Install::Repository ); foreach my $module (@modules) { eval "require $module; $module->import"; if ($@) { push @missing, $module; } } if (@missing) { print STDERR < sub { my $dispatch = JSON::RPC::Dispatch->new(); if (ok $dispatch->coder) { isa_ok $dispatch->coder, 'JSON'; } if (ok $dispatch->router) { isa_ok $dispatch->router, "Router::Simple"; } if (ok $dispatch->parser) { isa_ok $dispatch->parser, "JSON::RPC::Parser"; } }; subtest 'normal dispatch' => sub { my $coder = JSON->new; my $router = Router::Simple->new; $router->connect( blowup => { handler => "Sum", action => "blowup", } ); $router->connect( 'sum' => { handler => 'Sum', action => 'sum', } ); $router->connect( tidy_error => { handler => "Sum", action => "tidy_error", } ); $router->connect( 'sum_obj' => { handler => t::JSON::RPC::Test::Handler::Sum->new, action => 'sum', } ); my $dispatch = JSON::RPC::Dispatch->new( coder => $coder, parser => JSON::RPC::Parser->new( coder => $coder ), prefix => 't::JSON::RPC::Test::Handler', router => $router, ); ok $dispatch, "dispatch ok"; my $request_get = sub { my $cb = shift; my ($req, $res, $json); my $uri = URI->new( "http://localhost" ); # no such method... $uri->query_form( method => 'not_found' ); $req = HTTP::Request->new( GET => $uri ); $res = $cb->( $req ); if (! ok $res->is_success, "response is success") { diag $res->as_string; } $json = $coder->decode( $res->decoded_content ); if ( ! ok $json->{error}, "I should have gotten an error" ) { diag explain $json; } if (! is $json->{error}->{code}, JSON::RPC::Constants::RPC_METHOD_NOT_FOUND(), "code is RPC_METHOD_NOT_FOUND" ) { diag explain $json; } my @params = ( 1, 2, 3, 4, 5 ); foreach my $method ( qw(sum sum_obj) ){ $uri->query_form( method => $method, params => $coder->encode(\@params) ); $req = HTTP::Request->new( GET => $uri ); $res = $cb->( $req ); if (! ok $res->is_success, "response is success") { diag $res->as_string; } $json = $coder->decode( $res->decoded_content ); if (! ok ! $json->{error}, "no errors") { diag explain $json; } my $sum = 0; foreach my $p (@params) { $sum += $p; } is $json->{result}, $sum, "sum matches"; } my $id = time(); $uri->query_form( jsonrpc => '2.0', id => $id, method => 'blowup', params => "fuga", ); $req = HTTP::Request->new( GET => $uri ); $res = $cb->( $req ); if (! ok $res->is_success, "response is success") { diag $res->as_string; } $json = $coder->decode( $res->decoded_content ); is $json->{jsonrpc}, '2.0'; is $json->{id}, $id; ok $json->{error}; }; my $request_post = sub { my $cb = shift; my ($req, $res, $post_content, $json); my $headers = HTTP::Headers->new( Content_Type => 'application/json',); my $uri = URI->new( "http://localhost" ); $post_content = $coder->encode( { method => 'not_found' } ); # no such method... $req = HTTP::Request->new( POST => $uri, $headers, $post_content); $res = $cb->($req); if (! ok $res->is_success, "response is success") { diag $res->as_string; } $json = $coder->decode( $res->decoded_content ); if ( ! ok $json->{error}, "I should have gotten an error" ) { diag explain $json; } if (! is $json->{error}->{code}, JSON::RPC::Constants::RPC_METHOD_NOT_FOUND(), "code is RPC_METHOD_NOT_FOUND" ) { diag explain $json; } my @params = ( 1, 2, 3, 4, 5 ); foreach my $method ( qw(sum sum_obj) ){ $post_content = $coder->encode( { method => $method, params => \@params, }, ); $req = HTTP::Request->new( POST => $uri, $headers, $post_content ); $res = $cb->( $req ); if (! ok $res->is_success, "response is success") { diag $res->as_string; } $json = $coder->decode( $res->decoded_content ); if (! ok ! $json->{error}, "no errors") { diag explain $json; } my $sum = 0; foreach my $p (@params) { $sum += $p; } is $json->{result}, $sum, "sum matches"; } my $id = time(); $post_content = $coder->encode( { jsonrpc => '2.0', id => $id, method => 'blowup', params => "fuga", }, ); $req = HTTP::Request->new( POST => $uri, $headers, $post_content ); $res = $cb->( $req ); if (! ok $res->is_success, "response is success") { diag $res->as_string; } $json = $coder->decode( $res->decoded_content ); is $json->{jsonrpc}, '2.0'; is $json->{id}, $id; ok $json->{error}; }; # XXX I want to test both Plack::Request and raw env, but test_rpc # makes it kinda hard... oh well, it's not /that/ much of a problem test_rpc $dispatch, sub { my $cb = shift; subtest 'JSONRPC via GET' => sub { $request_get->($cb) }; subtest 'JSONRPC via POST' => sub { $request_post->($cb) }; subtest 'JSONRPC Error' => sub { my ($post_content, $req, $res, $json); my $headers = HTTP::Headers->new( Content_Type => 'application/json',); my $uri = URI->new( "http://localhost" ); $post_content = $coder->encode( [ method => "hoge"] ); $req = HTTP::Request->new( POST => $uri, $headers, $post_content ); $res = $cb->($req); $json = $coder->decode( $res->decoded_content ); if (! is $json->{error}->{code}, RPC_INVALID_PARAMS ){ diag explain $json; } $post_content = "{ [[ broken json }"; $req = HTTP::Request->new( POST => $uri, $headers, $post_content ); $res = $cb->($req); $json = $coder->decode( $res->decoded_content ); if (! is $json->{error}->{code}, RPC_PARSE_ERROR ) { diag explain $json; } $post_content = "[]"; $req = HTTP::Request->new( POST => $uri, $headers, $post_content ); $res = $cb->($req); $json = $coder->decode( $res->decoded_content ); if (! is $json->{error}->{code}, RPC_INVALID_REQUEST ){ diag explain $json; } # invalid method 'PUT' $req = HTTP::Request->new( PUT => $uri ); $res = $cb->($req); $json = $coder->decode( $res->decoded_content ); if (! is $json->{error}->{code}, RPC_INVALID_REQUEST ){ diag explain $json; } my $id = time(); $post_content = $coder->encode( { jsonrpc => '2.0', id => $id, method => 'tidy_error', params => "foo", } ); $req = HTTP::Request->new( POST => $uri, $headers, $post_content); $res = $cb->($req); $json = $coder->decode( $res->decoded_content ); if (! is $json->{error}->{code}, RPC_INTERNAL_ERROR) { diag explain $json; } is $json->{error}->{message}, 'short description of the error'; is $json->{error}->{data}, 'additional information about the error'; }; }; }; done_testing; JSON-RPC-1.03/t/003_parser.t000644 000765 000024 00000001461 11766402104 015731 0ustar00daisukestaff000000 000000 use strict; use Test::More; use Plack::Request; use JSON; use_ok "JSON::RPC::Parser"; use_ok "JSON::RPC::Procedure"; subtest 'basic' => sub { my $req = Plack::Request->new( { QUERY_STRING => 'method=sum¶ms=[1,2,3]&id=1', REQUEST_METHOD => "GET", } ); my $parser = JSON::RPC::Parser->new( coder => JSON->new, ); my $procedures = $parser->construct_from_req( $req ); ok $procedures, "procedures is defined"; is @$procedures, 1, "should be 1 procedure"; my $procedure = $procedures->[0]; ok $procedure, "procedure is defined"; isa_ok $procedure, "JSON::RPC::Procedure"; is $procedure->id, 1, "id matches"; is $procedure->method, "sum", "method matches"; is_deeply $procedure->params, [ 1, 2, 3 ], "parameters match"; }; done_testing; JSON-RPC-1.03/t/JSON/000755 000765 000024 00000000000 11766777510 014455 5ustar00daisukestaff000000 000000 JSON-RPC-1.03/t/legacy/000755 000765 000024 00000000000 11766777510 015150 5ustar00daisukestaff000000 000000 JSON-RPC-1.03/t/legacy/00_pod.t000644 000765 000024 00000000231 11766402104 016372 0ustar00daisukestaff000000 000000 use strict; $^W = 1; use Test::More; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok (); JSON-RPC-1.03/t/legacy/01_use.t000644 000765 000024 00000000445 11766402104 016414 0ustar00daisukestaff000000 000000 use Test::More; use strict; BEGIN { plan tests => 1 }; use CGI; use JSON::RPC::Legacy::Client; use JSON::RPC::Legacy::Server; ok(1); # If we made it this far, we're ok. END { warn "\nJSON::RPC::nLegacy::Server::CGI requires CGI.pm (>= 2.9.2)." if(CGI->VERSION < 2.92); } JSON-RPC-1.03/t/legacy/02_server.t000644 000765 000024 00000001016 11766402104 017122 0ustar00daisukestaff000000 000000 use Test::More; use strict; BEGIN { plan tests => 4 }; use JSON::RPC::Legacy::Server; my $server = JSON::RPC::Legacy::Server->new; isa_ok($server, 'JSON::RPC::Legacy::Server'); isa_ok($server->json, 'JSON'); my $test = JSON::RPC::Legacy::Server::Test->new; isa_ok($test, 'JSON::RPC::Legacy::Server'); isa_ok($test->json, 'DummyJSONCoder'); #### package JSON::RPC::Legacy::Server::Test; use base qw(JSON::RPC::Legacy::Server); sub create_json_coder { bless {}, 'DummyJSONCoder'; } JSON-RPC-1.03/t/JSON/RPC/000755 000765 000024 00000000000 11766777510 015101 5ustar00daisukestaff000000 000000 JSON-RPC-1.03/t/JSON/RPC/Test/000755 000765 000024 00000000000 11766777510 016020 5ustar00daisukestaff000000 000000 JSON-RPC-1.03/t/JSON/RPC/Test/Handler/000755 000765 000024 00000000000 11766777510 017375 5ustar00daisukestaff000000 000000 JSON-RPC-1.03/t/JSON/RPC/Test/Handler/Sum.pm000644 000765 000024 00000000703 11766776506 020503 0ustar00daisukestaff000000 000000 package t::JSON::RPC::Test::Handler::Sum; use strict; use Class::Accessor::Lite new => 1; sub blowup { die "I blew up!"; } sub sum { my ($self, $params, $proc, @args) = @_; $params ||= []; my $sum = 0; foreach my $p (@$params) { $sum += $p; } return $sum; } sub tidy_error { die { message => "short description of the error", data => "additional information about the error" }; } 1; JSON-RPC-1.03/lib/JSON/000755 000765 000024 00000000000 11766777510 014760 5ustar00daisukestaff000000 000000 JSON-RPC-1.03/lib/JSON/RPC/000755 000765 000024 00000000000 11766777510 015404 5ustar00daisukestaff000000 000000 JSON-RPC-1.03/lib/JSON/RPC.pm000644 000765 000024 00000014554 11766777473 015763 0ustar00daisukestaff000000 000000 package JSON::RPC; use strict; our $VERSION = '1.03'; 1; __END__ =head1 NAME JSON::RPC - JSON RPC 2.0 Server Implementation =head1 SYNOPSIS # app.psgi use strict; use JSON::RPC::Dispatch; my $dispatch = JSON::RPC::Dispatch->new( prefix => "MyApp::JSONRPC::Handler", router => Router::Simple->new( ... ) ); sub { my $env = shift; $dispatch->handle_psgi($env); }; =head1 DESCRIPTION JSON::RPC is a set of modules that implment JSON RPC 2.0 protocol. If you are using old JSON::RPC code (up to 0.96), DO NOT EXPECT YOUR CODE TO WORK WITH THIS VERSION. THIS VERSION IS ****BACKWARDS INCOMPATIBLE**** =head1 BASIC USAGE The JSON::RPC::Dispatch object is responsible for marshalling the request. my $dispatch = JSON::RPC::Dispatch->new( router => ..., ); The routing between the JSON RPC methods and their implementors are handled by Router::Simple. For example, if you want to map method "foo" to a "MyApp::JSONRPC::Handler" object instance's "handle_foo" method, you specify something like the following in your router instance: use Router::Simple::Declare; my $router = router { connect "foo" => { handler => "+MyApp::JSONRPC::Handler", action => "handle_foo" }; }; my $dispatch = JSON::RPC::Dispatch->new( router => $router, ); The "+" prefix in the handler classname denotes that it is already a fully qualified classname. Without the prefix, the value of "prefix" in the dispatch object will be used to qualify the classname. If you specify it in your Dispatch instance, you may omit the prefix part to save you some typing: use JSON::RPC::Dispatch; use Router::Simple::Declare; my $router = router { connect "foo" => { handler => "Foo", action => "process", }; connect "bar" => { handler => "Bar", action => "process" } }; my $dispatch = JSON::RPC::Dispatch->new( prefix => "MyApp::JSONRPC::Handler", router => $router, ); # The above will roughly translate to the following: # # for method "foo" # my $handler = MyApp::JSONRPC::Handler::Foo->new; # $handler->process( ... ); # # for method "bar" # my $handler = MyApp::JSONRPC::Handler::Bar->new; # $handler->process( ... ); The implementors are called handlers. Handlers are simple objects, and will be instantiated automatically for you. Their return values are converted to JSON objects automatically. You may also choose to pass objects in the handler argument to connect in your router. This will save you the cost of instantiating the handler object, and you also don't have to rely on us instantiating your handler object. use Router::Simple::Declare; use MyApp::JSONRPC::Handler; my $handler = MyApp::JSONRPC::Handler->new; my $router = router { connect "foo" => { handler => $handler, action => "handle_foo" }; }; =head1 HANDLERS Your handlers are objects responsible for returning some sort of reference structure that can be properly encoded via JSON/JSON::XS. The handler only needs to implement the methods that you specified in your router. The handler methods will receive the following parameters: sub your_handler_method { my ($self, $params, $procedure, @extra_args) = @_; return $some_structure; } In most cases you will only need the parameters. The exact format of the $params is dependend on the caller -- you will be passed whatever JSON structure that caller used to call your handler. $procedure is an instance of JSON::RPC::Procedure. Use it if you need to figure out more about the procedure. @extra_args is optional, and will be filled with whatever extra arguments you passed to handle_psgi(). For example, # app.psgi sub { $dispatch->handle_psgi($env, "arg1", "arg2", "arg3"); } will cause your handlers to receive the following arguments: sub your_handler_method { my ($self, $params, $procedure, $arg1, $arg2, $arg3) = @_; } This is convenient if you have application-specific data that needs to be passed to your handlers. =head1 EMBED IT IN YOUR WEBAPP If you already have a web app (and whatever framework you might already have), you may choose to embed JSON::RPC in your webapp instead of directly calling it in your PSGI application. For example, if you would like to your webapp's "rpc" handler to marshall the JSON RPC request, you can do something like the following: package MyApp; use My::Favorite::WebApp; sub rpc { my ($self, $context) = @_; my $dispatch = ...; # grab it from somewhere $dispatch->handle_psgi( $context->env ); } =head1 ERRORS When your handler dies, it is automatically included in the response hash. For example, something like below sub rpc { ... if ($bad_thing_happend) { die "Argh! I failed!"; } } Would result in a response like { error => { code => -32603, message => "Argh! I failed! at ...", } } However, you can include custom data by die()'ing with a hash: sub rpc { ... if ($bad_thing_happend) { die { message => "Argh! I failed!", data => time() }; } } This would result in: { error => { code => -32603, message => "Argh! I failed! at ...", data => 1339817722, } } =head1 BACKWARDS COMPATIBILITY Eh, not compatible at all. JSON RPC 0.xx was fine, but it predates PSGI, and things are just... different before and after PSGI. Code at version 0.96 has been moved to JSON::RPC::Legacy namespace, so change your application to use JSON::RPC::Legacy if you were using the old version. =head1 AUTHORS Daisuke Maki Shinichiro Aska Yoshimitsu Torii =head1 AUTHOR EMERITUS Makamaka Hannyaharamitu, Emakamaka[at]cpan.orgE - JSON::RPC modules up to 0.96 =head1 COPYRIGHT AND LICENSE The JSON::RPC module is Copyright (C) 2011 by Daisuke Maki This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself, either Perl version 5.8.0 or, at your option, any later version of Perl 5 you may have available. See JSON::RPC::Legacy for copyrights and license for previous versions. =cut JSON-RPC-1.03/lib/JSON/RPC/Constants.pm000644 000765 000024 00000002275 11766402104 017704 0ustar00daisukestaff000000 000000 package JSON::RPC::Constants; use strict; use parent qw(Exporter); our @EXPORT_OK = qw( JSONRPC_DEBUG RPC_PARSE_ERROR RPC_INVALID_REQUEST RPC_METHOD_NOT_FOUND RPC_INVALID_PARAMS RPC_INTERNAL_ERROR ); our %EXPORT_TAGS = (all => \@EXPORT_OK); my %constants; BEGIN { %constants = ( JSONRPC_DEBUG => $ENV{PERL_JSONRPC_DEBUG} ? 1 : 0, RPC_PARSE_ERROR => -32700, RPC_INVALID_REQUEST => -32600, RPC_METHOD_NOT_FOUND => -32601, RPC_INVALID_PARAMS => -32602, RPC_INTERNAL_ERROR => -32603, ); require constant; constant->import( \%constants ); } 1; __END__ =head1 NAME JSON::RPC::Constants - Constants =head1 SYNOPSIS use JSON::RPC::Constants qw(:all); # or, import one by one =head1 DEBUG =over 4 =item B Set to true if PERL_JSONRPC_DEBUG environmental variable is set to a value that evaluates to true. False otherwise. This controls debug output of the module. =back =head1 JSON RPC VALUES These values are defined as per JSON RPC RFC. =head2 RPC_PARSE_ERROR =head2 RPC_INVALID_REQUEST =head2 RPC_METHOD_NOT_FOUND =head2 RPC_INVALID_PARAMS =head2 RPC_INTERNAL_ERROR =cut JSON-RPC-1.03/lib/JSON/RPC/Dispatch.pm000644 000765 000024 00000014632 11766776733 017515 0ustar00daisukestaff000000 000000 package JSON::RPC::Dispatch; use strict; use JSON::RPC::Constants qw(:all); use JSON::RPC::Parser; use JSON::RPC::Procedure; use Router::Simple; use Scalar::Util; use Try::Tiny; use Class::Accessor::Lite rw => [ qw( coder handlers parser prefix router ) ] ; sub new { my ($class, @args) = @_; my $self = bless { handlers => {}, @args, }, $class; if (! $self->{coder}) { require JSON; $self->{coder} = JSON->new->utf8; } if (! $self->{parser}) { $self->{parser} = JSON::RPC::Parser->new( coder => $self->coder ) } if (! $self->{router}) { $self->{router} = Router::Simple->new; } return $self; } sub guess_handler_class { my ($self, $klass) = @_; my $prefix = $self->prefix || ''; return "$prefix\::$klass"; } sub construct_handler { my ($self, $klass) = @_; my $handler = $self->handlers->{ $klass }; if (! $handler) { eval "require $klass"; die if $@; $handler = $klass->new(); $self->handlers->{$klass} = $handler; } return $handler; } sub get_handler { my ($self, $klass) = @_; if ( Scalar::Util::blessed( $klass )){ if (JSONRPC_DEBUG > 1) { warn "Handler is already object : $klass"; } return $klass; } if ($klass !~ s/^\+//) { $klass = $self->guess_handler_class( $klass ); } my $handler = $self->construct_handler( $klass ); if (JSONRPC_DEBUG > 1) { warn "$klass -> $handler"; } return $handler; } sub handle_psgi { my ($self, $req, @args) = @_; if ( ! Scalar::Util::blessed($req) ) { # assume it's a PSGI hash require Plack::Request; $req = Plack::Request->new($req); } my @response; my $procedures; try { $procedures = $self->parser->construct_from_req( $req ); if (@$procedures <= 0) { push @response, { error => { code => RPC_INVALID_REQUEST, message => "Could not find any procedures" } }; } } catch { my $e = $_; if (JSONRPC_DEBUG) { warn "error while creating jsonrpc request: $e"; } if ($e =~ /Invalid parameter/) { push @response, { error => { code => RPC_INVALID_PARAMS, message => "Invalid parameters", } }; } elsif ( $e =~ /parse error/ ) { push @response, { error => { code => RPC_PARSE_ERROR, message => "Failed to parse json", } }; } else { push @response, { error => { code => RPC_INVALID_REQUEST, message => $e } } } }; my $router = $self->router; foreach my $procedure (@$procedures) { if ( ! $procedure->{method} ) { my $message = "Procedure name not given"; if (JSONRPC_DEBUG) { warn $message; } push @response, { error => { code => RPC_METHOD_NOT_FOUND, message => $message, } }; next; } my $matched = $router->match( $procedure->{method} ); if (! $matched) { my $message = "Procedure '$procedure->{method}' not found"; if (JSONRPC_DEBUG) { warn $message; } push @response, { error => { code => RPC_METHOD_NOT_FOUND, message => $message, } }; next; } my $action = $matched->{action}; try { my ($ip, $ua); if (JSONRPC_DEBUG > 1) { warn "Procedure '$procedure->{method}' maps to action $action"; $ip = $req->address || 'N/A'; $ua = $req->user_agent || 'N/A'; } my $params = $procedure->params; my $handler = $self->get_handler( $matched->{handler} ); my $code = $handler->can( $action ); if (! $code) { if ( JSONRPC_DEBUG ) { warn "[INFO] handler $handler does not implement method $action!."; } die "Internal Error"; } my $result = $code->( $handler, $procedure->params, $procedure, @args ); if (JSONRPC_DEBUG) { warn "[INFO] action=$action " . "params=[" . (ref $params ? $self->{coder}->encode($params) : $params) . "] ret=" . (ref $result ? $self->{coder}->encode($result) : $result) . " IP=$ip UA=$ua"; } push @response, { jsonrpc => '2.0', result => $result, id => $procedure->id, }; } catch { my $e = $_; if (JSONRPC_DEBUG) { warn "Error while executing $action: $e"; } my $error = {code => RPC_INTERNAL_ERROR} ; if (ref $e eq "HASH") { $error->{message} = $e->{message}, $error->{data} = $e->{data}, } else { $error->{message} = $e, } push @response, { jsonrpc => '2.0', id => $procedure->id, error => $error, }; }; } my $res = $req->new_response(200); $res->content_type( 'application/json; charset=utf8' ); $res->body( $self->coder->encode( @$procedures > 1 ? \@response : $response[0] ) ); return $res->finalize; } no Try::Tiny; 1; __END__ =head1 NAME JSON::RPC::Dispatch - Dispatch JSON RPC Requests To Handlers =head1 SYNOPSIS use JSON::RPC::Dispatch; my $router = Router::Simple->new; # or use Router::Simple::Declare $router->connect( method_name => { handler => $class_name_or_instance, action => $method_name_to_invoke ); my $dispatch = JSON::RPC::Dispatch->new( router => $router ); sub psgi_app { $dispatch->handle_psgi( $env ); } =head1 DESCRIPTION See docs in L for details =cut JSON-RPC-1.03/lib/JSON/RPC/Legacy/000755 000765 000024 00000000000 11766777510 016610 5ustar00daisukestaff000000 000000 JSON-RPC-1.03/lib/JSON/RPC/Legacy.pm000644 000765 000024 00000005561 11766402104 017135 0ustar00daisukestaff000000 000000 package JSON::RPC::Legacy; use strict; 1; __END__ =pod =head1 NAME JSON::RPC - Perl implementation of JSON-RPC 1.1 protocol =head1 DESCRIPTION JSON-RPC is a stateless and light-weight remote procedure call (RPC) protocol for inter-networking applications over HTTP. It uses JSON as the data format for of all facets of a remote procedure call, including all application data carried in parameters. quoted from L. This module was in JSON package on CPAN before. Now its interfaces was completely changed. The old modules - L and L are deprecated. Please try to use JSON::RPC::Server and JSON::RPC::Client which support both JSON-RPC protocol version 1.1 and 1.0. =head1 EXAMPLES CGI version. #-------------------------- # In your application class package MyApp; use base qw(JSON::RPC::Procedure); # Perl 5.6 or more than sub echo : Public { # new version style. called by clients # first argument is JSON::RPC::Server object. return $_[1]; } sub sum : Public(a:num, b:num) { # sets value into object member a, b. my ($s, $obj) = @_; # return a scalar value or a hashref or an arryaref. return $obj->{a} + $obj->{b}; } sub a_private_method : Private { # ... can't be called by client } sub sum_old_style { # old version style. taken as Public my ($s, @arg) = @_; return $arg[0] + $arg[1]; } #-------------------------- # In your triger script. use JSON::RPC::Server::CGI; use MyApp; # simple JSON::RPC::Server::CGI->dispatch('MyApp')->handle(); # or JSON::RPC::Server::CGI->dispatch([qw/MyApp FooBar/])->handle(); # or INFO_PATH version JSON::RPC::Server::CGI->dispatch({'/Test' => 'MyApp'})->handle(); #-------------------------- # Client use JSON::RPC::Client; my $client = new JSON::RPC::Client; my $uri = 'http://www.example.com/jsonrpc/Test'; my $obj = { method => 'sum', # or 'MyApp.sum' params => [10, 20], }; my $res = $client->call( $uri, $obj ) if($res){ if ($res->is_error) { print "Error : ", $res->error_message; } else { print $res->result; } } else { print $client->status_line; } # or $client->prepare($uri, ['sum', 'echo']); print $client->sum(10, 23); See to L, L, L L and L. =head1 ABOUT NEW VERSION =over =item supports JSON-RPC protocol v1.1 =back =head1 TODO =over =item Document =item Examples =item More Tests =back =head1 AUTHOR Makamaka Hannyaharamitu, Emakamaka[at]cpan.orgE =head1 COPYRIGHT AND LICENSE Copyright 2007-2008 by Makamaka Hannyaharamitu This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut JSON-RPC-1.03/lib/JSON/RPC/Parser.pm000644 000765 000024 00000003753 11766402104 017166 0ustar00daisukestaff000000 000000 package JSON::RPC::Parser; use strict; use JSON::RPC::Procedure; use Carp (); use Plack::Request; use Class::Accessor::Lite new => 1, rw => [ qw( coder ) ] ; sub construct_procedure { my $self = shift; JSON::RPC::Procedure->new( @_ ); } sub construct_from_req { my ($self, $req) = @_; my $method = $req->method; my $proc; if ($method eq 'POST') { $proc = $self->construct_from_post_req( $req ); } elsif ($method eq 'GET') { $proc = $self->construct_from_get_req( $req ); } else { Carp::croak( "Invalid method: $method" ); } return $proc; } sub construct_from_post_req { my ($self, $req) = @_; my $request = eval { $self->coder->decode( $req->content ) }; if ($@) { Carp::croak( "JSON parse error: $@" ); } my $ref = ref $request; if ($ref ne 'ARRAY') { $request = [ $request ]; } my @procs; foreach my $req ( @$request ) { Carp::croak( "Invalid parameter") unless ref $req eq 'HASH'; push @procs, $self->construct_procedure( method => $req->{method}, id => $req->{id}, params => $req->{params}, ); } return \@procs; } sub construct_from_get_req { my ($self, $req) = @_; my $params = $req->query_parameters; my $decoded_params; if ($params->{params}) { $decoded_params = eval { $self->coder->decode( $params->{params} ) }; } return [ $self->construct_procedure( method => $params->{method}, id => $params->{id}, params => $decoded_params ) ]; } 1; __END__ =head1 NAME JSON::RPC::Parser - Parse JSON RPC Requests from Plack::Request =head1 SYNOPSIS use JSON::RPC::Parser; my $parser = JSON::RPC::Parser->new( coder => JSON->new ); my $procedure = $parser->construct_from_req( $request ); =head1 DESCRIPTION Constructs a L object from a Plack::Request object =cut JSON-RPC-1.03/lib/JSON/RPC/Procedure.pm000644 000765 000024 00000000732 11766402104 017654 0ustar00daisukestaff000000 000000 package JSON::RPC::Procedure; use strict; use Carp (); use Class::Accessor::Lite new => 1, rw => [ qw( id method params ) ] ; 1; __END__ =head1 NAME JSON::RPC::Procedure - A JSON::RPC Procedure =head1 SYNOPSIS use JSON::RPC::Procedure; my $procedure = JSON::RPC::Procedure->new( id => ..., method => ... params => ... ); =head1 DESCRIPTION A container for JSON RPC procedure information =cut JSON-RPC-1.03/lib/JSON/RPC/Test.pm000644 000765 000024 00000001227 11766403137 016652 0ustar00daisukestaff000000 000000 package JSON::RPC::Test; use strict; use parent qw(Exporter); our @EXPORT = qw(test_rpc); sub test_rpc { if (ref $_[0] && @_ == 2) { @_ = (dispatch => $_[0], client => $_[1]); } my %args = @_; my $dispatch = delete $args{dispatch}; $args{app} = sub { $dispatch->handle_psgi(@_); }; @_ = %args; goto \&Plack::Test::test_psgi; } 1; =head1 NAME JSON::RPC::Test - Simple Wrapper To Test Your JSON::RPC =head1 SYNOPSIS use JSON::RPC::Test; test_rpc $dispatch, sub { ... }; # or test_rpc dispatch => $dispatch, client => sub { ... } ; =cut JSON-RPC-1.03/lib/JSON/RPC/Legacy/Client.pm000644 000765 000024 00000022452 11766402104 020351 0ustar00daisukestaff000000 000000 ############################################################################## # 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__ =pod =head1 NAME JSON::RPC::Legacy::Client - Perl implementation of JSON-RPC client =head1 SYNOPSIS use JSON::RPC::Legacy::Client; my $client = new JSON::RPC::Legacy::Client; my $url = 'http://www.example.com/jsonrpc/API'; my $callobj = { method => 'sum', params => [ 17, 25 ], # ex.) params => { a => 20, b => 10 } for JSON-RPC v1.1 }; my $res = $client->call($uri, $callobj); if($res) { if ($res->is_error) { print "Error : ", $res->error_message; } else { print $res->result; } } else { print $client->status_line; } # Easy access $client->prepare($uri, ['sum', 'echo']); print $client->sum(10, 23); =head1 DESCRIPTION This is JSON-RPC Client. See L. Gets a perl object and convert to a JSON request data. Sends the request to a server. Gets a response returned by the server. Converts the JSON response data to the perl object. =head1 JSON::RPC::Legacy::Client =head2 METHODS =over =item $client = JSON::RPC::Legacy::Client->new Creates new JSON::RPC::Legacy::Client object. =item $response = $client->call($uri, $procedure_object) Calls to $uri with $procedure_object. The request method is usually C. If $uri has query string, method is C. About 'GET' method, see to L. Return value is L. =item $client->prepare($uri, $arrayref_of_procedure) Allow to call methods in contents of $arrayref_of_procedure. Then you can call the prepared methods with an array reference or a list. The return value is a result part of JSON::RPC::Legacy::ReturnObject. $client->prepare($uri, ['sum', 'echo']); $res = $client->echo('foobar'); # $res is 'foobar'. $res = $client->sum(10, 20); # sum up $res = $client->sum( [10, 20] ); # same as above If you call a method which is not prepared, it will C. Currently, B. =item version Sets the JSON-RPC protocol version. 1.1 by default. =item id Sets a request identifier. In JSON-RPC 1.1, it is optoinal. If you set C 1.0 and don't set id, the module sets 'JSON::RPC::Legacy::Client' to it. =item ua Setter/getter to L object. =item json Setter/getter to the JSON coder object. Default is L, likes this: $self->json( JSON->new->allow_nonref->utf8 ); $json = $self->json; This object serializes/deserializes JSON data. By default, returned JSON data assumes UTF-8 encoded. =item status_line Returns status code; After C a remote procedure, the status code is set. =item create_json_coder (Class method) Returns a JSON de/encoder in C. You can override it to use your favorite JSON de/encoder. =back =head1 JSON::RPC::Legacy::ReturnObject C method or the methods set by C returns this object. (The returned JSON data is decoded by the JSON coder object which was passed by the client object.) =head2 METHODS =over =item is_success If the call is successful, returns a true, otherwise a false. =item is_error If the call is not successful, returns a true, otherwise a false. =item error_message If the response contains an error message, returns it. =item result Returns the result part of a data structure returned by the called server. =item content Returns the whole data structure returned by the called server. =item jsontext Returns the row JSON data. =item version Returns the version of this response data. =back =head1 JSON::RPC::Legacy::ServiceObject =head1 RESERVED PROCEDURE When a client call a procedure (method) name 'system.foobar', JSON::RPC::Legacy::Server look up MyApp::system::foobar. L L There is JSON::RPC::Legacy::Server::system::describe for default response of 'system.describe'. =head1 SEE ALSO L L =head1 AUTHOR Makamaka Hannyaharamitu, Emakamaka[at]cpan.orgE =head1 COPYRIGHT AND LICENSE Copyright 2007-2008 by Makamaka Hannyaharamitu This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut JSON-RPC-1.03/lib/JSON/RPC/Legacy/Procedure.pm000644 000765 000024 00000006577 11766402104 021075 0ustar00daisukestaff000000 000000 package JSON::RPC::Legacy::Procedure; # # http://json-rpc.org/wd/JSON-RPC-1-1-WD-20060807.html # $JSON::RPC::Legacy::Procedure::VERSION = '0.90'; 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__ =pod =head1 NAME JSON::RPC::Legacy::Procedure - JSON-RPC Service attributes =head1 SYNOPSIS package MyApp; use base ('JSON::RPC::Legacy::Procedure'); sub sum : Public { my ($s, @arg) = @_; return $arg[0] + $arg[1]; } # or sub sum : Public(a, b) { my ($s, $obj) = @_; return $obj->{a} + $obj->{b}; } # or sub sum : Number(a:num, b:num) { my ($s, $obj) = @_; return $obj->{a} + $obj->{b}; } # private method can't be called by clients sub _foobar : Private { # ... } =head1 DESCRIPTION Using this module, you can write a subroutine with a special attribute. Currently, in below attributes, only Public and Private are available. Others are same as Public. =over =item Public Means that a client can call this procedure. =item Private Means that a client can't call this procedure. =item Arr Means that its return values is an array object. =item Obj Means that its return values is a member object. =item Bit =item Bool Means that a return values is a C or C. =item Num Means that its return values is a number. =item Str Means that its return values is a string. =item Nil =item None Means that its return values is a C. =back =head1 TODO =over =item Auto Service Description =item Type check =back =head1 SEE ALSO L =head1 AUTHOR Makamaka Hannyaharamitu, Emakamaka[at]cpan.orgE =head1 COPYRIGHT AND LICENSE Copyright 2007 by Makamaka Hannyaharamitu This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut JSON-RPC-1.03/lib/JSON/RPC/Legacy/Server/000755 000765 000024 00000000000 11766777510 020056 5ustar00daisukestaff000000 000000 JSON-RPC-1.03/lib/JSON/RPC/Legacy/Server.pm000644 000765 000024 00000035650 11766402104 020405 0ustar00daisukestaff000000 000000 ############################################################################## # JSONRPC version 1.1 # http://json-rpc.org/wd/JSON-RPC-1-1-WD-20060807.html ############################################################################## use strict; use JSON (); use Carp (); use HTTP::Request (); use HTTP::Response (); ############################################################################## package JSON::RPC::Legacy::Server; my $JSONRPC_Procedure_Able; BEGIN { if ($] >= 5.006) { require JSON::RPC::Legacy::Procedure; $JSONRPC_Procedure_Able = 1; } } $JSON::RPC::Legacy::Server::VERSION = '0.92'; BEGIN { for my $method (qw/request path_info json version error_message max_length charset content_type error_response_header return_die_message/) { eval qq| sub $method { \$_[0]->{$method} = \$_[1] if defined \$_[1]; \$_[0]->{$method}; } |; } } sub create_json_coder { JSON->new->utf8; # assumes UTF8 } sub new { my $class = shift; bless { max_length => 1024 * 100, charset => 'UTF-8', content_type => 'application/json', json => $class->create_json_coder, loaded_module => { name => {}, order => [], }, @_, }, $class; } *dispatch_to = *dispatch; # Alias sub dispatch { my ($self, @arg) = @_; if (@arg == 0){ Carp::carp "Run test mode..."; } elsif (@arg > 1) { for my $pkg (@arg) { $self->_load_module($pkg); } } else { if (ref $arg[0] eq 'ARRAY') { for my $pkg (@{$arg[0]}) { $self->_load_module($pkg); } } elsif (ref $arg[0] eq 'HASH') { # Lazy loading for my $path (keys %{$arg[0]}) { my $pkg = $arg[0]->{$path}; $self->{dispatch_path}->{$path} = $pkg; } } elsif (ref $arg[0]) { Carp::croak 'Invalid dispatch value.'; } else { # Single module $self->_load_module($arg[0]); } } $self; } sub handle { my ($self) = @_; my ($obj, $res, $jsondata); if ($self->request->method eq 'POST') { $jsondata = $self->retrieve_json_from_post(); } elsif ($self->request->method eq 'GET') { $jsondata = $self->retrieve_json_from_get(); } if ( $jsondata ) { $obj = eval q| $self->json->decode($jsondata) |; if ($@) { $self->raise_error(code => 201, message => "Can't parse JSON data."); } } else { # may have error_response_header at retroeve_json_from_post / get unless ($self->error_response_header) { $self->error_response_header($self->response_header(403, 'No data.')); } } if ($obj) { $res = $self->_handle($obj); unless ($self->error_response_header) { return $self->response( $self->response_header(200, $res) ); } } $self->response( $self->error_response_header ); } sub retrieve_json_from_post { } # must be implemented in subclass sub retrieve_json_from_get { } # must be implemented in subclass sub response { } # must be implemented in subclass sub raise_error { my ($self, %opt) = @_; my $status_code = $opt{status_code} || 200; if (exists $opt{version} and $opt{version} ne '1.1') { $self->version(0); } else { $self->version(1.1); } my $res = $self->_error($opt{id}, $opt{code}, $opt{message}); $self->error_response_header($self->response_header($status_code, $res)); return; } sub response_header { my ($self, $code, $result) = @_; my $h = HTTP::Headers->new; $h->header('Content-Type' => $self->content_type . '; charset=' . $self->charset); HTTP::Response->new($code => undef, $h, $result); } sub _handle { my ($self, $obj) = @_; $obj->{version} ? $self->version(1.1) : $self->version(0); my $method = $obj->{method}; if (!defined $method) { return $self->_error($obj->{id}, 300, "method is nothing."); } elsif ($method =~ /[^-._a-zA-Z0-9]/) { return $self->_error($obj->{id}, 301, "method is invalid."); } my $procedure = $self->_find_procedure($method); unless ($procedure) { return $self->_error($obj->{id}, 302, "No such a method : '$method'."); } my $params; unless ($obj->{version}) { unless ($obj->{params} and ref($obj->{params}) eq 'ARRAY') { return $self->_error($obj->{id}, 400, "Invalid params for JSONRPC 1.0."); } } unless ($params = $self->_argument_type_check($procedure->{argument_type}, $obj->{params})) { return $self->_error($obj->{id}, 401, $self->error_message); } my $result; if ($obj->{version}) { $result = ref $params ? eval q| $procedure->{code}->($self, $params) | : eval q| $procedure->{code}->($self) | ; } else { my @params; if(ref($params) eq 'ARRAY') { @params = @$params; } else { $params[0] = $params; } $result = eval q| $procedure->{code}->($self, @params) |; } if ($self->error_response_header) { return; } elsif ($@) { return $self->_error($obj->{id}, 500, ($self->return_die_message ? $@ : 'Procedure error.')); } if (!$obj->{version} and !defined $obj->{id}) { # notification return ''; } my $return_obj = {result => $result}; if ($obj->{version}) { $return_obj->{version} = '1.1'; } else { $return_obj->{error} = undef; $return_obj->{id} = $obj->{id}; } return $self->json->encode($return_obj); } sub _find_procedure { my ($self, $method) = @_; my $found; my $classname; my $system_call; if ($method =~ /^system\.(\w+)$/) { $system_call = 1; $method = $1; } elsif ($method =~ /\./) { my @p = split/\./, $method; $method = pop @p; $classname= join('::', @p); } if ($self->{dispatch_path}) { my $path = $self->{path_info}; if (my $pkg = $self->{dispatch_path}->{$path}) { return if ( $classname and $pkg ne $classname ); return if ( $JSONRPC_Procedure_Able and JSON::RPC::Legacy::Procedure->can( $method ) ); $self->_load_module($pkg); if ($system_call) { $pkg .= '::system' } return $self->_method_is_ebable($pkg, $method, $system_call); } } else { for my $pkg (@{$self->{loaded_module}->{order}}) { next if ( $classname and $pkg ne $classname ); next if ( $JSONRPC_Procedure_Able and JSON::RPC::Legacy::Procedure->can( $method ) ); if ($system_call) { $pkg .= '::system' } if ( my $ret = $self->_method_is_ebable($pkg, $method, $system_call) ) { return $ret; } } } return; } sub _method_is_ebable { my ($self, $pkg, $method, $system_call) = @_; my $allowable_procedure = $pkg->can('allowable_procedure'); my $code; if ( $allowable_procedure ) { if ( exists $allowable_procedure->()->{ $method } ) { $code = $allowable_procedure->()->{ $method }; } else { return; } } if ( $code or ( $code = $pkg->can($method) ) ) { return {code => $code} if ($system_call or !$JSONRPC_Procedure_Able); if ( my $procedure = JSON::RPC::Legacy::Procedure::check($pkg, $code) ) { return if ($procedure->{return_type} and $procedure->{return_type} eq 'Private'); $procedure->{code} = $code; return $procedure; } } if ($system_call) { # if not found, default system.foobar if ( my $code = 'JSON::RPC::Legacy::Server::system'->can($method) ) { return {code => $code}; } } return; } sub _argument_type_check { my ($self, $type, $params) = @_; unless (defined $type) { return defined $params ? $params : 1; } my $regulated; if (ref $params eq 'ARRAY') { if (@{$type->{position}} != @$params) { $self->error_message("Number of params is mismatch."); return; } if (my $hash = $type->{names}) { my $i = 0; for my $name (keys %$hash) { $regulated->{$name} = $params->[$i++]; } } } elsif (ref $params eq 'HASH') { if (@{$type->{position}} != keys %$params) { $self->error_message("Number of params is mismatch."); return; } if (my $hash = $type->{names}) { my $i = 0; for my $name (keys %$params) { if ($name =~ /^\d+$/) { my $realname = $type->{position}[$name]; $regulated->{$realname} = $params->{$name}; } else { $regulated->{$name} = $params->{$name}; } } } } elsif (!defined $params) { if (@{$type->{position}} != 0) { $self->error_message("Number of params is mismatch."); return; } return 1; } else { $self->error_message("the params member is any other type except JSON Object or Array."); return; } return $regulated ? $regulated : $params; } sub _load_module { my ($self, $pkg) = @_; eval qq| require $pkg |; if ($@) { Carp::croak $@; } $self->{loaded_module}->{name}->{$pkg} = $pkg; push @{ $self->{loaded_module}->{order} }, $pkg; } # Error Handling sub _error { my ($self, $id, $code, $message) = @_; if ($self->can('translate_error_message')) { $message = $self->translate_error_message($code, $message); } my $error_obj = { name => 'JSONRPCError', code => $code, message => $message, }; my $obj; if ($self->version) { $obj = { version => "1.1", error => $error_obj, }; $obj->{id} = $id if (defined $id); } else { return '' if (!defined $id); $obj = { result => undef, error => $message, id => $id, }; } return $self->json->encode($obj); } ############################################################################## package JSON::RPC::Legacy::Server::system; sub describe { { sdversion => "1.0", name => __PACKAGE__, summary => 'Default system description', } } 1; __END__ =pod =head1 NAME JSON::RPC::Server - Perl implementation of JSON-RPC sever =head1 SYNOPSIS # CGI version use JSON::RPC::Legacy::Server::CGI; my $server = JSON::RPC::Legacy::Server::CGI->new; $server->dispatch_to('MyApp')->handle(); # Apache version # In apache conf PerlRequire /your/path/start.pl PerlModule MyApp SetHandler perl-script PerlResponseHandler JSON::RPC::Legacy::Server::Apache PerlSetVar dispatch "MyApp" PerlSetVar return_die_message 0 # Daemon version use JSON::RPC::Legacy::Server::Daemon; JSON::RPC::Legacy::Server::Daemon->new(LocalPort => 8080); ->dispatch({'/jsonrpc/API' => 'MyApp'}) ->handle(); # FastCGI version use JSON::RPC::Legacy::Server::FastCGI; my $server = JSON::RPC::Legacy::Server::FastCGI->new; $server->dispatch_to('MyApp')->handle(); =head1 DESCRIPTION Gets a client request. Parses its JSON data. Passes the server object and the object decoded from the JSON data to your procedure (method). Takes your returned value (scalar or arrayref or hashref). Sends a response. Well, you write your procedure code only. =head1 METHODS =over =item new Creates new JSON::RPC::Legacy::Server object. =item dispatch($package) =item dispatch([$package1, $package1, ...]) =item dispatch({$path => $package, ...}) Sets your procedure module using package name list or arrayref or hashref. Hashref version is used for path_info access. =item dispatch_to An alias to C. =item handle Runs server object and returns a response. =item raise_error(%hash) return $server->raise_error( code => 501, message => "This is error in my procedure." ); Sets an error. An error code number in your procedure is an integer between 501 and 899. =item json Setter/Getter to json encoder/decoder object. The default value is L object in the below way: JSON->new->utf8 In your procedure, changes its behaviour. $server->json->utf8(0); The JSON coder creating method is C. =item version Setter/Getter to JSON-RPC protocol version used by a client. If version is 1.1, returns 1.1. Otherwise returns 0. =item charset Setter/Getter to cahrset. Default is 'UTF-8'. =item content_type Setter/Getter to content type. Default is 'application/json'. =item return_die_message When your program dies in your procedure, sends a return object with errror message 'Procedure error' by default. If this option is set, uses C message. sub your_procedure { my ($s) = @_; $s->return_die_message(1); die "This is test."; } =item retrieve_json_from_post It is used by JSON::RPC::Legacy::Server subclass. =item retrieve_json_from_get In the protocol v1.1, 'GET' request method is also allowable. It is used by JSON::RPC::Legacy::Server subclass. =item response It is used by JSON::RPC::Legacy::Server subclass. =item request Returns L object. =item path_info Returns PATH_INFO. =item max_length Returns max content-length to your application. =item translate_error_message Implemented in your subclass. Three arguments (server object, error code and error message) are passed. It must return a message. sub translate_error_message { my ($s, $code, $message) = @_; return $translation_jp_message{$code}; } =item create_json_coder (Class method) Returns a JSON de/encoder in C. You can override it to use your favorite JSON de/encode. =back =head1 RESERVED PROCEDURE When a client call a procedure (method) name 'system.foobar', JSON::RPC::Legacy::Server look up MyApp::system::foobar. L L There is JSON::RPC::Legacy::Server::system::describe for default response of 'system.describe'. =head1 SEE ALSO L L L =head1 AUTHOR Makamaka Hannyaharamitu, Emakamaka[at]cpan.orgE =head1 COPYRIGHT AND LICENSE Copyright 2007-2008 by Makamaka Hannyaharamitu This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut JSON-RPC-1.03/lib/JSON/RPC/Legacy/Server/Apache2.pm000644 000765 000024 00000011334 11766402104 021641 0ustar00daisukestaff000000 000000 ############################################################################## package JSON::RPC::Legacy::Server::Apache2; use strict; use lib qw(/var/www/cgi-bin/json/); use base qw(JSON::RPC::Legacy::Server); use Apache2::Const -compile => qw(OK HTTP_BAD_REQUEST SERVER_ERROR); use APR::Table (); use Apache2::RequestRec (); use Apache2::RequestIO (); use Apache2::RequestUtil (); $JSON::RPC::Legacy::Server::Apache::VERSION = '0.05'; sub handler { my($r) = @_; my $s = __PACKAGE__->new; $s->request($r); $s->{path_info} = $r->path_info; my @modules = $r->dir_config('dispatch') || $r->dir_config('dispatch_to'); $s->return_die_message( $r->dir_config('return_die_message') ); $s->dispatch([@modules]); $s->handle(@_); Apache2::Const::OK; } sub new { my $class = shift; return $class->SUPER::new(); } sub retrieve_json_from_post { my $self = shift; my $r = $self->request; my $len = $r->headers_in()->get('Content-Length'); return if($r->method ne 'POST'); return if($len > $self->max_length); my ($buf, $content); while( $r->read($buf,$len) ){ $content .= $buf; } $content; } sub retrieve_json_from_get { my $self = shift; my $r = $self->request; my $args = $r->args; $args = '' if (!defined $args); $self->{path_info} = $r->path_info; my $params = {}; $self->version(1.1); for my $pair (split/&/, $args) { my ($key, $value) = split/=/, $pair; if ( defined ( my $val = $params->{ $key } ) ) { if ( ref $val ) { push @{ $params->{ $key } }, $value; } else { # change a scalar into an arrayref $params->{ $key } = []; push @{ $params->{ $key } }, $val, $value; } } else { $params->{ $key } = $value; } } my $method = $r->path_info; $method =~ s{^.*/}{}; $self->{path_info} =~ s{/?[^/]+$}{}; $self->json->encode({ version => '1.1', method => $method, params => $params, }); } sub response { my ($self, $response) = @_; my $r = $self->request; $r->content_type($self->content_type); $r->print($response->content); return ($response->code == 200) ? Apache2::Const::OK : Apache2::Const::SERVER_ERROR; } 1; __END__ =pod =head1 NAME JSON::RPC::Legacy::Server::Apache2 - JSON-RPC sever for mod_perl2 =head1 SYNOPSIS # In apache conf PerlRequire /your/path/start.pl PerlModule MyApp SetHandler perl-script PerlResponseHandler JSON::RPC::Legacy::Server::Apache PerlSetVar dispatch "MyApp" PerlSetVar return_die_message 0 #-------------------------- # In your application class package MyApp; use base qw(JSON::RPC::Legacy::Procedure); # Perl 5.6 or more than sub echo : Public { # new version style. called by clients # first argument is JSON::RPC::Legacy::Server object. return $_[1]; } sub sum : Public(a:num, b:num) { # sets value into object member a, b. my ($s, $obj) = @_; # return a scalar value or a hashref or an arryaref. return $obj->{a} + $obj->{b}; } sub a_private_method : Private { # ... can't be called by client } sub sum_old_style { # old version style. taken as Public my ($s, @arg) = @_; return $arg[0] + $arg[1]; } =head1 DESCRIPTION Gets a client request. Parses its JSON data. Passes the server object and the object decoded from the JSON data to your procedure (method). Takes your returned value (scalar or arrayref or hashref). Sends a response. Well, you write your procedure code only. =head1 METHODS They are inherited from the L methods basically. The below methods are implemented in JSON::RPC::Legacy::Server::Apache2. =over =item new Creates new JSON::RPC::Legacy::Server::Apache2 object. =item handle Runs server object and returns a response. =item retrieve_json_from_post retrieves a JSON request from the body in POST method. =item retrieve_json_from_get In the protocol v1.1, 'GET' request method is also allowable. it retrieves a JSON request from the query string in GET method. =item response returns a response JSON data to a client. =back =head1 SEE ALSO L, L, L, L, L, =head1 AUTHOR Makamaka Hannyaharamitu, Emakamaka[at]cpan.orgE =head1 COPYRIGHT AND LICENSE Copyright 2007-2008 by Makamaka Hannyaharamitu This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut JSON-RPC-1.03/lib/JSON/RPC/Legacy/Server/CGI.pm000644 000765 000024 00000007404 11766402104 021003 0ustar00daisukestaff000000 000000 ############################################################################## package JSON::RPC::Legacy::Server::CGI; use strict; use CGI; use JSON::RPC::Legacy::Server; # for old Perl 5.005 use base qw(JSON::RPC::Legacy::Server); $JSON::RPC::Legacy::Server::CGI::VERSION = '0.92'; sub new { my $class = shift; my $self = $class->SUPER::new(); my $cgi = $self->cgi; $self->request( HTTP::Request->new($cgi->request_method, $cgi->url) ); $self->path_info($cgi->path_info); $self; } sub retrieve_json_from_post { my $json = $_[0]->cgi->param('POSTDATA'); return $json; } sub retrieve_json_from_get { my $self = shift; my $cgi = $self->cgi; my $params = {}; $self->version(1.1); for my $name ($cgi->param) { my @values = $cgi->param($name); $params->{$name} = @values > 1 ? [@values] : $values[0]; } my $method = $cgi->path_info; $method =~ s{^.*/}{}; $self->{path_info} =~ s{/?[^/]+$}{}; $self->json->encode({ version => '1.1', method => $method, params => $params, }); } sub response { my ($self, $response) = @_; print "Status: " . $response->code . "\015\012" . $response->headers_as_string("\015\012") . "\015\012" . $response->content; } sub cgi { $_[0]->{cgi} ||= new CGI; } 1; __END__ =head1 NAME JSON::RPC::Legacy::Server::CGI - JSON-RPC sever for CGI =head1 SYNOPSIS # CGI version #-------------------------- # In your CGI script use JSON::RPC::Legacy::Server::CGI; my $server = JSON::RPC::Legacy::Server::CGI->new; $server->dispatch('MyApp')->handle(); # or an array ref setting $server->dispatch( [qw/MyApp MyApp::Subclass/] )->handle(); # or a hash ref setting $server->dispatch( {'/jsonrpc/API' => 'MyApp'} )->handle(); #-------------------------- # In your application class package MyApp; use base qw(JSON::RPC::Legacy::Procedure); # Perl 5.6 or more than sub echo : Public { # new version style. called by clients # first argument is JSON::RPC::Legacy::Server object. return $_[1]; } sub sum : Public(a:num, b:num) { # sets value into object member a, b. my ($s, $obj) = @_; # return a scalar value or a hashref or an arryaref. return $obj->{a} + $obj->{b}; } sub a_private_method : Private { # ... can't be called by client } sub sum_old_style { # old version style. taken as Public my ($s, @arg) = @_; return $arg[0] + $arg[1]; } =head1 DESCRIPTION Gets a client request. Parses its JSON data. Passes the server object and the object decoded from the JSON data to your procedure (method). Takes your returned value (scalar or arrayref or hashref). Sends a response. Well, you write your procedure code only. =head1 METHODS They are inherited from the L methods basically. The below methods are implemented in JSON::RPC::Legacy::Server::CGI. =over =item new Creates new JSON::RPC::Legacy::Server::CGI object. =item retrieve_json_from_post retrieves a JSON request from the body in POST method. =item retrieve_json_from_get In the protocol v1.1, 'GET' request method is also allowable. it retrieves a JSON request from the query string in GET method. =item response returns a response JSON data to a client. =item cgi returns the L object. =back =head1 SEE ALSO L, L, L, L, L, =head1 AUTHOR Makamaka Hannyaharamitu, Emakamaka[at]cpan.orgE =head1 COPYRIGHT AND LICENSE Copyright 2007-2008 by Makamaka Hannyaharamitu This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut JSON-RPC-1.03/lib/JSON/RPC/Legacy/Server/Daemon.pm000644 000765 000024 00000007066 11766402104 021610 0ustar00daisukestaff000000 000000 ############################################################################## package JSON::RPC::Legacy::Server::Daemon; use strict; use JSON::RPC::Legacy::Server; # for old Perl 5.005 use base qw(JSON::RPC::Legacy::Server); $JSON::RPC::Legacy::Server::Daemon::VERSION = '0.03'; use Data::Dumper; sub new { my $class = shift; my $self = $class->SUPER::new(); my $pkg; if( grep { $_ =~ /^SSL_/ } @_ ){ $self->{_daemon_pkg} = $pkg = 'HTTP::Daemon::SSL'; } else{ $self->{_daemon_pkg} = $pkg = 'HTTP::Daemon'; } eval qq| require $pkg; |; if($@){ die $@ } $self->{_daemon} ||= $pkg->new(@_) or die; return $self; } sub handle { my $self = shift; my %opt = @_; my $d = $self->{_daemon} ||= $self->{_daemon_pkg}->new(@_) or die; while (my $c = $d->accept) { $self->{con} = $c; while (my $r = $c->get_request) { $self->request($r); $self->path_info($r->url->path); $self->SUPER::handle(); last; } $c->close; } } sub retrieve_json_from_post { return $_[0]->request->content; } sub retrieve_json_from_get { } sub response { my ($self, $response) = @_; $self->{con}->send_response($response); } 1; __END__ =head1 NAME JSON::RPC::Legacy::Server::Daemon - JSON-RPC sever for daemon =head1 SYNOPSIS # Daemon version #-------------------------- # In your daemon server script use JSON::RPC::Legacy::Server::Daemon; JSON::RPC::Legacy::Server::Daemon->new(LocalPort => 8080); ->dispatch({'/jsonrpc/API' => 'MyApp'}) ->handle(); #-------------------------- # In your application class package MyApp; use base qw(JSON::RPC::Legacy::Procedure); # Perl 5.6 or more than sub echo : Public { # new version style. called by clients # first argument is JSON::RPC::Legacy::Server object. return $_[1]; } sub sum : Public(a:num, b:num) { # sets value into object member a, b. my ($s, $obj) = @_; # return a scalar value or a hashref or an arryaref. return $obj->{a} + $obj->{b}; } sub a_private_method : Private { # ... can't be called by client } sub sum_old_style { # old version style. taken as Public my ($s, @arg) = @_; return $arg[0] + $arg[1]; } =head1 DESCRIPTION This module is for http daemon servers using L or L. =head1 METHODS They are inherited from the L methods basically. The below methods are implemented in JSON::RPC::Legacy::Server::Daemon. =over =item new Creates new JSON::RPC::Legacy::Server::Daemon object. Arguments are passed to L or L. =item handle Runs server object and returns a response. =item retrieve_json_from_post retrieves a JSON request from the body in POST method. =item retrieve_json_from_get In the protocol v1.1, 'GET' request method is also allowable. it retrieves a JSON request from the query string in GET method. =item response returns a response JSON data to a client. =back =head1 SEE ALSO L, L, L, L, L, L, L, =head1 AUTHOR Makamaka Hannyaharamitu, Emakamaka[at]cpan.orgE =head1 COPYRIGHT AND LICENSE Copyright 2007-2008 by Makamaka Hannyaharamitu This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut JSON-RPC-1.03/inc/Module/000755 000765 000024 00000000000 11766777510 015437 5ustar00daisukestaff000000 000000 JSON-RPC-1.03/inc/Module/Install/000755 000765 000024 00000000000 11766777510 017045 5ustar00daisukestaff000000 000000 JSON-RPC-1.03/inc/Module/Install.pm000644 000765 000024 00000030135 11766777503 017407 0ustar00daisukestaff000000 000000 #line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.005; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '1.06'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split //, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_NEW sub _read { local *FH; open( FH, "< $_[0]" ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_OLD sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_NEW sub _write { local *FH; open( FH, "> $_[0]" ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_OLD # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version ($) { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp ($$) { _version($_[1]) <=> _version($_[2]); } # Cloned from Params::Util::_CLASS sub _CLASS ($) { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2012 Adam Kennedy. JSON-RPC-1.03/inc/Module/Install/Base.pm000644 000765 000024 00000002147 11766777503 020263 0ustar00daisukestaff000000 000000 #line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.06'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; use vars qw{$VERSION}; BEGIN { $VERSION = $Module::Install::Base::VERSION; } my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159 JSON-RPC-1.03/inc/Module/Install/Can.pm000644 000765 000024 00000006157 11766777503 020117 0ustar00daisukestaff000000 000000 #line 1 package Module::Install::Can; use strict; use Config (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # Check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; require File::Spec; my $abs = File::Spec->catfile($dir, $cmd); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # Can our C compiler environment build XS files sub can_xs { my $self = shift; # Ensure we have the CBuilder module $self->configure_requires( 'ExtUtils::CBuilder' => 0.27 ); # Do we have the configure_requires checker? local $@; eval "require ExtUtils::CBuilder;"; if ( $@ ) { # They don't obey configure_requires, so it is # someone old and delicate. Try to avoid hurting # them by falling back to an older simpler test. return $self->can_cc(); } # Do we have a working C compiler my $builder = ExtUtils::CBuilder->new( quiet => 1, ); unless ( $builder->have_compiler ) { # No working C compiler return 0; } # Write a C file representative of what XS becomes require File::Temp; my ( $FH, $tmpfile ) = File::Temp::tempfile( "compilexs-XXXXX", SUFFIX => '.c', ); binmode $FH; print $FH <<'END_C'; #include "EXTERN.h" #include "perl.h" #include "XSUB.h" int main(int argc, char **argv) { return 0; } int boot_sanexs() { return 1; } END_C close $FH; # Can the C compiler access the same headers XS does my @libs = (); my $object = undef; eval { local $^W = 0; $object = $builder->compile( source => $tmpfile, ); @libs = $builder->link( objects => $object, module_name => 'sanexs', ); }; my $result = $@ ? 0 : 1; # Clean up all the build files foreach ( $tmpfile, $object, @libs ) { next unless defined $_; 1 while unlink; } return $result; } # Can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 236 JSON-RPC-1.03/inc/Module/Install/Fetch.pm000644 000765 000024 00000004627 11766777503 020447 0ustar00daisukestaff000000 000000 #line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; JSON-RPC-1.03/inc/Module/Install/Makefile.pm000644 000765 000024 00000027437 11766777503 021137 0ustar00daisukestaff000000 000000 #line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use Fcntl qw/:flock :seek/; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # This previous attempted to inherit the version of # ExtUtils::MakeMaker in use by the module author, but this # was found to be untenable as some authors build releases # using future dev versions of EU:MM that nobody else has. # Instead, #toolchain suggests we use 6.59 which is the most # stable version on CPAN at time of writing and is, to quote # ribasushi, "not terminally fucked, > and tested enough". # TODO: We will now need to maintain this over time to push # the version up as new versions are released. $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 544 JSON-RPC-1.03/inc/Module/Install/Metadata.pm000644 000765 000024 00000043277 11766777503 021142 0ustar00daisukestaff000000 000000 #line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; my $value = @_ ? shift : 1; if ( $self->{values}->{dynamic_config} ) { # Once dynamic we never change to static, for safety return 0; } $self->{values}->{dynamic_config} = $value ? 1 : 0; return 1; } # Convenience command sub static_config { shift->dynamic_config(0); } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the really old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) \s* ; /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license 2\.0' => 'artistic_2', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashs delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; JSON-RPC-1.03/inc/Module/Install/Repository.pm000644 000765 000024 00000004256 11766777503 021573 0ustar00daisukestaff000000 000000 #line 1 package Module::Install::Repository; use strict; use 5.005; use vars qw($VERSION); $VERSION = '0.06'; use base qw(Module::Install::Base); sub _execute { my ($command) = @_; `$command`; } sub auto_set_repository { my $self = shift; return unless $Module::Install::AUTHOR; my $repo = _find_repo(\&_execute); if ($repo) { $self->repository($repo); } else { warn "Cannot determine repository URL\n"; } } sub _find_repo { my ($execute) = @_; if (-e ".git") { # TODO support remote besides 'origin'? if ($execute->('git remote show -n origin') =~ /URL: (.*)$/m) { # XXX Make it public clone URL, but this only works with github my $git_url = $1; $git_url =~ s![\w\-]+\@([^:]+):!git://$1/!; return $git_url; } elsif ($execute->('git svn info') =~ /URL: (.*)$/m) { return $1; } } elsif (-e ".svn") { if (`svn info` =~ /URL: (.*)$/m) { return $1; } } elsif (-e "_darcs") { # defaultrepo is better, but that is more likely to be ssh, not http if (my $query_repo = `darcs query repo`) { if ($query_repo =~ m!Default Remote: (http://.+)!) { return $1; } } open my $handle, '<', '_darcs/prefs/repos' or return; while (<$handle>) { chomp; return $_ if m!^http://!; } } elsif (-e ".hg") { if ($execute->('hg paths') =~ /default = (.*)$/m) { my $mercurial_url = $1; $mercurial_url =~ s!^ssh://hg\@(bitbucket\.org/)!https://$1!; return $mercurial_url; } } elsif (-e "$ENV{HOME}/.svk") { # Is there an explicit way to check if it's an svk checkout? my $svk_info = `svk info` or return; SVK_INFO: { if ($svk_info =~ /Mirrored From: (.*), Rev\./) { return $1; } if ($svk_info =~ m!Merged From: (/mirror/.*), Rev\.!) { $svk_info = `svk info /$1` or return; redo SVK_INFO; } } return; } } 1; __END__ =encoding utf-8 #line 128 JSON-RPC-1.03/inc/Module/Install/Win32.pm000644 000765 000024 00000003403 11766777503 020307 0ustar00daisukestaff000000 000000 #line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; JSON-RPC-1.03/inc/Module/Install/WriteAll.pm000644 000765 000024 00000002376 11766777503 021140 0ustar00daisukestaff000000 000000 #line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { # XXX: This still may be a bit over-defensive... unless ($self->makemaker(6.25)) { $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; } } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1;