RPC-XML-0.77/ 000755 000765 000024 00000000000 12021176462 013024 5 ustar 00rjray staff 000000 000000 RPC-XML-0.77/ChangeLog 000644 000765 000024 00000166436 12021176143 014612 0 ustar 00rjray staff 000000 000000 Perl Module RPC::XML Change History
Revision history for the Perl extension module
RPC::XML. This is an implementation of the
XML-RPC standard as described at
http://www.xmlrpc.com. This implementation also
permits some minor extensions to the base
protocol in terms of supporting HTTP/1.1 and
allowing choice of character-set encodings for
XML messages.
0.77 Monday September 3, 2012, 12:00:00 PM -0700
* t/15_serialize.t
Fix a test failure on Windows.
* lib/RPC/XML.pm
RT #70408: Fix spelling error in man page, reported by Debian
group.
* t/90_rt54183_sigpipe.t
Fix to handle cases where server creation fails. Now skips the
tests rather than dying.
* lib/RPC/XML/Client.pm
RT #67486: Add port to Host header in client requests.
* lib/RPC/XML/Server.pm
RT #65341: Added "use" of forgotten library File::Temp. This
was causing failure when "message_file_thresh" kicked in.
* t/10_data.t
RT #78602: Changed 64-bit test from use64bitint to longsize. On
some systems (such as OS X), use64bitint can be true even when
in 32-bit mode.
* t/21_xml_libxml.t
Fix from Christian Walde, skip passed test on Windows.
* lib/RPC/XML/Server.pm
* t/40_server.t
Checkpoint refactoring and additional tests. Work is not
complete here, but the Net::Server changes demand immediate
attention
* t/20_xml_parser.t
RT #72780: Check for a possible parser failure. One instance of
XML::Parser failing to parse the extern entities test. Cannot
reproduce, so wrap it in a "skip" block for now.
* lib/RPC/XML/Procedure.pm
* t/30_method.t
RT #71452: Correct handling of dateTime parameters. Existing
code in lib/RPC/XML/Procedure.pm did not properly handle
parameters of the dateTime.iso8601 type. Also, there were no
tests for these.
* MANIFEST
* t/30_method.t (deleted)
* t/30_proceudre.t (added)
Renamed t/30_method.t to t/30_procedure.t.
* lib/RPC/XML/Server.pm
RT #77992: Make RPC::XML::Server work with Net::Server again,
after the API changes of Net::Server 2.x.
0.76 Saturday August 20, 2011, 06:30:00 PM -0700
* etc/make_method
* lib/RPC/XML/Server.pm
RT #70258: Fixed typos in docs pointed out by Debian team.
* lib/Apache/RPC/Server.pm
Better version of the fix for infinite loops. This is the patch
originally suggested by Eric Cholet, who found the bug.
* t/00_load.t
RT #70280: This test was still testing RPC/XML/Method.pm.
Rewrote to remove that but include the (forgotten) XMLLibXML.pm
module. That test has to be conditional on the presence of
XML::LibXML.
* Makefile.PL
* t/51_client_with_host_header.t
Clean up test suite to work with older Test::More. Also specify
a minimum Test::More that supports subtest(). This is also a
part of RT #70280.
* t/11_base64_fh.t
* t/20_xml_parser.t
* t/21_xml_libxml.t
* t/40_server.t
These tests had failures when run as root. Permissions-based
negative tests were incorrectly passing.
* t/10_data.t
Moved the 64-bit "TODO" tests to a SKIP block. Non-64-bit
systems will skip, rather than fail, these tests.
* lib/RPC/XML/Server.pm
RT #65616: Fix for slow methods killing servers. Applied and
modified patch from person who opened the ticket.
* MANIFEST
* lib/RPC/XML.pm
* t/10_data.t
* t/14_datetime_iso8601.t (added)
RT #55628: Improve flexibility of date parsing. This adds the
ability to pass any ISO 8601 string to the
RPC::XML::datetime_iso8601 constructor.
0.75 Saturday August 13, 2011, 05:30:00 PM -0700
* MANIFEST
Somehow, t/13_no_deep_recursion.t never got added to MANIFEST.
* lib/RPC/XML/Parser/XMLLibXML.pm
RT #65154: Fixed a cut/paste error in an error message.
* lib/RPC/XML/Client.pm
* t/51_client_with_host_header.t (added)
RT #68792: Merge pull request #2 from dragon3/master
(https://github.com/dragon3). Allow setting of "Host" header,
and test suite for it.
* MANIFEST
* t/51_client_with_host_header.t
Added new test suite to MANIFEST, fixed spelling. Also added
"plan tests" line to the test suite.
* lib/RPC/XML/Parser/XMLLibXML.pm
* t/20_xml_parser.t
* t/21_xml_libxml.t
* t/41_server_hang.t
Merge pull request #3 from yannk/master
(https://github.com/yannk). Expat parser subclass is protected
against ext ent attack, libxml isn't.
* t/41_server_hang.t
Undo a change to this suite from yannk's pull.
* etc/make_method
* lib/Apache/RPC/Server.pm
* lib/Apache/RPC/Status.pm
* lib/RPC/XML.pm
* lib/RPC/XML/Client.pm
* lib/RPC/XML/Function.pm
* lib/RPC/XML/Method.pm
* lib/RPC/XML/Parser.pm
* lib/RPC/XML/Parser/XMLLibXML.pm
* lib/RPC/XML/Parser/XMLParser.pm
* lib/RPC/XML/ParserFactory.pm
* lib/RPC/XML/Procedure.pm
* lib/RPC/XML/Server.pm
More perlcritic-driven clean-up. This is mostly POD sections,
but also includes heavy re-working of etc/make_method and parts
of lib/RPC/XML.pm.
* lib/RPC/XML/Parser/XMLLibXML.pm
* t/21_xml_libxml.t
Fixed external entity handling on MacOS. Also made small change
to the test suite to be cleaner.
* lib/RPC/XML/Parser/XMLLibXML.pm
* lib/RPC/XML/Parser/XMLParser.pm
Took out warnings on external entities blocking. Now it blocks
silently. Also cleaned up some docs.
* t/15_serialize.t
Additions to increase code coverage in XML.pm.
* lib/RPC/XML.pm
Turns out this wasn't exporting RPC_I8.
* lib/Apache/RPC/Server.pm
* lib/Apache/RPC/Status.pm
* lib/RPC/XML.pm
* lib/RPC/XML/Client.pm
* lib/RPC/XML/Function.pm
* lib/RPC/XML/Method.pm
* lib/RPC/XML/Parser.pm
* lib/RPC/XML/Parser/XMLLibXML.pm
* lib/RPC/XML/Parser/XMLParser.pm
* lib/RPC/XML/ParserFactory.pm
* lib/RPC/XML/Procedure.pm
* lib/RPC/XML/Server.pm
* xt/02_pod_coverage.t
Made 5.8.8 the new minimum-required perl. Also dropped the
utf8_downgrade hack, which affected an xt test.
* lib/RPC/XML/Client.pm
Improved arguments-checking in send_request.
* lib/RPC/XML/Client.pm
* lib/RPC/XML/Parser/XMLLibXML.pm
* lib/RPC/XML/Parser/XMLParser.pm
* lib/RPC/XML/Server.pm
Fixed error-cases in usage of File::Temp->new().
File::Temp::new croaks on errors, doesn't return undef like I
thought.
* MANIFEST
* lib/RPC/XML/Function.pm (deleted)
* lib/RPC/XML/Method.pm (deleted)
* lib/RPC/XML/Procedure.pm
Roll Method.pm and Function.pm into Procedure.pm. Remove
Method.pm and Function.pm from distro.
* lib/RPC/XML/Parser/XMLLibXML.pm
Fixed regexp for methodName validation.
* t/10_data.t
* t/11_base64_fh.t
* t/12_nil.t
* t/15_serialize.t
* t/20_xml_parser.t
* t/21_xml_libxml.t
* t/25_parser_negative.t (added)
* t/29_parserfactory.t
* t/30_method.t
* t/40_server.t
* t/40_server_xmllibxml.t
* t/50_client.t
* t/BadParserClass.pm (added)
* t/meth_good_1.xpl
* t/namespace3.xpl
* t/svsm_text.b64 (added)
* t/util.pl
First round of Devel::Cover-inspired improvements. These are
the changes to the test suites to increase coverage of the code.
* lib/RPC/XML.pm
* lib/RPC/XML/Procedure.pm
* lib/RPC/XML/Server.pm
Fixes and such from Devel::Cover analysis.
* lib/RPC/XML/Procedure.pm
* lib/RPC/XML/Server.pm
* t/30_method.t
* t/meth_good_1.xpl
* t/meth_good_2.xpl (added)
* t/meth_good_3.xpl (added)
Fixes for file-based method loading/reloading. New tests in the
suite, and re-working of the ugliest hacky part of this package.
* lib/RPC/XML/Procedure.pm
* lib/RPC/XML/Server.pm
* t/30_method.t
* t/meth_good_3.xpl
RPC::XML::Procedure test-coverage improvement. Also removed
some unneeded code.
* lib/RPC/XML/Procedure.pm
* lib/RPC/XML/Server.pm
* t/30_method.t
* t/40_server.t
Last round of RPC::XML::Procedure test coverage. This is mostly
in t/40_server.t, though some bugs were found and addressed in
the modules and in t/30_method.t.
* lib/Apache/RPC/Server.pm
* lib/Apache/RPC/Status.pm
* lib/RPC/XML.pm
* lib/RPC/XML/Client.pm
* lib/RPC/XML/Parser.pm
* lib/RPC/XML/Parser/XMLLibXML.pm
* lib/RPC/XML/Parser/XMLParser.pm
* lib/RPC/XML/ParserFactory.pm
* lib/RPC/XML/Procedure.pm
* lib/RPC/XML/Server.pm
Documentation clean-up and update.
* lib/Apache/RPC/Server.pm
* lib/Apache/RPC/Status.pm
* lib/RPC/XML/Client.pm
* lib/RPC/XML/Parser/XMLLibXML.pm
* lib/RPC/XML/Parser/XMLParser.pm
* lib/RPC/XML/Procedure.pm
* lib/RPC/XML/Server.pm
Changes from new Perl::Critic::Bangs policies.
* xt/01_pod.t
* xt/02_pod_coverage.t
* xt/03_meta.t
* xt/04_minimumversion.t
* xt/05_critic.t
Adjustments to reflect moving from t to xt. Also made changes
to xt/02_pod_coverage.t to reflect changes to modules.
* lib/RPC/XML/Client.pm
Removed some error checks that can never fail.
* lib/RPC/XML/Server.pm
* t/40_server.t
Code-coverage-driven changes and added tests.
* etc/make_method
Fixes from new Perl::Critic::Bangs policies.
* lib/RPC/XML/Server.pm
Removed usage of AutoLoader completely.
* lib/RPC/XML/Server.pm
* t/40_server.t
* xt/02_pod_coverage.t
Removed some dead code and better did the aliases. This
required a change in t/40_server.t for a private sub that no
longer exists. Also updated xt/02_pod_coverage.t for private
subs that have no pod.
* lib/Apache/RPC/Server.pm
RT #67694: Fix a potential infinite-loop condition.
0.74 Sunday January 23, 2011, 12:50:00 PM -0800
* t/90_rt54183_sigpipe.t
RT #56800: Make this suite skip all tests on Windows platforms.
* lib/Apache/RPC/Server.pm
Clean up some run-time "use of undefined value" messages.
* lib/RPC/XML/Parser/XMLLibXML.pm
* lib/RPC/XML/Parser/XMLParser.pm
* t/90_rt58323_push_parser.t (added)
RT #58323: Started as making the parser interfaces correctly
report errors when passed null-length strings or "0" values.
Turned out that the error return interface from XMLLibXML.pm
was not consistent with the rest of the system, so fixed that
as well.
* lib/RPC/XML/Server.pm
* t/40_server.t
RT #58240: Applied a patch from Martijn van de Streek that adds
access to the HTTP::Request object to called method code.
* lib/RPC/XML.pm
* lib/RPC/XML/Parser/XMLLibXML.pm
* lib/RPC/XML/Parser/XMLParser.pm
* t/90_rt58065_allow_nil.t (added)
RT #58065: Allow the parsing of tags when they are
encountered, even if $RPC::XML::ALLOW_NIL is not set. Only
limit the generation of these tags.
* lib/RPC/XML/Server.pm
* t/41_server_hang.t
This test sporadically fails, so enhance the error message for
more info. Also alter the test slightly, hoping it fixes the
random failures.
* etc/make_method
Applied perlcritic to the make_method tool.
* lib/XML/RPC.pm
* t/10_data.t
* t/20_xml_parser.t
* t/21_xml_libxml.t
RT #62916: Previous adjustments to the dateTime.iso8601
stringification caused it to no longer fit the XML-RPC spec.
Fixed.
* lib/RPC/XML.pm
* lib/RPC/XML/Client.pm
* lib/RPC/XML/Parser/XMLParser.pm
* lib/RPC/XML/ParserFactory.pm
* lib/RPC/XML/Server.pm
Used warnings::unused to find unused variables not found by
Perl::Critic.
* t/10_data.t
Realized I had no boundary-tests for ints in smart_encode().
This revealed some problems with i8 values on my 32-bit system.
Don't want to introduce dependency on BigInt right now, so
marked those tests "TODO".
0.73 Tuesday March 16, 2010, 10:45:00 PM -0700
* MANIFEST
* t/28_parser_bugs_50013.t (deleted)
* t/90_rt50013_parser_bugs.t (added)
Rename of t/28_parser_bugs_50013.t to fit more universal scheme
for test suites that directly address specific RT bugs.
* lib/RPC/XML/Server.pm
* t/90_rt54183_sigpipe.t (added)
RT #54183: Provide handling of SIGPIPE when sending the
response to the client, in case they've terminated the
connection.
* MANIFEST
Forgot to add the new test suite to MANIFEST.
* lib/RPC/XML/Server.pm
Forgot to update the module version number.
* lib/RPC/XML.pm
Fix typo in reftype() call.
* lib/RPC/XML.pm
* t/90_rt54494_blessed_refs.t (added)
RT #54494: Fix handling of blessed references in smart_encode().
* lib/Apache/RPC/Server.pm
* lib/Apache/RPC/Status.pm
* lib/RPC/XML.pm
* lib/RPC/XML/Client.pm
* lib/RPC/XML/Function.pm
* lib/RPC/XML/Method.pm
* lib/RPC/XML/Parser.pm
* lib/RPC/XML/Parser/XMLLibXML.pm
* lib/RPC/XML/Parser/XMLParser.pm
* lib/RPC/XML/ParserFactory.pm
* lib/RPC/XML/Procedure.pm
* lib/RPC/XML/Server.pm
Large-scale code clean-up driven by Perl::Critic. All critic
flags down to severity 1 now removed.
* MANIFEST
Forgot to add t/90_rt54494_blessed_refs.t when it was created.
0.72 Sunday December 13, 2009, 09:45:00 PM -0800
* Makefile.PL
* t/40_server_xmllibxml.t
RT #52662: Fix requirement specification for XML::LibXML.
* lib/RPC/XML.pm
Some more clean-up of the docs, removing a redundant section.
0.71 Monday December 7, 2009, 08:00:00 PM -0800
* MANIFEST
* t/01_pod.t (deleted)
* t/02_pod_coverage.t (deleted)
* t/03_meta.t (deleted)
* t/04_minimumversion.t (deleted)
* t/05_critic.t (deleted)
* xt/01_pod.t (added)
* xt/02_pod_coverage.t (added)
* xt/03_meta.t (added)
* xt/04_minimumversion.t (added)
* xt/05_critic.t (added)
Moved author-only tests to xt/, updated MANIFEST.
* MANIFEST
Add test suite t/28_parser_bugs_50013.t, which was omitted from
last release.
* xt/01_pod.t
* xt/02_pod_coverage.t
* xt/03_meta.t
* xt/04_minimumversion.t
* xt/05_critic.t
Re-engineered the author-only/release tests, since they're no
longer in the t/ directory and thus should not interfere.
0.70 Sunday December 6, 2009, 10:00:00 PM -0800
* lib/RPC/XML.pm
* t/10_data.t
RT #49406: Make Base64 data-type allow zero-length data.
* lib/RPC/XML.pm
* t/10_data.t
Hand-applied a patch (most likely from Bill Moseley) to extend
the construction of dateTime.iso8601 data-types.
* t/40_server.t
Fixed another corner-case for the url() test.
* lib/RPC/XML.pm
Fixed a case from previous work that caused "undef" warnings.
* lib/RPC/XML.pm
* lib/RPC/XML/Parser.pm
* t/28_parser_bugs_50013.t
RT #50013: Restore backwards-compatibility for projects that
use RPC::XML::Parser directly.
* lib/RPC/XML/Procedure.pm
RT #50143: Incorrectly called server_fault() as if it were a
coderef.
* lib/Apache/RPC/Server.pm
Applied patch from Frank Wiegand to fix a POD problem.
* lib/RPC/XML.pm
Some additional regexp issues on dateTime.iso8601, to handle
backwards-compatibility.
* lib/RPC/XML/ParserFactory.pm
Fixed some minor doc errors.
* lib/RPC/XML/Parser/XMLParser.pm
Moved the 'require' of some libraries to the point where they
are first needed, to delay loading until/unless necessary.
* lib/RPC/XML/Parser/XMLLibXML.pm (added)
* t/21_xml_libxml.t (added)
* t/29_parserfactory.t
* t/40_server_xmllibxml.t (added)
Implement support for XML::LibXML in the parser-factory.
0.69 Thursday September 3, 2009, 10:25:00 AM -0700
* t/00_load.t
* t/01_pod.t
* t/02_pod_coverage.t
* t/10_data.t
* t/11_base64_fh.t
* t/12_nil.t
* t/15_serialize.t
* t/20_parser.t
* t/50_client.t
Minor clean-up of old CVS/SVN keyword references.
* lib/RPC/XML/Client.pm
* lib/RPC/XML/Parser.pm
* lib/RPC/XML/Parser/XMLParser.pm (added)
* lib/RPC/XML/ParserFactory.pm (added)
* lib/RPC/XML/Server.pm
* t/20_parser.t (deleted)
* t/20_xml_parser.t (added)
* t/29_parserfactory.t (added)
* t/40_server.t
* t/util.pl
Converted parsing to be from a specific class to a
parser-factory style. This included renaming the existing
parser class and shuffling tests around.
* t/70_compression_detect.t
Cleaner approach to scrubbing symbol tables.
* t/00_load.t
* t/01_pod.t
* t/02_pod_coverage.t
* t/03_meta.t (added)
* t/04_minimumversion.t (added)
* t/05_critic.t (added)
New tests, and developer-specific tests changed to only run in
my copy.
* lib/RPC/XML/Client.pm
* lib/RPC/XML/Parser/XMLParser.pm
* lib/RPC/XML/Server.pm
* t/11_base64_fh.t
* t/15_serialize.t
* t/20_xml_parser.t
* t/30_method.t
* t/35_namespaces.t
* t/40_server.t
* t/41_server_hang.t
* t/50_client.t
RT #47806: One more patch for Windows compatibility with
temp-files.
* lib/Apache/RPC/Server.pm
* lib/Apache/RPC/Status.pm
* lib/RPC/XML.pm
* lib/RPC/XML/Client.pm
* lib/RPC/XML/Function.pm
* lib/RPC/XML/Method.pm
* lib/RPC/XML/Parser.pm
* lib/RPC/XML/Parser/XMLParser.pm
* lib/RPC/XML/ParserFactory.pm
* lib/RPC/XML/Procedure.pm
* lib/RPC/XML/Server.pm
Fixes based on Perl::Critic and other best-practices techniques.
* etc/make_method
Also made changes based on Perl::Critic.
* MANIFEST
* lib/RPC/XML/Parser.pm
* lib/RPC/XML/Parser/XMLParser.pm
Expanded definition of the interface to include push-parsing
methods. Documented these and added stubs to
RPC::XML::Parser::XMLParser that throw exceptions when called
by a non-push-parser instance. Reflected changes to test suite
in MANIFEST.
* lib/RPC/XML/Parser/XMLParser.pm
Slight tweak to make this 5.6.1-compatible.
* lib/RPC/XML/Procedure.pm
* lib/RPC/XML/Server.pm
RT #42736: Support user-adjustment of server-based faults, and
normalize the existing faults.
* lib/RPC/XML/Procedure.pm
Fix encoding of return values from call() when the method
called is of type Function (and thus has no strict signatures).
* lib/RPC/XML.pm
* t/13_no_deep_recursion.t (added)
RT #41063: Re-visit how arrays and structs are smart-encoded
and constructed, so as to avoid cyclical data structure
references.
0.67 Friday July 10, 2009, 01:30:00 AM -0700
* lib/RPC/XML/Client.pm
* lib/RPC/XML/Server.pm
* t/70_compression_detect.t (added)
RT #47219: Mis-read the patch from previous fix, this actually
fixes it. Also added a test suite to check for
compression-detection.
0.66 Thursday July 9, 2009, 07:36:15 AM -0700
* lib/RPC/XML/Client.pm
* lib/RPC/XML/Server.pm
RT #47219: Re-did the detection of compression availability
(testing for the Compress::Zlib module) based on comments in
this bug.
* t/60_net_server.t
RT #47220: Net::Server tests are not (currently) viable on
Windows. Also made script taint-safe.
* t/40_server.t
* t/50_client.t
* t/util.pl
RT #47221: Applied a patch from kmx@volny.cz, for better
Windows testing.
* lib/Apache/RPC/Server.pm
* lib/Apache/RPC/Status.pm
* lib/RPC/XML.pm
* lib/RPC/XML/Client.pm
* lib/RPC/XML/Function.pm
* lib/RPC/XML/Method.pm
* lib/RPC/XML/Parser.pm
* lib/RPC/XML/Procedure.pm
* lib/RPC/XML/Server.pm
All modules now use the "warnings" pragma.
0.65 Wednesday June 17, 2009, 06:00:00 AM -0700
* etc/make_method
* etc/rpc-method.dtd
* lib/RPC/XML/Procedure.pm
* t/30_method.t
* t/35_namespaces.t (added)
* t/namespace1.xpl (added)
* t/namespace2.xpl (added)
* t/namespace3.xpl (added)
Support for declaration of namespaces in XPL code. Adds a new
test suite and includes a rewrite/update of the method tests.
Change also covers the make_method tool and the DTD for XPL
files.
* lib/RPC/XML.pm
* lib/RPC/XML/Client.pm
* lib/RPC/XML/Server.pm
* t/02_pod_coverage.t
Interim fix for encoding issues, prior to the mega-encoding
work. This makes the library correctly create octet-based
messages, rather than letting UTF-8 leak in if it was passed in
initially.
* lib/Apache/RPC/Server.pm
* lib/RPC/XML.pm
* lib/RPC/XML/Client.pm
Follow-up to previous commit, some serialization-related
problems. Not all instances of bytelength() had been removed
after the previous slate of changes, and once that was done
some tests in 15_serialize.t broke.
* lib/RPC/XML.pm
* lib/RPC/XML/Parser.pm
* t/12_nil.t (added)
* t/30_method.t
RT #34132: Based on a patch from the requestor, added support
for . Documentation and tests are present, but a little
sparse. This change also incorporates a small add to
lib/RPC/XML/Parser.pm to address RT #42033.
* t/40_server.t
* t/41_server_hang.t
RT #27778: Fix problems with child-process management on
Windows that was causing t/40_server.t to hang during test
runs. Also put skip-clause into t/41_server_hang.t, as
according to the person reporting, it doesn't work at all on
MSWin (the network code is very UNIX-y).
* lib/RPC/XML.pm
* t/10_data.t
Applied a regexp-fix from Joakim Mared for stringification of
doubles.
* lib/RPC/XML.pm
* lib/RPC/XML/Client.pm
* lib/RPC/XML/Parser.pm
* lib/RPC/XML/Procedure.pm
* lib/RPC/XML/Server.pm
* t/10_data.t
RT ticket #35106: Make the behavior of RPC::XML::array
constructor work as expected. This led to adding use of
Scalar::Util and cleaning up the places where I was still doing
"UNIVERSAL::isa(...)" hacks to test refs without the risk of
directly calling ->isa() on a potentially-unblessed ref.
* lib/Apache/RPC/Server.pm
* lib/Apache/RPC/Status.pm
* lib/RPC/XML.pm
* lib/RPC/XML/Client.pm
* lib/RPC/XML/Function.pm
* lib/RPC/XML/Method.pm
* lib/RPC/XML/Parser.pm
* lib/RPC/XML/Procedure.pm
* lib/RPC/XML/Server.pm
Update the copyright year and license information, and add
contact data to all POD sections for RT, AnnoCPAN, GitHub, etc.
* lib/RPC/XML/Client.pm
* t/50_client.t
RT ticket #34559: Allow control of LWP::UA timeouts from within
client class.
* lib/RPC/XML/Server.pm
RT ticket #43019: Small hack to the existing SSL hack for
Socket6 problems.
* lib/Apache/RPC/Server.pm
* lib/Apache/RPC/Status.pm
* lib/RPC/XML.pm
* lib/RPC/XML/Client.pm
* lib/RPC/XML/Function.pm
* lib/RPC/XML/Method.pm
* lib/RPC/XML/Parser.pm
* lib/RPC/XML/Procedure.pm
* lib/RPC/XML/Server.pm
Since Scalar::Util requires 5.006, make that (5.006001,
actually) the base required Perl version.
0.64 Monday September 29, 2008, 04:15:00 AM -0700
* t/40_server.t, revision 361
Further flexibility on the test of $srv->url(). This should
(finally) catch any variation of 127.* address and/or
host/domain naming that aliases to "localhost".
* lib/RPC/XML/Parser.pm, revision 363
* t/20_parser.t, revision 363
Lingering problem from RT ticket #30354, RPC::XML::Parser did
not get the change committed that included parser-level support
for . Also added tests for parsing RPC::XML::request
objects and all the data-type objects to the parser test suite
(had they been there before, I would have caught this myself).
0.63 Friday September 19, 2008, 02:23:12 AM -0700
* lib/RPC/XML.pm, revision 359
Forgot to increment $VERSION before the previous commit. Won't
show up in CPAN as an available update otherwise.
0.62 Friday September 19, 2008, 02:12:02 AM -0700
* t/40_server.t, revision 355
Extended the die message when $srv fails to allocate. Some
testers are getting a failure here but I have no idea how or
why.
* lib/RPC/XML.pm, revision 356
Testers-service reports showed that the new i8 type was not
auto-boxing correctly on true 64-bit machines. Turns out I had
bogus values for the maximums and minimums, not just for 8-byte
ints but also for plain 4-byte ones as well.
0.61 Monday September 15, 2008, 01:38:44 AM -0700
* t/00_load.t, revision 346
Converted to Test::More due to some cpan-testers reports that
showed test 2 failing. Hoping this might provide better
feedback if it continues to fail.
* t/40_server.t, revision 347
Changed a test for "localhost:$port" in the server URL method
to optionally allow localhost.localdomain, for those systems
whose /etc/hosts cause the former to convert to the latter. Was
causing false failures.
* t/40_server.t, revision 348
* t/50_client.t, revision 348
* t/60_net_server.t, revision 348
Test suites armored against server processes that die as a
result of croak() or other calls within 3rd-party modules. The
client and net_server suites were also converted to Test::More
at this time.
* t/40_server.t, revision 349
Fix for RT ticket #36078, fix the URL testing on the server
object to be less strict. Instead of only allowing "localhost",
now also allows "localhost.localdomain" and does a look-up of
"localhost" for the 127.* IP address and permits that as well.
In essence, this extends and supercedes the second change
listed above after more invariant cases were discovered.
* lib/RPC/XML.pm, revision 350
* t/10_data.t, revision 350
Per RT ticket #30354 and specific request from a large agency
using this package, implemented an "i8" type as an extension to
the official XML-RPC specification. Documentation and tests
included.
* t/40_server.t, revision 352
* t/60_net_server.t, revision 352
Some of the work in armoring the test suites against
server-death changed the counts on tests and on call-counts in
the system.status method. Some explicit re-starts didn't help.
0.60 Wednesday April 9, 2008, 03:01:07 AM -0700
* t/00_load.t, revision 328
* t/01_pod.t, revision 328
* t/02_pod_coverage.t, revision 328
* t/10_data.t, revision 328
* t/11_base64_fh.t, revision 328
* t/15_serialize.t, revision 328
* t/20_parser.t, revision 328
* t/30_method.t, revision 328
* t/40_server.t, revision 328
* t/50_client.t, revision 328
* t/60_net_server.t, revision 328
Related to the main change of RT ticket #30849, fixes potential
problem in the creation of temporary file names if a test
script is run directly from the "t" directory. While at it,
added a line with the Subversion "Id" keyword and set the
"svn:keywords" property on all test scripts. The code-fix is
based on suggestions from Jörg Meltzer .
* lib/RPC/XML/Client.pm, revision 329
Per RT ticket #30849, fix problem caused by having colons in
temp-file names. Fix largely from patch suggested by Jörg
Meltzer .
* lib/RPC/XML/Server.pm, revision 331
Applied a modified form of a patch submitted by Mike Rylander
to make things work under SSL.
* lib/RPC/XML/Server.pm, revision 332
* t/41_server_hang.t, revision 332 (added)
Fixed the bug in RPC::XML::Server::process_request() could lead
to an infinite loop if the client shuts down the socket before
the full request is sent. Added a test script specific to this
bug, to catch it if it reappears.
* lib/RPC/XML.pm, revision 333
* t/10_data.t, revision 333
Per RT ticket #30042, made a do-nothing branch in
RPC::XML::smart_encode actually die with an error when a
reference-type is passed in that cannot be converted. Added two
tests to cover this, and took the opportunity to convert
10_data.t to Test::More.
* t/40_server.t, revision 334
* t/50_client.t, revision 334
Applied a patch from Chris Darroch to make the spawning of
servers work in some corner-cases that were failing. All that
was required was explicit specification of 'localhost' in the
instantiation.
* lib/RPC/XML/Parser.pm, revision 336
* t/20_parser.t, revision 336
Applied a patch from Masatake Daimon (大門正岳) to improve the
performance of the parser by reducing the (vast) number of
string-concat operations. During this change, re-wrote the
parser tests to use Test::More and have better diagnostics.
* lib/RPC/XML/Server.pm, revision 337
* t/40_server.t, revision 337
Per RT ticket #29351, fixed a bug that caused a server to
incorrectly report the location and cause of an XML parsing
error in the request. The actual bug and solution were
different than initially reported in the ticket.
* lib/RPC/XML.pm, revision 338
* t/10_data.t, revision 338
Per RT ticket #31818, fix to the XML serialization of double
values to conform to the XML-RPC spec, as it does not allow for
exponential notation. This also required changes to the tests,
as values were no longer being auto-truncated at 5 decimal
places. Also finished cleaning up the t/10_data.t test suite
with diagnostic messages on the tests that had not previously
gotten them.
* lib/RPC/XML.pm, revision 339
* t/20_parser.t, revision 339
In response to concerns raised by a report of parsing problems,
added XML entity encoding for ' and " (' and ") to
the base RPC::XML module, and added a test to the parser suite
to make sure it is correctly turning all core XML entities back
into characters during the parsing process.
* lib/Apache/RPC/Server.pm, revision 341
* lib/RPC/XML/Server.pm, revision 341
* t/40_server.t, revision 341
RT ticket #34557: Provide access to client-side connection info
to methods called on the server, by placing the data from
get_peeraddr() (as abstracted through existing methods in
HTTP::Daemon::ClientConn and Apache::Connection) into localized
keys on the server object, as is already done with the
method_name and signature pseudo-keys. Tests added to
40_server.t and docs updated.
* etc/make_method, revision 343
* lib/Apache/RPC/Server.pm, revision 343
* lib/Apache/RPC/Status.pm, revision 343
* lib/RPC/XML.pm, revision 343
* lib/RPC/XML/Client.pm, revision 343
* lib/RPC/XML/Function.pm, revision 343
* lib/RPC/XML/Method.pm, revision 343
* lib/RPC/XML/Parser.pm, revision 343
* lib/RPC/XML/Procedure.pm, revision 343
* lib/RPC/XML/Server.pm, revision 343
Updated all copyright/redistribution information with current
year and correct/current URLs for Artistic and LGPL licenses.
0.59 Friday June 30, 2006, 01:48:37 AM -0600
* t/10_data.t, revision 1.10
Eliminated the source of some "Modification of a read-only
value..." errors. Patch from Juan Camacho.
* t/01_pod.t, revision 1.1 (added)
* t/02_pod_coverage.t, revision 1.1 (added)
Two new unit-test suites added; the first checks the validity
of the POD docs in each module (correctness tests), the other
checks that POD covers all the publically-visible API routines
(coverage tests).
* lib/Apache/RPC/Server.pm, revision 1.28
* lib/Apache/RPC/Status.pm, revision 1.6
* lib/RPC/XML/Function.pm, revision 1.4
* lib/RPC/XML/Parser.pm, revision 1.13
* lib/RPC/XML/Server.pm, revision 1.44
Fixes to POD documentation (and/or inline comments) as
uncovered by the added POD-oriented unit tests.
* MANIFEST, revision 1.17
* README.apache (deleted)
The README.apache file is no longer relevant.
* lib/Apache/RPC/Server.pm, revision 1.29
Fixed the logic around the setting of $no_def in new(); it was
handling the no_default method-argument backwards. Found by
Eric Cholet.
* lib/RPC/XML.pm, revision 1.36
* t/10_data.t, revision 1.11
Applied a patch from Jos Boumans to add flexibility to the
smart_encode() hack that tries to match bare Perl data to RPC
classes. At the same time, added documentation of the $ENCODE
global variable in the documentation.
0.58 Thursday May 12, 2005, 03:24:23 AM -0700
* lib/RPC/XML.pm, revision 1.35
* t/10_data.t, revision 1.9
Applied patches from Stephen Veiss to fix a small bug in the
encoding method of RPC::XML::string. Trying to encode the
literal string "0" would result in a null string. The patches
provided the fix and a specific test-case for the related suite.
* lib/RPC/XML/Procedure.pm, revision 1.13
* lib/RPC/XML/Server.pm, revision 1.43
Applied a patch from Mike Pomraning to allow user-level
functions to return RPC::XML::fault objects directly without
them being further wrapped by intermediate layers.
* lib/RPC/XML/Procedure.pm, revision 1.14
Implemented a modified version of a patch from Lubomir Host
that addresses an intermittent IOCTL problem when reading XPL
files.
* Makefile.PL, revision 1.38
Incremented package version number and put in warning of the
impending move to XML::LibXML.
0.57 Friday December 24, 2004, 03:02:48 AM -0800
* lib/Apache/RPC/Server.pm, revision 1.27
Some minor changes to how values are read from the
configuration, to reduce "use of uninitialized value" warnings
in regex operations.
* lib/RPC/XML.pm, revision 1.34
* t/10_data.t, revision 1.8
Based on a report from Brian Phillips, made adjustments in the
smart_encode helper-routine to deal with blessed references.
Anything that is derived from HASH or ARRAY is encoded as a
struct or array, respectively. Anything derived from SCALAR is
dereferenced and encoded as per usual. Carried this over to the
class constructors, with special attention to the
RPC::XML::simple_type class. Added tests to the suite for all
of this, as well.
* lib/Apache/RPC/status.base, revision 1.5
* lib/Apache/RPC/status.code, revision 1.4
* lib/Apache/RPC/status.help, revision 1.2
* lib/RPC/XML/Procedure.pm, revision 1.12
* lib/RPC/XML/Server.pm, revision 1.42
* methods/status.base, revision 1.6
* methods/status.code, revision 1.4
* methods/status.help, revision 1.2
* t/40_server.t, revision 1.8
The "system.status" method (both the general one and the one
that is specific to Apache) now recognizes an optional boolean
parameter that can keep the status call from counting against
the "total_requests" struct value. This is to allow external
monitors (status, health, etc.) to use that call without
running up the value of that field needlessly.
0.56 Thursday December 9, 2004, 01:07:00 AM -0800
* etc/make_method, revision 1.10
Small change to the generated XML, to add an "encoding" setting
to the XML preamble.
* t/10_data.t, revision 1.7
* t/60_net_server.t, revision 1.4
Very minor changes, to make the test work with older Perls
and/or Test modules.
* lib/RPC/XML.pm, revision 1.31
Add "encoding" settings to all XML preambles, and make the
scalar variable "$RPC::XML::ENCODING" an importable symbol,
should users want to change the default encoding. Not currently
documented, since this is technically a break from the XML-RPC
spec.
* Makefile.PL, revision 1.35
* t/50_client.t, revision 1.8
Traced a bug that was causing test failures in 50_client.t to a
bug in version 5.800 of the LWP package. Now, Makefile.PL
explicitly requires 5.801 or higher, and the test suite skips
the two tests that are broken by it, in cases where the system
is still at 5.800 or older.
* lib/RPC/XML/Client.pm, revision 1.21
Tightened some numeric comparisons (for deciding to compress
and/or spool to a file), and corrected a typo in an error
message.
* lib/RPC/XML.pm, revision 1.32
Adding the encoding to the request and response blocks messed
up some of the tests in the 10_data.t and 15_serialize.t
suites. Fixed.
* README, revision 1.24
* etc/make_method, revision 1.11
* etc/rpc-method.dtd, revision 1.7
* lib/Apache/RPC/Server.pm, revision 1.26
* lib/Apache/RPC/Status.pm, revision 1.5
* lib/RPC/XML.pm, revision 1.33
* lib/RPC/XML/Client.pm, revision 1.22
* lib/RPC/XML/Function.pm, revision 1.3
* lib/RPC/XML/Method.pm, revision 1.8
* lib/RPC/XML/Parser.pm, revision 1.12
* lib/RPC/XML/Procedure.pm, revision 1.11
* lib/RPC/XML/Server.pm, revision 1.41
Changed all URL references to the Artistic License from the (no
longer valid) language.perl.com version to the (current,
working) www.opensource.org one.
* ChangeLog, revision 1.26
* ChangeLog.xml, revision 1.2
* Makefile.PL, revision 1.36
* README, revision 1.25
Admin files prepped for 0.56 release (also, the ChangeLog.xml
file was modified to reflect tuning of the schema).
0.55 Tuesday November 30, 2004, 01:16:57 AM -0800
* lib/RPC/XML/Server.pm, revision 1.39
Fix from Thomax G. to the loop-invariance near line 1403, for a
bug that mostly appears with openACS-based clients.
* t/60_net_server.t, revision 1.3
Clarify in the message emitted why the tests are skipped when
Net::Server is not available.
* lib/RPC/XML/Server.pm, revision 1.40
Fix based on input from several sources: The Content-Encoding
header was not being set correctly for responses when
compression was applied to the response message.
* lib/RPC/XML/Procedure.pm, revision 1.10
Applied a fix from the Debian maintainer of this package for
their distribution, David Parrish: auto-reloading of methods
was not actually stuffing the new data into the calling object.
* lib/Apache/RPC/Server.pm, revision 1.25
Applied a patch from a user to fix a problem with reading
PerlSetVar values withing a block (worked fine in
blocks), as well as a small addition to the examples in
the docs.
* ChangeLog.xml, revision 1.1 (added)
* MANIFEST, revision 1.16
Added this file (ChangeLog.xml) to the distribution.
0.54 Wednesday April 14, 2004, 04:43:56 AM -0700
* Makefile.PL, revision 1.33
Extended $CLEAN to also remove *.ppd files, and bumped the
package version to 0.54.
* lib/RPC/XML.pm, revision 1.30
* lib/RPC/XML/Procedure.pm, revision 1.9
Applied a patch from Tim Peoples that does three things: the
301 error code in RPC::XML::Procedure::call now includes
signature info when a signature mismatch occurs.
RPC::XML::smart_encode turns undef values into zero-length
RPC::XML::string objects. Lastly, the
RPC::XML::string::as_string method turns undef into null values
as well.
* lib/RPC/XML.pm, revision 1.28
* t/10_data.t, revision 1.6
Small change to the XML character-escaping in
RPC::XML::string's as_string method, so that a lookup-table is
used. The same table is now used to escape keys in structs, as
well. Added tests to cover this. This was suggested by
Johnathan Kupferer.
* t/20_parser.t, revision 1.3
Made a small change for the sake of syntax pedantry.
* lib/RPC/XML/Client.pm, revision 1.20
Fix to the error-handling for a failed LWP::UserAgent->request
call send_request (thanks to Jasper Cramwinckel). Also got a
small glitch covered in one of the calls to the inflate()
method in Compress::Zlib. Thanks to John Tobing for that one.
* lib/RPC/XML/Parser.pm, revision 1.11
Dropped a regex-compare in favor of a string-compare for the
special case of the XML tag being dateTime.iso8601. In some
locales, the 'lc' caused problems. This is near line 288.
* lib/Apache/RPC/Server.pm, revision 1.23
Applied a patch to Apache::RPC::Server (supplied by Tim
Peoples) to support "NoCompression" as a PerlSetVar directive,
the function of which is to disable compression support upon
demand.
* lib/Apache/RPC/Server.pm, revision 1.24
Fixed two minor typo errors in the docs, the names of two of
the PerlSetVar directives.
* lib/RPC/XML.pm, revision 1.29
Added to the docs the fact that struct keys are now escaped.
Also put some coverage in the docs on the two ways of
initializing a struct object.
* lib/RPC/XML/Server.pm, revision 1.38
Applied a patch from Chris Darroch to allow better handling of
arguments in RPC::XML::Server::server_loop. While the
HTTP::Daemon portion was fine with collapsing the arg list into
a hash, the Net::Server portion actually has documented
behavior when it sees the same argument more than once, and
collapsing to a hash caused these extra arguments to be lost.
0.53 Tuesday February 25, 2003, 01:12:11 AM -0800
* t/40_server.t, revision 1.7
Eliminate a warning under 5.00503.
* lib/RPC/XML.pm, revision 1.25
* lib/RPC/XML/Client.pm, revision 1.19
* lib/RPC/XML/Parser.pm, revision 1.10
* t/50_client.t, revision 1.7
Changes to the opening of files for base64 data. The existing
method didn't work under 5.00503.
* t/15_serialize.t, revision 1.3
Added consideration to the filehandle-length tests for Win-ish
offsets.
* lib/RPC/XML.pm, revision 1.26
Added a forgotten binmode() call to an just-opened filehandle
in the base64-to-file support.
0.52 Monday February 10, 2003, 01:37:05 AM -0800
* lib/RPC/XML/Server.pm, revision 1.37
Really got the warning in RPC::XML::Server.pm this time.
Really. Also got some potential errors that seem to be
overlooked under auto-loading but appear when auto-loading is
disabled.
* lib/RPC/XML/Client.pm, revision 1.18
Fixed a potentially-confusing problem in the example code
within the RPC::XML::Client man page, just under "SYNOPSIS".
* spec.in, revision 1.4
More work to the spec.in RPM specfile template. The
Provides/Requires list should be a lot cleaner now, and it also
builds packages under rpm 4.1, now.
* lib/Apache/RPC/Server.pm, revision 1.22
Fixed a lurking bug in the Apache::RPC::Server class that was
not setting the headers properly on responses. Probably lived
this long because no one else but me was using it, and my
client is lax enough to ignore it.
0.51 Thursday January 30, 2003, 12:49:07 AM -0800
* t/11_base64_fh.t, revision 1.4
Removed an extraneous print line in t/11_base64_fh that caused
a warning on some systems.
* t/11_base64_fh.t, revision 1.5
* t/50_client.t, revision 1.6
Fixed calls to skip() in the test suites so that they work with
older versions of the Test module.
* lib/RPC/XML.pm, revision 1.24
* t/10_data.t, revision 1.5
* t/11_base64_fh.t, revision 1.6
Calls to the encode_base64 routine from MIME::Base64 now pass a
zero- length second argument, to suppress newlines between
Base64 lines when stringifying the RPC::XML::base64 objects.
This is to accomodate a broken Java XML-RPC package.
* lib/RPC/XML/Server.pm, revision 1.36
Force a default value for the compress_re attribute in
RPC::XML::Server when none is otherwise present. All my tests
have had Compress::Zlib available, but when it isn't the
compress_re attribute was triggering warnings when used in a
regex.
0.50 Monday January 27, 2003, 03:24:45 AM -0800
* lib/RPC/XML/Procedure.pm
Changed the usage of =head3 directives in the manual page for
RPC::XML::Procedure to a =over/=back block instead. The =head3
directive requires a newer set of pod utilities, and would mean
the package had trouble building on 5.005 installations.
* lib/RPC/XML.pm
* t/11_base64_fh.t
Extended the RPC::XML::base64 class to allow for and handle
being given a filehandle object instead of straight data. The
object is kept as an open filehandle, and the buffer position
is always noted and reset when operated on, so that other parts
of the process using the handle don't get surprised. Added
tests in t/11_base64_fh.t to exercise this.
* lib/RPC/xML.pm
* t/15_serialize.t
Added a serialize() method to all the data classes in
preparation for changing the client and server modules to
stream XML over the line rather than print it using in-memory
strings. Added test suite t/15_serialize.t to exercise this.
* lib/RPC/XML/Parser.pm
* t/20_parser.t
Modified RPC::XML::Parser to accept arguments to new() that
instruct it to spool Base64 data to a filehandle, using the new
capabilities of the base64 class described previously. Added
tests to t/20_parser.t and support for the parameters to the
constructors of the client and base server classes. Documented
all around.
* lib/RPC/XML.pm
Re-engineered the test for the "bytes" pragma in RPC::XML, so
that it now works with Perl 5.005.
* lib/RPC/XML/Client.pm
Fixed the credentials() method in RPC::XML::Client.
* lib/Apache/RPC/Server.pm
* lib/RPC/XML/Client.pm
* lib/RPC/XML/Server.pm
All the internal use of object attributes in RPC::XML::Client
now use accessors instead of the hash keys directly, to make it
easier to sub-class the package. The same was done in
RPC::XML::Server and to some degree in Apache::RPC::Server. The
server classes are more likely to have problems, though.
* lib/RPC/XML/Client.pm
* lib/RPC/XML/Parser.pm
* lib/RPC/XML/Server.pm
The parsing of incoming data in the client and both server
classes is now done to a streaming XML parser, eliminating the
need for the full message to ever be in memory at once.
Likewise, the client and server classes have new attributes and
accessor methods to allow them to spool outgoing messages to
files if the messages threaten to be too large to keep in
memory (this is best used when dealing with a lot of Base64
data that is being dealt with directly on disk as well).
0.46 Sunday December 29, 2002, 11:39:05 PM -0800
* lib/RPC/XML/Client.pm
Applied a patch from Andrew Langmead to fix a bug in the uri()
method of RPC::XML::Client. Prior, retrieving the value could
accidentally reset it. Applied another fix from him to prevent
a possible warning.
* lib/RPC/XML/Server.pm
Applied another patch to better handle testing of the
availability of compression in the client.
* Makefile.PL
Moving around some of the RPM spec-file generation caused
problems with some people trying to build the package if
spec.in was missing. Fixed this in Makefile.PL.
* lib/RPC/XML/Procedure.pm
Fix to RPC::XML::Procedure per tip from Stig Porsgaard, to fix
the reading of 'signature' arguments to new() when providing
all the proc data directly. Reported by others as well, but
Stig nailed it down to a specific line.
0.45 Tuesday October 29, 2002, 09:06:00 PM -0800
* lib/RPC/XML.pm
Fixed a problem in the test-usage of the bytes pragma in
RPC::XML, reported by Marc Jauvin.
* lib/RPC/XML/Parser.pm
Closed a potential security hole in the parsing of external
entities, pointed out by Gregory Steuck.
0.43 Sunday August 18, 2002, 10:19:30 PM -0700
* methods/methodSignature.code
* t/40_server.t
* t/60_net_server.t
Changed methods/methodSignature.code, t/40_server.t and
t/60_net_server.t so that the provided system.methodSignature
follows the accepted API (returns a list of lists, rather than
list of strings). Pointed out by Bjoern Stierand.
* lib/RPC/XML.pm
Added a missing helper (RPC_I4) to RPC::XML.pm.
* lib/Apache/RPC/Server.pm
Fixed a bad bug with the newly-added compression support in
Apache::RPC::Server::handler. Because $self was defined
earlier, strict failed to point out that my object in that
scope was called $srv, rather than $self. And $self->compress
didn't work, amazingly enough. Found and reported by Scott Fagg.
* lib/RPC/XML/Client.pm
Added a credentials() method to the RPC::XML::Client class to
set Basic Authentication credentials on the underlying
LWP::UserAgent object. Per suggestion and sample implementation
from Stuart Clark.
* lib/RPC/XML.pm
* lib/RPC/XML/Server.pm
Fixed a docs-nit in RPC::XML::Server, and did some major
clean-up in the docs for RPC::XML. In particular, added
documentation for one of the data class methods that had been
overlooked ("type").
0.42 Thursday August 1, 2002, 12:51:12 AM -0700
* lib/Apache/RPC/Server.pm
Changed the test in Apache::RPC::Server of the Content-type
header so that it accepts a header that contains "text/xml", as
opposed to only accepting a header that exactly equalled that
string. Allows for things like SOAP::Lite's XMLRPC::Lite which
include a charset in the header.
* lib/RPC/XML.pm
time2iso8601() in the RPC::XML module now allows defaulting of
the $time argument to time() (which means no timezone
specification).
* lib/RPC/XML/Parser.pm
Found a bug in RPC::XML::Parser where base64 data being parsed
in a request/response message wasn't being properly passed to
the c'tor for RPC::XML::base64. Reported by Chris Brierley.
* lib/Apache/RPC/Server.pm
Added a line in Apache::RPC::Server to set the Content-Type
header on HEAD responses. Apache won't take this from the usual
header() method, it has to be explicitly set with
content_type().
* t/40_server.t
Two of the tests in t/40_server.t could cause fatal errors
since a return value wasn't tested for ref-ness before having a
method called on it. Fixed.
* lib/Apache/RPC/Server.pm
* lib/RPC/XML/Client.pm
* lib/RPC/XML/Server.pm
Compress::Zlib-based compression is now supported in
RPC::XML::Server, RPC::XML::Client and Apache::RPC::Server. It
should be compatible with the XMLRPC::Lite package's
compression.
0.41 Wednesday May 22, 2002, 02:50:47 AM -0700
* lib/RPC/XML/Parser.pm
Wrapped the call to XML::Parser::parse (lib/RPC/XML/Parser.pm)
in an eval {} so that parse failures don't kill a server or
client. Reported by Kevin Greene.
* lib/RPC/XML.pm
An intended clone-operation in RPC::XML::response::new
(lib/RPC/XML.pm) was never actually written, which allowed for
a corner case that could result in new() return undef when it
shouldn't. Related to the bug reported by Sergey Scherbinin.
* lib/RPC/XML/Procedure.pm
The RPC::XML::Procedure::call method (lib/RPC/XML/Procedure.pm)
had one error-check loop that was returning a full
RPC::XML::response object, instead of just a RPC::XML::fault.
Reported by Sergey Scherbinin.
0.40 Saturday May 4, 2002, 12:42:18 AM -0700
* *
Fixed some grammar problems in error messages, and some
formatting.
* lib/Apache/RPC/Server.pm
Fixed a bug in the new() method of Apache::RPC::Server where it
was expecting the value of the "apache" key to be an object of
the Apache::Server class, but it was actually getting an object
of the Apache class.
* etc/make_method
* etc/rpc-method.dtd
* lib/RPC/XML/Function.pm (added)
Created RPC::XML::Function class, which is a type of
server-side encapsulator that doesn't bother with signature
tests of any kind. The DTD and make_method tool support the new
type.
* etc/make_method
Changed the encoding of the Perl code in etc/make_method as
follows: If the code does not already contain either of the two
sequences, ']]>' or '__DATA__', then the code is wrapped in a
section, with #!/usr/bin/perl (actually,
$Config{startperl}) at the head and __DATA__ at the end.
Besides leaving the Perl code readable, the *.xpl files can now
be syntax-checked with "perl -cx". Thanks to the mod_perl guys
for this idea, cribbed from their manual page.
* lib/RPC/XML/Procedure.pm
* lib/RPC/XML/Server.pm
Abstracted some of the invocation code out of the server class
and into the RPC::XML::Procedure class, where it really
belonged. This aided in further eliminating redundancy in the
server class in the same general area. I may yet want to tune
this area, but I'm a good deal happier with the reduction in
complexity and repetition.
0.44 Tuesday April 30, 2002, 11:44:08 PM -0700
* lib/RPC/XML.pm
Cleaned up the exports list in RPC::XML.pm, which still had
remnants from when this package was intended to extend XML-RPC.
There were no routines to match the symbols, but the potential
for error was there.
* lib/RPC/XML/Client.pm
* lib/RPC/XML/Procedure.pm
* lib/RPC/XML/Server.pm
Fixed a typo in the docs for RPC::XML::Client, and some
documentation goofs in RPC::XML::Server (regarding the timeout
method/option). A few doc fixes in RPC::XML::Procedure, for
good measure.
* lib/RPC/XML.pm
Implemented two fixes sent in by Marc Liyanage: a fix for
setting the Content-Length headers on messages that takes the
length in bytes rather than characters; the second is a fix
around the compression support that makes certain an undef
isn't evaluated against the regex.
* lib/RPC/XML.pm
The above added an exported function to RPC::XML, so that got
documented. In the process, it occurred to me to document the
helper functions like RPC_BOOLEAN, RPC_DOUBLE, etc.
0.37 Friday March 22, 2002, 10:16:08 PM -0800
* lib/RPC/XML/Server.pm
Applied a patch to RPC::XML::Server from Tino Wuensche
() that fixed some of the
signal-handling and exit-case-handling in server_loop().
* lib/RPC/XML/Procedure.pm
Fixed a bug in RPC::XML::Procedure found by a user (a former
co-worker from my Denver days, coincidentally enough) that
would trigger when auto_methods was set to 1 on a server
object, but the request had no matching file anywhere in the
search path.
0.36 Tuesday January 29, 2002, 12:11:30 PM -0800
* MANIFEST
The file util.pl in the t directory was accidentally omitted
from the 0.35 release. This release is meant only to correct
that oversight.
0.35 Sunday January 27, 2002, 04:29:19 PM -0800
* etc/make_method
Fixed a small bug in make_method that would have caused a
failure if anyone used the command-line switches to specify
data, rather than a base-file (specifically, the handling of
the --code argument). Also clarified a few places in the man
page.
* lib/Apache/RPC/status.code
* methods/methodHelp.code
* methods/status.code
Found bugs in both versions of the system.status server method
(both the basic and the Apache flavor). Both were neglecting to
set the "methods_known" value. Also found a bug in
system.methodHelp. Amazing what writing the regression tests
can uncover.
* lib/RPC/XML/Method.pm
* lib/RPC/XML/Procedure.pm (added)
RPC::XML::Method is now a skeleton file, slated to be removed
by or before 1.0. It has been renamed to RPC::XML::Procedure,
and the RPC::XML::Method class is declared as an empty subclass
of the RPC::XML::Procedure class. Procedures differ from
methods in that they do not get the server object instance as a
first parameter in the list that gets passed in.
* etc/make_method
* etc/rpc-method.dtd
* ex/linux.proc.cpuinfo.code
* ex/linux.proc.meminfo.code
Support for RPC::XML::Procedure (and general procedure vs.
method) added to the DTD and the make_method tool. All the
routines in the ex/ directory are declared as procedures, to
further illustrate the concept.
* lib/RPC/XML/Procedure.pm
* lib/RPC/XML/Server.pm
When code blocks for XPL files are eval'd, they are given a
"package" statement to force subsequent calls to be in the
RPC::XML::Procedure namespace, rather than defaulting to main
(a potentially dangerous assumption). The docs on
routine-calling in RPC::XML::Server have been updated to
discuss this.
* t/40_server.t
Many more tests added to the suite for RPC::XML::Server.
* t/50_client.t (added)
Created the test suite for RPC::XML::Client.
* lib/RPC/XML.pm
* lib/RPC/XML/Client.pm
RPC::XML::Client no longer returns a full RPC::XML::response
object from any of its routines. Rather, simple_request still
does what it always has, and send_request now returns a
data-type value. All the data-type classes have a method called
"is_fault" that returns false for all except (of course)
RPC::XML::fault. This lets callers of send_request test the
return value to see if it is a fault.
* lib/RPC/XML/Client.pm
* t/50_client.t
Added callback support for errors and faults to the
RPC::XML::Client class. This allows programmers to tie specific
actions to cases where a call returns a RPC::XML::fault object,
or an outright error.
* t/60_net_server.t (added)
Created a separate test suite for RPC::XML::Server when used in
conjunction with the Net::Server package (it skips if the
latter is not installed on the system).
* lib/RPC/XML/Server.pm
Almost all of the method-manipulation routines in
RPC::XML::Server (all but add_default_methods()) now have
counterparts called by the same name after s/method/proc/. This
is purely for syntactical sugar and symmetry. Except in the
case of add_proc(), where it actually ensures that a
hash-reference calling convention is geared correctly to add a
RPC::XML::Procedure object rather than RPC::XML::Method.
0.30 Thursday January 3, 2002, 01:57:29 AM -0800
* lib/Apache/RPC/Server.pm
Apache::RPC::Server::list_servers no longer sorts the list
before returning it. No reason to assume it matters, or to levy
that tax against those who don't care.
* lib/RPC/XML/Server.pm
RPC::XML::Server::url now constructs saner strings for HTTPS
and for HTTP on port 80.
* lib/RPC/XML/Server.pm
The new() method in RPC::XML::Server wasn't quite handling the
"host" and "port" arguments that Apache::RPC::Server sent it
correctly.
* lib/RPC/XML/Server.pm
Added a patch to the RPC::XML::Server class from Christopher
Blizzard (blizzard@redhat.com) to allow control over the
timeout interval that HTTP::Daemon uses in answering new
connections.
* Makefile.PL
Replaced a GNU Make-centric dependancy rule for the XPL files
with a more portable .SUFFIXES-based one. This is unfortunate,
as the % syntax of GNU make is much cleaner. But GNU Make isn't
universal. Yet.
* lib/Apache/RPC/Status.pm (added)
This release marks the debut of Apache::RPC::Status, a monitor
similar in nature and design to Apache::Status, for running RPC
servers under Apache/mod_perl. See the manual page for details.
* lib/Apache/RPC/Server.pm
Documentation for Apache::RPC::Server was updated based on
trials and travails in trying to actually set up a
configuration inside blocks. This isn't very clear in
the mod_perl documentation, but at least the docs for this
module reflect exactly what I have configured on my development
box, so I know it works.
0.29 Sunday December 2, 2001, 10:41:39 PM -0800
* lib/RPC/XML/Server.pm
Added share_methods(), copy_methods() and delete_method() calls
to the RPC::XML::Server class (and thus to the Apache class as
well). Had already added an INSTALL_DIR method to retrieve the
class-specific installation dir to the Apache class, so
mirrored it here, as well.
* lib/Apache/RPC/Server.pm
Added list_servers() static method to Apache::RPC::Server, to
allow for abstract retrieval of the ID-tags of the current
known servers. This is mainly so Apache::RPC::Status can use it
in conjunction with get_server() to examine the server objects
for the sake of stats and such.
* lib/RPC/XML/Server.pm
Added list_methods() to RPC::XML::Server, to list the object's
known (published) methods by name. Mainly for use in the
regression suites, but worth documenting in the API in case
someone else finds it useful.
* methods/introspection.code
* methods/listMethods.code
* methods/methodHelp.code
* methods/methodSignature.code
Four of the provided methods in the introspection API
(system.introspection, system.listMethods, system.methodHelp
and system.methodSignature) needed to be updated to use the
newer API for the XML::RPC::Method class when retrieving
information from the server.
* t/30_method.t (added)
* t/40_server.t (added)
Started the test suites for RPC::XML::Method and
RPC::XML::Server. The tests that are delivered as part of this
build are not fully complete, but should be a reasonable start.
0.28 Sunday October 7, 2001, 09:27:39 PM -0700
* lib/RPC/XML.pm
Found a subtle-but-nasty bug in the handling of
RPC::XML::string objects. Thanks to Dominic Mitchell
for pointing me in the right direction.
* lib/RPC/XML.pm
Started down the path of making the suite as a whole geared
more towards real use than illustrative example. The XML
data-classes now no longer use indention (or any superfluous
whitespace) in their stringification. This shortened the code
quite a bit, and will also mean shorter messages. This could
not have been done cleanly without the tests in t/10_data.t.
* lib/Apache/RPC/Server.pm
* lib/RPC/XML/Method.pm (added)
* lib/RPC/XML/Server.pm
Extracted the method-manipulation code into a new class, called
RPC::XML::Method. This should make method-sharing easier, and
pull a lot of method-specific code out of RPC::XML::Server and
Apache::RPC::Server.
* lib/Apache/RPC/Server.pm
Clarified some issues in the new() constructor of the
Apache::RPC::Server class, and also changed the calling
convention. It no longer treats the first few arguments in any
special way at all. The arguments are all consistently taken as
option/value pairs, just as with RPC::XML::Server. The
documentation reflects this. This may break things built on the
old style, but in the long run it should prove much better.
0.27 Sunday July 8, 2001, 04:25:51 PM -0700
* lib/RPC/XML.pm
Removed a -w warning from RPC/XML.pm. Fixed some cases in the
new() method of RPC::XML::boolean that would have permitted
invalid data. Added two convenience methods to RPC::XML::fault,
called code() and string(), that fetch the faultCode and
faultString member values as native Perl values. The
RPC::XML::base64 class was using the wrong container tags in
the as_string method.
* lib/RPC/XML/Server.pm
Clarified and expanded some of the documentation in
RPC/XML/Server.pm.
* Makefile.PL
Adjusted the PREREQ_PM hash in Makefile.PL so that it correctly
looks for LWP, and also looks for File::Spec 0.8 or newer
(needed to ensure that the splitpath() method is available).
* t/00_load.t
* t/10_data.t
* t/20_parser.t
Cleaned up the load-tests (t/00_load.t) to use the Test
harnessing package. Added test suites for the RPC::XML data
classes (t/10_data.t, 96 tests) and the RPC::XML::Parser
container-class (t/20_parser.t, 7 tests).
0.26 Monday June 25, 2001, 10:30:18 PM -0700
* lib/RPC/XML/Server.pm
Fixed some doc errors in RPC::XML::Server. Mainly things I had
simplified, but not updated the docs to reflect.
* lib/Apache/RPC/Server.pm
Added a fair amount to the docs in Apache::RPC::Server. In
particular, a new section was added that illustrates using
configuration sections to create the server objects in
the master Apache process, so that they are automatically
inherited by children.
0.25 Tuesday June 12, 2001, 10:35:09 PM -0700
* *
All files are tracked from this point forward.
# Generated on Monday September 3, 2012, 11:48:20 AM -0700
# Using changelog2x/0.11, App::Changelog2x/0.11, XML::LibXML/2.0004,
# XML::LibXSLT/1.77, libxml/2.7.3, libxslt/1.1.24 (with exslt)
# XSLT sources:
# $Id: changelog2text.xslt 8 2009-01-19 06:46:50Z rjray $
# $Id: common-text.xslt 8 2009-01-19 06:46:50Z rjray $
# $Id: common.xslt 4 2009-01-07 13:02:06Z rjray $
RPC-XML-0.77/ChangeLog.xml 000644 000765 000024 00000332406 12021175217 015402 0 ustar 00rjray staff 000000 000000
RPC::XMLPerl Module RPC::XML Change History
Revision history for the Perl extension module RPC::XML. This is an
implementation of the XML-RPC standard as described at
http://www.xmlrpc.com.
This implementation also permits some minor
extensions to the base protocol in terms of supporting HTTP/1.1 and
allowing choice of character-set encodings for XML messages.
Fix a test failure on Windows.
RT #70408:
Fix spelling error in man page, reported by Debian group.
Fix to handle cases where server creation fails. Now skips the
tests rather than dying.
RT #67486:
Add port to Host header in client requests.
RT #65341:
Added "use" of forgotten library File::Temp. This was causing failure
when "message_file_thresh" kicked in.
RT #78602:
Changed 64-bit test from use64bitint to longsize.
On some systems (such as OS X), use64bitint can be true even when in
32-bit mode.
Fix from Christian Walde, skip passed test on Windows.
Checkpoint refactoring and additional tests.
Work is not complete here, but the Net::Server changes demand
immediate attention
RT #72780:
Check for a possible parser failure. One instance of XML::Parser
failing to parse the extern entities test. Cannot reproduce, so wrap it
in a "skip" block for now.
RT #71452:
Correct handling of dateTime parameters. Existing code in
lib/RPC/XML/Procedure.pm did not properly handle
parameters of the dateTime.iso8601 type. Also, there were no tests for
these.
Renamed t/30_method.t to t/30_procedure.t.
RT #77992:
Make RPC::XML::Server work with Net::Server again, after the API
changes of Net::Server 2.x.
RT #70258:
Fixed typos in docs pointed out by Debian team.
Better version of the fix for infinite loops.
This is the patch originally suggested by Eric Cholet, who found
the bug.
RT #70280:
This test was still testing RPC/XML/Method.pm.
Rewrote to remove that but include the (forgotten) XMLLibXML.pm module.
That test has to be conditional on the presence of XML::LibXML.
Clean up test suite to work with older Test::More.
Also specify a minimum Test::More that supports subtest(). This is
also a part of
RT #70280.
These tests had failures when run as root.
Permissions-based negative tests were incorrectly passing.
Moved the 64-bit "TODO" tests to a SKIP block.
Non-64-bit systems will skip, rather than fail, these tests.
RT #65616:
Fix for slow methods killing servers.
Applied and modified patch from person who opened the ticket.
RT #55628:
Improve flexibility of date parsing.
This adds the ability to pass any ISO 8601 string to the
RPC::XML::datetime_iso8601 constructor.
Somehow, t/13_no_deep_recursion.t never got added to MANIFEST.
RT #65154:
Fixed a cut/paste error in an error message.
RT #68792:
Merge pull request #2 from dragon3/master
(https://github.com/dragon3).
Allow setting of "Host" header, and test suite for it.
Added new test suite to MANIFEST, fixed spelling.
Also added "plan tests" line to the test suite.
Merge pull request #3 from yannk/master
(https://github.com/yannk).
Expat parser subclass is protected against ext ent attack, libxml isn't.
Undo a change to this suite from yannk's pull.
More perlcritic-driven clean-up.
This is mostly POD sections, but also includes heavy re-working of
etc/make_method and parts of lib/RPC/XML.pm.
Fixed external entity handling on MacOS.
Also made small change to the test suite to be cleaner.
Took out warnings on external entities blocking.
Now it blocks silently. Also cleaned up some docs.
Additions to increase code coverage in XML.pm.
Turns out this wasn't exporting RPC_I8.
Made 5.8.8 the new minimum-required perl.
Also dropped the utf8_downgrade hack, which affected an xt test.
Improved arguments-checking in send_request.
Fixed error-cases in usage of File::Temp->new().
File::Temp::new croaks on errors, doesn't return undef like I thought.
Roll Method.pm and Function.pm into Procedure.pm.
Remove Method.pm and Function.pm from distro.
Fixed regexp for methodName validation.
First round of Devel::Cover-inspired improvements.
These are the changes to the test suites to increase coverage of the
code.
Fixes and such from Devel::Cover analysis.
Fixes for file-based method loading/reloading.
New tests in the suite, and re-working of the ugliest hacky part of this
package.
RPC::XML::Procedure test-coverage improvement.
Also removed some unneeded code.
Last round of RPC::XML::Procedure test coverage.
This is mostly in t/40_server.t, though some bugs were found and
addressed in the modules and in t/30_method.t.
Documentation clean-up and update.
Changes from new Perl::Critic::Bangs policies.
Adjustments to reflect moving from t to xt.
Also made changes to xt/02_pod_coverage.t to reflect changes to
modules.
Removed some error checks that can never fail.
Code-coverage-driven changes and added tests.
Fixes from new Perl::Critic::Bangs policies.
Removed usage of AutoLoader completely.
Removed some dead code and better did the aliases.
This required a change in t/40_server.t for a private sub that no
longer exists. Also updated xt/02_pod_coverage.t for private subs that
have no pod.
RT #67694:
Fix a potential infinite-loop condition.
RT #56800:
Make this suite skip all tests on Windows platforms.
Clean up some run-time "use of undefined value" messages.
RT #58323:
Started as making the parser interfaces correctly report errors when
passed null-length strings or "0" values. Turned out that the error
return interface from XMLLibXML.pm was not consistent with the rest of
the system, so fixed that as well.
RT #58240:
Applied a patch from Martijn van de Streek that adds access to the
HTTP::Request object to called method code.
RT #58065:
Allow the parsing of <nil /> tags when they
are encountered, even if $RPC::XML::ALLOW_NIL is not set. Only limit
the generation of these tags.
This test sporadically fails, so enhance the error message for more info.
Also alter the test slightly, hoping it fixes the random failures.
Applied perlcritic to the make_method tool.
RT #62916:
Previous adjustments to the dateTime.iso8601
stringification caused it to no longer fit the XML-RPC spec. Fixed.
Used warnings::unused to find unused variables
not found by Perl::Critic.
Realized I had no boundary-tests for ints in smart_encode(). This
revealed some problems with i8 values on my 32-bit system. Don't
want to introduce dependency on BigInt right now, so marked those
tests "TODO".
Rename of t/28_parser_bugs_50013.t to fit more universal scheme for
test suites that directly address specific RT bugs.
RT #54183:
Provide handling of SIGPIPE when sending the response to the client,
in case they've terminated the connection.
Forgot to add the new test suite to MANIFEST.
Forgot to update the module version number.
Fix typo in reftype() call.
RT #54494:
Fix handling of blessed references in smart_encode().
Large-scale code clean-up driven by Perl::Critic. All critic flags
down to severity 1 now removed.
Forgot to add t/90_rt54494_blessed_refs.t when it was created.
RT #52662:
Fix requirement specification for XML::LibXML.
Some more clean-up of the docs, removing a redundant section.
Moved author-only tests to xt/, updated MANIFEST.
Add test suite t/28_parser_bugs_50013.t, which was omitted from last
release.
Re-engineered the author-only/release tests, since they're no longer in
the t/ directory and thus should not interfere.
RT #49406:
Make Base64 data-type allow zero-length data.
Hand-applied a patch (most likely from Bill Moseley) to extend the
construction of dateTime.iso8601 data-types.
Fixed another corner-case for the url() test.
Fixed a case from previous work that caused "undef" warnings.
RT #50013:
Restore backwards-compatibility for projects that use RPC::XML::Parser
directly.
RT #50143:
Incorrectly called server_fault() as if it were a coderef.
Applied patch from Frank Wiegand to fix a POD problem.
Some additional regexp issues on dateTime.iso8601, to handle
backwards-compatibility.
Fixed some minor doc errors.
Moved the 'require' of some libraries to the point where they are
first needed, to delay loading until/unless necessary.
Implement support for XML::LibXML in the parser-factory.
Minor clean-up of old CVS/SVN keyword references.
Converted parsing to be from a specific class to a parser-factory style.
This included renaming the existing parser class and shuffling tests
around.
Cleaner approach to scrubbing symbol tables.
New tests, and developer-specific tests changed to only run in my copy.
RT #47806:
One more patch for Windows compatibility with temp-files.
Fixes based on Perl::Critic and other best-practices techniques.
Also made changes based on Perl::Critic.
Expanded definition of the interface to include push-parsing methods.
Documented these and added stubs to RPC::XML::Parser::XMLParser that
throw exceptions when called by a non-push-parser instance. Reflected
changes to test suite in MANIFEST.
Slight tweak to make this 5.6.1-compatible.
RT #42736:
Support user-adjustment of server-based faults, and normalize the
existing faults.
Fix encoding of return values from call() when the method called is of
type Function (and thus has no strict signatures).
RT #41063:
Re-visit how arrays and structs are smart-encoded and constructed, so
as to avoid cyclical data structure references.
RT #47219:
Mis-read the patch from previous fix, this actually fixes it.
Also added a test suite to check for compression-detection.
RT #47219:
Re-did the detection of compression availability (testing for the
Compress::Zlib module) based on comments in this bug.
RT #47220:
Net::Server tests are not (currently) viable on Windows. Also made
script taint-safe.
RT #47221:
Applied a patch from kmx@volny.cz, for better Windows testing.
All modules now use the "warnings" pragma.
Support for declaration of namespaces in XPL code.
Adds a new test suite and includes a rewrite/update of the method
tests. Change also covers the make_method tool and the DTD for XPL
files.
Interim fix for encoding issues, prior to the mega-encoding work.
This makes the library correctly create octet-based messages, rather
than letting UTF-8 leak in if it was passed in initially.
Follow-up to previous commit, some serialization-related problems.
Not all instances of bytelength() had been removed after the previous
slate of changes, and once that was done some tests in 15_serialize.t
broke.
RT #34132:
Based on a patch from the requestor, added support for <nil/>.
Documentation and tests are present, but a little sparse. This change
also incorporates a small add to lib/RPC/XML/Parser.pm
to address
RT #42033.
RT #27778:
Fix problems with child-process management on Windows that was causing
t/40_server.t to hang during test runs. Also put
skip-clause into t/41_server_hang.t, as according
to the person reporting, it doesn't work at all on MSWin (the network
code is very UNIX-y).
Applied a regexp-fix from Joakim Mared for stringification of doubles.
RT ticket #35106:
Make the behavior of RPC::XML::array constructor work as expected.
This led to adding use of Scalar::Util and cleaning up the places where
I was still doing "UNIVERSAL::isa(...)" hacks to test refs without the
risk of directly calling ->isa() on a potentially-unblessed ref.
Update the copyright year and license information, and add contact data
to all POD sections for RT, AnnoCPAN, GitHub, etc.
RT ticket #34559:
Allow control of LWP::UA timeouts from within client class.
RT ticket #43019:
Small hack to the existing SSL hack for Socket6 problems.
Since Scalar::Util requires 5.006, make that (5.006001, actually) the
base required Perl version.
Further flexibility on the test of $srv->url(). This should (finally)
catch any variation of 127.* address and/or host/domain naming that
aliases to "localhost".
Lingering problem from
RT ticket #30354,
RPC::XML::Parser did not get the change committed that included
parser-level support for <i8>. Also added tests for parsing
RPC::XML::request objects and all the data-type objects to the parser
test suite (had they been there before, I would have caught this
myself).
Forgot to increment $VERSION before the previous commit. Won't show up
in CPAN as an available update otherwise.
Extended the die message when $srv fails to allocate. Some testers are
getting a failure here but I have no idea how or why.
Testers-service reports showed that the new i8 type was not auto-boxing
correctly on true 64-bit machines. Turns out I had bogus values for
the maximums and minimums, not just for 8-byte ints but also for plain
4-byte ones as well.
Converted to Test::More due to some cpan-testers reports that showed
test 2 failing. Hoping this might provide better feedback if it
continues to fail.
Changed a test for "localhost:$port" in the server URL method to
optionally allow localhost.localdomain, for those systems whose
/etc/hosts cause the former to convert to the latter. Was causing
false failures.
Test suites armored against server processes that die as a result of
croak() or other calls within 3rd-party modules. The client and
net_server suites were also converted to Test::More at this time.
Fix for
RT ticket #36078,
fix the URL testing on the server object to be less strict. Instead of
only allowing "localhost", now also allows "localhost.localdomain" and
does a look-up of "localhost" for the 127.* IP address and permits
that as well. In essence, this extends and supercedes the second change
listed above after more invariant cases were discovered.
Per
RT ticket #30354
and specific request from a large agency using this package,
implemented an "i8" type as an extension to the official XML-RPC
specification. Documentation and tests included.
Some of the work in armoring the test suites against server-death
changed the counts on tests and on call-counts in the system.status
method. Some explicit re-starts didn't help.
Related to the main change of
RT ticket #30849,
fixes potential problem in the creation of temporary file names if a
test script is run directly from the "t" directory. While at it, added
a line with the Subversion "Id" keyword and set the "svn:keywords"
property on all test scripts. The code-fix is based on suggestions from
Jörg Meltzer <joerg@joergmeltzer.de>.
Per RT ticket #30849,
fix problem caused by having colons in temp-file names. Fix largely
from patch suggested by Jörg Meltzer <joerg@joergmeltzer.de>.
Applied a modified form of a patch submitted by Mike Rylander
<miker@n2bb.com> to make things work under SSL.
Fixed the bug in RPC::XML::Server::process_request() could lead to an
infinite loop if the client shuts down the socket before the full
request is sent. Added a test script specific to this bug, to catch it
if it reappears.
Per RT ticket #30042,
made a do-nothing branch in RPC::XML::smart_encode actually die with an
error when a reference-type is passed in that cannot be converted.
Added two tests to cover this, and took the opportunity to convert
10_data.t to Test::More.
Applied a patch from Chris Darroch to make the spawning of servers work
in some corner-cases that were failing. All that was required was
explicit specification of 'localhost' in the instantiation.
Applied a patch from Masatake Daimon (大門正岳) to improve the performance
of the parser by reducing the (vast) number of string-concat operations.
During this change, re-wrote the parser tests to use Test::More and
have better diagnostics.
Per RT ticket #29351,
fixed a bug that caused a server to incorrectly report the location and
cause of an XML parsing error in the request. The actual bug and
solution were different than initially reported in the ticket.
Per RT ticket #31818,
fix to the XML serialization of double values to conform to the
XML-RPC spec, as it does not allow for exponential notation. This also
required changes to the tests, as values were no longer being
auto-truncated at 5 decimal places. Also finished cleaning up the
t/10_data.t test suite with diagnostic messages on the tests that
had not previously gotten them.
In response to concerns raised by a report of parsing problems, added
XML entity encoding for ' and " (' and ") to the
base RPC::XML module, and added a test to the parser suite to make
sure it is correctly turning all core XML entities back into characters
during the parsing process.
RT ticket #34557:
Provide access to client-side connection info to methods called on
the server, by placing the data from get_peeraddr() (as abstracted
through existing methods in HTTP::Daemon::ClientConn and
Apache::Connection) into localized keys on the server object, as is
already done with the method_name and signature pseudo-keys. Tests
added to 40_server.t and docs updated.
Updated all copyright/redistribution information with current year and
correct/current URLs for Artistic and LGPL licenses.
Eliminated the source of some "Modification of a read-only value..."
errors. Patch from Juan Camacho.
Two new unit-test suites added; the first checks the validity of the
POD docs in each module (correctness tests), the other checks that POD
covers all the publically-visible API routines (coverage tests).
Fixes to POD documentation (and/or inline comments) as uncovered by the
added POD-oriented unit tests.
The README.apache file is no longer relevant.
Fixed the logic around the setting of $no_def in new(); it was handling
the no_default method-argument backwards. Found by Eric Cholet.
Applied a patch from Jos Boumans to add flexibility to the
smart_encode() hack that tries to match bare Perl data to RPC classes.
At the same time, added documentation of the $ENCODE global variable
in the documentation.
Applied patches from Stephen Veiss to fix a small bug in the encoding
method of RPC::XML::string. Trying to encode the literal string "0"
would result in a null string. The patches provided the fix and a
specific test-case for the related suite.
Applied a patch from Mike Pomraning to allow user-level functions to
return RPC::XML::fault objects directly without them being further
wrapped by intermediate layers.
Implemented a modified version of a patch from Lubomir Host that
addresses an intermittent IOCTL problem when reading XPL files.
Incremented package version number and put in warning of the impending
move to XML::LibXML.
Some minor changes to how values are read from the configuration, to
reduce "use of uninitialized value" warnings in regex operations.
Based on a report from Brian Phillips, made adjustments in the
smart_encode helper-routine to deal with blessed references. Anything
that is derived from HASH or ARRAY is encoded as a struct or array,
respectively. Anything derived from SCALAR is dereferenced and encoded
as per usual. Carried this over to the class constructors, with special
attention to the RPC::XML::simple_type class. Added tests to the suite
for all of this, as well.
The "system.status" method (both the general one and the one that is
specific to Apache) now recognizes an optional boolean parameter that
can keep the status call from counting against the "total_requests"
struct value. This is to allow external monitors (status, health, etc.)
to use that call without running up the value of that field needlessly.
Small change to the generated XML, to add an "encoding" setting to the
XML preamble.
Very minor changes, to make the test work with older Perls and/or Test
modules.
Add "encoding" settings to all XML preambles, and make the scalar
variable "$RPC::XML::ENCODING" an importable symbol, should users want
to change the default encoding. Not currently documented, since this is
technically a break from the XML-RPC spec.
Traced a bug that was causing test failures in 50_client.t to a bug in
version 5.800 of the LWP package. Now, Makefile.PL explicitly requires
5.801 or higher, and the test suite skips the two tests that are broken
by it, in cases where the system is still at 5.800 or older.
Tightened some numeric comparisons (for deciding to compress and/or
spool to a file), and corrected a typo in an error message.
Adding the encoding to the request and response blocks messed up some
of the tests in the 10_data.t and 15_serialize.t suites. Fixed.
Changed all URL references to the Artistic License from the (no longer
valid) language.perl.com version to the (current, working)
www.opensource.org one.
Admin files prepped for 0.56 release (also, the ChangeLog.xml file was
modified to reflect tuning of the schema).
Fix from Thomax G. to the loop-invariance near line 1403, for a bug
that mostly appears with openACS-based clients.
Clarify in the message emitted why the tests are skipped when
Net::Server is not available.
Fix based on input from several sources: The Content-Encoding header
was not being set correctly for responses when compression was applied
to the response message.
Applied a fix from the Debian maintainer of this package for their
distribution, David Parrish: auto-reloading of methods was not actually
stuffing the new data into the calling object.
Applied a patch from a user to fix a problem with reading PerlSetVar
values withing a <Location> block (worked fine in <Perl> blocks),
as well as a small addition to the examples in the docs.
Added this file (ChangeLog.xml) to the distribution.
Extended $CLEAN to also remove *.ppd files, and bumped the package
version to 0.54.
Applied a patch from Tim Peoples that does three things: the 301
error code in RPC::XML::Procedure::call now includes signature info
when a signature mismatch occurs. RPC::XML::smart_encode turns undef
values into zero-length RPC::XML::string objects. Lastly, the
RPC::XML::string::as_string method turns undef into null values as
well.
Small change to the XML character-escaping in RPC::XML::string's
as_string method, so that a lookup-table is used. The same table
is now used to escape keys in structs, as well. Added tests to cover
this. This was suggested by Johnathan Kupferer.
Made a small change for the sake of syntax pedantry.
Fix to the error-handling for a failed LWP::UserAgent->request call
send_request (thanks to Jasper Cramwinckel). Also got a small glitch
covered in one of the calls to the inflate() method in Compress::Zlib.
Thanks to John Tobing for that one.
Dropped a regex-compare in favor of a string-compare for the special
case of the XML tag being dateTime.iso8601. In some locales, the 'lc'
caused problems. This is near line 288.
Applied a patch to Apache::RPC::Server (supplied by Tim Peoples) to
support "NoCompression" as a PerlSetVar directive, the function of
which is to disable compression support upon demand.
Fixed two minor typo errors in the docs, the names of two of the
PerlSetVar directives.
Added to the docs the fact that struct keys are now escaped. Also put
some coverage in the docs on the two ways of initializing a struct
object.
Applied a patch from Chris Darroch to allow better handling of
arguments in RPC::XML::Server::server_loop. While the HTTP::Daemon
portion was fine with collapsing the arg list into a hash, the
Net::Server portion actually has documented behavior when it sees the
same argument more than once, and collapsing to a hash caused these
extra arguments to be lost.
Eliminate a warning under 5.00503.
Changes to the opening of files for base64 data. The existing method
didn't work under 5.00503.
Added consideration to the filehandle-length tests for Win-ish offsets.
Added a forgotten binmode() call to an just-opened filehandle in the
base64-to-file support.
Really got the warning in RPC::XML::Server.pm this time. Really. Also
got some potential errors that seem to be overlooked under auto-loading
but appear when auto-loading is disabled.
Fixed a potentially-confusing problem in the example code within the
RPC::XML::Client man page, just under "SYNOPSIS".
More work to the spec.in RPM specfile template. The Provides/Requires
list should be a lot cleaner now, and it also builds packages under
rpm 4.1, now.
Fixed a lurking bug in the Apache::RPC::Server class that was not
setting the headers properly on responses. Probably lived this long
because no one else but me was using it, and my client is lax enough
to ignore it.
Removed an extraneous print line in t/11_base64_fh that caused a
warning on some systems.
Fixed calls to skip() in the test suites so that they work with
older versions of the Test module.
Calls to the encode_base64 routine from MIME::Base64 now pass a zero-
length second argument, to suppress newlines between Base64 lines
when stringifying the RPC::XML::base64 objects. This is to accomodate
a broken Java XML-RPC package.
Force a default value for the compress_re attribute in RPC::XML::Server
when none is otherwise present. All my tests have had Compress::Zlib
available, but when it isn't the compress_re attribute was triggering
warnings when used in a regex.
Changed the usage of =head3 directives in the manual page for
RPC::XML::Procedure to a =over/=back block instead. The =head3
directive requires a newer set of pod utilities, and would mean the
package had trouble building on 5.005 installations.
Extended the RPC::XML::base64 class to allow for and handle being
given a filehandle object instead of straight data. The object is
kept as an open filehandle, and the buffer position is always noted
and reset when operated on, so that other parts of the process using
the handle don't get surprised. Added tests in t/11_base64_fh.t to
exercise this.
Added a serialize() method to all the data classes in preparation for
changing the client and server modules to stream XML over the line
rather than print it using in-memory strings. Added test suite
t/15_serialize.t to exercise this.
Modified RPC::XML::Parser to accept arguments to new() that instruct
it to spool Base64 data to a filehandle, using the new capabilities
of the base64 class described previously. Added tests to t/20_parser.t
and support for the parameters to the constructors of the client and
base server classes. Documented all around.
Re-engineered the test for the "bytes" pragma in RPC::XML, so that
it now works with Perl 5.005.
Fixed the credentials() method in RPC::XML::Client.
All the internal use of object attributes in RPC::XML::Client now use
accessors instead of the hash keys directly, to make it easier to
sub-class the package. The same was done in RPC::XML::Server and to
some degree in Apache::RPC::Server. The server classes are more likely
to have problems, though.
The parsing of incoming data in the client and both server classes is
now done to a streaming XML parser, eliminating the need for the
full message to ever be in memory at once. Likewise, the client and
server classes have new attributes and accessor methods to allow
them to spool outgoing messages to files if the messages threaten to
be too large to keep in memory (this is best used when dealing with a
lot of Base64 data that is being dealt with directly on disk as well).
Applied a patch from Andrew Langmead to fix a bug in the uri() method
of RPC::XML::Client. Prior, retrieving the value could accidentally
reset it. Applied another fix from him to prevent a possible warning.
Applied another patch to better handle testing of the availability of
compression in the client.
Moving around some of the RPM spec-file generation caused problems
with some people trying to build the package if spec.in was missing.
Fixed this in Makefile.PL.
Fix to RPC::XML::Procedure per tip from Stig Porsgaard, to fix the
reading of 'signature' arguments to new() when providing all the
proc data directly. Reported by others as well, but Stig nailed it
down to a specific line.
Fixed a problem in the test-usage of the bytes pragma in RPC::XML,
reported by Marc Jauvin.
Closed a potential security hole in the parsing of external entities,
pointed out by Gregory Steuck.
Cleaned up the exports list in RPC::XML.pm, which still had remnants
from when this package was intended to extend XML-RPC. There were no
routines to match the symbols, but the potential for error was there.
Fixed a typo in the docs for RPC::XML::Client, and some documentation
goofs in RPC::XML::Server (regarding the timeout method/option). A
few doc fixes in RPC::XML::Procedure, for good measure.
Implemented two fixes sent in by Marc Liyanage: a fix for setting the
Content-Length headers on messages that takes the length in bytes
rather than characters; the second is a fix around the compression
support that makes certain an undef isn't evaluated against the
regex.
The above added an exported function to RPC::XML, so that got
documented. In the process, it occurred to me to document the helper
functions like RPC_BOOLEAN, RPC_DOUBLE, etc.
Changed methods/methodSignature.code, t/40_server.t and
t/60_net_server.t so that the provided system.methodSignature follows
the accepted API (returns a list of lists, rather than list of
strings). Pointed out by Bjoern Stierand.
Added a missing helper (RPC_I4) to RPC::XML.pm.
Fixed a bad bug with the newly-added compression support in
Apache::RPC::Server::handler. Because $self was defined earlier,
strict failed to point out that my object in that scope was called
$srv, rather than $self. And $self->compress didn't work, amazingly
enough. Found and reported by Scott Fagg.
Added a credentials() method to the RPC::XML::Client class to set
Basic Authentication credentials on the underlying LWP::UserAgent
object. Per suggestion and sample implementation from Stuart Clark.
Fixed a docs-nit in RPC::XML::Server, and did some major clean-up in
the docs for RPC::XML. In particular, added documentation for one
of the data class methods that had been overlooked ("type").
Changed the test in Apache::RPC::Server of the Content-type header so
that it accepts a header that contains "text/xml", as opposed to only
accepting a header that exactly equalled that string. Allows for
things like SOAP::Lite's XMLRPC::Lite which include a charset in the
header.
time2iso8601() in the RPC::XML module now allows defaulting of the
$time argument to time() (which means no timezone specification).
Found a bug in RPC::XML::Parser where base64 data being parsed in a
request/response message wasn't being properly passed to the c'tor
for RPC::XML::base64. Reported by Chris Brierley.
Added a line in Apache::RPC::Server to set the Content-Type header
on HEAD responses. Apache won't take this from the usual header()
method, it has to be explicitly set with content_type().
Two of the tests in t/40_server.t could cause fatal errors since a
return value wasn't tested for ref-ness before having a method called
on it. Fixed.
Compress::Zlib-based compression is now supported in RPC::XML::Server,
RPC::XML::Client and Apache::RPC::Server. It should be compatible with
the XMLRPC::Lite package's compression.
Wrapped the call to XML::Parser::parse (lib/RPC/XML/Parser.pm) in an
eval {} so that parse failures don't kill a server or client. Reported
by Kevin Greene.
An intended clone-operation in RPC::XML::response::new (lib/RPC/XML.pm)
was never actually written, which allowed for a corner case that could
result in new() return undef when it shouldn't. Related to the bug
reported by Sergey Scherbinin.
The RPC::XML::Procedure::call method (lib/RPC/XML/Procedure.pm) had one
error-check loop that was returning a full RPC::XML::response object,
instead of just a RPC::XML::fault. Reported by Sergey Scherbinin.
Fixed some grammar problems in error messages, and some formatting.
Fixed a bug in the new() method of Apache::RPC::Server where it was
expecting the value of the "apache" key to be an object of the
Apache::Server class, but it was actually getting an object of the
Apache class.
Created RPC::XML::Function class, which is a type of server-side
encapsulator that doesn't bother with signature tests of any kind.
The DTD and make_method tool support the new type.
Changed the encoding of the Perl code in etc/make_method as follows:
If the code does not already contain either of the two sequences,
']]>' or '__DATA__', then the code is wrapped in a
<![CDATA[ ]]> section, with #!/usr/bin/perl (actually,
$Config{startperl}) at the head and __DATA__ at the end. Besides
leaving the Perl code readable, the *.xpl files can now be
syntax-checked with "perl -cx". Thanks to the mod_perl guys for this
idea, cribbed from their manual page.
Abstracted some of the invocation code out of the server class and
into the RPC::XML::Procedure class, where it really belonged. This
aided in further eliminating redundancy in the server class in the
same general area. I may yet want to tune this area, but I'm a good
deal happier with the reduction in complexity and repetition.
Applied a patch to RPC::XML::Server from Tino Wuensche
(<tino_wuensche@yahoo.com>) that fixed some of the signal-handling
and exit-case-handling in server_loop().
Fixed a bug in RPC::XML::Procedure found by a user (a former
co-worker from my Denver days, coincidentally enough) that would
trigger when auto_methods was set to 1 on a server object, but the
request had no matching file anywhere in the search path.
The file util.pl in the t directory was accidentally omitted from the
0.35 release. This release is meant only to correct that oversight.
Fixed a small bug in make_method that would have caused a failure if
anyone used the command-line switches to specify data, rather than a
base-file (specifically, the handling of the --code argument). Also
clarified a few places in the man page.
Found bugs in both versions of the system.status server method (both
the basic and the Apache flavor). Both were neglecting to set the
"methods_known" value. Also found a bug in system.methodHelp. Amazing
what writing the regression tests can uncover.
RPC::XML::Method is now a skeleton file, slated to be removed by or
before 1.0. It has been renamed to RPC::XML::Procedure, and the
RPC::XML::Method class is declared as an empty subclass of the
RPC::XML::Procedure class. Procedures differ from methods in that they
do not get the server object instance as a first parameter in the list
that gets passed in.
Support for RPC::XML::Procedure (and general procedure vs. method)
added to the DTD and the make_method tool. All the routines in the
ex/ directory are declared as procedures, to further illustrate the
concept.
When code blocks for XPL files are eval'd, they are given a "package"
statement to force subsequent calls to be in the RPC::XML::Procedure
namespace, rather than defaulting to main (a potentially dangerous
assumption). The docs on routine-calling in RPC::XML::Server have been
updated to discuss this.
Many more tests added to the suite for RPC::XML::Server.
Created the test suite for RPC::XML::Client.
RPC::XML::Client no longer returns a full RPC::XML::response object
from any of its routines. Rather, simple_request still does what it
always has, and send_request now returns a data-type value. All the
data-type classes have a method called "is_fault" that returns false
for all except (of course) RPC::XML::fault. This lets callers of
send_request test the return value to see if it is a fault.
Added callback support for errors and faults to the RPC::XML::Client
class. This allows programmers to tie specific actions to cases where
a call returns a RPC::XML::fault object, or an outright error.
Created a separate test suite for RPC::XML::Server when used in
conjunction with the Net::Server package (it skips if the latter is
not installed on the system).
Almost all of the method-manipulation routines in RPC::XML::Server (all
but add_default_methods()) now have counterparts called by the same
name after s/method/proc/. This is purely for syntactical sugar and
symmetry. Except in the case of add_proc(), where it actually ensures
that a hash-reference calling convention is geared correctly to add a
RPC::XML::Procedure object rather than RPC::XML::Method.
first beta release
Apache::RPC::Server::list_servers no longer sorts the list before
returning it. No reason to assume it matters, or to levy that tax
against those who don't care.
RPC::XML::Server::url now constructs saner strings for HTTPS and for
HTTP on port 80.
The new() method in RPC::XML::Server wasn't quite handling the "host"
and "port" arguments that Apache::RPC::Server sent it correctly.
Added a patch to the RPC::XML::Server class from Christopher Blizzard
(blizzard@redhat.com) to allow control over the timeout interval that
HTTP::Daemon uses in answering new connections.
Replaced a GNU Make-centric dependancy rule for the XPL files with
a more portable .SUFFIXES-based one. This is unfortunate, as the %
syntax of GNU make is much cleaner. But GNU Make isn't universal. Yet.
This release marks the debut of Apache::RPC::Status, a monitor similar
in nature and design to Apache::Status, for running RPC servers under
Apache/mod_perl. See the manual page for details.
Documentation for Apache::RPC::Server was updated based on trials and
travails in trying to actually set up a configuration inside <Perl>
blocks. This isn't very clear in the mod_perl documentation, but at
least the docs for this module reflect exactly what I have configured
on my development box, so I know it works.
Added share_methods(), copy_methods() and delete_method() calls to the
RPC::XML::Server class (and thus to the Apache class as well). Had
already added an INSTALL_DIR method to retrieve the class-specific
installation dir to the Apache class, so mirrored it here, as well.
Added list_servers() static method to Apache::RPC::Server, to allow
for abstract retrieval of the ID-tags of the current known servers.
This is mainly so Apache::RPC::Status can use it in conjunction with
get_server() to examine the server objects for the sake of stats and
such.
Added list_methods() to RPC::XML::Server, to list the object's known
(published) methods by name. Mainly for use in the regression suites,
but worth documenting in the API in case someone else finds it
useful.
Four of the provided methods in the introspection API
(system.introspection, system.listMethods, system.methodHelp and
system.methodSignature) needed to be updated to use the newer API for
the XML::RPC::Method class when retrieving information from the server.
Started the test suites for RPC::XML::Method and RPC::XML::Server.
The tests that are delivered as part of this build are not fully
complete, but should be a reasonable start.
Found a subtle-but-nasty bug in the handling of RPC::XML::string
objects. Thanks to Dominic Mitchell <dom@semantico.com> for pointing
me in the right direction.
Started down the path of making the suite as a whole geared more
towards real use than illustrative example. The XML data-classes now
no longer use indention (or any superfluous whitespace) in their
stringification. This shortened the code quite a bit, and will also
mean shorter messages. This could not have been done cleanly without
the tests in t/10_data.t.
Extracted the method-manipulation code into a new class, called
RPC::XML::Method. This should make method-sharing easier, and pull
a lot of method-specific code out of RPC::XML::Server and
Apache::RPC::Server.
Clarified some issues in the new() constructor of the
Apache::RPC::Server class, and also changed the calling convention.
It no longer treats the first few arguments in any special way at all.
The arguments are all consistently taken as option/value pairs, just
as with RPC::XML::Server. The documentation reflects this. This may
break things built on the old style, but in the long run it should
prove much better.
Removed a -w warning from RPC/XML.pm. Fixed some cases in the new()
method of RPC::XML::boolean that would have permitted invalid data.
Added two convenience methods to RPC::XML::fault, called code() and
string(), that fetch the faultCode and faultString member values as
native Perl values. The RPC::XML::base64 class was using the wrong
container tags in the as_string method.
Clarified and expanded some of the documentation in RPC/XML/Server.pm.
Adjusted the PREREQ_PM hash in Makefile.PL so that it correctly looks
for LWP, and also looks for File::Spec 0.8 or newer (needed to ensure
that the splitpath() method is available).
Cleaned up the load-tests (t/00_load.t) to use the Test harnessing
package. Added test suites for the RPC::XML data classes (t/10_data.t,
96 tests) and the RPC::XML::Parser container-class (t/20_parser.t,
7 tests).
Fixed some doc errors in RPC::XML::Server. Mainly things I had
simplified, but not updated the docs to reflect.
Added a fair amount to the docs in Apache::RPC::Server. In particular,
a new section was added that illustrates using <Perl> configuration
sections to create the server objects in the master Apache process,
so that they are automatically inherited by children.
This is the initial release.
All files are tracked from this point forward.
RPC-XML-0.77/etc/ 000755 000765 000024 00000000000 12021176461 013576 5 ustar 00rjray staff 000000 000000 RPC-XML-0.77/ex/ 000755 000765 000024 00000000000 12021176461 013437 5 ustar 00rjray staff 000000 000000 RPC-XML-0.77/lib/ 000755 000765 000024 00000000000 12021176461 013571 5 ustar 00rjray staff 000000 000000 RPC-XML-0.77/Makefile.PL 000644 000765 000024 00000007347 12021173704 015005 0 ustar 00rjray staff 000000 000000 ###############################################################################
#
# This is the MakeMaker skeleton for the RPC-XML extension. Besides the usual
# tricks, this has to add rules to make the *.xpl files from *.code in the
# methods/ subdir, as well as get them into a place where they get installed
# correctly.
#
###############################################################################
use ExtUtils::MakeMaker;
use File::Spec;
use File::Find;
use Cwd 'cwd';
my ($vol, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0));
$dir = File::Spec->catpath($vol, $dir, '');
eval "require XML::LibXML;";
if ($@)
{
print STDERR <catfile(qw(etc make_method)));
$CLEAN .= File::Spec->catfile(qw(methods *.xpl));
@PM_FILES = ();
find(sub { push(@PM_FILES, $File::Find::name) if (-f $_ and /\.pm$/) }, 'lib');
# Exclude Apache2 stuff until it's ready for deployment
@PM_FILES = grep(! /Apache2/, @PM_FILES);
%PM_FILES = map { ($temp = $_) =~ s|^lib|\$\(INST_LIB\)|; $_ => $temp }
@PM_FILES;
# Handle the method code in "methods" specially:
find(sub {
if (-f $_ and /\.base$/)
{
s/\.base$//;
$PM_FILES{File::Spec->catfile('methods', "$_.xpl")} =
File::Spec->catfile('$(INST_LIB)', 'RPC', 'XML', "$_.xpl");
}
}, 'methods');
# Anything stuck under "lib" is more generic
find(sub {
if (-f $_ and /\.base$/)
{
$File::Find::name =~ s/base$/xpl/;
($tmp = $File::Find::name) =~ s|^lib|\$(INST_LIB)|;
$PM_FILES{$File::Find::name} = $tmp;
$CLEAN .= " $File::Find::name";
}
}, 'lib');
WriteMakefile(
NAME => 'RPC::XML',
VERSION => '0.77',
AUTHOR => 'Randy J. Ray',
ABSTRACT => 'Data, client and server classes for XML-RPC',
EXE_FILES => \@scripts,
PM => \%PM_FILES,
PREREQ_PM => {
'File::Spec' => 0.8,
'constant' => 1.03,
'Scalar::Util' => 1.19,
'Test::More' => 0.94,
'LWP' => 5.834,
'XML::Parser' => 2.31,
},
dist => { COMPRESS => 'gzip -9f' },
clean => { FILES => $CLEAN },
LICENSE => 'perl',
MIN_PERL_VERSION => 5.008008,
META_MERGE => {
recommends => {
'XML::LibXML' => '1.85',
'DateTime' => '0.70',
'DateTime::Format::ISO8601' => '0.07',
},
resources => {
homepage => 'http://search.cpan.org/dist/RPC-XML',
bugtracker =>
'http://rt.cpan.org/Public/Dist/Display.html?Name=RPC-XML',
repository => 'http://github.com/rjray/rpc-xml',
}
},
);
sub MY::post_initialize
{
my $self = shift;
my @text;
my $makemeth = File::Spec->catfile(qw(etc make_method));
push(@text,
'.SUFFIXES: .xpl .base',
'',
'.base.xpl:',
"\t\$(PERL) $makemeth --base=\$*",
'');
join("\n", @text);
}
sub MY::postamble
{
my $self = shift;
my @text;
my $makemeth = File::Spec->catfile(qw(etc make_method));
# Create the dependancy rules for the methods/XPL files
for (sort grep(/\.xpl$/, keys %::PM_FILES))
{
s/\.xpl$//;
push(@text, "$_.xpl: $_.base $_.help $_.code $makemeth");
}
join("\n", @text);
}
RPC-XML-0.77/MANIFEST 000644 000765 000024 00000006223 12021176462 014160 0 ustar 00rjray staff 000000 000000 ChangeLog # Ch-ch-ch-changes
ChangeLog.xml # See my swanky new XML format!
MANIFEST # This file
Makefile.PL # MakeMaker skeleton
README # Overview
README.apache2 # Notes on Apache2 and mod_perl2
etc/make_method # Tool to create *.xpl files
etc/rpc-method.dtd # DTD for the *.xpl file structure
ex/linux.proc.meminfo.base # Base/help/code files for the sample methods
ex/linux.proc.meminfo.code # in the ex/ directory
ex/linux.proc.meminfo.help
ex/linux.proc.cpuinfo.base
ex/linux.proc.cpuinfo.code
ex/linux.proc.cpuinfo.help
ex/README # Description of the contents of the ex/ dir
ex/Makefile # Makefile to generate *.xpl files in ex/
lib/Apache/RPC/Server.pm # Apache-centric server implementation
lib/Apache/RPC/Status.pm # Apache::Status for Apache::RPC::Server data
lib/Apache/RPC/status.base # Apache version of the system.status method
lib/Apache/RPC/status.code
lib/Apache/RPC/status.help
lib/RPC/XML.pm # Base data-type manipuation, etc.
lib/RPC/XML/Client.pm # Basic client class
lib/RPC/XML/Parser.pm # Parser base class
lib/RPC/XML/Parser/XMLParser.pm # Parser implementation class (XML::Parser)
lib/RPC/XML/Parser/XMLLibXML.pm # Parser implementation class (XML::LibXML)
lib/RPC/XML/ParserFactory.pm # Parser factory-class
lib/RPC/XML/Procedure.pm # Class encapsulation of RPC procedures
lib/RPC/XML/Server.pm # Basic server class
methods/identity.base # Everything under method/ is template for the
methods/identity.code # etc/make_method tool to create *.xpl files.
methods/identity.help
methods/introspection.base
methods/introspection.code
methods/introspection.help
methods/listMethods.base
methods/listMethods.code
methods/listMethods.help
methods/methodHelp.base
methods/methodHelp.code
methods/methodHelp.help
methods/methodSignature.base
methods/methodSignature.code
methods/methodSignature.help
methods/multicall.base
methods/multicall.code
methods/multicall.help
methods/status.base
methods/status.code
methods/status.help
t/00_load.t # Test suites
t/10_data.t
t/11_base64_fh.t
t/12_nil.t
t/13_no_deep_recursion.t
t/14_datetime_iso8601.t
t/15_serialize.t
t/20_xml_parser.t
t/21_xml_libxml.t
t/25_parser_negative.t
t/29_parserfactory.t
t/30_procedure.t
t/35_namespaces.t
t/40_server.t
t/40_server_xmllibxml.t
t/41_server_hang.t
t/50_client.t
t/51_client_with_host_header.t
t/60_net_server.t
t/70_compression_detect.t
t/90_rt50013_parser_bugs.t
t/90_rt54183_sigpipe.t
t/90_rt54494_blessed_refs.t
t/90_rt58065_allow_nil.t
t/90_rt58323_push_parser.t
t/BadParserClass.pm
t/meth_bad_1.xpl
t/meth_bad_2.xpl
t/meth_good_1.xpl
t/meth_good_2.xpl
t/meth_good_3.xpl
t/namespace1.xpl
t/namespace2.xpl
t/namespace3.xpl
t/svsm_text.b64
t/svsm_text.gif
t/util.pl
xt/01_pod.t
xt/02_pod_coverage.t
xt/03_meta.t
xt/04_minimumversion.t
xt/05_critic.t
META.yml Module YAML meta-data (added by MakeMaker)
META.json Module JSON meta-data (added by MakeMaker)
RPC-XML-0.77/META.json 000644 000765 000024 00000002734 12021176462 014453 0 ustar 00rjray staff 000000 000000 {
"abstract" : "Data, client and server classes for XML-RPC",
"author" : [
"Randy J. Ray"
],
"dynamic_config" : 1,
"generated_by" : "ExtUtils::MakeMaker version 6.62, CPAN::Meta::Converter version 2.120921",
"license" : [
"perl_5"
],
"meta-spec" : {
"url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
"version" : "2"
},
"name" : "RPC-XML",
"no_index" : {
"directory" : [
"t",
"inc"
]
},
"prereqs" : {
"build" : {
"requires" : {
"ExtUtils::MakeMaker" : "0"
}
},
"configure" : {
"requires" : {
"ExtUtils::MakeMaker" : "0"
}
},
"runtime" : {
"recommends" : {
"DateTime" : "0.70",
"DateTime::Format::ISO8601" : "0.07",
"XML::LibXML" : "1.85"
},
"requires" : {
"File::Spec" : "0.8",
"LWP" : "5.834",
"Scalar::Util" : "1.19",
"Test::More" : "0.94",
"XML::Parser" : "2.31",
"constant" : "1.03",
"perl" : "5.008008"
}
}
},
"release_status" : "stable",
"resources" : {
"bugtracker" : {
"web" : "http://rt.cpan.org/Public/Dist/Display.html?Name=RPC-XML"
},
"homepage" : "http://search.cpan.org/dist/RPC-XML",
"repository" : {
"url" : "http://github.com/rjray/rpc-xml"
}
},
"version" : "0.77"
}
RPC-XML-0.77/META.yml 000644 000765 000024 00000001516 12021176462 014300 0 ustar 00rjray staff 000000 000000 ---
abstract: 'Data, client and server classes for XML-RPC'
author:
- 'Randy J. Ray'
build_requires:
ExtUtils::MakeMaker: 0
configure_requires:
ExtUtils::MakeMaker: 0
dynamic_config: 1
generated_by: 'ExtUtils::MakeMaker version 6.62, CPAN::Meta::Converter version 2.120921'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: 1.4
name: RPC-XML
no_index:
directory:
- t
- inc
recommends:
DateTime: 0.70
DateTime::Format::ISO8601: 0.07
XML::LibXML: 1.85
requires:
File::Spec: 0.8
LWP: 5.834
Scalar::Util: 1.19
Test::More: 0.94
XML::Parser: 2.31
constant: 1.03
perl: 5.008008
resources:
bugtracker: http://rt.cpan.org/Public/Dist/Display.html?Name=RPC-XML
homepage: http://search.cpan.org/dist/RPC-XML
repository: http://github.com/rjray/rpc-xml
version: 0.77
RPC-XML-0.77/methods/ 000755 000765 000024 00000000000 12021176461 014466 5 ustar 00rjray staff 000000 000000 RPC-XML-0.77/README 000644 000765 000024 00000006520 12021176376 013713 0 ustar 00rjray staff 000000 000000 RPC::XML - An implementation of XML-RPC
Version: 0.77
WHAT IS IT
The RPC::XML package is an implementation of XML-RPC. The module provides
classes for sample client and server implementations, a server designed as an
Apache location-handler, and a suite of data-manipulation classes that are
used by them.
USING RPC::XML
There are not any pre-packaged executables in this distribution (except for a
utility tool). Client usage will usually be along the lines of:
use RPC::XML::Client;
...
my $client = new RPC::XML::Client
'http://www.oreillynet.com/meerkat/xml-rpc/server.php';
my $req = RPC::XML::request->new('meerkat.getChannelsBySubstring', 'perl');
my $res = $client->send_request($req);
# This returns an object of the RPC::XML::response class. This double-call
# of value() first gets a RPC::XML::* data object from the response, then
# the actual data from it:
my $value = $res->value->value;
Running a simple server is not much more involved:
use RPC::XML::Server;
...
my $srv = new RPC::XML::Server (host => 'localhost',
port => 9000);
# You would then use $srv->add_method to add some remotely-callable code
...
$srv->accept_loop; # Stays in an accept/connect loop
BUILDING/INSTALLING
This package is set up to configure and build like a typical Perl extension.
To build:
perl Makefile.PL
make && make test
If RPC::XML passes all tests, then:
make install
You may need super-user access to install.
PROBLEMS/BUG REPORTS
Please send any reports of problems or bugs to rjray@blackperl.com
SEE ALSO
XML-RPC: http://www.xmlrpc.com/spec
The Artistic 2.0: http://www.opensource.org/licenses/artistic-license-2.0.php
The LGPL 2.1: http://www.opensource.org/licenses/lgpl-2.1.php
CHANGES
* t/15_serialize.t
Fix a test failure on Windows.
* lib/RPC/XML.pm
RT #70408: Fix spelling error in man page, reported by Debian
group.
* t/90_rt54183_sigpipe.t
Fix to handle cases where server creation fails. Now skips the
tests rather than dying.
* lib/RPC/XML/Client.pm
RT #67486: Add port to Host header in client requests.
* lib/RPC/XML/Server.pm
RT #65341: Added "use" of forgotten library File::Temp. This
was causing failure when "message_file_thresh" kicked in.
* t/10_data.t
RT #78602: Changed 64-bit test from use64bitint to longsize. On
some systems (such as OS X), use64bitint can be true even when
in 32-bit mode.
* t/21_xml_libxml.t
Fix from Christian Walde, skip passed test on Windows.
* lib/RPC/XML/Server.pm
* t/40_server.t
Checkpoint refactoring and additional tests. Work is not
complete here, but the Net::Server changes demand immediate
attention
* t/20_xml_parser.t
RT #72780: Check for a possible parser failure. One instance of
XML::Parser failing to parse the extern entities test. Cannot
reproduce, so wrap it in a "skip" block for now.
* lib/RPC/XML/Procedure.pm
* t/30_method.t
RT #71452: Correct handling of dateTime parameters. Existing
code in lib/RPC/XML/Procedure.pm did not properly handle
parameters of the dateTime.iso8601 type. Also, there were no
tests for these.
* MANIFEST
* t/30_method.t (deleted)
* t/30_proceudre.t (added)
Renamed t/30_method.t to t/30_procedure.t.
* lib/RPC/XML/Server.pm
RT #77992: Make RPC::XML::Server work with Net::Server again,
after the API changes of Net::Server 2.x.
RPC-XML-0.77/README.apache2 000644 000765 000024 00000001020 11612471030 015171 0 ustar 00rjray staff 000000 000000 Note:
At present, this package does not work with Apache2 and the soon-to-be
mod_perl2. The changes to the API for location handlers are too drastic to
try and support both within the same class (I tried, using the compatibility
layer). Also, mp2 does not currently provide support for sections, which
are the real strength of the Apache::RPC::Server class.
As time permits, and the Apache2/mod_perl2 API develops, I intend to have
versions of both Apache::RPC::Server and Apache::RPC::Status for that platform.
Randy
RPC-XML-0.77/t/ 000755 000765 000024 00000000000 12021176461 013266 5 ustar 00rjray staff 000000 000000 RPC-XML-0.77/xt/ 000755 000765 000024 00000000000 12021176461 013456 5 ustar 00rjray staff 000000 000000 RPC-XML-0.77/xt/01_pod.t 000644 000765 000024 00000000313 11621321116 014714 0 ustar 00rjray staff 000000 000000 #!/usr/bin/perl
# Test that the syntax of our POD documentation is valid
use strict;
BEGIN {
$| = 1;
$^W = 1;
}
use Test::More;
use Pod::Simple 3.07;
use Test::Pod 1.26;
all_pod_files_ok();
exit;
RPC-XML-0.77/xt/02_pod_coverage.t 000644 000765 000024 00000002667 11621415153 016613 0 ustar 00rjray staff 000000 000000 #!/usr/bin/perl
use Test::More;
use Test::Pod::Coverage;
plan tests => 10;
pod_coverage_ok('Apache::RPC::Server' => { also_private => [ 'debug' ] } =>
'Apache::RPC::Server');
pod_coverage_ok('Apache::RPC::Status' => 'Apache::RPC::Status');
pod_coverage_ok('RPC::XML' =>
{ also_private => [ qr/^RPC_/ ] },
'RPC::XML');
pod_coverage_ok('RPC::XML::Client' => { also_private => [ qr/^compress/ ] } =>
'RPC::XML::Client');
pod_coverage_ok('RPC::XML::ParserFactory' => 'RPC::XML::ParserFactory');
pod_coverage_ok('RPC::XML::Parser' => 'RPC::XML::Parser');
pod_coverage_ok('RPC::XML::Parser::XMLParser' =>
{ also_private =>
[ qr/^(tag|message)_/,
qw(char_data error extern_ent final stack_error) ] } =>
'RPC::XML::Parser::XMLParser');
pod_coverage_ok('RPC::XML::Parser::XMLLibXML' =>
{ also_private => [ qr/^dom_/ ] } =>
'RPC::XML::Parser::XMLLibXML');
pod_coverage_ok('RPC::XML::Procedure' =>
{ also_private => [ qw(load_xpl_file make_sig_table) ] } =>
'RPC::XML::Procedure');
pod_coverage_ok('RPC::XML::Server' =>
{ also_private => [ qw(compress_re call method_from_file
post_configure_hook pre_loop_hook
process_request) ] } =>
'RPC::XML::Server');
exit;
RPC-XML-0.77/xt/03_meta.t 000644 000765 000024 00000000372 11621321147 015073 0 ustar 00rjray staff 000000 000000 #!/usr/bin/perl
# Test that our META.yml file matches the specification
use strict;
BEGIN {
$| = 1;
$^W = 1;
}
use Test::CPAN::Meta 0.12;
use Test::More;
plan skip_all => "No META.yml file found" unless (-f 'META.yml');
meta_yaml_ok();
exit;
RPC-XML-0.77/xt/04_minimumversion.t 000644 000765 000024 00000000373 11621321165 017230 0 ustar 00rjray staff 000000 000000 #!/usr/bin/perl
# Test that our declared minimum Perl version matches our syntax
use strict;
BEGIN {
$| = 1;
$^W = 1;
}
use Perl::MinimumVersion 1.20;
use Test::MinimumVersion 0.008;
use Test::More;
all_minimum_version_from_metayml_ok();
exit;
RPC-XML-0.77/xt/05_critic.t 000644 000765 000024 00000000303 11621321177 015421 0 ustar 00rjray staff 000000 000000 #!/usr/bin/perl
# Test that the module passes perlcritic
use strict;
BEGIN {
$| = 1;
$^W = 1;
}
use Perl::Critic 1.098;
use Test::Perl::Critic 1.01;
use Test::More;
all_critic_ok();
exit;
RPC-XML-0.77/t/00_load.t 000644 000765 000024 00000002305 11622334117 014671 0 ustar 00rjray staff 000000 000000 #!/usr/bin/perl
use strict;
use vars qw(@MODULES @APACHE_MODULES $do_apache $do_libxml);
use Test::More;
# Verify that the individual modules will load
BEGIN
{
@MODULES = qw(
RPC::XML
RPC::XML::Client
RPC::XML::Parser
RPC::XML::Parser::XMLLibXML
RPC::XML::Parser::XMLParser
RPC::XML::ParserFactory
RPC::XML::Procedure
RPC::XML::Server
);
@APACHE_MODULES = qw(Apache::RPC::Server Apache::RPC::Status);
# If mod_perl is not available, Apache::RPC::Server cannot be blamed
eval "use Apache";
$do_apache = $@ ? 0 : 1;
# If XML::LibXML is not installed, also skip RPC::XML::Parser::XMLLibXML
eval "use XML::LibXML";
$do_libxml = $@ ? 0 : 1;
plan tests => (scalar(@MODULES) + scalar(@APACHE_MODULES));
}
# Core modules
for my $module (@MODULES)
{
SKIP: {
skip 'XML::LibXML not installed', 1
if (($module eq 'RPC::XML::Parser::XMLLibXML') &&
(! $do_libxml));
use_ok($module);
}
}
# Test these only if Apache (v1) is available
SKIP: {
skip "No mod_perl 1.X detected", scalar(@APACHE_MODULES) unless $do_apache;
use_ok($_) for (@APACHE_MODULES);
}
exit 0;
RPC-XML-0.77/t/10_data.t 000644 000765 000024 00000052057 12005333013 014663 0 ustar 00rjray staff 000000 000000 #!/usr/bin/perl
# Test the data-manipulation routines in RPC::XML
use strict;
use vars qw($val $str $fh $obj $class %val_tbl @values $datetime_avail);
use Config;
use Test::More tests => 252;
use File::Spec;
use RPC::XML ':all';
BEGIN
{
eval "use DateTime";
$datetime_avail = $@ ? 0 : 1;
}
# First, make sure we can't instantiate any of "abstract" classes directly,
# and also make sure that certain base-class methods properly return when
# (wrongly) called as static methods:
$obj = RPC::XML::simple_type->new('foo');
ok(! ref $obj, 'Attempt to directly construct simple_type failed');
like($RPC::XML::ERROR, qr/Cannot instantiate/, 'Correct error message');
$val = RPC::XML::simple_type->value;
ok(! defined $val, 'Static call to RPC::XML::simple_type::value fails');
like($RPC::XML::ERROR, qr/static method/, 'Correct error message');
ok(! RPC::XML::simple_type->as_string(),
'Static call to RPC::XML::simple_type::as_string fails');
like($RPC::XML::ERROR, qr/static method/, 'Correct error message');
# RPC::XML::double and RPC::XML::string have their own as_string methods
ok(! RPC::XML::double->as_string(),
'Static call to RPC::XML::simple_type::as_string fails');
like($RPC::XML::ERROR, qr/static method/, 'Correct error message');
ok(! RPC::XML::string->as_string(),
'Static call to RPC::XML::simple_type::as_string fails');
like($RPC::XML::ERROR, qr/static method/, 'Correct error message');
# Try instantiating a non-scalar reference
$obj = RPC::XML::int->new([]);
ok(! ref $obj, 'Attempt to instantiate from non-scalar ref failed');
like($RPC::XML::ERROR, qr/not derived from scalar/, 'Correct error message');
# Next, the most basic data-types
%val_tbl = (
'int' => int(rand 10000) + 1,
i4 => int(rand 10000) + 1,
i8 => 2**32,
double => 0.5,
string => __FILE__
);
for (sort keys %val_tbl)
{
$val = $val_tbl{$_};
$class = "RPC::XML::$_";
$obj = $class->new($val);
isa_ok($obj, $class, "Basic data-type $_");
is($obj->value, $val, "Basic data-type $_, value check");
is($obj->as_string, "<$_>$val",
"Basic data-type $_, XML serialization");
is($obj->type, $_, "Basic data-type $_, type identification");
is(length($obj->as_string), $obj->length,
"Basic data-type $_, length() method test");
}
# Go again, with each of the values being a blessed scalar reference
my @vals = (1, -1, 2**32, 0.5, __FILE__);
%val_tbl = (
'int' => bless(\(shift(@vals)), "Tmp::Scalar::Int"),
i4 => bless(\(shift(@vals)), "Tmp::Scalar::I4"),
i8 => bless(\(shift(@vals)), "Tmp::Scalar::I8"),
double => bless(\(shift(@vals)), "Tmp::Scalar::Double"),
string => bless(\(shift(@vals)), "Tmp::Scalar::String")
);
for (sort keys %val_tbl)
{
$val = $val_tbl{$_};
$class = "RPC::XML::$_";
$obj = $class->new($val);
isa_ok($obj, $class, "Data objects from blessed scalar refs, type $_");
is($obj->value, $$val,
"Data objects from blessed scalar refs, type $_, value check");
is($obj->as_string, "<$_>${$val}",
"Data objects from blessed scalar refs, type $_, XML serialization");
is($obj->type, $_,
"Data objects from blessed scalar refs, type $_, type identification");
is(length($obj->as_string), $obj->length,
"Data objects from blessed scalar refs, type $_, length() method test");
}
# A few extra tests for RPC::XML::double to make sure the stringification
# doesn't lead to wonky values:
$obj = RPC::XML::double->new(10.0);
is($obj->as_string, '10.0',
'RPC::XML::double stringification [1]');
$obj = RPC::XML::double->new(0.50);
is($obj->as_string, '0.5',
'RPC::XML::double stringification [2]');
# Another little test for RPC::XML::string, to check encoding
$val = 'Subroutine &bogus not defined at <_> line -NaN';
$obj = RPC::XML::string->new($val);
is($obj->value, $val, "RPC::XML::string extra tests, value check");
is($obj->as_string,
"Subroutine &bogus not defined at <_> line -NaN",
"RPC::XML::string extra tests, XML serialization");
# Test for correct handling of encoding a 0 (false but defined)
$val = 0;
$obj = RPC::XML::string->new($val);
is($obj->as_string, "0", "RPC::XML::string, encoding '0'");
# Type boolean is a little funky
# Each of these should be OK
for (qw(0 1 yes no tRuE FaLsE))
{
$val = (/0|no|false/i) ? 0 : 1;
$obj = RPC::XML::boolean->new($_);
isa_ok($obj, 'RPC::XML::boolean', '$obj($_)');
is($obj->value, $val, "RPC::XML::boolean($_), value check");
is($obj->as_string, "$val",
"RPC::XML::boolean($_), XML serialization");
is($obj->type, 'boolean', "RPC::XML::boolean($_), type identification");
}
# This should not
$obj = RPC::XML::boolean->new('of course!');
ok(! ref $obj, 'RPC::XML::boolean, bad value did not yield referent');
like($RPC::XML::ERROR, qr/::new: Value must be one of/,
'RPC::XML::boolean, bad value correctly set $RPC::XML::ERROR');
# The dateTime.iso8601 type
$val = time2iso8601(time);
$obj = RPC::XML::datetime_iso8601->new($val);
isa_ok($obj, 'RPC::XML::datetime_iso8601', '$obj');
is($obj->type, 'dateTime.iso8601',
'RPC::XML::datetime_iso8601, type identification');
is(length($obj->as_string), $obj->length,
'RPC::XML::datetime_iso8601, length() method test');
is($obj->value, $val, 'RPC::XML::datetime_iso8601, value() method test');
$obj = RPC::XML::datetime_iso8601->new(\$val);
isa_ok($obj, 'RPC::XML::datetime_iso8601', '$obj');
is($obj->type, 'dateTime.iso8601',
'RPC::XML::datetime_iso8601, type identification (ref)');
is(length($obj->as_string), $obj->length,
'RPC::XML::datetime_iso8601, length() method test (ref)');
is($obj->value, $val, 'RPC::XML::datetime_iso8601, value() method test (ref)');
# Add a fractional part and try again
chop $val; # Lose the 'Z'
$val .= '.125Z';
$obj = RPC::XML::datetime_iso8601->new($val);
isa_ok($obj, 'RPC::XML::datetime_iso8601', '$obj');
is($obj->type, 'dateTime.iso8601',
"RPC::XML::datetime_iso8601, type identification");
is(length($obj->as_string), $obj->length,
"RPC::XML::datetime_iso8601, length() method test");
is($obj->value, $val, 'RPC::XML::datetime_iso8601, value() method test');
# Test bad date-data
$obj = RPC::XML::datetime_iso8601->new();
ok(! ref $obj,
'RPC::XML::datetime_iso8601, empty value did not yield referent');
like($RPC::XML::ERROR, qr/::new: Value required/,
'RPC::XML::datetime_iso8601, empty value correctly set $RPC::XML::ERROR');
$obj = RPC::XML::datetime_iso8601->new('not a date');
ok(! ref $obj,
'RPC::XML::datetime_iso8601, bad value did not yield referent');
like($RPC::XML::ERROR, qr/::new: Malformed data/,
'RPC::XML::datetime_iso8601, empty value correctly set $RPC::XML::ERROR');
# Test the slightly different date format
$obj = RPC::XML::datetime_iso8601->new('2008-09-29T12:00:00-07:00');
isa_ok($obj, 'RPC::XML::datetime_iso8601', '$obj');
is($obj->type, 'dateTime.iso8601',
"RPC::XML::datetime_iso8601, type identification");
is($obj->value, '20080929T12:00:00-07:00',
'RPC::XML::datetime_iso8601, value() method test');
# Test interoperability with the DateTime package, if it is available
SKIP: {
skip 'Module DateTime not available', 4
if (! $datetime_avail);
my $dt = DateTime->now();
(my $dt_str = "$dt") =~ s/-//g;
$obj = RPC::XML::datetime_iso8601->new("$dt");
isa_ok($obj, 'RPC::XML::datetime_iso8601', '$obj');
is($obj->value, $dt_str, 'RPC::XML::datetime_iso8601, from DateTime');
$obj = smart_encode($dt);
isa_ok($obj, 'RPC::XML::datetime_iso8601', '$obj');
is($obj->value, $dt_str,
'RPC::XML::datetime_iso8601, from DateTime via smart_encode');
}
# Test the base64 type
require MIME::Base64;
$str = 'one reasonable-length string';
$val = MIME::Base64::encode_base64($str, '');
$obj = RPC::XML::base64->new($str);
isa_ok($obj, 'RPC::XML::base64', '$obj');
is($obj->as_string, "$val",
'RPC::XML::base64, XML serialization');
is($obj->value, $str, 'RPC::XML::base64, correct value()');
is(length($obj->as_string), $obj->length,
"RPC::XML::base64, length() method test");
# Test pre-encoded data
$obj = RPC::XML::base64->new($val, 'pre-encoded');
isa_ok($obj, 'RPC::XML::base64', '$obj (pre-encoded)');
is($obj->value, $str, 'RPC::XML::base64(pre-encoded), value check');
# Test passing in a reference
$obj = RPC::XML::base64->new(\$str);
isa_ok($obj, 'RPC::XML::base64', '$obj');
is($obj->value, $str, 'RPC::XML::base64, correct value()');
# Test a null Base64 object
$obj = RPC::XML::base64->new();
isa_ok($obj, 'RPC::XML::base64', '$obj');
is($obj->value, '', 'Zero-length base64 object value OK');
is($obj->as_string, '',
'Zero-length base64 object stringifies OK');
# Now we throw some junk at smart_encode()
@values = smart_encode(
__FILE__, # [0] string
10, # [1] int
3.14159, # [2] double
'2112', # [3] int
RPC::XML::string->new('2112'), # [4] string
[], # [5] array
{}, # [6] struct
\ "foo", # [7] string
\2, # [8] int
\1.414, # [9] double
2_147_483_647, # [10] int
-2_147_483_648, # [11] int
9_223_372_036_854_775_807, # [12] i8
-9_223_372_036_854_775_808, # [13] i8
4_294_967_295, # [14] i8
'2009-09-03T10:25:00', # [15] dateTime.iso8601
'20090903T10:25:00Z', # [16] dateTime.iso8601
'2009-09-03T10:25:00.125' # [17] dateTime.iso8601
);
is($values[0]->type, 'string', "smart_encode, string<1>");
is($values[1]->type, 'int', "smart_encode, int<1>");
is($values[2]->type, 'double', "smart_encode, double<1>");
# Should have been encoded int regardless of ''
is($values[3]->type, 'int', "smart_encode, int<2>");
# Was given an object explicitly
is($values[4]->type, 'string', "smart_encode, string<2>");
is($values[5]->type, 'array', "smart_encode, array");
is($values[6]->type, 'struct', "smart_encode, struct");
is($values[7]->type, 'string', "smart_encode, string<3>");
is($values[8]->type, 'int', "smart_encode, int<3>");
is($values[9]->type, 'double', "smart_encode, double<2>");
is($values[10]->type, 'int', 'smart_encode, int<4>');
is($values[11]->type, 'int', 'smart_encode, int<5>');
SKIP: {
skip '64-bit architecture required to test these I8 values', 2
if ($Config{longsize} != 8);
is($values[12]->type, 'i8', 'smart_encode, i8<1>');
is($values[13]->type, 'i8', 'smart_encode, i8<2>');
}
is($values[14]->type, 'i8', 'smart_encode, i8<3>');
is($values[15]->type, 'dateTime.iso8601', 'smart_encode, dateTime.iso8601');
is($values[16]->type, 'dateTime.iso8601', 'smart_encode, dateTime.iso8601<2>');
is($values[17]->type, 'dateTime.iso8601', 'smart_encode, dateTime.iso8601<3>');
# Without $RPC::XML::ALLOW_NIL set, smart_encode should encode this as a null
# string:
$obj = smart_encode(undef);
is($obj->type, 'string', 'smart_encode undef->string type');
is($obj->value, '', 'smart_encode undef->string value');
# Check that smart_encode gives up on un-convertable references
{
my $badvalue;
eval { $badvalue = smart_encode(\*STDIN); };
ok(! ref($badvalue),
"smart_encode, bad reference argument did not yield referent");
like($@, qr/Un-convertable reference/,
"smart_encode, bad reference argument set \$@ as expected");
}
# Arrays
$obj = RPC::XML::array->new(1 .. 10);
isa_ok($obj, 'RPC::XML::array', '$obj');
is($obj->type, 'array', "RPC::XML::array, type identification");
@values = @{ $obj->value };
is(scalar(@values), 10, "RPC::XML::array, array size test");
@values = @{ $obj->value(1) };
ok(ref($values[0]) && ($values[0]->type eq 'int'),
'RPC::XML::array, array content is RPC::XML::* referent');
like($obj->as_string, qr|.*(\d+.*){10}.*|sm,
'RPC::XML::array, XML serialization');
is(length($obj->as_string), $obj->length,
'RPC::XML::array, length() method test');
# Blessed array references
my $arrayobj = bless [ 1 .. 10 ], "Tmp::Array$$";
$obj = RPC::XML::array->new(from => $arrayobj);
isa_ok($obj, 'RPC::XML::array', '$obj from blessed arrayref');
is($obj->type, 'array',
'RPC::XML::array from blessed arrayref, type identification');
@values = @{ $obj->value };
is(scalar(@values), 10,
'RPC::XML::array from blessed arrayref, array size test');
@values = @{ $obj->value(1) };
ok(ref($values[0]) && ($values[0]->type eq 'int'),
'RPC::XML::array from blessed arrayref, array content is referent');
like($obj->as_string, qr|.*(\d+.*){10}.*|sm,
'RPC::XML::array from blessed arrayref, XML serialization');
is(length($obj->as_string), $obj->length,
'RPC::XML::array from blessed arrayref, length() method test');
undef $arrayobj;
# Structs
$obj = RPC::XML::struct->new(key1 => 1, key2 => 2);
isa_ok($obj, 'RPC::XML::struct', '$obj');
is($obj->type, 'struct', 'RPC::XML::struct, type identification');
$val = $obj->value;
is(ref($val), 'HASH', 'RPC::XML::struct, ref-type of value()');
is(scalar(keys %$val), 2, 'RPC::XML::struct, correct number of keys');
is($val->{key1}, 1, q(RPC::XML::struct, 'key1' value test));
$val = $obj->value(1);
ok(ref($val->{key1}) && ($val->{key1}->type eq 'int'),
'RPC::XML::struct, key-value is referent in shallow conversion');
$val->{key1} = RPC::XML::string->new('hello');
$obj = RPC::XML::struct->new($val);
isa_ok($obj, 'RPC::XML::struct', '$obj(object-values)');
is(($obj->value)->{key1}, 'hello',
q{RPC::XML::struct(object-values), 'key1' value test});
is(($obj->value(1))->{key1}->type, 'string',
'RPC::XML::struct(object-values), value-object type correctness');
like($obj->as_string, qr|.*(.*
.*.*
.*.*
.*){2}.*|smx,
'RPC::XML::struct, XML serialization');
is(length($obj->as_string), $obj->length,
"RPC::XML::struct, length() method test");
# Test handling of keys that contain XML special characters
$obj = RPC::XML::struct->new('>' => these =>
'<' => are =>
'&' => special =>
'<>' => XML =>
'&&' => 'characters');
isa_ok($obj, 'RPC::XML::struct', '$obj(with XML special char keys)');
is((my $tmp = $obj->as_string) =~ tr/&/&/, 7,
'RPC::XML::struct, XML-encoding of serialized form with char entities');
# Blessed struct reference
my $structobj = bless { key1 => 1, key2 => 2 }, "Tmp::Struct$$";
$obj = RPC::XML::struct->new($structobj);
isa_ok($obj, 'RPC::XML::struct', '$obj(struct<1>)');
is($obj->type, 'struct', 'struct object type method');
$val = $obj->value;
isa_ok($val, 'HASH', 'struct $obj->value');
is(scalar(keys %$val), 2, 'struct obj number of keys test');
is($val->{key1}, 1, 'struct obj "key1" test');
$val = $obj->value(1);
isa_ok($val->{key1}, 'RPC::XML::int', '$val->{key1} (shallow eval)');
$val->{key1} = RPC::XML::string->new('hello');
$obj = RPC::XML::struct->new($val);
isa_ok($obj, 'RPC::XML::struct', '$obj(struct<2>)');
is(($obj->value)->{key1}, 'hello', 'struct<2> "key1" test');
is(($obj->value(1))->{key1}->type, 'string', 'struct<2> "key1" type test');
like($obj->as_string, qr|.*(.*
.*.*
.*.*
.*){2}.*|smx,
'struct<2> XML serialization');
is(length($obj->as_string), $obj->length, 'struct<2> length() check');
# No need to re-test the XML character handling
# Faults are a subclass of structs
$obj = RPC::XML::fault->new(faultCode => 1, faultString => 'test');
isa_ok($obj, 'RPC::XML::fault', '$obj (fault)');
# Since it's a subclass, I won't waste cycles testing the similar methods
$obj = RPC::XML::fault->new(faultCode => 1);
ok(! ref $obj, 'fault class constructor fails on missing key(s)');
like($RPC::XML::ERROR, qr/:new: Missing required struct fields/,
'fault class failure set error string');
$obj = RPC::XML::fault->new(faultCode => 1, faultString => 'test',
faultFail => 'extras are not allowed');
ok(! ref($obj), 'fault class rejects extra args');
like($RPC::XML::ERROR, qr/:new: Extra struct/,
'fault class failure set error string');
$obj = RPC::XML::fault->new(1, 'test');
isa_ok($obj, 'RPC::XML::fault', '$obj<2> (fault)');
is($obj->code, 1, 'fault code() method');
is($obj->string, 'test', 'fault string() method');
like($obj->as_string, qr|.*
.*
.*
(.*
.*.*
.*.*
.*){2}.*
.*
.*
|smx,
'fault XML serialization');
is(length($obj->as_string), $obj->length, 'fault length() check');
# Requests
$obj = RPC::XML::request->new('test.method');
isa_ok($obj, 'RPC::XML::request', '$obj (request)');
is($obj->name, 'test.method', 'request name method');
ok($obj->args && (@{ $obj->args } == 0), 'request args method');
$obj = RPC::XML::request->new();
ok(! ref($obj), 'bad request contructor failed');
like($RPC::XML::ERROR, qr/:new: At least a method name/,
'bad request constructor set error string');
$obj = RPC::XML::request->new('#*'); # Bad method name, should fail
ok(! ref($obj), 'Bad method name in constructor failed');
like($RPC::XML::ERROR, qr/Invalid method name/,
'Bad method name in constructor set error string');
$obj = RPC::XML::request->new('test.method', (1 .. 10));
ok($obj->args && (@{ $obj->args } == 10), 'request args method size test');
# The new() method uses smart_encode on the args, which has already been
# tested. These are just to ensure that it *does* in fact call it
is($obj->args->[0]->type, 'int', 'request args elt[0] type test');
is($obj->args->[9]->value, 10, 'request args elt[9] value test');
like($obj->as_string, qr|<\?xml.*
.*
.*.*
.*
(.*.*){10}.*
.*
|smx,
'request XML serialization');
is(length($obj->as_string), $obj->length, 'request length() test');
# Responses
$obj = RPC::XML::response->new('ok');
isa_ok($obj, 'RPC::XML::response', '$obj (response)');
is($obj->value->type, 'string', 'response value->type test');
is($obj->value->value, 'ok', 'response value->value test');
ok(! $obj->is_fault, 'response object not fault');
like($obj->as_string, qr|<\?xml.*
.*
.*
.*.*
.*
|smx,
'response XML serialization');
is(length($obj->as_string), $obj->length, 'response length() test');
$obj = RPC::XML::response->new();
ok(! ref($obj), 'bad response constructor failed');
like($RPC::XML::ERROR, qr/:new: One of a datatype, value or a fault/,
'bad response constructor set error string');
$obj = RPC::XML::response->new(qw(one two));
ok(! ref($obj), 'bad response constructor failed');
like($RPC::XML::ERROR, qr/only one argument/,
'bad response constructor set error string');
$obj = RPC::XML::response->new(RPC::XML::fault->new(1, 'test'));
isa_ok($obj, 'RPC::XML::response', '$obj (response/fault)');
# The other methods have already been tested
ok($obj->is_fault, 'fault response creation is_fault test');
### test for bug where encoding was done too freely, encoding
### any ^\d+$ as int, etc
{
my %map = (
256 => 'int',
256**4+1 => 'i8', # will do *-1 as well
256**8+1 => 'double',
1e37+1 => 'string',
);
while (my($val,$type) = each %map)
{
for my $mod (1,-1)
{
{
my $obj = smart_encode($mod * $val);
ok($obj, "smart_encode zealousness test, $mod * $val");
is($obj->type, $type,
'smart_encode zealousness, non-forced type');
}
### test force string encoding
{
### double assign to silence -w
local $RPC::XML::FORCE_STRING_ENCODING = 1;
local $RPC::XML::FORCE_STRING_ENCODING = 1;
my $obj = smart_encode($mod * $val);
ok($obj, "smart_encode zealousness test, $mod * $val (force)");
is($obj->type, 'string',
'smart_encode zealousness, forced to string');
}
}
}
}
# Test for RT# 31818, ensure that very small double values are expressed in
# a format that conforms to the XML-RPC spec.
is(RPC::XML::double->new(0.000005)->as_string, '0.000005',
'Floating-point format test, RT31818');
exit 0;
RPC-XML-0.77/t/11_base64_fh.t 000644 000765 000024 00000016136 11622773312 015530 0 ustar 00rjray staff 000000 000000 #!/usr/bin/perl
# Test the usage of RPC::XML::base64 with filehandles
use strict;
use vars qw($dir $vol $file $b64file $tmpfile $value $enc_value $obj $fh $pos
$md5_able $md5 $size $ofh);
# This is what we're testing
use RPC::XML;
use Test::More tests => 35;
use File::Spec;
use IO::File;
use MIME::Base64;
($vol, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0));
$dir = File::Spec->catpath($vol, $dir, '');
$file = File::Spec->catfile($dir, 'svsm_text.gif');
$b64file = File::Spec->catfile($dir, 'svsm_text.b64');
$tmpfile = File::Spec->catfile($dir, "__tmp__${$}__");
BEGIN
{
eval "use Digest::MD5";
$md5_able = $@ ? 0 : 1;
}
END
{
if (-f $tmpfile)
{
unlink $tmpfile;
}
}
$value = 'Short string for easy tests';
$enc_value = encode_base64($value, '');
if (! (open $fh, '+>', $tmpfile))
{
die "Error opening $tmpfile: $!";
}
select($fh); $| = 1; select STDOUT;
print {$fh} $value;
$pos = tell $fh;
# We now have a ready-to-use FH, and we know the seek-pos on it
$obj = RPC::XML::base64->new($fh);
isa_ok($obj, 'RPC::XML::base64', '$obj');
is(tell $fh, $pos, 'object construction leaves pos() unchanged');
is($obj->value(), $value, 'object value is correct');
is(tell $fh, $pos, 'call to value() leaves pos() unchanged');
is($obj->as_string(), "$enc_value",
'object stringification is correct');
is(tell $fh, $pos, 'call to as_string leaves pos() unchanged');
# Done with this for now
close $fh;
unlink $tmpfile;
# Same tests, but init the FH with the encoded data rather than the cleartext
if (! (open $fh, '+>', $tmpfile))
{
die "Error opening $tmpfile: $!";
}
select($fh); $| = 1; select STDOUT;
print $fh $enc_value;
$pos = tell $fh;
# We now have a ready-to-use FH, and we know the seek-pos on it
$obj = RPC::XML::base64->new($fh, 'encoded');
isa_ok($obj, 'RPC::XML::base64', '$obj(encoded)');
is(tell $fh, $pos, 'object(encoded) construction leaves pos() unchanged');
is($obj->value(), $value, 'object(encoded) value is correct');
is(tell $fh, $pos, 'call to value() leaves pos() unchanged');
is($obj->as_string(), "$enc_value",
'object(encoded) stringification is correct');
is(tell $fh, $pos, 'call to as_string leaves pos() unchanged');
# Done with this for now
close $fh;
unlink $tmpfile;
# Test old-style glob filehandles
local *F;
if (! (open F, '+>', $tmpfile))
{
die "Error opening $tmpfile: $!";
}
select(F); $| = 1; select STDOUT;
print F $enc_value;
$pos = tell F;
# We now have a ready-to-use FH, and we know the seek-pos on it
$obj = RPC::XML::base64->new(\*F, 'encoded');
isa_ok($obj, 'RPC::XML::base64', '$obj(glob)');
is(tell F, $pos, 'object(glob) construction leaves pos() unchanged');
is($obj->value(), $value, 'object(glob) value is correct');
is(tell F, $pos, 'call to value() leaves pos() unchanged');
is($obj->as_string(), "$enc_value",
'object(glob) stringification is correct');
is(tell F, $pos, 'call to as_string leaves pos() unchanged');
# Done with this for now
close F;
unlink $tmpfile;
# Test with a larger file
if (! (open $fh, '<', $file))
{
die "Error opening $file: $!";
}
$obj = RPC::XML::base64->new($fh);
isa_ok($obj, 'RPC::XML::base64', '$obj');
$enc_value = ''; $value = '';
while (read $fh, $value, 60*57)
{
$enc_value .= encode_base64($value, '');
}
is($obj->as_string(), "$enc_value",
'from file, stringification');
is(length($obj->as_string), $obj->length, 'from file, length');
seek $fh, 0, 0;
SKIP: {
skip 'Digest::MD5 unavailable', 1 if (! $md5_able);
$md5 = Digest::MD5->new;
$md5->addfile($fh);
$value = $md5->hexdigest;
$md5->new; # Clear the digest
$md5->add($obj->value);
is($value, $md5->hexdigest, 'MD5 checksum matches');
}
close $fh;
# Test the to_file method
if (! (open $fh, '<', $file))
{
die "Error opening $file: $!";
}
$obj = RPC::XML::base64->new($fh);
# Start by trying to write the new file
$size = $obj->to_file($tmpfile);
is($size, -s $file, 'to_file call returned correct number of bytes');
is(-s $tmpfile, -s $file, 'temp-file size matches file size');
SKIP: {
skip 'Digest::MD5 unavailable', 1 if (! $md5_able);
$md5 = Digest::MD5->new;
$md5->addfile($fh);
$value = $md5->hexdigest;
$md5->new; # Clear the digest
# Now get an MD5 on the new file
if (! (open $ofh, '<', $tmpfile))
{
die "Error opening $tmpfile for reading: $!";
}
$md5->addfile($ofh);
is($value, $md5->hexdigest, 'MD5 hexdigest matches');
close $ofh;
unlink $tmpfile;
}
close $fh;
# Try with in-memory data
$value = 'a simple in-memory string';
$obj = RPC::XML::base64->new($value);
# Try to write it
$size = $obj->to_file($tmpfile);
is($size, length $value, 'to_file call returned correct number of bytes');
is(length $value, -s $tmpfile, 'temp-file size matches string');
unlink $tmpfile;
# Try with a file-handle instead of a file name
if (! (open $ofh, '>', $tmpfile))
{
die "Error opening $tmpfile for writing: $!";
}
select($ofh); $| = 1; select STDOUT;
$size = $obj->to_file($ofh);
is($size, length $value, 'to_file call on file-handle, correct size');
is(length $value, -s $ofh, 'temp-file size matches string');
close $ofh;
unlink $tmpfile;
# Try an unusable reference
$size = $obj->to_file([]);
is($size, -1, 'to_file call failed on unusable reference type');
like($RPC::XML::ERROR, qr/Unusable reference/, 'Correct error message');
SKIP: {
# Test the failure to open a file. Cannot run this on Windows because
# it doesn't have the concept of chmod...
skip 'Tests involving directory permissions skipped on Windows', 2
if ($^O eq 'MSWin32' || $^O eq 'cygwin');
skip 'Tests involving directory permissions skipped under root', 2
if ($< == 0);
my $baddir = File::Spec->catdir(File::Spec->tmpdir(), "baddir_$$");
if (! mkdir $baddir)
{
skip "Skipping, failed to create dir $baddir: $!", 2;
}
if (! chmod oct(600), $baddir)
{
skip "Skipping, failed to chmod dir $baddir: $!", 2;
}
my $badfile = File::Spec->catfile($baddir, 'file');
$size = $obj->to_file($badfile);
is($size, -1, 'to_file call failed on un-openable file');
like($RPC::XML::ERROR, qr/Error opening/, 'Correct error message');
if (! rmdir $baddir)
{
warn "Failed to remove temp-dir $baddir: $!";
}
}
# Test to_file() with an encoded file in the file-handle
if (! (open $fh, '<', $b64file))
{
die "Error opening $b64file for reading: $!";
}
$obj = RPC::XML::base64->new($fh, 'encoded');
$size = $obj->to_file($tmpfile);
is($size, -s $file, 'to_file() written size matches decoded file size');
SKIP: {
skip 'Digest::MD5 unavailable', 1 if (! $md5_able);
if (! (open $fh, '<', $file))
{
die "Error opening $file: $!";
}
$md5 = Digest::MD5->new;
$md5->addfile($fh);
$value = $md5->hexdigest;
$md5->new; # Clear the digest
# Now get an MD5 on the new file
if (! (open $ofh, '<', $tmpfile))
{
die "Error opening $tmpfile for reading: $!";
}
$md5->addfile($ofh);
is($value, $md5->hexdigest, 'MD5 hexdigest matches');
close $ofh;
unlink $tmpfile;
}
close $fh;
exit;
RPC-XML-0.77/t/12_nil.t 000644 000765 000024 00000002444 11612471026 014543 0 ustar 00rjray staff 000000 000000 #!/usr/bin/perl
# Test the data-manipulation routines in RPC::XML
use strict;
use vars qw($val $obj);
use Test::More tests => 11;
use RPC::XML 'smart_encode';
# First ensure that we can't actually create these objects unless we explicitly
# enable the extension:
$obj = RPC::XML::nil->new();
ok(! defined($obj), 'Did not create a nil without first enabling nil');
like($RPC::XML::ERROR, qr/RPC::XML::ALLOW_NIL must be set/,
'$RPC::XML::ERROR correctly set');
# Enable and try again
$RPC::XML::ALLOW_NIL = 1;
$obj = RPC::XML::nil->new();
isa_ok($obj, 'RPC::XML::nil');
# Check stringification and length
is($obj->as_string, '', 'Stringification');
is($obj->length, 6, 'Length of element');
# Test the convenience function
{
use RPC::XML 'RPC_NIL';
isa_ok(RPC_NIL, 'RPC::XML::nil');
}
# Verify that anything passed to the constructor has no effect on the created
# object:
$obj = RPC::XML::nil->new('ignored');
isa_ok($obj, 'RPC::XML::nil');
is($obj->as_string, '', 'Stringification');
is($obj->length, 6, 'Length of element');
# With nil enabled, smart_encode() should now encode undef as a nil, not as a
# null-length string:
$obj = smart_encode(undef);
is($obj->type, 'nil', 'smart_encode undef->string type');
is($obj->value, undef, 'smart_encode undef->string value');
exit 0;
RPC-XML-0.77/t/13_no_deep_recursion.t 000644 000765 000024 00000003400 11612471026 017455 0 ustar 00rjray staff 000000 000000 #!/usr/bin/perl
# Test the changes in RPC::XML to prevent infinite recursion on cyclic refs
use strict;
use vars qw($val $newval $obj);
use Test::More tests => 17;
use RPC::XML 'smart_encode';
$val = [];
push(@$val, 'a');
push(@$val, $val);
$obj = smart_encode($val);
isa_ok($obj, 'RPC::XML::array');
$newval = $obj->value;
is(scalar(@$newval), 1, 'Cyclical array now length 1');
is($newval->[0], 'a', 'Cyclical array kept non-cyclic element');
$obj = RPC::XML::array->new($val);
isa_ok($obj, 'RPC::XML::array');
$newval = $obj->value;
# Because we used the constructor, the first level didn't count for the cyclic
# tests. Instead, the first element is the potentially-cyclical array.
$newval = $newval->[0];
is(scalar(@$newval), 1, 'Cyclical array <2> now length 1');
is($newval->[0], 'a', 'Cyclical array <2> kept non-cyclic element');
$val = {};
$val->{a} = 'a';
$val->{b} = [ qw(a b c) ];
$val->{c} = 1;
$val->{b}->[1] = $val;
$obj = smart_encode($val);
isa_ok($obj, 'RPC::XML::struct');
$newval = $obj->value;
is(scalar(keys %$newval), 3, 'Cyclical struct has correct num of keys');
is(scalar(@{$newval->{b}}), 2, 'Cyclical struct array elem is correct');
is($newval->{a}, 'a', 'Cyclical struct other key no. 1 correct');
is($newval->{c}, 1, 'Cyclical struct other key no. 2 correct');
$obj = RPC::XML::struct->new($val);
isa_ok($obj, 'RPC::XML::struct');
$newval = $obj->value;
is(scalar(keys %$newval), 3, 'Cyclical struct <2> has correct num of keys');
is(scalar(@{$newval->{b}}), 3, 'Cyclical struct <2> array elem is correct');
is($newval->{a}, 'a', 'Cyclical struct <2> other key no. 1 correct');
is($newval->{c}, 1, 'Cyclical struct <2> other key no. 2 correct');
is(scalar(keys %{$newval->{b}->[1]}), 2,
'Cyclical struct <2> nested hash has correct keys');
exit 0;
RPC-XML-0.77/t/14_datetime_iso8601.t 000644 000765 000024 00000004224 11624055533 016752 0 ustar 00rjray staff 000000 000000 #!/usr/bin/perl
# Test the date-parsing facilities provided by the DateTime::Format::ISO8601
# module, if available
use strict;
use vars qw($obj @values $formatter);
use Test::More;
use RPC::XML;
eval "use DateTime::Format::ISO8601";
# Do not run this suite if the package is not available
plan skip_all => 'DateTime::Format::ISO8601 not available' if $@;
# Otherwise, we have to calculate our tests from the content after __DATA__:
while (defined(my $line = ))
{
next if ($line =~ /^#/);
chomp $line;
next if ($line =~ /^$/);
push @values, [ split /[|]/, $line ];
}
plan tests => (scalar(@values) * 2);
# Create a formatter from the DateTime::Format::ISO8601 package, we'll use it
# to determine what the constructor *should* return:
$formatter = DateTime::Format::ISO8601->new();
for my $test (0 .. $#values)
{
my ($input, $is_error) = @{$values[$test]};
$obj = RPC::XML::datetime_iso8601->new($input);
if (! $is_error)
{
my $match = $formatter->parse_datetime($input);
$match =~ s/-//g;
isa_ok($obj, 'RPC::XML::datetime_iso8601', "Input $test \$obj");
is($obj->value, $match, "Input '$input' yielded correct value");
}
else
{
ok(! ref($obj), "Input $test yielded no object");
like($RPC::XML::ERROR, qr/Malformed data [(]$input[)]/,
"Input '$input' yielded correct error message");
}
}
exit 0;
__DATA__
# Format is:
# |
#
# If the second field is non-blank, then the input should yield an error
#
# I am skipping some of the sillier formats, as I don't care if people use them
# and get unexpected results. Caveat Programmer, and all that...
20110820
2011-08-20
2011-08
2011
110820
11-08-20
-1108
-11-08
--0820
--08-20
--08
---20
2011232
2011-232
11232
11-232
-232
2011W336
2011-W33-6
2011W33
2011-W33
11W336
11-W33-6
11W33
11-W33
-1W336
-1-W33-6
-1W33
-1-W33
-W336
-W33-6
17:55:55
17:55
175555,50
17:55:55,50
175555.50
1755.50
17:55.50
17.50
-55:00
-5500,50
-55.50
--00.0
175555Z
17:55:55Z
1755Z
17:55Z
17Z
175555.0Z
17:55:55.0Z
175555-0700
17:55:55-07:00
175555-07
17:55:55-07
175555.0-0700
17:55:55.0-07:00
17,01|bad
20110820175555|bad
RPC-XML-0.77/t/15_serialize.t 000644 000765 000024 00000011572 11624416525 015763 0 ustar 00rjray staff 000000 000000 #!/usr/bin/perl
# Test the serialization of XML structures to filehandles
use strict;
use vars qw($dir $vol $fh $file $tmpfile $md5_able $faux_req $faux_res $ofh
$data);
use RPC::XML ':all';
use Test::More tests => 20;
use File::Spec;
# We'll be using the extension here:
$RPC::XML::ALLOW_NIL = 1;
($vol, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0));
$dir = File::Spec->catpath($vol, $dir, '');
$file = File::Spec->catfile($dir, 'svsm_text.gif');
$tmpfile = File::Spec->catfile($dir, "__tmp__${$}__");
END
{
# Make sure we don't leave any droppings...
if (-f $tmpfile)
{
unlink $tmpfile;
}
}
if (! (open $fh, '<', $file))
{
die "Could not open $file for reading: $!";
}
$faux_req = RPC::XML::request->new(
'test',
RPC_STRING 'string',
RPC_INT 10,
RPC_I4 20,
RPC_I8 4294967296,
RPC_DOUBLE 0.5,
RPC_BOOLEAN 1,
RPC_DATETIME_ISO8601 time2iso8601(),
[ qw(a b c) ],
{ one => 2 },
RPC_NIL,
RPC_BASE64 $fh
);
# This is a good place to test the length() method, while we're at it
is(length($faux_req->as_string), $faux_req->length, 'Testing length() method');
if (! (open $ofh, '+>', $tmpfile))
{
die "Could not open $tmpfile for read/write: $!";
}
select $ofh; $| = 1; select STDOUT;
$faux_req->serialize($ofh);
ok(1, 'serialize method did not croak'); # Just happy we made it this far.
is(-s $ofh, length($faux_req->as_string), 'File size is correct');
seek $ofh, 0, 0;
$data = '';
read $ofh, $data, -s $ofh;
is($data, $faux_req->as_string, 'File content is correct');
# Done with these for now
close $fh;
close $ofh;
unlink $tmpfile;
# We'll be doing this next set twice, as RPC::XML::response::serialize has a
# slightly different code-path for faults and all other responses.
if (! (open $ofh, '+>', $tmpfile))
{
die "Could not open $tmpfile for read/write: $!";
}
select $ofh; $| = 1; select STDOUT;
$faux_res = RPC::XML::response->new(RPC::XML::fault->new(1, 'test'));
is(length($faux_res->as_string), $faux_res->length,
'length() in fault response');
$faux_res->serialize($ofh);
# Again, this means that all the triggered calls managed to not die
ok(1, 'serialize method did not croak');
is(-s $ofh, length($faux_res->as_string), 'Fault-response file size OK');
seek $ofh, 0, 0;
$data = '';
read $ofh, $data, -s $ofh;
is($data, $faux_res->as_string, 'Fault-response content is correct');
close $ofh;
unlink $tmpfile;
# Round two, with normal response (not fault)
if (! (open $ofh, '+>', $tmpfile))
{
die "Could not open $tmpfile for read/write: $!";
}
select $ofh; $| = 1; select STDOUT;
$faux_res = RPC::XML::response->new('test');
is(length($faux_res->as_string), $faux_res->length,
'length() in normal response');
$faux_res->serialize($ofh);
# Again, this means that all the triggered calls managed to not die
ok(1, 'serialize method did not croak');
is(-s $ofh, length($faux_res->as_string), 'Normal response file size OK');
seek $ofh, 0, 0;
$data = '';
read $ofh, $data, -s $ofh;
is($data, $faux_res->as_string, 'Normal response content OK');
close $ofh;
unlink $tmpfile;
# Test some extra code-paths in the base64 logic:
# Route 1: In-memory content
if (! (open $ofh, '+>', $tmpfile))
{
die "Could not open $tmpfile for read/write: $!";
}
select $ofh; $| = 1; select STDOUT;
$faux_res = RPC::XML::response->new(RPC::XML::base64->new('a simple string'));
is(length($faux_res->as_string), $faux_res->length,
'length() in normal response');
$faux_res->serialize($ofh);
# Again, this means that all the triggered calls managed to not die
ok(1, 'serialize method did not croak');
is(-s $ofh, length($faux_res->as_string), 'Normal response file size OK');
seek $ofh, 0, 0;
$data = '';
read $ofh, $data, -s $ofh;
is($data, $faux_res->as_string, 'Normal response content OK');
close $ofh;
unlink $tmpfile;
# Route 2: Spool from a file that is already encoded
if (! (open $ofh, '+>', $tmpfile))
{
die "Could not open $tmpfile for read/write: $!";
}
select $ofh; $| = 1; select STDOUT;
$file = File::Spec->catfile($dir, 'svsm_text.b64');
if (! (open $fh, '<', $file))
{
die "Could not open $file for reading: $!";
}
$faux_res = RPC::XML::response->new(RPC::XML::base64->new($fh, 'encoded'));
is(length($faux_res->as_string), $faux_res->length,
'length() in normal response');
$faux_res->serialize($ofh);
# Again, this means that all the triggered calls managed to not die
ok(1, 'serialize method did not croak');
# If we're on Windows, then the re-spooling of the content of svsm_text.b64
# introduced 32 extra bytes (due to \n\r silliness). Set $offset to 0 or 32
# depending on the value of $^O.
my $offset = ($^O =~ /mswin/i) ? 32 : 0;
is(-s $ofh, length($faux_res->as_string) + $offset,
'Normal response file size OK');
seek $ofh, 0, 0;
$data = '';
read $ofh, $data, -s $ofh;
is($data, $faux_res->as_string, 'Normal response content OK');
close $fh;
close $ofh;
unlink $tmpfile;
exit;
RPC-XML-0.77/t/20_xml_parser.t 000644 000765 000024 00000043762 12016253033 016137 0 ustar 00rjray staff 000000 000000 #!/usr/bin/perl
# Test the RPC::XML::Parser::XMLParser class
use strict;
use vars qw($p $req $res $ret $dir $vol $file $fh $str $badstr);
use Test::More tests => 137;
require File::Spec;
require IO::File;
use RPC::XML ':all';
use RPC::XML::Parser::XMLParser;
($vol, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0));
$dir = File::Spec->catpath($vol, $dir, '');
$file = File::Spec->catfile($dir, 'svsm_text.gif');
# The organization of the test suites is such that we assume anything that
# runs before the current suite is 100%. Thus, no consistency checks on
# RPC::XML::* classes are done, only on the data and return values of this
# class under consideration, RPC::XML::Parser::XMLParser.
$p = RPC::XML::Parser::XMLParser->new();
isa_ok($p, 'RPC::XML::Parser::XMLParser', '$p');
isa_ok($p, 'RPC::XML::Parser', '$p');
# Make sure you can't call parse_more() or parse_done() on a vanilla
# RPC::XML::Parser::XMLParser instance:
$ret = eval { $p->parse_more(); 1; };
ok(! $ret, 'Calling parse_more on $p failed');
like($@, qr/Must be called on a push-parser instance/,
'Correct error message');
$ret = eval { $p->parse_done(); 1; };
ok(! $ret, 'Calling parse_done on $p failed');
like($@, qr/Must be called on a push-parser instance/,
'Correct error message');
$req = RPC::XML::request->new('test.method');
$ret = $p->parse($req->as_string);
isa_ok($ret, 'RPC::XML::request', '$ret');
is($ret->name, 'test.method', 'Correct request method name');
# Try a request with no block at all:
$str = <test.method
EO_STR
$ret = $p->parse($str);
isa_ok($ret, 'RPC::XML::request', '$ret');
is($ret->name, 'test.method', 'Correct request method name');
ok(ref($ret->args) eq 'ARRAY' && @{$ret->args} == 0,
'No block yields correct args list');
$res = RPC::XML::response->new(RPC::XML::string->new('test response'));
$ret = $p->parse($res->as_string);
isa_ok($ret, 'RPC::XML::response', '$ret');
is($ret->value->value, 'test response', 'Response value');
# Test some badly-formed data
my $tmp = $res->as_string; $tmp =~ s/methodResponse/mR/g;
$ret = $p->parse($tmp);
ok(! ref($ret), 'Bad XML did not parse');
like($ret, qr/Unknown tag/, 'Parse failure returned error');
# Make sure that the parser can handle all of the core data-types. Easiest way
# to do this is to create a fake request with a parameter of each type (except
# base64, which is getting exercised later on).
$req = RPC::XML::request->new(
'parserTest',
RPC::XML::i4->new(1),
RPC::XML::int->new(2),
RPC::XML::i8->new(3),
RPC::XML::double->new(4.5),
RPC::XML::string->new('string'),
RPC::XML::boolean->new('true'),
RPC::XML::datetime_iso8601->new('2008-09-29T12:00:00-07:00'),
[ 0, 1 ], # Array, auto-encoded
{ a => 1, b => 2 }, # Hash/struct, also auto-encoded
);
$ret = $p->parse($req->as_string);
isa_ok($ret, 'RPC::XML::request', 'Parse of RPC::XML::request block');
SKIP: {
skip "RPC::XML::request object not properly parsed, cannot test it.", 20
unless (ref($ret) eq 'RPC::XML::request');
is($ret->name, 'parserTest', 'Properly parsed /methodCall/methodName');
my $args = $ret->args;
is(scalar @$args, 9, 'Parser created correct-length args list');
# I could (and should) probably turn this into a loop with a table of
# data, but I'm lazy right this moment.
isa_ok($args->[0], 'RPC::XML::i4', 'Parse of argument');
is($args->[0]->value, 1, 'RPC::XML::i4 value parsed OK');
isa_ok($args->[1], 'RPC::XML::int', 'Parse of argument');
is($args->[1]->value, 2, 'RPC::XML::int value parsed OK');
isa_ok($args->[2], 'RPC::XML::i8', 'Parse of argument');
is($args->[2]->value, 3, 'RPC::XML::i8 value parsed OK');
isa_ok($args->[3], 'RPC::XML::double', 'Parse of argument');
is($args->[3]->value, 4.5, 'RPC::XML::double value parsed OK');
isa_ok($args->[4], 'RPC::XML::string', 'Parse of argument');
is($args->[4]->value, 'string', 'RPC::XML::string value parsed OK');
isa_ok($args->[5], 'RPC::XML::boolean', 'Parse of argument');
ok($args->[5]->value, 'RPC::XML::boolean value parsed OK');
isa_ok($args->[6], 'RPC::XML::datetime_iso8601',
'Parse of argument');
is($args->[6]->value, '20080929T12:00:00-07:00',
'RPC::XML::dateTime.iso8601 value parsed OK');
isa_ok($args->[7], 'RPC::XML::array', 'Parse of argument');
is(scalar(@{$args->[7]->value}), 2, 'RPC::XML::array value parsed OK');
isa_ok($args->[8], 'RPC::XML::struct', 'Parse of argument');
is(scalar(keys %{$args->[8]->value}), 2,
'RPC::XML::struct value parsed OK');
}
# Prior to this, we've confirmed that spooling base64 data to files works.
# Here, we test whether the parser (when configured to do so) can create
# filehandles as well.
undef $p;
$p = RPC::XML::Parser::XMLParser->new(base64_to_fh => 1);
$fh = IO::File->new("< $file");
die "Error opening $file: $!" unless ref $fh;
my $base64 = RPC::XML::base64->new($fh);
$req = RPC::XML::request->new('method', $base64);
# Start testing
my $spool_ret = $p->parse($req->as_string);
isa_ok($spool_ret, 'RPC::XML::request', '$spool_ret');
is($spool_ret->name, 'method', 'Request, base64 spooling, method name test');
ok(ref($spool_ret->args), 'Request, base64 spooling, return arg test');
my $new_base64 = $spool_ret->args->[0];
isa_ok($new_base64, 'RPC::XML::base64', '$new_base64');
is($base64->as_string(), $new_base64->as_string,
'Parse base64 spooling, value comparison');
isa_ok($new_base64->{value_fh}, 'GLOB', '$new_base64->{value_fh}');
# Per problem reported by Bill Moseley, check that messages parsed by the
# parser class handle the core entities.
$tmp = q{Entity test: & < > ' "};
$res = RPC::XML::response->new($tmp);
$ret = $p->parse($res->as_string);
is($ret->value->value, $tmp, 'RPC::XML::Parser handles core entities');
my $bad_entities = <
]>
metaWeblog.newPostEntity test: &foo;
EOX
$p = RPC::XML::Parser::XMLParser->new();
$ret = $p->parse($bad_entities);
SKIP: {
skip 'Weird entities parsing error in XML::Parser encountered', 1
if (! ref $ret);
my $args = $ret->args;
is($args->[0]->value, 'Entity test: ', 'Bad entities ignored');
}
# Now test passing of various references to the parser
$p = RPC::XML::Parser::XMLParser->new();
$str = RPC::XML::request->new('test.method')->as_string;
$ret = $p->parse(\$str);
isa_ok($ret, 'RPC::XML::request', '$ret from scalar reference');
ok(ref($ret) && ($ret->name eq 'test.method'), 'Correct request method name');
my $tmpfile = File::Spec->catfile($dir, "tmp_$$.xml");
open $fh, '+>', $tmpfile;
SKIP: {
skip "Open of $tmpfile failed, cannot test on it ($!)", 2
if (! $fh);
print {$fh} $str;
seek $fh, 0, 0;
$ret = $p->parse($fh);
isa_ok($ret, 'RPC::XML::request', '$ret from glob reference');
ok((ref($ret) and ($ret->name eq 'test.method')),
'Correct request method name');
close $fh;
unlink $tmpfile;
}
# Tweak the XML to test the error cases
$str =~ s{}{};
$ret = $p->parse(\$str);
ok(! ref $ret, '$ret error from scalar reference');
like($ret, qr/no element found/, 'Correct error message');
open $fh, '+>', $tmpfile;
SKIP: {
skip "Open of $tmpfile failed, cannot test on it ($!)", 2
if (! $fh);
print {$fh} $str;
seek $fh, 0, 0;
$ret = $p->parse($fh);
ok(! ref $ret, '$ret error from glob reference');
like($ret, qr/no element found/, 'Correct error message');
close $fh;
unlink $tmpfile;
}
# Try an unusable reference
$ret = $p->parse([]);
ok(! ref $ret, 'Unusable reference did not parse to anything');
like($ret, qr/Unusable reference type/, 'Correct error message');
# Negative testing-- try to break the parser
my $bad_counter = 1;
sub test_bad_xml
{
my ($badstr, $message) = @_;
$ret = $p->parse($badstr);
ok(! ref $ret, "Bad XML <$bad_counter>");
like($ret, qr/$message/, 'Correct error message');
$bad_counter++;
}
$str = RPC::XML::request->new('name', 'foo')->as_string;
($badstr = $str) =~ s/>namebad^name.*}{};
test_bad_xml($badstr, 'No methodName tag detected');
($badstr = $str) =~ s{}{};
test_bad_xml($badstr, 'Extra content in "methodCall"');
($badstr = $str) =~ s{params>}{paramss>}g;
test_bad_xml($badstr, 'Unknown tag encountered: paramss');
$str = RPC::XML::response->new(1)->as_string;
($badstr = $str) =~ s{}{};
test_bad_xml($badstr, 'Stack corruption detected');
($badstr = $str) =~ s{}{};
test_bad_xml($badstr, 'No found within container');
($badstr = $str) =~ s{param>}{paramm>}g;
test_bad_xml($badstr, 'Unknown tag encountered: paramm');
($badstr = $str) =~ s{}{};
test_bad_xml($badstr, 'Illegal content in param tag');
($badstr = $str) =~ s{value>}{valuee>}g;
test_bad_xml($badstr, 'Unknown tag encountered: valuee');
($badstr = $str) =~ s{>1<}{>foo<};
test_bad_xml($badstr, 'Bad integer');
($badstr = $str) =~ s{params}{paramss}g;
test_bad_xml($badstr, 'Unknown tag encountered: paramss');
$str = RPC::XML::response->new(RPC::XML::fault->new(1, 'foo'))->as_string;
($badstr = $str) =~ s{}{};
test_bad_xml($badstr, 'Stack corruption detected');
($badstr = $str) =~ s{}{};
$badstr =~ s{}{};
test_bad_xml($badstr, 'Unknown tag encountered: valuee');
# These are a little more hairy, trying to pass an invalid fault structure.
# Gonna hard-code the strings rather than trying to transform $str.
$badstr = <strfaultStringfoofaultCode1
EO_BADSTR
test_bad_xml($badstr, 'Bad content inside struct block');
$badstr = <faultStringfoofaultCode1extraMember1
EO_BADSTR
test_bad_xml($badstr, 'Extra struct fields not allowed');
$badstr = <
EO_BADSTR
test_bad_xml($badstr, 'Stack corruption detected');
$badstr = <foo
EO_BADSTR
test_bad_xml($badstr, 'Only a value may be within a ');
$RPC::XML::ALLOW_NIL = 1;
$str = RPC::XML::response->new(undef)->as_string;
($badstr = $str) =~ s{}{undef};
test_bad_xml($badstr, ' element must be empty');
$str = RPC::XML::request->new('foo', 1)->as_string;
($badstr = $str) =~ s{}{};
test_bad_xml($badstr, 'Illegal content in params tag');
($badstr = $str) =~ s{.*}{};
test_bad_xml($badstr, 'Illegal content in params tag');
($badstr = $str) =~ s{}{};
$badstr =~ s{}{};
test_bad_xml($badstr, 'Unknown tag encountered: valuee');
($badstr = $str) =~ s{}{1};
test_bad_xml($badstr, 'Stack corruption detected');
($badstr = $str) =~ s{1}{foo};
test_bad_xml($badstr, 'Bad floating-point data read');
# Parser errors specific to arrays:
$str = RPC::XML::response->new([ 1 ])->as_string;
($badstr = $str) =~ s{}{};
test_bad_xml($badstr, 'Illegal content in array tag');
($badstr = $str) =~ s{}{};
$badstr =~ s{}{};
test_bad_xml($badstr, 'Unknown tag encountered: valuee');
($badstr = $str) =~ s{1}{foo};
test_bad_xml($badstr, 'Bad integer data read');
$badstr = <1foo
EO_BADSTR
test_bad_xml($badstr, 'Bad content inside data block');
$badstr = <foo1
EO_BADSTR
test_bad_xml($badstr, 'Illegal content in data tag');
# Parser errors specific to structs:
$str = RPC::XML::response->new({ foo => 1 })->as_string;
($badstr = $str) =~ s{}{};
test_bad_xml($badstr, 'Unknown tag encountered: foo');
($badstr = $str) =~ s{name>}{namee>}g;
test_bad_xml($badstr, 'Unknown tag encountered: namee');
($badstr = $str) =~ s{1}{foo};
test_bad_xml($badstr, 'Bad integer data');
$badstr = <foo11
EO_BADSTR
test_bad_xml($badstr, 'Element mismatch, expected to see name');
$badstr = <1foo
EO_BADSTR
test_bad_xml($badstr, 'Element mismatch, expected to see value');
$badstr = <foo11
EO_BADSTR
test_bad_xml($badstr, 'Element mismatch, expected to see member');
$badstr = <1foo1
EO_BADSTR
test_bad_xml($badstr, 'Bad content inside struct block');
# Some corner-cases in responses
$badstr = <11
EO_BADSTR
test_bad_xml($badstr, 'invalid: too many params');
$badstr = <
EO_BADSTR
test_bad_xml($badstr, 'invalid: no params');
$badstr = <
EO_BADSTR
test_bad_xml($badstr, 'No parameter was declared');
# Corner case(s) in requests
$badstr = <foofoo
EO_BADSTR
test_bad_xml($badstr, 'methodName tag must immediately follow a methodCall');
# Test the "none of the above" error case
($badstr = $str) =~ s/struct/structt/g;
test_bad_xml($badstr, 'Unknown tag encountered: structt');
# Test parse-end errors
$badstr = <1
EO_BADSTR
test_bad_xml($badstr, 'End-of-parse error');
# Test some of the failures related to Base64-spooling. This can only be tested
# on non-Windows systems, as to cause some of the failures we'll need to create
# an un-writable directory (and Windows doesn't have the same chmod concept we
# have in other places).
SKIP: {
skip 'Tests involving directory permissions skipped on Windows', 1
if ($^O eq 'MSWin32' || $^O eq 'cygwin');
skip 'Tests involving directory permissions skipped under root', 1
if ($< == 0);
my $baddir = File::Spec->catdir(File::Spec->tmpdir(), "baddir_$$");
if (! mkdir $baddir)
{
skip "Skipping, failed to create dir $baddir: $!", 1;
}
if (! chmod oct(600), $baddir)
{
skip "Skipping, failed to chmod dir $baddir: $!", 1;
}
undef $p;
$p = RPC::XML::Parser::XMLParser->new(
base64_to_fh => 1,
base64_temp_dir => $baddir
);
open $fh, '<', $file;
die "Error opening $file: $!" unless $fh;
my $base64 = RPC::XML::base64->new($fh);
$req = RPC::XML::request->new('method', $base64);
$ret = $p->parse($req->as_string);
like($ret, qr/Error opening temp file for base64/,
'Opening Base64 spoolfile correctly failed');
if (! rmdir $baddir)
{
warn "Failed to remove temp-dir $baddir: $!";
}
}
exit 0;
RPC-XML-0.77/t/21_xml_libxml.t 000644 000765 000024 00000040056 12005334416 016127 0 ustar 00rjray staff 000000 000000 #!/usr/bin/perl
# Test the RPC::XML::Parser::XMLLibXML class
use strict;
use vars qw($p $req $res $str $badstr $ret $dir $vol $file $fh);
BEGIN
{
use Test::More;
eval "use XML::LibXML";
if ($@)
{
plan skip_all => "XML::LibXML not installed";
}
else
{
plan tests => 110;
}
}
require File::Spec;
use RPC::XML ':all';
use RPC::XML::Parser::XMLLibXML;
($vol, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0));
$dir = File::Spec->catpath($vol, $dir, '');
$file = File::Spec->catfile($dir, 'svsm_text.gif');
# The organization of the test suites is such that we assume anything that
# runs before the current suite is 100%. Thus, no consistency checks on
# RPC::XML::* classes are done, only on the data and return values of this
# class under consideration, RPC::XML::Parser::XMLLibXML.
$p = RPC::XML::Parser::XMLLibXML->new();
isa_ok($p, 'RPC::XML::Parser::XMLLibXML', '$p');
isa_ok($p, 'RPC::XML::Parser', '$p');
$req = RPC::XML::request->new('test.method');
$ret = $p->parse($req->as_string);
isa_ok($ret, 'RPC::XML::request', '$ret');
is($ret->name, 'test.method', 'Correct request method name');
$res = RPC::XML::response->new(RPC::XML::string->new('test response'));
$ret = $p->parse($res->as_string);
isa_ok($ret, 'RPC::XML::response', '$ret');
is($ret->value->value, 'test response', 'Response value');
# Test some badly-formed data
my $tmp = $res->as_string; $tmp =~ s/methodResponse/mR/g;
$ret = $p->parse($tmp);
ok(! ref($ret), 'Bad XML did not parse');
like($ret, qr/Unknown tag/, 'Parse failure returned error');
# Test parsing of faults
$res = RPC::XML::response->new(RPC::XML::fault->new(1, 'foo'));
$ret = $p->parse($res->as_string);
isa_ok($ret, 'RPC::XML::response', 'fault parsing: $ret');
isa_ok($ret->value, 'RPC::XML::fault', 'fault parsing: $ret->value');
is($ret->value->code, 1, 'fault parsing: correct code value');
is($ret->value->string, 'foo', 'fault parsing: correct string value');
# Make sure that the parser can handle all of the core data-types. Easiest way
# to do this is to create a fake request with a parameter of each type (except
# base64, which is getting exercised later on).
$req = RPC::XML::request->new(
'parserTest',
RPC::XML::i4->new(1),
RPC::XML::int->new(2),
RPC::XML::i8->new(3),
RPC::XML::double->new(4.5),
RPC::XML::string->new('string'),
RPC::XML::boolean->new('true'),
RPC::XML::datetime_iso8601->new('2008-09-29T12:00:00-07:00'),
[ 0, 1 ], # Array, auto-encoded
{ a => 1, b => 2 }, # Hash/struct, also auto-encoded
);
$ret = $p->parse($req->as_string);
isa_ok($ret, 'RPC::XML::request', 'Parse of RPC::XML::request block');
SKIP: {
skip "RPC::XML::request object not properly parsed, cannot test it.", 20
unless (ref($ret) eq 'RPC::XML::request');
is($ret->name, 'parserTest', 'Properly parsed /methodCall/methodName');
my $args = $ret->args;
is(scalar @$args, 9, 'Parser created correct-length args list');
# I could (and should) probably turn this into a loop with a table of
# data, but I'm lazy right this moment.
isa_ok($args->[0], 'RPC::XML::i4', 'Parse of argument');
is($args->[0]->value, 1, 'RPC::XML::i4 value parsed OK');
isa_ok($args->[1], 'RPC::XML::int', 'Parse of argument');
is($args->[1]->value, 2, 'RPC::XML::int value parsed OK');
isa_ok($args->[2], 'RPC::XML::i8', 'Parse of argument');
is($args->[2]->value, 3, 'RPC::XML::i8 value parsed OK');
isa_ok($args->[3], 'RPC::XML::double', 'Parse of argument');
is($args->[3]->value, 4.5, 'RPC::XML::double value parsed OK');
isa_ok($args->[4], 'RPC::XML::string', 'Parse of argument');
is($args->[4]->value, 'string', 'RPC::XML::string value parsed OK');
isa_ok($args->[5], 'RPC::XML::boolean', 'Parse of argument');
ok($args->[5]->value, 'RPC::XML::boolean value parsed OK');
isa_ok($args->[6], 'RPC::XML::datetime_iso8601',
'Parse of argument');
is($args->[6]->value, '20080929T12:00:00-07:00',
'RPC::XML::dateTime.iso8601 value parsed OK');
isa_ok($args->[7], 'RPC::XML::array', 'Parse of argument');
is(scalar(@{$args->[7]->value}), 2, 'RPC::XML::array value parsed OK');
isa_ok($args->[8], 'RPC::XML::struct', 'Parse of argument');
is(scalar(keys %{$args->[8]->value}), 2,
'RPC::XML::struct value parsed OK');
}
# Prior to this, we've confirmed that spooling base64 data to files works.
# Here, we test whether the parser (when configured to do so) can create
# filehandles as well.
undef $p;
$p = RPC::XML::Parser::XMLLibXML->new(base64_to_fh => 1);
open $fh, '<', $file;
die "Error opening $file: $!" unless $fh;
my $base64 = RPC::XML::base64->new($fh);
$req = RPC::XML::request->new('method', $base64);
# Start testing
my $spool_ret = $p->parse($req->as_string);
isa_ok($spool_ret, 'RPC::XML::request', '$spool_ret');
is($spool_ret->name, 'method', 'Request, base64 spooling, method name test');
ok(ref($spool_ret->args), 'Request, base64 spooling, return arg test');
my $new_base64 = $spool_ret->args->[0];
isa_ok($new_base64, 'RPC::XML::base64', '$new_base64');
is($new_base64->as_string, $base64->as_string(),
'Parse base64 spooling, value comparison');
isa_ok($new_base64->{value_fh}, 'GLOB', '$new_base64->{value_fh}');
# Per problem reported by Bill Moseley, check that messages parsed by the
# parser class handle the core entities.
$tmp = q{Entity test: & < > ' "};
$res = RPC::XML::response->new($tmp);
$ret = $p->parse($res->as_string);
is($ret->value->value, $tmp, 'RPC::XML::Parser handles core entities');
# The variables $req and $base64 are still in scope, and should still be OK.
# In fact, I should be testing this functionality in the XML::Parser suite as
# well, but the server tests exercise it for that parser.
# Test the push-parser functionality.
my $pp = RPC::XML::Parser::XMLLibXML->new->parse();
isa_ok($pp, 'RPC::XML::Parser::XMLLibXML', 'Push-parser instance');
my $string = $req->as_string;
my $string1 = substr($string, 0, int(length($string)/2));
my $string2 = substr($string, int(length($string)/2));
$pp->parse_more($string1);
$pp->parse_more($string2);
$res = $pp->parse_done();
isa_ok($res, 'RPC::XML::request', 'parse_done() return value');
my $new_b64 = $res->args->[0];
isa_ok($new_b64, 'RPC::XML::base64', 'First args value');
is($new_b64->as_string, $base64->as_string(),
'Push-parse value comparison');
SKIP: {
skip "/etc/passwd is not an issue on windows.", 1 if $^O eq 'MSWin32';
my $bad_entities = <
]>
metaWeblog.newPostEntity test: &foo;
EOX
$pp = RPC::XML::Parser::XMLLibXML->new->parse();
$ret = $pp->parse($bad_entities);
my $args = $ret->args;
is($args->[0]->value, 'Entity test: ', 'Bad entities ignored');
}
# Now test passing of various references to the parser
$p = RPC::XML::Parser::XMLLibXML->new();
$str = RPC::XML::request->new('test.method')->as_string;
$ret = $p->parse(\$str);
isa_ok($ret, 'RPC::XML::request', '$ret from scalar reference');
ok(ref($ret) && ($ret->name eq 'test.method'), 'Correct request method name');
my $tmpfile = File::Spec->catfile($dir, "tmp_$$.xml");
open $fh, '+>', $tmpfile;
SKIP: {
skip "Open of $tmpfile failed, cannot test on it ($!)", 2
if (! $fh);
print {$fh} $str;
seek $fh, 0, 0;
$ret = $p->parse($fh);
isa_ok($ret, 'RPC::XML::request', '$ret from glob reference');
ok((ref($ret) and ($ret->name eq 'test.method')),
'Correct request method name');
close $fh;
unlink $tmpfile;
}
# Tweak the XML to test the error cases
$str =~ s{}{};
$ret = $p->parse(\$str);
ok(! ref $ret, '$ret error from scalar reference');
like($ret, qr/parser error/, 'Correct error message');
open $fh, '+>', $tmpfile;
SKIP: {
skip "Open of $tmpfile failed, cannot test on it ($!)", 2
if (! $fh);
print {$fh} $str;
seek $fh, 0, 0;
$ret = $p->parse($fh);
ok(! ref $ret, '$ret error from glob reference');
like($ret, qr/parser error/, 'Correct error message');
close $fh;
unlink $tmpfile;
}
# Try an unusable reference
$ret = $p->parse([]);
ok(! ref $ret, 'Unusable reference did not parse to anything');
like($ret, qr/Unusable reference type/, 'Correct error message');
# Negative testing-- try to break the parser
$str = RPC::XML::request->new('name', 'foo')->as_string;
($badstr = $str) =~ s/>namebad^nameparse($badstr);
ok(! ref $ret, 'Bad XML <1>');
like($ret, qr/methodName value.*not a valid name/, 'Correct error message');
($badstr = $str) =~ s{.*}{};
$ret = $p->parse($badstr);
ok(! ref $ret, 'Bad XML <2>');
like($ret, qr/missing "methodName" child-element/, 'Correct error message');
($badstr = $str) =~ s{}{};
$ret = $p->parse($badstr);
ok(! ref $ret, 'Bad XML <3>');
like($ret, qr/Extra content in "methodCall"/, 'Correct error message');
($badstr = $str) =~ s{params>}{paramss>}g;
$ret = $p->parse($badstr);
ok(! ref $ret, 'Bad XML <4>');
like($ret, qr/Unknown tag "paramss"/, 'Correct error message');
$str = RPC::XML::response->new(1)->as_string;
($badstr = $str) =~ s{}{};
$ret = $p->parse($badstr);
ok(! ref $ret, 'Bad XML <5>');
like($ret, qr/too many child elements/, 'Correct error message');
($badstr = $str) =~ s{}{};
$ret = $p->parse($badstr);
ok(! ref $ret, 'Bad XML <6>');
like($ret, qr/too many child elements/, 'Correct error message');
($badstr = $str) =~ s{param>}{paramm>}g;
$ret = $p->parse($badstr);
ok(! ref $ret, 'Bad XML <7>');
like($ret, qr/Unknown tag "paramm"/, 'Correct error message');
($badstr = $str) =~ s{}{};
$ret = $p->parse($badstr);
ok(! ref $ret, 'Bad XML <8>');
like($ret, qr/too many child elements/, 'Correct error message');
($badstr = $str) =~ s{value>}{valuee>}g;
$ret = $p->parse($badstr);
ok(! ref $ret, 'Bad XML <9>');
like($ret, qr/Unknown tag "valuee"/, 'Correct error message');
($badstr = $str) =~ s{>1<}{>foo<};
$ret = $p->parse($badstr);
ok(! ref $ret, 'Bad XML <10>');
like($ret, qr/Bad integer/, 'Correct error message');
($badstr = $str) =~ s{params}{paramss}g;
$ret = $p->parse($badstr);
ok(! ref $ret, 'Bad XML <11>');
like($ret, qr/Illegal tag "paramss"/, 'Correct error message');
$str = RPC::XML::response->new(RPC::XML::fault->new(1, 'foo'))->as_string;
($badstr = $str) =~ s{}{};
$ret = $p->parse($badstr);
ok(! ref $ret, 'Bad XML <12>');
like($ret, qr/too many child elements/, 'Correct error message');
($badstr = $str) =~ s{}{};
$badstr =~ s{}{};
$ret = $p->parse($badstr);
ok(! ref $ret, 'Bad XML <13>');
like($ret, qr/Unknown tag "valuee"/, 'Correct error message');
# These are a little more hairy, trying to pass an invalid fault structure.
# Gonna hard-code the strings rather than trying to transform $str.
$badstr = <strfaultStringfoofaultCode1
EO_BADSTR
$ret = $p->parse($badstr);
ok(! ref $ret, 'Bad XML <14>');
like($ret, qr/Bad tag within struct/, 'Correct error message');
$badstr = <faultStringfoofaultCode1extraMember1
EO_BADSTR
$ret = $p->parse($badstr);
ok(! ref $ret, 'Bad XML <15>');
like($ret, qr/Extra struct fields not allowed/, 'Correct error message');
$RPC::XML::ALLOW_NIL = 1;
$str = RPC::XML::response->new(undef)->as_string;
($badstr = $str) =~ s{}{undef};
$ret = $p->parse($badstr);
ok(! ref $ret, 'Bad XML <16>');
like($ret, qr/nil tag must be empty/, 'Correct error message');
$str = RPC::XML::request->new('foo', 1)->as_string;
($badstr = $str) =~ s{}{};
$ret = $p->parse($badstr);
ok(! ref $ret, 'Bad XML <17>');
like($ret, qr/Unknown tag in params: value/, 'Correct error message');
($badstr = $str) =~ s{}{};
$badstr =~ s{}{};
$ret = $p->parse($badstr);
ok(! ref $ret, 'Bad XML <18>');
like($ret, qr/Unknown tag in param: valuee/, 'Correct error message');
($badstr = $str) =~ s{}{1};
$ret = $p->parse($badstr);
ok(! ref $ret, 'Bad XML <19>');
like($ret, qr/Too many child-nodes for value tag/, 'Correct error message');
($badstr = $str) =~ s{1}{foo};
$ret = $p->parse($badstr);
ok(! ref $ret, 'Bad XML <20>');
like($ret, qr/Bad floating-point data read/, 'Correct error message');
# Parser errors specific to arrays:
$str = RPC::XML::response->new([ 1 ])->as_string;
($badstr = $str) =~ s{}{};
$ret = $p->parse($badstr);
ok(! ref $ret, 'Bad XML <21>');
like($ret, qr/array tag must have just one child element/,
'Correct error message');
($badstr = $str) =~ s{}{};
$badstr =~ s{}{};
$ret = $p->parse($badstr);
ok(! ref $ret, 'Bad XML <22>');
like($ret, qr/Bad tag within array: got "valuee"/, 'Correct error message');
($badstr = $str) =~ s{1}{foo};
$ret = $p->parse($badstr);
ok(! ref $ret, 'Bad XML <23>');
like($ret, qr/Bad integer data read/, 'Correct error message');
# Parser errors specific to structs:
$str = RPC::XML::response->new({ foo => 1 })->as_string;
($badstr = $str) =~ s{}{};
$ret = $p->parse($badstr);
ok(! ref $ret, 'Bad XML <24>');
like($ret, qr/Wrong number of nodes within struct/, 'Correct error message');
($badstr = $str) =~ s{name>}{namee>}g;
$ret = $p->parse($badstr);
ok(! ref $ret, 'Bad XML <25>');
like($ret, qr/expected tags "name" and "value"/, 'Correct error message');
($badstr = $str) =~ s{1}{foo};
$ret = $p->parse($badstr);
ok(! ref $ret, 'Bad XML <26>');
like($ret, qr/Bad integer data/, 'Correct error message');
# Test the "none of the above" error case
($badstr = $str) =~ s/struct/structt/g;
$ret = $p->parse($badstr);
ok(! ref $ret, 'Bad XML <27>');
like($ret, qr/Unknown tag "structt"/, 'Correct error message');
# Test some of the failures related to Base64-spooling. This can only be tested
# on non-Windows systems, as to cause some of the failures we'll need to create
# an un-writable directory (and Windows doesn't have the same chmod concept we
# have in other places).
SKIP: {
skip 'Tests involving directory permissions skipped on Windows', 1
if ($^O eq 'MSWin32' || $^O eq 'cygwin');
skip 'Tests involving directory permissions skipped under root', 1
if ($< == 0);
my $baddir = File::Spec->catdir(File::Spec->tmpdir(), "baddir_$$");
if (! mkdir $baddir)
{
skip "Skipping, failed to create dir $baddir: $!", 1;
}
if (! chmod oct(600), $baddir)
{
skip "Skipping, failed to chmod dir $baddir: $!", 1;
}
undef $p;
$p = RPC::XML::Parser::XMLLibXML->new(
base64_to_fh => 1,
base64_temp_dir => $baddir
);
open $fh, '<', $file;
die "Error opening $file: $!" unless $fh;
my $base64 = RPC::XML::base64->new($fh);
$req = RPC::XML::request->new('method', $base64);
$ret = $p->parse($req->as_string);
like($ret, qr/Error opening temp file for base64/,
'Opening Base64 spoolfile correctly failed');
if (! rmdir $baddir)
{
warn "Failed to remove temp-dir $baddir: $!";
}
}
exit 0;
RPC-XML-0.77/t/25_parser_negative.t 000644 000765 000024 00000003246 11612471026 017144 0 ustar 00rjray staff 000000 000000 #!/usr/bin/perl
# Test the RPC::XML::Parser class negative conditions
use strict;
use warnings;
use vars qw($p $retval);
use Test::More tests => 14;
# Create a dummy class to use for attempts to call methods within the
# RPC::XML::Parser class:
package BadParser;
use base 'RPC::XML::Parser';
package main;
# This is the pattern we are looking for in the error messages:
my $errtext = qr/should have been overridden by the BadParser class/;
# First, the constructor:
eval { $p = BadParser->new() };
ok(! defined $p, 'RPC::XML::Parser did not instantiate');
like($@, $errtext, 'Correctly-set error message in $@');
# Fine! We'll *force* an object into that class:
$p = bless {}, 'BadParser';
# *Now* try and stop me from calling methods!
$retval = eval { $p->parse(); 1 };
ok(! $retval, '::parse correctly failed to run');
like($@, $errtext, 'Correctly-set error message in $@');
$retval = eval { $p->parse_more(); 1 };
ok(! $retval, '::parse_more correctly failed to run');
like($@, $errtext, 'Correctly-set error message in $@');
$retval = eval { $p->parse_done(); 1 };
ok(! $retval, '::parse_done correctly failed to run');
like($@, $errtext, 'Correctly-set error message in $@');
# Try them as static methods:
$retval = eval { BadParser->parse(); 1 };
ok(! $retval, '::parse correctly failed to run');
like($@, $errtext, 'Correctly-set error message in $@');
$retval = eval { BadParser->parse_more(); 1 };
ok(! $retval, '::parse_more correctly failed to run');
like($@, $errtext, 'Correctly-set error message in $@');
$retval = eval { BadParser->parse_done(); 1 };
ok(! $retval, '::parse_done correctly failed to run');
like($@, $errtext, 'Correctly-set error message in $@');
exit;
RPC-XML-0.77/t/29_parserfactory.t 000644 000765 000024 00000011072 11612471026 016652 0 ustar 00rjray staff 000000 000000 #!/usr/bin/perl
# Test the RPC::XML::ParserFactory class
use strict;
use vars qw($p $req $res $ret $ns $dir $vol $config %parsers);
use Test::More tests => 38;
require File::Spec;
use RPC::XML ':all';
use RPC::XML::ParserFactory;
($vol, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0));
$dir = File::Spec->catpath($vol, $dir, '');
unshift @INC, $dir;
%parsers = (
'XML::Parser' => 1,
);
# See if we should run tests dependent on XML::LibXML
eval "use XML::LibXML;";
$parsers{'XML::LibXML'} = 1 unless $@;
# The organization of the test suites is such that we assume anything that
# runs before the current suite is 100%. Thus, no consistency checks on
# RPC::XML::* classes, RPC::XML::Parser::XMLParser or any of the other
# parser-instance classes that are currently part of the distro.
# First let's squeeze in a negative test, to see what happens when an attempt
# to load a valid parser fails
unshift @INC, sub {
die 'Force-failing RPC::XML::Parser::XMLParser'
if ($_[1] eq 'RPC/XML/Parser/XMLParser.pm');
return undef;
};
$p = RPC::XML::ParserFactory->new(class => 'XML::Parser');
ok(! $p, 'Factory correctly failed when it could not load parser class');
like($RPC::XML::ERROR, qr/Error loading RPC::XML::Parser::XMLParser/,
'Correct error message');
# Now clear out that pesky closure so the rest of the tests succeed
shift @INC;
# Now start by testing with the XML::Parser wrapper, since that is the only one
# that is "required" (for now).
$p = RPC::XML::ParserFactory->new();
isa_ok($p, 'RPC::XML::Parser', '$p');
isa_ok($p, 'RPC::XML::Parser::XMLParser', '$p');
$req = RPC::XML::request->new('test.method');
$ret = $p->parse($req->as_string);
isa_ok($ret, 'RPC::XML::request', '$ret');
is($ret->name, 'test.method', 'Correct request method name');
$res = RPC::XML::response->new(RPC::XML::string->new('test response'));
$ret = $p->parse($res->as_string);
isa_ok($ret, 'RPC::XML::response', '$ret');
is($ret->value->value, 'test response', 'Response value');
# Test some badly-formed data
my $tmp = $res->as_string;
$tmp =~ s/methodResponse/mR/g;
$ret = $p->parse($tmp);
ok(!ref($ret), 'Bad XML did not parse');
like($ret, qr/Unknown tag/, 'Parse failure returned error');
# For all the evals, to avoid namespace pollution, we'll keep incrementing
# this...
my $ns = 'namespace0000';
my %aliases = (
'XML::Parser' => [ qw(XML::Parser xml::parser xmlparser) ],
'XML::LibXML' => [ qw(XML::LibXML xml::libxml xmllibxml) ],
);
# Test with the various aliases for XML::Parser
for my $alias (@{$aliases{'XML::Parser'}})
{
$ns++;
eval <<"EndOfEval";
{
package $ns;
use RPC::XML::ParserFactory (class => '$alias');
\$main::p = RPC::XML::ParserFactory->new();
}
EndOfEval
isa_ok($p, 'RPC::XML::Parser', "Alias $alias: \$p");
isa_ok($p, 'RPC::XML::Parser::XMLParser', "Alias $alias: \$p");
}
# The non-xmlparser parsers are all optional, so skip their sets if the
# parser isn't in the config:
for my $parser (qw(XML::LibXML))
{
(my $factory_class = $parser) =~ s/:://g;
$factory_class = "RPC::XML::Parser::$factory_class";
SKIP:
{
skip "$parser not detected, tests skipped", 6
unless $parsers{$parser};
for my $alias (@{$aliases{$parser}})
{
$ns++;
eval <<"EndOfEval";
{
package $ns;
use RPC::XML::ParserFactory qw($alias);
\$main::p = RPC::XML::ParserFactory->new();
}
EndOfEval
isa_ok($p, 'RPC::XML::Parser', "Alias $alias: \$p");
isa_ok($p, $factory_class, "Alias $alias: \$p");
}
}
}
# This block makes sure that we can new() a parser with a specific alias
for my $parser (qw(XML::Parser XML::LibXML))
{
(my $factory_class = $parser) =~ s/:://g;
$factory_class = "RPC::XML::Parser::$factory_class";
SKIP:
{
skip "$parser not detected, tests skipped", 6
unless $parsers{$parser};
for my $alias (@{$aliases{$parser}})
{
$p = RPC::XML::ParserFactory->new(class => $alias);
isa_ok($p, 'RPC::XML::Parser', "New'ing $alias: \$p");
isa_ok($p, $factory_class, "New'ing $alias: \$p");
}
}
}
# Some negative tests
$p = RPC::XML::ParserFactory->new(class => 'DoesNotExist');
ok(! $p, 'Factory-new fails with bad class argument');
like($RPC::XML::ERROR, qr/Error loading DoesNotExist/,
'Correct error message');
$p = RPC::XML::ParserFactory->new(class => 'BadParserClass');
ok(! $p, 'Factory-new fails with a bad parser class');
like($RPC::XML::ERROR, qr/is not a sub-class of/, 'Correct error message');
exit 0;
RPC-XML-0.77/t/30_procedure.t 000644 000765 000024 00000043103 12016606537 015754 0 ustar 00rjray staff 000000 000000 #!/usr/bin/perl
# Test the RPC::XML::Procedure class (and the ::Method and ::Function classes)
use strict;
use warnings;
use vars qw($obj $obj2 $flag $dir $vol $tmp $tmpfile $fh);
use File::Spec;
use Test::More;
use RPC::XML qw($ALLOW_NIL RPC_INT RPC_DATETIME_ISO8601 time2iso8601);
use RPC::XML::Procedure;
plan tests => 87;
($vol, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0));
$dir = File::Spec->catpath($vol, $dir, '');
$tmpfile = File::Spec->catfile($dir, "tmp_xpl_$$.xpl");
# The organization of the test suites is such that we assume anything that
# runs before the current suite is 100%. Thus, no consistency checks on
# any other classes are done, only on the data and return values of this
# class under consideration, RPC::XML::Procedure. As such, we are not testing
# any part of the RPC::XML::Server class here. Only the code for managing
# methods.
# Basic new() success, simple accessors and successful calling
$obj = RPC::XML::Procedure->new({ name => 'test.test',
signature => [ 'int' ],
code => sub { $flag = 1; } });
isa_ok($obj, 'RPC::XML::Procedure', '$obj');
SKIP: {
skip 'Cannot test without object', 15
unless (ref($obj) eq 'RPC::XML::Procedure');
# Arguments here don't matter, just testing that trying to call new() on a
# referent fails:
$obj2 = $obj->new();
like($obj2, qr/Must be called as a static method/,
'Correct error message from bad new()');
ok(($obj->name() eq 'test.test') &&
($obj->namespace() eq '') &&
(scalar(@{$obj->signature}) == 1) &&
($obj->signature->[0] eq 'int'),
'Basic accessors');
$flag = 0;
eval { $obj->code->(); };
ok((! $@) && $flag, 'Calling the code');
# What about the missing values?
is($obj->help(), '', 'Null value for help()');
is($obj->namespace(), '', 'Null value for namespace()');
is($obj->version(), 0, 'Zero value for version()');
is($obj->hidden(), 0, 'Zero value for hidden()');
# Try changing the attributes that can change:
$obj->help('help');
is($obj->help(), 'help', 'help() changes correctly');
$obj->version('1.1.1');
is($obj->version(), '1.1.1', 'version() changes correctly');
$obj->hidden(1);
is($obj->hidden(), 1, 'hidden() changes correctly');
my $sub = sub { 'foo' };
$obj->code($sub);
is($obj->code(), $sub, 'code() changes correctly');
# Try a value that should be rejected
$obj->code([]);
is($obj->code(), $sub, 'code() did not change to a bad value');
# Changing signature() is tricky
$obj->signature([ 'int int', 'string string', 'double double' ]);
is(scalar(@{$obj->signature}), 3, 'signature() changes correctly');
# This one should fail
my $err = $obj->signature([ qw(int double) ]);
like($err, qr/Cannot have two different return values/,
'signature() failed correctly on ambiguous data');
is(scalar(@{$obj->signature}), 3, 'signature() reverted to old value');
# This should fail for a different reason
$err = $obj->signature(1);
like($err, qr/Bad value '1'/, 'signature() failed correctly on bad input');
# What happens if I try reload() on it?
$err = $obj->reload();
like($err, qr/No file associated with method/, 'reload() fails OK');
}
# Basic new() using faux hash table input
$obj = RPC::XML::Procedure->new(
name => 'test.test',
hidden => 1,
signature => 'int int',
signature => [ qw(string string) ],
code => sub { 1; }
);
isa_ok($obj, 'RPC::XML::Procedure', '$obj<2>');
SKIP: {
skip 'Cannot test without object', 2
unless (ref($obj) eq 'RPC::XML::Procedure');
ok(($obj->name() eq 'test.test') &&
($obj->namespace() eq '') &&
(scalar(@{$obj->signature}) == 2) &&
($obj->signature->[0] eq 'int int') &&
($obj->signature->[1] eq 'string string'),
'Basic accessors <2>');
$flag = eval { $obj->code->(); };
ok((! $@) && $flag, 'Calling the code <2>');
}
# This should succeed, but "hidden" is false because the second overrides the
# first.
$obj = RPC::XML::Procedure->new(
name => 'test.test',
hidden => 1,
hidden => 0,
signature => 'int int',
signature => [ qw(string string) ],
code => sub { 1; }
);
isa_ok($obj, 'RPC::XML::Procedure', '$obj<3>');
is($obj->hidden(), 0, 'hidden() is correctly false');
# This should fail due to missing name
$obj = RPC::XML::Procedure->new({ code => sub { 1; } });
like($obj, qr/Missing required data \(name or code\)/,
'Correct constructor failure [1]');
# This should fail due to missing code
$obj = RPC::XML::Procedure->new({ name => 'test.test1' });
like($obj, qr/Missing required data \(name or code\)/,
'Correct constructor failure [2]');
# This should fail due to missing information (the signature)
$obj = RPC::XML::Method->new({ name => 'test.test2',
code => sub { $flag = 2; } });
like($obj, qr/Missing required data \(signatures\)/,
'Correct constructor failure [3]');
# This one fails because the signatures have a collision
$obj = RPC::XML::Method->new({ name => 'test.test2',
signature => [ 'int int',
'string int' ],
code => sub { $flag = 2; } });
like($obj, qr/two different return values for one set of params/,
'Correct constructor failure [4]');
# Fails because of a null signature
$obj = RPC::XML::Method->new({ name => 'test.test2',
signature => [ '' ],
code => sub { $flag = 2; } });
like($obj, qr/Invalid signature, cannot be null/,
'Correct constructor failure [5]');
# Fails because of an unknown type in the return value slot
$obj = RPC::XML::Method->new({ name => 'test.test2',
signature => [ 'frob int' ],
code => sub { $flag = 2; } });
like($obj, qr/Unknown return type 'frob'/,
'Correct constructor failure [6]');
# Fails because of an unknown type in the args-list
$obj = RPC::XML::Method->new({ name => 'test.test2',
signature => [ 'int string frob int' ],
code => sub { $flag = 2; } });
like($obj, qr/One or more invalid types in signature/,
'Correct constructor failure [7]');
# This file will not load due to missing required information
$obj = RPC::XML::Method->new(File::Spec->catfile($dir, 'meth_bad_1.xpl'));
like($obj, qr/missing/i, 'Bad XPL [1] not loaded');
# This file will not load due to an XML parsing error
$obj = RPC::XML::Method->new(File::Spec->catfile($dir, 'meth_bad_2.xpl'));
like($obj, qr/error parsing/i, 'Bad XPL [2] not loaded');
# And the third bowl of porridge was _just_ _right_...
$obj = RPC::XML::Method->new(File::Spec->catfile($dir, 'meth_good_1.xpl'));
isa_ok($obj, 'RPC::XML::Method', '$obj');
SKIP: {
skip 'Cannot test without a value $obj', 20
if (ref($obj) ne 'RPC::XML::Method');
# Check the basics
ok(ref($obj) && $obj->name() && scalar(@{$obj->signature}) &&
$obj->hidden() && $obj->version() && $obj->help(),
'Good XPL load, basic accessors');
# Is code() the type of ref we expect?
ok(ref($obj) && (ref($obj->code) eq 'CODE'),
'Good XPL load, code() accessor');
# This looks more complex than it is. The code returns this specific key,
# but because this is a RPC::XML::Method, it expects a ref as the first
# argument, representing a RPC::XML::Server (or derived) instance.
is($obj->code->(undef, { method_name => $obj->name }), $obj->name(),
'Good XPL load, code() invocation');
# Time to test cloning
$obj2 = $obj->clone;
# Did it?
isa_ok($obj2, ref($obj), '$obj2');
SKIP: {
skip 'Clone failed, cannot test without second object', 4
if (ref($obj2) ne ref $obj);
# Primary accessors/data
ok(($obj->name() eq $obj2->name()) &&
($obj->version() eq $obj2->version()) &&
($obj->help() eq $obj2->help()),
'Compare accessors of clone and source');
# Are the actual listrefs of signatures different?
isnt($obj->signature(), $obj2->signature(),
'Clone signature() accessor has different listref');
# And yet, the contents are the same?
ok((@{$obj->signature} == @{$obj2->signature}) &&
# There's only one signature in the list
($obj->signature->[0] eq $obj2->signature->[0]),
'Clone signature() value is same despite this');
# Lastly, and very importantly, the coderefs are still the same
is($obj->code(), $obj2->code(),
'Clone code() ref value is same as source');
undef $obj2; # Don't need it anymore
}
# Now let's play around with signatures a bit
# Basic test of match_signature()
is($obj->match_signature(''), 'string', 'Test match_signature()');
# Add a new signature, simple
is($obj->add_signature('int int'), $obj,
'Adding via add_signature() returns obj ref');
# There should now be two
is(scalar(@{$obj->{signature}}), 2,
'Number of signatures after add_signature()');
# Does the new one match OK?
is($obj->match_signature('int'), 'int', 'New signature matches correctly');
# Try matching it with an array-ref
is($obj->match_signature([ 'int' ]), 'int', 'Signature matches arrayref');
# This addition should fail due to ambiguity
isnt($tmp = $obj->add_signature([ 'double', 'int' ]), $obj,
'Correct failure of adding ambiguous signature');
# But did it fail for the right reasons?
like($tmp, qr/make_sig_table/,
'Signature failure returned correct message');
# Test deletion
is($obj->delete_signature('int int'), $obj, 'Test delete_signature()');
# Which means checking the count again
is(scalar(@{$obj->{signature}}), 1,
'Correct signature count after delete');
# Try deleting the last signature
my $err = $obj->delete_signature('string');
like($err, qr/Cannot delete last signature/,
'Deleting last signature fails');
# Note that deleting a non-existent signature "succeeds"
is($obj->delete_signature([ 'int' ]), $obj,
'Attempt to delete non-existent signature');
is(scalar(@{$obj->{signature}}), 1,
'Correct signature count after useless delete');
# We're done with this one for now.
undef $obj;
}
# Check the other two proc-types being loaded from files:
$obj = RPC::XML::Procedure->new(File::Spec->catfile($dir, 'meth_good_2.xpl'));
isa_ok($obj, 'RPC::XML::Procedure', '$obj');
# This should return an RPC::XML::Function object, despite being called via
# RPC::XML::Procedure.
$obj = RPC::XML::Procedure->new(File::Spec->catfile($dir, 'meth_good_3.xpl'));
isa_ok($obj, 'RPC::XML::Function', '$obj');
# With this later object, test some of the routines that are overridden in
# RPC::XML::Function:
SKIP: {
skip 'Cannot test without RPC::XML::Function object', 8
if (ref($obj) ne 'RPC::XML::Function');
ok((ref($obj->signature) eq 'ARRAY' && (@{$obj->signature} == 1)),
'RPC::XML::Function valid return from signature() <1>');
is($obj->add_signature('int int'), $obj,
'RPC::XML::Function valid add_signature');
ok((ref($obj->signature) eq 'ARRAY' && (@{$obj->signature} == 1)),
'RPC::XML::Function valid return from signature() <2>');
is($obj->match_signature('int'), 'scalar',
'RPC::XML::Function correct signature match');
is($obj->delete_signature('int int'), $obj,
'RPC::XML::Function valid delete_signature');
ok((ref($obj->signature) eq 'ARRAY' && (@{$obj->signature} == 1)),
'RPC::XML::Function valid return from signature() <3>');
# Can we clone it?
$obj2 = $obj->clone();
isa_ok($obj2, ref($obj), '$obj2');
ok(($obj->name() eq $obj2->name()) &&
($obj->version() eq $obj2->version()) &&
($obj->help() eq $obj2->help()),
'Compare accessors of clone and source');
is($obj->code(), $obj2->code(),
'Clone code() ref value is same as source');
}
# But this should fail, as only RPC::XML::Procedure is allowed to act as a
# factory constructor:
$obj = RPC::XML::Method->new(File::Spec->catfile($dir, 'meth_good_3.xpl'));
like($obj, qr/must match this calling class/,
'Correct error message on bad constructor call');
# Test procedures that utilize nil data-types
$ALLOW_NIL = 1;
# First a simple nil-return
$obj = RPC::XML::Procedure->new({ name => 'test.test_nil',
signature => [ 'nil' ],
code => sub { return; } });
isa_ok($obj, 'RPC::XML::Procedure');
SKIP: {
skip 'Cannot test without object', 2
unless (ref($obj) eq 'RPC::XML::Procedure');
my $val;
eval { $val = $obj->call({}); };
ok(! $@, 'Calling test.test_nil');
isa_ok($val, 'RPC::XML::nil', 'Return value');
}
# Nil return from a proc with argument(s)
$obj = RPC::XML::Procedure->new({ name => 'test.test_nil2',
signature => [ 'nil int' ],
code =>
sub { my $int = shift; return; } });
isa_ok($obj, 'RPC::XML::Procedure');
SKIP: {
skip 'Cannot test without object', 2
unless (ref($obj) eq 'RPC::XML::Procedure');
my $val;
eval { $val = $obj->call({}, RPC_INT 1); };
ok(! $@, 'Calling test.test_nil2');
isa_ok($val, 'RPC::XML::nil', 'Return value');
}
# Return value properly ignored when the signature types it as nil
$obj = RPC::XML::Procedure->new({ name => 'test.test_nil3',
signature => [ 'nil' ],
code => sub { 1; } });
isa_ok($obj, 'RPC::XML::Procedure');
SKIP: {
skip 'Cannot test without object', 2
unless (ref($obj) eq 'RPC::XML::Procedure');
my $val;
eval { $val = $obj->call({}); };
ok(! $@, 'Calling test.test_nil3');
isa_ok($val, 'RPC::XML::nil', 'Return value');
}
# Make sure that the presence of nil in a signature doesn't interfere with
# proper look-ups
$obj = RPC::XML::Procedure->new({ name => 'test.test_nil4',
signature => [ 'nil int' ],
code => sub { return; } });
isa_ok($obj, 'RPC::XML::Procedure');
SKIP: {
skip 'Cannot test without object', 2
unless (ref($obj) eq 'RPC::XML::Procedure');
is($obj->match_signature('int'), 'nil', 'Test match_signature() with nil');
ok(! $obj->match_signature('string'),
'Test match_signature() with nil [2]');
}
# This one will be fun. To truly test the reload() method, I need a file to
# actually change. So create a file, load it as XPL, rewrite it and reload it.
if (! (open $fh, '>', $tmpfile))
{
die "Error opening $tmpfile for writing: $!";
}
print {$fh} <test1.0stringSimple test method for RPC::XML::Procedure classsub test { 'foo' }
END
close $fh;
$obj = RPC::XML::Procedure->new($tmpfile);
isa_ok($obj, 'RPC::XML::Procedure', '$obj');
SKIP: {
skip 'Cannot test without object', 3
if (ref($obj) ne 'RPC::XML::Procedure');
if (! (open $fh, '>', $tmpfile))
{
die "Error opening $tmpfile for writing: $!";
}
print {$fh} <test1.0stringSimple test method for RPC::XML::Procedure classsub test { 'bar' }
END
close $fh;
is($obj->reload(), $obj, 'reload() returns ok');
my $val;
eval { $val = $obj->call(); };
is($val->value, 'bar', 'Reloaded method gave correct value');
# Try to reload again, after unlinking the file
unlink $tmpfile;
$val = $obj->reload();
like($val, qr/Error loading/, 'Correct error from reload() after unlink');
}
# Per RT#71452, I learned that I never tested dateTime.iso8601 in any of the
# signatures/calls, and that as of release 0.76, I may have bugs...
undef $obj;
$obj = RPC::XML::Procedure->new(
name => 'test.iso8601',
signature => 'string dateTime.iso8601',
code => sub {
my $date = shift;
return substr($date, 0, 4);
},
);
isa_ok($obj, 'RPC::XML::Procedure', '$obj');
SKIP: {
skip 'Cannot test without object', 2
unless (ref($obj) eq 'RPC::XML::Procedure');
is($obj->match_signature('dateTime.iso8601'), 'string',
'Test match_signature() with a dateTime.iso8601 input');
my $time = time2iso8601;
my $year = substr $time, 0, 4;
is($obj->call({}, RPC_DATETIME_ISO8601 $time)->value, $year,
'Test a call with a dateTime.iso8601 argument');
}
$obj = RPC::XML::Procedure->new(
name => 'test.iso8601',
signature => 'dateTime.iso8601 int',
code => sub {
my $time = shift;
return time2iso8601($time);
},
);
isa_ok($obj, 'RPC::XML::Procedure', '$obj');
SKIP: {
skip 'Cannot test without object', 2
unless (ref($obj) eq 'RPC::XML::Procedure');
is($obj->match_signature('int'), 'dateTime.iso8601',
'Test match_signature() with a dateTime.iso8601 output');
my $time = time;
is($obj->call({}, RPC_INT $time)->value, time2iso8601($time),
'Test a call with a dateTime.iso8601 return value');
}
END
{
# Just in case...
if (-e $tmpfile)
{
unlink $tmpfile;
}
}
exit 0;
RPC-XML-0.77/t/35_namespaces.t 000644 000765 000024 00000003213 11612471026 016100 0 ustar 00rjray staff 000000 000000 #!/usr/bin/perl
# Test the RPC::XML::Method class
use strict;
use warnings;
use vars qw($obj $obj2 $dir $vol);
use File::Spec;
use Test::More;
use RPC::XML::Procedure;
plan tests => 7;
($vol, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0));
$dir = File::Spec->catpath($vol, $dir, '');
# The organization of the test suites is such that we assume anything that
# runs before the current suite is 100%. Thus, no consistency checks on
# any other classes are done.
$obj = RPC::XML::Method->new(File::Spec->catfile($dir, 'namespace1.xpl'));
# We do an @ISA check again, because we've added the tag to the
# mix
isa_ok($obj, 'RPC::XML::Method');
SKIP: {
skip 'Cannot test without object', 2
unless (ref($obj) eq 'RPC::XML::Method');
is($obj->namespace(), 'Test::NS', 'Test namespace() method');
is($obj->code->(), 'Test::NS', 'Sub closure value of __PACKAGE__');
}
$obj2 = RPC::XML::Method->new(File::Spec->catfile($dir, 'namespace2.xpl'));
isa_ok($obj2, 'RPC::XML::Method');
SKIP: {
skip 'Cannot test without object', 2
unless (ref($obj2) eq 'RPC::XML::Method');
is($obj2->namespace(), 'Test::NS',
'Test namespace() method (dotted namespace)');
is($obj2->code->(), 'Test::NS',
'Sub closure value of __PACKAGE__ (dotted namespace)');
}
$Test::NS::value = 0;
$Test::NS::value++; # Just to suppress the "used only once" warning
$obj = RPC::XML::Method->new(File::Spec->catfile($dir, 'namespace3.xpl'));
SKIP: {
skip 'Cannot test without object', 1
unless (ref($obj) eq 'RPC::XML::Method');
ok($obj->code->(), 'Reading namespace-local value declared outside XPL');
}
exit;
RPC-XML-0.77/t/40_server.t 000644 000765 000024 00000110726 11632557550 015304 0 ustar 00rjray staff 000000 000000 #!/usr/bin/perl
# Test the RPC::XML::Server class
use strict;
use warnings;
use subs qw(start_server find_port);
use vars qw($srv $res $bucket $child $parser $xml $req $port $UA @API_METHODS
$list $meth @keys %seen $dir $vol $oldtable $newtable $value);
use Carp qw(croak);
use Socket;
use File::Spec;
use Test::More tests => 91;
use LWP::UserAgent;
use HTTP::Request;
use Scalar::Util 'blessed';
use RPC::XML 'RPC_BASE64';
require RPC::XML::Server;
require RPC::XML::ParserFactory;
@API_METHODS = qw(system.identity system.introspection system.listMethods
system.methodHelp system.methodSignature system.multicall
system.status);
($vol, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0));
$dir = File::Spec->catpath($vol, $dir, q{});
require File::Spec->catfile($dir, 'util.pl');
sub failmsg
{
my ($msg, $line) = @_;
return sprintf '%s at line %d', $msg, $line;
}
# The organization of the test suites is such that we assume anything that
# runs before the current suite is 100%. Thus, no consistency checks on
# any other classes are done, only on the data and return values of this
# class under consideration, RPC::XML::Server. In this particular case, this
# also means that we cannot use RPC::XML::Client to test it.
# Start with some very basic things, without actually firing up a live server.
$srv = RPC::XML::Server->new(no_http => 1, no_default => 1);
isa_ok($srv, 'RPC::XML::Server', '$srv<1>');
# This assignment is just to suppress "used only once" warnings
$value = $RPC::XML::Server::VERSION;
is($srv->version, $RPC::XML::Server::VERSION,
'RPC::XML::Server::version method');
ok(! $srv->started, 'RPC::XML::Server::started method');
like($srv->product_tokens, qr{/}, 'RPC::XML::Server::product_tokens method');
ok(! $srv->url, 'RPC::XML::Server::url method (empty)');
ok(! $srv->requests, 'RPC::XML::Server::requests method (0)');
ok($srv->response->isa('HTTP::Response'),
'RPC::XML::Server::response method returns HTTP::Response');
# Some negative tests:
$res = $srv->new();
like($res, qr/Must be called as a static method/,
'Calling new() as an instance method fails');
$meth = $srv->method_from_file('does_not_exist.xpl');
ok(! ref $meth, 'Bad file did not result in method reference');
like($meth, qr/Error opening.*does_not_exist/, 'Correct error message');
# Test the functionality of manipulating the fault table. First get the vanilla
# table from a simple server object. Then create a new server object with both
# a fault-base offset and some user-defined faults. We use the existing $srv to
# get the "plain" table.
$oldtable = $srv->{__fault_table};
# Now re-assign $srv
$srv = RPC::XML::Server->new(
no_http => 1,
no_default => 1,
fault_code_base => 1000,
fault_table => {
myfault1 => [ 2000, 'test' ],
myfault2 => 2001,
}
);
$newtable = $srv->{__fault_table};
# Compare number of faults, the values of the fault codes, and the presence of
# the user-defined faults:
ok((scalar(keys %{$oldtable}) + 2) == (scalar keys %{$newtable}),
'Proper number of relative keys');
$value = 1;
for my $key (keys %{$oldtable})
{
if ($newtable->{$key}->[0] != ($oldtable->{$key}->[0] + 1000))
{
$value = 0;
last;
}
}
ok($value, 'Fault codes adjustment yielded correct new codes');
ok((exists $newtable->{myfault1} && exists $newtable->{myfault2} &&
ref($newtable->{myfault1}) eq 'ARRAY' && $newtable->{myfault2} == 2001 &&
$newtable->{myfault1}->[0] == 2000),
'User-supplied fault elements look OK');
# Done with this one, let it go
undef $srv;
# Test that the url() method behaves like we expect it for certain ports
$srv = RPC::XML::Server->new(
no_default => 1,
no_http => 1,
host => 'localhost',
port => 80
);
SKIP: {
if (ref($srv) ne 'RPC::XML::Server')
{
skip 'Failed to get port-80 server, cannot test', 1;
}
is($srv->url, 'http://localhost', 'Default URL for port-80 server');
}
$srv = RPC::XML::Server->new(
no_default => 1,
no_http => 1,
host => 'localhost',
port => 443
);
SKIP: {
if (ref($srv) ne 'RPC::XML::Server')
{
skip 'Failed to get port-443 server, cannot test', 1;
}
is($srv->url, 'https://localhost', 'Default URL for port-443 server');
}
# Let's test that server creation properly fails if/when HTTP::Daemon fails.
# First find a port in use, preferably under 1024:
SKIP: {
if ($< == 0)
{
skip 'Negative port-based test unreliable when run as root', 2;
}
$port = find_port_in_use();
if ($port == -1)
{
skip 'No in-use port found for negative testing, skipped', 2;
}
$srv = RPC::XML::Server->new(port => $port);
is(ref($srv), q{}, 'Bad new return is not an object');
like($srv, qr/Unable to create HTTP::Daemon/, 'Proper error message');
}
# This one will have a HTTP::Daemon server, but still no default methods
if (($port = find_port) == -1)
{
croak 'No usable port found between 9000 and 11000, skipping';
}
$srv = RPC::XML::Server->new(no_default => 1,
host => 'localhost', port => $port);
isa_ok($srv, 'RPC::XML::Server', '$srv<2>');
# Test the URL the server uses. Allow for "localhost", "localhost.localdomain"
# or the local-net IP address of this host (not always 127.0.0.1).
# 22/09/2008 - Just allow for anything the user has attached to this address.
# Aliases keep causing this test to falsely fail.
my @localhostinfo = gethostbyname('localhost');
my $localIP = join('.', unpack('C4', $localhostinfo[4]));
my @allhosts = ($localIP, $localhostinfo[0], split(' ', $localhostinfo[1]));
for (@allhosts) { s/\./\\./g }
# Per RT 27778: For some reason gethostbyname('localhost') does not return
# "localhost" on win32
push @allhosts, 'localhost' if ($^O eq 'MSWin32' || $^O eq 'cygwin');
push @allhosts, 'localhost\.localdomain'
unless (grep(/localdomain/, @allhosts));
my $allhosts = join('|', @allhosts);
like($srv->url, qr{http://($allhosts):$port},
'RPC::XML::Server::url method (set)'); # This should be non-null this time
# Test some of the simpler cases of add_method and get_method
$res = $srv->add_method({ name => 'perl.test.suite.test1',
signature => [ 'int' ],
code => sub { return 1; } });
ok($res eq $srv, 'add_method return value test');
$res = $srv->get_method('perl.test.suite.test1');
isa_ok($res, 'RPC::XML::Method', 'get_method return value');
$res = $srv->get_method('perl.test.suite.not.added.yet');
ok(! ref($res), 'get_method for non-existent method');
# Throw junk at add_method/add_procedure/add_function
$res = $srv->add_method([]);
like($res, qr/file name, a hash reference or an object/,
'add_method() fails on bad data');
$res = $srv->add_method('file does not exist');
like($res, qr/Error loading from file/,
'add_method() fails on non-existent file');
$res = $srv->add_procedure({ name => 'procedure1',
signature => [ 'int' ],
code => sub { return 1; } });
ok($res eq $srv, 'add_procedure return value test');
$res = $srv->get_procedure('procedure1');
is(ref($res), 'RPC::XML::Procedure', 'get_procedure(procedure1) return value');
$res = $srv->add_function({ name => 'function1',
code => sub { return 1; } });
ok($res eq $srv, 'add_function return value test');
$res = $srv->get_function('function1');
is(ref($res), 'RPC::XML::Function', 'get_function(function1) return value');
$res = $srv->add_method({ name => 'method1',
type => 'bad',
signature => [ 'int' ],
code => sub { return 1; } });
like($res, qr/Unknown type: bad/, 'add_method, bad type param');
# Here goes...
$parser = RPC::XML::ParserFactory->new;
$UA = LWP::UserAgent->new;
$req = HTTP::Request->new(POST => "http://localhost:$port/");
$child = start_server($srv);
$req->header(Content_Type => 'text/xml');
$req->content(RPC::XML::request->new('perl.test.suite.test1')->as_string);
# Use alarm() to manage a resaonable time-out on the request
$bucket = 0;
$SIG{ALRM} = sub { $bucket++ };
alarm(120);
$res = $UA->request($req);
alarm(0);
ok(! $bucket, 'First live-request returned without timeout');
SKIP: {
skip "Server failed to respond within 120 seconds!", 4 if $bucket;
ok(! $res->is_error, 'First live req: Check that $res is not an error');
$xml = $res->content;
$res = $parser->parse($xml);
isa_ok($res, 'RPC::XML::response', 'First live req: parsed $res');
SKIP: {
skip "Response content did not parse, cannot test", 2
unless (ref $res and $res->isa('RPC::XML::response'));
ok(! $res->is_fault, 'First live req: parsed $res is not a fault');
is($res->value->value, 1, 'First live req: $res value test');
}
}
stop_server($child);
# Try deleting the method
ok(ref $srv->delete_method('perl.test.suite.test1'),
'delete_method return value test');
# Start the server again
# Add a method that echoes back socket-peer information
$res = $srv->add_method({ name => 'perl.test.suite.peeraddr',
signature => [ 'array' ],
code =>
sub {
my $srv = shift;
my $ipaddr = inet_aton($srv->{peerhost});
my $peeraddr = RPC_BASE64 $srv->{peeraddr};
my $packet = pack_sockaddr_in($srv->{peerport},
$ipaddr);
$packet = RPC_BASE64 $packet;
[ $peeraddr, $packet,
$srv->{peerhost}, $srv->{peerport} ];
} });
$child = start_server($srv);
$bucket = 0;
$SIG{ALRM} = sub { $bucket++ };
alarm(120);
$res = $UA->request($req);
alarm(0);
ok(! $bucket, 'Second live-request returned without timeout');
SKIP: {
skip "Server failed to respond within 120 seconds!", 4 if $bucket;
ok(! $res->is_error, 'Second live req: Check that $res is not an error');
$res = $parser->parse($res->content);
isa_ok($res, 'RPC::XML::response', 'Second live req: parsed $res');
SKIP: {
skip "Response content did not parse, cannot test", 2
unless (ref $res and $res->isa('RPC::XML::response'));
ok($res->is_fault, 'Second live req: parsed $res is a fault');
like($res->value->value->{faultString}, qr/Unknown method/,
'Second live request: correct faultString');
}
}
stop_server($child);
# Start the server again
$child = start_server($srv);
$bucket = 0;
$req->content(RPC::XML::request->new('perl.test.suite.peeraddr')->as_string);
$SIG{ALRM} = sub { $bucket++ };
alarm(120);
$res = $UA->request($req);
alarm(0);
ok(! $bucket, 'Third live-request returned without timeout');
SKIP: {
skip "Server failed to respond within 120 seconds!", 4 if $bucket;
ok(! $res->is_error, 'Third live req: Check that $res is not an error');
$res = $parser->parse($res->content);
isa_ok($res, 'RPC::XML::response', 'Third live req: parsed $res');
SKIP: {
skip "Response content did not parse, cannot test", 3
unless (ref $res and $res->isa('RPC::XML::response'));
$res = $res->value->value;
is($res->[2], inet_ntoa(inet_aton('localhost')),
'Third live req: Correct IP addr from peerhost');
is($res->[0], inet_aton($res->[2]),
'Third request: peeraddr packet matches converted peerhost');
is($res->[1], pack_sockaddr_in($res->[3], inet_aton($res->[2])),
'Third request: pack_sockaddr_in validates all');
}
}
stop_server($child);
# Start the server again
# Add a method that echoes back info from the HTTP request object
$res = $srv->add_method({ name => 'perl.test.suite.http_request',
signature => [ 'array' ],
code =>
sub {
my $srv = shift;
[ $srv->{request}->content_type,
$srv->{request}->header('X-Foobar') ]
} });
$child = start_server($srv);
$bucket = 0;
$req->content(RPC::XML::request->new('perl.test.suite.http_request')->as_string);
$req->header('X-Foobar', 'Wibble');
$SIG{ALRM} = sub { $bucket++ };
alarm(120);
$res = $UA->request($req);
alarm(0);
ok(! $bucket, 'Fourth live-request returned without timeout');
SKIP: {
skip "Server failed to respond within 120 seconds!", 4 if $bucket;
ok(! $res->is_error, 'Fourth live req: Check that $res is not an error');
$res = $parser->parse($res->content);
isa_ok($res, 'RPC::XML::response', 'Fourth live req: parsed $res');
SKIP: {
skip "Response content did not parse, cannot test", 3
unless (ref $res and $res->isa('RPC::XML::response'));
$res = $res->value->value;
is($res->[0], 'text/xml',
'Fourth request: Content type returned correctly');
is($res->[1], 'Wibble',
'Fourth live req: Correct value for request header X-Foobar');
}
}
# Clean up after ourselves.
$req->remove_header('X-Foobar');
stop_server($child);
# Start the server again
$child = start_server($srv);
# Test the error-message-mixup problem reported in RT# 29351
# (http://rt.cpan.org/Ticket/Display.html?id=29351)
my $tmp = q{
test.methodfoobar};
$req->content($tmp);
$bucket = 0;
$SIG{ALRM} = sub { $bucket++ };
alarm(120);
$res = $UA->request($req);
alarm(0);
ok(! $bucket, 'RT29351 live-request returned without timeout');
SKIP: {
skip "Server failed to respond within 120 seconds!", 4 if $bucket;
ok(! $res->is_error, 'RT29351 live req: $res is not an error');
$res = $parser->parse($res->content);
isa_ok($res, 'RPC::XML::response', 'RT29351 live req: parsed $res');
SKIP: {
skip "Response content did not parse, cannot test", 2
unless (ref $res and $res->isa('RPC::XML::response'));
ok($res->is_fault, 'RT29351 live req: parsed $res is a fault');
like(
$res->value->value->{faultString},
qr/Illegal content in param tag/,
'RT29351 live request: correct faultString'
);
}
}
stop_server($child);
# OK-- At this point, basic server creation and accessors have been validated.
# We've run a remote method and we've correctly failed to run an unknown remote
# method. Before moving into the more esoteric XPL-file testing, we will test
# the provided introspection API.
undef $srv;
undef $req;
die "No usable port found between 9000 and 10000, skipping"
if (($port = find_port) == -1);
$srv = RPC::XML::Server->new(host => 'localhost', port => $port);
# Did it create OK, with the requirement of loading the XPL code?
isa_ok($srv, 'RPC::XML::Server', '$srv<3> (with default methods)');
SKIP: {
skip "Failed to create RPC::XML::Server object with default methods", 3
unless ref($srv);
# Did it get all of them?
is($srv->list_methods(), scalar(@API_METHODS),
'Correct number of methods (defaults)');
$req = HTTP::Request->new(POST => "http://localhost:$port/");
$child = start_server($srv);
$req->header(Content_Type => 'text/xml');
$req->content(RPC::XML::request->new('system.listMethods')->as_string);
# Use alarm() to manage a reasonable time-out on the request
$bucket = 0;
undef $res;
$SIG{ALRM} = sub { $bucket++ };
alarm(120);
$res = $UA->request($req);
alarm(0);
SKIP: {
skip "Server failed to respond within 120 seconds!", 2 if $bucket;
$res = ($res->is_error) ? '' : $parser->parse($res->content);
isa_ok($res, 'RPC::XML::response', 'system.listMethods response');
SKIP: {
skip "Response content did not parse, cannot test", 1
unless (ref $res and $res->isa('RPC::XML::response'));
$list = (ref $res) ? $res->value->value : [];
ok((ref($list) eq 'ARRAY') &&
(join('', sort @$list) eq join('', sort @API_METHODS)),
'system.listMethods return list correct');
}
}
}
# Assume $srv is defined, for the rest of the tests (so as to avoid the
# annoying 'ok(0)' streams like above).
die "Server allocation failed, cannot continue. Message was: $srv"
unless (ref $srv);
stop_server($child);
# Start the server again
$child = start_server($srv);
# Set the ALRM handler to something more serious, since we have passed that
# hurdle already.
$SIG{ALRM} = sub { die "Server failed to respond within 120 seconds\n"; };
# Test the substring-parameter calling of system.listMethods
$req->content(RPC::XML::request->new('system.listMethods',
'method')->as_string);
alarm(120);
$res = $UA->request($req);
alarm(0);
$res = ($res->is_error) ? '' : $parser->parse($res->content);
SKIP: {
skip "Server response was error, cannot test", 1 unless $res;
$list = $res->value->value;
if ($res->is_fault)
{
fail(failmsg($res->value->string, __LINE__));
}
else
{
is(join(',', sort @$list),
'system.methodHelp,system.methodSignature',
'system.listMethods("method") return list correct');
}
}
# If the response was any kind of error, kill and re-start the server, as
# HTTP::Message::content might have killed it already via croak().
unless ($res) # $res was made null above if it was an error
{
stop_server($child);
# Start the server again
$child = start_server($srv);
}
# Run again, with a pattern that will produce no matches
$req->content(RPC::XML::request->new('system.listMethods',
'nomatch')->as_string);
alarm(120);
$res = $UA->request($req);
alarm(0);
$res = ($res->is_error) ? '' : $parser->parse($res->content);
SKIP: {
skip "Server response was error, cannot test", 1 unless $res;
$list = $res->value->value;
if ($res->is_fault)
{
fail(failmsg($res->value->string, __LINE__));
}
else
{
is(scalar(@$list), 0,
'system.listMethods("nomatch") return list correct');
}
}
# If the response was any kind of error, kill and re-start the server, as
# HTTP::Message::content might have killed it already via croak().
unless ($res) # $res was made null above if it was an error
{
stop_server($child);
# Start the server again
$child = start_server($srv);
}
# system.identity
$req->content(RPC::XML::request->new('system.identity')->as_string);
alarm(120);
$res = $UA->request($req);
alarm(0);
$res = ($res->is_error) ? '' : $parser->parse($res->content);
SKIP: {
skip "Server response was error, cannot test", 1 unless $res;
is($res->value->value, $srv->product_tokens, 'system.identity test');
}
# If the response was any kind of error, kill and re-start the server, as
# HTTP::Message::content might have killed it already via croak().
unless ($res) # $res was made null above if it was an error
{
stop_server($child);
# Start the server again
$child = start_server($srv);
}
# system.status
$req->content(RPC::XML::request->new('system.status')->as_string);
alarm(120);
$res = $UA->request($req);
alarm(0);
$res = ($res->is_error) ? '' : $parser->parse($res->content);
SKIP: {
skip "Server response was error, cannot test", 2 unless $res;
$res = $res->value->value;
@keys = qw(host port name version path date date_int started started_int
total_requests methods_known);
is(scalar(grep(defined $res->{$_}, @keys)), @keys,
'system.status hash has correct keys');
is($res->{total_requests}, 4,
'system.status reports correct total_requests');
}
# If the response was any kind of error, kill and re-start the server, as
# HTTP::Message::content might have killed it already via croak().
unless ($res) # $res was made null above if it was an error
{
stop_server($child);
# Start the server again
$child = start_server($srv);
}
# Test again, with a 'true' value passed to the method, which should prevent
# the 'total_requests' key from incrementing.
$req->content(RPC::XML::request->new('system.status',
RPC::XML::boolean->new(1))->as_string);
alarm(120);
$res = $UA->request($req);
alarm(0);
$res = ($res->is_error) ? '' : $parser->parse($res->content);
SKIP: {
skip "Server response was error, cannot test", 1 unless $res;
$res = $res->value->value;
is($res->{total_requests}, 4,
'system.status reports correct total_requests ("true" call)');
}
# If the response was any kind of error, kill and re-start the server, as
# HTTP::Message::content might have killed it already via croak().
unless ($res) # $res was made null above if it was an error
{
stop_server($child);
# Start the server again
$child = start_server($srv);
}
# system.methodHelp
$req->content(RPC::XML::request->new('system.methodHelp',
'system.identity')->as_string);
alarm(120);
$res = $UA->request($req);
alarm(0);
$res = ($res->is_error) ? '' : $parser->parse($res->content);
SKIP: {
skip "Server response was error, cannot test", 1 unless $res;
$meth = $srv->get_method('system.identity');
if (! blessed $meth)
{
fail(failmsg($meth, __LINE__));
}
else
{
is($res->value->value, $meth->{help},
'system.methodHelp("system.identity") test');
}
}
# If the response was any kind of error, kill and re-start the server, as
# HTTP::Message::content might have killed it already via croak().
unless ($res) # $res was made null above if it was an error
{
stop_server($child);
# Start the server again
$child = start_server($srv);
}
# system.methodHelp with multiple arguments
$req->content(RPC::XML::request->new('system.methodHelp',
[ 'system.identity',
'system.status' ])->as_string);
alarm(120);
$res = $UA->request($req);
alarm(0);
$res = ($res->is_error) ? '' : $parser->parse($res->content);
SKIP: {
skip "Server response was error, cannot test", 1 unless $res;
if ($res->is_fault)
{
fail(failmsg($res->value->string, __LINE__));
}
else
{
is(join('', @{ ref($res) ? $res->value->value : [] }),
$srv->get_method('system.identity')->{help} .
$srv->get_method('system.status')->{help},
'system.methodHelp("system.identity", "system.status") test');
}
}
# If the response was any kind of error, kill and re-start the server, as
# HTTP::Message::content might have killed it already via croak().
unless ($res) # $res was made null above if it was an error
{
stop_server($child);
# Start the server again
$child = start_server($srv);
}
# system.methodHelp with an invalid argument
$req->content(RPC::XML::request->new('system.methodHelp',
'system.bad')->as_string);
alarm(120);
$res = $UA->request($req);
alarm(0);
$res = ($res->is_error) ? '' : $parser->parse($res->content);
SKIP: {
skip "Server response was error, cannot test", 2 unless $res;
ok($res->value->is_fault(),
'system.methodHelp returned fault for unknown method');
like($res->value->string, qr/Method.*unknown/,
'system.methodHelp("system.bad") correct faultString');
}
# If the response was any kind of error, kill and re-start the server, as
# HTTP::Message::content might have killed it already via croak().
unless ($res) # $res was made null above if it was an error
{
stop_server($child);
# Start the server again
$child = start_server($srv);
}
# system.methodSignature
$req->content(RPC::XML::request->new('system.methodSignature',
'system.methodHelp')->as_string);
alarm(120);
$res = $UA->request($req);
alarm(0);
$res = ($res->is_error) ? '' : $parser->parse($res->content);
SKIP: {
skip "Server response was error, cannot test", 1 unless $res;
$meth = $srv->get_method('system.methodHelp');
if (! blessed $meth)
{
fail(failmsg($meth, __LINE__));
}
else
{
is(join('',
sort map { join(' ', @$_) }
@{ ref($res) ? $res->value->value : [] }),
join('', sort @{ $meth->{signature} }),
'system.methodSignature("system.methodHelp") test');
}
}
# If the response was any kind of error, kill and re-start the server, as
# HTTP::Message::content might have killed it already via croak().
unless ($res) # $res was made null above if it was an error
{
stop_server($child);
# Start the server again
$child = start_server($srv);
}
# system.methodSignature, with an invalid request
$req->content(RPC::XML::request->new('system.methodSignature',
'system.bad')->as_string);
alarm(120);
$res = $UA->request($req);
alarm(0);
$res = ($res->is_error) ? '' : $parser->parse($res->content);
SKIP: {
skip "Server response was error, cannot test", 2 unless $res;
ok($res->value->is_fault(),
'system.methodSignature returned fault for unknown method');
like($res->value->string, qr/Method.*unknown/,
'system.methodSignature("system.bad") correct faultString');
}
# If the response was any kind of error, kill and re-start the server, as
# HTTP::Message::content might have killed it already via croak().
unless ($res) # $res was made null above if it was an error
{
stop_server($child);
# Start the server again
$child = start_server($srv);
}
# system.introspection
$req->content(RPC::XML::request->new('system.introspection')->as_string);
alarm(120);
$res = $UA->request($req);
alarm(0);
$res = ($res->is_error) ? '' : $parser->parse($res->content);
SKIP: {
skip "Server response was error, cannot test", 1 unless $res;
if ($res->is_fault)
{
fail(failmsg($res->value->string, __LINE__));
}
else
{
$list = $res->value->value;
$bucket = 0;
%seen = ();
for $res (@$list)
{
if ($seen{$res->{name}}++)
{
# If we somehow get the same name twice, that is a point off
$bucket++;
next;
}
$meth = $srv->get_method($res->{name});
if ($meth)
{
$bucket++ unless
(($meth->{help} eq $res->{help}) &&
($meth->{version} eq $res->{version}) &&
(join('', sort @{ $res->{signature } }) eq
join('', sort @{ $meth->{signature} })));
}
else
{
# That is also a point
$bucket++;
}
}
ok(! $bucket, 'system.introspection passed with no errors');
}
}
# If the response was any kind of error, kill and re-start the server, as
# HTTP::Message::content might have killed it already via croak().
unless ($res) # $res was made null above if it was an error
{
stop_server($child);
# Start the server again
$child = start_server($srv);
}
# system.multicall
$req->content(RPC::XML::request->new('system.multicall',
[ { methodName => 'system.identity' },
{ methodName => 'system.listMethods',
params => [ 'intro' ] }
])->as_string);
alarm(120);
$res = $UA->request($req);
alarm(0);
$res = ($res->is_error) ? '' : $parser->parse($res->content);
SKIP: {
skip "Server response was error, cannot test", 2 unless $res;
if ($res->is_fault)
{
fail(failmsg($res->value->string, __LINE__));
fail(failmsg($res->value->string, __LINE__));
}
else
{
$res = $res->value->value;
is($res->[0], $srv->product_tokens,
'system.multicall response elt [0] is correct');
is((ref($res->[1]) eq 'ARRAY' ? $res->[1]->[0] : ''),
'system.introspection',
'system.multicall response elt [1][0] is correct');
}
}
# If the response was any kind of error, kill and re-start the server, as
# HTTP::Message::content might have killed it already via croak().
unless ($res) # $res was made null above if it was an error
{
stop_server($child);
# Start the server again
$child = start_server($srv);
}
# system.multicall, with an attempt at illegal recursion
$req->content(RPC::XML::request->new('system.multicall',
[ { methodName => 'system.identity' },
{ methodName => 'system.multicall',
params => [ 'intro' ] }
])->as_string);
alarm(120);
$res = $UA->request($req);
alarm(0);
$res = ($res->is_error) ? '' : $parser->parse($res->content);
SKIP: {
skip "Server response was error, cannot test", 2 unless $res;
$res = $res->value;
ok($res->is_fault,
'system.multicall returned fault on attempt at recursion');
like($res->string, qr/Recursive/,
'system.multicall recursion attempt set correct faultString');
}
# If the response was any kind of error, kill and re-start the server, as
# HTTP::Message::content might have killed it already via croak().
unless ($res) # $res was made null above if it was an error
{
stop_server($child);
# Start the server again
$child = start_server($srv);
}
# system.multicall, with bad data on one of the call specifications
$req->content(RPC::XML::request->new('system.multicall',
[ { methodName => 'system.identity' },
{ methodName => 'system.status',
params => 'intro' }
])->as_string);
alarm(120);
$res = $UA->request($req);
alarm(0);
$res = ($res->is_error) ? '' : $parser->parse($res->content);
SKIP: {
skip "Server response was error, cannot test", 2 unless $res;
$res = $res->value;
ok($res->is_fault,
'system.multicall returned fault when passed a bad param array');
like($res->string, qr/value for.*params.*not an array/i,
'system.multicall bad param array set correct faultString');
}
# If the response was any kind of error, kill and re-start the server, as
# HTTP::Message::content might have killed it already via croak().
unless ($res) # $res was made null above if it was an error
{
stop_server($child);
# Start the server again
$child = start_server($srv);
}
# system.multicall, with bad data in the request itself
$req->content(RPC::XML::request->new('system.multicall',
[ { methodName => 'system.identity' },
'This is not acceptable data'
])->as_string);
alarm(120);
$res = $UA->request($req);
alarm(0);
$res = ($res->is_error) ? '' : $parser->parse($res->content);
SKIP: {
skip "Server response was error, cannot test", 2 unless $res;
$res = $res->value;
ok($res->is_fault, 'system.multicall returned fault on bad input');
like($res->string, qr/one.*array element.*not a struct/i,
'system.multicall bad input set correct faultString');
}
# If the response was any kind of error, kill and re-start the server, as
# HTTP::Message::content might have killed it already via croak().
unless ($res) # $res was made null above if it was an error
{
stop_server($child);
# Start the server again
$child = start_server($srv);
}
# system.status, once more, to check the total_requests value
$req->content(RPC::XML::request->new('system.status')->as_string);
alarm(120);
$res = $UA->request($req);
alarm(0);
$res = ($res->is_error) ? '' : $parser->parse($res->content);
SKIP: {
skip "Server response was error, cannot test", 1 unless $res;
$res = $res->value->value;
is($res->{total_requests}, 20, 'system.status, final request tally');
}
# This time we have to stop the server regardless of whether the response was
# an error. We're going to add some more methods to test some of the error code
# and other bits in RPC::XML::Procedure.
stop_server($child);
$srv->add_method({
type => 'procedure',
name => 'argcount.p',
signature => [ 'int' ],
code => sub { return scalar(@_); },
});
$srv->add_method({
name => 'argcount.m',
signature => [ 'int' ],
code => sub { return scalar(@_); },
});
$srv->add_method({
type => 'function',
name => 'argcount.f',
code => sub { return scalar(@_); },
});
$srv->add_method({
name => 'die1',
signature => [ 'int' ],
code => sub { die "die\n"; },
});
$srv->add_method({
name => 'die2',
signature => [ 'int' ],
code => sub { die RPC::XML::fault->new(999, 'inner fault'); },
});
# Start the server again, with the new methods
$child = start_server($srv);
# First, call the argcount.? routines, to see that we are getting the correct
# number of args passed in. Up to now, everything running on $srv has been in
# the RPC::XML::Method class. This will test some of the other code.
my @returns = ();
for my $type (qw(p m f))
{
$req->content(RPC::XML::request->new("argcount.$type")->as_string);
$bucket = 0;
$SIG{ALRM} = sub { $bucket++ };
alarm 120;
$res = $UA->request($req);
alarm 0;
if ($bucket)
{
push @returns, 'timed-out';
}
else
{
$res = $parser->parse($res->content);
if (ref($res) ne 'RPC::XML::response')
{
push @returns, 'parse-error';
}
else
{
push @returns, $res->value->value;
}
}
}
# Finally, test what we got from those three calls:
is(join(q{,} => @returns), '0,1,0', 'Arg-count testing of procedure types');
# While we're at it... test that a ::Function can take any args list
$req->content(RPC::XML::request->new("argcount.f", 1, 1, 1)->as_string);
$bucket = 0;
$SIG{ALRM} = sub { $bucket++ };
alarm 120;
$res = $UA->request($req);
alarm 0;
SKIP: {
if ($bucket)
{
skip 'Second call to argcount.f timed out', 1;
}
else
{
$res = $parser->parse($res->content);
if (ref($res) ne 'RPC::XML::response')
{
skip 'Second call to argcount.f failed to parse', 1;
}
else
{
is($res->value->value, 3, 'A function takes any argslist');
}
}
}
# And test that those that aren't ::Function recognize bad parameter lists
$req->content(RPC::XML::request->new("argcount.p", 1, 1, 1)->as_string);
$bucket = 0;
$SIG{ALRM} = sub { $bucket++ };
alarm 120;
$res = $UA->request($req);
alarm 0;
SKIP: {
if ($bucket)
{
skip 'Second call to argcount.f timed out', 1;
}
else
{
$res = $parser->parse($res->content);
if (ref($res) ne 'RPC::XML::response')
{
skip 'Second call to argcount.f failed to parse', 1;
}
else
{
skip "Test did not return fault, cannot test", 2
if (! $res->is_fault);
is($res->value->code, 201,
'Bad params list test: Correct faultCode');
like($res->value->string,
qr/no matching signature for the argument list/,
'Bad params list test: Correct faultString');
}
}
}
# Test behavior when the called function throws an exception
my %die_tests = (
die1 => {
code => 300,
string => "Code execution error: Method die1 returned error: die\n",
},
die2 => {
code => 999,
string => 'inner fault',
},
);
for my $test (sort keys %die_tests)
{
$req->content(RPC::XML::request->new($test)->as_string);
$bucket = 0;
$SIG{ALRM} = sub { $bucket++ };
alarm 120;
$res = $UA->request($req);
alarm 0;
SKIP: {
if ($bucket)
{
skip "Test '$test' timed out, cannot test results", 2;
}
else
{
$res = $parser->parse($res->content);
if (ref($res) ne 'RPC::XML::response')
{
skip "Test '$test' failed to parse, cannot test results", 2;
}
else
{
skip "Test '$test' did not return fault, cannot test", 2
if (! $res->is_fault);
is($res->value->code, $die_tests{$test}{code},
"Test $test: Correct faultCode");
is($res->value->string, $die_tests{$test}{string},
"Test $test: Correct faultString");
}
}
}
}
# Don't leave any children laying around
stop_server($child);
exit;
RPC-XML-0.77/t/40_server_xmllibxml.t 000644 000765 000024 00000065213 11612471026 017363 0 ustar 00rjray staff 000000 000000 #!/usr/bin/perl
# Test the RPC::XML::Server class
use strict;
use subs qw(start_server find_port);
use vars qw($srv $res $bucket $child $parser $xml $req $port $UA @API_METHODS
$list $meth @keys %seen $dir $vol);
BEGIN
{
use Test::More;
eval "use XML::LibXML";
if ($@)
{
plan skip_all => "XML::LibXML not installed";
}
else
{
plan tests => 62;
}
}
use Socket;
use File::Spec;
use LWP::UserAgent;
use HTTP::Request;
use Scalar::Util 'blessed';
use RPC::XML 'RPC_BASE64';
require RPC::XML::Server;
require RPC::XML::ParserFactory;
@API_METHODS = qw(system.identity system.introspection system.listMethods
system.methodHelp system.methodSignature system.multicall
system.status);
($vol, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0));
$dir = File::Spec->catpath($vol, $dir, '');
require File::Spec->catfile($dir, 'util.pl');
sub failmsg { sprintf("%s at line %d", @_) }
# The organization of the test suites is such that we assume anything that
# runs before the current suite is 100%. Thus, no consistency checks on
# any other classes are done, only on the data and return values of this
# class under consideration, RPC::XML::Server. In this particular case, this
# also means that we cannot use RPC::XML::Client to test it.
# Start with some very basic things, without actually firing up a live server.
$srv = RPC::XML::Server->new(parser => [ class => 'XML::LibXML' ],
no_http => 1, no_default => 1);
isa_ok($srv, 'RPC::XML::Server', '$srv<1>');
isa_ok($srv->parser, 'RPC::XML::Parser::XMLLibXML', '$srv<1> parser');
# Suppress "used only once" warning
$_ = $RPC::XML::Server::VERSION;
is($srv->version, $RPC::XML::Server::VERSION,
'RPC::XML::Server::version method');
ok(! $srv->started, 'RPC::XML::Server::started method');
like($srv->product_tokens, qr|/|, 'RPC::XML::Server::product_tokens method');
ok(! $srv->url, 'RPC::XML::Server::url method (empty)');
ok(! $srv->requests, 'RPC::XML::Server::requests method (0)');
ok($srv->response->isa('HTTP::Response'),
'RPC::XML::Server::response method returns HTTP::Response');
# Done with this one, let it go
undef $srv;
# This one will have a HTTP::Daemon server, but still no default methods
die "No usable port found between 9000 and 10000, skipping"
if (($port = find_port) == -1);
$srv = RPC::XML::Server->new(no_default => 1,
parser => [ class => 'XML::LibXML' ],
host => 'localhost', port => $port);
isa_ok($srv, 'RPC::XML::Server', '$srv<2>');
# Test the URL the server uses. Allow for "localhost", "localhost.localdomain"
# or the local-net IP address of this host (not always 127.0.0.1).
# 22/09/2008 - Just allow for anything the user has attached to this address.
# Aliases keep causing this test to falsely fail.
my @localhostinfo = gethostbyname('localhost');
my $localIP = join('.', unpack('C4', $localhostinfo[4]));
my @allhosts = ($localIP, $localhostinfo[0], split(' ', $localhostinfo[1]));
for (@allhosts) { s/\./\\./g }
# Per RT 27778: For some reason gethostbyname('localhost') does not return
# "localhost" on win32
push @allhosts, 'localhost' if ($^O eq 'MSWin32' || $^O eq 'cygwin');
push @allhosts, 'localhost\.localdomain'
unless (grep(/localdomain/, @allhosts));
my $allhosts = join('|', @allhosts);
like($srv->url, qr{http://($allhosts):$port},
'RPC::XML::Server::url method (set)'); # This should be non-null this time
# Test some of the simpler cases of add_method and get_method
$res = $srv->add_method({ name => 'perl.test.suite.test1',
signature => [ 'int' ],
code => sub { return 1; } });
ok($res eq $srv, 'add_method return value test');
$res = $srv->get_method('perl.test.suite.test1');
isa_ok($res, 'RPC::XML::Method', 'get_method return value');
$res = $srv->get_method('perl.test.suite.not.added.yet');
ok(! ref($res), 'get_method for non-existent method');
# Here goes...
$parser = RPC::XML::ParserFactory->new;
$UA = LWP::UserAgent->new;
$req = HTTP::Request->new(POST => "http://localhost:$port/");
$child = start_server($srv);
$req->header(Content_Type => 'text/xml');
$req->content(RPC::XML::request->new('perl.test.suite.test1')->as_string);
# Use alarm() to manage a resaonable time-out on the request
$bucket = 0;
$SIG{ALRM} = sub { $bucket++ };
alarm(120);
$res = $UA->request($req);
alarm(0);
ok(! $bucket, 'First live-request returned without timeout');
SKIP: {
skip "Server failed to respond within 120 seconds!", 4 if $bucket;
ok(! $res->is_error, 'First live req: Check that $res is not an error');
$xml = $res->content;
$res = $parser->parse($xml);
isa_ok($res, 'RPC::XML::response', 'First live req: parsed $res');
SKIP: {
skip "Response content did not parse, cannot test", 2
unless (ref $res and $res->isa('RPC::XML::response'));
ok(! $res->is_fault, 'First live req: parsed $res is not a fault');
is($res->value->value, 1, 'First live req: $res value test');
}
}
stop_server($child);
# Try deleting the method
ok(ref $srv->delete_method('perl.test.suite.test1'),
'delete_method return value test');
# Start the server again
# Add a method that echoes back socket-peer information
$res = $srv->add_method({ name => 'perl.test.suite.peeraddr',
signature => [ 'array' ],
code =>
sub {
my $srv = shift;
my $ipaddr = inet_aton($srv->{peerhost});
my $peeraddr = RPC_BASE64 $srv->{peeraddr};
my $packet = pack_sockaddr_in($srv->{peerport},
$ipaddr);
$packet = RPC_BASE64 $packet;
[ $peeraddr, $packet,
$srv->{peerhost}, $srv->{peerport} ];
} });
$child = start_server($srv);
$bucket = 0;
$SIG{ALRM} = sub { $bucket++ };
alarm(120);
$res = $UA->request($req);
alarm(0);
ok(! $bucket, 'Second live-request returned without timeout');
SKIP: {
skip "Server failed to respond within 120 seconds!", 4 if $bucket;
ok(! $res->is_error, 'Second live req: Check that $res is not an error');
$res = $parser->parse($res->content);
isa_ok($res, 'RPC::XML::response', 'Second live req: parsed $res');
SKIP: {
skip "Response content did not parse, cannot test", 2
unless (ref $res and $res->isa('RPC::XML::response'));
ok($res->is_fault, 'Second live req: parsed $res is a fault');
like($res->value->value->{faultString}, qr/Unknown method/,
'Second live request: correct faultString');
}
}
stop_server($child);
# Start the server again
$child = start_server($srv);
$bucket = 0;
$req->content(RPC::XML::request->new('perl.test.suite.peeraddr')->as_string);
$SIG{ALRM} = sub { $bucket++ };
alarm(120);
$res = $UA->request($req);
alarm(0);
ok(! $bucket, 'Third live-request returned without timeout');
SKIP: {
skip "Server failed to respond within 120 seconds!", 4 if $bucket;
ok(! $res->is_error, 'Third live req: Check that $res is not an error');
$res = $parser->parse($res->content);
isa_ok($res, 'RPC::XML::response', 'Third live req: parsed $res');
SKIP: {
skip "Response content did not parse, cannot test", 3
unless (ref $res and $res->isa('RPC::XML::response'));
$res = $res->value->value;
is($res->[2], inet_ntoa(inet_aton('localhost')),
'Third live req: Correct IP addr from peerhost');
is($res->[0], inet_aton($res->[2]),
'Third request: peeraddr packet matches converted peerhost');
is($res->[1], pack_sockaddr_in($res->[3], inet_aton($res->[2])),
'Third request: pack_sockaddr_in validates all');
}
}
stop_server($child);
# Start the server again
$child = start_server($srv);
# Test the error-message-mixup problem reported in RT# 29351
# (http://rt.cpan.org/Ticket/Display.html?id=29351)
my $tmp = q{
test.methodfoobar};
$req->content($tmp);
$bucket = 0;
$SIG{ALRM} = sub { $bucket++ };
alarm(120);
$res = $UA->request($req);
alarm(0);
ok(! $bucket, 'RT29351 live-request returned without timeout');
SKIP: {
skip "Server failed to respond within 120 seconds!", 4 if $bucket;
ok(! $res->is_error, 'RT29351 live req: $res is not an error');
$res = $parser->parse($res->content);
isa_ok($res, 'RPC::XML::response', 'RT29351 live req: parsed $res');
SKIP: {
skip "Response content did not parse, cannot test", 2
unless (ref $res and $res->isa('RPC::XML::response'));
ok($res->is_fault, 'RT29351 live req: parsed $res is a fault');
like($res->value->value->{faultString}, qr/Too many child-nodes/,
'RT29351 live request: correct faultString');
}
}
stop_server($child);
# OK-- At this point, basic server creation and accessors have been validated.
# We've run a remote method and we've correctly failed to run an unknown remote
# method. Before moving into the more esoteric XPL-file testing, we will test
# the provided introspection API.
undef $srv;
undef $req;
die "No usable port found between 9000 and 10000, skipping"
if (($port = find_port) == -1);
$srv = RPC::XML::Server->new(parser => [ class => 'XML::LibXML' ],
host => 'localhost', port => $port);
# Did it create OK, with the requirement of loading the XPL code?
isa_ok($srv, 'RPC::XML::Server', '$srv<3> (with default methods)');
SKIP: {
skip "Failed to create RPC::XML::Server object with default methods", 3
unless ref($srv);
# Did it get all of them?
is($srv->list_methods(), scalar(@API_METHODS),
'Correct number of methods (defaults)');
$req = HTTP::Request->new(POST => "http://localhost:$port/");
$child = start_server($srv);
$req->header(Content_Type => 'text/xml');
$req->content(RPC::XML::request->new('system.listMethods')->as_string);
# Use alarm() to manage a reasonable time-out on the request
$bucket = 0;
undef $res;
$SIG{ALRM} = sub { $bucket++ };
alarm(120);
$res = $UA->request($req);
alarm(0);
SKIP: {
skip "Server failed to respond within 120 seconds!", 2 if $bucket;
$res = ($res->is_error) ? '' : $parser->parse($res->content);
isa_ok($res, 'RPC::XML::response', 'system.listMethods response');
SKIP: {
skip "Response content did not parse, cannot test", 1
unless (ref $res and $res->isa('RPC::XML::response'));
$list = (ref $res) ? $res->value->value : [];
ok((ref($list) eq 'ARRAY') &&
(join('', sort @$list) eq join('', sort @API_METHODS)),
'system.listMethods return list correct');
}
}
}
# Assume $srv is defined, for the rest of the tests (so as to avoid the
# annoying 'ok(0)' streams like above).
die "Server allocation failed, cannot continue. Message was: $srv"
unless (ref $srv);
stop_server($child);
# Start the server again
$child = start_server($srv);
# Set the ALRM handler to something more serious, since we have passed that
# hurdle already.
$SIG{ALRM} = sub { die "Server failed to respond within 120 seconds\n"; };
# Test the substring-parameter calling of system.listMethods
$req->content(RPC::XML::request->new('system.listMethods',
'method')->as_string);
alarm(120);
$res = $UA->request($req);
alarm(0);
$res = ($res->is_error) ? '' : $parser->parse($res->content);
SKIP: {
skip "Server response was error, cannot test", 1 unless $res;
$list = $res->value->value;
if ($res->is_fault)
{
fail(failmsg($res->value->string, __LINE__));
}
else
{
is(join(',', sort @$list),
'system.methodHelp,system.methodSignature',
'system.listMethods("method") return list correct');
}
}
# If the response was any kind of error, kill and re-start the server, as
# HTTP::Message::content might have killed it already via croak().
unless ($res) # $res was made null above if it was an error
{
stop_server($child);
# Start the server again
$child = start_server($srv);
}
# Run again, with a pattern that will produce no matches
$req->content(RPC::XML::request->new('system.listMethods',
'nomatch')->as_string);
alarm(120);
$res = $UA->request($req);
alarm(0);
$res = ($res->is_error) ? '' : $parser->parse($res->content);
SKIP: {
skip "Server response was error, cannot test", 1 unless $res;
$list = $res->value->value;
if ($res->is_fault)
{
fail(failmsg($res->value->string, __LINE__));
}
else
{
is(scalar(@$list), 0,
'system.listMethods("nomatch") return list correct');
}
}
# If the response was any kind of error, kill and re-start the server, as
# HTTP::Message::content might have killed it already via croak().
unless ($res) # $res was made null above if it was an error
{
stop_server($child);
# Start the server again
$child = start_server($srv);
}
# system.identity
$req->content(RPC::XML::request->new('system.identity')->as_string);
alarm(120);
$res = $UA->request($req);
alarm(0);
$res = ($res->is_error) ? '' : $parser->parse($res->content);
SKIP: {
skip "Server response was error, cannot test", 1 unless $res;
is($res->value->value, $srv->product_tokens, 'system.identity test');
}
# If the response was any kind of error, kill and re-start the server, as
# HTTP::Message::content might have killed it already via croak().
unless ($res) # $res was made null above if it was an error
{
stop_server($child);
# Start the server again
$child = start_server($srv);
}
# system.status
$req->content(RPC::XML::request->new('system.status')->as_string);
alarm(120);
$res = $UA->request($req);
alarm(0);
$res = ($res->is_error) ? '' : $parser->parse($res->content);
SKIP: {
skip "Server response was error, cannot test", 2 unless $res;
$res = $res->value->value;
@keys = qw(host port name version path date date_int started started_int
total_requests methods_known);
is(scalar(grep(defined $res->{$_}, @keys)), @keys,
'system.status hash has correct keys');
is($res->{total_requests}, 4,
'system.status reports correct total_requests');
}
# If the response was any kind of error, kill and re-start the server, as
# HTTP::Message::content might have killed it already via croak().
unless ($res) # $res was made null above if it was an error
{
stop_server($child);
# Start the server again
$child = start_server($srv);
}
# Test again, with a 'true' value passed to the method, which should prevent
# the 'total_requests' key from incrementing.
$req->content(RPC::XML::request->new('system.status',
RPC::XML::boolean->new(1))->as_string);
alarm(120);
$res = $UA->request($req);
alarm(0);
$res = ($res->is_error) ? '' : $parser->parse($res->content);
SKIP: {
skip "Server response was error, cannot test", 1 unless $res;
$res = $res->value->value;
is($res->{total_requests}, 4,
'system.status reports correct total_requests ("true" call)');
}
# If the response was any kind of error, kill and re-start the server, as
# HTTP::Message::content might have killed it already via croak().
unless ($res) # $res was made null above if it was an error
{
stop_server($child);
# Start the server again
$child = start_server($srv);
}
# system.methodHelp
$req->content(RPC::XML::request->new('system.methodHelp',
'system.identity')->as_string);
alarm(120);
$res = $UA->request($req);
alarm(0);
$res = ($res->is_error) ? '' : $parser->parse($res->content);
SKIP: {
skip "Server response was error, cannot test", 1 unless $res;
$meth = $srv->get_method('system.identity');
if (! blessed $meth)
{
fail(failmsg($meth, __LINE__));
}
else
{
is($res->value->value, $meth->{help},
'system.methodHelp("system.identity") test');
}
}
# If the response was any kind of error, kill and re-start the server, as
# HTTP::Message::content might have killed it already via croak().
unless ($res) # $res was made null above if it was an error
{
stop_server($child);
# Start the server again
$child = start_server($srv);
}
# system.methodHelp with multiple arguments
$req->content(RPC::XML::request->new('system.methodHelp',
[ 'system.identity',
'system.status' ])->as_string);
alarm(120);
$res = $UA->request($req);
alarm(0);
$res = ($res->is_error) ? '' : $parser->parse($res->content);
SKIP: {
skip "Server response was error, cannot test", 1 unless $res;
if ($res->is_fault)
{
fail(failmsg($res->value->string, __LINE__));
}
else
{
is(join('', @{ ref($res) ? $res->value->value : [] }),
$srv->get_method('system.identity')->{help} .
$srv->get_method('system.status')->{help},
'system.methodHelp("system.identity", "system.status") test');
}
}
# If the response was any kind of error, kill and re-start the server, as
# HTTP::Message::content might have killed it already via croak().
unless ($res) # $res was made null above if it was an error
{
stop_server($child);
# Start the server again
$child = start_server($srv);
}
# system.methodHelp with an invalid argument
$req->content(RPC::XML::request->new('system.methodHelp',
'system.bad')->as_string);
alarm(120);
$res = $UA->request($req);
alarm(0);
$res = ($res->is_error) ? '' : $parser->parse($res->content);
SKIP: {
skip "Server response was error, cannot test", 2 unless $res;
ok($res->value->is_fault(),
'system.methodHelp returned fault for unknown method');
like($res->value->string, qr/Method.*unknown/,
'system.methodHelp("system.bad") correct faultString');
}
# If the response was any kind of error, kill and re-start the server, as
# HTTP::Message::content might have killed it already via croak().
unless ($res) # $res was made null above if it was an error
{
stop_server($child);
# Start the server again
$child = start_server($srv);
}
# system.methodSignature
$req->content(RPC::XML::request->new('system.methodSignature',
'system.methodHelp')->as_string);
alarm(120);
$res = $UA->request($req);
alarm(0);
$res = ($res->is_error) ? '' : $parser->parse($res->content);
SKIP: {
skip "Server response was error, cannot test", 1 unless $res;
$meth = $srv->get_method('system.methodHelp');
if (! blessed $meth)
{
fail(failmsg($meth, __LINE__));
}
else
{
is(join('',
sort map { join(' ', @$_) }
@{ ref($res) ? $res->value->value : [] }),
join('', sort @{ $meth->{signature} }),
'system.methodSignature("system.methodHelp") test');
}
}
# If the response was any kind of error, kill and re-start the server, as
# HTTP::Message::content might have killed it already via croak().
unless ($res) # $res was made null above if it was an error
{
stop_server($child);
# Start the server again
$child = start_server($srv);
}
# system.methodSignature, with an invalid request
$req->content(RPC::XML::request->new('system.methodSignature',
'system.bad')->as_string);
alarm(120);
$res = $UA->request($req);
alarm(0);
$res = ($res->is_error) ? '' : $parser->parse($res->content);
SKIP: {
skip "Server response was error, cannot test", 2 unless $res;
ok($res->value->is_fault(),
'system.methodSignature returned fault for unknown method');
like($res->value->string, qr/Method.*unknown/,
'system.methodSignature("system.bad") correct faultString');
}
# If the response was any kind of error, kill and re-start the server, as
# HTTP::Message::content might have killed it already via croak().
unless ($res) # $res was made null above if it was an error
{
stop_server($child);
# Start the server again
$child = start_server($srv);
}
# system.introspection
$req->content(RPC::XML::request->new('system.introspection')->as_string);
alarm(120);
$res = $UA->request($req);
alarm(0);
$res = ($res->is_error) ? '' : $parser->parse($res->content);
SKIP: {
skip "Server response was error, cannot test", 1 unless $res;
if ($res->is_fault)
{
fail(failmsg($res->value->string, __LINE__));
}
else
{
$list = $res->value->value;
$bucket = 0;
%seen = ();
for $res (@$list)
{
if ($seen{$res->{name}}++)
{
# If we somehow get the same name twice, that is a point off
$bucket++;
next;
}
$meth = $srv->get_method($res->{name});
if ($meth)
{
$bucket++ unless
(($meth->{help} eq $res->{help}) &&
($meth->{version} eq $res->{version}) &&
(join('', sort @{ $res->{signature } }) eq
join('', sort @{ $meth->{signature} })));
}
else
{
# That is also a point
$bucket++;
}
}
ok(! $bucket, 'system.introspection passed with no errors');
}
}
# If the response was any kind of error, kill and re-start the server, as
# HTTP::Message::content might have killed it already via croak().
unless ($res) # $res was made null above if it was an error
{
stop_server($child);
# Start the server again
$child = start_server($srv);
}
# system.multicall
$req->content(RPC::XML::request->new('system.multicall',
[ { methodName => 'system.identity' },
{ methodName => 'system.listMethods',
params => [ 'intro' ] }
])->as_string);
alarm(120);
$res = $UA->request($req);
alarm(0);
$res = ($res->is_error) ? '' : $parser->parse($res->content);
SKIP: {
skip "Server response was error, cannot test", 2 unless $res;
if ($res->is_fault)
{
fail(failmsg($res->value->string, __LINE__));
fail(failmsg($res->value->string, __LINE__));
}
else
{
$res = $res->value->value;
is($res->[0], $srv->product_tokens,
'system.multicall response elt [0] is correct');
is((ref($res->[1]) eq 'ARRAY' ? $res->[1]->[0] : ''),
'system.introspection',
'system.multicall response elt [1][0] is correct');
}
}
# If the response was any kind of error, kill and re-start the server, as
# HTTP::Message::content might have killed it already via croak().
unless ($res) # $res was made null above if it was an error
{
stop_server($child);
# Start the server again
$child = start_server($srv);
}
# system.multicall, with an attempt at illegal recursion
$req->content(RPC::XML::request->new('system.multicall',
[ { methodName => 'system.identity' },
{ methodName => 'system.multicall',
params => [ 'intro' ] }
])->as_string);
alarm(120);
$res = $UA->request($req);
alarm(0);
$res = ($res->is_error) ? '' : $parser->parse($res->content);
SKIP: {
skip "Server response was error, cannot test", 2 unless $res;
$res = $res->value;
ok($res->is_fault,
'system.multicall returned fault on attempt at recursion');
like($res->string, qr/Recursive/,
'system.multicall recursion attempt set correct faultString');
}
# If the response was any kind of error, kill and re-start the server, as
# HTTP::Message::content might have killed it already via croak().
unless ($res) # $res was made null above if it was an error
{
stop_server($child);
# Start the server again
$child = start_server($srv);
}
# system.multicall, with bad data on one of the call specifications
$req->content(RPC::XML::request->new('system.multicall',
[ { methodName => 'system.identity' },
{ methodName => 'system.status',
params => 'intro' }
])->as_string);
alarm(120);
$res = $UA->request($req);
alarm(0);
$res = ($res->is_error) ? '' : $parser->parse($res->content);
SKIP: {
skip "Server response was error, cannot test", 2 unless $res;
$res = $res->value;
ok($res->is_fault,
'system.multicall returned fault when passed a bad param array');
like($res->string, qr/value for.*params.*not an array/i,
'system.multicall bad param array set correct faultString');
}
# If the response was any kind of error, kill and re-start the server, as
# HTTP::Message::content might have killed it already via croak().
unless ($res) # $res was made null above if it was an error
{
stop_server($child);
# Start the server again
$child = start_server($srv);
}
# system.multicall, with bad data in the request itself
$req->content(RPC::XML::request->new('system.multicall',
[ { methodName => 'system.identity' },
'This is not acceptable data'
])->as_string);
alarm(120);
$res = $UA->request($req);
alarm(0);
$res = ($res->is_error) ? '' : $parser->parse($res->content);
SKIP: {
skip "Server response was error, cannot test", 2 unless $res;
$res = $res->value;
ok($res->is_fault, 'system.multicall returned fault on bad input');
like($res->string, qr/one.*array element.*not a struct/i,
'system.multicall bad input set correct faultString');
}
# If the response was any kind of error, kill and re-start the server, as
# HTTP::Message::content might have killed it already via croak().
unless ($res) # $res was made null above if it was an error
{
stop_server($child);
# Start the server again
$child = start_server($srv);
}
# system.status, once more, to check the total_requests value
$req->content(RPC::XML::request->new('system.status')->as_string);
alarm(120);
$res = $UA->request($req);
alarm(0);
$res = ($res->is_error) ? '' : $parser->parse($res->content);
SKIP: {
skip "Server response was error, cannot test", 1 unless $res;
$res = $res->value->value;
is($res->{total_requests}, 20, 'system.status, final request tally');
}
# Don't leave any children laying around
stop_server($child);
exit;
RPC-XML-0.77/t/41_server_hang.t 000644 000765 000024 00000005107 11612471026 016265 0 ustar 00rjray staff 000000 000000 #!/usr/bin/perl
# Test the RPC::XML::Server bug that causes a hang when a client terminates in
# mid-message. Unlike 40_server.t, this isn't trying to fully exercise the
# server class, just looking for and (trying to) tickle a specific bug.
use strict;
use subs qw(start_server find_port);
use vars qw($dir $vol $srv $bucket $child $req $port $socket $body);
use File::Spec;
use Test::More tests => 2;
use LWP::UserAgent;
use HTTP::Request;
require RPC::XML::Server;
require IO::Socket;
($vol, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0));
$dir = File::Spec->catpath($vol, $dir, '');
require File::Spec->catfile($dir, 'util.pl');
{
package MyServer;
use strict;
our @ISA = qw(RPC::XML::Server);
sub process_request
{
my $self = shift;
$self->SUPER::process_request(@_);
exit 1;
}
}
SKIP: {
skip "This suite does not run on MSWin", 2 if ($^O eq "MSWin32");
$srv = MyServer->new(no_default => 1);
isa_ok($srv, 'RPC::XML::Server', 'Server instance');
$srv->add_method({ name => 'echo',
signature => [ 'string string' ],
code => sub { shift; return shift; } });
$port = $srv->port;
$req = HTTP::Request->new(POST => "http://localhost:$port/");
$body = RPC::XML::request->new('echo', 'foo')->as_string;
$req->content($body);
$req->protocol('HTTP/1.0');
$req->header(Content_Length => length($body));
$req->header(Content_Type => 'text/xml');
$req = $req->as_string;
substr($req, -32) = '';
$child = start_server($srv);
$bucket = 0;
$SIG{CHLD} = sub {
my $dead = wait;
if ($dead == $child)
{
$bucket = $? >> 8;
}
else
{
warn "PANIC: Unknown child return";
}
};
# Create an IO::Socket object for the client-side. In order to fool the
# server with a bad Content-Length and terminate early, we have to ditch
# LWP and go old-skool.
$socket = IO::Socket::INET->new(Proto => 'tcp', PeerAddr => 'localhost',
PeerPort => $port)
or die "Error creating IO::Socket obj: $!";
print $socket "$req";
# This *should* force the server to drop the request. The bug relates to
# the fact that (previously) the server just hangs:
close($socket);
# Give the server time to crap out:
sleep 95 unless $bucket;
# If it still hasn't, kill it:
$SIG{CHLD} = 'IGNORE';
kill 'KILL', $child unless $bucket;
is($bucket, 1, 'Check if server hangs on short requests');
}
exit;
RPC-XML-0.77/t/50_client.t 000644 000765 000024 00000020753 11612471026 015244 0 ustar 00rjray staff 000000 000000 #!/usr/bin/perl
# Test the RPC::XML::Client class
use strict;
use vars qw($dir $vol $srv $child $port $cli $res $flag);
use subs qw(start_server find_port);
use Test::More;
use LWP;
require File::Spec;
require RPC::XML::Server;
require RPC::XML::Client;
($vol, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0));
$dir = File::Spec->catpath($vol, $dir, '');
require File::Spec->catfile($dir, 'util.pl');
plan tests => 33;
# The organization of the test suites is such that we assume anything that
# runs before the current suite is 100%. Thus, no consistency checks on
# any other classes are done, only on the data and return values of this
# class under consideration, RPC::XML::Client. In this particular case, this
# means that we can safely use RPC::XML::Server in creating a suitable test
# environment.
# Start with some very basic things, before actually firing up a live server.
$cli = RPC::XML::Client->new();
ok(! ref $cli, 'RPC::XML::Client::new without endpoint fails');
like($cli, qr/Missing location argument/, 'Correct error message set');
die "No usable port found between 9000 and 10000, skipping"
if (($port = find_port) == -1);
$cli = RPC::XML::Client->new("http://localhost:$port");
$cli->timeout(5); #to prevent long waiting for non-existing server
isa_ok($cli, 'RPC::XML::Client', '$cli');
# With no server yet at that port, test the failure modes
ok((! $cli->simple_request('system.identity')) && $RPC::XML::ERROR,
'Calling a server method without a server sets $RPC::XML::ERROR');
ok(! ref($cli->send_request('system.identity')),
'send_request returns a non-ref value when there is no server');
$res = $cli->send_request();
ok(! ref $res, 'Call to send_request without a method name fails');
like($res, qr/No request object/, 'Correct error message set');
$res = $cli->send_request('bad^method');
ok(! ref $res, 'Call to send_request with a bad method name fails');
like($res, qr/Error creating RPC::XML::request object/,
'Correct error message set');
# Test the error-handling callback
$cli->error_handler(sub { $res++ });
$res = 0;
$cli->simple_request('system.identity');
ok($res, 'error_handler callback system');
# Test clearing it
$cli->error_handler(undef);
$res = 0;
$cli->simple_request('system.identity');
ok(! $res, 'Clearing the error_handler callback system');
# Test setting and clearing both with combined_handler
$cli->combined_handler(sub { 1 });
ok($cli->error_handler() && ($cli->error_handler() eq $cli->fault_handler()),
'combined_handler set both error_handler and fault_handler');
$cli->combined_handler(undef);
ok(! ($cli->error_handler() or $cli->fault_handler()),
'combined_handler clears both error_handler and fault_handler');
# Check the getting/setting of the timeout() value on the underlying UA
is($cli->timeout(), $cli->useragent->timeout(),
'Client timeout() method, fetching');
$cli->timeout(60);
is($cli->useragent->timeout(), 60, 'Client timeout() method, setting');
# Cool so far. Create and spawn the server.
$srv = RPC::XML::Server->new(host => 'localhost', port => $port);
die "Failed to create server: $srv, stopped" unless (ref $srv);
$child = start_server($srv);
# NOW, this should work. Also, set $RPC::XML::ERROR to see if it clears
$RPC::XML::ERROR = 'foo';
is($cli->simple_request('system.identity'), $srv->product_tokens,
'simple_request/system.identity returns correct value');
ok(! $RPC::XML::ERROR,
'simple_request/system.identity left $RPC::XML::ERROR empty');
# Using send_request should yield an RPC::XML::string object with that value
$res = $cli->send_request('system.identity');
isa_ok($res, 'RPC::XML::string', 'system.identity response');
SKIP: {
skip 'Client response not a RPC::XML data object', 1
unless ref $res;
is($res->value, $srv->product_tokens,
'system.identity response is correct');
}
unless (ref $res)
{
# Assume that if an error occurred, the server might be in a confused
# state. Kill and restart it.
stop_server($child);
$child = start_server($srv);
}
# See what comes back from bad (but successful) calls
$res = $cli->simple_request('system.bad');
isa_ok($res, 'HASH', 'simple_request/system.bad response');
SKIP: {
skip 'Client response was not a RPC::XML data object', 2
unless ref $res;
is(join(';', sort keys %$res), 'faultCode;faultString',
'simple_request/system.bad hashref has correct keys');
like($res->{faultString}, qr/Unknown method/,
'simple_request/system.bad set correct faultString');
}
unless (ref $res)
{
# Assume that if an error occurred, the server might be in a confused
# state. Kill and restart it.
stop_server($child);
$child = start_server($srv);
}
# As opposed to a fault object:
$res = $cli->send_request('system.bad');
isa_ok($res, 'RPC::XML::fault', 'send_request/system.bad response');
SKIP: {
skip 'Client response not a RPC::XML data object', 1
unless ref $res;
like($res->string, qr/Unknown method/,
'send_request/system.bad set correct string() property');
}
unless (ref $res)
{
# Assume that if an error occurred, the server might be in a confused
# state. Kill and restart it.
stop_server($child);
$child = start_server($srv);
}
# Give the fault handler a whirl -- note the return value is the fault object
$cli->fault_handler(sub { $flag++ if ((ref($_[0]) eq 'RPC::XML::fault') &&
($_[0]->string =~ /Unknown method/));
$_[0] });
$flag = 0;
$res = $cli->send_request('system.bad');
# Did the callback run correctly?
ok($flag, 'fault_handler correctly set $flag');
# Is the value returned correct?
isa_ok($res, 'RPC::XML::fault', 'fault_handler returned value');
SKIP: {
skip 'Client response not a RPC::XML data object', 1
unless ref $res;
like($res->string, qr/Unknown method/,
'fault_handler object has correct faultString');
}
unless (ref $res)
{
# Assume that if an error occurred, the server might be in a confused
# state. Kill and restart it.
stop_server($child);
$child = start_server($srv);
}
# Last tests-- is the url() method working?
like($cli->uri, qr|http://localhost(\.localdomain)?:$port/?|,
'RPC::XML::Client::uri method return value is correct');
# does calling it as an accesor change it at all?
$cli->uri('http://www.oreilly.com/RPC');
is($cli->uri, 'http://www.oreilly.com/RPC',
'RPC::XML::Client::uri changes as expected');
# Kill the server long enough to add a new method
stop_server($child);
use Digest::MD5;
$srv->add_method({ name => 'cmpImg',
signature => [ 'boolean base64 base64' ],
code => sub {
my ($self, $img1, $img2) = @_;
return (Digest::MD5::md5_hex($img1) eq
Digest::MD5::md5_hex($img2));
} });
$child = start_server($srv);
use Symbol;
my ($fh1, $fh2) = (gensym, gensym);
SKIP: {
skip 'Message-to-file spooling broken with LWP < 5.801', 4
unless ($LWP::VERSION > 5.800);
open($fh1, '<' . File::Spec->catfile($dir, 'svsm_text.gif'));
open($fh2, '<' . File::Spec->catfile($dir, 'svsm_text.gif'));
SKIP: {
skip "Error opening svsm_text.gif: $!", 4
unless ($fh1 and $fh2);
# Setting the size threshhold to the size of the GIF will guarantee a
# file spool, since we're sending the GIF twice.
$cli->message_file_thresh(-s $fh1);
$cli->message_temp_dir($dir);
$cli->uri("http://localhost:$port/");
$res = $cli->send_request(cmpImg =>
RPC::XML::base64->new($fh1),
RPC::XML::base64->new($fh2));
isa_ok($res, 'RPC::XML::boolean', 'cmpImg return value');
SKIP: {
skip 'Client response not a RPC::XML data object', 1
unless ref($res);
ok($res->value, 'cmpImg, file spooling, correct return');
}
# Force the compression threshhold down, to test that branch
$cli->compress_requests(1);
$cli->compress_thresh(-s $fh1);
$res = $cli->send_request(cmpImg =>
RPC::XML::base64->new($fh1),
RPC::XML::base64->new($fh2));
isa_ok($res, 'RPC::XML::boolean', 'cmpImg return value');
SKIP: {
skip 'Client response not a RPC::XML data object', 1
unless ref($res);
ok($res->value, 'cmpImg, file spooling, correct return');
}
}
}
# Kill the server before exiting
stop_server($child);
exit;
RPC-XML-0.77/t/51_client_with_host_header.t 000644 000765 000024 00000002177 11622334117 020645 0 ustar 00rjray staff 000000 000000 #!/usr/bin/perl
# Test the ability of requests to specify their own Host: header
use strict;
use warnings;
use HTTP::Request;
use Test::More;
plan tests => 2;
sub clone_with_host_header
{
my $req = shift;
my $reqclone = $req->clone;
unless ($reqclone->header('Host'))
{
$reqclone->header(Host => URI->new($reqclone->uri)->host);
}
return $reqclone;
}
subtest "without_host_header" => sub {
plan tests => 2;
my $req = HTTP::Request->new(POST => 'http://example.com');
ok(! $req->header('Host'), 'Host: header not set');
my $reqclone = clone_with_host_header($req);
is($reqclone->header('Host'), 'example.com', 'Host: header set properly');
};
subtest "with_host_header" => sub {
plan tests => 3;
my $req = HTTP::Request->new(POST => 'http://example.com');
ok(! $req->header('Host'), 'Host: header not set');
$req->header('Host', 'google.com');
is($req->header('Host'), 'google.com', 'Host: header set properly');
my $reqclone = clone_with_host_header($req);
is($reqclone->header('Host'), 'google.com',
'Host: header in clone is correct');
};
exit;
RPC-XML-0.77/t/60_net_server.t 000644 000765 000024 00000022277 11612471026 016146 0 ustar 00rjray staff 000000 000000 #!/usr/bin/perl
# Test the RPC::XML::Server class with Net::Server rather than HTTP::Daemon
# This is run after the test suite for RPC::XML::Client, so we will use that
# for the client-side of the tests.
use strict;
use vars qw($dir $srv $pid_file $log_file $port $client $res @keys $meth $list
$bucket %seen);
use subs qw(start_server find_port);
use File::Spec;
use Test::More;
eval "use Net::Server";
# If they do not have Net::Server, quietly skip
plan skip_all => 'Net::Server not available' if $@;
# ...or if they are on Windows, skip
plan skip_all => 'Net::Server tests not reliable on Windows platform'
if ($^O eq "MSWin32");
# otherwise...
plan tests => 30;
require RPC::XML::Server;
require RPC::XML::Client;
(undef, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0));
require File::Spec->catfile($dir, 'util.pl');
$pid_file = File::Spec->catfile($dir, 'net_server.pid');
$log_file = File::Spec->catfile($dir, 'net_server.log');
die "No usable port found between 9000 and 10000, skipping"
if (($port = find_port) == -1);
unlink $log_file if (-e $log_file);
unlink $pid_file if (-e $pid_file);
# All this, and we haven't even created a server object or run a test yet
$srv = RPC::XML::Server->new(no_http => 1);
# Technically, this is overkill. But if it fails everything else blows up:
isa_ok($srv, 'RPC::XML::Server');
# All of these parameters are passed to the run() method of
# Net::Server::MultiType
start_server($srv,
server_type => 'Single',
log_file => $log_file,
log_level => 4,
pid_file => $pid_file,
port => $port,
host => 'localhost',
background => 1);
sleep 1; # Allow time for server to spin up
# Unless we see "ok 2", we have a problem
ok(-e $pid_file, 'server started, PID file exists');
# After this point, we have the obligation of killing the server manually
$client = RPC::XML::Client->new("http://localhost:$port");
is($client->simple_request('system.identity'), $srv->product_tokens,
'system.identity matches $srv->product_tokens');
# At this point, most of this is copied from the first server test suite (40).
# We do want to verify the full introspection API under Net::Server, though.
$res = $client->simple_request('system.listMethods');
@keys = $srv->list_methods;
is(ref($res), 'ARRAY', 'system.listMethods returned ARRAY ref');
SKIP: {
skip 'server response not an ARRAY reference', 2 unless ref($res);
is(scalar(@$res), scalar(@keys),
'system.listMethods returned correct number of names');
is(join('', sort @$res), join('', sort @keys),
'system.listMethods returned matching set of names');
}
# Test the substring-parameter calling of system.listMethods
$res = $client->simple_request('system.listMethods', 'method');
is(ref($res), 'ARRAY', 'system.listMethods returned ARRAY ref');
SKIP: {
skip 'server response not an ARRAY reference', 1 unless ref($res);
is(join(',', sort @$res), 'system.methodHelp,system.methodSignature',
'system.listMethods with pattern returned correct set of names');
}
# Again, with a pattern that will produce no matches
$res = $client->simple_request('system.listMethods', 'none_will_match');
is(ref($res), 'ARRAY', 'system.listMethods returned ARRAY ref');
SKIP: {
skip 'server response not an ARRAY reference', 1 unless ref($res);
is(scalar(@$res), 0, 'system.listMethods with bad pattern returned none');
}
# system.status
$res = $client->simple_request('system.status');
@keys = qw(host port name version path date date_int started started_int
total_requests methods_known);
is(ref($res), 'HASH', 'system.listMethods returned HASH ref');
SKIP: {
skip 'server response not a HASH reference', 2 unless ref($res);
is(scalar(grep(defined $res->{$_}, @keys)), scalar(@keys),
'system.status hashref has correct number of keys');
is($res->{total_requests}, 5, 'system.status total_request count correct');
}
# system.methodHelp
$res = $client->simple_request('system.methodHelp', 'system.identity');
is($res, $srv->get_method('system.identity')->{help},
'system.methodHelp returned correct string');
# system.methodHelp with multiple arguments
$res = $client->simple_request('system.methodHelp',
[ 'system.identity', 'system.status' ]);
is(ref($res), 'ARRAY', 'system.methodHelp returned ARRAY ref');
SKIP: {
skip 'server response not an ARRAY reference', 1 unless ref($res);
is(join('', @$res),
$srv->get_method('system.identity')->{help} .
$srv->get_method('system.status')->{help},
'system.methodHelp with specific methods returns correctly');
}
# system.methodHelp with an invalid argument
$res = $client->send_request('system.methodHelp', 'system.bad');
isa_ok($res, 'RPC::XML::fault', 'system.methodHelp (bad arg) response');
SKIP: {
skip 'server response not an RPC::XML data object', 1 unless ref($res);
like($res->string(), qr/Method.*unknown/,
'system.methodHelp (bad arg) has correct faultString');
}
# system.methodSignature
$res = $client->simple_request('system.methodSignature', 'system.methodHelp');
is(ref($res), 'ARRAY', 'system.methodHelp returned ARRAY ref');
SKIP: {
skip 'server response not an ARRAY reference', 1 unless ref($res);
is(join('', sort (map { join(' ', @$_) } @$res)),
join('', sort @{ $srv->get_method('system.methodHelp')->{signature} }),
'system.methodSignature return value correct');
}
# system.methodSignature, with an invalid request
$res = $client->send_request('system.methodSignature', 'system.bad');
isa_ok($res, 'RPC::XML::fault', 'system.methodSignature (bad arg) response');
SKIP: {
skip 'server response not an RPC::XML data object', 1 unless ref($res);
like($res->string(), qr/Method.*unknown/,
'system.methodSignature (bad arg) has correct faultString');
}
# system.introspection
$list = $client->simple_request('system.introspection');
$bucket = 0;
%seen = ();
SKIP: {
skip 'system.introspection call did not return ARRAY ref', 1
unless (ref($list) eq 'ARRAY');
for $res (@$list)
{
if ($seen{$res->{name}}++)
{
# If we somehow get the same name twice, that's a point off
$bucket++;
next;
}
$meth = $srv->get_method($res->{name});
if ($meth)
{
$bucket++ unless
(($meth->{help} eq $res->{help}) &&
($meth->{version} eq $res->{version}) &&
(join('', sort @{ $res->{signature } }) eq
join('', sort @{ $meth->{signature} })));
}
else
{
# That's a point
$bucket++;
}
}
ok(! $bucket, 'system.introspection return data is correct');
}
# system.multicall
$res = $client->simple_request('system.multicall',
[ { methodName => 'system.identity' },
{ methodName => 'system.listMethods',
params => [ 'intro' ] } ]);
is(ref($res), 'ARRAY', 'system.methodHelp returned ARRAY ref');
SKIP: {
skip 'server response not an ARRAY reference', 2 unless ref($res);
is($res->[0], $srv->product_tokens,
'system.multicall, first return value correct');
SKIP: {
skip 'system.multicall return value second index not ARRAY ref', 1
unless (ref($res->[1]) eq 'ARRAY');
is(scalar(@{$res->[1]}), 1,
'system.multicall, second return value correct length');
is($res->[1]->[0], 'system.introspection',
'system.multicall, second return value correct value');
}
}
# system.multicall, with an attempt at illegal recursion
$res = $client->send_request('system.multicall',
[ { methodName => 'system.identity' },
{ methodName => 'system.multicall',
params => [ 'intro' ] } ]);
SKIP: {
skip 'system.multicall (recursion) response error, cannot test', 1 unless
(ref($res) eq 'RPC::XML::fault');
like($res->string, qr/Recursive/,
'system.multicall recursion attempt set correct faultString');
}
# system.multicall, with bad data on one of the call specifications
$res = $client->send_request('system.multicall',
[ { methodName => 'system.identity' },
{ methodName => 'system.listMethods',
params => 'intro' } ]);
SKIP: {
skip 'system.multicall (bad data) response error, cannot test', 1 unless
(ref($res) eq 'RPC::XML::fault');
like($res->string, qr/value for.*params.*not an array/i,
'system.multicall bad param array set correct faultString');
}
# system.status, once more, to check the total_requests value
$res = $client->simple_request('system.status');
SKIP: {
skip 'system.status response not HASH ref', 1 unless (ref($res) eq 'HASH');
is($res->{total_requests}, 19,
'system.status total_request correct at end of suite');
}
# Now that we're done, kill the server and exit
open(my $fh, "< $pid_file");
chomp(my $pid = <$fh>);
if ($pid =~ /^(\d+)$/)
{
kill 'INT', $1;
}
else
{
warn "WARNING: $pid_file appears corrupt, zombie processes may remain!\n";
}
exit;
RPC-XML-0.77/t/70_compression_detect.t 000644 000765 000024 00000004457 11612471026 017664 0 ustar 00rjray staff 000000 000000 #!/usr/bin/perl
# Test whether the client and server classes correctly detect the presence
# or absence of compression support.
use strict;
use warnings;
use vars qw($compression_available %TEST_PKGS);
use Symbol 'delete_package';
use Test::More;
# First, determine if we actually *do* have Compress::Zlib available:
eval { require Compress::Zlib; };
$compression_available = ($@) ? 0 : 1;
# These are the modules that need to correctly detect compression:
%TEST_PKGS = ( 'RPC::XML::Client' => 'RPC/XML/Client.pm',
'RPC::XML::Server' => 'RPC/XML/Server.pm' );
plan tests => (2 * (scalar keys %TEST_PKGS));
# Clear out Compress::Zlib so it'll try to load again:
clear('Compress::Zlib', 'Compress/Zlib.pm');
# If compression is truly not available, just test that the modules correctly
# detect this. Otherwise, get crafty.
# Start by testing failure-to-detect
unshift(@INC, sub {
die "Force-failing Compress::Zlib" if ($_[1] eq 'Compress/Zlib.pm');
return undef;
}) if ($compression_available);
for my $pkg (sort keys %TEST_PKGS)
{
no strict 'refs';
eval "require $pkg;";
is(${"${pkg}::COMPRESSION_AVAILABLE"}, '',
"$pkg correctly saw no Compress::Zlib");
# Remove from %INC so later tests still run
clear($pkg, $TEST_PKGS{$pkg});
}
SKIP: {
# Test successful detection, but only if we actually have Compress::Zlib
skip 'Compress::Zlib truly not available', (scalar keys %TEST_PKGS)
unless $compression_available;
shift(@INC); # Drop the force-failure sub from above
for my $pkg (sort keys %TEST_PKGS)
{
no strict 'refs';
clear('Compress::Zlib', 'Compress/Zlib.pm');
for (qw(deflate flush inflate))
{
clear('Compress::Zlib', 'Compress/Zlib.pm', $_);
}
eval "require $pkg;";
# I am not explicitly testing for "deflate" here, because that might
# change in the future. What matters is that it is not null.
isnt(${"${pkg}::COMPRESSION_AVAILABLE"}, '',
"$pkg correctly detected Compress::Zlib");
}
}
exit;
sub clear
{
no strict 'refs';
my ($pkg, $file, $name) = @_;
delete $INC{$file};
delete_package($pkg);
if ($pkg eq 'Compress::Zlib')
{
delete_package 'Zlib::OldDeflate';
delete_package 'Zlib::OldInflate';
}
}
RPC-XML-0.77/t/90_rt50013_parser_bugs.t 000644 000765 000024 00000000724 11612471026 017400 0 ustar 00rjray staff 000000 000000 #!/usr/bin/perl
# https://rt.cpan.org/Ticket/Display.html?id=50013
#
# Ensure that RPC::XML::Parser::new() maintains backwards-compatibility
use strict;
use vars qw($parser);
use Test::More tests => 2;
use RPC::XML::Parser;
# Since the changed behaviour was to die, to be safe use eval here
eval { $parser = RPC::XML::Parser->new(); };
isa_ok($parser, 'RPC::XML::Parser', 'Parser object');
isa_ok($parser, 'RPC::XML::Parser::XMLParser', 'Parser object');
exit;
RPC-XML-0.77/t/90_rt54183_sigpipe.t 000644 000765 000024 00000003715 11624614130 016541 0 ustar 00rjray staff 000000 000000 #!/usr/bin/perl
# http://rt.cpan.org/Ticket/Display.html?id=54183
#
# Test that the RPC::XML::Server class can handle SIGPIPE issues
use strict;
use vars qw($dir $vol $srv $child $port $cli $res);
use subs qw(start_server stop_server find_port);
use Test::More;
require File::Spec;
require RPC::XML::Server;
require RPC::XML::Client;
# This suite doesn't run on Windows, since it's based on *NIX signals
if ($^O eq 'MSWin32' || $^O eq 'cygwin')
{
plan skip_all => 'Skipping *NIX signals-based test on Windows platform';
exit;
}
($vol, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0));
$dir = File::Spec->catpath($vol, $dir, '');
require File::Spec->catfile($dir, 'util.pl');
if (($port = find_port) == -1)
{
plan skip_all => "No usable port found between 9000 and 10000";
}
else
{
$srv = RPC::XML::Server->new(host => 'localhost', port => $port);
if (! ref $srv)
{
plan skip_all => "Creating server failed: $srv"
}
else
{
plan tests => 4;
}
}
$cli = RPC::XML::Client->new("http://localhost:$port");
$srv->add_method({
name => 'test',
signature => [ 'string' ],
code => sub {
my ($server) = @_;
sleep 3;
return 'foo';
}
});
$child = start_server($srv);
eval {
local $SIG{ALRM} = sub { die "alarm\n" };
alarm(1);
$res = $cli->send_request('test');
alarm(0); # Shouldn't reach here
};
like($res, qr/alarm/, 'Initial request alarmed-out correctly');
eval {
local $SIG{ALRM} = sub { die "alarm\n" };
alarm(6);
$res = $cli->send_request('test');
alarm(0); # Shouldn't reach here
};
unlike($res, qr/alarm/, 'Second request did not alarm-out');
ok(ref($res) && $res->value eq 'foo', 'Second request correct value');
eval {
local $SIG{ALRM} = sub { die "alarm\n" };
alarm(2);
$res = $cli->send_request('system.status');
alarm(0);
};
ok(ref($res) && ref($res->value) eq 'HASH',
'Good system.status return');
stop_server($child);
exit;
RPC-XML-0.77/t/90_rt54494_blessed_refs.t 000644 000765 000024 00000002531 11612471026 017543 0 ustar 00rjray staff 000000 000000 #!/usr/bin/perl
# https://rt.cpan.org/Ticket/Display.html?id=54494
#
# Test that smart_encode() in RPC::XML can correctly deal with blessed refs
# by treating them as non-blessed.
use strict;
use vars qw($val $obj);
use Test::More tests => 8;
use RPC::XML ':all';
$val = bless { integer => 10, string => 'foo' }, 'BlessedHash';
eval { $obj = smart_encode($val); };
isa_ok($obj, 'RPC::XML::struct', '$obj');
SKIP: {
skip 'Blessed hash did not encode', 2
unless (ref($obj) eq 'RPC::XML::struct');
my $value = $obj->value;
is($value->{integer}, 10, 'Converted hash integer value');
is($value->{string}, 'foo', 'Converted hash string value');
}
$val = bless [ 10, 'foo' ], 'BlessedArray';
eval { $obj = smart_encode($val); };
isa_ok($obj, 'RPC::XML::array', '$obj');
SKIP: {
skip 'Blessed array did not encode', 2
unless (ref($obj) eq 'RPC::XML::array');
my $value = $obj->value;
is($value->[0], 10, 'Converted array integer value');
is($value->[1], 'foo', 'Converted array string value');
}
$val = bless \do { my $elt = 'foo' }, 'BlessedScalar';
eval { $obj = smart_encode($val); };
isa_ok($obj, 'RPC::XML::string', '$obj');
SKIP: {
skip 'Blessed scalar did not encode', 1
unless (ref($obj) eq 'RPC::XML::string');
my $value = $obj->value;
is($value, 'foo', 'Converted scalar value');
}
exit;
RPC-XML-0.77/t/90_rt58065_allow_nil.t 000644 000765 000024 00000005316 11612471026 017065 0 ustar 00rjray staff 000000 000000 #!/usr/bin/perl
# https://rt.cpan.org/Ticket/Display.html?id=58065
#
# Test that the parser-factory instance classes allow the parsing of the
# tag whether $RPC::XML::ALLOW_NIL is set or not. This is to allow
# liberal acceptance of the tag in what we take in. Production of the tag is
# still limited to only when the flag is set.
use strict;
use vars qw($parser $req_message $res_message $parsed);
use Test::More tests => 8;
# Use classes from here directly to create test messages for parsing
use RPC::XML;
# This factory-class-instance should always be present
require RPC::XML::Parser::XMLParser;
# This one may not be present
my $can_libxml = eval {
require RPC::XML::Parser::XMLLibXML;
1;
};
# Create mock request and response messages that contain nils in them by first
# setting the flag. We'll then unset the flag for the tests.
$RPC::XML::ALLOW_NIL = 1;
$req_message = RPC::XML::request->new(
'foo',
RPC::XML::nil->new()
);
$res_message = RPC::XML::response->new(
RPC::XML::nil->new()
);
$RPC::XML::ALLOW_NIL = 0;
# To test this, instantiate each parser then call the ->parse() method with
# both the request and response message that contain nil tags.
# First test the class we always have, RPC::XML::Parser::XMLParser
$parser = RPC::XML::Parser::XMLParser->new();
# Test-parse the request message
$parsed = $parser->parse($req_message->as_string);
isa_ok($parsed, 'RPC::XML::request');
SKIP: {
skip 'Parsed value corrupted, cannot test nil value', 1
unless (ref($parsed) eq 'RPC::XML::request');
isa_ok($parsed->args->[0], 'RPC::XML::nil');
}
# Test-parse the response message
$parsed = $parser->parse($res_message->as_string);
isa_ok($parsed, 'RPC::XML::response');
SKIP: {
skip 'Parsed value corrupted, cannot test nil value', 1
unless (ref($parsed) eq 'RPC::XML::response');
isa_ok($parsed->value, 'RPC::XML::nil');
}
# Next, test RPC::XML::Parser::XMLLibXML (which we might not have)
SKIP: {
skip 'XML::LibXML not installed', 4
unless $can_libxml;
$parser = RPC::XML::Parser::XMLLibXML->new();
# Test-parse the request message
$parsed = $parser->parse($req_message->as_string);
isa_ok($parsed, 'RPC::XML::request');
SKIP: {
skip 'Parsed value corrupted, cannot test nil value', 1
unless (ref($parsed) eq 'RPC::XML::request');
isa_ok($parsed->args->[0], 'RPC::XML::nil');
}
# Test-parse the response message
$parsed = $parser->parse($res_message->as_string);
isa_ok($parsed, 'RPC::XML::response');
SKIP: {
skip 'Parsed value corrupted, cannot test nil value', 1
unless (ref($parsed) eq 'RPC::XML::response');
isa_ok($parsed->value, 'RPC::XML::nil');
}
}
exit;
RPC-XML-0.77/t/90_rt58323_push_parser.t 000644 000765 000024 00000002751 11612471026 017435 0 ustar 00rjray staff 000000 000000 #!/usr/bin/perl
# https://rt.cpan.org/Ticket/Display.html?id=58323
#
# Test that the parser-factory instance classes correctly cause errors when
# passed null strings or 0 as an argument to parse().
use strict;
use vars qw($parser $eval_result $parse_result);
use Test::More tests => 4;
# This factory-class-instance should always be present
require RPC::XML::Parser::XMLParser;
# This one may not be present
my $can_libxml = eval {
require RPC::XML::Parser::XMLLibXML;
1;
};
# To test this, instantiate each parser then call the ->parse() method with
# both a null string and with 0 as an argument. Each call should throw an
# error about failed parsing. If they don't, the test has failed.
# First test the class we always have, RPC::XML::Parser::XMLParser
$parser = RPC::XML::Parser::XMLParser->new();
# Empty string
$parse_result = $parser->parse(q{});
ok(! ref($parse_result), 'RPC::XML::Parser::XMLParser null string');
# Zero
$parse_result = $parser->parse(0);
ok(! ref($parse_result), 'RPC::XML::Parser::XMLParser zero value');
# Next, test RPC::XML::Parser::XMLLibXML (which we might not have)
SKIP: {
skip 'XML::LibXML not installed', 2
unless $can_libxml;
$parser = RPC::XML::Parser::XMLLibXML->new();
# Empty string
$parse_result = $parser->parse(q{});
ok(! ref($parse_result), 'RPC::XML::Parser::XMLLibXML null string');
# Zero
$parse_result = $parser->parse(0);
ok(! ref($parse_result), 'RPC::XML::Parser::XMLLibXML zero value');
}
exit;
RPC-XML-0.77/t/BadParserClass.pm 000644 000765 000024 00000000144 11612471026 016454 0 ustar 00rjray staff 000000 000000 # This is a dummy class used only for testing RPC::XML::ParserFactory.
package BadParserClass;
1;
RPC-XML-0.77/t/meth_bad_1.xpl 000644 000765 000024 00000001465 11612471026 016004 0 ustar 00rjray staff 000000 000000
system.identity1.0
Return the server name and version as a string
###############################################################################
#
# Sub Name: identity
#
# Description: Simply returns the server's identity as a string
#
# Arguments: First arg is server instance
#
# Globals: None.
#
# Returns: string
#
###############################################################################
sub identity
{
use strict;
sprintf('%s/%s', ref($_[0]), $_[0]->version);
}
RPC-XML-0.77/t/meth_bad_2.xpl 000644 000765 000024 00000001513 11612471026 015777 0 ustar 00rjray staff 000000 000000
system.identity1.0string
Return the server name and version as a string
###############################################################################
#
# Sub Name: identity
#
# Description: Simply returns the server's identity as a string
#
# Arguments: First arg is server instance
#
# Globals: None.
#
# Returns: string
#
###############################################################################
sub identity
{
use strict;
sprintf('%s/%s', ref($_[0]), $_[0]->version);
}
RPC-XML-0.77/t/meth_good_1.xpl 000644 000765 000024 00000000467 11612471026 016207 0 ustar 00rjray staff 000000 000000
test.rpc.xml.method1.0stringSimple test method for RPC::XML::Method classsub test { $_[1]->{method_name} }
RPC-XML-0.77/t/meth_good_2.xpl 000644 000765 000024 00000000454 11612471026 016204 0 ustar 00rjray staff 000000 000000
test.rpc.xml.procedure1.0stringSimple test method for RPC::XML::Procedure classsub test { $_[0] }
RPC-XML-0.77/t/meth_good_3.xpl 000644 000765 000024 00000000411 11612471026 016176 0 ustar 00rjray staff 000000 000000
test.rpc.xml.function1.0Simple test method for RPC::XML::Function classsub test { $_[0] }
RPC-XML-0.77/t/namespace1.xpl 000644 000765 000024 00000000472 11612471026 016033 0 ustar 00rjray staff 000000 000000
nstest1Test::NS1.0stringNamespace test method for RPC::XML::Method suitesub test { __PACKAGE__ }
RPC-XML-0.77/t/namespace2.xpl 000644 000765 000024 00000000471 11612471026 016033 0 ustar 00rjray staff 000000 000000
nstest2Test.NS1.0stringNamespace test method for RPC::XML::Method suitesub test { __PACKAGE__ }
RPC-XML-0.77/t/namespace3.xpl 000644 000765 000024 00000000500 11612471026 016025 0 ustar 00rjray staff 000000 000000
nstest3Test::NS1.0stringNamespace test method for RPC::XML::Method suitesub test { no strict; $value }
RPC-XML-0.77/t/svsm_text.b64 000644 000765 000024 00000004604 11612471026 015643 0 ustar 00rjray staff 000000 000000 R0lGODlhYwEcAOMAAAAAAFVVVTk5OR0dHaqqqo6OjnJycv///+Pj48fHxwAAAAAAAAAAAAAAAAAA
AAAAACH5BAEAAAcALAAAAABjARwAAAT+8MiJiJ046827/2AojmQZVpeprmzrvnBHDEBdC0lmA4RE
7JOALRCDGXY5zLFmIAlrRMmuV5TRdriq5md7PaeZwq5GdXFrpTNAG/qOeRjwQR0cslnqskRg04O+
UQdyd3VvZIRzQC5uNQUZjHAvdCSTiFuGOwgTcpWAliY7gVJdTnajh5Zqhpp3lSyQooJvfiuuIbaf
B1dMBEtMm30+igeeuSO7AhgJNsmlUMCoiLsABr07Ta3Dr4YYqtEtuB/hiAjXE2fNcxYErJUJ60nG
bdpnsX+mst9s5TbYiTeExjkDwKdGvCUF9dXSdovhpzwYBBhg5WNdu2HvLMSbkMBAgAD+BjYq8whS
pLoLCAp8LEDxko14X/yk/BiggMhi+SJ1o6knI4F4PlsKCzZBolAJHT+GlEGzWgZcM0veY0L0QEFf
Os/RZMkhgdIKDpPWFApVpdSnGg8g8BiPwNaWauzpINoJn9qEQ1oiwHujZaZpWTHwi5aQIgJIAETh
HDQH8ABWYp5J+HI0Loi9bwIIjTzm8TmGWCV3iImvD+MZb/wVGqIK8xg9tkInnpsYwZUeCRyXWYbF
JLRIdUXbxiQKsI0BcY6/Qc5hV6DjGIzjW1zVWwrPg5nrAqiBNzPfEoYbEiX7+EVSk4l7+JKP+Zmc
uzFRUyIfTXjpOl0hngoKZJ/Bb1D+ZJwAjmjAyTA4YSWAG0lwBkABDhaYE0EBTAPeF814F4gvAxRA
AF6rPVcVMgRw1swurPTT3BsEbqAgg0hdYwpdGMn4hYQasIfiAQjBV9RxbmUSHhYzosehhzv+Y98B
3lETZCPQ4PVkYkUG4uAOHdIGHIKmAFggZ1EkFAWGv2XIGAYODqXTLkkASAV1qKjBii+a+NLDGeBd
eRyOXkoApgS++COmmmukx912BI3WRUxW/SKHm6c8CKiQxAyzQ4HeFRhcohJckc5yATQ5gRgDqLYf
f5FSsWkUlWQX6ZeWVnUmR0hUWgNFFniUHCpwRkKmmneqyNl68gXSKnRMlhhqiIT+/iYhexywV89g
PRxoAyuD2gqAdpPI2V+zr67223ypcrRBAfhJaO2SxfiSDjE0KbklUYPM+lsPBWm3gQVy9EoFibna
UKAdT8iFZrqTHgrvR119aMokTVZjQWHRduGdAO/5qG2hG0dqrCJYrYMOuBGvQ3FO706DsTh8bXsv
uNqOaddT60ZSb1U52jHzHPu9WRq99fGno0L7tswcTh10JB2rilj3WsX2hcJdv1ySEspnpJxKSrdB
26ziqMtN5MFhYyRRM7Mxy1AzFTcT7ed3OIuHic+iydF1FJx5d1QHZNeK9AZaM71117QYWigk2FCN
nhseY22f1vZxHTTbOG9sXgb+N9lN4+Km/N3N2uWGvu8UL0V3TQ6Ko6r5CiLDMyQUCnf1CBie08dM
D8VIzkvr7EBdqJ6U81p11PhM4gbvKejuJO8pVj6H0Wo9uRFEGq9q+LtKBbs5Km0HpuUun8tKlL+N
ewCYaoJJH/4hv04GUvCo5t60vYpG/sbLHRte6NXgMq724M7blfeQYgALAUgUDmpenIYnuFvF6Drh
OkCaREe/PWQGA/5TS+pEJDzRcKFFCSvdBg6IJiF5i0nQoV6jJFOJQRTsQugZw6e2BwBsdY4ZjiuU
K67TQI65EApmw1mu4rELfF1DE2rQztkMFwUS9o0/2Wpf9wo3AdngyApz2iD+/ia4wvyMwQN4EVsS
X/eMJxJBCpjiXyWyBaD6cSyM+INUTgqEFVb4T45/ktePJNNG0Y3McLghHP6sZ0H5NOhSEcKfxjjg
jY1gJQBF6qDqRjSEIukrJwZ7YH3K0LJaNWkAJZpGD2klMIf9wner0ckgEgJKLGqSIJHkGIdCKUJ3
XMqU5FokJkuELAnWRxRLTBsZLzgB/Ohrih+4nzIMMYCE0G2S0XBaYBjlAT3xb5hjCMTSHqaN/XgG
lTBbZJPGYCoWCkNu2cwhBjHxTV1a8xuo6QyOqsdAZRgnFq7Bgl/E57Y9iqaKnXligciXQ+dxZm9P
MU6WMHfPbgCGX9yxBSS82gk49AzmXacxDvrQ+ZjWNFSd6wyoAP1QnsK5JXv7skh4RMYR1z1lK+AR
y1LQYgFcqdQDPvnJBsRCBRToNFlpqUhNM1ABnuwtMu8SR1Oo6AOYaiAqXDlJT1mKObM45QM+6UZQ
hdq7l64EoSflClW7QRKbEHWsHLEqLUR2lKiMRR5wjStcCzJPudr1rnjNq173+omPJImvgAqsYAdL
2LvKsLCITaxiF8tYD5StsZCNrGQnC1dPgYeymIVsBAAAOw==
RPC-XML-0.77/t/svsm_text.gif 000644 000765 000024 00000003411 11612471026 016010 0 ustar 00rjray staff 000000 000000 GIF89ac UUU999 rrr ! , c ȉ8ͻ`(dVlpG @] IfD쓀-v9̱f kDɮWvg{=®Fuqk3@yA YD`ӃQrwuods@.n5p/t$[;r&;R]Nvjw,o~+!WLKL}># 6ɥP ;Mï- gs Imgl6؉79F%v<`c]a,ě@ 6*R
|,@x_b"u'#x>[
6AP ?AZ\3KcB@A_:d!
Uԧ ֖j ڄCZ"{eiY1"H D 4 VbIr4.o<9X%wo
=B' Y$HuE$
qAaW[\[
σ73%ER{1QS" Mx:]!
doPd h08a%Ip@ALx/@ ^=W2p.n H]c
]Wqne 3ǡ;cQd#dbE X gQ$e.I Hu/]y ^J #kvELV"< C\\r49 Rid闖Vu&GHTZEx *pFBwz*tLj&!{ W`= h+
v_|rAIh14)%Q[irJP Oȅf
G]}h$MVcAav mGj"XCqNN8|m{/ڎiSFRoU91 YB N t$ XZ]\gJJA۬Mac$Q31P37w8ϢuywTdZ3u״Z($P cmq 48ol^7M冾/EwM
"3$
wLHK@]ZuL)$)V>j=DjJ9*m.J{ jI !NRF ^2ەb Hj^'[::@DG=dSKD$B4YiHM3P-2GSj *\9IOY98>FPڻ'
UAu *-DvE p+\ 2Oxͫ^$
`KػʰMbXd' WOl ; RPC-XML-0.77/t/util.pl 000644 000765 000024 00000003571 11614455366 014621 0 ustar 00rjray staff 000000 000000 # Nothing exciting, just a couple of utility routines that are used in several
# test suites
use IO::Socket;
sub start_server
{
my $S = shift;
my $pid;
if (! defined($pid = fork()))
{
die "fork() error: $!, stopped";
}
elsif ($pid)
{
return $pid;
}
else
{
$S->server_loop(@_);
exit; # When the parent stops this server, we want to stop this child
}
}
sub stop_server
{
my $pid = shift;
# Per RT 27778, use 'KILL' instead of 'INT' as the stop-server signal for
# MSWin platforms:
my $SIGNAL = ($^O eq "MSWin32") ? 'KILL' : 'INT';
kill $SIGNAL, $pid;
sleep 2; # give the old sockets time to go away
}
sub find_port
{
my $start_at = $_[0] || 9000;
my ($port, $sock);
for ($port = $start_at; $port < ($start_at + 2000); $port++)
{
$sock = IO::Socket->new(Domain => AF_INET,
PeerAddr => 'localhost',
PeerPort => $port);
return $port unless ref $sock;
}
-1;
}
sub find_port_in_use
{
my $start_at = $_[0] || 80;
my ($port, $sock);
for ($port = $start_at; $port < ($start_at + 2000); $port++)
{
$sock = IO::Socket->new(Domain => AF_INET,
PeerAddr => 'localhost',
PeerPort => $port);
return $port if ref $sock;
}
-1;
}
sub read_config
{
my $file = shift;
return {} unless -f $file;
open(my $fh, "< $file") || die "Error opening $file: $!";
my $config = {};
while (defined($_ = <$fh>))
{
next if /^#/;
chomp;
next if /^\s*$/;
my ($key, $value) = split(/\s*=\s*/, $_, 2);
$value =~ s/\s+$//; # Lose trailing whitespace
$value = [ split(/\s*,\s*/, $value) ];
$config->{$key} = $value;
}
$config;
}
1;
RPC-XML-0.77/methods/identity.base 000644 000765 000024 00000000162 11612471030 017145 0 ustar 00rjray staff 000000 000000 Name: system.identity
Version: 1.1
Hidden: no
Signature: string
Helpfile: identity.help
Codefile: identity.code
RPC-XML-0.77/methods/identity.code 000644 000765 000024 00000000661 11612471030 017151 0 ustar 00rjray staff 000000 000000 ###############################################################################
#
# Sub Name: identity
#
# Description: Simply returns the server's identity as a string
#
# Arguments: First arg is server instance
#
# Globals: None.
#
# Returns: string
#
###############################################################################
sub identity
{
use strict;
$_[0]->product_tokens;
}
RPC-XML-0.77/methods/identity.help 000644 000765 000024 00000000057 11612471030 017166 0 ustar 00rjray staff 000000 000000 Return the server name and version as a string
RPC-XML-0.77/methods/introspection.base 000644 000765 000024 00000000260 11612471030 020213 0 ustar 00rjray staff 000000 000000 Name: system.introspection
Version: 1.1
Hidden: no
Signature: array
Signature: array array
Signature: struct string
Helpfile: introspection.help
Codefile: introspection.code
RPC-XML-0.77/methods/introspection.code 000644 000765 000024 00000003723 11612471030 020222 0 ustar 00rjray staff 000000 000000 ###############################################################################
#
# Sub Name: introspection
#
# Description: Collates the data from listMethods, methodHelp and
# methodSignature into a single array
#
# Arguments: NAME IN/OUT TYPE DESCRIPTION
# $srv in ref Server object instance
# $list in listref If passed, limit methods listed
# or scalar to these.
#
# Globals: None.
#
# Environment: None.
#
# Returns: Success: string or listref
# Failure: fault object
#
###############################################################################
sub introspection
{
use strict;
my $srv = shift;
my $list = shift;
my (@methods, @all_methods, %all_methods, @bad, @results, $scalar, $meth);
my $name = $srv->{method_name};
$scalar = ($list and (! ref($list))) ? 1 : 0;
@all_methods = sort $srv->list_methods;
if ($list)
{
# This is an expensive-enough operation that I don't want to do it
# if I don't have to
@methods = ($scalar) ? ($list) : @$list;
@all_methods{@all_methods} = (1) x scalar(@all_methods);
if (@bad = grep(! $all_methods{$_}, @methods))
{
local $" = ', ';
return RPC::XML::fault->new(302, "$name: Method(s) @bad unknown");
}
}
else
{
@methods = @all_methods;
}
# Convert in-place to their objects
for (@methods) { $_ = $srv->get_method($_); }
# Since that list came from the server object, we know alls calls were OK
for (@methods)
{
push(@results, { name => $_->name,
help => $_->help,
signature => $_->signature,
version => RPC::XML::string->new($_->version) });
}
return $scalar ? $results[0] : \@results;
}
RPC-XML-0.77/methods/introspection.help 000644 000765 000024 00000001453 11612471030 020236 0 ustar 00rjray staff 000000 000000 Return the name, signatures and help text for the registered methods on
the server. With no parameters, returns an ARRAY of STRUCTs. With an ARRAY
parameter, expects all elements to be of type STRING and specify method
names, with the return value being an ARRAY of STRUCT for the named methods
(in order). If the parameter is a single STRING type, the return value is
a STRUCT for the named method.
Each STRUCT will have the following members:
name A STRING containing the method name
version A STRING version stamp. Empty if none was specified.
signature An ARRAY containing the signatures, each an ARRAY of STRING
help A STRING containing the help text for the method
Note that an ARRAY is returned for the signatures even when there is only one
signature.
RPC-XML-0.77/methods/listMethods.base 000644 000765 000024 00000000222 11612471030 017610 0 ustar 00rjray staff 000000 000000 Name: system.listMethods
Version: 1.1
Hidden: no
Signature: array
Signature: array string
Helpfile: listMethods.help
Codefile: listMethods.code
RPC-XML-0.77/methods/listMethods.code 000644 000765 000024 00000001774 11612471030 017625 0 ustar 00rjray staff 000000 000000 ###############################################################################
#
# Sub Name: listMethods
#
# Description: Read the current list of methods from the server object
# and return the names in a list reference.
#
# Arguments: NAME IN/OUT TYPE DESCRIPTION
# $srv in ref Server object instance
# $pat in scalar If passed, a substring to match
# names against. NOT a regex!
#
# Globals: None.
#
# Environment: None.
#
# Returns: listref
#
###############################################################################
sub listMethods
{
use strict;
my $srv = shift;
my $pat = shift;
my @list = sort $srv->list_methods;
# Exclude any that are hidden from introspection APIs
@list = grep(! $srv->get_method($_)->hidden, @list);
@list = grep(index($_, $pat) != -1, @list) if ($pat);
\@list;
}
RPC-XML-0.77/methods/listMethods.help 000644 000765 000024 00000000412 11612471030 017627 0 ustar 00rjray staff 000000 000000 List all the methods known to the server. If the STRING parameter is passed,
it is used as a substring to match against, with only those matching methods
being returned. Note that the STRING parameter is not a regular expression,
but rather just a simple substring.
RPC-XML-0.77/methods/methodHelp.base 000644 000765 000024 00000000226 11612471030 017406 0 ustar 00rjray staff 000000 000000 Name: system.methodHelp
Version: 1.2
Hidden: no
Signature: string string
Signature: array array
Helpfile: methodHelp.help
Codefile: methodHelp.code
RPC-XML-0.77/methods/methodHelp.code 000644 000765 000024 00000002210 11612471030 017401 0 ustar 00rjray staff 000000 000000 ###############################################################################
#
# Sub Name: methodHelp
#
# Description: Retrieve any help text for the specified methods.
#
# Arguments: NAME IN/OUT TYPE DESCRIPTION
# $srv in ref Server object instance
# $arg in ref/sc Listref or scalar specification
#
# Globals: None.
#
# Environment: None.
#
# Returns: Success: string or listref
# Failure: fault object
#
###############################################################################
sub methodHelp
{
use strict;
my $srv = shift;
my $arg = shift;
my $name = $srv->{method_name};
my @list = (ref $arg) ? @$arg : ($arg);
my @results = ();
my $method;
for (@list)
{
if (ref($method = $srv->get_method($_)) and (! $method->hidden))
{
push(@results, $method->help() || '');
}
else
{
return RPC::XML::fault->new(302, "$name: Method $_ unknown");
}
}
return (ref $arg) ? \@results : $results[0];
}
RPC-XML-0.77/methods/methodHelp.help 000644 000765 000024 00000000464 11612471030 017430 0 ustar 00rjray staff 000000 000000 Return the help text (such as this) associated with the specified method(s).
If a STRING parameter specifying the method name is passed, the return value
will be a STRING. If multiple methods are queried by passing an ARRAY of
STRING values, then the return value will be an ARRAY of STRING values, as
well.
RPC-XML-0.77/methods/methodSignature.base 000644 000765 000024 00000000244 11612471030 020457 0 ustar 00rjray staff 000000 000000 Name: system.methodSignature
Version: 1.2
Hidden: no
Signature: array string
Signature: array array
Helpfile: methodSignature.help
Codefile: methodSignature.code
RPC-XML-0.77/methods/methodSignature.code 000644 000765 000024 00000002325 11612471030 020461 0 ustar 00rjray staff 000000 000000 ###############################################################################
#
# Sub Name: methodSignature
#
# Description: Retrieve the list of method signatures for the specified
# methods.
#
# Arguments: NAME IN/OUT TYPE DESCRIPTION
# $srv in ref Server object instance
# $arg in ref/sc Listref or scalar specification
#
# Globals: None.
#
# Environment: None.
#
# Returns: Success: listref
# Failure: fault object
#
###############################################################################
sub methodSignature
{
use strict;
my $srv = shift;
my $arg = shift;
my $name = $srv->{method_name};
my @list = (ref $arg) ? @$arg : ($arg);
my (@results, $list, $method);
for (@list)
{
if (ref($method = $srv->get_method($_)) and (! $method->hidden))
{
push(@results,
[ map { [ split(/ /) ] } @{$method->signature} ]);
}
else
{
return RPC::XML::fault->new(302, "$name: Method $_ unknown");
}
}
return (ref $arg) ? \@results : $results[0];
}
RPC-XML-0.77/methods/methodSignature.help 000644 000765 000024 00000000566 11612471030 020504 0 ustar 00rjray staff 000000 000000 Return the signatures that the specified method(s) may be called with. Always
returns an ARRAY, even if there is only one signature. Either a single method
must be named in the STRING parameter, or a list of one or more may be
specified in the ARRAY parameter. If an ARRAY is passed, then return value will
be an ARRAY containing other ARRAY values, one per requested name.
RPC-XML-0.77/methods/multicall.base 000644 000765 000024 00000000172 11612471030 017303 0 ustar 00rjray staff 000000 000000 Name: system.multicall
Version: 1.0
Hidden: no
Signature: array array
Helpfile: multicall.help
Codefile: multicall.code
RPC-XML-0.77/methods/multicall.code 000644 000765 000024 00000003720 11612471030 017305 0 ustar 00rjray staff 000000 000000 ###############################################################################
#
# Sub Name: multicall
#
# Description: Execute multiple method calls in a single request
#
# Arguments: NAME IN/OUT TYPE DESCRIPTION
# $srv in ref Server object instance
# $list in ref List of struct's with the call
# data within.
#
# Globals: None.
#
# Environment: None.
#
# Returns: Success: listref
# Failure: fault object
#
###############################################################################
sub multicall
{
use strict;
my $srv = shift;
my $list = shift;
my ($call, $subname, $params, $result, @results);
my $name = $srv->{method_name};
for $call (@$list)
{
unless (ref($call) eq 'HASH')
{
return RPC::XML::fault->new(200,
"$name: One of the array elements " .
'passed in was not a struct');
}
return RPC::XML::fault->new(310,
"$name: Request was missing required " .
'"methodName" member')
unless ($subname = $call->{methodName});
return RPC::XML::fault->new(310,
"$name: Recursive calling of $name not " .
'allowed')
if ($subname eq $name);
$params = $call->{params} || [];
return RPC::XML::fault->new(200,
"$name: Request's value for \"params\" " .
'was not an array')
unless (ref($params) eq 'ARRAY');
$result = $srv->dispatch([ $subname, @$params ]);
return $result if $result->is_fault;
push @results, $result->value;
}
\@results;
}
RPC-XML-0.77/methods/multicall.help 000644 000765 000024 00000001664 11612471030 017330 0 ustar 00rjray staff 000000 000000 Execute a set of one or more procedure calls on the server as a single
request. The only supported call signature takes an ARRAY of STRUCT values.
Each STRUCT should have two members:
methodName The name of the method/routine to invoke as a STRING
params An ARRAY of the parameters to pass to the routine
If the "params" member is absent, a call with no parameters is assumed. The
ARRAY of parameters will be expanded prior to the call, otherwise all the
called routines would have to have a signature allowing for a single ARRAY
input. Thus, any routine taking such an input will have to nest it within an
outer containing ARRAY.
The return value is an ARRAY of the return values from the calls, or a fault
response if one of the calls failed. Because the specification does not allow
for faults as first-class datatypes, all other results are discarded upon an
error, and any remaining calls will not get executed.
RPC-XML-0.77/methods/status.base 000644 000765 000024 00000000206 11612471030 016636 0 ustar 00rjray staff 000000 000000 Name: system.status
Version: 1.2
Hidden: no
Signature: struct
Signature: struct boolean
Helpfile: status.help
Codefile: status.code
RPC-XML-0.77/methods/status.code 000644 000765 000024 00000003173 11612471030 016644 0 ustar 00rjray staff 000000 000000 ###############################################################################
#
# Sub Name: status
#
# Description: Create a status-reporting struct and returns it.
#
# Arguments: NAME IN/OUT TYPE DESCRIPTION
# $srv in ref Server object instance
# $no_inc in boolean A true/false value that tells
# whether to count this call
# in the total_requests field.
#
# Returns: hashref
#
###############################################################################
sub status
{
use strict;
my $srv = shift;
my $no_inc = shift || 0;
my $status = {};
my $time = time;
my $URI;
require URI;
$status->{name} = ref($srv);
$status->{version} = RPC::XML::string->new($srv->version);
$status->{host} = $srv->host || $srv->{host} || '';
$status->{port} = $srv->port || $srv->{port} || '';
$status->{path} = RPC::XML::string->new($srv->path);
$status->{date} = RPC::XML::datetime_iso8601
->new(RPC::XML::time2iso8601($time));
$status->{started} = RPC::XML::datetime_iso8601
->new(RPC::XML::time2iso8601($srv->started));
$status->{date_int} = $time;
$status->{started_int} = $srv->started;
$status->{total_requests} = $srv->requests();
# In special cases where the call to system.status is not going to incr
# the total, don't add the extra here, either...
$status->{total_requests}++ unless $no_inc;
$status->{methods_known} = scalar($srv->list_methods);
$status;
}
RPC-XML-0.77/methods/status.help 000644 000765 000024 00000004672 11612471030 016667 0 ustar 00rjray staff 000000 000000 Report on the various status markers of the server itself. The return value is
a STRUCT with the following members:
Key Type Value
host STRING Name of the (possibly virtual) host name to which
requests are sent.
port INT TCP/IP port the server is listening on.
name STRING The name of the server software, as it identifies
itself in transport headers.
version STRING The software version. Note that this is defined as
a STRING, not a DOUBLE, to allow for non-numeric
values.
path STRING URL path portion, for use when sending POST
request messages.
date ISO8601 The current date and time on the server, as an
ISO 8601 date string.
date_int INT The current date as a UNIX time() value. This is
encoded as an INT rather than the dateTime.int
type, so that it is readable by older clients.
started ISO8601 The date and time when the current server started
accepting connections, as an ISO 8601 string.
started_int
INT The server start-time as a UNIX time() value. This
is also encoded as INT for the same reasons as
the "date_int" value above.
total_requests
INT Total number of requests served thus far
(including the current one). This will not include
requests for which there was no matching method,
or HTTP-HEAD requests.
methods_known
INT The number of different methods the server has
registered for serving requests.
If this method is called with a single boolean value, that value determines
whether the current call should be counted against the value of the
"total_requests" field. This is also handled at the server level. Setting
this boolean value to a "true" value causes the server (and the resulting
data structure returned) to not count this call. This feature allows external
tools (monitors, etc.) to check the status regularly without falsely running
up the value of "total_requests".
RPC-XML-0.77/lib/Apache/ 000755 000765 000024 00000000000 12021176461 014752 5 ustar 00rjray staff 000000 000000 RPC-XML-0.77/lib/RPC/ 000755 000765 000024 00000000000 12021176461 014215 5 ustar 00rjray staff 000000 000000 RPC-XML-0.77/lib/RPC/XML/ 000755 000765 000024 00000000000 12021176461 014655 5 ustar 00rjray staff 000000 000000 RPC-XML-0.77/lib/RPC/XML.pm 000644 000765 000024 00000177015 11624420572 015231 0 ustar 00rjray staff 000000 000000 ###############################################################################
#
# This file copyright (c) 2001-2011 Randy J. Ray, all rights reserved
#
# Copying and distribution are permitted under the terms of the Artistic
# License 2.0 (http://www.opensource.org/licenses/artistic-license-2.0.php) or
# the GNU LGPL (http://www.opensource.org/licenses/lgpl-2.1.php).
#
###############################################################################
#
# Description: This module provides the core XML <-> RPC conversion and
# structural management.
#
# Functions: This module contains many, many subclasses. Better to
# examine them individually.
#
# Libraries: RPC::XML::base64 uses MIME::Base64
#
# Global Consts: $VERSION
#
###############################################################################
package RPC::XML;
use 5.008008;
use strict;
use warnings;
use vars qw(@EXPORT_OK %EXPORT_TAGS $VERSION $ERROR
%XMLMAP $XMLRE $ENCODING $FORCE_STRING_ENCODING $ALLOW_NIL
$DATETIME_REGEXP $DATETIME_ISO8601_AVAILABLE);
use subs qw(time2iso8601 smart_encode);
use base 'Exporter';
use Scalar::Util qw(blessed reftype);
## no critic (ProhibitSubroutinePrototypes)
## no critic (ProhibitMultiplePackages)
## no critic (Capitalization)
BEGIN
{
# Default encoding:
$ENCODING = 'us-ascii';
# force strings?
$FORCE_STRING_ENCODING = 0;
# Allow the extension?
$ALLOW_NIL = 0;
# Determine if the DateTime::Format::ISO8601 module is available for
# RPC::XML::datetime_iso8601 to use:
my $retval = eval 'use DateTime::Format::ISO8601; 1;';
$DATETIME_ISO8601_AVAILABLE = $retval ? 1 : 0;
}
@EXPORT_OK = qw(time2iso8601 smart_encode
RPC_BOOLEAN RPC_INT RPC_I4 RPC_I8 RPC_DOUBLE
RPC_DATETIME_ISO8601 RPC_BASE64 RPC_STRING RPC_NIL
$ENCODING $FORCE_STRING_ENCODING $ALLOW_NIL);
%EXPORT_TAGS = (types => [ qw(RPC_BOOLEAN RPC_INT RPC_I4 RPC_I8 RPC_DOUBLE
RPC_STRING RPC_DATETIME_ISO8601 RPC_BASE64
RPC_NIL) ],
all => [ @EXPORT_OK ]);
$VERSION = '1.56';
$VERSION = eval $VERSION; ## no critic (ProhibitStringyEval)
# Global error string
$ERROR = q{};
# These are used for stringifying XML-sensitive characters that may appear
# in struct keys:
%XMLMAP = (
q{>} => '>',
q{<} => '<',
q{&} => '&',
q{"} => '"',
q{'} => ''',
);
$XMLRE = join q{} => keys %XMLMAP; $XMLRE = qr/([$XMLRE])/;
# The XMLRPC spec only allows for the incorrect iso8601 format
# without dashes, but dashes are part of the standard so we include
# them. Note that the actual RPC::XML::datetime_iso8601 class will strip
# them out if present.
my $date_re =
qr{
(\d{4})-?
([01]\d)-?
([0123]\d)
}x;
my $time_re =
qr{
([012]\d):
([0-5]\d):
([0-5]\d)([.,]\d+)?
(Z|[-+]\d\d:\d\d)?
}x;
$DATETIME_REGEXP = qr{^${date_re}T?${time_re}$};
# All of the RPC_* functions are convenience-encoders
sub RPC_STRING ($)
{
return RPC::XML::string->new(shift);
}
sub RPC_BOOLEAN ($)
{
return RPC::XML::boolean->new(shift);
}
sub RPC_INT ($)
{
return RPC::XML::int->new(shift);
}
sub RPC_I4 ($)
{
return RPC::XML::i4->new(shift);
}
sub RPC_I8 ($)
{
return RPC::XML::i8->new(shift);
}
sub RPC_DOUBLE ($)
{
return RPC::XML::double->new(shift);
}
sub RPC_DATETIME_ISO8601 ($)
{
return RPC::XML::datetime_iso8601->new(shift);
}
sub RPC_BASE64 ($;$)
{
return RPC::XML::base64->new(shift, shift);
}
sub RPC_NIL ()
{
return RPC::XML::nil->new();
}
# This is a dead-simple ISO8601-from-UNIX-time stringifier. Always expresses
# time in UTC. The format isn't strictly ISO8601, though, as the XML-RPC spec
# fucked it up.
sub time2iso8601
{
my $time = shift || time;
my @time = gmtime $time;
$time = sprintf '%4d%02d%02dT%02d:%02d:%02dZ',
$time[5] + 1900, $time[4] + 1, @time[3, 2, 1, 0];
return $time;
}
# This is a (futile?) attempt to provide a "smart" encoding method that will
# take a Perl scalar and promote it to the appropriate RPC::XML::_type_.
{
my $MAX_INT = 2_147_483_647;
my $MIN_INT = -2_147_483_648;
my $MAX_BIG_INT = 9_223_372_036_854_775_807;
my $MIN_BIG_INT = -9_223_372_036_854_775_808;
my $MAX_DOUBLE = 1e37;
my $MIN_DOUBLE = $MAX_DOUBLE * -1;
sub smart_encode ## no critic (ProhibitExcessComplexity)
{
my @values = @_;
my ($type, $seenrefs, @newvalues);
# Look for sooper-sekrit pseudo-blessed hashref as first argument.
# It means this is a recursive call, and it contains a map of any
# references we've already seen.
if ((blessed $values[0]) && ($values[0]->isa('RPC::XML::refmap')))
{
# Peel it off of the list
$seenrefs = shift @values;
}
else
{
# Create one just in case we need it
$seenrefs = bless {}, 'RPC::XML::refmap';
}
foreach (@values)
{
if (! defined $_)
{
$type = $ALLOW_NIL ?
RPC::XML::nil->new() : RPC::XML::string->new(q{});
}
elsif (ref $_)
{
# Skip any that we've already seen
next if $seenrefs->{$_}++;
if (blessed($_) &&
($_->isa('RPC::XML::datatype') || $_->isa('DateTime')))
{
# Only if the reference is a datatype or a DateTime
# instance, do we short-cut here...
if ($_->isa('RPC::XML::datatype'))
{
# Pass through any that have already been encoded
$type = $_;
}
else
{
# Must be a DateTime object, convert to ISO8601
$type = RPC::XML::datetime_iso8601
->new($_->clone->set_time_zone('UTC'));
}
}
elsif (reftype($_) eq 'HASH')
{
# Per RT 41063, to catch circular refs I can't delegate
# to the struct constructor, I have to create my own
# copy of the hash with locally-recursively-encoded
# values
my %newhash;
for my $key (keys %{$_})
{
# Forcing this into a list-context *should* make the
# test be true even if the return value is a hard
# undef. Only if the return value is an empty list
# should this evaluate as false...
if (my @value = smart_encode($seenrefs, $_->{$key}))
{
$newhash{$key} = $value[0];
}
}
$type = RPC::XML::struct->new(\%newhash);
}
elsif (reftype($_) eq 'ARRAY')
{
# This is a somewhat-ugly approach, but I don't want to
# dereference @$_, but I also want people to be able to
# pass array-refs in to this constructor and have them
# be treated as single elements, as one would expect
# (see RT 35106)
# Per RT 41063, looks like I get to deref $_ after all...
$type = RPC::XML::array->new(
from => [ smart_encode($seenrefs, @{$_}) ]
);
}
elsif (reftype($_) eq 'SCALAR')
{
# This is a rare excursion into recursion, since the scalar
# nature (de-refed from the object, so no longer magic)
# will prevent further recursing.
$type = smart_encode($seenrefs, ${$_});
}
else
{
# If the user passed in a reference that didn't pass one
# of the above tests, we can't do anything with it:
$type = reftype $_;
die "Un-convertable reference: $type, cannot use\n";
}
}
# You have to check ints first, because they match the
# next pattern (for doubles) too
elsif (! $FORCE_STRING_ENCODING &&
/^[-+]?\d+$/ &&
$_ >= $MIN_BIG_INT &&
$_ <= $MAX_BIG_INT)
{
if (($_ > $MAX_INT) || ($_ < $MIN_INT))
{
$type = RPC::XML::i8->new($_);
}
else
{
$type = RPC::XML::int->new($_);
}
}
# Pattern taken from perldata(1)
elsif (! $FORCE_STRING_ENCODING &&
/^[+-]?(?=\d|[.]\d)\d*(?:[.]\d*)?(?:[Ee](?:[+-]?\d+))?$/x &&
$_ > $MIN_DOUBLE &&
$_ < $MAX_DOUBLE)
{
$type = RPC::XML::double->new($_);
}
elsif (/$DATETIME_REGEXP/)
{
$type = RPC::XML::datetime_iso8601->new($_);
}
else
{
$type = RPC::XML::string->new($_);
}
push @newvalues, $type;
}
return (wantarray ? @newvalues : $newvalues[0]);
}
}
# This is a (mostly) empty class used as a common superclass for simple and
# complex types, so that their derivatives may be universally type-checked.
package RPC::XML::datatype;
sub type
{
my $self = shift;
my $class = ref($self) || $self;
$class =~ s/.*://;
return $class;
}
sub is_fault { return 0; }
###############################################################################
#
# Package: RPC::XML::simple_type
#
# Description: A base class for the simpler type-classes to inherit from,
# for default constructor, stringification, etc.
#
###############################################################################
package RPC::XML::simple_type;
use strict;
use base 'RPC::XML::datatype';
use Scalar::Util 'reftype';
# new - a generic constructor that presumes the value being stored is scalar
sub new
{
my $class = shift;
my $value = shift;
$RPC::XML::ERROR = q{};
$class = ref($class) || $class;
if ($class eq 'RPC::XML::simple_type')
{
$RPC::XML::ERROR = 'RPC::XML::simple_type::new: Cannot instantiate ' .
'this class directly';
return;
}
if (ref $value)
{
# If it is a scalar reference, just deref
if (reftype($value) eq 'SCALAR')
{
$value = ${$value};
}
else
{
# We can only manage scalar references (or blessed scalar refs)
$RPC::XML::ERROR = "${class}::new: Cannot instantiate from a " .
'reference not derived from scalar';
return;
}
}
return bless \$value, $class;
}
# value - a generic accessor
sub value
{
my $self = shift;
if (! ref $self)
{
$RPC::XML::ERROR =
"{$self}::value: Cannot be called as a static method";
return;
}
return ${$self};
}
# as_string - return the value as an XML snippet
sub as_string
{
my $self = shift;
my $class = ref $self;
if (! $class)
{
$RPC::XML::ERROR =
"{$self}::as_string: Cannot be called as a static method";
return;
}
$class =~ s/^.*\://;
$class =~ s/_/./g;
if (substr($class, 0, 8) eq 'datetime')
{
substr $class, 0, 8, 'dateTime';
}
return "<$class>$$self";
}
# Serialization for simple types is just a matter of sending as_string over
sub serialize
{
my ($self, $fh) = @_;
utf8::downgrade(my $str = $self->as_string);
print {$fh} $str;
return;
}
# The switch to serialization instead of in-memory strings means having to
# calculate total size in bytes for Content-Length headers:
sub length ## no critic (ProhibitBuiltinHomonyms)
{
my $self = shift;
utf8::downgrade(my $str = $self->as_string);
return length $str;
}
###############################################################################
#
# Package: RPC::XML::int
#
# Description: Data-type class for integers
#
###############################################################################
package RPC::XML::int;
use strict;
use base 'RPC::XML::simple_type';
###############################################################################
#
# Package: RPC::XML::i4
#
# Description: Data-type class for i4. Forces data into an int object.
#
###############################################################################
package RPC::XML::i4;
use strict;
use base 'RPC::XML::simple_type';
###############################################################################
#
# Package: RPC::XML::i8
#
# Description: Data-type class for i8. Forces data into a 8-byte int.
#
###############################################################################
package RPC::XML::i8;
use strict;
use base 'RPC::XML::simple_type';
###############################################################################
#
# Package: RPC::XML::double
#
# Description: The "double" type-class
#
###############################################################################
package RPC::XML::double;
use strict;
use base 'RPC::XML::simple_type';
sub as_string
{
my $self = shift;
if (! ref $self)
{
$RPC::XML::ERROR =
"{$self}::as_string: Cannot be called as a static method";
return;
}
my $class = $self->type;
(my $value = sprintf '%.20f', ${$self}) =~ s/([.]\d+?)0+$/$1/;
return "<$class>$value";
}
###############################################################################
#
# Package: RPC::XML::string
#
# Description: The "string" type-class
#
###############################################################################
package RPC::XML::string;
use strict;
use base 'RPC::XML::simple_type';
# as_string - return the value as an XML snippet
sub as_string
{
my $self = shift;
my ($class, $value);
if (! ref $self)
{
$RPC::XML::ERROR =
"{$self}::as_string: Cannot be called as a static method";
return;
}
$class = $self->type;
($value = defined ${$self} ? ${$self} : q{} )
=~ s/$RPC::XML::XMLRE/$RPC::XML::XMLMAP{$1}/ge;
return "<$class>$value";
}
###############################################################################
#
# Package: RPC::XML::boolean
#
# Description: The type-class for boolean data. Handles some "extra" cases
#
###############################################################################
package RPC::XML::boolean;
use strict;
use base 'RPC::XML::simple_type';
# This constructor allows any of true, false, yes or no to be specified
sub new
{
my $class = shift;
my $value = shift || 0;
$RPC::XML::ERROR = q{};
if ($value =~ /true|yes|1/i)
{
$value = 1;
}
elsif ($value =~ /false|no|0/i)
{
$value = 0;
}
else
{
$class = ref($class) || $class;
$RPC::XML::ERROR = "${class}::new: Value must be one of yes, no, " .
'true, false, 1, 0 (case-insensitive)';
return;
}
return bless \$value, $class;
}
###############################################################################
#
# Package: RPC::XML::datetime_iso8601
#
# Description: This is the class to manage ISO8601-style date/time values
#
###############################################################################
package RPC::XML::datetime_iso8601;
use strict;
use base 'RPC::XML::simple_type';
use Scalar::Util 'reftype';
sub type { return 'dateTime.iso8601'; };
# Check the value passed in for sanity, and normalize the string representation
sub new
{
my ($class, $value) = @_;
my $newvalue;
if (ref($value) && reftype($value) eq 'SCALAR')
{
$value = ${$value};
}
if (defined $value)
{
if ($value =~ /$RPC::XML::DATETIME_REGEXP/)
{
# This is *not* a valid ISO 8601 format, but it's the way it is
# given in the spec, so assume that other implementations can only
# accept this form. Also, this should match the form that
# time2iso8601 produces.
$newvalue = $7 ? "$1$2$3T$4:$5:$6$7" : "$1$2$3T$4:$5:$6";
if ($8) {
$newvalue .= $8;
}
}
elsif ($RPC::XML::DATETIME_ISO8601_AVAILABLE)
{
$newvalue =
eval { DateTime::Format::ISO8601->parse_datetime($value) };
if ($newvalue)
{
# This both removes the dashes (*sigh*) and forces it from an
# object to an ordinary string:
$newvalue =~ s/-//g;
}
}
if (! $newvalue)
{
$RPC::XML::ERROR = "${class}::new: Malformed data ($value) " .
'passed as dateTime.iso8601';
return;
}
}
else
{
$RPC::XML::ERROR = "${class}::new: Value required in constructor";
return;
}
return bless \$newvalue, $class;
}
###############################################################################
#
# Package: RPC::XML::nil
#
# Description: The "nil" type-class extension
#
###############################################################################
package RPC::XML::nil;
use strict;
use base 'RPC::XML::simple_type';
# no value need be passed to this method
sub new
{
my ($class, $value, $flag) = @_;
# We need $value so we can bless a reference to it. But regardless of
# what was passed, it needs to be undef to be a proper "nil".
undef $value;
if (! $RPC::XML::ALLOW_NIL && ! $flag)
{
$RPC::XML::ERROR = "${class}::new: \$RPC::XML::ALLOW_NIL must be set" .
' for RPC::XML::nil objects to be supported';
return;
}
return bless \$value, $class;
}
# Stringification and serialsation are trivial..
sub as_string
{
return '';
}
sub serialize
{
my ($self, $fh) = @_;
print {$fh} $self->as_string; # In case someone sub-classes this
return;
}
###############################################################################
#
# Package: RPC::XML::array
#
# Description: This class encapsulates the array data type. Each element
# within the array should be one of the datatype classes.
#
###############################################################################
package RPC::XML::array;
use strict;
use base 'RPC::XML::datatype';
use Scalar::Util qw(blessed reftype);
# The constructor for this class mainly needs to sanity-check the value data
sub new
{
my ($class, @args) = @_;
# Special-case time: If the args-list has exactly two elements, and the
# first element is "from" and the second element is an array-ref (or a
# type derived from), then copy the ref's contents into @args.
if ((2 == @args) && ($args[0] eq 'from') && (reftype($args[1]) eq 'ARRAY'))
{
@args = @{$args[1]};
}
# Ensure that each argument passed in is itself one of the data-type
# class instances.
return bless [ RPC::XML::smart_encode(@args) ], $class;
}
# This became more complex once it was shown that there may be a need to fetch
# the value while preserving the underlying objects.
sub value
{
my $self = shift;
my $no_recurse = shift || 0;
my $ret;
if ($no_recurse)
{
$ret = [ @{$self} ];
}
else
{
$ret = [ map { $_->value } @{$self} ];
}
return $ret;
}
sub as_string
{
my $self = shift;
return join q{},
'',
(map { ('', $_->as_string(), '') } (@{$self})),
'';
}
# Serialization for arrays is not as straight-forward as it is for simple
# types. One or more of the elements may be a base64 object, which has a
# non-trivial serialize() method. Thus, rather than just sending the data from
# as_string down the pipe, instead call serialize() recursively on all of the
# elements.
sub serialize
{
my ($self, $fh) = @_;
print {$fh} '';
for (@{$self})
{
print {$fh} '';
$_->serialize($fh);
print {$fh} '';
}
print {$fh} '';
return;
}
# Length calculation starts to get messy here, due to recursion
sub length ## no critic (ProhibitBuiltinHomonyms)
{
my $self = shift;
# Start with the constant components in the text
my $len = 28; # That the part
for (@{$self}) { $len += (15 + $_->length) } # 15 is for
return $len;
}
###############################################################################
#
# Package: RPC::XML::struct
#
# Description: This is the "struct" data class. The struct is like Perl's
# hash, with the constraint that all values are instances
# of the datatype classes.
#
###############################################################################
package RPC::XML::struct;
use strict;
use base 'RPC::XML::datatype';
use Scalar::Util qw(blessed reftype);
# The constructor for this class mainly needs to sanity-check the value data
sub new
{
my ($class, @args) = @_;
my %args = (ref $args[0] and reftype($args[0]) eq 'HASH') ?
%{$args[0]} : @args;
# RT 41063: If all the values are datatype objects, either they came in
# that way or we've already laundered them through smart_encode(). If there
# is even one that isn't, then we have to pass the whole mess to be
# encoded.
my $ref =
(grep { ! (blessed($_) && $_->isa('RPC::XML::datatype')) } values %args)
? RPC::XML::smart_encode(\%args) : \%args;
return bless $ref, $class;
}
# This became more complex once it was shown that there may be a need to fetch
# the value while preserving the underlying objects.
sub value
{
my $self = shift;
my $no_recurse = shift || 0;
my %value;
if ($no_recurse)
{
%value = map { ($_, $self->{$_}) } (keys %{$self});
}
else
{
%value = map { ($_, $self->{$_}->value) } (keys %{$self});
}
return \%value;
}
sub as_string
{
my $self = shift;
my $key;
# Clean the keys of $self, in case they have any HTML-special characters
my %clean;
for (keys %{$self})
{
($key = $_) =~ s/$RPC::XML::XMLRE/$RPC::XML::XMLMAP{$1}/ge;
$clean{$key} = $self->{$_}->as_string;
}
return join q{},
'',
(map {
("$_",
$clean{$_},
'')
} (keys %clean)),
'';
}
# As with the array type, serialization here isn't cut and dried, since one or
# more values may be base64.
sub serialize
{
my ($self, $fh) = @_;
my $key;
print {$fh} '';
for (keys %{$self})
{
($key = $_) =~ s/$RPC::XML::XMLRE/$RPC::XML::XMLMAP{$1}/ge;
utf8::downgrade($key);
print {$fh} "$key";
$self->{$_}->serialize($fh);
print {$fh} '';
}
print {$fh} '';
return;
}
# Length calculation is a real pain here. But not as bad as base64 promises
sub length ## no critic (ProhibitBuiltinHomonyms)
{
my $self = shift;
my $len = 17; #
for my $key (keys %{$self})
{
$len += 45; # For all the constant XML presence
$len += $self->{$key}->length;
utf8::downgrade($key);
$len += length $key;
}
return $len;
}
###############################################################################
#
# Package: RPC::XML::base64
#
# Description: This is the base64-encoding type. Plain data is passed in,
# plain data is returned. Plain is always returned. All the
# encoding/decoding is done behind the scenes.
#
###############################################################################
package RPC::XML::base64;
use strict;
use base 'RPC::XML::datatype';
use Scalar::Util 'reftype';
sub new
{
my ($class, $value, $encoded) = @_;
require MIME::Base64;
my $self = {};
$RPC::XML::ERROR = q{};
$self->{encoded} = $encoded ? 1 : 0; # Is this already Base-64?
$self->{inmem} = 0; # To signal in-memory vs. filehandle
# First, determine if the call sent actual data, a reference to actual
# data, or an open filehandle.
if (ref $value and reftype($value) eq 'GLOB')
{
# This is a seekable filehandle (or acceptable substitute thereof).
# This assignment increments the ref-count, and prevents destruction
# in other scopes.
binmode $value;
$self->{value_fh} = $value;
$self->{fh_pos} = tell $value;
}
else
{
# Not a filehandle. Might be a scalar ref, but other than that it's
# in-memory data.
$self->{inmem}++;
$self->{value} = ref($value) ? ${$value} : ($value || q{});
# We want in-memory data to always be in the clear, to reduce the tests
# needed in value(), below.
if ($self->{encoded})
{
local $^W = 0; # Disable warnings in case the data is underpadded
$self->{value} = MIME::Base64::decode_base64($self->{value});
$self->{encoded} = 0;
}
}
return bless $self, $class;
}
sub value
{
my ($self, $flag) = @_;
my $as_base64 = (defined $flag and $flag) ? 1 : 0;
# There are six cases here, based on whether or not the data exists in
# Base-64 or clear form, and whether the data is in-memory or needs to be
# read from a filehandle.
if ($self->{inmem})
{
# This is simplified into two cases (rather than four) since we always
# keep in-memory data as cleartext
return $as_base64 ?
MIME::Base64::encode_base64($self->{value}, q{}) : $self->{value};
}
else
{
# This is trickier with filehandle-based data, since we chose not to
# change the state of the data. Thus, the behavior is dependant not
# only on $as_base64, but also on $self->{encoded}. This is why we
# took pains to explicitly set $as_base64 to either 0 or 1, rather than
# just accept whatever non-false value the caller sent. It makes this
# first test possible.
my ($accum, $pos, $res);
$accum = q{};
$self->{fh_pos} = tell $self->{value_fh};
seek $self->{value_fh}, 0, 0;
if ($as_base64 == $self->{encoded})
{
$pos = 0;
while ($res = read $self->{value_fh}, $accum, 1024, $pos)
{
$pos += $res;
}
}
else
{
if ($as_base64)
{
# We're reading cleartext and converting it to Base-64. Read in
# multiples of 57 bytes for best Base-64 calculation. The
# choice of 60 for the multiple is purely arbitrary.
$res = q{};
while (read $self->{value_fh}, $res, 60*57)
{
$accum .= MIME::Base64::encode_base64($res, q{});
}
}
else
{
# Reading Base-64 and converting it back to cleartext. If the
# Base-64 data doesn't have any line-breaks, no telling how
# much memory this will eat up.
local $^W = 0; # Disable padding-length warnings
$pos = $self->{value_fh};
while (defined($res = <$pos>))
{
$accum .= MIME::Base64::decode_base64($res);
}
}
}
seek $self->{value_fh}, $self->{fh_pos}, 0;
return $accum;
}
}
# The value needs to be encoded before being output
sub as_string
{
my $self = shift;
return '' . $self->value('encoded') . '';
}
# If it weren't for Tellme and their damnable WAV files, and ViAir and their
# half-baked XML-RPC server, I wouldn't have to do any of this...
#
# (On the plus side, at least here I don't have to worry about encodings...)
sub serialize
{
my ($self, $fh) = @_;
# If the data is in-memory, just call as_string and pass it down the pipe
if ($self->{inmem})
{
print {$fh} $self->as_string;
}
else
{
# If it's a filehandle, at least we take comfort in knowing that we
# always want Base-64 at this level.
my $buf = q{};
$self->{fh_pos} = tell $self->{value_fh};
seek $self->{value_fh}, 0, 0;
print {$fh} '';
if ($self->{encoded})
{
# Easy-- just use read() to send it down in palatably-sized chunks
while (read $self->{value_fh}, $buf, 4096)
{
print {$fh} $buf;
}
}
else
{
# This actually requires work. As with value(), the 60*57 is based
# on ideal Base-64 chunks, with the 60 part being arbitrary.
while (read $self->{value_fh}, $buf, 60*57)
{
print {$fh} MIME::Base64::encode_base64($buf, q{});
}
}
print {$fh} '';
seek $self->{value_fh}, $self->{fh_pos}, 0;
}
return;
}
# This promises to be a big enough pain that I seriously considered opening
# an anon-temp file (one that's unlinked for security, and survives only as
# long as the FH is open) and passing that to serialize just to -s on the FH.
# But I'll do this the "right" way instead...
sub length ## no critic (ProhibitBuiltinHomonyms)
{
my $self = shift;
# Start with the constant bits
my $len = 17; #
if ($self->{inmem})
{
# If it's in-memory, it's cleartext. Size the encoded version
$len += length(MIME::Base64::encode_base64($self->{value}, q{}));
}
else
{
if ($self->{encoded})
{
# We're lucky, it's already encoded in the file, and -s will do
$len += -s $self->{value_fh};
}
else
{
# Oh bugger. We have to encode it.
my $buf = q{};
my $cnt = 0;
$self->{fh_pos} = tell $self->{value_fh};
seek$self->{value_fh}, 0, 0;
while ($cnt = read $self->{value_fh}, $buf, 60*57)
{
$len += length(MIME::Base64::encode_base64($buf, q{}));
}
seek $self->{value_fh}, $self->{fh_pos}, 0;
}
}
return $len;
}
# This allows writing the decoded data to an arbitrary file. It's useful when
# an application has gotten a RPC::XML::base64 object back from a request, and
# knows that it needs to go straight to a file without being completely read
# into memory, first.
sub to_file
{
my ($self, $file) = @_;
my ($fh, $buf, $do_close, $count) = (undef, q{}, 0, 0);
if (ref $file)
{
if (reftype($file) eq 'GLOB')
{
$fh = $file;
}
else
{
$RPC::XML::ERROR = 'Unusable reference type passed to to_file';
return -1;
}
}
else
{
if (! open $fh, '>', $file) ## no critic (RequireBriefOpen)
{
$RPC::XML::ERROR = "Error opening $file for writing: $!";
return -1;
}
binmode $fh;
$do_close++;
}
# If all the data is in-memory, then we know that it's clear, and we
# don't have to jump through hoops in moving it to the filehandle.
if ($self->{inmem})
{
print {$fh} $self->{value};
$count = CORE::length($self->{value});
}
else
{
# Filehandle-to-filehandle transfer.
# Now determine if the data can be copied over directly, or if we have
# to decode it along the way.
$self->{fh_pos} = tell $self->{value_fh};
seek $self->{value_fh}, 0, 0;
if ($self->{encoded})
{
# As with the caveat in value(), if the base-64 data doesn't have
# any line-breaks, no telling how much memory this will eat up.
local $^W = 0; # Disable padding-length warnings
my $tmp_fh = $self->{value_fh};
while (defined($_ = <$tmp_fh>))
{
$buf = MIME::Base64::decode_base64($_);
print {$fh} $buf;
$count += CORE::length($buf);
}
}
else
{
# If the data is already decoded in the filehandle, then just copy
# it over.
my $size;
while ($size = read $self->{value_fh}, $buf, 4096)
{
print {$fh} $buf;
$count += $size;
}
}
# Restore the position of the file-pointer for the internal FH
seek $self->{value_fh}, $self->{fh_pos}, 0;
}
if ($do_close)
{
if (! close $fh)
{
$RPC::XML::ERROR = "Error closing $file after writing: $!";
return -1;
}
}
return $count;
}
###############################################################################
#
# Package: RPC::XML::fault
#
# Description: This is the class that encapsulates the data for a RPC
# fault-response. Like the others, it takes the relevant
# information and maintains it internally. This is put
# at the end of the datum types, though it isn't really a
# data type in the sense that it cannot be passed in to a
# request. But it is separated so as to better generalize
# responses.
#
###############################################################################
package RPC::XML::fault;
use strict;
use base 'RPC::XML::struct';
use Scalar::Util 'blessed';
# For our new(), we only need to ensure that we have the two required members
sub new
{
my ($class, @args) = @_;
my %args;
$RPC::XML::ERROR = q{};
if (blessed $args[0] and $args[0]->isa('RPC::XML::struct'))
{
# Take the keys and values from the struct object as our own
%args = %{$args[0]->value('shallow')};
}
elsif ((@args == 2) && ($args[0] =~ /^-?\d+$/) && length $args[1])
{
# This is a special convenience-case to make simple new() calls clearer
%args = (faultCode => RPC::XML::int->new($args[0]),
faultString => RPC::XML::string->new($args[1]));
}
else
{
%args = @args;
}
if (! ($args{faultCode} and $args{faultString}))
{
$class = ref($class) || $class;
$RPC::XML::ERROR = "${class}::new: Missing required struct fields";
return;
}
if (scalar(keys %args) > 2)
{
$class = ref($class) || $class;
$RPC::XML::ERROR = "${class}::new: Extra struct fields not allowed";
return;
}
return $class->SUPER::new(%args);
}
# This only differs from the display of a struct in that it has some extra
# wrapped around it. Let the superclass as_string method do most of the work.
sub as_string
{
my $self = shift;
return '' . $self->SUPER::as_string . '';
}
# Again, only differs from struct in that it has some extra wrapped around it.
sub serialize
{
my ($self, $fh) = @_;
print {$fh} '';
$self->SUPER::serialize($fh);
print {$fh} '';
return;
}
# Because of the slight diff above, length() has to be different from struct
sub length ## no critic (ProhibitBuiltinHomonyms)
{
my $self = shift;
return $self->SUPER::length + 30; # For constant XML content
}
# Convenience methods:
sub code { return shift->{faultCode}->value; }
sub string { return shift->{faultString}->value; }
# This is the only one to override this method, for obvious reasons
sub is_fault { return 1; }
###############################################################################
#
# Package: RPC::XML::request
#
# Description: This is the class that encapsulates the data for a RPC
# request. It takes the relevant information and maintains
# it internally until asked to stringify. Only then is the
# XML generated, encoding checked, etc. This allows for
# late-selection of or as a
# containing tag.
#
# This class really only needs a constructor and a method
# to stringify.
#
###############################################################################
package RPC::XML::request;
use strict;
use Scalar::Util 'blessed';
###############################################################################
#
# Sub Name: new
#
# Description: Creating a new request object, in this (reference) case,
# means checking the list of arguments for sanity and
# packaging it up for later use.
#
# Arguments: NAME IN/OUT TYPE DESCRIPTION
# $class in scalar Class/ref to bless into
# @argz in list The exact disposition of the
# arguments is based on the
# type of the various elements
#
# Returns: Success: object ref
# Failure: undef, error in $RPC::XML::ERROR
#
###############################################################################
sub new
{
my ($class, @argz) = @_;
my $name;
$class = ref($class) || $class;
$RPC::XML::ERROR = q{};
if (! @argz)
{
$RPC::XML::ERROR = 'RPC::XML::request::new: At least a method name ' .
'must be specified';
return;
}
# This is the method name to be called
$name = shift @argz;
# Is it valid?
if ($name !~ m{^[\w.:/]+$})
{
$RPC::XML::ERROR =
'RPC::XML::request::new: Invalid method name specified';
return;
}
# All the remaining args must be data.
@argz = RPC::XML::smart_encode(@argz);
return bless { args => [ @argz ], name => $name }, $class;
}
# Accessor methods
sub name { return shift->{name}; }
sub args { return shift->{args}; }
###############################################################################
#
# Sub Name: as_string
#
# Description: This is a fair bit more complex than the simple as_string
# methods for the datatypes. Express the invoking object as
# a well-formed XML document.
#
# Arguments: NAME IN/OUT TYPE DESCRIPTION
# $self in ref Invoking object
# $indent in scalar Indention level for output
#
# Returns: Success: text
# Failure: undef
#
###############################################################################
sub as_string
{
my $self = shift;
my $text;
$RPC::XML::ERROR = q{};
$text = qq();
$text .= "$self->{name}";
for (@{$self->{args}})
{
$text .= '' . $_->as_string . '';
}
$text .= '';
return $text;
}
# The difference between stringifying and serializing a request is much like
# the difference was for structs and arrays. The boilerplate is the same, but
# the destination is different in a sensitive way.
sub serialize
{
my ($self, $fh) = @_;
utf8::downgrade(my $name = $self->{name});
print {$fh} qq();
print {$fh} "$name";
for (@{$self->{args}})
{
print {$fh} '';
$_->serialize($fh);
print {$fh} '';
}
print {$fh} '';
return;
}
# Compared to base64, length-calculation here is pretty easy, much like struct
sub length ## no critic (ProhibitBuiltinHomonyms)
{
my $self = shift;
my $len = 100 + length $RPC::XML::ENCODING; # All the constant XML present
utf8::downgrade(my $name = $self->{name});
$len += length $name;
for (@{$self->{args}})
{
$len += 30; # Constant XML
$len += $_->length;
}
return $len;
}
###############################################################################
#
# Package: RPC::XML::response
#
# Description: This is the class that encapsulates the data for a RPC
# response. As above, it takes the information and maintains
# it internally until asked to stringify. Only then is the
# XML generated, encoding checked, etc. This allows for
# late-selection of or
# as above.
#
###############################################################################
package RPC::XML::response;
use strict;
use Scalar::Util 'blessed';
###############################################################################
#
# Sub Name: new
#
# Description: Creating a new response object, in this (reference) case,
# means checking the outgoing parameter(s) for sanity.
#
# Arguments: NAME IN/OUT TYPE DESCRIPTION
# $class in scalar Class/ref to bless into
# @argz in list The exact disposition of the
# arguments is based on the
# type of the various elements
#
# Returns: Success: object ref
# Failure: undef, error in $RPC::XML::ERROR
#
###############################################################################
sub new
{
my ($class, @argz) = @_;
$class = ref($class) || $class;
$RPC::XML::ERROR = q{};
if (! @argz)
{
$RPC::XML::ERROR = 'RPC::XML::response::new: One of a datatype, ' .
'value or a fault object must be specified';
return;
}
elsif (@argz > 1)
{
$RPC::XML::ERROR = 'RPC::XML::response::new: Responses may take ' .
'only one argument';
return;
}
$argz[0] = RPC::XML::smart_encode($argz[0]);
return bless { value => $argz[0] }, $class;
}
# Accessor/status methods
sub value { return shift->{value}; }
sub is_fault { return shift->{value}->is_fault; }
###############################################################################
#
# Sub Name: as_string
#
# Description: This is a fair bit more complex than the simple as_string
# methods for the datatypes. Express the invoking object as
# a well-formed XML document.
#
# Arguments: NAME IN/OUT TYPE DESCRIPTION
# $self in ref Invoking object
# $indent in scalar Indention level for output
#
# Returns: Success: text
# Failure: undef
#
###############################################################################
sub as_string
{
my $self = shift;
my $text;
$RPC::XML::ERROR = q{};
$text = qq();
$text .= '';
if ($self->{value}->isa('RPC::XML::fault'))
{
$text .= $self->{value}->as_string;
}
else
{
$text .= '' . $self->{value}->as_string .
'';
}
$text .= '';
return $text;
}
# See the comment for serialize() above in RPC::XML::request
sub serialize
{
my ($self, $fh) = @_;
print {$fh} qq();
print {$fh} '';
if ($self->{value}->isa('RPC::XML::fault'))
{
# A fault lacks the params-boilerplate
$self->{value}->serialize($fh);
}
else
{
print {$fh} '';
$self->{value}->serialize($fh);
print {$fh} '';
}
print {$fh} '';
return;
}
# Compared to base64, length-calculation here is pretty easy, much like struct
sub length ## no critic (ProhibitBuiltinHomonyms)
{
my $self = shift;
my $len = 66 + length $RPC::XML::ENCODING; # All the constant XML present
# This boilerplate XML is only present when it is NOT a fault
if (! $self->{value}->isa('RPC::XML::fault'))
{
$len += 47;
}
$len += $self->{value}->length;
return $len;
}
1;
__END__
=head1 NAME
RPC::XML - A set of classes for core data, message and XML handling
=head1 SYNOPSIS
use RPC::XML;
$req = RPC::XML::request->new('fetch_prime_factors',
RPC::XML::int->new(985_120_528));
...
$resp = RPC::XML::ParserFactory->new()->parse(STREAM);
if (ref($resp))
{
return $resp->value->value;
}
else
{
die $resp;
}
=head1 DESCRIPTION
The B package is an implementation of the B standard. The
package as a whole provides classes for data, for clients, for servers and for
parsers (based on the L and L
packages from CPAN).
This module provides a set of classes for creating values to pass to the
constructors for requests and responses. These are lightweight objects, most of
which are implemented as blessed scalar references so as to associate specific
type information with the value. Classes are also provided for requests,
responses and faults (errors).
This module does not actually provide any transport implementation or server
basis. For these, see L and
L, respectively.
=head1 SUBROUTINES/METHODS
At present, two subroutines are available for import. They must be explicitly
imported as part of the C