@@ -1,4 +1,4 @@
-
+ Perl Module RPC::XML Change History
Revision history for the Perl extension module
RPC::XML. This is an implementation of the
@@ -9,6 +9,102 @@
allowing choice of character-set encodings for
XML messages.
+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
@@ -1154,8 +1250,8 @@
* *
All files are tracked from this point forward.
-# Generated on Friday July 10, 2009, 01:30:09 AM -0700
-# Using changelog2x/0.10, App::Changelog2x/0.10, XML::LibXML/1.69,
+# Generated on Thursday September 3, 2009, 10:25:26 AM -0700
+# Using changelog2x/0.11, App::Changelog2x/0.11, XML::LibXML/1.69,
# XML::LibXSLT/1.68, libxml/2.6.32, libxslt/1.1.24 (with exslt)
# XSLT sources:
# $Id: changelog2text.xslt 8 2009-01-19 06:46:50Z rjray $
@@ -6,8 +6,8 @@
xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"
xmlns:xhtml="http://www.w3.org/1999/xhtml"
xsi:schemaLocation="http://www.blackperl.com/2009/01/ChangeLogML etc/ChangeLogML.xsd">
- <project></project>
- <title></title>
+ <project>RPC::XML</project>
+ <title>Perl Module RPC::XML Change History</title>
<description>
Revision history for the Perl extension module RPC::XML. This is an
implementation of the XML-RPC standard as described at the URL
@@ -15,6 +15,153 @@
extensions to the base protocol in terms of supporting HTTP/1.1 and
allowing choice of character-set encodings for XML messages.
</description>
+ <release date="2009-09-03T10:25:00-07:00" version="0.69" sc:tag="0.69">
+ <change git:commit="da64377d20640d347436c856c0fbc59c09c96ecd">
+ <fileset>
+ <file path="t/00_load.t" />
+ <file path="t/01_pod.t" />
+ <file path="t/02_pod_coverage.t" />
+ <file path="t/10_data.t" />
+ <file path="t/11_base64_fh.t" />
+ <file path="t/12_nil.t" />
+ <file path="t/15_serialize.t" />
+ <file path="t/20_parser.t" />
+ <file path="t/50_client.t" />
+ </fileset>
+ <description>
+ Minor clean-up of old CVS/SVN keyword references.
+ </description>
+ </change>
+ <change git:commit="b5da315f4fe1b3ffbf179c334ef1b58af625d483">
+ <fileset>
+ <file path="lib/RPC/XML/Client.pm" />
+ <file path="lib/RPC/XML/Parser.pm" />
+ <file path="lib/RPC/XML/Parser/XMLParser.pm" action="ADD" />
+ <file path="lib/RPC/XML/ParserFactory.pm" action="ADD" />
+ <file path="lib/RPC/XML/Server.pm" />
+ <file path="t/20_parser.t" action="DELETE" />
+ <file path="t/20_xml_parser.t" action="ADD" />
+ <file path="t/29_parserfactory.t" action="ADD" />
+ <file path="t/40_server.t" />
+ <file path="t/util.pl" />
+ </fileset>
+ <description>
+ Converted parsing to be from a specific class to a parser-factory style.
+ This included renaming the existing parser class and shuffling tests
+ around.
+ </description>
+ </change>
+ <change git:commit="1115ea4070938edcc3ae0bb192c5fae47c542ab8">
+ <file path="t/70_compression_detect.t" />
+ <description>
+ Cleaner approach to scrubbing symbol tables.
+ </description>
+ </change>
+ <change git:commit="6cc8cea15f527a8d2a3f8e402941bcd7a93b7c13">
+ <fileset>
+ <file path="t/00_load.t" />
+ <file path="t/01_pod.t" />
+ <file path="t/02_pod_coverage.t" />
+ <file path="t/03_meta.t" action="ADD" />
+ <file path="t/04_minimumversion.t" action="ADD" />
+ <file path="t/05_critic.t" action="ADD" />
+ </fileset>
+ <description>
+ New tests, and developer-specific tests changed to only run in my copy.
+ </description>
+ </change>
+ <change git:commit="e31cca20b53d062faa2234f10f8794e4e7058c27">
+ <fileset>
+ <file path="lib/RPC/XML/Client.pm" />
+ <file path="lib/RPC/XML/Parser/XMLParser.pm" />
+ <file path="lib/RPC/XML/Server.pm" />
+ <file path="t/11_base64_fh.t" />
+ <file path="t/15_serialize.t" />
+ <file path="t/20_xml_parser.t" />
+ <file path="t/30_method.t" />
+ <file path="t/35_namespaces.t" />
+ <file path="t/40_server.t" />
+ <file path="t/41_server_hang.t" />
+ <file path="t/50_client.t" />
+ </fileset>
+ <description>
+ <xhtml:a href="http://rt.cpan.org/Ticket/Display.html?id=47806">RT #47806</xhtml:a>:
+ One more patch for Windows compatibility with temp-files.
+ </description>
+ </change>
+ <change git:commit="03e00c1944254eee3dba120c2887bc34a5655a35">
+ <fileset>
+ <file path="lib/Apache/RPC/Server.pm" />
+ <file path="lib/Apache/RPC/Status.pm" />
+ <file path="lib/RPC/XML.pm" />
+ <file path="lib/RPC/XML/Client.pm" />
+ <file path="lib/RPC/XML/Function.pm" />
+ <file path="lib/RPC/XML/Method.pm" />
+ <file path="lib/RPC/XML/Parser.pm" />
+ <file path="lib/RPC/XML/Parser/XMLParser.pm" />
+ <file path="lib/RPC/XML/ParserFactory.pm" />
+ <file path="lib/RPC/XML/Procedure.pm" />
+ <file path="lib/RPC/XML/Server.pm" />
+ </fileset>
+ <description>
+ Fixes based on Perl::Critic and other best-practices techniques.
+ </description>
+ </change>
+ <change git:commit="e02196452fd86135b24cc936f969ee5a261c8483">
+ <file path="etc/make_method" />
+ <description>
+ Also made changes based on Perl::Critic.
+ </description>
+ </change>
+ <change git:commit="3c01cda3398e0b0fceef2cc36492ccbff6aba773">
+ <fileset>
+ <file path="MANIFEST" />
+ <file path="lib/RPC/XML/Parser.pm" />
+ <file path="lib/RPC/XML/Parser/XMLParser.pm" />
+ </fileset>
+ <description>
+ 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.
+ </description>
+ </change>
+ <change git:commit="4ed1f2ced8cb30ea4776b54ccab8c6ea774a619a">
+ <file path="lib/RPC/XML/Parser/XMLParser.pm" />
+ <description>
+ Slight tweak to make this 5.6.1-compatible.
+ </description>
+ </change>
+ <change git:commit="b45db2993c694d312d2bee27a0a1cda850acb4d4">
+ <fileset>
+ <file path="lib/RPC/XML/Procedure.pm" />
+ <file path="lib/RPC/XML/Server.pm" />
+ </fileset>
+ <description>
+ <xhtml:a href="http://rt.cpan.org/Ticket/Display.html?id=42736">RT #42736</xhtml:a>:
+ Support user-adjustment of server-based faults, and normalize the
+ existing faults.
+ </description>
+ </change>
+ <change git:commit="b449b138f243ad40e61a110bbe9514be277ee5b1">
+ <file path="lib/RPC/XML/Procedure.pm" />
+ <description>
+ Fix encoding of return values from call() when the method called is of
+ type Function (and thus has no strict signatures).
+ </description>
+ </change>
+ <change git:commit="9a0fe50ad9648716e287717d2007a439946930a1">
+ <fileset>
+ <file path="lib/RPC/XML.pm" />
+ <file path="t/13_no_deep_recursion.t" action="ADD" />
+ </fileset>
+ <description>
+ <xhtml:a href="http://rt.cpan.org/Ticket/Display.html?id=41063">RT #41063</xhtml:a>:
+ Re-visit how arrays and structs are smart-encoded and constructed, so
+ as to avoid cyclical data structure references.
+ </description>
+ </change>
+ </release>
<release date="2009-07-10T01:30:00-07:00" version="0.67" sc:tag="0.67">
<change git:commit="67180ef41cdfa56c771e6b9dd8d5f1f116b7dc77">
<fileset>
@@ -24,6 +24,8 @@ lib/RPC/XML/Client.pm # Basic client class
lib/RPC/XML/Function.pm # Reference client implementation
lib/RPC/XML/Method.pm # Class encapsulation of RPC server methods
lib/RPC/XML/Parser.pm # Parser class for client and server
+lib/RPC/XML/Parser/XMLParser.pm
+lib/RPC/XML/ParserFactory.pm
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
@@ -54,7 +56,8 @@ t/10_data.t
t/11_base64_fh.t
t/12_nil.t
t/15_serialize.t
-t/20_parser.t
+t/20_xml_parser.t
+t/29_parserfactory.t
t/30_method.t
t/35_namespaces.t
t/40_server.t
@@ -1,6 +1,6 @@
--- #YAML:1.0
name: RPC-XML
-version: 0.67
+version: 0.69
abstract: Data, client and server classes for XML-RPC
author:
- Randy J. Ray
@@ -15,7 +15,7 @@ requires:
File::Spec: 0.8
LWP: 5.801
perl: 5.006001
- Scalar::Util: 1.2
+ Scalar::Util: 1.19
Test::More: 0
XML::Parser: 2.31
no_index:
@@ -11,6 +11,10 @@ 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, '');
+my $test_config = File::Spec->catfile($dir, 't', 'test.conf');
+
eval "require LWP;";
if ($LWP::VERSION and $LWP::VERSION < 5.801)
{
@@ -27,25 +31,61 @@ if ($LWP::VERSION and $LWP::VERSION < 5.801)
END
}
-eval "use XML::LibXML;";
-if ($@ or $XML::LibXML::VERSION < 1.58)
-{
- print STDERR <<END;
-@@@@@
- Please note!
-
- Starting with release 0.70 (previously planned for 0.60 but pushed
- back), the XML parsing will switch to using the XML::LibXML module, in
- place of XML::Parser. You either do not have this module, or it is a
- version older than 1.58, the minimum version that will be
- required. When release 0.70 is made available, you will not be able to
- build this package without at least version 1.58 of XML::LibXML.
-@@@@@
-
-END
-}
-
-$cwd = cwd;
+my %parserlist = ();
+my %recommended = ();
+
+# eval "use XML::Parser";
+# if ($@ or $XML::Parser::VERSION < 2.31)
+# {
+# print STDERR <<END;
+# @@@@@
+# XML::Parser not found
+
+# You do not have to have this package if you plan to always
+# explicitly choose an alternate parser in RPC::XML::ParserFactory,
+# RPC::XML::Client or RPC::XML::Server. It's installation is
+# recommended, however. The default selection of parser will not
+# work without this installed.
+# @@@@@
+
+# END
+
+# $recommended{'XML::Parser'} = '2.31';
+# }
+# else
+# {
+# $parserlist{'XML::Parser'} = $XML::Parser::VERSION;
+# }
+
+# eval "use XML::LibXML;";
+# if ($@ or $XML::LibXML::VERSION < 1.58)
+# {
+# print STDERR <<END;
+# @@@@@
+# XML::LibXML not found
+
+# The RPC::XML::ParserFactory class (the replacement for the previous
+# RPC::XML::Parser class) can use this parser if you have it installed
+# and request it when instantiating either RPC::XML::Client or
+# RPC::XML::Server (or RPC::XML::ParserFactor itself, directly).
+# @@@@@
+
+# END
+
+# $recommended{'XML::LibXML'} = '1.58';
+# }
+# else
+# {
+# $parserlist{'XML::LibXML'} = $XML::LibXML::VERSION;
+# }
+
+# Write test.conf file
+$parserlist{'XML::Parser'}++;
+open(my $fh, "> $test_config")
+ or die "Cannot open $test_config for writing: $!";
+print $fh sprintf("# Generated by $0 on %s\n", scalar localtime);
+print $fh 'parsers = ' . join(', ' => sort keys %parserlist) . "\n";
+close $fh;
$CLEAN = 'pod2html-* *.html *.spec *.rpm rpmrc rpmmacro *.log t/*.log ' .
'META.yml *.ppd ';
@@ -84,17 +124,18 @@ find(sub {
WriteMakefile(
NAME => 'RPC::XML',
- VERSION => '0.67',
+ VERSION => '0.69',
AUTHOR => 'Randy J. Ray',
ABSTRACT => 'Data, client and server classes for XML-RPC',
EXE_FILES => \@scripts,
PM => \%PM_FILES,
- PREREQ_PM => { XML::Parser => 2.31,
- File::Spec => 0.8,
- constant => 1.03,
- Scalar::Util => 1.20,
- Test::More => 0,
- LWP => 5.801 },
+ PREREQ_PM => { 'File::Spec' => 0.8,
+ 'constant' => 1.03,
+ 'Scalar::Util' => 1.19,
+ 'Test::More' => 0,
+ 'LWP' => 5.801,
+ 'XML::Parser' => 2.31 },
+ # %parserlist },
dist => { COMPRESS => 'gzip -9f' },
clean => { FILES => $CLEAN },
LICENSE => 'perl',
@@ -1,6 +1,6 @@
RPC::XML - An implementation of XML-RPC
-Version: 0.67
+Version: 0.69
WHAT IS IT
@@ -66,8 +66,96 @@ The LGPL 2.1: http://www.opensource.org/licenses/lgpl-2.1.php
CHANGES
+* 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
-* 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.
+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.
@@ -14,14 +14,14 @@ not run its Makefile.PL or Build.PL.
-----BEGIN PGP SIGNED MESSAGE-----
Hash: SHA1
-SHA1 906fca9d72d8534b59eb659f1f610cdb4af0f8b5 ChangeLog
-SHA1 1b4c52cbfcf208911c985169e0950f7b2eb0a578 ChangeLog.xml
-SHA1 4bfed1e5bed91fe3bfc1a83ec43bdb6dc7fcedd8 MANIFEST
-SHA1 46e6e9e3cb6b7476496192bdb1f0cae499393737 META.yml
-SHA1 a77a4132a614fbcd166ecbd434cd7cfa4adcc489 Makefile.PL
-SHA1 f0fd357de4399e8b9e30712fb92e4ab5963d0f99 README
+SHA1 b6dcbbb74f0a0844a980880a6d9429c293d5ee65 ChangeLog
+SHA1 dacab13c23bdfe5e89902c7896c36a84b1afef47 ChangeLog.xml
+SHA1 70380e97e3a7d135c049f4aa752f125898bbee2d MANIFEST
+SHA1 019c4ce53ccabeaa7e8797f1871477efa1a5fa52 META.yml
+SHA1 49cfbf3be4d287d7ca03d6c8066d979b0dc0775f Makefile.PL
+SHA1 abf75c12af9b605da57d60630eeba91b39ea463c README
SHA1 d210d832fa02c0f0b79d7c5c65c4a72c3315e230 README.apache2
-SHA1 4389a5f0ad9caa86b4d3d2578dcabe67105302ca etc/make_method
+SHA1 297a1d067f33ef14b98256fc306f387814de0e42 etc/make_method
SHA1 e6a42047da332c81c196ce8f043977d25ccfde8e etc/rpc-method.dtd
SHA1 4ce2dae81316825ac0537d58f36548b250aac5fe ex/Makefile
SHA1 72823d6ce7ceb5ed435f18ed339cc9201880e2f2 ex/README
@@ -31,18 +31,20 @@ SHA1 a95f3432d56cfd8bb74090063248be2df6637ab6 ex/linux.proc.cpuinfo.help
SHA1 c7f4c28760897c7e2ed81e94445abe22fc663aaf ex/linux.proc.meminfo.base
SHA1 0d5d3d59e82e2466147878e7ffc543d43535e7c9 ex/linux.proc.meminfo.code
SHA1 a452d760da2e94baf64cc660c965753ba2b05195 ex/linux.proc.meminfo.help
-SHA1 65c5911c4694b4ef90ca1711bde8a95af7e099b2 lib/Apache/RPC/Server.pm
-SHA1 de5b7a8ed21ae70649ca1a3c2b243def2cd10092 lib/Apache/RPC/Status.pm
+SHA1 af5b115a02602b1fcc58db7d353c2f35e3151cb9 lib/Apache/RPC/Server.pm
+SHA1 07571f739e2a7787c4c83afbdbdc52502d5f58a1 lib/Apache/RPC/Status.pm
SHA1 644075447f174b9c5704aece6c8a11988a6feb33 lib/Apache/RPC/status.base
SHA1 d87580bfe927be390284fd2f3712ba2b5f4173b2 lib/Apache/RPC/status.code
SHA1 9ef9b17398ef8bd90a84d6b64b7721a9ed7717af lib/Apache/RPC/status.help
-SHA1 a68515510bab1a3dbf5c4de1fce7842e748d7b0c lib/RPC/XML.pm
-SHA1 888be0d7e7ffdaf3c53fc05340cb96fd83194c29 lib/RPC/XML/Client.pm
-SHA1 d94c5845f1bee94677794c1d022f975b8a5ec99a lib/RPC/XML/Function.pm
-SHA1 f3f34dc634762ea8bde150b9080ad73b595b356d lib/RPC/XML/Method.pm
-SHA1 17b18032f64a42774ba3c87a51f245b1813c506c lib/RPC/XML/Parser.pm
-SHA1 e8a147ef5ebdea6e319879779ee6ed85ad1830fe lib/RPC/XML/Procedure.pm
-SHA1 7cd469ff8481636f2ff3564bb76eb3862ddfb82a lib/RPC/XML/Server.pm
+SHA1 3abe761de8ffe21af4281890d02eed1f6eb80af9 lib/RPC/XML.pm
+SHA1 ed82105b92a774ca46483601399d367449350c5e lib/RPC/XML/Client.pm
+SHA1 c51ab9b8b3d17afc3a88d40b1ce0b97edc72dcd4 lib/RPC/XML/Function.pm
+SHA1 b31d652bead6e3da7d642b0444c8e671392e8813 lib/RPC/XML/Method.pm
+SHA1 94d9aaf9436927c88351c0fe368abaa08a6aa384 lib/RPC/XML/Parser.pm
+SHA1 4ebbea5d15fe1090f9608aa5f4a6bcf07da8b3f6 lib/RPC/XML/Parser/XMLParser.pm
+SHA1 28adf942713d57b07c12ed4727d859a9c0337c1b lib/RPC/XML/ParserFactory.pm
+SHA1 caa67377d85c79cf5ac0e5aee48c8c4288da4b2d lib/RPC/XML/Procedure.pm
+SHA1 bc91af849eed4501ea600855ba3808b7caae75fa lib/RPC/XML/Server.pm
SHA1 3b1b1815be69edabfad34b45f93259aeab6e314e methods/identity.base
SHA1 dfb493b476b4284b10597ddcfa33c3fbb1f38658 methods/identity.code
SHA1 2ac37e1c74e4a534e55f20cb53a2023b2eaf80bc methods/identity.help
@@ -64,21 +66,22 @@ SHA1 1868a6aeee193bfaec790733c7e5e3103bdb1a26 methods/multicall.help
SHA1 644075447f174b9c5704aece6c8a11988a6feb33 methods/status.base
SHA1 7c1cd809453dbe35446672c1aedac5243e5d344e methods/status.code
SHA1 2a0e71934ae43a0c53565eb899c1e9ab06a754c9 methods/status.help
-SHA1 2ba22e884462a2e20b2a4be2ae6f7f5729572616 t/00_load.t
-SHA1 dc9be39a8b97c6ff38260c398520b095c6f2872f t/01_pod.t
-SHA1 788e02626aeecd6739238446a17e5b863782b38f t/02_pod_coverage.t
-SHA1 1942734ae6654d0a0da0681209ee46d44102fa99 t/10_data.t
-SHA1 ab4cf45e526b6d362c6752d0adeacfc4b6a4b400 t/11_base64_fh.t
-SHA1 d77edf41f9c8507b849a13eb649bfd49c051f601 t/12_nil.t
-SHA1 4f2db20e40eb52ad5047ece97fc529079fb0e920 t/15_serialize.t
-SHA1 72439b9a75e8f0135231f0ef99ddf3ea495c53ac t/20_parser.t
-SHA1 71414471c2222bfff51678a91763027a43d4f470 t/30_method.t
-SHA1 a19ee8a3f37027ee6d9de49cb331907e6e6de39c t/35_namespaces.t
-SHA1 2704f5da9776de51a1f43a4257a01ac8f25c4b50 t/40_server.t
-SHA1 1f84874e532cfd374465b4483718984739d84971 t/41_server_hang.t
-SHA1 006615241f01a80b4ac43f17477ea042917f29fa t/50_client.t
+SHA1 333d72d0e7b8fd6d982181223866353429fe3fcf t/00_load.t
+SHA1 9f09733cd3cb1f3bd151637039e62fd4dcd8e844 t/01_pod.t
+SHA1 9b37e5a8f0cb04269d19c88af47e31dda9156bb9 t/02_pod_coverage.t
+SHA1 ab343d0dab487c66e115f9117d47aeaf5fce216b t/10_data.t
+SHA1 8a72f8c5766105c353a87db6616246b98bb9c729 t/11_base64_fh.t
+SHA1 5fef37213eea6345dd528e2a007e94d4cf2292bc t/12_nil.t
+SHA1 0b7f4e29a3b50bd61543434e9ee7cb540dfc0779 t/15_serialize.t
+SHA1 f25a98d7c500e5f1b8638e48775b618a2467ec0e t/20_xml_parser.t
+SHA1 aad1de4bfaa98b7fd25788874a5bc65b0cb3577b t/29_parserfactory.t
+SHA1 98122d9c4adcaf2989510864bf0ee7a91c3d7305 t/30_method.t
+SHA1 7e25a7f372fe7142cb98ca949f78885e89d55ffe t/35_namespaces.t
+SHA1 170392bcf7d8d658f92ee3aa336b41dd39d7a6b3 t/40_server.t
+SHA1 9e3ea90d8280d00d396c504b74a0eab80adba831 t/41_server_hang.t
+SHA1 cf3ff15153258942ba8c4fff58e0a567e1691338 t/50_client.t
SHA1 159600810136f11de3fa41d160fda57a2f0647a7 t/60_net_server.t
-SHA1 5bd19f446ce3ac8f47928f80679694e1943f8e74 t/70_compression_detect.t
+SHA1 84a8362a1a4f7c02d04bdf8633f0000e03c56fce t/70_compression_detect.t
SHA1 99b3f1434b7223d74a8ed49e5b67d87d27c2e457 t/meth_bad_1.xpl
SHA1 14e3dfb6129a9d6f5bfd15bd490daa9010f6bac9 t/meth_bad_2.xpl
SHA1 99509569e177902aceaac0a7681c421f22a356b6 t/meth_good_1.xpl
@@ -86,11 +89,11 @@ SHA1 5f8149cf024adaa956307ebb2de9e615f1dc58a5 t/namespace1.xpl
SHA1 14a969cc89b23d6daad963f716d64fef23dd819c t/namespace2.xpl
SHA1 f50c01dd06bfa60f0c2bc12143afb35af09fcdad t/namespace3.xpl
SHA1 8ef631d58ca4a1386dfc0218fd71667260f974ad t/svsm_text.gif
-SHA1 477f11fbd0f64d7d3140fc5cb2f0aa0deab7137a t/util.pl
+SHA1 c8ea8ddf621b6231a3693b79fc28288200ab8b8a t/util.pl
-----BEGIN PGP SIGNATURE-----
Version: GnuPG v1.4.9 (GNU/Linux)
-iEYEARECAAYFAkpW/L0ACgkQ3Cp33jjp81XiSwCfUJwlrJPPyNrrCLy40Pvpj2Fd
-DdEAn3gqEckabiXZ8pGzPrUCd3zUlypj
-=jLJ4
+iEYEARECAAYFAkqf/oMACgkQ3Cp33jjp81VnWQCfQiWBtW9N5DQkT/vYIhxxkk5E
+axUAn2nq/dMcWw8BCcEsYoZFykTyJYhe
+=eQS2
-----END PGP SIGNATURE-----
@@ -163,7 +163,7 @@ else
if ($opts{signature})
{
- @siglist = map { s/:/ /g; $_ } @{$opts{signature}};
+ @siglist = map { (my $val = $_) =~ s/:/ /g; $val } @{$opts{signature}};
}
else
{
@@ -43,13 +43,16 @@ use RPC::XML;
use RPC::XML::Server;
@Apache::RPC::Server::ISA = qw(RPC::XML::Server);
+## no critic (ProhibitSubroutinePrototypes)
+
BEGIN
{
$Apache::RPC::Server::INSTALL_DIR = (File::Spec->splitpath(__FILE__))[1];
%Apache::RPC::Server::SERVER_TABLE = ();
}
-$Apache::RPC::Server::VERSION = '1.33';
+our $VERSION = '1.34';
+$VERSION = eval $VERSION; ## no critic
sub version { $Apache::RPC::Server::VERSION }
@@ -52,6 +52,8 @@ use Apache;
use Apache::Constants qw(DECLINED OK SERVER_VERSION);
use CGI;
+## no critic (ProhibitSubroutinePrototypes)
+
# We use the server module to get the class methods for server objects, etc.
require Apache::RPC::Server;
require RPC::XML::Method;
@@ -61,7 +63,8 @@ $SERVER_CLASS = 'Apache::RPC::Server';
$STARTED = scalar localtime $^T;
$PERL_VER = $^V ? sprintf "v%vd", $^V : $];
-$Apache::RPC::Status::VERSION = '1.09';
+our $VERSION = '1.10';
+$VERSION = eval $VERSION; ## no critic
#
# %proto is the prototype set of screens/handlers that this class knows about.
@@ -83,7 +86,7 @@ my %IS_INSTALLED = ();
{
local $SIG{__DIE__};
%IS_INSTALLED = map {
- $_, (eval("require $_") || 0);
+ $_, (eval("require $_") || 0); ## no critic
} qw(Data::Dumper Devel::Symdump B Apache::Request Apache::Peek
Apache::Symbol);
}
@@ -41,9 +41,10 @@ use LWP::UserAgent;
use HTTP::Request;
use URI;
use Scalar::Util 'blessed';
+use File::Temp;
use RPC::XML;
-require RPC::XML::Parser;
+require RPC::XML::ParserFactory;
BEGIN
{
@@ -52,7 +53,8 @@ BEGIN
$COMPRESSION_AVAILABLE = ($@) ? '' : 'deflate';
}
-$VERSION = '1.29';
+$VERSION = '1.31';
+$VERSION = eval $VERSION; ## no critic
###############################################################################
#
@@ -140,10 +142,10 @@ sub new
delete $attrs{error_handler};
}
- # Get the RPC::XML::Parser instance
- $self->{__parser} = RPC::XML::Parser->new($attrs{parser} ?
- @{$attrs{parser}} : ()) or
- return "${class}::new: Unable to get RPC::XML::Parser object";
+ # Get the RPC::XML::Parser instance from the ParserFactory
+ $self->{__parser} =
+ RPC::XML::ParserFactory->new($attrs{parser} ? @{$attrs{parser}} : ())
+ or return "${class}::new: Unable to get RPC::XML::Parser object";
delete $attrs{parser};
# Now preserve any remaining attributes passed in
@@ -182,7 +184,7 @@ sub simple_request
unless (ref $return)
{
$RPC::XML::ERROR = ref($self) . "::simple_request: $return";
- return undef;
+ return;
}
$return->value;
}
@@ -208,7 +210,7 @@ sub send_request
my ($self, $req, @args) = @_;
my ($me, $message, $response, $reqclone, $content, $can_compress, $value,
- $do_compress, $req_fh, $tmpfile, $com_engine);
+ $do_compress, $req_fh, $tmpdir, $com_engine);
$me = ref($self) . '::send_request';
@@ -241,13 +243,11 @@ sub send_request
require File::Spec;
require Symbol;
# Start by creating a temp-file
- $tmpfile = $self->message_temp_dir || File::Spec->tmpdir;
- ($tmpfile = File::Spec->catfile($tmpfile, __PACKAGE__ . $$ . time)) =~
- s/::/-/g; # Colons in filenames bad on some systems!
+ $tmpdir = $self->message_temp_dir || File::Spec->tmpdir;
$req_fh = Symbol::gensym();
- return "$me: Error opening $tmpfile: $!"
- unless (open($req_fh, "+> $tmpfile"));
- unlink $tmpfile;
+ return "$me: Error opening tmpfile: $!"
+ unless ($req_fh = File::Temp->new(UNLINK=>1, DIR=>$tmpdir));
+ binmode($req_fh);
# Make it auto-flush
my $old_fh = select($req_fh); $| = 1; select($old_fh);
@@ -259,10 +259,8 @@ sub send_request
if ($do_compress && ($req->length >= $self->compress_thresh))
{
my $fh2 = Symbol::gensym();
- $tmpfile .= '-2';
- return "$me: Error opening $tmpfile: $!"
- unless (open($fh2, "+> $tmpfile"));
- unlink $tmpfile;
+ return "$me: Error opening tmpfile: $!"
+ unless ($fh2 = File::Temp->new(UNLINK=>1, DIR=>$tmpdir));
# Make it auto-flush
$old_fh = select($fh2); $| = 1; select($old_fh);
@@ -304,8 +302,7 @@ sub send_request
$reqclone->content_length(-s $req_fh);
$reqclone->content(sub {
my $b = '';
- return undef
- unless defined(read($req_fh, $b, 4096));
+ return unless defined(read($req_fh, $b, 4096));
$b;
});
}
@@ -463,7 +460,7 @@ sub credentials
# Immutable accessor methods
BEGIN
{
- no strict 'refs';
+ no strict 'refs'; ## no critic
for my $method (qw(useragent request compress_re compress parser))
{
@@ -593,11 +590,11 @@ treated specially:
=item parser
-If this parameter is passed, the value following it is expected to be an
-array reference. The contents of that array are passed to the B<new> method
-of the B<RPC::XML::Parser> object that the client object caches for its use.
-See the B<RPC::XML::Parser> manual page for a list of recognized parameters
-to the constructor.
+If this parameter is passed, the value following it is expected to be an array
+reference. The contents of that array are passed to the B<new> method of the
+B<RPC::XML::ParserFactory>-generated object that the client object caches for
+its use. See the B<RPC::XML::ParserFactory> manual page for a list of
+recognized parameters to the constructor.
=item useragent
@@ -641,7 +638,7 @@ temporary file, and spooled from there instead. This is useful for cases in
which the request includes B<RPC::XML::base64> objects that are themselves
spooled from file-handles. This test is independent of compression, so even
if compression of a request would drop it below this threshhold, it will be
-spooled anyway. The file itself is unlinked after the file-handle is created,
+spooled anyway. The file itself is created via File::Temp with UNLINK=>1,
so once it is freed the disk space is immediately freed.
=item message_temp_dir
@@ -846,6 +843,6 @@ L<RPC::XML>, L<RPC::XML::Server>
=head1 AUTHOR
-Randy J. Ray <rjray@blackperl.com>
+Randy J. Ray C<< <rjray@blackperl.com> >>
=cut
@@ -39,7 +39,8 @@ use AutoLoader 'AUTOLOAD';
require RPC::XML::Procedure;
@ISA = qw(RPC::XML::Procedure);
-$VERSION = '1.07';
+$VERSION = '1.08';
+$VERSION = eval $VERSION; ## no critic
###############################################################################
#
@@ -32,7 +32,8 @@ use vars qw($VERSION);
require RPC::XML::Procedure;
@RPC::XML::Method::ISA = qw(RPC::XML::Procedure);
-$VERSION = '1.11';
+$VERSION = '1.12';
+$VERSION = eval $VERSION; ## no critic
1;
@@ -0,0 +1,708 @@
+###############################################################################
+#
+# This file copyright (c) 2001-2009 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 is the RPC::XML::Parser::XMLParser class, a container
+# for the XML::Parser class.
+#
+# Functions: new
+# parse
+# message_init
+# message_end
+# tag_start
+# error
+# stack_error
+# tag_end
+# char_data
+# extern_ent
+# final
+#
+# Libraries: RPC::XML
+# XML::Parser
+#
+# Global Consts: Uses $RPC::XML::ERROR
+#
+# Environment: None.
+#
+###############################################################################
+
+package RPC::XML::Parser::XMLParser;
+
+use 5.006001;
+use strict;
+use warnings;
+use vars qw($VERSION @ISA);
+use subs qw(error stack_error new message_init message_end tag_start tag_end
+ final char_data parse);
+use base 'RPC::XML::Parser';
+
+# These constants are only used by the internal stack machine
+use constant PARSE_ERROR => 0;
+use constant METHOD => 1;
+use constant METHODSET => 2;
+use constant RESPONSE => 3;
+use constant RESPONSESET => 4;
+use constant STRUCT => 5;
+use constant ARRAY => 6;
+use constant DATATYPE => 7;
+use constant ATTR_SET => 8;
+use constant METHODNAME => 9;
+use constant VALUEMARKER => 10;
+use constant PARAMSTART => 11;
+use constant PARAM => 12;
+use constant STRUCTMEM => 13;
+use constant STRUCTNAME => 14;
+use constant DATAOBJECT => 15;
+use constant PARAMLIST => 16;
+use constant NAMEVAL => 17;
+use constant MEMBERENT => 18;
+use constant METHODENT => 19;
+use constant RESPONSEENT => 20;
+use constant FAULTENT => 21;
+use constant FAULTSTART => 22;
+
+# This is to identify valid types
+use constant VALIDTYPES => { map { $_, 1 } qw(int i4 i8 string double
+ boolean dateTime.iso8601
+ base64) };
+# This maps XML tags to stack-machine tokens
+use constant TAG2TOKEN => { methodCall => METHOD,
+ methodResponse => RESPONSE,
+ methodName => METHODNAME,
+ params => PARAMSTART,
+ param => PARAM,
+ value => VALUEMARKER,
+ fault => FAULTSTART,
+ array => ARRAY,
+ struct => STRUCT,
+ member => STRUCTMEM,
+ name => STRUCTNAME };
+
+# Members of the class
+use constant M_STACK => 0;
+use constant M_CDATA => 1;
+use constant M_BASE64_TO_FH => 2;
+use constant M_BASE64_TEMP_DIR => 3;
+use constant M_SPOOLING_BASE64_DATA => 4;
+
+use XML::Parser;
+require File::Spec;
+require File::Temp;
+
+require RPC::XML;
+
+$VERSION = '1.19';
+$VERSION = eval $VERSION; ## no critic
+
+###############################################################################
+#
+# Sub Name: new
+#
+# Description: Constructor. Save any important attributes, leave the
+# heavy lifting for the parse() routine and XML::Parser.
+#
+# Arguments: NAME IN/OUT TYPE DESCRIPTION
+# $class in scalar Class we're initializing
+# %attr in hash Any extras the caller wants
+#
+# Globals: $RPC::XML::ERROR
+#
+# Returns: Success: object ref
+# Failure: undef
+#
+###############################################################################
+sub new
+{
+ my $class = shift;
+ my %attrs = @_;
+
+ my $self = [];
+
+ while (my ($key, $val) = each %attrs)
+ {
+ if ($key eq 'base64_to_fh')
+ {
+ $self->[M_BASE64_TO_FH] = $val;
+ }
+ elsif ($key eq 'base64_temp_dir')
+ {
+ $self->[M_BASE64_TEMP_DIR] = $val;
+ }
+ }
+
+ bless $self, $class;
+}
+
+###############################################################################
+#
+# Sub Name: parse
+#
+# Description: Parse the requested string or stream. This behaves mostly
+# like parse() in the XML::Parser namespace, but does some
+# extra, as well.
+#
+# Arguments: NAME IN/OUT TYPE DESCRIPTION
+# $self in ref Object of this class
+# $stream in scalar Either the string to parse or
+# an open filehandle of sorts
+#
+# Returns: Success: ref to request or response object
+# Failure: error string
+#
+###############################################################################
+sub parse
+{
+ my ($self, $stream) = @_;
+
+ my $parser = XML::Parser->new(Namespaces => 0,
+ ParseParamEnt => 0,
+ ErrorContext => 1,
+ Handlers =>
+ {
+ Init => sub { message_init $self, @_ },
+ Start => sub { tag_start $self, @_ },
+ End => sub { tag_end $self, @_ },
+ Char => sub { char_data $self, @_ },
+ Final => sub { final $self, @_ },
+ ExternEnt => sub { extern_ent $self, @_ },
+ });
+
+ # If there is no stream given, then create an incremental parser handle
+ # and return it.
+ return $parser->parse_start() unless $stream;
+
+ my $retval;
+ eval { $retval = $parser->parse($stream) };
+ return $@ if $@;
+
+ $retval;
+}
+
+# This is called when a new document is about to start parsing
+sub message_init
+{
+ my ($robj, $self) = @_;
+
+ $robj->[M_STACK] = [];
+ $self;
+}
+
+# This is called when the parsing process is complete
+sub final
+{
+ my ($robj, $self) = @_;
+
+ # Look at the top-most marker, it'll need to be one of the end cases
+ my $marker = pop(@{$robj->[M_STACK]});
+ # There should be only on item on the stack after it
+ my $retval = pop(@{$robj->[M_STACK]});
+ # If the top-most marker isn't the error marker, check the stack
+ $retval = 'RPC::XML Error: Extra data on parse stack at document end'
+ if ($marker != PARSE_ERROR and (@{$robj->[M_STACK]}));
+
+ $retval;
+}
+
+# This gets called each time an opening tag is parsed
+sub tag_start
+{
+ my ($robj, $self, $elem, %attr) = @_;
+
+ $robj->[M_CDATA] = [];
+ return if ($elem eq 'data');
+
+ if (TAG2TOKEN->{$elem})
+ {
+ push(@{$robj->[M_STACK]}, TAG2TOKEN->{$elem});
+ }
+ # Note that the <nil /> element is not in VALIDTYPES, as it is only valid
+ # when $RPC::XML::ALLOW_NIL is true.
+ elsif (VALIDTYPES->{$elem} || ($RPC::XML::ALLOW_NIL && $elem eq 'nil'))
+ {
+ # All datatypes are represented on the stack by this generic token
+ push(@{$robj->[M_STACK]}, DATATYPE);
+ # If the tag is <base64> and we've been told to use filehandles, set
+ # that up.
+ if ($elem eq 'base64')
+ {
+ return unless ($robj->[M_BASE64_TO_FH]);
+ require Symbol;
+ my ($fh, $tmpdir) = (Symbol::gensym(), File::Spec->tmpdir);
+
+ $tmpdir = $robj->[M_BASE64_TEMP_DIR]
+ if ($robj->[M_BASE64_TEMP_DIR]);
+ unless ($fh = File::Temp->new(UNLINK => 1, DIR => $tmpdir))
+ {
+ push(@{$robj->[M_STACK]},
+ "Error opening temp file for base64: $!", PARSE_ERROR);
+ $self->finish;
+ }
+ $robj->[M_CDATA] = $fh;
+ $robj->[M_SPOOLING_BASE64_DATA]= 1;
+ }
+ }
+ else
+ {
+ push(@{$robj->[M_STACK]},
+ "Unknown tag encountered: $elem", PARSE_ERROR);
+ $self->finish;
+ }
+}
+
+# Very simple error-text generator, just to eliminate heavy reduncancy in the
+# next sub:
+sub error
+{
+ my ($robj, $self, $mesg, $elem) = @_;
+ $elem ||= '';
+
+ my $fmt = $elem ?
+ '%s at document line %d, column %d (byte %d, closing tag %s)' :
+ '%s at document line %d, column %d (byte %d)';
+
+ push(@{$robj->[M_STACK]},
+ sprintf($fmt, $mesg, $self->current_line, $self->current_column,
+ $self->current_byte, $elem),
+ PARSE_ERROR);
+ $self->finish;
+}
+
+# A shorter-cut for stack integrity errors
+sub stack_error
+{
+ my ($robj, $self, $elem) = @_;
+
+ error($robj, $self, 'Stack corruption detected', $elem);
+}
+
+# This is a hairy subroutine-- what to do at the end-tag. The actions range
+# from simply new-ing a datatype all the way to building the final object.
+sub tag_end
+{
+ my ($robj, $self, $elem) = @_;
+
+ my ($op, $attr, $obj, $class, $list, $name, $err);
+
+ return if ($elem eq 'data');
+ # This should always be one of the stack machine ops defined above
+ $op = pop(@{$robj->[M_STACK]});
+
+ my $cdata = '';
+ if ($robj->[M_SPOOLING_BASE64_DATA])
+ {
+ $cdata = $robj->[M_CDATA];
+ seek $cdata, 0, 0;
+ }
+ elsif ($robj->[M_CDATA])
+ {
+ $cdata = join('', @{$robj->[M_CDATA]});
+ }
+
+ # Decide what to do from here
+ # Note that the <nil /> element is not in VALIDTYPES, as it is only valid
+ # when $RPC::XML::ALLOW_NIL is true.
+ if (VALIDTYPES->{$elem} || ($elem eq 'nil' && $RPC::XML::ALLOW_NIL))
+ {
+ # This is the closing tag of one of the data-types.
+ $class = $elem;
+ # Cheaper than the regex that was here, and more locale-portable
+ $class = 'datetime_iso8601' if ($class eq 'dateTime.iso8601');
+ # Some minimal data-integrity checking
+ if ($class eq 'int' or $class eq 'i4' or $class eq 'i8')
+ {
+ return error($robj, $self, 'Bad integer data read')
+ unless ($cdata =~ /^[-+]?\d+$/);
+ }
+ elsif ($class eq 'double')
+ {
+ return error($robj, $self, 'Bad floating-point data read')
+ unless ($cdata =~
+ # Taken from perldata(1)
+ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/);
+ }
+ elsif ($class eq 'nil')
+ {
+ # We passed the earlier test, so we know that <nil /> is allowed.
+ # By definition though, it must be, well... nil.
+ return error($robj, $self, '<nil /> element must be empty')
+ if ($cdata !~ /^\s*$/);
+ }
+
+ $class = "RPC::XML::$class";
+ # The string at the end is only seen by the RPC::XML::base64 class
+ $obj = $class->new($cdata, 'base64 already encoded');
+ return error($robj, $self, 'Error instantiating data object: ' .
+ $RPC::XML::ERROR)
+ unless ($obj);
+ push(@{$robj->[M_STACK]}, $obj, DATAOBJECT);
+ if ($robj->[M_SPOOLING_BASE64_DATA])
+ {
+ $robj->[M_SPOOLING_BASE64_DATA] = 0;
+ $robj->[M_CDATA] = undef; # Doesn't close FH, $obj still holds it
+ }
+ }
+ elsif ($elem eq 'value')
+ {
+ # For <value></value>, there should already be a dataobject, or else
+ # the marker token in which case the CDATA is used as a string value.
+ if ($op == DATAOBJECT)
+ {
+ ($op, $obj) = splice(@{$robj->[M_STACK]}, -2);
+ return stack_error($robj, $self, $elem)
+ unless ($op == VALUEMARKER);
+ }
+ elsif ($op == VALUEMARKER)
+ {
+ $obj = RPC::XML::string->new($cdata);
+ }
+ else
+ {
+ return error($robj, $self,
+ 'No datatype found within <value> container');
+ }
+
+ push(@{$robj->[M_STACK]}, $obj, DATAOBJECT);
+ }
+ elsif ($elem eq 'param')
+ {
+ # Almost like above, since this is really a NOP anyway
+ return error($robj, $self, 'No <value> found within <param> container')
+ unless ($op == DATAOBJECT);
+ ($op, $obj) = splice(@{$robj->[M_STACK]}, -2);
+ return stack_error($robj, $self, $elem) unless ($op == PARAM);
+ push(@{$robj->[M_STACK]}, $obj, DATAOBJECT);
+ }
+ elsif ($elem eq 'params')
+ {
+ # At this point, there should be zero or more DATAOBJECT tokens on the
+ # stack, each with a data object right below it.
+ $list = [];
+ return stack_error($robj, $self, $elem)
+ unless ($op == DATAOBJECT or $op == PARAMSTART);
+ while ($op == DATAOBJECT)
+ {
+ unshift(@$list, pop(@{$robj->[M_STACK]}));
+ $op = pop(@{$robj->[M_STACK]});
+ }
+ # Now that we see something ! DATAOBJECT, it needs to be PARAMSTART
+ return stack_error($robj, $self, $elem) unless ($op == PARAMSTART);
+ push(@{$robj->[M_STACK]}, $list, PARAMLIST);
+ }
+ elsif ($elem eq 'fault')
+ {
+ # If we're finishing up a fault definition, there needs to be a struct
+ # on the stack.
+ return stack_error($robj, $self, $elem) unless ($op == DATAOBJECT);
+ ($op, $obj) = splice(@{$robj->[M_STACK]}, -2);
+ return error($robj, $self,
+ 'Only a <struct> value may be within a <fault>')
+ unless ($obj->isa('RPC::XML::struct'));
+
+ $obj = RPC::XML::fault->new($obj);
+ return error($robj, $self, 'Unable to instantiate fault object: ' .
+ $RPC::XML::ERROR)
+ unless $obj;
+ push(@{$robj->[M_STACK]}, $obj, FAULTENT);
+ }
+ elsif ($elem eq 'member')
+ {
+ # We need to see a DATAOBJECT followed by a STRUCTNAME
+ return stack_error($robj, $self, $elem) unless ($op == DATAOBJECT);
+ ($op, $obj) = splice(@{$robj->[M_STACK]}, -2);
+ return stack_error($robj, $self, $elem) unless ($op == STRUCTNAME);
+ # Get the name off the stack to clear the way for the STRUCTMEM marker
+ # under it
+ ($op, $name) = splice(@{$robj->[M_STACK]}, -2);
+ # Push the name back on, with the value and the new marker (STRUCTMEM)
+ push(@{$robj->[M_STACK]}, $name, $obj, STRUCTMEM);
+ }
+ elsif ($elem eq 'name')
+ {
+ # Fairly simple: just push the current content of CDATA on w/ a marker
+ push(@{$robj->[M_STACK]}, $cdata, STRUCTNAME);
+ }
+ elsif ($elem eq 'struct')
+ {
+ # Create the hash table in-place, then pass the ref to the constructor
+ $list = {};
+ # First off the stack needs to be STRUCTMEM or STRUCT
+ return stack_error($robj, $self, $elem)
+ unless ($op == STRUCTMEM or $op == STRUCT);
+ while ($op == STRUCTMEM)
+ {
+ # Next on stack (in list-order): name, value
+ ($name, $obj) = splice(@{$robj->[M_STACK]}, -2);
+ $list->{$name} = $obj;
+ $op = pop(@{$robj->[M_STACK]});
+ }
+ # Now that we see something ! STRUCTMEM, it needs to be STRUCT
+ return stack_error($robj, $self, $elem) unless ($op == STRUCT);
+ $obj = RPC::XML::struct->new($list);
+ return error($robj, $self,
+ 'Error creating a RPC::XML::struct object: ' .
+ $RPC::XML::ERROR)
+ unless $obj;
+ push(@{$robj->[M_STACK]}, $obj, DATAOBJECT);
+ }
+ elsif ($elem eq 'array')
+ {
+ # This is similar in most ways to struct creation, save for the lack
+ # of naming for the elements.
+ # Create the list in-place, then pass the ref to the constructor
+ $list = [];
+ # Only DATAOBJECT or ARRAY should be visible
+ return stack_error($robj, $self, $elem)
+ unless ($op == DATAOBJECT or $op == ARRAY);
+ while ($op == DATAOBJECT)
+ {
+ unshift(@$list, pop(@{$robj->[M_STACK]}));
+ $op = pop(@{$robj->[M_STACK]});
+ }
+ # Now that we see something ! DATAOBJECT, it needs to be ARRAY
+ return stack_error($robj, $self, $elem) unless ($op == ARRAY);
+ # Use the special-form of the constructor, for when a listref should
+ # be dereferenced by the constructor (to avoid doing it here and
+ # possibly creating a huge stack):
+ $obj = RPC::XML::array->new(from => $list);
+ return error($robj, $self,
+ 'Error creating a RPC::XML::array object: ' .
+ $RPC::XML::ERROR)
+ unless $obj;
+ push(@{$robj->[M_STACK]}, $obj, DATAOBJECT);
+ }
+ elsif ($elem eq 'methodName')
+ {
+ return error($robj, $self,
+ "<$elem> tag must immediately follow a <methodCall> tag")
+ unless ($robj->[M_STACK]->[$#{$robj->[M_STACK]}] == METHOD);
+ push(@{$robj->[M_STACK]}, $cdata, NAMEVAL);
+ }
+ elsif ($elem eq 'methodCall')
+ {
+ # A methodCall closing should have on the stack an optional PARAMLIST
+ # marker, a NAMEVAL marker, then the METHOD token from the
+ # opening tag. An ATTR_SET may follow the METHOD token.
+ if ($op == PARAMLIST)
+ {
+ ($op, $list) = splice(@{$robj->[M_STACK]}, -2);
+ }
+ else
+ {
+ $list = [];
+ }
+ if ($op == NAMEVAL)
+ {
+ ($op, $name) = splice(@{$robj->[M_STACK]}, -2);
+ }
+ return error($robj, $self,
+ "No methodName tag detected during methodCall parsing")
+ unless $name;
+ return stack_error($robj, $self, $elem) unless ($op == METHOD);
+ # Create the request object and push it on the stack
+ $obj = RPC::XML::request->new($name, @$list);
+ return error($robj, $self,
+ "Error creating request object: $RPC::XML::ERROR")
+ unless $obj;
+ push(@{$robj->[M_STACK]}, $obj, METHODENT);
+ }
+ elsif ($elem eq 'methodResponse')
+ {
+ # A methodResponse closing should have on the stack only the
+ # DATAOBJECT marker, then the RESPONSE token from the opening tag.
+ if ($op == PARAMLIST)
+ {
+ # To my knowledge, the XML-RPC spec limits the params list for
+ # a response to exactly one object. Extract it from the listref
+ # and put it back.
+ $list = pop(@{$robj->[M_STACK]});
+ return error($robj, $self,
+ "Params list for <$elem> tag invalid")
+ unless (@$list == 1);
+ $obj = $list->[0];
+ return error($robj, $self,
+ "Returned value on stack not a type reference")
+ unless (ref $obj and $obj->isa('RPC::XML::datatype'));
+ push(@{$robj->[M_STACK]}, $obj);
+ }
+ elsif (! ($op == DATAOBJECT or $op == FAULTENT))
+ {
+ return error($robj, $self,
+ "No parameter was declared for the <$elem> tag");
+ }
+ ($op, $list) = splice(@{$robj->[M_STACK]}, -2);
+ return stack_error($robj, $self, $elem) unless ($op == RESPONSE);
+ # Create the response object and push it on the stack
+ $obj = RPC::XML::response->new($list);
+ return error($robj, $self,
+ "Error creating response object: $RPC::XML::ERROR")
+ unless $obj;
+ push(@{$robj->[M_STACK]}, $obj, RESPONSEENT);
+ }
+}
+
+# This just spools the character data until a closing tag makes use of it
+sub char_data
+{
+ my ($robj, undef, $data) = @_;
+
+ if ($robj->[M_SPOOLING_BASE64_DATA])
+ {
+ print {$robj->[M_CDATA]} $data;
+ }
+ else
+ {
+ push @{$robj->[M_CDATA]}, $data;
+ }
+}
+
+# At some future point, this may be expanded to provide more entities than
+# just the four basic XML ones.
+sub extern_ent
+{
+ my $robj = shift;
+
+ local $" = ', ';
+ warn ref($robj) . '::extern_ent: Attempt to reference external entity ' .
+ "(@_)\n";
+ return '';
+}
+
+# Exception-throwing stub in case this is called without first getting the
+# XML::Parser::ExpatNB instance:
+sub parse_more
+{
+ die __PACKAGE__ . '::parse_more: Must be called on a push-parser ' .
+ 'instance obtained from parse()';
+}
+
+# Exception-throwing stub in case this is called without first getting the
+# XML::Parser::ExpatNB instance:
+sub parse_done
+{
+ die __PACKAGE__ . '::parse_done: Must be called on a push-parser ' .
+ 'instance obtained from parse()';
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+RPC::XML::Parser::XMLParser - A container class for XML::Parser
+
+=head1 SYNOPSIS
+
+ # This class should rarely (if ever) be used directly:
+
+ use RPC::XML::ParserFactory 'XML::Parser';
+ ...
+ $P = RPC::XML::ParserFactory->new();
+ $P->parse($message);
+
+=head1 DESCRIPTION
+
+This class implements the interface defined in the B<RPC::XML::Parser>
+factory-class (see L<RPC::XML::Parser>) using the B<XML::Parser> module
+to handle the actual manipulation of XML.
+
+=head1 METHODS
+
+This module implements the public-facing methods as described in
+L<RPC::XML::Parser>:
+
+=over 4
+
+=item new [ ARGS ]
+
+The constructor only recognizes the two parameters specified in the base
+class (for the B<RPC::XML::base64> file-spooling operations).
+
+=item parse [ STRING | STREAM ]
+
+The parse() method accepts either a string of XML, a filehandle of some sort,
+or no argument at all. In the latter case, the return value is a parser
+instance that acts as a push-parser (a non-blocking parser). For the first
+two types of input, the return value is either a message object (one of
+B<RPC::XML::request> or B<RPC::XML::response>) or an error.
+
+=item parse_more STRING
+
+(Only callable on a push-parser instance) Parses the chunk of XML, which does
+not have to describe a complete document, and adds it to the current running
+document. If this method is called on a parser instance that is not a
+push-parser, an exception is thrown.
+
+=item parse_done
+
+(Only callable on a push-parser instance) Finishes the parsing process and
+returns either a message object (one of B<RPC::XML::request> or
+B<RPC::XML::response>) or an error (if the document was incomplete, not
+wel-formed, or not valid). If this method is called on a parser instance that
+is not a push-parser, an exception is thrown.
+
+=back
+
+=head1 BUGS
+
+Please report any bugs or feature requests to
+C<bug-rpc-xml at rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=RPC-XML>. I will be
+notified, and then you'll automatically be notified of progress on
+your bug as I make changes.
+
+=head1 SUPPORT
+
+=over 4
+
+=item * RT: CPAN's request tracker
+
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=RPC-XML>
+
+=item * AnnoCPAN: Annotated CPAN documentation
+
+L<http://annocpan.org/dist/RPC-XML>
+
+=item * CPAN Ratings
+
+L<http://cpanratings.perl.org/d/RPC-XML>
+
+=item * Search CPAN
+
+L<http://search.cpan.org/dist/RPC-XML>
+
+=item * Source code on GitHub
+
+L<http://github.com/rjray/rpc-xml/tree/master>
+
+=back
+
+=head1 COPYRIGHT & LICENSE
+
+This file and the code within are copyright (c) 2009 by Randy J. Ray.
+
+Copying and distribution are permitted under the terms of the Artistic
+License 2.0 (L<http://www.opensource.org/licenses/artistic-license-2.0.php>) or
+the GNU LGPL 2.1 (L<http://www.opensource.org/licenses/lgpl-2.1.php>).
+
+=head1 CREDITS
+
+The B<XML-RPC> standard is Copyright (c) 1998-2001, UserLand Software, Inc.
+See <http://www.xmlrpc.com> for more information about the B<XML-RPC>
+specification.
+
+=head1 SEE ALSO
+
+L<RPC::XML>, L<RPC::XML::Parser>, L<XML::Parser>
+
+=head1 AUTHOR
+
+Randy J. Ray <rjray@blackperl.com>
+
+=cut
@@ -8,26 +8,14 @@
#
###############################################################################
#
-# Description: This is the RPC::XML::Parser class, a container for the
-# XML::Parser class. It was moved here from RPC::XML in
-# order to reduce the weight of that module.
+# Description: This is the RPC::XML::Parser class, an empty class that
+# acts as an interface for parser implementations that can
+# be created/returned by RPC::XML::ParserFactory.
#
# Functions: new
# parse
-# message_init
-# message_end
-# tag_start
-# error
-# stack_error
-# tag_end
-# char_data
-# extern_ent
-# final
#
-# Libraries: RPC::XML
-# XML::Parser
-#
-# Global Consts: Uses $RPC::XML::ERROR
+# Global Consts: $VERSION
#
# Environment: None.
#
@@ -38,540 +26,84 @@ package RPC::XML::Parser;
use 5.006001;
use strict;
use warnings;
-use vars qw($VERSION @ISA);
-use subs qw(error stack_error new message_init message_end tag_start tag_end
- final char_data parse);
-
-# These constants are only used by the internal stack machine
-use constant PARSE_ERROR => 0;
-use constant METHOD => 1;
-use constant METHODSET => 2;
-use constant RESPONSE => 3;
-use constant RESPONSESET => 4;
-use constant STRUCT => 5;
-use constant ARRAY => 6;
-use constant DATATYPE => 7;
-use constant ATTR_SET => 8;
-use constant METHODNAME => 9;
-use constant VALUEMARKER => 10;
-use constant PARAMSTART => 11;
-use constant PARAM => 12;
-use constant STRUCTMEM => 13;
-use constant STRUCTNAME => 14;
-use constant DATAOBJECT => 15;
-use constant PARAMLIST => 16;
-use constant NAMEVAL => 17;
-use constant MEMBERENT => 18;
-use constant METHODENT => 19;
-use constant RESPONSEENT => 20;
-use constant FAULTENT => 21;
-use constant FAULTSTART => 22;
-
-# This is to identify valid types
-use constant VALIDTYPES => { map { $_, 1 } qw(int i4 i8 string double
- boolean dateTime.iso8601
- base64) };
-# This maps XML tags to stack-machine tokens
-use constant TAG2TOKEN => { methodCall => METHOD,
- methodResponse => RESPONSE,
- methodName => METHODNAME,
- params => PARAMSTART,
- param => PARAM,
- value => VALUEMARKER,
- fault => FAULTSTART,
- array => ARRAY,
- struct => STRUCT,
- member => STRUCTMEM,
- name => STRUCTNAME };
-
-# Members of the class
-use constant {
- M_STACK => 0,
- M_CDATA => 1,
- M_BASE64_TO_FH => 2,
- M_BASE64_TEMP_DIR => 3,
- M_SPOOLING_BASE64_DATA => 4,
-};
-
-use XML::Parser;
-require File::Spec;
-
-require RPC::XML;
-
-$VERSION = '1.18';
+use vars qw($VERSION);
+use subs qw(new parse);
+
+$VERSION = '1.20';
+$VERSION = eval $VERSION; ## no critic
###############################################################################
#
# Sub Name: new
#
-# Description: Constructor. Save any important attributes, leave the
-# heavy lifting for the parse() routine and XML::Parser.
-#
-# Arguments: NAME IN/OUT TYPE DESCRIPTION
-# $class in scalar Class we're initializing
-# %attr in hash Any extras the caller wants
+# Description: Constructor. Dies, because this should be overridden.
#
-# Globals: $RPC::XML::ERROR
-#
-# Returns: Success: object ref
-# Failure: undef
+# Returns: undef
#
###############################################################################
sub new
{
- my $class = shift;
- my %attrs = @_;
-
- my $self = [];
-
- while (my ($key, $val) = each %attrs)
- {
- if ($key eq 'base64_to_fh')
- {
- $self->[M_BASE64_TO_FH] = $val;
- }
- elsif ($key eq 'base64_temp_dir')
- {
- $self->[M_BASE64_TEMP_DIR] = $val;
- }
- }
-
- bless $self, $class;
+ die __PACKAGE__ . '::new: This method should have been overridden by ' .
+ "the $_[0] class";
}
###############################################################################
#
# Sub Name: parse
#
-# Description: Parse the requested string or stream. This behaves mostly
-# like parse() in the XML::Parser namespace, but does some
-# extra, as well.
-#
-# Arguments: NAME IN/OUT TYPE DESCRIPTION
-# $self in ref Object of this class
-# $stream in scalar Either the string to parse or
-# an open filehandle of sorts
+# Description: Parse the requested string or stream, or return a
+# push-parser instance. In this case, it dies because the
+# sub-class should have overridden it.
#
-# Returns: Success: ref to request or response object
-# Failure: error string
+# Returns: dies
#
###############################################################################
sub parse
{
- my ($self, $stream) = @_;
-
- my $parser = XML::Parser->new(Namespaces => 0,
- ParseParamEnt => 0,
- ErrorContext => 1,
- Handlers =>
- {
- Init => sub { message_init $self, @_ },
- Start => sub { tag_start $self, @_ },
- End => sub { tag_end $self, @_ },
- Char => sub { char_data $self, @_ },
- Final => sub { final $self, @_ },
- ExternEnt => sub { extern_ent $self, @_ },
- });
-
- # If there is no stream given, then create an incremental parser handle
- # and return it.
- return $parser->parse_start() unless $stream;
-
- my $retval;
- eval { $retval = $parser->parse($stream) };
- return $@ if $@;
-
- $retval;
-}
-
-# This is called when a new document is about to start parsing
-sub message_init
-{
- my ($robj, $self) = @_;
-
- $robj->[M_STACK] = [];
- $self;
-}
-
-# This is called when the parsing process is complete
-sub final
-{
- my ($robj, $self) = @_;
-
- # Look at the top-most marker, it'll need to be one of the end cases
- my $marker = pop(@{$robj->[M_STACK]});
- # There should be only on item on the stack after it
- my $retval = pop(@{$robj->[M_STACK]});
- # If the top-most marker isn't the error marker, check the stack
- $retval = 'RPC::XML Error: Extra data on parse stack at document end'
- if ($marker != PARSE_ERROR and (@{$robj->[M_STACK]}));
-
- $retval;
-}
-
-# This gets called each time an opening tag is parsed
-sub tag_start
-{
- my ($robj, $self, $elem, %attr) = @_;
-
- $robj->[M_CDATA] = [];
- return if ($elem eq 'data');
-
- if (TAG2TOKEN->{$elem})
- {
- push(@{$robj->[M_STACK]}, TAG2TOKEN->{$elem});
- }
- # Note that the <nil /> element is not in VALIDTYPES, as it is only valid
- # when $RPC::XML::ALLOW_NIL is true.
- elsif (VALIDTYPES->{$elem} || ($RPC::XML::ALLOW_NIL && $elem eq 'nil'))
- {
- # All datatypes are represented on the stack by this generic token
- push(@{$robj->[M_STACK]}, DATATYPE);
- # If the tag is <base64> and we've been told to use filehandles, set
- # that up.
- if ($elem eq 'base64')
- {
- return unless ($robj->[M_BASE64_TO_FH]);
- require Symbol;
- my ($fh, $file) = (Symbol::gensym(), File::Spec->tmpdir);
-
- $file = $robj->[M_BASE64_TEMP_DIR] if ($robj->[M_BASE64_TEMP_DIR]);
- $file = File::Spec->catfile($file, 'b64' . $self->current_byte);
- unless (open($fh, "+> $file"))
- {
- push(@{$robj->[M_STACK]},
- "Error opening temp file for base64: $!", PARSE_ERROR);
- $self->finish;
- }
- unlink($file);
- $robj->[M_CDATA] = $fh;
- $robj->[M_SPOOLING_BASE64_DATA]= 1;
- }
- }
- else
- {
- push(@{$robj->[M_STACK]},
- "Unknown tag encountered: $elem", PARSE_ERROR);
- $self->finish;
- }
-}
+ my $class = ref($_[0]) || $_[0];
-# Very simple error-text generator, just to eliminate heavy reduncancy in the
-# next sub:
-sub error
-{
- my ($robj, $self, $mesg, $elem) = @_;
- $elem ||= '';
-
- my $fmt = $elem ?
- '%s at document line %d, column %d (byte %d, closing tag %s)' :
- '%s at document line %d, column %d (byte %d)';
-
- push(@{$robj->[M_STACK]},
- sprintf($fmt, $mesg, $self->current_line, $self->current_column,
- $self->current_byte, $elem),
- PARSE_ERROR);
- $self->finish;
+ die __PACKAGE__ . '::parse: This method should have been overridden by ' .
+ "the $class class";
}
-# A shorter-cut for stack integrity errors
-sub stack_error
-{
- my ($robj, $self, $elem) = @_;
-
- error($robj, $self, 'Stack corruption detected', $elem);
-}
-
-# This is a hairy subroutine-- what to do at the end-tag. The actions range
-# from simply new-ing a datatype all the way to building the final object.
-sub tag_end
+###############################################################################
+#
+# Sub Name: parse_more
+#
+# Description: When called on a push-parser instance (which may or may
+# not be the same class), parses additional content and
+# waits for more. In this case it dies because the sub-class
+# should have overridden it.
+#
+# Returns: dies
+#
+###############################################################################
+sub parse_more
{
- my ($robj, $self, $elem) = @_;
-
- my ($op, $attr, $obj, $class, $list, $name, $err);
-
- return if ($elem eq 'data');
- # This should always be one of the stack machine ops defined above
- $op = pop(@{$robj->[M_STACK]});
-
- my $cdata = '';
- if ($robj->[M_SPOOLING_BASE64_DATA])
- {
- $cdata = $robj->[M_CDATA];
- seek $cdata, 0, 0;
- }
- elsif ($robj->[M_CDATA])
- {
- $cdata = join('', @{$robj->[M_CDATA]});
- }
-
- # Decide what to do from here
- # Note that the <nil /> element is not in VALIDTYPES, as it is only valid
- # when $RPC::XML::ALLOW_NIL is true.
- if (VALIDTYPES->{$elem} || ($elem eq 'nil' && $RPC::XML::ALLOW_NIL))
- {
- # This is the closing tag of one of the data-types.
- $class = $elem;
- # Cheaper than the regex that was here, and more locale-portable
- $class = 'datetime_iso8601' if ($class eq 'dateTime.iso8601');
- # Some minimal data-integrity checking
- if ($class eq 'int' or $class eq 'i4' or $class eq 'i8')
- {
- return error($robj, $self, 'Bad integer data read')
- unless ($cdata =~ /^[-+]?\d+$/);
- }
- elsif ($class eq 'double')
- {
- return error($robj, $self, 'Bad floating-point data read')
- unless ($cdata =~
- # Taken from perldata(1)
- /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/);
- }
- elsif ($class eq 'nil')
- {
- # We passed the earlier test, so we know that <nil /> is allowed.
- # By definition though, it must be, well... nil.
- return error($robj, $self, '<nil /> element must be empty')
- if ($cdata !~ /^\s*$/);
- }
-
- $class = "RPC::XML::$class";
- # The string at the end is only seen by the RPC::XML::base64 class
- $obj = $class->new($cdata, 'base64 already encoded');
- return error($robj, $self, 'Error instantiating data object: ' .
- $RPC::XML::ERROR)
- unless ($obj);
- push(@{$robj->[M_STACK]}, $obj, DATAOBJECT);
- if ($robj->[M_SPOOLING_BASE64_DATA])
- {
- $robj->[M_SPOOLING_BASE64_DATA] = 0;
- $robj->[M_CDATA] = undef; # Doesn't close FH, $obj still holds it
- }
- }
- elsif ($elem eq 'value')
- {
- # For <value></value>, there should already be a dataobject, or else
- # the marker token in which case the CDATA is used as a string value.
- if ($op == DATAOBJECT)
- {
- ($op, $obj) = splice(@{$robj->[M_STACK]}, -2);
- return stack_error($robj, $self, $elem)
- unless ($op == VALUEMARKER);
- }
- elsif ($op == VALUEMARKER)
- {
- $obj = RPC::XML::string->new($cdata);
- }
- else
- {
- return error($robj, $self,
- 'No datatype found within <value> container');
- }
-
- push(@{$robj->[M_STACK]}, $obj, DATAOBJECT);
- }
- elsif ($elem eq 'param')
- {
- # Almost like above, since this is really a NOP anyway
- return error($robj, $self, 'No <value> found within <param> container')
- unless ($op == DATAOBJECT);
- ($op, $obj) = splice(@{$robj->[M_STACK]}, -2);
- return stack_error($robj, $self, $elem) unless ($op == PARAM);
- push(@{$robj->[M_STACK]}, $obj, DATAOBJECT);
- }
- elsif ($elem eq 'params')
- {
- # At this point, there should be zero or more DATAOBJECT tokens on the
- # stack, each with a data object right below it.
- $list = [];
- return stack_error($robj, $self, $elem)
- unless ($op == DATAOBJECT or $op == PARAMSTART);
- while ($op == DATAOBJECT)
- {
- unshift(@$list, pop(@{$robj->[M_STACK]}));
- $op = pop(@{$robj->[M_STACK]});
- }
- # Now that we see something ! DATAOBJECT, it needs to be PARAMSTART
- return stack_error($robj, $self, $elem) unless ($op == PARAMSTART);
- push(@{$robj->[M_STACK]}, $list, PARAMLIST);
- }
- elsif ($elem eq 'fault')
- {
- # If we're finishing up a fault definition, there needs to be a struct
- # on the stack.
- return stack_error($robj, $self, $elem) unless ($op == DATAOBJECT);
- ($op, $obj) = splice(@{$robj->[M_STACK]}, -2);
- return error($robj, $self,
- 'Only a <struct> value may be within a <fault>')
- unless ($obj->isa('RPC::XML::struct'));
-
- $obj = RPC::XML::fault->new($obj);
- return error($robj, $self, 'Unable to instantiate fault object: ' .
- $RPC::XML::ERROR)
- unless $obj;
- push(@{$robj->[M_STACK]}, $obj, FAULTENT);
- }
- elsif ($elem eq 'member')
- {
- # We need to see a DATAOBJECT followed by a STRUCTNAME
- return stack_error($robj, $self, $elem) unless ($op == DATAOBJECT);
- ($op, $obj) = splice(@{$robj->[M_STACK]}, -2);
- return stack_error($robj, $self, $elem) unless ($op == STRUCTNAME);
- # Get the name off the stack to clear the way for the STRUCTMEM marker
- # under it
- ($op, $name) = splice(@{$robj->[M_STACK]}, -2);
- # Push the name back on, with the value and the new marker (STRUCTMEM)
- push(@{$robj->[M_STACK]}, $name, $obj, STRUCTMEM);
- }
- elsif ($elem eq 'name')
- {
- # Fairly simple: just push the current content of CDATA on w/ a marker
- push(@{$robj->[M_STACK]}, $cdata, STRUCTNAME);
- }
- elsif ($elem eq 'struct')
- {
- # Create the hash table in-place, then pass the ref to the constructor
- $list = {};
- # First off the stack needs to be STRUCTMEM or STRUCT
- return stack_error($robj, $self, $elem)
- unless ($op == STRUCTMEM or $op == STRUCT);
- while ($op == STRUCTMEM)
- {
- # Next on stack (in list-order): name, value
- ($name, $obj) = splice(@{$robj->[M_STACK]}, -2);
- $list->{$name} = $obj;
- $op = pop(@{$robj->[M_STACK]});
- }
- # Now that we see something ! STRUCTMEM, it needs to be STRUCT
- return stack_error($robj, $self, $elem) unless ($op == STRUCT);
- $obj = RPC::XML::struct->new($list);
- return error($robj, $self,
- 'Error creating a RPC::XML::struct object: ' .
- $RPC::XML::ERROR)
- unless $obj;
- push(@{$robj->[M_STACK]}, $obj, DATAOBJECT);
- }
- elsif ($elem eq 'array')
- {
- # This is similar in most ways to struct creation, save for the lack
- # of naming for the elements.
- # Create the list in-place, then pass the ref to the constructor
- $list = [];
- # Only DATAOBJECT or ARRAY should be visible
- return stack_error($robj, $self, $elem)
- unless ($op == DATAOBJECT or $op == ARRAY);
- while ($op == DATAOBJECT)
- {
- unshift(@$list, pop(@{$robj->[M_STACK]}));
- $op = pop(@{$robj->[M_STACK]});
- }
- # Now that we see something ! DATAOBJECT, it needs to be ARRAY
- return stack_error($robj, $self, $elem) unless ($op == ARRAY);
- # Use the special-form of the constructor, for when a listref should
- # be dereferenced by the constructor (to avoid doing it here and
- # possibly creating a huge stack):
- $obj = RPC::XML::array->new(from => $list);
- return error($robj, $self,
- 'Error creating a RPC::XML::array object: ' .
- $RPC::XML::ERROR)
- unless $obj;
- push(@{$robj->[M_STACK]}, $obj, DATAOBJECT);
- }
- elsif ($elem eq 'methodName')
- {
- return error($robj, $self,
- "<$elem> tag must immediately follow a <methodCall> tag")
- unless ($robj->[M_STACK]->[$#{$robj->[M_STACK]}] == METHOD);
- push(@{$robj->[M_STACK]}, $cdata, NAMEVAL);
- }
- elsif ($elem eq 'methodCall')
- {
- # A methodCall closing should have on the stack an optional PARAMLIST
- # marker, a NAMEVAL marker, then the METHOD token from the
- # opening tag. An ATTR_SET may follow the METHOD token.
- if ($op == PARAMLIST)
- {
- ($op, $list) = splice(@{$robj->[M_STACK]}, -2);
- }
- else
- {
- $list = [];
- }
- if ($op == NAMEVAL)
- {
- ($op, $name) = splice(@{$robj->[M_STACK]}, -2);
- }
- return error($robj, $self,
- "No methodName tag detected during methodCall parsing")
- unless $name;
- return stack_error($robj, $self, $elem) unless ($op == METHOD);
- # Create the request object and push it on the stack
- $obj = RPC::XML::request->new($name, @$list);
- return error($robj, $self,
- "Error creating request object: $RPC::XML::ERROR")
- unless $obj;
- push(@{$robj->[M_STACK]}, $obj, METHODENT);
- }
- elsif ($elem eq 'methodResponse')
- {
- # A methodResponse closing should have on the stack only the
- # DATAOBJECT marker, then the RESPONSE token from the opening tag.
- if ($op == PARAMLIST)
- {
- # To my knowledge, the XML-RPC spec limits the params list for
- # a response to exactly one object. Extract it from the listref
- # and put it back.
- $list = pop(@{$robj->[M_STACK]});
- return error($robj, $self,
- "Params list for <$elem> tag invalid")
- unless (@$list == 1);
- $obj = $list->[0];
- return error($robj, $self,
- "Returned value on stack not a type reference")
- unless (ref $obj and $obj->isa('RPC::XML::datatype'));
- push(@{$robj->[M_STACK]}, $obj);
- }
- elsif (! ($op == DATAOBJECT or $op == FAULTENT))
- {
- return error($robj, $self,
- "No parameter was declared for the <$elem> tag");
- }
- ($op, $list) = splice(@{$robj->[M_STACK]}, -2);
- return stack_error($robj, $self, $elem) unless ($op == RESPONSE);
- # Create the response object and push it on the stack
- $obj = RPC::XML::response->new($list);
- return error($robj, $self,
- "Error creating response object: $RPC::XML::ERROR")
- unless $obj;
- push(@{$robj->[M_STACK]}, $obj, RESPONSEENT);
- }
-}
+ my $class = ref($_[0]) || $_[0];
-# This just spools the character data until a closing tag makes use of it
-sub char_data
-{
- my ($robj, undef, $data) = @_;
-
- if ($robj->[M_SPOOLING_BASE64_DATA])
- {
- print {$robj->[M_CDATA]} $data;
- }
- else
- {
- push @{$robj->[M_CDATA]}, $data;
- }
+ die __PACKAGE__ . '::parse_more: This method should have been overridden' .
+ " by the $class class";
}
-# At some future point, this may be expanded to provide more entities than
-# just the four basic XML ones.
-sub extern_ent
+###############################################################################
+#
+# Sub Name: parse_done
+#
+# Description: When called on a push-parser instance (which may or may
+# not be the same class), finishes the parse process and
+# returns the result. In this case it dies because the
+# sub-class should have overridden it.
+#
+# Returns: dies
+#
+###############################################################################
+sub parse_done
{
- my $robj = shift;
+ my $class = ref($_[0]) || $_[0];
- local $" = ', ';
- warn ref($robj) . '::extern_ent: Attempt to reference external entity ' .
- "(@_)\n";
- return '';
+ die __PACKAGE__ . '::parse_done: This method should have been overridden' .
+ " by the $class class";
}
1;
@@ -580,23 +112,29 @@ __END__
=head1 NAME
-RPC::XML::Parser - A container class for XML::Parser
+RPC::XML::Parser - Interface for parsers created by RPC::XML::ParserFactory
=head1 SYNOPSIS
- use RPC::XML::Parser;
- ...
- $P = RPC::XML::Parser->new();
- $P->parse($message);
+This class is not instantiated directly; see L<RPC::XML::ParserFactory>.
=head1 DESCRIPTION
-The B<RPC::XML::Parser> class encapsulates the parsing process, for turning a
-string or an input stream into a B<RPC::XML::request> or B<RPC::XML::response>
-object. The B<XML::Parser> class is used internally, with a new instance
-created for each call to C<parse> (detailed below). This allows the
-B<RPC::XML::Parser> object to be reusable, even though the B<XML::Parser>
-objects are not. The methods are:
+The B<RPC::XML::Parser> class encapsulates the interface for the parsing
+process. It is an empty class that is used in conjuntion with the
+B<RPC::XML::ParserFactory> class.
+
+All parser implementations that are intended to be returned by calls to
+RPC::XML::ParserFactory::new() should declare this as their parent class.
+
+=head1 METHODS
+
+This class provides empty implementations for the following methods. A parser
+implementation must provide definitions for B<both> of these methods. If the
+versions from this class are triggered they will throw exceptions (C<die>).
+
+The descriptions below define the interface that implementations must
+adhere to.
=over 4
@@ -630,33 +168,73 @@ relevant if B<base64_to_fh> is set.
=back
-=item parse [ { STRING | STREAM } ]
+The C<base64*> parameters do not have to be implemented if the user has
+no plans to use the C<to_file> method of the B<RPC::XML::base64> data-class.
+
+=item parse [ STRING | STREAM ]
Parse the XML document specified in either a string or a stream. The stream
-may be any file descriptor, derivative of B<IO::Handle>, etc. The return
-value is either an object reference (to one of B<RPC::XML::request> or
-B<RPC::XML::response>) or an error string. Any non-reference return value
-should be treated as an error condition.
+may be any file descriptor, derivative of B<IO::Handle>, etc.
+
+The value returned must be one of the following:
+
+=over 4
+
+=item RPC::XML::request instance
+
+When passed a valid XML-RPC request message, the return value should be
+an instance of the B<RPC::XML::request> class.
+
+=item RPC::XML::response instance
+
+Likewise, when passed a valid XML-RPC response, the return value should be
+an instance of the B<RPC::XML::response> class.
+
+=item string containing an error message
+
+If the message does not conform to either a request or a response, or does
+not properly parse, the return value must be a string containing the error
+message.
-If no argument is given, then the C<parse_start> method of B<XML::Parser> is
-used to create a B<XML::Parser::ExpatNB> object, which is returned. This
-object may then be used to parse the data in chunks, rather than a steady
-stream. See the B<XML::Parser> manual page for more details on how this
-works.
+=item A non-blocking (push) parser instance
+
+If no arguments are passed in, the return value must be a parser object that
+implements push-parsing (non-blocking). It does not have to be of the same
+class as the original object, but it must support the remaining two methods
+
+=back
=back
-=head1 DIAGNOSTICS
+The next two methods are only called on push-parser instances, and as such do
+not have to be implemented by the actual factory-compatible parser. It is
+enough if the non-blocking parser instance it returns from the no-argument call
+to parse() implements these:
+
+=over 4
+
+=item parse_more STRING
+
+Send a chunk of the current XML document to the parser for processing.
+
+=item parse_done
-The constructor returns C<undef> upon failure, with the error message available
-in the global variable B<C<$RPC::XML::ERROR>>.
+Signal the end of parsing. The return value from this should be one of the
+same three possibilities that the direct use of parse() (above) returns:
-=head1 CAVEATS
+=over 4
+
+=item RPC::XML::request instance
+
+=item RPC::XML::response instance
+
+=item string containing an error message
-This began as a reference implementation in which clarity of process and
-readability of the code took precedence over general efficiency. It is now
-being maintained as production code, but may still have parts that could be
-written more efficiently.
+=back
+
+parse_done() may also signal an error by throwing an exception.
+
+=back
=head1 BUGS
@@ -708,7 +286,7 @@ specification.
=head1 SEE ALSO
-L<RPC::XML>, L<RPC::XML::Client>, L<RPC::XML::Server>, L<XML::Parser>
+L<RPC::XML>, L<RPC::XML::ParserFactory>, L<RPC::XML::Parser::XMLParser>
=head1 AUTHOR
@@ -0,0 +1,306 @@
+###############################################################################
+#
+# This file copyright (c) 2001-2009 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 is the RPC::XML::ParserFactory class, a factory for
+# classes that derive from the RPC::XML::Parser class.
+#
+# Functions: import
+# new
+# register
+#
+# Libraries: RPC::XML::Parser::XMLParser \
+# RPC::XML::Parser::XMLLibXML > One (or more) of these
+# RPC::XML::Parser::XMLSAX /
+#
+# Global Consts: $VERSION
+#
+# Environment: None.
+#
+###############################################################################
+
+package RPC::XML::ParserFactory;
+
+use 5.006001;
+use strict;
+use warnings;
+use vars qw($VERSION %AVAILABLE $PARSER_CLASS);
+use subs qw(import new register);
+
+$VERSION = '1.00';
+$VERSION = eval $VERSION; ## no critic
+
+# These are the known parsers supported, not including any that are specified
+# by the user at import-time.
+$PARSER_CLASS = 'XML::Parser';
+%AVAILABLE = (
+ 'XML::Parser' => 'RPC::XML::Parser::XMLParser',
+ 'XML::LibXML' => 'RPC::XML::Parser::XMLLibXML',
+);
+
+# "Normalize" the key-names to allow some simplicity (and sugar):
+for (keys %AVAILABLE)
+{
+ my $key = lc $_;
+ $AVAILABLE{$key} = $AVAILABLE{$_};
+ $key =~ s/:://g;
+ $AVAILABLE{$key} = $AVAILABLE{$_};
+}
+
+###############################################################################
+#
+# Sub Name: import
+#
+# Description: Method called when this module is use'd
+#
+# Arguments: NAME IN/OUT TYPE DESCRIPTION
+# $class in scalar Class name
+# @args in list Arguments to the import
+#
+# Globals: $PARSER_CLASS
+#
+# Returns: void
+#
+###############################################################################
+sub import
+{
+ my ($class, @args) = @_;
+
+ # As a special-case, this one parameter might be specified without the
+ # key, if it is the ONLY thing passed:
+ @args = (class => @args) if (1 == @args);
+
+ # For now, the only arguments are key/value pairs so it's safe to coerce
+ # this into a hash
+ my %argz = @args;
+
+ # In fact, for now, this is the only argument:
+ if ($argz{class})
+ {
+ $PARSER_CLASS = $argz{class};
+ }
+
+ return;
+}
+
+###############################################################################
+#
+# Sub Name: new
+#
+# Description: Constructor. Save any important attributes, leave the
+# heavy lifting for the parse() routine and XML::Parser.
+#
+# Arguments: NAME IN/OUT TYPE DESCRIPTION
+# $class in scalar Class we're initializing
+# %attr in hash Any extras the caller wants
+#
+# Globals: $RPC::XML::ERROR
+#
+# Returns: Success: object ref
+# Failure: undef
+#
+###############################################################################
+sub new
+{
+ my $class = shift;
+ my %attrs = @_;
+
+ my $factory = delete $attrs{class} || $PARSER_CLASS;
+
+ if ($class = $AVAILABLE{$factory})
+ {
+ eval "require $class;"; ## no critic
+ if ($@)
+ {
+ $RPC::XML::ERROR = __PACKAGE__ . "::new: Error loading $class (" .
+ "factory for '$factory'): $@";
+ return;
+ }
+ }
+ else
+ {
+ # This means that the class is not one of the built-in ones. Try to
+ # load it, then make sure it's a sub-class of this one:
+ $class = $factory;
+ eval "require $class;"; ## no critic
+ if ($@)
+ {
+ $RPC::XML::ERROR = __PACKAGE__ . "::new: Error loading $class: $@";
+ return;
+ }
+ # Loaded OK... is it a descendent?
+ unless ($class->isa(__PACKAGE__))
+ {
+ $RPC::XML::ERROR = __PACKAGE__ . "::new: Class '$class' cannot " .
+ 'be used, as it is not a sub-class of ' . __PACKAGE__;
+ return;
+ }
+ }
+
+ $class->new(%attrs);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+RPC::XML::ParserFactory - A factory class for RPC::XML::Parser objects
+
+=head1 SYNOPSIS
+
+ use RPC::XML::ParserFactory;
+ ...
+ $P = RPC::XML::ParserFactory->new();
+ $P->parse($message);
+
+=head1 DESCRIPTION
+
+The B<RPC::XML::ParserFactory> class encapsulates the process of creating
+parser objects that adhere to the interface described in L<RPC::XML::Parser>.
+Under the hood, the parser object created and returned could be from any of
+a number of implementation classes.
+
+=head1 IMPORT-TIME ARGUMENTS
+
+You can specify a particular underlying parser class to use, if you do not
+want to allow B<RPC::XML::Parser> to use the default class. This is done with
+the C<class> keyword:
+
+ use RPC::XML::Parser (class => 'XML::Parser');
+
+The value may be the name for any of the built-in classes, or it may be the
+name of a class that is a sub-class of this package (and can thus be
+"manufactured" by the factory). The value is saved and becomes the default
+class for any calls to B<new> that do not explicitly name a class to use.
+
+Note that if the specified class is not valid, this is not tested until the
+first call to B<new>, at which point an invalid class will cause an exception
+(error) to occur. The constructor will return C<undef> and the
+B<$RPC::XML::ERROR> variable will contain the error message.
+
+=head2 Names of Built-In Parsers
+
+The following names are valid when specified as the value of the C<class>
+argument described above:
+
+=over 4
+
+=item XML::Parser
+
+=item xml::parser
+
+=item xmlparser
+
+All of these specify the parser implementation based on the B<XML::Parser>
+module. This is the default parser if the user does not specify any
+alternative.
+
+=item XML::LibXML
+
+=item xml::libxml
+
+=item xmllibxml
+
+These specify a parser implementation based on the B<XML::LibXML> module.
+This is a new parser and not as well-vetted as the previous one, hence it
+must be explicitly requested.
+
+=back
+
+=head1 METHODS
+
+The methods are:
+
+=over 4
+
+=item new([ARGS])
+
+Create a new instance of the class. Any extra data passed to the constructor
+is taken as key/value pairs (B<not> a hash reference) and attached to the
+object.
+
+This method passes all arguments on to the new() method of the chosen
+implementation class, except for the following:
+
+=over 4
+
+=item class NAME
+
+If the user chooses, they may specify an explicit class to use for parsers
+when calling new(). If passed, this overrides any value that was given at
+use-time (processed by import()).
+
+=back
+
+=back
+
+=head1 DIAGNOSTICS
+
+The constructor returns C<undef> upon failure, with the error message available
+in the global variable B<C<$RPC::XML::ERROR>>.
+
+=head1 BUGS
+
+Please report any bugs or feature requests to
+C<bug-rpc-xml at rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=RPC-XML>. I will be
+notified, and then you'll automatically be notified of progress on
+your bug as I make changes.
+
+=head1 SUPPORT
+
+=over 4
+
+=item * RT: CPAN's request tracker
+
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=RPC-XML>
+
+=item * AnnoCPAN: Annotated CPAN documentation
+
+L<http://annocpan.org/dist/RPC-XML>
+
+=item * CPAN Ratings
+
+L<http://cpanratings.perl.org/d/RPC-XML>
+
+=item * Search CPAN
+
+L<http://search.cpan.org/dist/RPC-XML>
+
+=item * Source code on GitHub
+
+L<http://github.com/rjray/rpc-xml/tree/master>
+
+=back
+
+=head1 COPYRIGHT & LICENSE
+
+This file and the code within are copyright (c) 2009 by Randy J. Ray.
+
+Copying and distribution are permitted under the terms of the Artistic
+License 2.0 (L<http://www.opensource.org/licenses/artistic-license-2.0.php>) or
+the GNU LGPL 2.1 (L<http://www.opensource.org/licenses/lgpl-2.1.php>).
+
+=head1 CREDITS
+
+The B<XML-RPC> standard is Copyright (c) 1998-2001, UserLand Software, Inc.
+See <http://www.xmlrpc.com> for more information about the B<XML-RPC>
+specification.
+
+=head1 SEE ALSO
+
+L<RPC::XML>, L<RPC::XML::Client>, L<RPC::XML::Server>, L<XML::Parser>
+
+=head1 AUTHOR
+
+Randy J. Ray C<< <rjray@blackperl.com> >>
+
+=cut
@@ -43,15 +43,18 @@ use strict;
use warnings;
use vars qw($VERSION);
use subs qw(new is_valid name code signature help version hidden
- add_signature delete_signature make_sig_table match_signature
- reload load_XPL_file);
+ add_signature delete_signature make_sig_table match_signature
+ reload load_XPL_file);
use AutoLoader 'AUTOLOAD';
-require File::Spec;
+use File::Spec;
use Scalar::Util 'blessed';
-$VERSION = '1.18';
+use RPC::XML 'smart_encode';
+
+$VERSION = '1.19';
+$VERSION = eval $VERSION; ## no critic
###############################################################################
#
@@ -74,7 +77,7 @@ sub new
my $class = shift;
my @argz = @_;
- my $data; # This will be a hashref that eventually gets blessed
+ my $data; # This will be a hashref that eventually gets blessed
$class = ref($class) || $class;
@@ -84,7 +87,7 @@ sub new
if (ref $argz[0])
{
# 1. A hashref containing all the relevant keys
- $data = {};
+ $data = {};
%$data = %{$argz[0]};
}
elsif (@argz == 1)
@@ -102,14 +105,14 @@ sub new
if (defined $class)
{
$data = $class->load_XPL_file($argz[0]);
- return $data unless ref $data; # load_XPL_path signalled an error
+ return $data unless ref $data; # load_XPL_path signalled an error
}
else
{
# Spoofing the "class" argument to load_XPL_file makes me feel
# even dirtier...
$data = load_XPL_file(\$class, $argz[0]);
- return $data unless ref $data; # load_XPL_path signalled an error
+ return $data unless ref $data; # load_XPL_path signalled an error
$class = "RPC::XML::$class";
}
}
@@ -129,7 +132,7 @@ sub new
# repeat. Of course, that's also why we can't just take @argz
# directly as a hash. *shrug*
push(@{$data->{signature}},
- ref($val) ? join(' ', @$val) : $val);
+ ref($val) ? join(' ', @$val) : $val);
}
elsif (exists $data->{$key})
{
@@ -143,10 +146,11 @@ sub new
}
return "${class}::new: Missing required data"
- unless (exists $data->{signature} and
- (ref($data->{signature}) eq 'ARRAY') and
- scalar(@{$data->{signature}}) and
- $data->{name} and $data->{code});
+ unless (exists $data->{signature}
+ and (ref($data->{signature}) eq 'ARRAY')
+ and scalar(@{$data->{signature}})
+ and $data->{name}
+ and $data->{code});
bless $data, $class;
# This needs to happen post-bless in case of error (for error messages)
$data->make_sig_table;
@@ -171,17 +175,19 @@ sub make_sig_table
{
my $self = shift;
- my ($sig, $return, $rest);
+ my ($return, $rest);
delete $self->{sig_table};
- for $sig (@{$self->{signature}})
+ for my $sig (@{$self->{signature}})
{
- ($return, $rest) = split(/ /, $sig, 2); $rest = '' unless $rest;
+ ($return, $rest) = split(/ /, $sig, 2);
+ $rest = '' unless $rest;
# If the key $rest already exists, then this is a collision
- return ref($self) . '::make_sig_table: Cannot have two different ' .
+ return
+ ref($self) . '::make_sig_table: Cannot have two different ' .
"return values for one set of params ($return vs. " .
"$self->{sig_table}->{$rest})"
- if $self->{sig_table}->{$rest};
+ if $self->{sig_table}->{$rest};
$self->{sig_table}->{$rest} = $return;
}
@@ -191,16 +197,18 @@ sub make_sig_table
#
# These are basic accessor/setting functions for the various attributes
#
-sub name { $_[0]->{name}; } # "name" cannot be changed at this level
-sub namespace { $_[0]->{namespace} || ''; } # Nor can "namespace"
-sub help { $_[1] and $_[0]->{help} = $_[1]; $_[0]->{help}; }
-sub version { $_[1] and $_[0]->{version} = $_[1]; $_[0]->{version}; }
-sub hidden { $_[1] and $_[0]->{hidden} = $_[1]; $_[0]->{hidden}; }
+sub name { $_[0]->{name}; } # "name" cannot be changed at this level
+sub namespace { $_[0]->{namespace} || ''; } # Nor can "namespace"
+sub help { $_[1] and $_[0]->{help} = $_[1]; $_[0]->{help}; }
+sub version { $_[1] and $_[0]->{version} = $_[1]; $_[0]->{version}; }
+sub hidden { $_[1] and $_[0]->{hidden} = $_[1]; $_[0]->{hidden}; }
+
sub code
{
ref $_[1] eq 'CODE' and $_[0]->{code} = $_[1];
$_[0]->{code};
}
+
sub signature
{
if ($_[1] and ref $_[1] eq 'ARRAY')
@@ -216,7 +224,7 @@ sub signature
}
}
# Return a copy of the array, not the original
- [ @{$_[0]->{signature}} ];
+ [@{$_[0]->{signature}}];
}
package RPC::XML::Method;
@@ -733,8 +741,9 @@ sub is_valid
{
my $self = shift;
- return ((ref($self->{code}) eq 'CODE') and $self->{name} and
- (ref($self->{signature}) && scalar(@{$self->{signature}})));
+ return ( (ref($self->{code}) eq 'CODE')
+ and $self->{name}
+ and (ref($self->{signature}) && scalar(@{$self->{signature}})));
}
###############################################################################
@@ -768,15 +777,14 @@ sub add_signature
$tmp = (ref $one_sig) ? join(' ', @$one_sig) : $one_sig;
$sigs{$tmp} = 1;
}
- $self->{signature} = [ keys %sigs ];
+ $self->{signature} = [keys %sigs];
unless (ref($tmp = $self->make_sig_table))
{
# Because this failed, we have to restore the old table and return
# an error
$self->{signature} = $old;
$self->make_sig_table;
- return ref($self) . '::add_signature: Error re-hashing table: ' .
- $tmp;
+ return ref($self) . '::add_signature: Error re-hashing table: ' . $tmp;
}
$self;
@@ -797,15 +805,15 @@ sub delete_signature
$tmp = (ref $one_sig) ? join(' ', @$one_sig) : $one_sig;
delete $sigs{$tmp};
}
- $self->{signature} = [ keys %sigs ];
+ $self->{signature} = [keys %sigs];
unless (ref($tmp = $self->make_sig_table))
{
# Because this failed, we have to restore the old table and return
# an error
$self->{signature} = $old;
$self->make_sig_table;
- return ref($self) . '::delete_signature: Error re-hashing table: ' .
- $tmp;
+ return
+ ref($self) . '::delete_signature: Error re-hashing table: ' . $tmp;
}
$self;
@@ -853,8 +861,9 @@ sub reload
{
my $self = shift;
- return ref($self) . '::reload: No file associated with method ' .
- $self->{name} unless $self->{file};
+ return
+ ref($self) . '::reload: No file associated with method ' . $self->{name}
+ unless $self->{file};
my $tmp = $self->load_XPL_file($self->{file});
if (ref $tmp)
@@ -909,46 +918,50 @@ sub load_XPL_file
}
$data = {};
# So these don't end up undef, since they're optional elements
- $data->{hidden} = 0; $data->{version} = ''; $data->{help} = '';
- $data->{called} = 0;
+ $data->{hidden} = 0;
+ $data->{version} = '';
+ $data->{help} = '';
+ $data->{called} = 0;
open(F, "< $file") or return "$me: Error opening $file for reading: $!";
- $P = XML::Parser
- ->new(ErrorContext => 1,
- Handlers => {Char => sub { $accum .= $_[1] },
- Start => sub { %attr = splice(@_, 2) },
- End =>
- sub {
- my $elem = $_[1];
-
- $accum =~ s/^[\s\n]+//;
- $accum =~ s/[\s\n]+$//;
- if ($elem eq 'signature')
- {
- $data->{signature} ||= [];
- push(@{$data->{signature}}, $accum);
- }
- elsif ($elem eq 'code')
- {
- $data->{$elem} = $accum
- unless ($attr{language} and
- $attr{language} ne 'perl');
- }
- elsif (substr($elem, -3) eq 'def')
- {
- # Don't blindly store the container tag...
- # We may need it to tell the caller what
- # our type is
- $$self = ucfirst substr($elem, 0, -3)
- if (ref($self) eq 'SCALAR');
- }
- else
- {
- $data->{$elem} = $accum;
- }
-
- %attr = ();
- $accum = '';
- }});
+ $P = XML::Parser->new(
+ ErrorContext => 1,
+ Handlers => {
+ Char => sub { $accum .= $_[1] },
+ Start => sub { %attr = splice(@_, 2) },
+ End => sub {
+ my $elem = $_[1];
+
+ $accum =~ s/^[\s\n]+//;
+ $accum =~ s/[\s\n]+$//;
+ if ($elem eq 'signature')
+ {
+ $data->{signature} ||= [];
+ push(@{$data->{signature}}, $accum);
+ }
+ elsif ($elem eq 'code')
+ {
+ $data->{$elem} = $accum
+ unless ($attr{language}
+ and $attr{language} ne 'perl');
+ }
+ elsif (substr($elem, -3) eq 'def')
+ {
+ # Don't blindly store the container tag...
+ # We may need it to tell the caller what
+ # our type is
+ $$self = ucfirst substr($elem, 0, -3)
+ if (ref($self) eq 'SCALAR');
+ }
+ else
+ {
+ $data->{$elem} = $accum;
+ }
+
+ %attr = ();
+ $accum = '';
+ }
+ }
+ );
return "$me: Error creating XML::Parser object" unless $P;
# Trap any errors
eval { $P->parse(*F) };
@@ -981,7 +994,7 @@ sub load_XPL_file
$data->{code} = $code;
# Add the file's mtime for when we check for stat-based reloading
$data->{mtime} = (stat $file)[9];
- $data->{file} = $file;
+ $data->{file} = $file;
$data;
}
@@ -1017,25 +1030,33 @@ sub call
$name = $self->name;
# Create the param list.
# The type for the response will be derived from the matching signature
- @paramtypes = map { $_->type } @data;
+ @paramtypes = map { $_->type } @data;
@params = map { $_->value } @data;
$signature = join(' ', @paramtypes);
$resptype = $self->match_signature($signature);
# Since there must be at least one signature with a return value (even
# if the param list is empty), this tells us if the signature matches:
- return RPC::XML::fault->new(301,
- "method $name has no matching " .
- 'signature for the argument list: ' .
- "[$signature]")
+ return $srv->server_fault(badsignature => "method $name has no matching " .
+ "signature for the argument list: [$signature]")
unless ($resptype);
+ # Make sure that the response-type is a valid XML-RPC type
+ if (($resptype ne 'scalar') && (! "RPC::XML::$resptype"->can('new')))
+ {
+ return $srv->server_fault(badsignature =>
+ "Signature [$signature] for method $name has unknown " .
+ "return-type '$resptype'");
+ }
# Set these in case the server object is part of the param list
- local $srv->{signature} = [ $resptype, @paramtypes ];
+ local $srv->{signature} = [$resptype, @paramtypes];
local $srv->{method_name} = $name;
# If the method being called is "system.status", check to see if we should
# increment the server call-count.
- $noinc = (($name eq 'system.status') && @data &&
- ($paramtypes[0] eq 'boolean') && $params[0]) ? 1 : 0;
+ $noinc =
+ (($name eq 'system.status') &&
+ @data &&
+ ($paramtypes[0] eq 'boolean') &&
+ $params[0]) ? 1 : 0;
# For RPC::XML::Method (and derivatives), pass the server object
unshift(@params, $srv) if ($self->isa('RPC::XML::Method'));
@@ -1045,15 +1066,29 @@ sub call
# transform Perl-level error/failure into such an object
if ($@)
{
- return (blessed $@ and $@->isa('RPC::XML::fault')) ?
- $@ : RPC::XML::fault->new(302, "Method $name returned error: $@");
+ return (blessed $@ and $@->isa('RPC::XML::fault'))
+ ? $@
+ : $srv->server_fault->(
+ execerror => "Method $name returned error: $@");
}
$self->{called}++ unless $noinc;
# Create a suitable return value
- if ((! ref($response)) && "RPC::XML::$resptype"->can('new'))
+ if (! ref($response))
{
- $response = "RPC::XML::$resptype"->new($response);
+ if ($resptype eq 'scalar')
+ {
+ # Server code from the RPC::XML::Function class doesn't use
+ # signatures, so if they didn't encode the returned value
+ # themselves they're trusting smart_encode() to get it right.
+ $response = smart_encode($response);
+ }
+ else
+ {
+ # We checked that this was valid earlier, so no need for further
+ # tests here.
+ $response = "RPC::XML::$resptype"->new($response);
+ }
}
$response;
@@ -45,6 +45,7 @@
# share_methods
# copy_methods
# timeout
+# server_fault
#
# Libraries: AutoLoader
# HTTP::Daemon (conditionally)
@@ -52,11 +53,12 @@
# HTTP::Status
# URI
# RPC::XML
-# RPC::XML::Parser
+# RPC::XML::ParserFactory
# RPC::XML::Procedure
#
# Global Consts: $VERSION
# $INSTALL_DIR
+# %FAULT_TABLE
#
###############################################################################
@@ -65,8 +67,8 @@ package RPC::XML::Server;
use 5.006001;
use strict;
use warnings;
-use vars qw($VERSION @ISA $INSTANCE $INSTALL_DIR @XPL_PATH
- $IO_SOCKET_SSL_HACK_NEEDED $COMPRESSION_AVAILABLE);
+use vars qw($VERSION @ISA $INSTANCE $INSTALL_DIR %FAULT_TABLE @XPL_PATH
+ $IO_SOCKET_SSL_HACK_NEEDED $COMPRESSION_AVAILABLE);
use Carp 'carp';
use AutoLoader 'AUTOLOAD';
@@ -78,7 +80,7 @@ use URI;
use Scalar::Util 'blessed';
use RPC::XML;
-use RPC::XML::Parser;
+use RPC::XML::ParserFactory;
use RPC::XML::Procedure;
BEGIN
@@ -95,10 +97,18 @@ BEGIN
# Check for compression support
eval { require Compress::Zlib; };
$COMPRESSION_AVAILABLE = ($@) ? '' : 'deflate';
-}
+ # Set up the initial table of fault-types and their codes/messages
+ %FAULT_TABLE = (
+ badxml => [100 => 'XML parse error: %s'],
+ badmethod => [200 => 'Method lookup error: %s'],
+ badsignature => [201 => 'Method signature error: %s'],
+ execerror => [300 => 'Code execution error: %s'],
+ );
+}
-$VERSION = '1.52';
+$VERSION = '1.54';
+$VERSION = eval $VERSION; ## no critic
###############################################################################
#
@@ -119,76 +129,84 @@ $VERSION = '1.52';
sub new
{
my $class = shift;
- my %args = @_;
+ my %args = @_;
- my ($self, $http, $resp, $host, $port, $queue, $path, $URI, $srv_name,
- $srv_version, $timeout);
+ my (
+ $self, $http, $resp, $host,
+ $port, $queue, $path, $URI,
+ $srv_name, $srv_version, $timeout
+ );
$class = ref($class) || $class;
$self = bless {}, $class;
- $srv_version = $args{server_version} || $self->version;
- $srv_name = $args{server_name} || $class;
+ $srv_version = delete $args{server_version} || $self->version;
+ $srv_name = delete $args{server_name} || $class;
$self->{__version} = "$srv_name/$srv_version";
- if ($args{no_http})
+ if (delete $args{no_http})
{
- $self->{__host} = $args{host} || '';
- $self->{__port} = $args{port} || '';
- delete @args{qw(host port)};
+ $self->{__host} = delete $args{host} || '';
+ $self->{__port} = delete $args{port} || '';
}
else
{
require HTTP::Daemon;
- $host = $args{host} || '';
- $port = $args{port} || '';
- $queue = $args{queue} || 5;
- $http = HTTP::Daemon->new(Reuse => 1,
- ($host ? (LocalHost => $host) : ()),
- ($port ? (LocalPort => $port) : ()),
- ($queue ? (Listen => $queue) : ()));
+ $host = delete $args{host} || '';
+ $port = delete $args{port} || '';
+ $queue = delete $args{queue} || 5;
+ $http = HTTP::Daemon->new(
+ Reuse => 1,
+ ($host ? (LocalHost => $host) : ()),
+ ($port ? (LocalPort => $port) : ()),
+ ($queue ? (Listen => $queue) : ())
+ );
return "${class}::new: Unable to create HTTP::Daemon object"
unless $http;
- $URI = URI->new($http->url);
- $self->{__host} = $URI->host;
- $self->{__port} = $URI->port;
+ $URI = URI->new($http->url);
+ $self->{__host} = $URI->host;
+ $self->{__port} = $URI->port;
$self->{__daemon} = $http;
-
- # Remove those we've processed
- delete @args{qw(host port queue)};
}
+
+ # Create and store the cached response object for later cloning and use
$resp = HTTP::Response->new();
return "${class}::new: Unable to create HTTP::Response object"
unless $resp;
- $resp->header(# This is essentially the same string returned by the
- # default "identity" method that may be loaded from a
- # XPL file. But it hasn't been loaded yet, and may not
- # be, hence we set it here (possibly from option values)
- RPC_Server => $self->{__version},
- RPC_Encoding => 'XML-RPC',
- # Set any other headers as well
- Accept => 'text/xml');
+ $resp->header( # This is essentially the same string returned by the
+ # default "identity" method that may be loaded from a
+ # XPL file. But it hasn't been loaded yet, and may not
+ # be, hence we set it here (possibly from option values)
+ RPC_Server => $self->{__version},
+ RPC_Encoding => 'XML-RPC',
+ # Set any other headers as well
+ Accept => 'text/xml'
+ );
$resp->content_type('text/xml');
$resp->code(RC_OK);
$resp->message('OK');
$self->{__response} = $resp;
- $self->{__path} = $args{path} || '';
- $self->{__started} = 0;
- $self->{__method_table} = {};
- $self->{__requests} = 0;
- $self->{__auto_methods} = $args{auto_methods} || 0;
- $self->{__auto_updates} = $args{auto_updates} || 0;
- $self->{__debug} = $args{debug} || 0;
- $self->{__parser} = RPC::XML::Parser->new($args{parser} ?
- @{$args{parser}} : ());
- $self->{__xpl_path} = $args{xpl_path} || [];
- $self->{__timeout} = $args{timeout} || 10;
-
- $self->add_default_methods unless ($args{no_default});
+ # Basic (scalar) properties
+ $self->{__path} = delete $args{path} || '';
+ $self->{__started} = 0;
+ $self->{__method_table} = {};
+ $self->{__requests} = 0;
+ $self->{__auto_methods} = delete $args{auto_methods} || 0;
+ $self->{__auto_updates} = delete $args{auto_updates} || 0;
+ $self->{__debug} = delete $args{debug} || 0;
+ $self->{__xpl_path} = delete $args{xpl_path} || [];
+ $self->{__timeout} = delete $args{timeout} || 10;
+ $self->{__parser} = RPC::XML::ParserFactory->new(
+ $args{parser} ? @{delete $args{parser}} : ());
+
+ # Set up the default methods unless requested not to
+ $self->add_default_methods unless (delete $args{no_default});
+
+ # Compression support
$self->{__compress} = '';
- if ($args{no_compress})
+ if (delete $args{no_compress})
{
$self->{__compress} = '';
}
@@ -200,7 +218,7 @@ sub new
# to change the string in just one place (above) if I have to.
$resp->header(Accept_Encoding => $self->{__compress})
if $self->{__compress};
- $self->{__compress_thresh} = $args{compress_thresh} || 4096;
+ $self->{__compress_thresh} = delete $args{compress_thresh} || 4096;
# Yes, I know this is redundant. It's for future expansion/flexibility.
$self->{__compress_re} =
$self->{__compress} ? qr/$self->{__compress}/ : qr/deflate/;
@@ -210,14 +228,45 @@ sub new
# files due to size, and where to home the temp files. Start with a size
# threshhold of 1Meg and no specific dir (which will fall-through to the
# tmpdir() method of File::Spec).
- $self->{__message_file_thresh} = $args{message_file_thresh} || 1048576;
- $self->{__message_temp_dir} = $args{message_temp_dir} || '';
-
- # Remove the args we've already dealt with directly
- delete @args{qw(no_default no_http debug path server_name server_version
- no_compress compress_thresh parser message_file_thresh
- message_temp_dir)};
- # Copy the rest over untouched
+ $self->{__message_file_thresh} = delete $args{message_file_thresh} ||
+ 1048576;
+ $self->{__message_temp_dir} = delete $args{message_temp_dir} || '';
+
+ # Set up the table of response codes/messages that will be used when the
+ # server is sending a controlled error message to a client (as opposed to
+ # something HTTP-level that is less within our control).
+ $self->{__fault_table} = {%FAULT_TABLE};
+ if ($args{fault_code_base})
+ {
+ my $base = delete $args{fault_code_base};
+ # Apply the numerical offset to all (current) error codes
+ for my $key (keys %{$self->{__fault_table}})
+ {
+ if (ref($self->{__fault_table}->{$key}))
+ {
+ # A ref is a listref where the first element is the code
+ $self->{__fault_table}->{$key}->[0] += $base;
+ }
+ else
+ {
+ $self->{__fault_table}->{$key} += $base;
+ }
+ }
+ }
+ if ($args{fault_table})
+ {
+ my $local_table = delete $args{fault_table};
+ # Merge any data from this table into the object's fault-table
+ for my $key (keys %$local_table)
+ {
+ $self->{__fault_table}->{$key} =
+ (ref $local_table->{$key})
+ ? [@{$local_table->{$key}}]
+ : $local_table->{$key};
+ }
+ }
+
+ # Copy the remaining args over untouched
$self->{$_} = $args{$_} for (keys %args);
$self;
@@ -235,7 +284,7 @@ sub url
my $self = shift;
return $self->{__daemon}->url if $self->{__daemon};
- return undef unless (my $host = $self->host);
+ return unless (my $host = $self->host);
my $path = $self->path;
my $port = $self->port;
@@ -273,12 +322,11 @@ sub started
BEGIN
{
- no strict 'refs';
- my $method;
+ no strict 'refs'; ## no critic
# These are mutable member values for which the logic only differs in
# the name of the field to modify:
- for $method (qw(compress_thresh message_file_thresh message_temp_dir))
+ for my $method (qw(compress_thresh message_file_thresh message_temp_dir))
{
*$method = sub {
my ($self, $set) = @_;
@@ -287,12 +335,14 @@ BEGIN
$self->{"__$method"} = $set if (defined $set);
$old;
- }
+ }
}
# These are immutable member values, so this simple block applies to all
- for $method (qw(path host port requests response compress compress_re
- parser))
+ for my $method (
+ qw(path host port requests response compress compress_re
+ parser)
+ )
{
*$method = sub { shift->{"__$method"} }
}
@@ -302,7 +352,7 @@ BEGIN
sub xpl_path
{
my $self = shift;
- my $ret = $self->{__xpl_path};
+ my $ret = $self->{__xpl_path};
$self->{__xpl_path} = $_[0] if ($_[0] and ref($_[0]) eq 'ARRAY');
$ret;
@@ -331,10 +381,10 @@ sub add_method
my $me = ref($self) . '::add_method';
- if (! ref($meth))
+ if (!ref($meth))
{
$val = $self->method_from_file($meth);
- if (! ref($val))
+ if (!ref($val))
{
return "$me: Error loading from file $meth: $val";
}
@@ -345,10 +395,10 @@ sub add_method
}
elsif (ref($meth) eq 'HASH')
{
- my $class = 'RPC::XML::' . ucfirst ($meth->{type} || 'method');
+ my $class = 'RPC::XML::' . ucfirst($meth->{type} || 'method');
$meth = $class->new($meth);
}
- elsif (! (blessed $meth and $meth->isa('RPC::XML::Procedure')))
+ elsif (!(blessed $meth and $meth->isa('RPC::XML::Procedure')))
{
return "$me: Method argument must be a file name, a hash " .
'reference or an object derived from RPC::XML::Procedure';
@@ -356,7 +406,8 @@ sub add_method
# Do some sanity-checks
return "$me: Method missing required data; check name, code and/or " .
- 'signature' unless $meth->is_valid;
+ 'signature'
+ unless $meth->is_valid;
$name = $meth->name;
$self->{__method_table}->{$name} = $meth;
@@ -435,11 +486,11 @@ gzip-based compression and expansion of messages.
=item new(OPTIONS)
Creates a new object of the class and returns the blessed reference. Depending
-on the options, the object will contain some combination of an HTTP listener,
-a pre-populated B<HTTP::Response> object, a B<RPC::XML::Parser> object, and
-a dispatch table with the set of default methods pre-loaded. The options that
-B<new> accepts are passed as a hash of key/value pairs (not a hash reference).
-The accepted options are:
+on the options, the object will contain some combination of an HTTP listener, a
+pre-populated B<HTTP::Response> object, a B<RPC::XML::ParserFactory>-generated
+object, and a dispatch table with the set of default methods pre-loaded. The
+options that B<new> accepts are passed as a hash of key/value pairs (not a hash
+reference). The accepted options are:
=over 4
@@ -509,11 +560,11 @@ acknowledgement and consent.
=item B<parser>
-If this parameter is passed, the value following it is expected to be an
-array reference. The contents of that array are passed to the B<new> method
-of the B<RPC::XML::Parser> object that the server object caches for its use.
-See the B<RPC::XML::Parser> manual page for a list of recognized parameters
-to the constructor.
+If this parameter is passed, its value is expected to be an array
+reference. The contents of that array are passed to the B<new> method of the
+B<RPC::XML::ParserFactory> class, which creates the parser object that the
+server object caches for its use. See the B<RPC::XML::ParserFactory> manual
+page for a list of recognized parameters to the constructor.
=item B<message_file_thresh>
@@ -524,7 +575,7 @@ temporary file, and spooled from there instead. This is useful for cases in
which the request includes B<RPC::XML::base64> objects that are themselves
spooled from file-handles. This test is independent of compression, so even
if compression of a request would drop it below this threshhold, it will be
-spooled anyway. The file itself is unlinked after the file-handle is created,
+spooled anyway. The file itself is created via File::Temp with UNLINK=>1,
so once it is freed the disk space is immediately freed.
=item B<message_temp_dir>
@@ -533,6 +584,28 @@ If a message is to be spooled to a temporary file, this key can define a
specific directory in which to open those files. If this is not given, then
the C<tmpdir> method from the B<File::Spec> package is used, instead.
+=item B<fault_code_base>
+
+Specify a base integer value that is added to the numerical codes for all
+faults the server can return. See L</"Server Faults"> for the list of faults
+that are built-in to the server class. This allows an application to "move"
+the B<RPC::XML::Server> pre-defined fault codes out of the way of codes that
+the application itself may generate.
+
+Note that this value is B<not> applied to any faults specified via the next
+option, C<fault_table>. It is assumed that the developer has already applied
+any offset to those codes.
+
+=item B<fault_table>
+
+Specify one or more fault types to either add to or override the built-in set
+of faults for the server object. The value of this parameter is a hash
+reference whose keys are the fault type and whose values are either a scalar
+(which is taken to be the numerical code) or a list reference with two elements
+(the code followed by the string). See L</"Server Faults"> for the list of faults
+that are built-in to the server class, and for more information on defining
+your own.
+
=back
Any other keys in the options hash not explicitly used by the constructor are
@@ -579,6 +652,13 @@ they are received. This function returns the old timeout value. If
you pass in no value then it will return the old value without
modifying the current value. The default value is 10 seconds.
+=item server_fault(STRING, STRING)
+
+Create a B<RPC::XML::fault> object of the specified type, optionally including
+the second (string) parameter. See L</"Server Faults"> for the list of faults
+defined by B<RPC::XML::Server> (as well as documentation on creating your
+own).
+
=item add_method(FILE | HASHREF | OBJECT)
=item add_proc(FILE | HASHREF | OBJECT)
@@ -1053,19 +1133,167 @@ as defined earlier for the C<new> method.
=back
+=head2 Server Faults
+
+Previous versions of this library had a very loosely-organized set of fault
+codes that a server might return in certain (non-fatal) error circumstances.
+This has been replaced by a more configurable, adjustable system to allow
+users to better integrate the server-defined faults with any that their
+application may produce. It also allows for the definition of additional
+fault types so that the same mechanism for formatting the pre-defined faults
+can be used within sub-classes and user applications.
+
+The server method B<server_fault> is used to generate B<RPC::XML::fault>
+objects for these situations. It takes one or two arguments, the first being
+the name of the type of fault to create and the second being the specific
+message. If a fault is defined with a static message, the second argument may
+be skipped (and will be ignored if passed).
+
+In addition to defining their own faults, a user may override the definition
+of any of the server's pre-defined faults.
+
+=head3 Defining faults
+
+The user may define their own faults using the C<fault_table> argument to the
+constructor of the server class being instantiated. They may also override
+any of the pre-defined faults (detailed in the next section) by providing a
+new definition for the name.
+
+The value of the C<fault_table> argument is a hash reference whose keys are
+the names of the faults and whose values are one of two types:
+
+=over 4
+
+=item An integer
+
+If the value for the key is a scalar, it is assumed to be an integer and will
+be used as the fault code. When the fault is created, the message argument
+(the second parameter) will be used verbatim as the fault message.
+
+=item A 2-element list reference
+
+If the value is a list reference, it is assumed to have two elements: the first
+is the integer fault code to use, and the second is a message "template"
+string to use as the fault message. If the string contains the sequence C<%s>,
+this will be replaced with the message argument (the second parameter) passed
+to B<server_fault>. If that sequence is not in the string, then the fault
+message is considered static and the message argument is ignored.
+
+=back
+
+An example of defining faults:
+
+ my $server = RPC::XML::Server->new(
+ ...
+ fault_table => {
+ limitexceeded => [ 500 => 'Call limit exceeded' ],
+ accessdenied => [ 600 => 'Access denied: %s' ],
+ serviceclosed => 700
+ },
+ ...
+ );
+
+In this example, the fault-type "limitexceeded" is defined as having a fault
+code of 500 and a static message of C<Call limit exceeded>. The next fault
+defined is "accessdenied", which has a code of 600 and message that starts
+with C<Access denied:> and incorporates whatever message was passed in to the
+fault creation. The last example defines a fault called C<serviceclosed> that
+has a code of 700 and uses any passed-in message unaltered.
+
+=head3 Server-defined faults
+
+The B<RPC::XML::Server> class defines the following faults and uses them
+internally. You can override the codes and messages for these by including them
+in the table passed as a C<fault_table> argument. The faults fall into three
+groups:
+
+=over 4
+
+=item Request Initialization
+
+Faults in this group stem from the initialization of the request and the
+parsing of the XML. The codes for this group fall in the range 100-199.
+
+=item Method Resolution
+
+This group covers problems with mapping the request to a known method or
+function on the server. These codes will be in the range 200-299.
+
+=item Execution
+
+Lastly, these faults are for problems in actually executing the requested
+code. Their codes are in the range 300-399.
+
+=back
+
+The faults, and the phases they apply to, are:
+
+=over 4
+
+=item badxml (Request Initialization)
+
+This fault is sent back to the client when the XML of the request did not
+parse as a valid XML-RPC request.
+
+The code is C<100>, and the message is of the form, C<XML parse error: %s>.
+The specific error from the XML parser is included in the message.
+
+=item badmethod (Method Resolution)
+
+This fault is sent when the requested method is unknown to the server. No
+method has been configured on the server by that name.
+
+The code is C<200>, and the message is of the form, C<Method lookup error: %s>.
+The name of the method and other information is included in the message.
+
+=item badsignature (Method Resolution)
+
+If a method is known on the server, but there is no signature that matches the
+sequence of arguments passed, this fault is returned. This fault cannot be
+triggered by server-side code configured via B<RPC::XML::Function>, as no
+signature-checking is done for those.
+
+The code is C<201>, and the message is of the form, C<Method signature error:
+%s>. The name of the method and the signature of the arguments is included in
+the message.
+
+=item execerror (Execution)
+
+This fault relates back to the client any exception thrown by the remote code
+during execution. If the invoked code returned their error in the form of a
+B<RPC::XML::fault> object, that fault is returned instead. Otherwise, the
+value of C<$@> is used in the message of the fault that gets generated.
+
+The code is C<300>, and the message is of the form, C<Code execution error:
+%s>. The actual text of the exception thrown is included in the message.
+
+=back
+
+There is one special server-fault whose code and message cannot be overridden.
+If a call is made to B<server_fault> for an unknown type of fault, the
+returned object will have a code of C<-1> and a message stating that the
+fault-type is unknown. The message will include both the requested type-name
+and any message (if any) that was passed in.
+
+=head3 Adjusting the server-defined codes
+
+If you just want to "move" the range of codes that the server uses out of the
+way of your application's own faults, this can be done with the
+C<fault_code_base> parameter when constructing the server object. The value
+of the parameter must be an integer, and it is added to the value of all
+existing fault codes. For example, a value of C<10000> would make the code
+for the C<badxml> fault be C<10100>, the code for C<badmethod> be C<10200>,
+etc.
+
+This is applied before any user-defined faults are merged in, so their code
+values will not be affected by this value.
+
=head1 DIAGNOSTICS
Unless explicitly stated otherwise, all methods return some type of reference
on success, or an error string on failure. Non-reference return values should
always be interpreted as errors unless otherwise noted.
-=head1 CAVEATS
-
-This began as a reference implementation in which clarity of process and
-readability of the code took precedence over general efficiency. It is now
-being maintained as production code, but may still have parts that could be
-written more efficiently.
-
=head1 BUGS
Please report any bugs or feature requests to
@@ -1116,11 +1344,11 @@ specification.
=head1 SEE ALSO
-L<RPC::XML>, L<RPC::XML::Client>, L<RPC::XML::Parser>
+L<RPC::XML>, L<RPC::XML::Client>, L<RPC::XML::ParserFactory>
=head1 AUTHOR
-Randy J. Ray <rjray@blackperl.com>
+Randy J. Ray C<< <rjray@blackperl.com> >>
=cut
@@ -1230,7 +1458,8 @@ sub get_method
unless $meth = $self->{__method_table}->{$name};
}
# Check the mod-time of the file the method came from, if the test is on
- if ($self->{__auto_updates} && $meth->{file} &&
+ if ($self->{__auto_updates} &&
+ $meth->{file} &&
($meth->{mtime} < (stat $meth->{file})[9]))
{
my $ret = $meth->reload;
@@ -1284,12 +1513,12 @@ sub server_loop
push @exit_signals, 'INT';
}
- local @SIG{@exit_signals} = ( sub { $exit_now++ } ) x @exit_signals;
+ local @SIG{@exit_signals} = (sub { $exit_now++ }) x @exit_signals;
$self->started('set');
$exit_now = 0;
- $timeout = $self->{__daemon}->timeout(1);
- while (! $exit_now)
+ $timeout = $self->{__daemon}->timeout(1);
+ while (!$exit_now)
{
$conn = $self->{__daemon}->accept;
@@ -1298,7 +1527,7 @@ sub server_loop
$conn->timeout($self->timeout);
$self->process_request($conn);
$conn->close;
- undef $conn; # Free up any lingering resources
+ undef $conn; # Free up any lingering resources
}
$self->{__daemon}->timeout($timeout) if defined $timeout;
@@ -1310,20 +1539,20 @@ sub server_loop
require HTTP::Daemon;
my $conf_file_flag = 0;
- my $port_flag = 0;
- my $host_flag = 0;
+ my $port_flag = 0;
+ my $host_flag = 0;
for (my $i = 0; $i < @_; $i += 2)
{
$conf_file_flag = 1 if ($_[$i] eq 'conf_file');
- $port_flag = 1 if ($_[$i] eq 'port');
- $host_flag = 1 if ($_[$i] eq 'host');
+ $port_flag = 1 if ($_[$i] eq 'port');
+ $host_flag = 1 if ($_[$i] eq 'host');
}
# An explicitly-given conf-file trumps any specified at creation
- if (exists($self->{conf_file}) and (! $conf_file_flag))
+ if (exists($self->{conf_file}) and (!$conf_file_flag))
{
- push (@_, 'conf_file', $self->{conf_file});
+ push(@_, 'conf_file', $self->{conf_file});
$conf_file_flag = 1;
}
@@ -1331,15 +1560,16 @@ sub server_loop
# pointing to a config file:
unless ($conf_file_flag or $port_flag)
{
- push (@_, 'port', $self->{port} || $self->port || 9000);
- push (@_, 'host', $self->{host} || $self->host || '*');
+ push(@_, 'port', $self->{port} || $self->port || 9000);
+ push(@_, 'host', $self->{host} || $self->host || '*');
}
# Try to load the Net::Server::MultiType module
eval { require Net::Server::MultiType; };
- return ref($self) .
+ return
+ ref($self) .
"::server_loop: Error loading Net::Server::MultiType: $@"
- if ($@);
+ if ($@);
unshift(@RPC::XML::Server::ISA, 'Net::Server::MultiType');
$self->started('set');
@@ -1414,9 +1644,11 @@ sub process_request
my $self = shift;
my $conn = shift;
- my ($req, $reqxml, $resp, $respxml, $do_compress, $parser, $com_engine,
- $length, $read, $buf, $resp_fh, $tmpfile,
- $peeraddr, $peerhost, $peerport);
+ my (
+ $req, $reqxml, $resp, $respxml, $do_compress,
+ $parser, $com_engine, $length, $read, $buf,
+ $resp_fh, $tmpdir, $peeraddr, $peerhost, $peerport
+ );
my $me = ref($self) . '::process_request';
unless ($conn and ref($conn))
@@ -1425,15 +1657,15 @@ sub process_request
bless $conn, 'HTTP::Daemon::ClientConn';
${*$conn}{'httpd_daemon'} = $self;
- if ($IO::Socket::SSL::VERSION and
- $RPC::XML::Server::IO_SOCKET_SSL_HACK_NEEDED)
+ if ( $IO::Socket::SSL::VERSION
+ and $RPC::XML::Server::IO_SOCKET_SSL_HACK_NEEDED)
{
no strict 'vars';
# RT 43019: Don't do this if Socket6/IO::Socket::INET6 is in
# effect, as it causes calls to unpack_sockaddr_in6 to break.
unshift @HTTP::Daemon::ClientConn::ISA, 'IO::Socket::SSL'
- unless (defined $Socket6::VERSION or
- defined $IO::Socket::INET6::VERSION);
+ unless (defined $Socket6::VERSION
+ or defined $IO::Socket::INET6::VERSION);
$RPC::XML::Server::IO_SOCKET_SSL_HACK_NEEDED = 0;
}
}
@@ -1463,8 +1695,7 @@ sub process_request
unless ($self->compress)
{
$conn->send_error(RC_BAD_REQUEST,
- "$me: Compression not permitted in " .
- 'requests');
+ "$me: Compression not permitted in " . 'requests');
next;
}
@@ -1486,8 +1717,8 @@ sub process_request
unless ($com_engine = Compress::Zlib::inflateInit())
{
$conn->send_error(RC_INTERNAL_SERVER_ERROR,
- "$me: Unable to initialize the " .
- 'Compress::Zlib engine');
+ "$me: Unable to initialize the " .
+ 'Compress::Zlib engine');
next;
}
}
@@ -1501,12 +1732,13 @@ sub process_request
# left in the read buffer. The call to sysread() should
# NOT be made until we've emptied this source, first.
$read = length($buf);
- $conn->read_buffer(''); # Clear it, now that it's read
+ $conn->read_buffer(''); # Clear it, now that it's read
}
else
{
- $read = sysread($conn, $buf,
- ($length < 2048) ? $length : 2048);
+ $read =
+ sysread($conn, $buf,
+ ($length < 2048) ? $length : 2048);
unless ($read)
{
# Convert this print to a logging-hook call.
@@ -1525,8 +1757,7 @@ sub process_request
unless ($buf = $com_engine->inflate($buf))
{
$conn->send_error(RC_INTERNAL_SERVER_ERROR,
- "$me: Error inflating " .
- 'compressed data');
+ "$me: Error inflating " . 'compressed data');
# This error also means that even if Keep-Alive
# is set, we don't know how much of the stream
# is corrupted.
@@ -1539,8 +1770,8 @@ sub process_request
if ($@)
{
$conn->send_error(RC_INTERNAL_SERVER_ERROR,
- "$me: Parse error in (compressed) " .
- "XML request (mid): $@");
+ "$me: Parse error in (compressed) " .
+ "XML request (mid): $@");
# Again, the stream is likely corrupted
$conn->force_last_request;
next;
@@ -1551,16 +1782,16 @@ sub process_request
if ($@)
{
$conn->send_error(RC_INTERNAL_SERVER_ERROR,
- "$me: Parse error in (compressed) " .
- "XML request (end): $@");
+ "$me: Parse error in (compressed) " .
+ "XML request (end): $@");
next;
}
}
# Dispatch will always return a RPC::XML::response.
- # RT29351: If there was an error from RPC::XML::Parser (such as
- # a message that didn't conform to spec), then return it directly
- # as a fault, don't have dispatch() try and handle it.
+ # RT29351: If there was an error from RPC::XML::ParserFactory
+ # (such as a message that didn't conform to spec), then return it
+ # directly as a fault, don't have dispatch() try and handle it.
if (ref $reqxml)
{
# Set localized keys on $self, based on the connection info
@@ -1571,43 +1802,40 @@ sub process_request
}
else
{
- $respxml = RPC::XML::fault->new(RC_INTERNAL_SERVER_ERROR,
- $reqxml);
- $respxml = RPC::XML::response->new($respxml);
+ $respxml = RPC::XML::response->new(
+ $self->server_fault('badxml', $reqxml));
}
# Clone the pre-fab response and set headers
$resp = $self->response->clone;
# Should we apply compression to the outgoing response?
- $do_compress = 0; # In case it was set above for incoming data
- if ($self->compress and
- ($respxml->length > $self->compress_thresh) and
- (($req->header('Accept-Encoding') || '') =~
- $self->compress_re))
+ $do_compress = 0; # In case it was set above for incoming data
+ if ( $self->compress
+ and ($respxml->length > $self->compress_thresh)
+ and
+ (($req->header('Accept-Encoding') || '') =~ $self->compress_re))
{
$do_compress = 1;
$resp->header(Content_Encoding => $self->compress);
}
# Next step, determine the response disposition. If it is above the
# threshhold for a requested file cut-off, send it to a temp file
- if ($self->message_file_thresh and
- $self->message_file_thresh < $respxml->length)
+ if ( $self->message_file_thresh
+ and $self->message_file_thresh < $respxml->length)
{
require File::Spec;
# Start by creating a temp-file
- $tmpfile = $self->message_temp_dir || File::Spec->tmpdir;
- $tmpfile = File::Spec->catfile($tmpfile,
- __PACKAGE__ . $$ . time);
- $tmpfile =~ s/::/-/g;
- unless (open($resp_fh, "+> $tmpfile"))
+ $tmpdir = $self->message_temp_dir || File::Spec->tmpdir;
+ unless ($resp_fh = File::Temp->new(UNLINK => 1, DIR => $tmpdir))
{
$conn->send_error(RC_INTERNAL_SERVER_ERROR,
- "$me: Error opening $tmpfile: $!");
+ "$me: Error opening tmpfile: $!");
next;
}
- unlink $tmpfile;
# Make it auto-flush
- my $old_fh = select($resp_fh); $| = 1; select($old_fh);
+ my $old_fh = select($resp_fh);
+ $| = 1;
+ select($old_fh);
# Now that we have it, spool the response to it. This is a
# little hairy, since we still have to allow for compression.
@@ -1617,16 +1845,16 @@ sub process_request
if ($do_compress)
{
my $fh2;
- $tmpfile .= '-2';
- unless (open($fh2, "+> $tmpfile"))
+ unless ($fh2 = File::Temp->new(UNLINK => 1, DIR => $tmpdir))
{
$conn->send_error(RC_INTERNAL_SERVER_ERROR,
- "$me: Error opening $tmpfile: $!");
+ "$me: Error opening tmpfile: $!");
next;
}
- unlink $tmpfile;
# Make it auto-flush
- $old_fh = select($fh2); $| = 1; select($old_fh);
+ $old_fh = select($fh2);
+ $| = 1;
+ select($old_fh);
# Write the request to the second FH
$respxml->serialize($fh2);
@@ -1636,8 +1864,8 @@ sub process_request
unless ($com_engine = Compress::Zlib::deflateInit())
{
$conn->send_error(RC_INTERNAL_SERVER_ERROR,
- "$me: Unable to initialize the " .
- 'Compress::Zlib engine');
+ "$me: Unable to initialize the " .
+ 'Compress::Zlib engine');
next;
}
@@ -1650,8 +1878,7 @@ sub process_request
unless (defined($out = $com_engine->deflate(\$buf)))
{
$conn->send_error(RC_INTERNAL_SERVER_ERROR,
- "$me: Compression failure in " .
- 'deflate()');
+ "$me: Compression failure in " . 'deflate()');
next;
}
print $resp_fh $out;
@@ -1660,8 +1887,7 @@ sub process_request
unless (defined($out = $com_engine->flush))
{
$conn->send_error(RC_INTERNAL_SERVER_ERROR,
- "$me: Compression flush failure in" .
- ' deflate()');
+ "$me: Compression flush failure in" . ' deflate()');
next;
}
print $resp_fh $out;
@@ -1677,12 +1903,14 @@ sub process_request
seek($resp_fh, 0, 0);
$resp->content_length(-s $resp_fh);
- $resp->content(sub {
- my $b = '';
- return undef unless
- defined(read($resp_fh, $b, 4096));
- $b;
- });
+ $resp->content(
+ sub {
+ my $b = '';
+ return undef
+ unless defined(read($resp_fh, $b, 4096));
+ $b;
+ }
+ );
}
else
{
@@ -1736,9 +1964,8 @@ sub dispatch
if (ref($xml) eq 'SCALAR')
{
$reqobj = $self->parser->parse($$xml);
- return RPC::XML::response
- ->new(RPC::XML::fault->new(200, "XML parse failure: $reqobj"))
- unless (ref $reqobj);
+ return RPC::XML::response->new($self->server_fault(badxml => $reqobj))
+ unless (ref $reqobj);
}
elsif (ref($xml) eq 'ARRAY')
{
@@ -1754,9 +1981,8 @@ sub dispatch
else
{
$reqobj = $self->parser->parse($xml);
- return RPC::XML::response
- ->new(RPC::XML::fault->new(200, "XML parse failure: $reqobj"))
- unless (ref $reqobj);
+ return RPC::XML::response->new($self->server_fault(badxml => $reqobj))
+ unless (ref $reqobj);
}
@data = @{$reqobj->args};
@@ -1768,12 +1994,14 @@ sub dispatch
{
$response = $meth->call($self, @data);
$self->{__requests}++
- unless (($name eq 'system.status') && @data &&
- ($data[0]->type eq 'boolean') && ($data[0]->value));
+ unless (($name eq 'system.status') &&
+ @data &&
+ ($data[0]->type eq 'boolean') &&
+ ($data[0]->value));
}
else
{
- $response = RPC::XML::fault->new(300, $meth);
+ $response = $self->server_fault(badmethod => $meth);
}
# All the eval'ing and error-trapping happened within the method class
@@ -1855,8 +2083,8 @@ sub add_default_methods
###############################################################################
sub add_methods_in_dir
{
- my $self = shift;
- my $dir = shift;
+ my $self = shift;
+ my $dir = shift;
my @details = @_;
my $negate = 0;
@@ -1875,7 +2103,7 @@ sub add_methods_in_dir
@details{@details} = (1) x @details;
}
- local(*D);
+ local (*D);
opendir(D, $dir) || return "Error opening $dir for reading: $!";
my @files = grep($_ =~ /\.xpl$/, readdir(D));
closedir D;
@@ -1883,8 +2111,8 @@ sub add_methods_in_dir
for (@files)
{
# Use $detail as a short-circuit to avoid the other tests when we can
- next if ($detail and
- $negate ? $details{$_} : ! $details{$_});
+ next if ($detail
+ and $negate ? $details{$_} : !$details{$_});
# n.b.: Giving the full path keeps add_method from having to search
$ret = $self->add_method(File::Spec->catfile($dir, $_));
return $ret unless ref $ret;
@@ -1980,8 +2208,8 @@ sub share_methods
my ($me, $pkg, %tmp, @tmp, $tmp, $meth, @list, @missing);
- $me = ref($self) . '::share_methods';
- $pkg = __PACKAGE__; # So it can go inside quoted strings
+ $me = ref($self) . '::share_methods';
+ $pkg = __PACKAGE__; # So it can go inside quoted strings
return "$me: First arg not derived from $pkg, cannot share"
unless (blessed $src_srv && $src_srv->isa($pkg));
@@ -2065,8 +2293,8 @@ sub copy_methods
my ($me, $pkg, %tmp, @tmp, $tmp, $meth, @list, @missing);
- $me = ref($self) . '::copy_methods';
- $pkg = __PACKAGE__; # So it can go inside quoted strings
+ $me = ref($self) . '::copy_methods';
+ $pkg = __PACKAGE__; # So it can go inside quoted strings
return "$me: First arg not derived from $pkg, cannot copy"
unless (blessed $src_srv && $src_srv->isa($pkg));
@@ -2152,3 +2380,49 @@ sub timeout
}
return $old_timeout;
}
+
+###############################################################################
+#
+# Sub Name: server_fault
+#
+# Description: Create a RPC::XML::fault object for the class of error
+# and specific message that are passed in.
+#
+# Arguments: NAME IN/OUT TYPE DESCRIPTION
+# $self in ref Object of this class
+# $err in scalar Type of error/fault to generate
+# $message in scalar Error text for the fault
+#
+# Returns: RPC::XML::fault instance
+#
+###############################################################################
+sub server_fault
+{
+ my ($self, $err, $message) = @_;
+ $message ||= ''; # Avoid any "undef" warnings
+
+ my ($code, $text);
+
+ if (my $fault = $self->{__fault_table}->{$err})
+ {
+ if (ref $fault)
+ {
+ # This specifies both code and message
+ ($code, $text) = @$fault;
+ # Replace (the first) "%s" with $message
+ $text =~ s/%s/$message/;
+ }
+ else
+ {
+ # This is just the code, use $message verbatim
+ ($code, $text) = ($fault, $message);
+ }
+ }
+ else
+ {
+ $code = -1;
+ $text = "Unknown error class '$err' (message is '$message')";
+ }
+
+ RPC::XML::fault->new($code, $text);
+}
@@ -29,10 +29,10 @@ use vars qw(@EXPORT @EXPORT_OK %EXPORT_TAGS @ISA $VERSION $ERROR
%xmlmap $xmlre $ENCODING $FORCE_STRING_ENCODING $ALLOW_NIL);
use subs qw(time2iso8601 smart_encode utf8_downgrade);
+## no critic (ProhibitSubroutinePrototypes)
+
BEGIN
{
- no strict 'refs';
-
%xmlmap = ( '>' => '>', '<' => '<', '&' => '&',
'"' => '"', "'" => ''');
$xmlre = join('', keys %xmlmap); $xmlre = qr/([$xmlre])/;
@@ -64,7 +64,8 @@ require Exporter;
RPC_DATETIME_ISO8601 RPC_BASE64 RPC_NIL) ],
all => [ @EXPORT_OK ]);
-$VERSION = '1.43';
+$VERSION = '1.44';
+$VERSION = eval $VERSION; ## no critic
# Global error string
$ERROR = '';
@@ -114,9 +115,23 @@ sub time2iso8601
sub smart_encode
{
my @values = @_;
- my $type;
+ 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';
+ }
- @values = map
+ foreach (@values)
{
if (! defined $_)
{
@@ -125,14 +140,34 @@ sub time2iso8601
}
elsif (ref $_)
{
- # Skip any that have already been encoded
+ # Skip any that we've already seen
+ next if $seenrefs->{$_}++;
+
if (blessed $_ and $_->isa('RPC::XML::datatype'))
{
+ # Pass through any that have already been encoded
$type = $_;
}
elsif (reftype($_) eq 'HASH')
{
- $type = RPC::XML::struct->new($_);
+ # 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')
{
@@ -141,20 +176,23 @@ sub time2iso8601
# pass array-refs in to this constructor and have them
# be treated as single elements, as one would expect
# (see RT 35106)
- $type = RPC::XML::array->new(from => $_);
+ # 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($$_);
+ $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:
- my $type = reftype $_;
+ my $type = blessed $_ || reftype $_;
die "Un-convertable reference/type: $type, cannot use";
}
}
@@ -179,10 +217,10 @@ sub time2iso8601
$type = RPC::XML::string->new($_);
}
- $type;
- } @values;
+ push(@newvalues, $type);
+ }
- return (wantarray ? @values : $values[0]);
+ return (wantarray ? @newvalues : $newvalues[0]);
}
}
@@ -393,7 +431,7 @@ sub new
$class = ref($class) || $class;
$RPC::XML::ERROR = "${class}::new: Value must be one of yes, no, " .
'true, false, 1, 0 (case-insensitive)';
- return undef;
+ return;
}
bless \$value, $class;
@@ -435,7 +473,7 @@ sub new
{
$RPC::XML::ERROR = "${class}::new: \$RPC::XML::ALLOW_NIL must be set" .
'for RPC::XML::nil objects to be supported';
- return undef;
+ return;
}
bless \$value, $class;
@@ -482,15 +520,9 @@ sub new
@args = @{$args[1]};
}
- # First ensure that each argument passed in is itself one of the data-type
+ # Ensure that each argument passed in is itself one of the data-type
# class instances.
- for (@args)
- {
- $_ = RPC::XML::smart_encode($_)
- unless (blessed($_) && $_->isa('RPC::XML::datatype'));
- }
-
- bless \@args, $class;
+ bless [ RPC::XML::smart_encode(@args) ], $class;
}
# This became more complex once it was shown that there may be a need to fetch
@@ -576,15 +608,15 @@ sub new
my $class = shift;
my %args = (ref($_[0]) and reftype($_[0]) eq 'HASH') ? %{$_[0]} : @_;
- # First ensure that each argument passed in is itself one of the data-type
- # class instances.
- for (keys %args)
- {
- $args{$_} = RPC::XML::smart_encode($args{$_})
- unless (blessed $args{$_} && $args{$_}->isa('RPC::XML::datatype'));
- }
+ # 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;
- bless \%args, $class;
+ bless $ref, $class;
}
# This became more complex once it was shown that there may be a need to fetch
@@ -709,7 +741,7 @@ sub new
$class = ref($class) || $class;
$RPC::XML::ERROR = "${class}::new: Must be called with non-null " .
'data or an open, seekable filehandle';
- return undef;
+ return;
}
# We want in-memory data to always be in the clear, to reduce the tests
# needed in value(), below.
@@ -903,7 +935,7 @@ sub to_file
{
require Symbol;
$fh = Symbol::gensym();
- unless (open($fh, "> $file"))
+ unless (open($fh, '>', $file))
{
$RPC::XML::ERROR = $!;
return -1;
@@ -1005,13 +1037,13 @@ sub new
{
$class = ref($class) || $class;
$RPC::XML::ERROR = "${class}::new: Missing required struct fields";
- return undef;
+ return;
}
if (scalar(keys %args) > 2)
{
$class = ref($class) || $class;
$RPC::XML::ERROR = "${class}::new: Extra struct fields not allowed";
- return undef;
+ return;
}
$self = $class->SUPER::new(%args);
@@ -1104,7 +1136,7 @@ sub new
{
$RPC::XML::ERROR = 'RPC::XML::request::new: At least a method name ' .
'must be specified';
- return undef;
+ return;
}
if (blessed $argz[0] and $argz[0]->isa('RPC::XML::request'))
@@ -1,5 +1,4 @@
#!/usr/bin/perl
-# $Id$
use strict;
use vars qw(@MODULES @APACHE_MODULES $do_apache);
@@ -10,7 +9,8 @@ use Test::More;
BEGIN
{
- @MODULES = qw(RPC::XML RPC::XML::Parser
+ @MODULES = qw(RPC::XML RPC::XML::ParserFactory
+ RPC::XML::Parser RPC::XML::Parser::XMLParser
RPC::XML::Procedure RPC::XML::Method
RPC::XML::Client RPC::XML::Server);
@APACHE_MODULES = qw(Apache::RPC::Server Apache::RPC::Status);
@@ -1,12 +1,33 @@
#!/usr/bin/perl
-# $Id$
-use Test::More;
+# Test that the syntax of our POD documentation is valid
+use strict;
+BEGIN {
+ $| = 1;
+ $^W = 1;
+}
+
+my @MODULES = (
+ 'Pod::Simple 3.07',
+ 'Test::Pod 1.26',
+);
-eval "use Test::Pod 1.00";
+# Don't run tests during end-user installs
+use Test::More;
+unless ( $ENV{AUTOMATED_TESTING} or $ENV{RELEASE_TESTING} ) {
+ plan( skip_all => "Author tests not required for installation" );
+}
-plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
+# Load the testing modules
+foreach my $MODULE ( @MODULES ) {
+ eval "use $MODULE";
+ if ( $@ ) {
+ $ENV{RELEASE_TESTING}
+ ? die( "Failed to load required release-testing module $MODULE" )
+ : plan( skip_all => "$MODULE not available for testing" );
+ }
+}
all_pod_files_ok();
-exit;
+1;
@@ -1,37 +1,47 @@
#!/usr/bin/perl
-# $Id$
use Test::More;
-eval "use Test::Pod::Coverage 1.00";
+unless ( $ENV{AUTOMATED_TESTING} or $ENV{RELEASE_TESTING} ) {
+ plan( skip_all => "Author tests not required for installation" );
+}
-plan skip_all =>
- "Test::Pod::Coverage 1.00 required for testing POD coverage" if $@;
-plan tests => 9;
+my @MODULES = qw(Test::Pod::Coverage);
+# Load the testing modules
+foreach my $MODULE ( @MODULES ) {
+ eval "use $MODULE";
+ if ( $@ ) {
+ $ENV{RELEASE_TESTING}
+ ? die( "Failed to load required release-testing module $MODULE" )
+ : plan( skip_all => "$MODULE not available for testing" );
+ }
+}
-pod_coverage_ok(Apache::RPC::Server => { also_private => [ 'debug' ] } =>
+plan tests => 11;
+
+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::Client => { also_private => [ qr/^compress/ ] } =>
+pod_coverage_ok('Apache::RPC::Status' => 'Apache::RPC::Status');
+pod_coverage_ok('RPC::XML' =>
+ { also_private => [ qr/^RPC_/, 'utf8_downgrade' ] },
+ 'RPC::XML');
+pod_coverage_ok('RPC::XML::Client' => { also_private => [ qr/^compress/ ] } =>
'RPC::XML::Client');
-pod_coverage_ok(RPC::XML::Function =>
+pod_coverage_ok('RPC::XML::Function' =>
{ also_private => [ qw(make_sig_table) ] } =>
'RPC::XML::Function');
-pod_coverage_ok(RPC::XML::Method =>
- 'RPC::XML::Method');
-pod_coverage_ok(RPC::XML::Parser =>
+pod_coverage_ok('RPC::XML::Method' => 'RPC::XML::Method');
+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');
-pod_coverage_ok(RPC::XML::Procedure =>
+ 'RPC::XML::Parser::XMLParser');
+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 => [ 'compress_re' ] } =>
+pod_coverage_ok('RPC::XML::Server' => { also_private => [ 'compress_re' ] } =>
'RPC::XML::Server');
-pod_coverage_ok(RPC::XML =>
- { also_private => [ qr/^RPC_/, 'utf8_downgrade' ] },
- 'RPC::XML');
exit;
@@ -1,5 +1,4 @@
#!/usr/bin/perl
-# $Id$
# Test the data-manipulation routines in RPC::XML
@@ -1,10 +1,9 @@
#!/usr/bin/perl
-# $Id$
# Test the usage of RPC::XML::base64 with filehandles
use strict;
-use vars qw($dir $file $tmpfile $value $enc_value $obj $fh $pos $md5_able);
+use vars qw($dir $vol $file $tmpfile $value $enc_value $obj $fh $pos $md5_able);
# This is what we're testing
use RPC::XML;
@@ -14,7 +13,8 @@ use File::Spec;
use IO::File;
use MIME::Base64;
-(undef, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0));
+($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__${$}__");
@@ -1,5 +1,4 @@
#!/usr/bin/perl
-# $Id$
# Test the data-manipulation routines in RPC::XML
@@ -1,10 +1,9 @@
#!/usr/bin/perl
-# $Id$
# Test the serialization of XML structures to filehandles
use strict;
-use vars qw($dir $fh $file $tmpfile $md5_able $faux_req $faux_res $ofh $data);
+use vars qw($dir $vol $fh $file $tmpfile $md5_able $faux_req $faux_res $ofh $data);
use RPC::XML ':all';
@@ -12,7 +11,8 @@ use Test;
use File::Spec;
use IO::File;
-(undef, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0));
+($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__${$}__");
@@ -1,121 +0,0 @@
-#!/usr/bin/perl
-# $Id$
-
-# Test the XML::Parser container
-
-use strict;
-use vars qw($p $req $res $ret $dir $file);
-
-use Test::More tests => 35;
-require File::Spec;
-require IO::File;
-
-use RPC::XML ':all';
-use RPC::XML::Parser;
-
-(undef, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0));
-$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.
-
-$p = RPC::XML::Parser->new();
-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');
-
-# 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 <i4> argument');
- is($args->[0]->value, 1, 'RPC::XML::i4 value parsed OK');
- isa_ok($args->[1], 'RPC::XML::int', 'Parse of <int> argument');
- is($args->[1]->value, 2, 'RPC::XML::int value parsed OK');
- isa_ok($args->[2], 'RPC::XML::i8', 'Parse of <i8> argument');
- is($args->[2]->value, 3, 'RPC::XML::i8 value parsed OK');
- isa_ok($args->[3], 'RPC::XML::double', 'Parse of <double> argument');
- is($args->[3]->value, 4.5, 'RPC::XML::double value parsed OK');
- isa_ok($args->[4], 'RPC::XML::string', 'Parse of <string> argument');
- is($args->[4]->value, 'string', 'RPC::XML::string value parsed OK');
- isa_ok($args->[5], 'RPC::XML::boolean', 'Parse of <boolean> argument');
- ok($args->[5]->value, 'RPC::XML::boolean value parsed OK');
- isa_ok($args->[6], 'RPC::XML::datetime_iso8601',
- 'Parse of <dateTime.iso8601> argument');
- is($args->[6]->value, '2008-09-29T12:00:00-07:00',
- 'RPC::XML::dateTime.iso8601 value parsed OK');
- isa_ok($args->[7], 'RPC::XML::array', 'Parse of <array> argument');
- is(scalar(@{$args->[7]->value}), 2, 'RPC::XML::array value parsed OK');
- isa_ok($args->[8], 'RPC::XML::struct', 'Parse of <struct> 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->new(base64_to_fh => 1);
-my $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');
-
-exit 0;
@@ -0,0 +1,122 @@
+#!/usr/bin/perl
+
+# Test the RPC::XML::Parser::XMLParser class
+
+use strict;
+use vars qw($p $req $res $ret $dir $vol $file);
+
+use Test::More tests => 36;
+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.
+
+$p = RPC::XML::Parser::XMLParser->new();
+isa_ok($p, 'RPC::XML::Parser::XMLParser', '$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');
+
+# 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 <i4> argument');
+ is($args->[0]->value, 1, 'RPC::XML::i4 value parsed OK');
+ isa_ok($args->[1], 'RPC::XML::int', 'Parse of <int> argument');
+ is($args->[1]->value, 2, 'RPC::XML::int value parsed OK');
+ isa_ok($args->[2], 'RPC::XML::i8', 'Parse of <i8> argument');
+ is($args->[2]->value, 3, 'RPC::XML::i8 value parsed OK');
+ isa_ok($args->[3], 'RPC::XML::double', 'Parse of <double> argument');
+ is($args->[3]->value, 4.5, 'RPC::XML::double value parsed OK');
+ isa_ok($args->[4], 'RPC::XML::string', 'Parse of <string> argument');
+ is($args->[4]->value, 'string', 'RPC::XML::string value parsed OK');
+ isa_ok($args->[5], 'RPC::XML::boolean', 'Parse of <boolean> argument');
+ ok($args->[5]->value, 'RPC::XML::boolean value parsed OK');
+ isa_ok($args->[6], 'RPC::XML::datetime_iso8601',
+ 'Parse of <dateTime.iso8601> argument');
+ is($args->[6]->value, '2008-09-29T12:00:00-07:00',
+ 'RPC::XML::dateTime.iso8601 value parsed OK');
+ isa_ok($args->[7], 'RPC::XML::array', 'Parse of <array> argument');
+ is(scalar(@{$args->[7]->value}), 2, 'RPC::XML::array value parsed OK');
+ isa_ok($args->[8], 'RPC::XML::struct', 'Parse of <struct> 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);
+my $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');
+
+exit 0;
@@ -0,0 +1,112 @@
+#!/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 => 26;
+use Symbol;
+require File::Spec;
+require IO::File;
+
+use RPC::XML ':all';
+
+($vol, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0));
+$dir = File::Spec->catpath($vol, $dir, '');
+
+# Need read_config() from util.pl:
+require File::Spec->catfile($dir, 'util.pl');
+
+$config = read_config(File::Spec->catfile($dir, 'test.conf'));
+# What parsers did we detect?
+%parsers = map { $_ => 1 } @{$config->{parsers}};
+
+# 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.
+
+# Start by testing with the XML::Parser wrapper, since that is the only one
+# that is "required" (for now).
+{
+ use RPC::XML::ParserFactory;
+
+ $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)],
+ 'XML::SAX' => [qw(XML::SAX xml::sax xmlsax)],
+);
+
+# Test with the various aliases for XML::Parser
+for my $alias (@{$aliases{'XML::Parser'}})
+{
+ $ns++;
+
+ eval <<"EndOfEval1";
+{
+ package $ns;
+ use RPC::XML::ParserFactory (class => $alias);
+
+ \$main::p = RPC::XML::ParserFactory->new();
+}
+EndOfEval1
+
+ 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 XML::SAX))
+{
+ SKIP:
+ {
+ skip "$parser not detected, tests skipped", 6
+ unless $parsers{$parser};
+
+ for my $alias (@{$aliases{$parser}})
+ {
+ $ns++;
+
+ eval <<"EndOfEval1";
+{
+ package $ns;
+ use RPC::XML::ParserFactory (class => $alias);
+
+ \$main::p = RPC::XML::ParserFactory->new();
+}
+EndOfEval1
+
+ isa_ok($p, 'RPC::XML::Parser', "Alias $alias: \$p");
+ isa_ok($p, 'RPC::XML::Parser::XMLParser', "Alias $alias: \$p");
+ }
+ }
+}
+
+exit 0;
@@ -4,7 +4,7 @@
use strict;
use warnings;
-use vars qw($obj $obj2 $flag $dir $tmp);
+use vars qw($obj $obj2 $flag $dir $vol $tmp);
use File::Spec;
use Test::More;
@@ -13,7 +13,8 @@ use RPC::XML::Procedure;
plan tests => 37;
-(undef, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0));
+($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
@@ -4,7 +4,7 @@
use strict;
use warnings;
-use vars qw($obj $obj2 $dir);
+use vars qw($obj $obj2 $dir $vol);
use File::Spec;
use Test::More;
@@ -13,7 +13,8 @@ use RPC::XML::Procedure;
plan tests => 7;
-(undef, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0));
+($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
@@ -5,7 +5,7 @@
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);
+ $list $meth @keys %seen $dir $vol);
use Socket;
use File::Spec;
@@ -13,18 +13,22 @@ use File::Spec;
use Test::More tests => 61;
use LWP::UserAgent;
use HTTP::Request;
+use Scalar::Util 'blessed';
use RPC::XML 'RPC_BASE64';
require RPC::XML::Server;
-require RPC::XML::Parser;
+require RPC::XML::ParserFactory;
@API_METHODS = qw(system.identity system.introspection system.listMethods
system.methodHelp system.methodSignature system.multicall
system.status);
-(undef, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0));
+($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
@@ -64,7 +68,7 @@ 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');
+push @allhosts, 'localhost' if ($^O eq 'MSWin32' || $^O eq 'cygwin');
my $allhosts = join('|', @allhosts);
like($srv->url, qr{http://($allhosts):$port},
'RPC::XML::Server::url method (set)'); # This should be non-null this time
@@ -78,7 +82,7 @@ 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::Parser->new;
+$parser = RPC::XML::ParserFactory->new;
$UA = LWP::UserAgent->new;
$req = HTTP::Request->new(POST => "http://localhost:$port/");
$child = start_server($srv);
@@ -290,9 +294,16 @@ $res = ($res->is_error) ? '' : $parser->parse($res->content);
SKIP: {
skip "Server response was error, cannot test", 1 unless $res;
$list = $res->value->value;
- is(join(',', sort @$list),
- 'system.methodHelp,system.methodSignature',
- 'system.listMethods("method") return list correct');
+ 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
@@ -315,7 +326,15 @@ $res = ($res->is_error) ? '' : $parser->parse($res->content);
SKIP: {
skip "Server response was error, cannot test", 1 unless $res;
$list = $res->value->value;
- is(scalar(@$list), 0, 'system.listMethods("nomatch") return list correct');
+ 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
@@ -411,8 +430,15 @@ $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');
- is($res->value->value, $meth->{help},
- 'system.methodHelp("system.identity") test');
+ 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
@@ -435,10 +461,17 @@ alarm(0);
$res = ($res->is_error) ? '' : $parser->parse($res->content);
SKIP: {
skip "Server response was error, cannot test", 1 unless $res;
- 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 ($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
@@ -486,11 +519,18 @@ $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');
- is(join('',
- sort map { join(' ', @$_) }
- @{ ref($res) ? $res->value->value : [] }),
- join('', sort @{ $meth->{signature} }),
- 'system.methodSignature("system.methodHelp") test');
+ 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
@@ -536,34 +576,41 @@ 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;
- $bucket = 0;
- %seen = ();
- for $res (@$list)
+ if ($res->is_fault)
{
- 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
+ fail(failmsg($res->value->string, __LINE__));
+ }
+ else
+ {
+ $list = $res->value->value;
+ $bucket = 0;
+ %seen = ();
+ for $res (@$list)
{
- # That is also a point
- $bucket++;
+ 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');
}
- ok(! $bucket, 'system.introspection passed with no errors');
}
# If the response was any kind of error, kill and re-start the server, as
@@ -588,12 +635,20 @@ 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;
- 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 ($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
@@ -6,7 +6,7 @@
use strict;
use subs qw(start_server find_port);
-use vars qw($dir $srv $bucket $child $req $port $socket $body);
+use vars qw($dir $vol $srv $bucket $child $req $port $socket $body);
use File::Spec;
use Test::More tests => 2;
@@ -17,7 +17,8 @@ use HTTP::Request;
require RPC::XML::Server;
require IO::Socket;
-(undef, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0));
+($vol, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0));
+$dir = File::Spec->catpath($vol, $dir, '');
require File::Spec->catfile($dir, 'util.pl');
{
@@ -1,10 +1,9 @@
#!/usr/bin/perl
-# $Id$
# Test the RPC::XML::Client class
use strict;
-use vars qw($dir $srv $child $port $cli $res $flag);
+use vars qw($dir $vol $srv $child $port $cli $res $flag);
use subs qw(start_server find_port);
use Test::More;
@@ -15,7 +14,8 @@ require File::Spec;
require RPC::XML::Server;
require RPC::XML::Client;
-(undef, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0));
+($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 => 27;
@@ -31,11 +31,12 @@ plan tests => 27;
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::ERRPR');
+ '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');
@@ -7,6 +7,8 @@ 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:
@@ -77,10 +79,10 @@ sub clear
my ($pkg, $file, $name) = @_;
delete $INC{$file};
- %{"${pkg}::"} = ();
+ delete_package($pkg);
if ($pkg eq 'Compress::Zlib')
{
- delete @Zlib::OldDeflate::{qw(deflate flush)};
- delete $Zlib::OldInflate::{'inflate'};
+ delete_package 'Zlib::OldDeflate';
+ delete_package 'Zlib::OldInflate';
}
-}
\ No newline at end of file
+}
@@ -52,4 +52,30 @@ sub find_port
-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;