XML-RPC-Fast-0.8/000755 002100 002100 00000000000 11707766363 013324 5ustar00monsmons000000 000000 XML-RPC-Fast-0.8/inc/000755 002100 002100 00000000000 11707766363 014075 5ustar00monsmons000000 000000 XML-RPC-Fast-0.8/Changes000644 002100 002100 00000001641 11707766330 014613 0ustar00monsmons000000 000000 # XML::RPC::Fast history 0.8 2012-01-25 * fix Curl * fix encoding of large integers * customtype generator 0.7 2011-02-10 * Add WWW::Curl useragent (faster than LWP) * Add ability to redefine call url via encoder * Fix encoding of large integers 0.6 2009-09-04 * Fixes (thanks to Marko Nordberg for reports) * Added internal_encoding to Enc::LibXML 0.5 2009-09-03 * Fixes to tests * Added req method (more universal than call) * Make accessors with set ability * Add UA::AnyEvent 0.4 2009-08-28 * Make modular encoder and useragent * Use XML::LibXML instead of XML::Parser 0.3 2009-02-01 * Fix broken dependency on XML::Parser 0.2 2009-01-29 * add lwp_options, fix requests_redirectable by default * minor fixes of parsing/deparsing * fix dependency on Encode 0.1 2008-10-24 * First release XML-RPC-Fast-0.8/MYMETA.yml000644 002100 002100 00000001656 11707766354 015053 0ustar00monsmons000000 000000 --- abstract: 'Fast and modular implementation for an XML-RPC client and server' author: - 'Mons Anderson, C<< >>' - 'Mons Anderson ' build_requires: Encode: 0 ExtUtils::MakeMaker: 6.62 Test::More: 0 Test::NoWarnings: 0 lib::abs: 0.90 configure_requires: ExtUtils::MakeMaker: 6.62 dynamic_config: 0 generated_by: 'Module::Install version 1.04, CPAN::Meta::Converter version 2.112150' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: XML-RPC-Fast no_index: directory: - inc - t - xt recommends: AnyEvent: 5.0 AnyEvent::HTTP: 0 DateTime::Format::ISO8601: 0 MIME::Base64: 0 Sub::Name: 0 WWW::Curl: 0 requires: HTTP::Headers: 0 HTTP::Request: 0 HTTP::Response: 0 LWP::UserAgent: 0 XML::Hash::LX: 0.05 XML::LibXML: 1.58 perl: 5.008003 resources: license: http://dev.perl.org/licenses/ version: 0.8 XML-RPC-Fast-0.8/MANIFEST000644 002100 002100 00000001433 11707766352 014454 0ustar00monsmons000000 000000 .gitignore Changes ex/anyevent-client-gv.pl ex/anyevent-client.pl ex/anyevent-sync.pl ex/sample.pl inc/Module/AutoInstall.pm inc/Module/Install.pm inc/Module/Install/AutoInstall.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Include.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/XML/RPC/Enc.pm lib/XML/RPC/Enc/LibXML.pm lib/XML/RPC/Fast.pm lib/XML/RPC/UA.pm lib/XML/RPC/UA/AnyEvent.pm lib/XML/RPC/UA/AnyEventSync.pm lib/XML/RPC/UA/Curl.pm lib/XML/RPC/UA/LWP.pm LICENSE Makefile.PL MANIFEST This list of files MANIFEST.SKIP META.yml MYMETA.json MYMETA.yml README README.pod t/00-load.t t/01-compatibility.t t/02-enc.t t/pod-coverage.t t/pod.t xt/99-dist.t XML-RPC-Fast-0.8/lib/000755 002100 002100 00000000000 11707766363 014072 5ustar00monsmons000000 000000 XML-RPC-Fast-0.8/ex/000755 002100 002100 00000000000 11707766363 013740 5ustar00monsmons000000 000000 XML-RPC-Fast-0.8/t/000755 002100 002100 00000000000 11707766363 013567 5ustar00monsmons000000 000000 XML-RPC-Fast-0.8/META.yml000644 002100 002100 00000002732 11707766354 014601 0ustar00monsmons000000 000000 --- abstract: 'Fast and modular implementation for an XML-RPC client and server' author: - 'Mons Anderson, C<< >>' - 'Mons Anderson ' build_requires: Encode: 0 ExtUtils::MakeMaker: 6.62 Test::More: 0 Test::NoWarnings: 0 lib::abs: 0.90 configure_requires: ExtUtils::MakeMaker: 6.62 distribution_type: module dynamic_config: 1 generated_by: 'Module::Install version 1.04' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: XML-RPC-Fast no_index: directory: - inc - t - xt provides: XML::RPC::Enc: file: lib/XML/RPC/Enc.pm version: 0 XML::RPC::Enc::LibXML: file: lib/XML/RPC/Enc/LibXML.pm version: 0 XML::RPC::Fast: file: lib/XML/RPC/Fast.pm version: 0.8 XML::RPC::UA: file: lib/XML/RPC/UA.pm version: 0 XML::RPC::UA::AnyEvent: file: lib/XML/RPC/UA/AnyEvent.pm version: 0 XML::RPC::UA::AnyEventSync: file: lib/XML/RPC/UA/AnyEventSync.pm version: 0 XML::RPC::UA::Curl: file: lib/XML/RPC/UA/Curl.pm version: 0 XML::RPC::UA::LWP: file: lib/XML/RPC/UA/LWP.pm version: 0 recommends: AnyEvent: 5.0 AnyEvent::HTTP: 0 DateTime::Format::ISO8601: 0 MIME::Base64: 0 Sub::Name: 0 WWW::Curl: 0 requires: HTTP::Headers: 0 HTTP::Request: 0 HTTP::Response: 0 LWP::UserAgent: 0 XML::Hash::LX: 0.05 XML::LibXML: 1.58 perl: 5.8.3 resources: license: http://dev.perl.org/licenses/ version: 0.8 XML-RPC-Fast-0.8/MYMETA.json000644 002100 002100 00000004732 11707766361 015217 0ustar00monsmons000000 000000 { "abstract" : "Fast and modular implementation for an XML-RPC client and server", "author" : [ "Mons Anderson, C<< >>", "Mons Anderson " ], "dynamic_config" : 0, "generated_by" : "Module::Install version 1.04, CPAN::Meta::Converter version 2.112150", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "XML-RPC-Fast", "no_index" : { "directory" : [ "inc", "t", "xt" ] }, "prereqs" : { "build" : { "requires" : { "Encode" : 0, "ExtUtils::MakeMaker" : "6.62", "Test::More" : 0, "Test::NoWarnings" : 0, "lib::abs" : "0.90" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "6.62" } }, "runtime" : { "recommends" : { "AnyEvent" : "5.0", "AnyEvent::HTTP" : 0, "DateTime::Format::ISO8601" : 0, "MIME::Base64" : 0, "Sub::Name" : 0, "WWW::Curl" : 0 }, "requires" : { "HTTP::Headers" : 0, "HTTP::Request" : 0, "HTTP::Response" : 0, "LWP::UserAgent" : 0, "XML::Hash::LX" : "0.05", "XML::LibXML" : "1.58", "perl" : "5.008003" } } }, "provides" : { "XML::RPC::Enc" : { "file" : "lib/XML/RPC/Enc.pm", "version" : 0 }, "XML::RPC::Enc::LibXML" : { "file" : "lib/XML/RPC/Enc/LibXML.pm", "version" : 0 }, "XML::RPC::Fast" : { "file" : "lib/XML/RPC/Fast.pm", "version" : "0.8" }, "XML::RPC::UA" : { "file" : "lib/XML/RPC/UA.pm", "version" : 0 }, "XML::RPC::UA::AnyEvent" : { "file" : "lib/XML/RPC/UA/AnyEvent.pm", "version" : 0 }, "XML::RPC::UA::AnyEventSync" : { "file" : "lib/XML/RPC/UA/AnyEventSync.pm", "version" : 0 }, "XML::RPC::UA::Curl" : { "file" : "lib/XML/RPC/UA/Curl.pm", "version" : 0 }, "XML::RPC::UA::LWP" : { "file" : "lib/XML/RPC/UA/LWP.pm", "version" : 0 } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ] }, "version" : "0.8" } XML-RPC-Fast-0.8/MANIFEST.SKIP000644 002100 002100 00000000751 11647525677 015231 0ustar00monsmons000000 000000 # Avoid version control files. \B\.git\b # Avoid Makemaker generated and utility files. \bMANIFEST\.bak \bMakefile$ \bblib/ \bMakeMaker-\d \bpm_to_blib\.ts$ \bpm_to_blib$ \bblibdirs\.ts$ # 6.18 through 6.25 generated this # Avoid Module::Build generated and utility files. \bBuild$ \b_build/ # Avoid temp and backup files. ~$ \.old$ \#$ \b\.# \.bak$ # Avoid Devel::Cover files. \bcover_db\b # Avoid local testing/dist files ^dist/ ^makeall\.sh$ ^tmp/ ^AnyEvent-Connection-.* XML-RPC-Fast-0.8/README.pod000644 002100 002100 00000015251 11707766350 014765 0ustar00monsmons000000 000000 =head1 NAME XML::RPC::Fast - Fast and modular implementation for an XML-RPC client and server =cut =head1 SYNOPSIS Generic usage use XML::RPC::Fast; my $server = XML::RPC::Fast->new( undef, %args ); my $client = XML::RPC::Fast->new( $uri, %args ); Create a simple XML-RPC service: use XML::RPC::Fast; my $rpc = XML::RPC::Fast->new( undef, # the url is not required by server external_encoding => 'koi8-r', # any encoding, accepted by Encode #internal_encoding => 'koi8-r', # not supported for now ); my $xml = do { local $/; }; length($xml) == $ENV{CONTENT_LENGTH} or warn "Content-Length differs from actually received"; print "Content-type: text/xml; charset=$rpc->{external_encoding}\n\n"; print $rpc->receive( $xml, sub { my ( $methodname, @params ) = @_; return { you_called => $methodname, with_params => \@params }; } ); Make a call to an XML-RPC service: use XML::RPC::Fast; my $rpc = XML::RPC::Fast->new( 'http://your.hostname/rpc/url' ); # Syncronous call my @result = $rpc->req( call => [ 'examples.getStateStruct', { state1 => 12, state2 => 28 } ], url => 'http://...', ); # Syncronous call (compatibility method) my @result = $rpc->call( 'examples.getStateStruct', { state1 => 12, state2 => 28 } ); # Syncronous or asyncronous call $rpc->req( call => ['examples.getStateStruct', { state1 => 12, state2 => 28 }], cb => sub { my @result = @_; }, ); # Syncronous or asyncronous call (compatibility method) $rpc->call( sub { my @result = @_; }, 'examples.getStateStruct', { state1 => 12, state2 => 28 } ); =head1 DESCRIPTION XML::RPC::Fast is format-compatible with XML::RPC, but may use different encoders to parse/compose xml. Curerntly included encoder uses L, and is 3 times faster than XML::RPC and 75% faster, than XML::Parser implementation =head1 METHODS =head2 new ($url, %args) Create XML::RPC::Fast object, server if url is undef, client if url is defined =head2 req( %ARGS ) Clientside. Make syncronous or asyncronous call (depends on UA). If have cb, will invoke $cb with results and should not croak If have no cb, will return results and croak on error (only syncronous UA) Arguments are =over 4 =item call => [ methodName => @args ] array ref of call arguments. Required =item cb => $cb->(@results) Invocation callback. Optional for syncronous UA. Behaviour is same as in call with C<$cb> and without =item url => $request_url Alternative invocation URL. Optional. By default will be used defined from constructor =item headers => { http-headers hashref } Additional http headers to request =item external_encoding => '..., Specify the encoding, used inside XML container just for this request. Passed to encoder =back =head2 call( 'method_name', @arguments ) : @results Clientside. Make syncronous call and return results. Croaks on error. Just a simple wrapper around C =head2 call( $cb->(@res), 'method_name', @arguments ): void Clientside. Make syncronous or asyncronous call (depends on UA) and invoke $cb with results. Should not croak. Just a simple wrapper around C =head2 receive ( $xml, $handler->($methodName,@args) ) : xml byte-stream Serverside. Process received XML and invoke $handler with parameters $methodName and @args and returns response XML On error conditions C<$handler> could set C<$XML::RPC::Fast::faultCode> and die, or return C ->receive( $xml, sub { # ... return rpcfault( 3, "Some error" ) if $error_condition $XML::RPC::Fast::faultCode = 4 and die "Another error" if $another_error_condition; return { call => $methodname, params => \@params }; }) =head2 registerType Proxy-method to encoder. See L =head2 registerClass Proxy-method to encoder. See L =head1 OPTIONS Below is the options, accepted by new() =head2 ua Client only. Useragent object, or package name ->new( $url, ua => 'LWP' ) # same as XML::RPC::UA::LWP # or ->new( $url, ua => 'XML::RPC::UA::LWP' ) # or ->new( $url, ua => XML::RPC::UA::LWP->new( ... ) ) # or ->new( $url, ua => XML::RPC::UA::Curl->new( ... ) ) =head2 timeout Client only. Timeout for calls. Passed directly to UA ->new( $url, ua => 'LWP', timeout => 10 ) =head2 useragent Client only. Useragent string. Passed directly to UA ->new( $url, ua => 'LWP', useragent => 'YourClient/1.11' ) =head2 encoder Client and server. Encoder object or package name ->new( $url, encoder => 'LibXML' ) # or ->new( $url, encoder => 'XML::RPC::Enc::LibXML' ) # or ->new( $url, encoder => XML::RPC::Enc::LibXML->new( ... ) ) =head2 internal_encoding B Specify the encoding you are using in your code. By default option is undef, which means flagged utf-8 For translations is used Encode, so the list of accepted encodings fully derived from it. =head2 external_encoding Specify the encoding, used inside XML container. By default it's utf-8. Passed directly to encoder ->new( $url, encoder => 'LibXML', external_encoding => 'koi8-r' ) =head1 ACCESSORS =head2 url Get or set client url =head2 encoder Direct access to encoder object =head2 ua Direct access to useragent object =head1 FUNCTIONS =head2 rpcfault(faultCode, faultString) Returns hash structure, that may be returned by serverside handler, instead of die. Not exported by default =head1 CUSTOM TYPES =head2 sub {{ 'base64' => encode_base64($data) }} When passing a CODEREF as a value, encoder will simply use the returned hashref as a type => value pair. =head2 bless( do{\(my $o = encode_base64('test') )}, 'base64' ) When passing SCALARREF as a value, package name will be taken as type and dereference as a value =head2 bless( do{\(my $o = { something =>'complex' } )}, 'base64' ) When passing REFREF as a value, package name will be taken as type and LC<::hash2xml(deref)> would be used as value =head2 customtype( $type, $data ) Easily compose SCALARREF based custom type =cut =head1 BUGS & SUPPORT Bugs reports and testcases are welcome. It you write your own Enc or UA, I may include it into distribution If you have propositions for default custom types (see Enc), send me patches See L to report and view bugs. =head1 AUTHOR Mons Anderson, C<< >> =head1 COPYRIGHT & LICENSE Copyright (c) 2008-2009 Mons Anderson. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut XML-RPC-Fast-0.8/.gitignore000644 002100 002100 00000000150 11647525677 015314 0ustar00monsmons000000 000000 blib* inc* Makefile Makefile.old Build _build* pm_to_blib* *.tar.gz .lwpcookies XML-RPC-Fast-* cover_db XML-RPC-Fast-0.8/xt/000755 002100 002100 00000000000 11707766363 013757 5ustar00monsmons000000 000000 XML-RPC-Fast-0.8/LICENSE000644 002100 002100 00000000257 11647525677 014341 0ustar00monsmons000000 000000 LICENSE This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Copyright 2008-2009 Mons Anderson, all rights reserved. XML-RPC-Fast-0.8/Makefile.PL000644 002100 002100 00000001646 11647525677 015311 0ustar00monsmons000000 000000 my $MI = $Module::Install::MAIN; use 5.008003; # I want Encode to work use inc::Module::Install; name 'XML-RPC-Fast'; all_from 'lib/XML/RPC/Fast.pm'; #version my $v = '0.6'; author 'Mons Anderson '; build_requires 'Test::More'; build_requires 'Test::NoWarnings'; build_requires 'lib::abs', '0.90'; build_requires 'Encode'; # requires 'Encode'; requires 'LWP::UserAgent'; requires 'HTTP::Request'; requires 'HTTP::Response'; requires 'HTTP::Headers'; requires 'XML::LibXML', '1.58'; requires 'XML::Hash::LX' , '0.05'; recommends 'Sub::Name'; recommends 'MIME::Base64'; recommends 'DateTime::Format::ISO8601'; recommends 'AnyEvent', '5.0'; recommends 'AnyEvent::HTTP'; recommends 'WWW::Curl'; if (!eval { my $x = pack 'q', -1; 1 }) { requires 'Math::BigInt'; } auto_provides; auto_install; WriteAll; print STDERR "Generated makefile for ".$MI->load('name')->name."-".$MI->load('version')->version."\n"; XML-RPC-Fast-0.8/README000644 002100 002100 00000015440 11707766350 014204 0ustar00monsmons000000 000000 NAME XML::RPC::Fast - Fast and modular implementation for an XML-RPC client and server SYNOPSIS Generic usage use XML::RPC::Fast; my $server = XML::RPC::Fast->new( undef, %args ); my $client = XML::RPC::Fast->new( $uri, %args ); Create a simple XML-RPC service: use XML::RPC::Fast; my $rpc = XML::RPC::Fast->new( undef, # the url is not required by server external_encoding => 'koi8-r', # any encoding, accepted by Encode #internal_encoding => 'koi8-r', # not supported for now ); my $xml = do { local $/; }; length($xml) == $ENV{CONTENT_LENGTH} or warn "Content-Length differs from actually received"; print "Content-type: text/xml; charset=$rpc->{external_encoding}\n\n"; print $rpc->receive( $xml, sub { my ( $methodname, @params ) = @_; return { you_called => $methodname, with_params => \@params }; } ); Make a call to an XML-RPC service: use XML::RPC::Fast; my $rpc = XML::RPC::Fast->new( 'http://your.hostname/rpc/url' ); # Syncronous call my @result = $rpc->req( call => [ 'examples.getStateStruct', { state1 => 12, state2 => 28 } ], url => 'http://...', ); # Syncronous call (compatibility method) my @result = $rpc->call( 'examples.getStateStruct', { state1 => 12, state2 => 28 } ); # Syncronous or asyncronous call $rpc->req( call => ['examples.getStateStruct', { state1 => 12, state2 => 28 }], cb => sub { my @result = @_; }, ); # Syncronous or asyncronous call (compatibility method) $rpc->call( sub { my @result = @_; }, 'examples.getStateStruct', { state1 => 12, state2 => 28 } ); DESCRIPTION XML::RPC::Fast is format-compatible with XML::RPC, but may use different encoders to parse/compose xml. Curerntly included encoder uses XML::LibXML, and is 3 times faster than XML::RPC and 75% faster, than XML::Parser implementation METHODS new ($url, %args) Create XML::RPC::Fast object, server if url is undef, client if url is defined req( %ARGS ) Clientside. Make syncronous or asyncronous call (depends on UA). If have cb, will invoke $cb with results and should not croak If have no cb, will return results and croak on error (only syncronous UA) Arguments are call => [ methodName => @args ] array ref of call arguments. Required cb => $cb->(@results) Invocation callback. Optional for syncronous UA. Behaviour is same as in call with $cb and without url => $request_url Alternative invocation URL. Optional. By default will be used defined from constructor headers => { http-headers hashref } Additional http headers to request external_encoding => '..., Specify the encoding, used inside XML container just for this request. Passed to encoder call( 'method_name', @arguments ) : @results Clientside. Make syncronous call and return results. Croaks on error. Just a simple wrapper around "req" call( $cb->(@res), 'method_name', @arguments ): void Clientside. Make syncronous or asyncronous call (depends on UA) and invoke $cb with results. Should not croak. Just a simple wrapper around "req" receive ( $xml, $handler->($methodName,@args) ) : xml byte-stream Serverside. Process received XML and invoke $handler with parameters $methodName and @args and returns response XML On error conditions $handler could set $XML::RPC::Fast::faultCode and die, or return "rpcfault($faultCode,$faultString)" ->receive( $xml, sub { # ... return rpcfault( 3, "Some error" ) if $error_condition $XML::RPC::Fast::faultCode = 4 and die "Another error" if $another_error_condition; return { call => $methodname, params => \@params }; }) registerType Proxy-method to encoder. See XML::RPC::Enc registerClass Proxy-method to encoder. See XML::RPC::Enc OPTIONS Below is the options, accepted by new() ua Client only. Useragent object, or package name ->new( $url, ua => 'LWP' ) # same as XML::RPC::UA::LWP # or ->new( $url, ua => 'XML::RPC::UA::LWP' ) # or ->new( $url, ua => XML::RPC::UA::LWP->new( ... ) ) # or ->new( $url, ua => XML::RPC::UA::Curl->new( ... ) ) timeout Client only. Timeout for calls. Passed directly to UA ->new( $url, ua => 'LWP', timeout => 10 ) useragent Client only. Useragent string. Passed directly to UA ->new( $url, ua => 'LWP', useragent => 'YourClient/1.11' ) encoder Client and server. Encoder object or package name ->new( $url, encoder => 'LibXML' ) # or ->new( $url, encoder => 'XML::RPC::Enc::LibXML' ) # or ->new( $url, encoder => XML::RPC::Enc::LibXML->new( ... ) ) internal_encoding NOT IMPLEMENTED YET Specify the encoding you are using in your code. By default option is undef, which means flagged utf-8 For translations is used Encode, so the list of accepted encodings fully derived from it. external_encoding Specify the encoding, used inside XML container. By default it's utf-8. Passed directly to encoder ->new( $url, encoder => 'LibXML', external_encoding => 'koi8-r' ) ACCESSORS url Get or set client url encoder Direct access to encoder object ua Direct access to useragent object FUNCTIONS rpcfault(faultCode, faultString) Returns hash structure, that may be returned by serverside handler, instead of die. Not exported by default CUSTOM TYPES sub {{ 'base64' => encode_base64($data) }} When passing a CODEREF as a value, encoder will simply use the returned hashref as a type => value pair. bless( do{\(my $o = encode_base64('test') )}, 'base64' ) When passing SCALARREF as a value, package name will be taken as type and dereference as a value bless( do{\(my $o = { something =>'complex' } )}, 'base64' ) When passing REFREF as a value, package name will be taken as type and XML::Hash::LX"::hash2xml(deref)" would be used as value customtype( $type, $data ) Easily compose SCALARREF based custom type BUGS & SUPPORT Bugs reports and testcases are welcome. It you write your own Enc or UA, I may include it into distribution If you have propositions for default custom types (see Enc), send me patches See to report and view bugs. AUTHOR Mons Anderson, "" COPYRIGHT & LICENSE Copyright (c) 2008-2009 Mons Anderson. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. XML-RPC-Fast-0.8/xt/99-dist.t000644 002100 002100 00000000671 11647525677 015356 0ustar00monsmons000000 000000 #!/usr/bin/perl use lib::abs '../lib'; use Test::More; use Test::Dist; use Test::NoWarnings; chdir lib::abs::path('..'); Test::Dist::dist_ok( run => 1, '+' => 1, skip => [qw(prereq)], kwalitee => { req => [qw( has_separate_license_file has_example metayml_has_provides metayml_declares_perl_version uses_test_nowarnings has_version_in_each_file )], }, prereq => [ undef,undef, [qw( Test::Pod Test::Pod::Coverage )], ], ); XML-RPC-Fast-0.8/t/02-enc.t000644 002100 002100 00000025026 11647525677 014751 0ustar00monsmons000000 000000 #!/usr/bin/perl -w use strict; use lib::abs '../lib'; use XML::RPC::Enc::LibXML; use XML::Hash::LX 0.05; use Test::More; use Test::NoWarnings; use Encode; BEGIN{ binmode Test::More->builder->$_, ':utf8' for qw(failure_output todo_output output); } plan tests => 42; my $enc = XML::RPC::Enc::LibXML->new( internal_encoding => 'utf8', ); my $hd = qq{\n}; my ($xml,$data); #$xml = q{bss.storeDataStoragevalue€€€nametest}; #print + Dumper $enc->decode( $xml );exit; #print my $xml = $enc->request( test => bless( \do {my $o}, 'custom' ) );#exit; #use Data::Dumper; print + Dumper $enc->decode( $xml ); #exit; $SIG{__DIE__} = sub { require Carp;Carp::confess @_ }; is $xml = $enc->request( test => () ), $hd."test\n", 'undef args', or diag explain ($xml) ; is_deeply $data = [ $enc->decode($xml) ], [ test => () ], 'decode empty', or diag explain $data ; is $xml = $enc->request( test => bless( \do {my $o}, 'custom' ) ), $hd."test\n", 'custom undef args', or diag explain ($xml) ; is_deeply $data = [ $enc->decode($xml) ], [ test => bless( \do {my $o}, 'custom' ) ], 'decode empty custom', or diag explain $data ; is_deeply xml2hash( $enc->request( test => 1 ) ), { methodCall => { methodName => "test", params => { param => { value => { i4 => 1 } } } } }, 'request i4'; is_deeply xml2hash( $enc->request( test => 1.1 ) ), { methodCall => { methodName => "test", params => { param => { value => { double => 1.1 } } } } }, 'request double'; is_deeply xml2hash( $enc->request( test => 'z' ) ), { methodCall => { methodName => "test", params => { param => { value => { string => 'z' } } } } }, 'request string'; is_deeply xml2hash( $xml = $enc->request( test => { a => 1 } ) ), { methodCall => { methodName => "test", params => { param => { value => { struct => { member => { name => 'a', value => { i4 => 1 } } } } } } } }, 'request struct'; is $xml, $hd."testa1\n", 'request xml struct' or diag explain $xml ; is_deeply xml2hash( $enc->request( test => [ 1,2 ] ) ), { methodCall => { methodName => "test", params => { param => { value => { array => { data => { value => [ {i4 => 1},{i4 => 2} ] } } } } } } }, 'request array'; is_deeply xml2hash( $enc->request( test => sub {{ custom => '12345' }}, ) ), { methodCall => { methodName => "test", params => { param => { value => { custom => '12345' } } } } }, 'request custom compat'; is_deeply xml2hash( $enc->request( test => bless( do{\(my $o = '12345')}, 'custom' ) ) ), { methodCall => { methodName => "test", params => { param => { value => { custom => '12345' } } } } }, 'request custom bless'; is_deeply xml2hash( $enc->request( test => bless( do{\(my $o = { a => 1 })}, 'custom' ) ) ), { methodCall => { methodName => "test", params => { param => { value => { custom => { a => 1 } } } } } }, 'request custom bless'; is_deeply xml2hash( $enc->response( 1 ) ), { methodResponse => { params => { param => { value => { i4 => 1 } } } } }, 'response i4'; is_deeply xml2hash( $enc->response( 1.1 ) ), { methodResponse => { params => { param => { value => { double => 1.1 } } } } }, 'response double'; is_deeply xml2hash( $enc->response( 'z' ) ), { methodResponse => { params => { param => { value => { string => 'z' } } } } }, 'response string'; is_deeply $data = xml2hash( $enc->response( "5000000000" ) ), { methodResponse => { params => { param => { value => { i8 => "5000000000" } } } } }, 'response i8' or diag explain $data; is_deeply $data = xml2hash( $enc->response( "-5000000000" ) ), { methodResponse => { params => { param => { value => { i8 => "-5000000000" } } } } }, 'response -i8' or diag explain $data; is_deeply $data = xml2hash( $enc->response( "500000000000000000000" ) ), { methodResponse => { params => { param => { value => { string => "500000000000000000000" } } } } }, 'response very big integer' or diag explain $data; is_deeply $data = xml2hash( $enc->response( "+111111111111111111111111111.1111111111111111111111111" ) ), { methodResponse => { params => { param => { value => { double => "+111111111111111111111111111.1111111111111111111111111" } } } } }, 'response big double' or diag explain $data; is_deeply $data = xml2hash( $enc->response( "+0" ) ), { methodResponse => { params => { param => { value => { i4 => "0" } } } } }, 'response +0' or diag explain $data; is_deeply $data = xml2hash( $enc->response( "-0" ) ), { methodResponse => { params => { param => { value => { i4 => "0" } } } } }, 'response -0' or diag explain $data; is_deeply xml2hash( $enc->fault( 555,'test' ) ), { methodResponse => { fault => { value => { struct => { member => [ {name => faultCode => value => { i4 => 555 }}, {name => faultString => value => { string => 'test' }}, ]}}}}}, 'fault'; { local $enc->{external_encoding} = 'windows-1251'; local $enc->{internal_encoding} = undef; is $enc->response( Encode::decode utf8 => "тест" ), Encode::encode( $enc->{external_encoding} => Encode::decode utf8 => qq{\nтест\n} ), 'external_encoding'; } { use bytes; local $enc->{internal_encoding} = undef; is $enc->response( Encode::decode utf8 => "тест" ), qq{\nтест\n}, 'utf8-ness'; } # Decoder is_deeply [ $enc->decode( ( $enc->request( test => 1 ) ) ) ], [ test => 1 ], 'decode i4'; is_deeply [ $enc->decode( ( $enc->request( test => 1.2 ) ) ) ], [ test => 1.2 ], 'decode double'; is_deeply [ $enc->decode( ( $enc->request( test => 'z' ) ) ) ], [ test => 'z' ], 'decode string'; is_deeply [ $enc->decode( ( $enc->request( test => sub{{ custom => '12345'}} ) ) ) ], [ test => bless(do{\(my $o = '12345')}, 'custom') ], 'decode custom compat'; is_deeply [ $enc->decode( ( $enc->request( test => bless( do{\(my $o = '12345')}, 'custom' ) ) ) ) ], [ test => bless(do{\(my $o = '12345')}, 'custom') ], 'decode custom bless'; is_deeply $data = [ $enc->decode( ( $xml = $enc->request( test => bless( do{\(my $o = {a => 1})}, 'custom' ) ) ) ) ], [ test => bless(do{\(my $o = {a => 1})}, 'custom') ], 'decode custom bless struct', or diag explain($xml,$data) ; is_deeply $data = [ $enc->decode( ( $xml = $enc->request( test => { a => 1 } ) ) ) ], [ test => { a => 1 } ], 'decode struct', or diag explain($xml,$data) ; SKIP : { eval { require MIME::Base64;1 } or skip 'MIME::Base64 required',1; is_deeply [ $enc->decode( ( $enc->request( test => sub{{ base64 => MIME::Base64::encode('test') }} ) ) ) ], [ test => 'test' ], 'decode base64'; } SKIP : { eval { require DateTime::Format::ISO8601; 1 } or skip 'DateTime::Format::ISO8601 required',1; is_deeply [ $enc->decode( ( $enc->request( test => sub {{ 'dateTime.iso8601' => '20090816T010203.04+0330' }} ) ) ) ], [ test => DateTime::Format::ISO8601->parse_datetime('20090816T010203.04+0330') ], 'decode datetime'; } # Tests for Marko Nordberg's testcases { is_deeply $data = [ $enc->decode( q{statusnoError} ) ], [ { status => 'noError' } ], 'decode 1', or diag explain($data) ; } { local $enc->{internal_encoding} = undef; is_deeply $data = [ $enc->decode( q{bss.storeDataStoragevalue€€€nametest} ) ], [ 'bss.storeDataStorage' => { name => 'test', value => "\x{20ac}\x{20ac}\x{20ac}", } ], 'decode 2', or diag explain($data) ; } { local $enc->{internal_encoding} = undef; is $data = length($xml = $enc->request( 'bss.storeDataStorage' => { name => 'test', value => "\x{20ac}\x{20ac}\x{20ac}", } )), 320, 'utf8 xml content length' or diag explain $data, $xml; } is $data = length($xml = $enc->request( 'bss.storeDataStorage' => { name => 'test', value => "€€€", } )), 320, 'inplace octets xml content length' or diag explain $data, $xml; is $data = length($xml = $enc->request( 'bss.storeDataStorage' => { name => 'test', value => "\342\202\254\342\202\254\342\202\254", } )), 320, 'octets xml content length' or diag explain $data, $xml; { local $enc->{internal_encoding} = undef; is_deeply $data = [ $enc->decode( q{storeDataStoragevalueÄÄÄnametest} ) ], [ storeDataStorage => { name => 'test', value => "\x{c4}\x{c4}\x{c4}", }], 'decode 3', or diag explain($data) ; } { #local $enc->{internal_encoding} = undef; is_deeply $data = [ $enc->decode( qq{$hd} ) ], [ [] ], 'decode 4', or diag explain($data) ; } __END__ is_deeply $data = [ $enc->decode( q{} ) ], [ ], 'decode 3', or diag Dumper($data) ; my $hash = [ { name => 'rec', entries => { name => 'ent', fields => [ a => 1 ] }, } ]; my @prm = ( 1, 0.1, a => { my => [ test => 1 ], -is => 1}, bless( do{\(my $o = '12345')}, 'estring' ), bless( do{\(my $o = { inner => 1 })}, 'xval' ), sub {{ bool => '1' }}, sub {{ base64 => encode_base64('test') } }, sub {{ }}, # bless( {}, 'zzz' ), sub {{ custom => 'cusval' }}, #sub {[ { subs => 'subval' }, { -x => 1 } ]}, ); #print $t->parse(my $xml = $enc->encode( test => @prm ))->sprint; #print $t->parse(my $xml = $enc->response( @prm ))->sprint; print $t->parse(my $xml = $enc->fault( 111, 'err' ))->sprint; XML-RPC-Fast-0.8/t/pod-coverage.t000644 002100 002100 00000001227 11647525677 016335 0ustar00monsmons000000 000000 #!/usr/bin/env perl -w use strict; use Test::More; use lib::abs "../lib"; BEGIN { my $lib = lib::abs::path( ".." ); chdir $lib or plan skip_all => "Can't chdir to dist $lib"; } $ENV{TEST_AUTHOR} or plan skip_all => '$ENV{TEST_AUTHOR} not set'; # Ensure a recent version of Test::Pod::Coverage eval "use Test::Pod::Coverage 1.08; 1" or plan skip_all => "Test::Pod::Coverage 1.08 required for testing POD coverage"; eval "use Pod::Coverage 0.18; 1" or plan skip_all => "Pod::Coverage 0.18 required for testing POD coverage"; #plan tests => 1; all_pod_coverage_ok(); #all_pod_coverage_ok(); exit 0; require Test::Pod::Coverage; # ;) require Test::NoWarnings; XML-RPC-Fast-0.8/t/00-load.t000644 002100 002100 00000001262 11647525677 015115 0ustar00monsmons000000 000000 #!/usr/bin/perl -w use Test::More tests => 9; use Test::NoWarnings; use lib::abs '../lib'; BEGIN { use_ok( 'XML::RPC::Fast' ); use_ok( 'XML::RPC::Enc' ); use_ok( 'XML::RPC::Enc::LibXML' ); use_ok( 'XML::RPC::UA' ); use_ok( 'XML::RPC::UA::LWP' ); SKIP: { eval { require WWW::Curl::Easy; } or skip "WWW::Curl missed, UA::Curl will not work",1; use_ok( 'XML::RPC::UA::Curl' ); } SKIP: { eval { require AnyEvent::HTTP; } or skip "AnyEvent::HTTP missed, UA::AnyEvent will not work",2; use_ok( 'XML::RPC::UA::AnyEvent' ); use_ok( 'XML::RPC::UA::AnyEventSync' ); } } diag( "Testing XML::RPC::Fast $XML::RPC::Fast::VERSION, XML::LibXML $XML::LibXML::VERSION, Perl $], $^X" ); XML-RPC-Fast-0.8/t/pod.t000644 002100 002100 00000000706 11647525677 014545 0ustar00monsmons000000 000000 #!/usr/bin/env perl -w use strict; use Test::More; use lib::abs "../lib"; BEGIN { my $lib = lib::abs::path( ".." ); chdir $lib or plan skip_all => "Can't chdir to dist $lib"; } # Ensure a recent version of Test::Pod eval "use Test::Pod 1.22; 1" or plan skip_all => "Test::Pod 1.22 required for testing POD"; eval "use File::Find; 1" or plan skip_all => "File::Find required for testing POD"; all_pod_files_ok(); exit 0; require Test::NoWarnings; XML-RPC-Fast-0.8/t/01-compatibility.t000644 002100 002100 00000001062 11647525677 017046 0ustar00monsmons000000 000000 #!/usr/bin/perl -w use strict; use lib::abs '../lib'; use XML::RPC::Fast; use Test::More; BEGIN { eval "use XML::RPC 0.8;1" or plan skip_all => "XML::RPC 0.8 required for testing compatibility"; plan tests => 2; } use Test::NoWarnings; my $r = XML::RPC->new(); my $hash = [ { name => 'rec', entries => { name => 'ent', fields => [ a => 1 ] }, } ]; my $xml = $r->create_call_xml(test => $hash); my @in = $r->unparse_call( $r->{tpp}->parse($xml) ); my @f_in = XML::RPC::Fast->new()->encoder->decode($xml); is_deeply(\@in,\@f_in, 'args struct'); XML-RPC-Fast-0.8/ex/anyevent-client.pl000644 002100 002100 00000001400 11647525677 017401 0ustar00monsmons000000 000000 #!/usr/bin/env perl -w use utf8; use strict; use lib::abs '../lib'; use AnyEvent; use XML::RPC::Fast; use Data::Dumper; my $rpc = XML::RPC::Fast->new( 'http://betty.userland.com/RPC2', ua => 'AnyEvent', useragent => 'Test/0.1', timeout => 1, ); my $cv = AnyEvent->condvar; # Now, make any number of calls. When ged enough, call $cv->send; my $n = 2; my $got = 0; $rpc->req( call => [ 'examples.getStateStruct' => { state1 => 14, state2 => 25 } ], cb => sub { if (ref $_[0] eq 'HASH' and exists $_[0]{fault}) { warn "Failed: $_[0]{fault}{faultCode} / $XML::RPC::Fast::faultCode: $_[0]{fault}{faultString}"; } else { print "Success: ".Dumper \@_; } $cv->send if ++$got == $n; }, ) for 1..$n; # This blocks until $cv->send $cv->recv; XML-RPC-Fast-0.8/ex/sample.pl000644 002100 002100 00000001523 11647525677 015563 0ustar00monsmons000000 000000 #!/usr/bin/env perl -w use utf8; use strict; use lib::abs '../lib'; use XML::RPC::Fast; use Data::Dumper; my $rpc = XML::RPC::Fast->new( 'http://betty.userland.com/RPC2', encoder => 'LibXML', ua => 'LWP', useragent => 'Test/0.1', timeout => 1, ); # This never croaks. $rpc->call( sub { if (ref $_[0] eq 'HASH' and exists $_[0]{fault}) { warn "Failed: $_[0]{fault}{faultCode} / $XML::RPC::Fast::faultCode: $_[0]{fault}{faultString}"; } else { print "Success: ".Dumper \@_; } }, 'examples.getStateStruct', { state1 => 14, state2 => 25 } ); # This croaks on error, and return result on success my @result; eval { @result = $rpc->call( 'examples.getStateStruct', { state1 => 12, state2 => 28 } ); }; if (@result) { print "Success: ".Dumper \@result; } else { warn "Failed: $XML::RPC::Fast::faultCode: $@"; } XML-RPC-Fast-0.8/ex/anyevent-sync.pl000644 002100 002100 00000001653 11647525677 017111 0ustar00monsmons000000 000000 #!/usr/bin/env perl -w use utf8; use strict; use lib::abs '../lib'; use XML::RPC::Fast; use Data::Dumper; my $rpc = XML::RPC::Fast->new( 'http://betty.userland.com/RPC2', ua => 'AnyEventSync', useragent => 'Test/0.1', timeout => 1, ); # Now, make any number of calls. When ged enough, call $cv->send; my $n = 2; my $got = 0; $rpc->req( call => [ 'examples.getStateStruct' => { state1 => 14, state2 => 25 } ], cb => sub { if (ref $_[0] eq 'HASH' and exists $_[0]{fault}) { warn "Failed: $_[0]{fault}{faultCode} / $XML::RPC::Fast::faultCode: $_[0]{fault}{faultString}"; } else { print "Success: ".Dumper \@_; } }, ); warn "First request finished\n"; my @result; eval { @result = $rpc->call( 'examples.getStateStruct', { state1 => 12, state2 => 28 } ); }; if (@result) { print "Success: ".Dumper \@result; } else { warn "Failed: $XML::RPC::Fast::faultCode: $@"; } warn "Second request finished\n"; XML-RPC-Fast-0.8/ex/anyevent-client-gv.pl000644 002100 002100 00000001437 11647525677 020025 0ustar00monsmons000000 000000 #!/usr/bin/env perl -w use utf8; use strict; use lib::abs '../lib'; use AnyEvent; use XML::RPC::Fast; use Data::Dumper; my $rpc = XML::RPC::Fast->new( 'http://betty.userland.com/RPC2', ua => 'AnyEvent', useragent => 'Test/0.1', timeout => 1, ); my $cv = AnyEvent->condvar; $cv->begin(sub {$cv->send}); # Use group callback # Now, make any number of calls. When ged enough, call $cv->send; for (1..2) { $cv->begin; $rpc->call( sub { if (ref $_[0] eq 'HASH' and exists $_[0]{fault}) { warn "Failed: $_[0]{fault}{faultCode} / $XML::RPC::Fast::faultCode: $_[0]{fault}{faultString}"; } else { print "Success: ".Dumper \@_; } $cv->end; }, 'examples.getStateStruct', { state1 => 14, state2 => 25 } ); } $cv->end; $cv->recv; # This blocks until $cv->send XML-RPC-Fast-0.8/lib/XML/000755 002100 002100 00000000000 11707766363 014532 5ustar00monsmons000000 000000 XML-RPC-Fast-0.8/lib/XML/RPC/000755 002100 002100 00000000000 11707766363 015156 5ustar00monsmons000000 000000 XML-RPC-Fast-0.8/lib/XML/RPC/Enc.pm000644 002100 002100 00000007075 11647525677 016236 0ustar00monsmons000000 000000 package XML::RPC::Enc; =head1 NAME XML::RPC::Enc - Base class for XML::RPC encoders =head1 SYNOPSIS Generic usage use XML::RPC::Fast; my $server = XML::RPC::Fast->new( undef, encoder => XML::RPC::Enc::LibXML->new ); my $client = XML::RPC::Fast->new( $uri, encoder => XML::RPC::Enc::LibXML->new ); =cut use strict; use warnings; use Carp; # Base class for encoders use XML::RPC::Fast (); our $VERSION = $XML::RPC::Fast::VERSION; =head1 METHODS The following methods should be implemented =cut =head2 new (%args) Should support arguments: =over 4 =item internal_encoding [ = undef ] Internal encoding. C means wide perl characters (perl-5.8.1+) =item external_encoding [ = utf-8 ] External encoding. Which encoding to use in composed XML =back =cut sub new { my ( $pkg, %args ) = @_; } # Encoder part =head2 request ($method, @args) : xml byte-stream, [ new call url ] Encode request into XML =cut sub request { my ( $self, $method, @args ) = @_; croak "request not implemented by $self"; #return $xml; } =head2 response (@args) : xml byte-stream Encode response into XML =cut sub response { my ( $self, $method, @args ) = @_; croak "response not implemented by $self"; #return $xml; } =head2 fault ($faultcode, $faultstring) : xml byte-stream Encode fault into XML =cut sub fault { my ( $self, $faultcode, $faultstring ) = @_; croak "fault not implemented by $self"; #return $xml; } =head2 registerClass ($class_name,$encoder_cb) Register encoders for custom Perl types Encoders description: # Generic: $simple_encoder_cb = sub { my $object = shift; # ... return type => $string; }; # Encoder-dependent (XML::RPC::Enc::LibXML) $complex_encoder_cb = sub { my $object = shift; # ... return XML::LibXML::Node; }; Samples: $enc->registerClass( DateTime => sub { return ( 'dateTime.iso8601' => $_[0]->strftime('%Y%m%dT%H%M%S.%3N%z') ); }); # Encoder-dependent (XML::RPC::Enc::LibXML) $enc->registerClass( DateTime => sub { my $node = XML::LibXML::Element->new('dateTime.iso8601'); $node->appendText($_[0]->strftime('%Y%m%dT%H%M%S.%3N%z')); return $node; }); =cut sub registerClass { my ( $self,$class,$encoder ) = @_; croak "registerClass not implemented by $self"; } # Decoder part =head2 decode ($xml) : $methodname, @args Decode request xml =head2 decode ($xml) : @args Decode response xml =head2 decode ($xml) : { fault => { faultCode => ..., faultString => ... } } Decode fault xml =cut sub decode { my ( $self, $xml ) = @_; croak "decode not implemented by $self"; # return $methodname, @args if request # return @args if response # return { fault => { faultCode => ..., faultString => ... } } if fault } =head2 registerType ($xmlrpc_type,$decoder_cb) Register decoders for XML-RPC types $decoder_cb is depends on encoder implementation. Samples for XML::RPC::Enc::LibXML $enc->registerType( base64 => sub { my $node = shift; return MIME::Base64::decode($node->textContent); }); $enc->registerType( 'dateTime.iso8601' => sub { my $node = shift; return DateTime::Format::ISO8601->parse_datetime($node->textContent); }); =cut sub registerType { my ( $self,$type,$decoder ) = @_; croak "registerType not implemented by $self"; } =head1 COPYRIGHT & LICENSE Copyright (c) 2008-2009 Mons Anderson. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 AUTHOR Mons Anderson, C<< >> =cut 1; XML-RPC-Fast-0.8/lib/XML/RPC/UA/000755 002100 002100 00000000000 11707766363 015463 5ustar00monsmons000000 000000 XML-RPC-Fast-0.8/lib/XML/RPC/Fast.pm000644 002100 002100 00000030222 11707766242 016404 0ustar00monsmons000000 000000 # XML::RPC::Fast # # Copyright (c) 2008-2009 Mons Anderson , all rights reserved # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. package XML::RPC::Fast; =head1 NAME XML::RPC::Fast - Fast and modular implementation for an XML-RPC client and server =cut our $VERSION = '0.8'; $VERSION = eval $VERSION; =head1 SYNOPSIS Generic usage use XML::RPC::Fast; my $server = XML::RPC::Fast->new( undef, %args ); my $client = XML::RPC::Fast->new( $uri, %args ); Create a simple XML-RPC service: use XML::RPC::Fast; my $rpc = XML::RPC::Fast->new( undef, # the url is not required by server external_encoding => 'koi8-r', # any encoding, accepted by Encode #internal_encoding => 'koi8-r', # not supported for now ); my $xml = do { local $/; }; length($xml) == $ENV{CONTENT_LENGTH} or warn "Content-Length differs from actually received"; print "Content-type: text/xml; charset=$rpc->{external_encoding}\n\n"; print $rpc->receive( $xml, sub { my ( $methodname, @params ) = @_; return { you_called => $methodname, with_params => \@params }; } ); Make a call to an XML-RPC service: use XML::RPC::Fast; my $rpc = XML::RPC::Fast->new( 'http://your.hostname/rpc/url' ); # Syncronous call my @result = $rpc->req( call => [ 'examples.getStateStruct', { state1 => 12, state2 => 28 } ], url => 'http://...', ); # Syncronous call (compatibility method) my @result = $rpc->call( 'examples.getStateStruct', { state1 => 12, state2 => 28 } ); # Syncronous or asyncronous call $rpc->req( call => ['examples.getStateStruct', { state1 => 12, state2 => 28 }], cb => sub { my @result = @_; }, ); # Syncronous or asyncronous call (compatibility method) $rpc->call( sub { my @result = @_; }, 'examples.getStateStruct', { state1 => 12, state2 => 28 } ); =head1 DESCRIPTION XML::RPC::Fast is format-compatible with XML::RPC, but may use different encoders to parse/compose xml. Curerntly included encoder uses L, and is 3 times faster than XML::RPC and 75% faster, than XML::Parser implementation =head1 METHODS =head2 new ($url, %args) Create XML::RPC::Fast object, server if url is undef, client if url is defined =head2 req( %ARGS ) Clientside. Make syncronous or asyncronous call (depends on UA). If have cb, will invoke $cb with results and should not croak If have no cb, will return results and croak on error (only syncronous UA) Arguments are =over 4 =item call => [ methodName => @args ] array ref of call arguments. Required =item cb => $cb->(@results) Invocation callback. Optional for syncronous UA. Behaviour is same as in call with C<$cb> and without =item url => $request_url Alternative invocation URL. Optional. By default will be used defined from constructor =item headers => { http-headers hashref } Additional http headers to request =item external_encoding => '..., Specify the encoding, used inside XML container just for this request. Passed to encoder =back =head2 call( 'method_name', @arguments ) : @results Clientside. Make syncronous call and return results. Croaks on error. Just a simple wrapper around C =head2 call( $cb->(@res), 'method_name', @arguments ): void Clientside. Make syncronous or asyncronous call (depends on UA) and invoke $cb with results. Should not croak. Just a simple wrapper around C =head2 receive ( $xml, $handler->($methodName,@args) ) : xml byte-stream Serverside. Process received XML and invoke $handler with parameters $methodName and @args and returns response XML On error conditions C<$handler> could set C<$XML::RPC::Fast::faultCode> and die, or return C ->receive( $xml, sub { # ... return rpcfault( 3, "Some error" ) if $error_condition $XML::RPC::Fast::faultCode = 4 and die "Another error" if $another_error_condition; return { call => $methodname, params => \@params }; }) =head2 registerType Proxy-method to encoder. See L =head2 registerClass Proxy-method to encoder. See L =head1 OPTIONS Below is the options, accepted by new() =head2 ua Client only. Useragent object, or package name ->new( $url, ua => 'LWP' ) # same as XML::RPC::UA::LWP # or ->new( $url, ua => 'XML::RPC::UA::LWP' ) # or ->new( $url, ua => XML::RPC::UA::LWP->new( ... ) ) # or ->new( $url, ua => XML::RPC::UA::Curl->new( ... ) ) =head2 timeout Client only. Timeout for calls. Passed directly to UA ->new( $url, ua => 'LWP', timeout => 10 ) =head2 useragent Client only. Useragent string. Passed directly to UA ->new( $url, ua => 'LWP', useragent => 'YourClient/1.11' ) =head2 encoder Client and server. Encoder object or package name ->new( $url, encoder => 'LibXML' ) # or ->new( $url, encoder => 'XML::RPC::Enc::LibXML' ) # or ->new( $url, encoder => XML::RPC::Enc::LibXML->new( ... ) ) =head2 internal_encoding B Specify the encoding you are using in your code. By default option is undef, which means flagged utf-8 For translations is used Encode, so the list of accepted encodings fully derived from it. =head2 external_encoding Specify the encoding, used inside XML container. By default it's utf-8. Passed directly to encoder ->new( $url, encoder => 'LibXML', external_encoding => 'koi8-r' ) =head1 ACCESSORS =head2 url Get or set client url =head2 encoder Direct access to encoder object =head2 ua Direct access to useragent object =head1 FUNCTIONS =head2 rpcfault(faultCode, faultString) Returns hash structure, that may be returned by serverside handler, instead of die. Not exported by default =head1 CUSTOM TYPES =head2 sub {{ 'base64' => encode_base64($data) }} When passing a CODEREF as a value, encoder will simply use the returned hashref as a type => value pair. =head2 bless( do{\(my $o = encode_base64('test') )}, 'base64' ) When passing SCALARREF as a value, package name will be taken as type and dereference as a value =head2 bless( do{\(my $o = { something =>'complex' } )}, 'base64' ) When passing REFREF as a value, package name will be taken as type and LC<::hash2xml(deref)> would be used as value =head2 customtype( $type, $data ) Easily compose SCALARREF based custom type =cut use 5.008003; # I want Encode to work use strict; use warnings; #use Time::HiRes qw(time); use Carp qw(carp croak); BEGIN { eval { require Sub::Name; Sub::Name->import('subname'); 1 } or do { *subname = sub { $_[1] } }; no strict 'refs'; for my $m (qw(url encoder ua)) { *$m = sub { local *__ANON__ = $m; my $self = shift; $self->{$m} = shift if @_; $self->{$m}; }; } } our $faultCode = 0; #sub encoder { shift->{encoder} } #sub ua { shift->{ua} } sub import { my $me = shift; my $pkg = caller; no strict 'refs'; @_ or return; for (@_) { if ( $_ eq 'rpcfault' or $_ eq 'customtype') { *{$pkg.'::'.$_} = \&$_; } else { croak "$_ is not exported by $me"; } } } sub rpcfault($$) { my ($code,$string) = @_; return { fault => { faultCode => $code, faultString => $string, }, } } sub customtype($$) { my $type = shift; my $data = shift; bless( do{\(my $o = $data )}, $type ) } sub _load { my $pkg = shift; my ($prefix,$req,$default,@args) = @_; if (defined $req) { my @fail; eval { require join '/', split '::', $prefix.$req.'.pm'; $req = $prefix.$req; 1; } or do { push @fail, [ $prefix.$req,$@ ]; eval{ require join '/', split '::', $req.'.pm'; 1 } } or do { push @fail, [ $req,$@ ]; croak "Can't load any of:\n".join("\n\t",map { "$$_[0]: $$_[1]" } @fail)."\n"; } } else { eval { $req = $prefix.$default; require join '/', split '::', $req.'.pm'; 1 } or do { croak "Can't load $req: $@\n"; } } return $req->new(@args); } sub new { my $package = shift; my $url = shift; local $SIG{__WARN__} = sub { local $_ = shift; s{\n$}{};carp $_ }; my $self = { @_, }; unless ( ref $self->{encoder} ) { $self->{encoder} = $package->_load( 'XML::RPC::Enc::', $self->{encoder}, 'LibXML', internal_encoding => $self->{internal_encoding}, external_encoding => $self->{external_encoding}, ); } if ( $url and !ref $self->{ua} ) { $self->{ua} = $package->_load( 'XML::RPC::UA::', $self->{ua}, 'LWP', ua => $self->{useragent} || 'XML-RPC-Fast/'.$VERSION, timeout => $self->{timeout}, ); } $self->{url} = $url; bless $self, $package; return $self; } sub registerType { shift->encoder->registerType(@_); } sub registerClass { shift->encoder->registerClass(@_); } sub call { my $self = shift; my $cb;$cb = shift if ref $_[0] and ref $_[0] eq 'CODE'; $self->req( call => [@_], $cb ? ( cb => $cb ) : (), ); } sub req { my $self = shift; my %args = @_; my $cb = $args{cb}; if ($self->ua->async and !$cb) { croak("Call have no cb and useragent is async"); } my ( $methodname, @params ) = @{ $args{call} }; my $url = $args{url} || $self->{url}; unless ( $url ) { if ($cb) { $cb->(rpcfault(500, "No url")); return; } else { croak('No url'); } }; my $uri = "$url#$methodname"; $faultCode = 0; my $body; { local $self->encoder->{external_encoding} = $args{external_encoding} if exists $args{external_encoding}; my $newurl; ($body,$newurl) = $self->encoder->request( $methodname, @params ); $url = $newurl if defined $newurl; } $self->{xml_out} = $body; #my $start = time; my @data; #warn "Call $body"; $self->ua->call( ($args{method} || 'POST') => $url, $args{headers} ? ( headers => $args{headers} ) : (), body => $body, cb => sub { my $res = shift; { ( my $status = $res->status_line )=~ s/:?\s*$//s; $res->code == 200 or @data = (rpcfault( $res->code, "Call to $uri failed: $status" )) and last; my $text = $res->content; length($text) and $text =~ /^\s*<\?xml/s or @data = ({fault=>{ faultCode => 499, faultString => "Call to $uri failed: Response is not an XML: \"$text\"" }}) and last; eval { $self->{xml_in} = $text; @data = $self->encoder->decode( $text ); 1; } or @data = ({fault=>{ faultCode => 499, faultString => "Call to $uri failed: Bad Response: $@, \"$text\"" }}) and last; } #warn "Have data @data"; if ($cb) {{ local $faultCode = $data[0]{fault}{faultCode} if ref $data[0] eq 'HASH' and exists $data[0]{fault}; $cb->(@data); return; }} }, ); $cb and defined wantarray and carp "Useless use of return value for ".__PACKAGE__."->call(cb)"; return if $cb; if ( ref $data[0] eq 'HASH' and exists $data[0]{fault} ) { $faultCode = $data[0]{fault}{faultCode}; croak( "Remote Error [$data[0]{fault}{faultCode}]: ".$data[0]{fault}{faultString} ); } return @data == 1 ? $data[0] : @data; } sub receive { # ok my $self = shift; my $result = eval { my $xml_in = shift or return $self->encoder->fault(400,"Bad Request: No XML"); my $handler = shift or return $self->encoder->fault(501,"Server Error: No handler");; my ( $methodname, @params ) = $self->encoder->decode($xml_in); local $self->{xml_in} = $xml_in; subname( 'receive.handler.'.$methodname,$handler ); my @res = $handler->( $methodname, @params ); if (ref $res[0] eq 'HASH' and exists $res[0]{fault}) { $self->encoder->fault( $res[0]{fault}{faultCode},$res[0]{fault}{faultString} ); } else { $self->encoder->response( @res ); } }; if ($@) { (my $e = "$@") =~ s{\r?\n+$}{}s; $result = $self->encoder->fault(defined $faultCode ? $faultCode : 500,$e); } return $result; } =head1 BUGS & SUPPORT Bugs reports and testcases are welcome. It you write your own Enc or UA, I may include it into distribution If you have propositions for default custom types (see Enc), send me patches See L to report and view bugs. =head1 AUTHOR Mons Anderson, C<< >> =head1 COPYRIGHT & LICENSE Copyright (c) 2008-2009 Mons Anderson. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; XML-RPC-Fast-0.8/lib/XML/RPC/UA.pm000644 002100 002100 00000002445 11647525677 016032 0ustar00monsmons000000 000000 package XML::RPC::UA; =head1 NAME XML::RPC::UA - Base class for XML::RPC UserAgent =head1 SYNOPSIS Generic usage use XML::RPC::Fast; my $client = XML::RPC::Fast->new( $uri, ua => XML::RPC::UA::LWP->new( timeout => 10, ua => 'YourApp/0.01', # default User-Agent http-header ), ); =cut use strict; use warnings; use Carp; # Base class for encoders use XML::RPC::Fast (); our $VERSION = $XML::RPC::Fast::VERSION; =head1 METHODS The following methods should be implemented =cut =head2 async () Should return true, if useragent is asyncronous, false otherwise =cut sub async { 0 } =head2 call ( $method, $uri, body => $body, headers => { http-headers }, cb => $cb->( $response ) ); Should process HTTP-request to C<$uri>, using C<$method>, passing C<$headers> and C<$body>, receive response, and invoke $cb with HTTP::Response object =cut sub call { my ($self, $method, $url, %args) = @_; $args{cb} or croak "cb required for useragent"; # ... #$args{cb}( HTTP::Response->new() ); return; } =head1 COPYRIGHT & LICENSE Copyright (c) 2008-2009 Mons Anderson. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 AUTHOR Mons Anderson, C<< >> =cut 1; XML-RPC-Fast-0.8/lib/XML/RPC/Enc/000755 002100 002100 00000000000 11707766363 015663 5ustar00monsmons000000 000000 XML-RPC-Fast-0.8/lib/XML/RPC/Enc/LibXML.pm000644 002100 002100 00000035310 11647525677 017316 0ustar00monsmons000000 000000 package XML::RPC::Enc::LibXML; use strict; use warnings; use base 'XML::RPC::Enc'; use XML::LibXML; use XML::Hash::LX; use Carp; #use Encode (); use XML::RPC::Fast (); our $VERSION = $XML::RPC::Fast::VERSION; BEGIN { if (eval { my $x = pack 'q', -1; 1 }) { *_HAVE_BIGINT = sub () { 1 }; my $maxint = eval q{ 0+"9223372036854775807" }; *_MAX_BIGINT = sub () { $maxint }; } else { require Math::BigInt; *_HAVE_BIGINT = sub () { 0 }; my $maxint = Math::BigInt->new("0x7fffffffffffffff"); *_MAX_BIGINT = sub () { $maxint }; } } =head1 NAME XML::RPC::Enc::LibXML - Encode/decode XML-RPC using LibXML =head1 SYNOPSIS use XML::RPC::Fast; use XML::RPC::Enc::LibXML; my $rpc = XML::RPC::Fast->new( $uri, encoder => XML::RPC::Enc::LibXML->new( # internal_encoding currently not implemented, always want wide chars internal_encoding => undef, external_encoding => 'windows-1251', ) ); $rpc->registerType( base64 => sub { my $node = shift; return MIME::Base64::decode($node->textContent); }); $rpc->registerType( 'dateTime.iso8601' => sub { my $node = shift; return DateTime::Format::ISO8601->parse_datetime($node->textContent); }); $rpc->registerClass( DateTime => sub { return ( 'dateTime.iso8601' => $_[0]->strftime('%Y%m%dT%H%M%S.%3N%z') ); }); $rpc->registerClass( DateTime => sub { my $node = XML::LibXML::Element->new('dateTime.iso8601'); $node->appendText($_[0]->strftime('%Y%m%dT%H%M%S.%3N%z')); return $node; }); =head1 DESCRIPTION Default encoder/decoder for L If MIME::Base64 is installed, decoder for C type C will be setup If DateTime::Format::ISO8601 is installed, decoder for C type C will be setup Also will be setup by default encoders for L and L (will be encoded as C) Ty avoid default decoders setup: BEGIN { $XML::RPC::Enc::LibXML::TYPES{base64} = 0; $XML::RPC::Enc::LibXML::TYPES{'dateTime.iso8601'} = 0; } use XML::RPC::Enc::LibXML; =head1 IMPLEMENTED METHODS =head2 new =head2 request =head2 response =head2 fault =head2 decode =head2 registerType =head2 registerClass =head1 SEE ALSO =over 4 =item * L Base class (also contains documentation) =back =cut # xml => perl # args: xml-nodes (children of <$type> ... ) # retv: any scalar our %TYPES; # perl => xml # args: object # retv: ( type => string ) || xml-node our %CLASS; our $E; BEGIN { if ( !exists $TYPES{base64} and eval{ require MIME::Base64;1 } ) { $TYPES{base64} = sub { #defined $E ? $E->encode( MIME::Base64::decode(shift->textContent); }; } # DateTime is the most "standart" datetime object in perl, try to use it if ( !exists $TYPES{'dateTime.iso8601'} and eval{ require DateTime::Format::ISO8601;1 } ) { $TYPES{'dateTime.iso8601'} = sub { DateTime::Format::ISO8601->parse_datetime(shift->textContent) }; } } #%TYPES = ( # custom => sub { ... }, # %TYPES, #); # We need no modules to predefine encoders for dates %CLASS = ( DateTime => sub { 'dateTime.iso8601',$_[0]->strftime('%Y%m%dT%H%M%S.%3N%z'); }, 'Class::Date' => sub { 'dateTime.iso8601',$_[0]->strftime('%Y%m%dT%H%M%S').sprintf( '%+03d%02d', $_[0]->tzoffset / 3600, ( $_[0]->tzoffset % 3600 ) / 60 ); }, %CLASS, ); sub new { my $pkg = shift; my $self = bless { @_, parser => XML::LibXML->new(), types => { }, class => { }, #internal_encoding => undef, }, $pkg; $self->{external_encoding} = 'utf-8' unless defined $self->{external_encoding}; return $self; } sub registerType { my ( $self,$type,$decode ) = @_; my $old; if (ref $self) { $old = $self->{types}{$type}; $self->{types}{$type} = $decode; } else { $old = $TYPES{$type}; $TYPES{$type} = $decode; } $old; } sub registerClass { my ( $self,$class,$encode ) = @_; my $old; if (ref $self) { $old = $self->{class}{$class}; $self->{class}{$class} = $encode; } else { $old = $CLASS{$class}; $CLASS{$class} = $encode; } $old; } # Encoder part sub _unparse_param { my $p = shift; my $r = XML::LibXML::Element->new('value'); if ( ref($p) eq 'HASH' ) { # struct -> ( member -> { name, value } )* my $s = XML::LibXML::Element->new('struct'); $r->appendChild($s); for ( keys %$p ) { my $m = XML::LibXML::Element->new('member'); my $n = XML::LibXML::Element->new('name'); $n->appendText(defined $E ? $E->decode($_) : $_); $m->appendChild($n); $m->appendChild(_unparse_param($p->{$_})); $s->appendChild($m); } } elsif ( ref($p) eq 'ARRAY' ) { my $a = XML::LibXML::Element->new('array'); my $d = XML::LibXML::Element->new('data'); $a->appendChild($d); $r->appendChild($a); for (@$p) { $d->appendChild( _unparse_param($_) ) } } elsif ( ref($p) eq 'CODE' ) { $r->appendChild(hash2xml($p->(), doc => 1)->documentElement); } elsif (ref $p) { if (exists $CLASS{ ref $p }) { my ($t,$x) = $CLASS{ ref $p }->($p); if (ref $t and eval{ $t->isa('XML::LibXML::Node') }) { $r->appendChild($t); } else { my $v = XML::LibXML::Element->new($t); $v->appendText(defined $E ? $E->decode($x) : $x); $r->appendChild($v); } } elsif ( UNIVERSAL::isa($p,'SCALAR') ) { my $v = XML::LibXML::Element->new(ref $p); $v->appendText(defined $E ? $E->decode($$p) : $$p) if defined $$p; $r->appendChild($v); } elsif ( UNIVERSAL::isa($p,'REF') ) { my $v = XML::LibXML::Element->new(ref $p); $v->appendChild(hash2xml($$p, doc => 1)->documentElement); $r->appendChild($v); } else { warn "Bad reference: $p"; #$result = undef; } } else { #no warnings; if (!defined $p) { my $v = XML::LibXML::Element->new('string'); $r->appendChild($v); } =for rem Q: What is the legal syntax (and range) for integers? How to deal with leading zeros? Is a leading plus sign allowed? How to deal with whitespace? A: An integer is a 32-bit signed number. You can include a plus or minus at the beginning of a string of numeric characters. Leading zeros are collapsed. Whitespace is not permitted. Just numeric characters preceeded by a plus or minus. Q: What is the legal syntax (and range) for floating point values (doubles)? How is the exponent represented? How to deal with whitespace? Can infinity and "not a number" be represented? A: There is no representation for infinity or negative infinity or "not a number". At this time, only decimal point notation is allowed, a plus or a minus, followed by any number of numeric characters, followed by a period and any number of numeric characters. Whitespace is not allowed. The range of allowable values is implementation-dependent, is not specified. # int '+0' => 0 '-0' => 0 '+1234567' => 1234567 '0777' => 777 '0000000000000' => 0 '0000000000000000000000000000000000000000000000000' => 0 # not int '999999999999999999999999999999999999'; =cut elsif ($p =~ m/^([\-+]?)\d+(\.\d+|)$/) { my ($have_sign,$is_double) = ($1,$2); if ( $is_double ) { my $v = XML::LibXML::Element->new('double'); $v->appendText( $p ); $r->appendChild($v); } else { my $v; # TODO: should we pass sign "+"? if( $p == unpack "l", pack "l", $p ) { # i4 $v = XML::LibXML::Element->new('i4'); $v->appendText(int $p); } elsif ( _HAVE_BIGINT and $p == unpack "q", pack "q", $p ) { # i8 $v = XML::LibXML::Element->new('i8'); $v->appendText(int $p); } elsif ( !_HAVE_BIGINT and abs( my $bi = Math::BigInt->new($p) ) < _MAX_BIGINT ) { $v = XML::LibXML::Element->new('i8'); $v->appendText($bi->bstr); } else { # string $v = XML::LibXML::Element->new('string'); $v->appendText($p); } $r->appendChild($v); } } else { my $v = XML::LibXML::Element->new('string'); $v->appendText(defined $E ? $E->decode($p) : $p); $r->appendChild($v); } } return $r; } sub request { my $self = shift; local @CLASS{keys %{ $self->{class} }} = values %{ $self->{class} }; local $E = Encode::find_encoding($self->{internal_encoding}) or croak "Could not find encoding $self->{internal_encoding}" if defined $self->{internal_encoding}; my $method = shift; my $doc = XML::LibXML::Document->new('1.0',$self->{external_encoding}); my $root = XML::LibXML::Element->new('methodCall'); $doc->setDocumentElement($root); my $n = XML::LibXML::Element->new('methodName'); $n->appendText(defined $E ? $E->decode($method) : $method); $root->appendChild($n); my $prms = XML::LibXML::Element->new('params'); $root->appendChild($prms); for my $v (@_) { my $p = XML::LibXML::Element->new('param'); $p->appendChild( _unparse_param($v) ); $prms->appendChild($p); } my $x = $doc->toString; utf8::encode($x) if utf8::is_utf8($x); return $x; } sub response { my $self = shift; local @CLASS{keys %{ $self->{class} }} = values %{ $self->{class} }; local $E = Encode::find_encoding($self->{internal_encoding}) or croak "Could not find encoding $self->{internal_encoding}" if defined $self->{internal_encoding}; my $doc = XML::LibXML::Document->new('1.0',$self->{external_encoding}); my $root = XML::LibXML::Element->new('methodResponse'); $doc->setDocumentElement($root); my $prms = XML::LibXML::Element->new('params'); $root->appendChild($prms); for my $v (@_) { my $p = XML::LibXML::Element->new('param'); $p->appendChild( _unparse_param($v) ); $prms->appendChild($p); } my $x = $doc->toString; utf8::encode($x) if utf8::is_utf8($x); return $x; } sub fault { my $self = shift; local @CLASS{keys %{ $self->{class} }} = values %{ $self->{class} }; local $E = Encode::find_encoding($self->{internal_encoding}) or croak "Could not find encoding $self->{internal_encoding}" if defined $self->{internal_encoding}; my ($code,$err) = @_; my $doc = XML::LibXML::Document->new('1.0',$self->{external_encoding}); my $root = XML::LibXML::Element->new('methodResponse'); $doc->setDocumentElement($root); my $f = XML::LibXML::Element->new('fault'); my $v = XML::LibXML::Element->new('value'); my $s = XML::LibXML::Element->new('struct'); for (qw(faultCode faultString)){ my $m = XML::LibXML::Element->new('member'); my $n = XML::LibXML::Element->new('name'); $n->appendText(defined $E ? $E->decode($_) : $_); $m->appendChild($n); $m->appendChild(_unparse_param(shift)); $s->appendChild($m); } $v->appendChild($s); $f->appendChild($v); $root->appendChild($f); my $x = $doc->toString; utf8::encode($x) if utf8::is_utf8($x); return $x; } # Decoder part our $src; sub decode { my $self = shift; my $string = shift; #utf8::encode $string if utf8::is_utf8($string); local $src = $string; $self->_parse( $self->{parser}->parse_string($string) ) } sub _parse_param { my $v = shift; for my $t ($v->childNodes) { next if ref $t eq 'XML::LibXML::Text'; my $type = $t->nodeName; #print $t->nodeName,"\n"; if ($type eq 'string') { return defined $E ? $E->encode(''.$t->textContent) : ''.$t->textContent; } elsif ($type eq 'i4' or $type eq 'int') { return int $t->textContent; } elsif ($type eq 'double') { return 0+$t->textContent; } elsif ($type eq 'bool') { $v = $t->textContent; return $v eq 'false' ? 0 : !!$v ? 1 : 0; } elsif ($type eq 'struct') { my $r = {}; for my $m ($t->childNodes) { my ($mn,$mv); if ($m->nodeName eq 'member') { for my $x ($m->childNodes) { #print "\tmember:".$x->nodeName,"\n"; if ($x->nodeName eq 'name') { $mn = $x->textContent; #last; } elsif ($x->nodeName eq 'value') { $mv = _parse_param ($x); $mn and last; } } if (defined $E) { $mn = $E->encode($mn); $mv = $E->encode($mv); } $r->{$mn} = $mv; } } return $r; } elsif ($type eq 'array') { my $r = []; for my $d ($t->childNodes) { #print "\tdata:".$d->nodeName,"\n"; unless (defined $d) { warn "!!! Internal bug: childNodes return undef. XML=\n$src"; next; } if ($d->nodeName eq 'data') { for my $x ($d->childNodes) { #print "\tdata:".$x->nodeName,"\n"; if ($x->nodeName eq 'value') { push @$r, _parse_param ($x); } } } } return $r; } # elsif ($type eq 'base64') { # return decode_base64($t->textContent); # } # elsif ($type eq 'dateTime.iso8601') { # return $t->textContent; # } else { if (exists $TYPES{$type} and $TYPES{$type}) { return $TYPES{$type}( $t->childNodes ); } else { my @children = $t->childNodes; @children or return bless( \do{ my $o }, $type ); if (( @children > 1 ) xor ( ref $children[0] ne 'XML::LibXML::Text' )) { #print STDERR + (0+@children)."; $type => ",ref $children[0], ' ', $children[0]->nodeName, "\n"; return bless \(xml2hash($t)->{$type}),$type; } else { #print STDERR + "*** ".(0+@children)."; $type => ",ref $children[0], ' ', $children[0]->nodeName, "\n"; return bless \( defined $E ? $E->encode($children[0]->textContent) : $children[0]->textContent ),$type; } } } last; } return defined $E ? $E->encode($v->textContent) : $v->textContent } sub _parse { my $self = shift; my $doc = shift; my @r; my $root = $doc->documentElement; local @TYPES{keys %{ $self->{types} }} = values %{ $self->{types} }; local $E = Encode::find_encoding($self->{internal_encoding}) or croak "Could not find encoding $self->{internal_encoding}" if defined $self->{internal_encoding}; for my $p ($doc->findnodes('//param')) { #for my $ps ($root->childNodes) { # if ($ps->nodeName eq 'params') { # for my $p ($ps->childNodes) { # if ($p->nodeName eq 'param') { #print $p->nodeName,"\n"; for my $v ($p->childNodes) { if ($v->nodeName eq 'value') { #print $p->nodeName,'=',_parse_param($v),"\n"; push @r, _parse_param ($v); } } # } # } # } } for my $m ($doc->findnodes('//methodName')) { unshift @r, defined $E ? $E->encode($m->textContent) : $m->textContent; last; } unless(@r) { for my $f ($doc->findnodes('//fault')) { my ($c,$e); for ($f->childNodes) { if ( $_->nodeName eq 'value' ) { my $flt = _parse_param ( $_ ); $c = $flt->{faultCode}; $e = $flt->{faultString}; last; } else { $c = defined $E ? $E->encode($_->textContent) : $_->textContent if $_->nodeName eq 'faultCode'; $e = defined $E ? $E->encode($_->textContent) : $_->textContent if $_->nodeName eq 'faultString'; } } return { fault => { faultCode => $c, faultString => $e } }; } } #warn "@r"; return @r; } =head1 COPYRIGHT & LICENSE Copyright (c) 2008-2009 Mons Anderson. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 AUTHOR Mons Anderson, C<< >> =cut 1; XML-RPC-Fast-0.8/lib/XML/RPC/UA/Curl.pm000644 002100 002100 00000005123 11647525677 016733 0ustar00monsmons000000 000000 package XML::RPC::UA::Curl; use strict; use warnings; use base 'XML::RPC::UA'; use HTTP::Response; use WWW::Curl::Easy; use Carp; use XML::RPC::Fast (); our $VERSION = $XML::RPC::Fast::VERSION; =head1 NAME XML::RPC::UA::Curl - XML::RPC useragent, using Curl =head1 SYNOPSIS use XML::RPC::Fast; use XML::RPC::UA::Curl; my $rpc = XML::RPC::Fast->new( $uri, ua => XML::RPC::UA::Curl->new( ua => 'YourApp/0.1', timeout => 3, ), ); =head1 DESCRIPTION Default syncronous useragent for L =head1 IMPLEMENTED METHODS =head2 new =head2 async = 0 =head2 call =head1 SEE ALSO =over 4 =item * L Base class (also contains documentation) =item * L =back =cut sub async { 0 } sub new { my $pkg = shift; my %args = @_; my $useragent = delete $args{ua} || 'XML-RPC-Fast/'.$XML::RPC::Fast::VERSION; my $ua = WWW::Curl::Easy->new; $ua->setopt(CURLOPT_TIMEOUT, (exists $args{timeout} ? defined $args{timeout} ? $args{timeout} : 0 : 10) ); return bless { lwp => $ua, ua => $useragent, }, $pkg; } sub call { my $self = shift; my ($method, $url) = splice @_,0,2; my %args = @_; $args{cb} or croak "cb required for useragent @{[%args]}"; #warn "call"; if( utf8::is_utf8($args{body}) ) { carp "got an utf8 body: $args{body}"; utf8::encode($args{body}); } if (uc $method eq 'POST') { $self->{lwp}->setopt(CURLOPT_POST, 1) } elsif (uc $method eq 'GET') { $self->{lwp}->setopt(CURLOPT_HTTPGET, 1) } $self->{lwp}->setopt(CURLOPT_URL, $url); { use bytes; my $headers = [ 'Content-Type: text/xml', "UserAgent: $self->{ua}", (map { "$_: $args{headers}{$_}" } keys %{$args{headers}}), 'Content-Length:' . length($args{body}) ]; $self->{lwp}->setopt(CURLOPT_HTTPHEADER, $headers); } $self->{lwp}->setopt(CURLOPT_POSTFIELDS, $args{body}); $self->{lwp}->setopt(CURLOPT_VERBOSE) if $ENV{RPC_DEBUG}; my $response_body; my $response = $self->{lwp}->setopt(CURLOPT_WRITEDATA,\$response_body); my $res = $self->{lwp}->perform(); if ($res != 0) { die $self->{lwp}->strerror($res); } #warn sprintf "http call lasts %0.3fs",time - $start if DEBUG_TIMES; $args{cb}( HTTP::Response->new( $self->{lwp}->getinfo(CURLINFO_HTTP_CODE), '', [], $response_body, ) ); } =head1 COPYRIGHT & LICENSE Copyright (c) 2008-2011 Mons Anderson, Andrii Kostenko. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 AUTHOR Mons Anderson, C<< >>, Andrii Kostenko C<< >> =cut 1; XML-RPC-Fast-0.8/lib/XML/RPC/UA/AnyEvent.pm000644 002100 002100 00000003265 11657211214 017540 0ustar00monsmons000000 000000 package XML::RPC::UA::AnyEvent; use strict; use warnings; use HTTP::Response; use HTTP::Headers; use AnyEvent::HTTP 'http_request'; use Carp; use XML::RPC::Fast (); our $VERSION = $XML::RPC::Fast::VERSION; =head1 NAME XML::RPC::UA::AnyEvent - XML::RPC useragent, using AnyEvent::HTTP =head1 SYNOPSIS use XML::RPC::Fast; use XML::RPC::UA::AnyEvent; my $rpc = XML::RPC::Fast->new( $uri, ua => XML::RPC::UA::AnyEvent->new( ua => 'YourApp/0.1', timeout => 3, ), ); =head1 DESCRIPTION Asyncronous useragent for L. Could be used in any AnyEvent application. =head1 IMPLEMENTED METHODS =head2 new =head2 async = 1 =head2 call =head1 SEE ALSO =over 4 =item * L Base class (also contains documentation) =item * L Syncronous UA using AnyEvent =item * L DBI of event-loop programming =item * L HTTP-client using AnyEvent =back =cut sub async { 1 } sub new { my $pkg = shift; my %args = @_; return bless \(do {my $o = $args{ua} || 'XML-RPC-Fast/'.$XML::RPC::Fast::VERSION }),$pkg; } sub call { my $self = shift; my ($method, $url) = splice @_,0,2; my %args = @_; $args{cb} or croak "cb required for useragent @{[%args]}"; #warn "call"; http_request $method => $url, headers => { 'Content-Type' => 'text/xml', 'User-Agent' => $$self, do { use bytes; ( 'Content-Length' => length($args{body}) ) }, %{$args{headers} || {}}, }, body => $args{body}, cb => sub { $args{cb}( HTTP::Response->new( $_[1]{Status}, $_[1]{Reason}, HTTP::Headers->new(%{$_[1]}), $_[0], ) ); }, ; return; } 1; XML-RPC-Fast-0.8/lib/XML/RPC/UA/AnyEventSync.pm000644 002100 002100 00000003500 11647525677 020411 0ustar00monsmons000000 000000 package XML::RPC::UA::AnyEventSync; use strict; use warnings; use HTTP::Response; use HTTP::Headers; use AnyEvent 5.0; use AnyEvent::HTTP 'http_request'; use Carp; use XML::RPC::Fast (); our $VERSION = $XML::RPC::Fast::VERSION; =head1 NAME XML::RPC::UA::AnyEventSync - Syncronous XML::RPC useragent, using AnyEvent::HTTP =head1 SYNOPSIS use XML::RPC::Fast; use XML::RPC::UA::AnyEventSync; my $rpc = XML::RPC::Fast->new( $uri, ua => XML::RPC::UA::AnyEventSync->new( ua => 'YourApp/0.1', timeout => 3, ), ); =head1 DESCRIPTION Syncronous useragent for L. Couldn't be used in any AnyEvent application since using condvar->recv in every call. =head1 IMPLEMENTED METHODS =head2 new =head2 async = 0 =head2 call =head1 SEE ALSO =over 4 =item * L Base class (also contains documentation) =item * L Asyncronous UA using AnyEvent =item * L DBI of event-loop programming =item * L HTTP-client using AnyEvent =back =cut sub async { 0 } sub new { my $pkg = shift; my %args = @_; return bless \(do {my $o = $args{ua} || 'XML-RPC-Fast/'.$XML::RPC::Fast::VERSION }),$pkg; } sub call { my $self = shift; my ($method, $url) = splice @_,0,2; my %args = @_; $args{cb} or croak "cb required for useragent @{[%args]}"; my $cv = AnyEvent->condvar; #warn "call"; http_request $method => $url, headers => { 'Content-Type' => 'text/xml', 'User-Agent' => $$self, do { use bytes; ( 'Content-Length' => length($args{body}) ) }, %{$args{headers} || {}}, }, body => $args{body}, cb => sub { $args{cb}( HTTP::Response->new( $_[1]{Status}, $_[1]{Reason}, HTTP::Headers->new(%{$_[1]}), $_[0], ) ); $cv->send; }, ; $cv->recv; return; } 1; XML-RPC-Fast-0.8/lib/XML/RPC/UA/LWP.pm000644 002100 002100 00000004100 11647525677 016462 0ustar00monsmons000000 000000 package XML::RPC::UA::LWP; use strict; use warnings; use base 'XML::RPC::UA'; use HTTP::Request; use LWP::UserAgent; use Carp; use XML::RPC::Fast (); our $VERSION = $XML::RPC::Fast::VERSION; =head1 NAME XML::RPC::UA::LWP - XML::RPC useragent, using LWP =head1 SYNOPSIS use XML::RPC::Fast; use XML::RPC::UA::LWP; my $rpc = XML::RPC::Fast->new( $uri, ua => XML::RPC::UA::LWP->new( ua => 'YourApp/0.1', timeout => 3, ), ); =head1 DESCRIPTION Default syncronous useragent for L =head1 IMPLEMENTED METHODS =head2 new =head2 async = 0 =head2 call =head1 SEE ALSO =over 4 =item * L Base class (also contains documentation) =item * L =back =cut sub async { 0 } sub new { my $pkg = shift; my %args = @_; my $useragent = delete $args{ua} || 'XML-RPC-Fast/'.$XML::RPC::Fast::VERSION; my $ua = LWP::UserAgent->new( requests_redirectable => ['POST'], %args, ); $ua->timeout( exists $args{timeout} ? $args{timeout} : 10 ); $ua->env_proxy(); return bless { lwp => $ua, ua => $useragent, }, $pkg; } sub call { my $self = shift; my ($method, $url) = splice @_,0,2; my %args = @_; $args{cb} or croak "cb required for useragent @{[%args]}"; #warn "call"; my $req = HTTP::Request->new( $method => $url ); $req->header('Content-Type' => 'text/xml'); $req->header('User-Agent' => $self->{ua}); $req->header( $_ => $args{headers}{$_} ) for keys %{$args{headers}}; if( utf8::is_utf8($args{body}) ) { carp "got an utf8 body: $args{body}"; utf8::encode($args{body}); } { use bytes; $req->header( 'Content-Length' => length($args{body}) ); } $req->content($args{body}); my $res = $self->{lwp}->request($req); #warn sprintf "http call lasts %0.3fs",time - $start if DEBUG_TIMES; $args{cb}( $res ); } =head1 COPYRIGHT & LICENSE Copyright (c) 2008-2009 Mons Anderson. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 AUTHOR Mons Anderson, C<< >> =cut 1; XML-RPC-Fast-0.8/inc/Module/000755 002100 002100 00000000000 11707766363 015322 5ustar00monsmons000000 000000 XML-RPC-Fast-0.8/inc/Module/Install.pm000644 002100 002100 00000030135 11707766352 017266 0ustar00monsmons000000 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.04'; # 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 - 2011 Adam Kennedy. XML-RPC-Fast-0.8/inc/Module/Install/000755 002100 002100 00000000000 11707766363 016730 5ustar00monsmons000000 000000 XML-RPC-Fast-0.8/inc/Module/AutoInstall.pm000644 002100 002100 00000061202 11707766353 020117 0ustar00monsmons000000 000000 #line 1 package Module::AutoInstall; use strict; use Cwd (); use ExtUtils::MakeMaker (); use vars qw{$VERSION}; BEGIN { $VERSION = '1.04'; } # special map on pre-defined feature sets my %FeatureMap = ( '' => 'Core Features', # XXX: deprecated '-core' => 'Core Features', ); # various lexical flags my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $InstallDepsTarget, $HasCPANPLUS ); my ( $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps, $UpgradeDeps ); my ( $PostambleActions, $PostambleActionsNoTest, $PostambleActionsUpgradeDeps, $PostambleActionsUpgradeDepsNoTest, $PostambleActionsListDeps, $PostambleActionsListAllDeps, $PostambleUsed, $NoTest); # See if it's a testing or non-interactive session _accept_default( $ENV{AUTOMATED_TESTING} or ! -t STDIN ); _init(); sub _accept_default { $AcceptDefault = shift; } sub _installdeps_target { $InstallDepsTarget = shift; } sub missing_modules { return @Missing; } sub do_install { __PACKAGE__->install( [ $Config ? ( UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) : () ], @Missing, ); } # initialize various flags, and/or perform install sub _init { foreach my $arg ( @ARGV, split( /[\s\t]+/, $ENV{PERL_AUTOINSTALL} || $ENV{PERL_EXTUTILS_AUTOINSTALL} || '' ) ) { if ( $arg =~ /^--config=(.*)$/ ) { $Config = [ split( ',', $1 ) ]; } elsif ( $arg =~ /^--installdeps=(.*)$/ ) { __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) ); exit 0; } elsif ( $arg =~ /^--upgradedeps=(.*)$/ ) { $UpgradeDeps = 1; __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) ); exit 0; } elsif ( $arg =~ /^--default(?:deps)?$/ ) { $AcceptDefault = 1; } elsif ( $arg =~ /^--check(?:deps)?$/ ) { $CheckOnly = 1; } elsif ( $arg =~ /^--skip(?:deps)?$/ ) { $SkipInstall = 1; } elsif ( $arg =~ /^--test(?:only)?$/ ) { $TestOnly = 1; } elsif ( $arg =~ /^--all(?:deps)?$/ ) { $AllDeps = 1; } } } # overrides MakeMaker's prompt() to automatically accept the default choice sub _prompt { goto &ExtUtils::MakeMaker::prompt unless $AcceptDefault; my ( $prompt, $default ) = @_; my $y = ( $default =~ /^[Yy]/ ); print $prompt, ' [', ( $y ? 'Y' : 'y' ), '/', ( $y ? 'n' : 'N' ), '] '; print "$default\n"; return $default; } # the workhorse sub import { my $class = shift; my @args = @_ or return; my $core_all; print "*** $class version " . $class->VERSION . "\n"; print "*** Checking for Perl dependencies...\n"; my $cwd = Cwd::cwd(); $Config = []; my $maxlen = length( ( sort { length($b) <=> length($a) } grep { /^[^\-]/ } map { ref($_) ? ( ( ref($_) eq 'HASH' ) ? keys(%$_) : @{$_} ) : '' } map { +{@args}->{$_} } grep { /^[^\-]/ or /^-core$/i } keys %{ +{@args} } )[0] ); # We want to know if we're under CPAN early to avoid prompting, but # if we aren't going to try and install anything anyway then skip the # check entirely since we don't want to have to load (and configure) # an old CPAN just for a cosmetic message $UnderCPAN = _check_lock(1) unless $SkipInstall || $InstallDepsTarget; while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) { my ( @required, @tests, @skiptests ); my $default = 1; my $conflict = 0; if ( $feature =~ m/^-(\w+)$/ ) { my $option = lc($1); # check for a newer version of myself _update_to( $modules, @_ ) and return if $option eq 'version'; # sets CPAN configuration options $Config = $modules if $option eq 'config'; # promote every features to core status $core_all = ( $modules =~ /^all$/i ) and next if $option eq 'core'; next unless $option eq 'core'; } print "[" . ( $FeatureMap{ lc($feature) } || $feature ) . "]\n"; $modules = [ %{$modules} ] if UNIVERSAL::isa( $modules, 'HASH' ); unshift @$modules, -default => &{ shift(@$modules) } if ( ref( $modules->[0] ) eq 'CODE' ); # XXX: bugward combatability while ( my ( $mod, $arg ) = splice( @$modules, 0, 2 ) ) { if ( $mod =~ m/^-(\w+)$/ ) { my $option = lc($1); $default = $arg if ( $option eq 'default' ); $conflict = $arg if ( $option eq 'conflict' ); @tests = @{$arg} if ( $option eq 'tests' ); @skiptests = @{$arg} if ( $option eq 'skiptests' ); next; } printf( "- %-${maxlen}s ...", $mod ); if ( $arg and $arg =~ /^\D/ ) { unshift @$modules, $arg; $arg = 0; } # XXX: check for conflicts and uninstalls(!) them. my $cur = _load($mod); if (_version_cmp ($cur, $arg) >= 0) { print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n"; push @Existing, $mod => $arg; $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } else { if (not defined $cur) # indeed missing { print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n"; } else { # no need to check $arg as _version_cmp ($cur, undef) would satisfy >= above print "too old. ($cur < $arg)\n"; } push @required, $mod => $arg; } } next unless @required; my $mandatory = ( $feature eq '-core' or $core_all ); if ( !$SkipInstall and ( $CheckOnly or ($mandatory and $UnderCPAN) or $AllDeps or $InstallDepsTarget or _prompt( qq{==> Auto-install the } . ( @required / 2 ) . ( $mandatory ? ' mandatory' : ' optional' ) . qq{ module(s) from CPAN?}, $default ? 'y' : 'n', ) =~ /^[Yy]/ ) ) { push( @Missing, @required ); $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } elsif ( !$SkipInstall and $default and $mandatory and _prompt( qq{==> The module(s) are mandatory! Really skip?}, 'n', ) =~ /^[Nn]/ ) { push( @Missing, @required ); $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } else { $DisabledTests{$_} = 1 for map { glob($_) } @tests; } } if ( @Missing and not( $CheckOnly or $UnderCPAN) ) { require Config; my $make = $Config::Config{make}; if ($InstallDepsTarget) { print "*** To install dependencies type '$make installdeps' or '$make installdeps_notest'.\n"; } else { print "*** Dependencies will be installed the next time you type '$make'.\n"; } # make an educated guess of whether we'll need root permission. print " (You may need to do that as the 'root' user.)\n" if eval '$>'; } print "*** $class configuration finished.\n"; chdir $cwd; # import to main:: no strict 'refs'; *{'main::WriteMakefile'} = \&Write if caller(0) eq 'main'; return (@Existing, @Missing); } sub _running_under { my $thing = shift; print <<"END_MESSAGE"; *** Since we're running under ${thing}, I'll just let it take care of the dependency's installation later. END_MESSAGE return 1; } # Check to see if we are currently running under CPAN.pm and/or CPANPLUS; # if we are, then we simply let it taking care of our dependencies sub _check_lock { return unless @Missing or @_; if ($ENV{PERL5_CPANM_IS_RUNNING}) { return _running_under('cpanminus'); } my $cpan_env = $ENV{PERL5_CPAN_IS_RUNNING}; if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) { return _running_under($cpan_env ? 'CPAN' : 'CPANPLUS'); } require CPAN; if ($CPAN::VERSION > '1.89') { if ($cpan_env) { return _running_under('CPAN'); } return; # CPAN.pm new enough, don't need to check further } # last ditch attempt, this -will- configure CPAN, very sorry _load_cpan(1); # force initialize even though it's already loaded # Find the CPAN lock-file my $lock = MM->catfile( $CPAN::Config->{cpan_home}, ".lock" ); return unless -f $lock; # Check the lock local *LOCK; return unless open(LOCK, $lock); if ( ( $^O eq 'MSWin32' ? _under_cpan() : == getppid() ) and ( $CPAN::Config->{prerequisites_policy} || '' ) ne 'ignore' ) { print <<'END_MESSAGE'; *** Since we're running under CPAN, I'll just let it take care of the dependency's installation later. END_MESSAGE return 1; } close LOCK; return; } sub install { my $class = shift; my $i; # used below to strip leading '-' from config keys my @config = ( map { s/^-// if ++$i; $_ } @{ +shift } ); my ( @modules, @installed ); while ( my ( $pkg, $ver ) = splice( @_, 0, 2 ) ) { # grep out those already installed if ( _version_cmp( _load($pkg), $ver ) >= 0 ) { push @installed, $pkg; } else { push @modules, $pkg, $ver; } } if ($UpgradeDeps) { push @modules, @installed; @installed = (); } return @installed unless @modules; # nothing to do return @installed if _check_lock(); # defer to the CPAN shell print "*** Installing dependencies...\n"; return unless _connected_to('cpan.org'); my %args = @config; my %failed; local *FAILED; if ( $args{do_once} and open( FAILED, '.#autoinstall.failed' ) ) { while () { chomp; $failed{$_}++ } close FAILED; my @newmod; while ( my ( $k, $v ) = splice( @modules, 0, 2 ) ) { push @newmod, ( $k => $v ) unless $failed{$k}; } @modules = @newmod; } if ( _has_cpanplus() and not $ENV{PERL_AUTOINSTALL_PREFER_CPAN} ) { _install_cpanplus( \@modules, \@config ); } else { _install_cpan( \@modules, \@config ); } print "*** $class installation finished.\n"; # see if we have successfully installed them while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { if ( _version_cmp( _load($pkg), $ver ) >= 0 ) { push @installed, $pkg; } elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) { print FAILED "$pkg\n"; } } close FAILED if $args{do_once}; return @installed; } sub _install_cpanplus { my @modules = @{ +shift }; my @config = _cpanplus_config( @{ +shift } ); my $installed = 0; require CPANPLUS::Backend; my $cp = CPANPLUS::Backend->new; my $conf = $cp->configure_object; return unless $conf->can('conf') # 0.05x+ with "sudo" support or _can_write($conf->_get_build('base')); # 0.04x # if we're root, set UNINST=1 to avoid trouble unless user asked for it. my $makeflags = $conf->get_conf('makeflags') || ''; if ( UNIVERSAL::isa( $makeflags, 'HASH' ) ) { # 0.03+ uses a hashref here $makeflags->{UNINST} = 1 unless exists $makeflags->{UNINST}; } else { # 0.02 and below uses a scalar $makeflags = join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); } $conf->set_conf( makeflags => $makeflags ); $conf->set_conf( prereqs => 1 ); while ( my ( $key, $val ) = splice( @config, 0, 2 ) ) { $conf->set_conf( $key, $val ); } my $modtree = $cp->module_tree; while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { print "*** Installing $pkg...\n"; MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; my $success; my $obj = $modtree->{$pkg}; if ( $obj and _version_cmp( $obj->{version}, $ver ) >= 0 ) { my $pathname = $pkg; $pathname =~ s/::/\\W/; foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { delete $INC{$inc}; } my $rv = $cp->install( modules => [ $obj->{module} ] ); if ( $rv and ( $rv->{ $obj->{module} } or $rv->{ok} ) ) { print "*** $pkg successfully installed.\n"; $success = 1; } else { print "*** $pkg installation cancelled.\n"; $success = 0; } $installed += $success; } else { print << "."; *** Could not find a version $ver or above for $pkg; skipping. . } MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; } return $installed; } sub _cpanplus_config { my @config = (); while ( @_ ) { my ($key, $value) = (shift(), shift()); if ( $key eq 'prerequisites_policy' ) { if ( $value eq 'follow' ) { $value = CPANPLUS::Internals::Constants::PREREQ_INSTALL(); } elsif ( $value eq 'ask' ) { $value = CPANPLUS::Internals::Constants::PREREQ_ASK(); } elsif ( $value eq 'ignore' ) { $value = CPANPLUS::Internals::Constants::PREREQ_IGNORE(); } else { die "*** Cannot convert option $key = '$value' to CPANPLUS version.\n"; } push @config, 'prereqs', $value; } elsif ( $key eq 'force' ) { push @config, $key, $value; } elsif ( $key eq 'notest' ) { push @config, 'skiptest', $value; } else { die "*** Cannot convert option $key to CPANPLUS version.\n"; } } return @config; } sub _install_cpan { my @modules = @{ +shift }; my @config = @{ +shift }; my $installed = 0; my %args; _load_cpan(); require Config; if (CPAN->VERSION < 1.80) { # no "sudo" support, probe for writableness return unless _can_write( MM->catfile( $CPAN::Config->{cpan_home}, 'sources' ) ) and _can_write( $Config::Config{sitelib} ); } # if we're root, set UNINST=1 to avoid trouble unless user asked for it. my $makeflags = $CPAN::Config->{make_install_arg} || ''; $CPAN::Config->{make_install_arg} = join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); # don't show start-up info $CPAN::Config->{inhibit_startup_message} = 1; # set additional options while ( my ( $opt, $arg ) = splice( @config, 0, 2 ) ) { ( $args{$opt} = $arg, next ) if $opt =~ /^(?:force|notest)$/; # pseudo-option $CPAN::Config->{$opt} = $arg; } if ($args{notest} && (not CPAN::Shell->can('notest'))) { die "Your version of CPAN is too old to support the 'notest' pragma"; } local $CPAN::Config->{prerequisites_policy} = 'follow'; while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; print "*** Installing $pkg...\n"; my $obj = CPAN::Shell->expand( Module => $pkg ); my $success = 0; if ( $obj and _version_cmp( $obj->cpan_version, $ver ) >= 0 ) { my $pathname = $pkg; $pathname =~ s/::/\\W/; foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { delete $INC{$inc}; } my $rv = do { if ($args{force}) { CPAN::Shell->force( install => $pkg ) } elsif ($args{notest}) { CPAN::Shell->notest( install => $pkg ) } else { CPAN::Shell->install($pkg) } }; $rv ||= eval { $CPAN::META->instance( 'CPAN::Distribution', $obj->cpan_file, ) ->{install} if $CPAN::META; }; if ( $rv eq 'YES' ) { print "*** $pkg successfully installed.\n"; $success = 1; } else { print "*** $pkg installation failed.\n"; $success = 0; } $installed += $success; } else { print << "."; *** Could not find a version $ver or above for $pkg; skipping. . } MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; } return $installed; } sub _has_cpanplus { return ( $HasCPANPLUS = ( $INC{'CPANPLUS/Config.pm'} or _load('CPANPLUS::Shell::Default') ) ); } # make guesses on whether we're under the CPAN installation directory sub _under_cpan { require Cwd; require File::Spec; my $cwd = File::Spec->canonpath( Cwd::cwd() ); my $cpan = File::Spec->canonpath( $CPAN::Config->{cpan_home} ); return ( index( $cwd, $cpan ) > -1 ); } sub _update_to { my $class = __PACKAGE__; my $ver = shift; return if _version_cmp( _load($class), $ver ) >= 0; # no need to upgrade if ( _prompt( "==> A newer version of $class ($ver) is required. Install?", 'y' ) =~ /^[Nn]/ ) { die "*** Please install $class $ver manually.\n"; } print << "."; *** Trying to fetch it from CPAN... . # install ourselves _load($class) and return $class->import(@_) if $class->install( [], $class, $ver ); print << '.'; exit 1; *** Cannot bootstrap myself. :-( Installation terminated. . } # check if we're connected to some host, using inet_aton sub _connected_to { my $site = shift; return ( ( _load('Socket') and Socket::inet_aton($site) ) or _prompt( qq( *** Your host cannot resolve the domain name '$site', which probably means the Internet connections are unavailable. ==> Should we try to install the required module(s) anyway?), 'n' ) =~ /^[Yy]/ ); } # check if a directory is writable; may create it on demand sub _can_write { my $path = shift; mkdir( $path, 0755 ) unless -e $path; return 1 if -w $path; print << "."; *** You are not allowed to write to the directory '$path'; the installation may fail due to insufficient permissions. . if ( eval '$>' and lc(`sudo -V`) =~ /version/ and _prompt( qq( ==> Should we try to re-execute the autoinstall process with 'sudo'?), ((-t STDIN) ? 'y' : 'n') ) =~ /^[Yy]/ ) { # try to bootstrap ourselves from sudo print << "."; *** Trying to re-execute the autoinstall process with 'sudo'... . my $missing = join( ',', @Missing ); my $config = join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) if $Config; return unless system( 'sudo', $^X, $0, "--config=$config", "--installdeps=$missing" ); print << "."; *** The 'sudo' command exited with error! Resuming... . } return _prompt( qq( ==> Should we try to install the required module(s) anyway?), 'n' ) =~ /^[Yy]/; } # load a module and return the version it reports sub _load { my $mod = pop; # class/instance doesn't matter my $file = $mod; $file =~ s|::|/|g; $file .= '.pm'; local $@; return eval { require $file; $mod->VERSION } || ( $@ ? undef: 0 ); } # Load CPAN.pm and it's configuration sub _load_cpan { return if $CPAN::VERSION and $CPAN::Config and not @_; require CPAN; # CPAN-1.82+ adds CPAN::Config::AUTOLOAD to redirect to # CPAN::HandleConfig->load. CPAN reports that the redirection # is deprecated in a warning printed at the user. # CPAN-1.81 expects CPAN::HandleConfig->load, does not have # $CPAN::HandleConfig::VERSION but cannot handle # CPAN::Config->load # Which "versions expect CPAN::Config->load? if ( $CPAN::HandleConfig::VERSION || CPAN::HandleConfig->can('load') ) { # Newer versions of CPAN have a HandleConfig module CPAN::HandleConfig->load; } else { # Older versions had the load method in Config directly CPAN::Config->load; } } # compare two versions, either use Sort::Versions or plain comparison # return values same as <=> sub _version_cmp { my ( $cur, $min ) = @_; return -1 unless defined $cur; # if 0 keep comparing return 1 unless $min; $cur =~ s/\s+$//; # check for version numbers that are not in decimal format if ( ref($cur) or ref($min) or $cur =~ /v|\..*\./ or $min =~ /v|\..*\./ ) { if ( ( $version::VERSION or defined( _load('version') )) and version->can('new') ) { # use version.pm if it is installed. return version->new($cur) <=> version->new($min); } elsif ( $Sort::Versions::VERSION or defined( _load('Sort::Versions') ) ) { # use Sort::Versions as the sorting algorithm for a.b.c versions return Sort::Versions::versioncmp( $cur, $min ); } warn "Cannot reliably compare non-decimal formatted versions.\n" . "Please install version.pm or Sort::Versions.\n"; } # plain comparison local $^W = 0; # shuts off 'not numeric' bugs return $cur <=> $min; } # nothing; this usage is deprecated. sub main::PREREQ_PM { return {}; } sub _make_args { my %args = @_; $args{PREREQ_PM} = { %{ $args{PREREQ_PM} || {} }, @Existing, @Missing } if $UnderCPAN or $TestOnly; if ( $args{EXE_FILES} and -e 'MANIFEST' ) { require ExtUtils::Manifest; my $manifest = ExtUtils::Manifest::maniread('MANIFEST'); $args{EXE_FILES} = [ grep { exists $manifest->{$_} } @{ $args{EXE_FILES} } ]; } $args{test}{TESTS} ||= 't/*.t'; $args{test}{TESTS} = join( ' ', grep { !exists( $DisabledTests{$_} ) } map { glob($_) } split( /\s+/, $args{test}{TESTS} ) ); my $missing = join( ',', @Missing ); my $config = join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) if $Config; $PostambleActions = ( ($missing and not $UnderCPAN) ? "\$(PERL) $0 --config=$config --installdeps=$missing" : "\$(NOECHO) \$(NOOP)" ); my $deps_list = join( ',', @Missing, @Existing ); $PostambleActionsUpgradeDeps = "\$(PERL) $0 --config=$config --upgradedeps=$deps_list"; my $config_notest = join( ',', (UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config}), 'notest', 1 ) if $Config; $PostambleActionsNoTest = ( ($missing and not $UnderCPAN) ? "\$(PERL) $0 --config=$config_notest --installdeps=$missing" : "\$(NOECHO) \$(NOOP)" ); $PostambleActionsUpgradeDepsNoTest = "\$(PERL) $0 --config=$config_notest --upgradedeps=$deps_list"; $PostambleActionsListDeps = '@$(PERL) -le "print for @ARGV" ' . join(' ', map $Missing[$_], grep $_ % 2 == 0, 0..$#Missing); my @all = (@Missing, @Existing); $PostambleActionsListAllDeps = '@$(PERL) -le "print for @ARGV" ' . join(' ', map $all[$_], grep $_ % 2 == 0, 0..$#all); return %args; } # a wrapper to ExtUtils::MakeMaker::WriteMakefile sub Write { require Carp; Carp::croak "WriteMakefile: Need even number of args" if @_ % 2; if ($CheckOnly) { print << "."; *** Makefile not written in check-only mode. . return; } my %args = _make_args(@_); no strict 'refs'; $PostambleUsed = 0; local *MY::postamble = \&postamble unless defined &MY::postamble; ExtUtils::MakeMaker::WriteMakefile(%args); print << "." unless $PostambleUsed; *** WARNING: Makefile written with customized MY::postamble() without including contents from Module::AutoInstall::postamble() -- auto installation features disabled. Please contact the author. . return 1; } sub postamble { $PostambleUsed = 1; my $fragment; $fragment .= <<"AUTO_INSTALL" if !$InstallDepsTarget; config :: installdeps \t\$(NOECHO) \$(NOOP) AUTO_INSTALL $fragment .= <<"END_MAKE"; checkdeps :: \t\$(PERL) $0 --checkdeps installdeps :: \t$PostambleActions installdeps_notest :: \t$PostambleActionsNoTest upgradedeps :: \t$PostambleActionsUpgradeDeps upgradedeps_notest :: \t$PostambleActionsUpgradeDepsNoTest listdeps :: \t$PostambleActionsListDeps listalldeps :: \t$PostambleActionsListAllDeps END_MAKE return $fragment; } 1; __END__ #line 1178 XML-RPC-Fast-0.8/inc/Module/Install/AutoInstall.pm000644 002100 002100 00000004162 11707766353 021527 0ustar00monsmons000000 000000 #line 1 package Module::Install::AutoInstall; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.04'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub AutoInstall { $_[0] } sub run { my $self = shift; $self->auto_install_now(@_); } sub write { my $self = shift; $self->auto_install(@_); } sub auto_install { my $self = shift; return if $self->{done}++; # Flatten array of arrays into a single array my @core = map @$_, map @$_, grep ref, $self->build_requires, $self->requires; my @config = @_; # We'll need Module::AutoInstall $self->include('Module::AutoInstall'); require Module::AutoInstall; my @features_require = Module::AutoInstall->import( (@config ? (-config => \@config) : ()), (@core ? (-core => \@core) : ()), $self->features, ); my %seen; my @requires = map @$_, map @$_, grep ref, $self->requires; while (my ($mod, $ver) = splice(@requires, 0, 2)) { $seen{$mod}{$ver}++; } my @build_requires = map @$_, map @$_, grep ref, $self->build_requires; while (my ($mod, $ver) = splice(@build_requires, 0, 2)) { $seen{$mod}{$ver}++; } my @configure_requires = map @$_, map @$_, grep ref, $self->configure_requires; while (my ($mod, $ver) = splice(@configure_requires, 0, 2)) { $seen{$mod}{$ver}++; } my @deduped; while (my ($mod, $ver) = splice(@features_require, 0, 2)) { push @deduped, $mod => $ver unless $seen{$mod}{$ver}++; } $self->requires(@deduped); $self->makemaker_args( Module::AutoInstall::_make_args() ); my $class = ref($self); $self->postamble( "# --- $class section:\n" . Module::AutoInstall::postamble() ); } sub installdeps_target { my ($self, @args) = @_; $self->include('Module::AutoInstall'); require Module::AutoInstall; Module::AutoInstall::_installdeps_target(1); $self->auto_install(@args); } sub auto_install_now { my $self = shift; $self->auto_install(@_); Module::AutoInstall::do_install(); } 1; XML-RPC-Fast-0.8/inc/Module/Install/Makefile.pm000644 002100 002100 00000027012 11707766352 021003 0ustar00monsmons000000 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.04'; @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 ) { # MakeMaker can complain about module versions that include # an underscore, even though its own version may contain one! # Hence the funny regexp to get rid of it. See RT #35800 # for details. my ($v) = $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/; $self->build_requires( 'ExtUtils::MakeMaker' => $v ); $self->configure_requires( 'ExtUtils::MakeMaker' => $v ); } 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 540 XML-RPC-Fast-0.8/inc/Module/Install/Include.pm000644 002100 002100 00000001015 11707766353 020645 0ustar00monsmons000000 000000 #line 1 package Module::Install::Include; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.04'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub include { shift()->admin->include(@_); } sub include_deps { shift()->admin->include_deps(@_); } sub auto_include { shift()->admin->auto_include(@_); } sub auto_include_deps { shift()->admin->auto_include_deps(@_); } sub auto_include_dependent_dists { shift()->admin->auto_include_dependent_dists(@_); } 1; XML-RPC-Fast-0.8/inc/Module/Install/Metadata.pm000644 002100 002100 00000043277 11707766352 021021 0ustar00monsmons000000 000000 #line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.04'; @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; XML-RPC-Fast-0.8/inc/Module/Install/WriteAll.pm000644 002100 002100 00000002376 11707766353 021020 0ustar00monsmons000000 000000 #line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.04'; @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; XML-RPC-Fast-0.8/inc/Module/Install/Win32.pm000644 002100 002100 00000003403 11707766353 020167 0ustar00monsmons000000 000000 #line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.04'; @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; XML-RPC-Fast-0.8/inc/Module/Install/Fetch.pm000644 002100 002100 00000004627 11707766353 020327 0ustar00monsmons000000 000000 #line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.04'; @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; XML-RPC-Fast-0.8/inc/Module/Install/Base.pm000644 002100 002100 00000002147 11707766352 020142 0ustar00monsmons000000 000000 #line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.04'; } # 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 XML-RPC-Fast-0.8/inc/Module/Install/Can.pm000644 002100 002100 00000003333 11707766353 017770 0ustar00monsmons000000 000000 #line 1 package Module::Install::Can; use strict; use Config (); use File::Spec (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.04'; @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 ''; my $abs = File::Spec->catfile($dir, $_[1]); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # 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 156