RPC-XML-0.82/0000755000175000017500000000000013775375652011611 5ustar rjrayrjrayRPC-XML-0.82/README.apache20000644000175000017500000000102011356231360013740 0ustar rjrayrjrayNote: At present, this package does not work with Apache2 and the soon-to-be mod_perl2. The changes to the API for location handlers are too drastic to try and support both within the same class (I tried, using the compatibility layer). Also, mp2 does not currently provide support for sections, which are the real strength of the Apache::RPC::Server class. As time permits, and the Apache2/mod_perl2 API develops, I intend to have versions of both Apache::RPC::Server and Apache::RPC::Status for that platform. Randy RPC-XML-0.82/ex/0000755000175000017500000000000013775375652012225 5ustar rjrayrjrayRPC-XML-0.82/ex/linux.proc.cpuinfo.base0000644000175000017500000000023211356231360016575 0ustar rjrayrjrayName: linux.proc.cpuinfo Type: procedure Version: 1.0 Hidden: no Signature: struct Helpfile: linux.proc.cpuinfo.help Codefile: linux.proc.cpuinfo.code RPC-XML-0.82/ex/linux.proc.meminfo.code0000644000175000017500000000227211356231360016572 0ustar rjrayrjray############################################################################### # # Sub Name: linux_proc_meminfo # # Description: Read the /proc/meminfo on a Linux server and return a # STRUCT with the information. # # Arguments: None. # # Returns: hashref # ############################################################################### sub linux_proc_meminfo { use strict; my (%meminfo, $line, $key, @parts); local *F; open(F, '/proc/meminfo') or return RPC::XML::fault->new(501, "Cannot open /proc/meminfo: $!"); while (defined($line = )) { next if ($line =~ /^\s+/); chomp $line; @parts = split(/\s+/, $line); $key = shift(@parts); if ($key eq 'Mem:') { @meminfo{qw(mem_total mem_used mem_free mem_shared mem_buffers mem_cached)} = @parts; } elsif ($key eq 'Swap:') { @meminfo{qw(swap_total swap_used swap_free)} = @parts; } else { chop $key; # Lose the trailing ':' $meminfo{$key} = join(' ', @parts); } } close(F); \%meminfo; } RPC-XML-0.82/ex/linux.proc.cpuinfo.code0000644000175000017500000000156211356231360016604 0ustar rjrayrjray############################################################################### # # Sub Name: linux_proc_cpuinfo # # Description: Read the /proc/cpuinfo on a Linux server and return a # STRUCT with the information. # # Arguments: None. # # Returns: hashref # ############################################################################### sub linux_proc_sysinfo { use strict; my (%cpuinfo, $line, $key, $value); local *F; open(F, '/proc/cpuinfo') or return RPC::XML::fault->new(501, "Cannot open /proc/cpuinfo: $!"); while (defined($line = )) { chomp $line; next if ($line =~ /^\s*$/); ($key, $value) = split(/\s+:\s+/, $line, 2); $key =~ s/ /_/g; $cpuinfo{$key} = ($key eq 'flags') ? [ split(/ /, $value) ] : $value; } close(F); \%cpuinfo; } RPC-XML-0.82/ex/README0000644000175000017500000000041011356231360013054 0ustar rjrayrjrayThese are some samples of methods that a server might offer. They are only meant for illustrative purposes. Create the *.xpl files by running "make" in this directory. The resulting *.xpl files may then be copied to a directory that the server knows to read from. RPC-XML-0.82/ex/Makefile0000644000175000017500000000041111356231360013635 0ustar rjrayrjray# Simple makefile to create method files from the inputs MAKEMETHOD := make_method METHODS := linux.proc.cpuinfo linux.proc.meminfo XPL_FILES := $(METHODS:=.xpl) %.xpl : %.code %.help %.base $(MAKEMETHOD) --base=$* all: $(XPL_FILES) clean: rm -f $(XPL_FILES) RPC-XML-0.82/ex/linux.proc.cpuinfo.help0000644000175000017500000000047111356231360016620 0ustar rjrayrjrayRead the system's "/proc/cpuinfo" special file and return the information in the form of a STRUCT with the members based on the lines returned from the "file". All values are either INT or STRING, based on the disposition of the data itself. The exception to this is the key "flags", which is an ARRAY of STRING. RPC-XML-0.82/ex/linux.proc.meminfo.base0000644000175000017500000000023211356231360016564 0ustar rjrayrjrayName: linux.proc.meminfo Type: procedure Version: 1.0 Hidden: no Signature: struct Helpfile: linux.proc.meminfo.help Codefile: linux.proc.meminfo.code RPC-XML-0.82/ex/linux.proc.meminfo.help0000644000175000017500000000156211356231360016611 0ustar rjrayrjrayRead the system's "/proc/meminfo" special file and return the information in the form of a STRUCT with the following members: Key Type Value mem_total INT Total memory available, in bytes mem_used INT Total memory currently used, in bytes mem_free INT Memory remaining, in bytes mem_shared INT Memory being shared between processes, in bytes mem_buffers INT Number of memory buffers mem_cached INT Cached memory MemTotal STRING Total memory, in kB MemFree STRING Free memory, in kB MemShared STRING Shared memort, in kB Buffers STRING Memory buffers, in kB Cached STRING Cached memory, in kB SwapTotal STRING Total swap memory, in kB SwapFree STRING Available swap memory, in kB RPC-XML-0.82/Makefile.PL0000644000175000017500000001020113775374047013552 0ustar rjrayrjray#!/usr/bin/perl ############################################################################### # # This is the MakeMaker skeleton for the RPC-XML extension. Besides the usual # tricks, this has to add rules to make the *.xpl files from *.code in the # methods/ subdir, as well as get them into a place where they get installed # correctly. # ############################################################################### use 5.008008; use strict; use warnings; use ExtUtils::MakeMaker; use File::Spec; use File::Find; our $VERSION = '0.82'; my ($vol, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0)); $dir = File::Spec->catpath($vol, $dir, q{}); my $libxml_avail = eval { require XML::LibXML; 1; }; if (! $libxml_avail) { print {*STDERR} <<"END"; @@@@@ XML::LibXML not found You may ignore the warnings about XML::LibXML not being present, if you plan only to use the XML::Parser-based parsing engine. The use of XML::LibXML is optional. @@@@@ END } my $CLEAN = 'pod2html-* *.html *.spec *.rpm rpmrc rpmmacro *.log t/*.log ' . 't/*.pid META.yml META.json MYMETA.yml MYMETA.json *.ppd cover_db '; my @scripts = (File::Spec->catfile(qw(etc make_method))); $CLEAN .= File::Spec->catfile(qw(methods *.xpl)); my @PM_FILES = (); find( sub { if (-f and /[.]pm$/) { push @PM_FILES, $File::Find::name } }, 'lib' ); # Exclude Apache2 stuff until it's ready for deployment @PM_FILES = grep { ! /Apache2/ } @PM_FILES; my %PM_FILES = (); for my $file (@PM_FILES) { (my $temp = $file) =~ s/^lib/\$\(INST_LIB\)/; $PM_FILES{$file} = $temp; } # Handle the method code in "methods" specially: find( sub { if (-f and /[.]base$/) { s/[.]base$//; $PM_FILES{File::Spec->catfile('methods', "$_.xpl")} = File::Spec->catfile(qw($(INST_LIB) RPC XML), "$_.xpl"); } }, 'methods' ); # Anything stuck under "lib" is more generic find( sub { if (-f and /[.]base$/) { (my $name = $File::Find::name) =~ s/base$/xpl/; (my $tmp = $name) =~ s/^lib/\$(INST_LIB)/; $PM_FILES{$name} = $tmp; $CLEAN .= " $name"; } }, 'lib' ); WriteMakefile( NAME => 'RPC::XML', VERSION => $VERSION, AUTHOR => 'Randy J. Ray', ABSTRACT => 'Data, client and server classes for XML-RPC', EXE_FILES => \@scripts, PM => \%PM_FILES, PREREQ_PM => { 'Carp' => 0, 'Scalar::Util' => 1.55, 'HTTP::Daemon' => 6.12, 'HTTP::Message' => 6.26, 'LWP' => 6.51, 'Socket' => 0, 'XML::Parser' => 2.46, 'Module::Load' => 0.36, }, CONFIGURE_REQUIRES => { 'ExtUtils::MakeMaker' => 7.56, }, TEST_REQUIRES => { 'ExtUtils::MakeMaker' => 7.56, 'IO::Socket::IP' => 0, 'Test::More' => 1.302183, }, dist => { COMPRESS => 'gzip -9f' }, clean => { FILES => $CLEAN }, LICENSE => 'perl', MIN_PERL_VERSION => 5.008008, META_MERGE => { recommends => { 'XML::LibXML' => '2.0206', 'DateTime' => '1.54', 'DateTime::Format::ISO8601' => '0.15', }, resources => { homepage => 'http://github.com/rjray/rpc-xml', bugtracker => 'https://github.com/rjray/rpc-xml/issues', repository => 'http://github.com/rjray/rpc-xml', } }, ); sub MY::post_initialize { my $self = shift; my @text; my $makemeth = File::Spec->catfile(qw(etc make_method)); push @text, '.SUFFIXES: .xpl .base', q{}, '.base.xpl:', "\t\$(PERL) $makemeth --base=\$*", q{}; return join "\n", @text; } sub MY::postamble { my $self = shift; my @text; my $makemeth = File::Spec->catfile(qw(etc make_method)); # Create the dependancy rules for the methods/XPL files for (sort grep { /[.]xpl$/ } keys %PM_FILES) { s/[.]xpl$//; push @text, "$_.xpl: $_.base $_.help $_.code $makemeth"; } return join "\n", @text; } RPC-XML-0.82/etc/0000755000175000017500000000000013775375652012364 5ustar rjrayrjrayRPC-XML-0.82/etc/make_method0000755000175000017500000005321312713703551014553 0ustar rjrayrjray#!/usr/bin/perl ############################################################################### # # This file copyright (c) 2001-2011 Randy J. Ray, all rights reserved # # See "LICENSE AND COPYRIGHT" in the documentation for licensing and # redistribution terms. # ############################################################################### # # Description: Simple tool to turn a Perl routine and the support data # into the simple XML representation that RPC::XML::Server # understands. # # Functions: read_external # write_file # # Libraries: Config # Getopt::Long # IO::File # File::Spec # # Global Consts: $VERSION # $cmd # # Environment: None. # ############################################################################### use 5.006001; use strict; use warnings; use vars qw($USAGE $VERSION); use subs qw(read_from_file read_from_opts read_external write_file); use Config; use Carp 'croak'; use Getopt::Long; use File::Spec; my ($cmd, %opts, $ofh, %attrs); $VERSION = '1.15'; ($cmd = $0) =~ s{.*/}{}; $USAGE = "$cmd [ --options ] Where: --help Generate this message. --name Specifies the external (published) name of the method. --namespace Specify an explicit namespace for the method to be created in --type Specify whether this defines a PROCEDURE, a METHOD or a FUNCTION (case-free) --version Gives the version that should be attached to the method. --hidden Takes no value; if passed, flags the method as hidden. --signature Specifies one method signature. May be specified more than once. --helptext Provides the help string. --helpfile Gives the name of a file from which the help-text is read. --code Gives the name of the file from which to read the code. --output Name of the file to write the resulting XML to. --base If passed, this is used as a base-name from which to derive all the other information. The file .base must exist and be readable. That file will provide the information for the method, some of which may point to other files to be read. When done, the output is written to .xpl. If --base is specified, all other options are ignored, and any missing information (such as no signatures, etc.) will cause an error. "; GetOptions(\%opts, qw(help base=s name=s namespace=s type=s version=s hidden signature=s@ helptext=s helpfile=s code=s output=s)) or croak "$USAGE\n\nStopped"; if ($opts{help}) { print $USAGE; exit 0; } # First we start by getting all our data. Once that's all in place, then the # generation of the file is simple. if ($opts{base}) { read_from_file($opts{base}); $ofh = "$opts{base}.xpl"; } else { read_from_opts(); if ($opts{output}) { $ofh = $opts{output}; } else { $ofh = \*STDOUT; } } write_file( $ofh, { name => $attrs{name}, namespace => $attrs{namespace}, type => $attrs{type}, version => $attrs{version}, hidden => $attrs{hidden}, code => $attrs{codetxt}, help => $attrs{helptxt}, sigs => $attrs{siglist}, } ); exit 0; ############################################################################### # # Sub Name: read_from_file # # Description: Read method data from the given *.base file # # Arguments: NAME IN/OUT TYPE DESCRIPTION # $file in scalar File to read, minus the ".base" # # Globals: %attrs # # Returns: Success: void # Failure: croaks # ############################################################################### sub read_from_file { my $file = shift; my ($volume, $path) = File::Spec->splitpath($file); $path ||= q{.}; $attrs{type} = 'm'; # Default the type to 'm'ethod. $attrs{codetxt} = {}; $attrs{siglist} = []; $attrs{namespace} = q{}; $attrs{hidden} = 0; $attrs{version} = q{}; my @lines; if (open my $fh, '<', "$file.base") { @lines = <$fh>; close $fh or croak "Error closing $file.base: $!\nStopped"; } else { croak "Error opening $file.base for reading: $!\nStopped"; } for my $line (@lines) { chomp $line; # Skip blanks and comments next if ($line =~ /^\s*(?:#.*)?$/); # I'm using a horrendous if-else cascade to avoid moving the required # version of Perl to 5.012 just for the "when" construct. ## no critic (ProhibitCascadingIfElse) if ($line =~ /^name:\s+([\w.]+)$/i) { $attrs{name} = $1; } elsif ($line =~ /^namespace:\s+([\w.]+)$/i) { $attrs{namespace} = $1; } elsif ($line =~ /^type:\s+(\S+)$/i) { $attrs{type} = substr lc $1, 0, 1; } elsif ($line =~ /^version:\s+(\S+)$/i) { $attrs{version} = $1; } elsif ($line =~ /^signature:\s+\b(.*)$/i) { push @{$attrs{siglist}}, $1; } elsif ($line =~ /^hidden:\s+(no|yes)/i) { $attrs{hidden} = (lc $1 eq 'yes') ? 1 : 0; } elsif ($line =~ /^helpfile:\s+(.*)/i) { $attrs{helptxt} = read_external(File::Spec->catpath($volume, $path, $1)); } elsif ($line =~ /^codefile(?:\[(.*)\])?:\s+(.*)/i) { $attrs{codetxt}->{$1 || 'perl'} = read_external(File::Spec->catpath($volume, $path, $2)); } } if (! keys %{$attrs{codetxt}}) { croak "Error: no code specified in $opts{base}.base, stopped"; } if (! @{$attrs{siglist}}) { croak "Error: no signatures found in $opts{base}.base, stopped"; } return; } ############################################################################### # # Sub Name: read_from_opts # # Description: Read method data from the command-line options # # Arguments: None. # # Globals: %opts # %attrs # # Returns: Success: void # Failure: croaks # ############################################################################### sub read_from_opts { $attrs{siglist} = []; if ($opts{name}) { $attrs{name} = $opts{name}; } else { croak 'No name was specified for the published routine, stopped'; } $attrs{namespace} = $opts{namespace} || q{}; $attrs{type} = $opts{type} || 'm'; $attrs{hidden} = $opts{hidden} || 0; $attrs{version} = $opts{version} || q{}; if ($opts{signature}) { for my $val (@{$opts{signature}}) { $val =~ s/:/ /g; push @{$attrs{siglist}}, $val; } } else { croak "At least one signature must be specified for $attrs{name}, " . 'stopped'; } if ($opts{helptext}) { $attrs{helptxt} = \"$opts{helptext}\n"; } elsif ($opts{helpfile}) { $attrs{helptxt} = read_external($opts{helpfile}); } else { $attrs{helptxt} = \q{}; } if ($opts{code}) { $attrs{codetxt}->{perl} = read_external($opts{code}); } else { $attrs{codetxt}->{perl} = do { local $/ = undef; <> }; } return; } ############################################################################### # # Sub Name: read_external # # Description: Simple snippet to read in an external file and return the # results as a ref-to-scalar # # Arguments: NAME IN/OUT TYPE DESCRIPTION # $file in scalar File to open and read # # Returns: Success: scalar ref # Failure: dies # ############################################################################### sub read_external { my $file = shift; my ($fh, $content); if (! open $fh, '<', $file) { croak "Cannot open file $file for reading: $!, stopped"; } else { $content = do { local $/ = undef; <$fh> }; close $fh or croak "Error closing $file: $!, stopped"; } return \$content; } ############################################################################### # # Sub Name: write_file # # Description: Write the XML file that will describe a publishable method # # Arguments: NAME IN/OUT TYPE DESCRIPTION # $fh in IO Filehandle to write to # $args in hashref Hashref of arguments # # Globals: $cmd # $VERSION # # Environment: None. # # Returns: void # ############################################################################### sub write_file { my ($fh, $args) = @_; # Might need to open a FH here, and keep it open for a while. ## no critic (RequireBriefOpen) if (! ref $fh) { if (! open my $newfh, '>', $fh) { croak "Error opening $fh for writing: $!, stopped"; } else { $fh = $newfh; } } my %typemap = ( 'm' => 'method', p => 'procedure', f => 'function', ); my $tag = "$typemap{$args->{type}}def"; # Armor against XML confusion foreach (qw(name namespace version help)) { $args->{$_} =~ s/&/&/g; $args->{$_} =~ s/{$_} =~ s/>/>/g; } for (keys %{$args->{code}}) { if (($_ eq 'perl') and (index(${$args->{code}->{$_}}, ']]>') == -1) and (index(${$args->{code}->{$_}}, '__END__') == -1)) { ${$args->{code}->{$_}} = "{code}->{$_}}\n" . "__END__\n]]>"; } else { ${$args->{code}->{$_}} =~ s/&/&/g; ${$args->{code}->{$_}} =~ s/{code}->{$_}} =~ s/>/>/g; } } print {$fh} <<"EO_HDR"; <$tag> EO_HDR print {$fh} "$args->{name}\n"; if ($args->{namespace}) { print {$fh} "$args->{namespace}\n"; } if ($args->{version}) { print {$fh} "$args->{version}\n"; } if ($args->{hidden}) { print {$fh} "\n"; } print {$fh} map { "$_\n" } @{$args->{sigs}}; if ($args->{help}) { print {$fh} "\n${$args->{help}}\n"; } for (sort keys %{$args->{code}}) { print {$fh} qq{\n${$args->{code}->{$_}}\n}; } print {$fh} "\n"; return; } __END__ =head1 NAME make_method - Turn Perl code into an XML description for RPC::XML::Server =head1 SYNOPSIS make_method --name=system.identification --helptext='System ID string' --signature=string --code=ident.pl --output=ident.xpl make_method --base=methods/identification =head1 DESCRIPTION This is a simple tool to create the XML descriptive files for specifying methods to be published by an B-based server. If a server is written such that the methods it exports (or I) are a part of the running code, then there is no need for this tool. However, in cases where the server may be separate and distinct from the code (such as an Apache-based RPC server), specifying the routines and filling in the supporting information can be cumbersome. One solution that the B package offers is the means to load publishable code from an external file. The file is in a simple XML dialect that clearly delinates the externally-visible name, the method signatures, the help text and the code itself. These files may be created manually, or this tool may be used as an aide. =head1 REQUIRED ARGUMENTS There are no required arguments, but if there are not sufficient options passed you will be told by an error message. =head1 OPTIONS The tool recognizes the following options: =over 4 =item --help Prints a short summary of the options. =item --name=STRING Specifies the published name of the method being encoded. This is the name by which it will be visible to clients of the server. =item --namespace=STRING Specifies a namespace that the code of the method will be evaluated in, when the XPL file is loaded by a server instance. =item --type=STRING Specify the type for the resulting file. "Type" here refers to whether the container tag used in the resulting XML will specify a B or a B. The default is B. The string is treated case-independant, and only the first character (C or C

) is actually regarded. =item --version=STRING Specify a version stamp for the code routine. =item --hidden If this is passe, the resulting file will include a tag that tells the server daemon to not make the routine visible through any introspection interfaces. =item --signature=STRING [ --signature=STRING ... ] Specify one or more signatures for the method. Signatures should be the type names as laid out in the documentation in L, with the elements separated by a colon. You may also separate them with spaces, if you quote the argument. This option may be specified more than once, as some methods may have several signatures. =item --helptext=STRING Specify the help text for the method as a simple string on the command line. Not suited for terribly long help strings. =item --helpfile=FILE Read the help text for the method from the file specified. =item --code=FILE Read the actual code for the routine from the file specified. If this option is not given, the code is read from the standard input file descriptor. =item --output=FILE Write the resulting XML representation to the specified file. If this option is not given, then the output goes to the standard output file descriptor. =item --base=NAME This is a special, "all-in-one" option. If passed, all other options are ignored. The value is used as the base element for reading information from a file named B.base. This file will contain specification of the name, version, hidden status, signatures and other method information. Each line of the file should look like one of the following: =over 4 =item B> Specify the name of the routine being published. If this line does not appear, then the value of the B<--base> argument with all directory elements removed will be used. =item B> Provide a version stamp for the function. If no line matching this pattern is present, no version tag will be written. =item B> If present, I should be either C or C (case not important). If it is C, then the method is marked to be hidden from any introspection API. =item B> This line may appear more than once, and is treated cumulatively. Other options override previous values if they appear more than once. The portion following the C part is taken to be a published signature for the method, with elements separated by whitespace. Each method must have at least one signature, so a lack of any will cause an error. =item B> Specifies the file from which to read the help text. It is not an error if no help text is specified. =item B> Specifies the file from which to read the code. Code is assumed to be Perl, and will be tagged as such in the resulting file. =item B> Specifies the file from which to read code, while also identifying the language that the code is in. This allows for the creation of a B file that includes multiple language implementations of the given method or procedure. =back Any other lines than the above patterns are ignored. If no code has been read, then the tool will exit with an error message. The output is written to B.xpl, preserving the path information so that the resulting file is right alongside the source files. This allows constructs such as: make_method --base=methods/introspection =back =head1 FILE FORMAT AND DTD The file format for these published routines is a very simple XML dialect. This is less due to XML being an ideal format than it is the availability of the parser, given that the B class will already have the parser code in core. Writing a completely new format would not have gained anything. The Document Type Declaration for the format can be summarized by: The file C that comes with the distribution has some commentary in addition to the actual specification. A file is (for now) limited to one definition. This is started by the one of the opening tags CmethoddefE>, CfunctiondefE> or CproceduredefE>. This is followed by exactly one CnameE> container specifying the method name, an optional version stamp, an optional hide-from-introspection flag, one or more CsignatureE> containers specifying signatures, an optional ChelpE> container with the help text, then the CcodeE> container with the actual program code. All text should use entity encoding for the symbols: & C<&> (ampersand) E C<<> (less-than) E C<>> (greater-than) The parsing process within the server class will decode the entities. To make things easier, the tool scans all text elements and encodes the above entities before writing the file. =head2 The Specification of Code This is not I<"Programming 101">, nor is it I<"Perl for the Somewhat Dim">. The code that is passed in via one of the C<*.xpl> files gets passed to C with next to no modification (see below). Thus, badly-written or malicious code can very well wreak havoc on your server. This is not the fault of the server code. The price of the flexibility this system offers is the responsibility on the part of the developer to ensure that the code is tested and safe. Code itself is treated as verbatim as possible. Some edits may occur on the server-side, as it make the code suitable for creating an anonymous subroutine from. The B tool will attempt to use a C section to embed the code within the XML document, so that there is no need to encode entities or such. This allows for the resulting F<*.xpl> files to be syntax-testable with C. You can aid this by ensuring that the code does not contain either of the two following character sequences: ]]> __DATA__ The first is the C terminator. If it occurs naturally in the code, it would trigger the end-of-section in the parser. The second is the familiar Perl token, which is inserted so that the remainder of the XML document does not clutter up the Perl parser. =head1 EXAMPLES The B distribution comes with a number of default methods in a subdirectory called (cryptically enough) C. Each of these is expressed as a set of (C<*.base>, C<*.code>, C<*.help>) files. The Makefile.PL file configures the resulting Makefile such that these are used to create C<*.xpl> files using this tool, and then install them. =head1 DIAGNOSTICS Most problems come out in the form of error messages followed by an abrupt exit. =head1 EXIT STATUS The tool exits with a status of 0 upon success, and 255 otherwise. =head1 CAVEATS I don't much like this approach to specifying the methods, but I liked my other ideas even less. =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. 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 =item * AnnoCPAN: Annotated CPAN documentation L =item * CPAN Ratings L =item * Search CPAN L =item * Source code on GitHub L =back =head1 LICENSE AND COPYRIGHT This module and the code within are released under the terms of the Artistic License 2.0 (http://www.opensource.org/licenses/artistic-license-2.0.php). This code may be redistributed under either the Artistic License or the GNU Lesser General Public License (LGPL) version 2.1 (http://www.opensource.org/licenses/lgpl-2.1.php). =head1 SEE ALSO L, L =head1 CREDITS The B standard is Copyright (c) 1998-2001, UserLand Software, Inc. See for more information about the B specification. =head1 AUTHOR Randy J. Ray =cut RPC-XML-0.82/etc/rpc-method.dtd0000644000175000017500000000276211356231360015106 0ustar rjrayrjray RPC-XML-0.82/MANIFEST0000644000175000017500000000633113775375652012745 0ustar rjrayrjrayChangeLog # Ch-ch-ch-changes ChangeLog.xml # See my swanky new XML format! MANIFEST # This file Makefile.PL # MakeMaker skeleton README # Overview README.apache2 # Notes on Apache2 and mod_perl2 etc/make_method # Tool to create *.xpl files etc/rpc-method.dtd # DTD for the *.xpl file structure ex/linux.proc.meminfo.base # Base/help/code files for the sample methods ex/linux.proc.meminfo.code # in the ex/ directory ex/linux.proc.meminfo.help ex/linux.proc.cpuinfo.base ex/linux.proc.cpuinfo.code ex/linux.proc.cpuinfo.help ex/README # Description of the contents of the ex/ dir ex/Makefile # Makefile to generate *.xpl files in ex/ lib/Apache/RPC/Server.pm # Apache-centric server implementation lib/Apache/RPC/Status.pm # Apache::Status for Apache::RPC::Server data lib/Apache/RPC/status.base # Apache version of the system.status method lib/Apache/RPC/status.code lib/Apache/RPC/status.help lib/RPC/XML.pm # Base data-type manipuation, etc. lib/RPC/XML/Client.pm # Basic client class lib/RPC/XML/Parser.pm # Parser base class lib/RPC/XML/Parser/XMLParser.pm # Parser implementation class (XML::Parser) lib/RPC/XML/Parser/XMLLibXML.pm # Parser implementation class (XML::LibXML) lib/RPC/XML/ParserFactory.pm # Parser factory-class lib/RPC/XML/Procedure.pm # Class encapsulation of RPC procedures lib/RPC/XML/Server.pm # Basic server class methods/identity.base # Everything under method/ is template for the methods/identity.code # etc/make_method tool to create *.xpl files. methods/identity.help methods/introspection.base methods/introspection.code methods/introspection.help methods/listMethods.base methods/listMethods.code methods/listMethods.help methods/methodHelp.base methods/methodHelp.code methods/methodHelp.help methods/methodSignature.base methods/methodSignature.code methods/methodSignature.help methods/multicall.base methods/multicall.code methods/multicall.help methods/status.base methods/status.code methods/status.help perlcritic.rc # Perl::Critic configuration for tests t/00_load.t # Test suites t/10_data.t t/11_base64_fh.t t/12_nil.t t/13_no_deep_recursion.t t/14_datetime_iso8601.t t/15_serialize.t t/20_xml_parser.t t/21_xml_libxml.t t/25_parser_negative.t t/29_parserfactory.t t/30_procedure.t t/35_namespaces.t t/40_server.t t/40_server_xmllibxml.t t/41_server_hang.t t/50_client.t t/51_client_with_host_header.t t/60_net_server.t t/70_compression_detect.t t/90_rt50013_parser_bugs.t t/90_rt54183_sigpipe.t t/90_rt54494_blessed_refs.t t/90_rt58065_allow_nil.t t/90_rt58323_push_parser.t t/BadParserClass.pm t/meth_bad_1.xpl t/meth_bad_2.xpl t/meth_good_1.xpl t/meth_good_2.xpl t/meth_good_3.xpl t/namespace1.xpl t/namespace2.xpl t/namespace3.xpl t/svsm_text.b64 t/svsm_text.gif t/util.pl xt/01_pod.t xt/02_pod_coverage.t xt/03_meta.t xt/04_minimumversion.t xt/05_critic.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) RPC-XML-0.82/t/0000755000175000017500000000000013775375652012054 5ustar rjrayrjrayRPC-XML-0.82/t/meth_bad_1.xpl0000644000175000017500000000146511356231360014546 0ustar rjrayrjray system.identity 1.0 Return the server name and version as a string ############################################################################### # # Sub Name: identity # # Description: Simply returns the server's identity as a string # # Arguments: First arg is server instance # # Globals: None. # # Returns: string # ############################################################################### sub identity { use strict; sprintf('%s/%s', ref($_[0]), $_[0]->version); } RPC-XML-0.82/t/29_parserfactory.t0000644000175000017500000001164613774651431015436 0ustar rjrayrjray#!/usr/bin/env perl # Test the RPC::XML::ParserFactory class ## no critic(RequireInterpolationOfMetachars) ## no critic(ProhibitStringyEval) ## no critic(RequireCheckingReturnValueOfEval) use strict; use warnings; use Module::Load; use Test::More; use File::Spec; use RPC::XML ':all'; use RPC::XML::ParserFactory; plan tests => 38; my ($req, $res, $ret, $ns, $dir, $vol, %aliases, %parsers); # This one will be referenced from outside of main::, so it has to be visible: our $p; ## no critic(ProhibitPackageVars) ($vol, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0)); $dir = File::Spec->catpath($vol, $dir, q{}); unshift @INC, $dir; %parsers = ( 'XML::Parser' => 1, ); # See if we should run tests dependent on XML::LibXML if (eval { load XML::LibXML; 1; }) { $parsers{'XML::LibXML'} = 1; } # The organization of the test suites is such that we assume anything that # runs before the current suite is 100%. Thus, no consistency checks on # RPC::XML::* classes, RPC::XML::Parser::XMLParser or any of the other # parser-instance classes that are currently part of the distro. # First let's squeeze in a negative test, to see what happens when an attempt # to load a valid parser fails unshift @INC, sub { die "Force-failing RPC::XML::Parser::XMLParser\n" if ($_[1] eq 'RPC/XML/Parser/XMLParser.pm'); return; }; $p = RPC::XML::ParserFactory->new(class => 'XML::Parser'); ok(! $p, 'Factory correctly failed when it could not load parser class'); like($RPC::XML::ERROR, qr/loading RPC::XML::Parser::XMLParser/, 'Correct error message'); # Now clear out that pesky closure so the rest of the tests succeed shift @INC; # Now start by testing with the XML::Parser wrapper, since that is the only one # that is "required" (for now). $p = RPC::XML::ParserFactory->new(); isa_ok($p, 'RPC::XML::Parser', '$p'); isa_ok($p, 'RPC::XML::Parser::XMLParser', '$p'); $req = RPC::XML::request->new('test.method'); $ret = $p->parse($req->as_string); isa_ok($ret, 'RPC::XML::request', '$ret'); is($ret->name, 'test.method', 'Correct request method name'); $res = RPC::XML::response->new(RPC::XML::string->new('test response')); $ret = $p->parse($res->as_string); isa_ok($ret, 'RPC::XML::response', '$ret'); is($ret->value->value, 'test response', 'Response value'); # Test some badly-formed data my $tmp = $res->as_string; $tmp =~ s/methodResponse/mR/g; $ret = $p->parse($tmp); ok(!ref($ret), 'Bad XML did not parse'); like($ret, qr/Unknown tag/, 'Parse failure returned error'); # For all the evals, to avoid namespace pollution, we'll keep incrementing # this... $ns = 'namespace0000'; %aliases = ( 'XML::Parser' => [ qw(XML::Parser xml::parser xmlparser) ], 'XML::LibXML' => [ qw(XML::LibXML xml::libxml xmllibxml) ], ); # Test with the various aliases for XML::Parser for my $alias (@{$aliases{'XML::Parser'}}) { $ns++; undef $p; eval <<"END_OF_EVAL"; { package $ns; use RPC::XML::ParserFactory (class => '$alias'); \$main::p = RPC::XML::ParserFactory->new(); } END_OF_EVAL isa_ok($p, 'RPC::XML::Parser', "Alias $alias: \$p"); isa_ok($p, 'RPC::XML::Parser::XMLParser', "Alias $alias: \$p"); } # The non-xmlparser parsers are all optional, so skip their sets if the # parser isn't in the config: for my $parser (qw(XML::LibXML)) { (my $factory_class = $parser) =~ s/:://g; $factory_class = "RPC::XML::Parser::$factory_class"; SKIP: { if (! $parsers{$parser}) { skip "$parser not detected, tests skipped", 6; } for my $alias (@{$aliases{$parser}}) { $ns++; undef $p; eval <<"END_OF_EVAL"; { package $ns; use RPC::XML::ParserFactory qw($alias); \$main::p = RPC::XML::ParserFactory->new(); } END_OF_EVAL isa_ok($p, 'RPC::XML::Parser', "Alias $alias: \$p"); isa_ok($p, $factory_class, "Alias $alias: \$p"); } } } # This block makes sure that we can new() a parser with a specific alias for my $parser (qw(XML::Parser XML::LibXML)) { (my $factory_class = $parser) =~ s/:://g; $factory_class = "RPC::XML::Parser::$factory_class"; SKIP: { if (! $parsers{$parser}) { skip "$parser not detected, tests skipped", 6; } for my $alias (@{$aliases{$parser}}) { $p = RPC::XML::ParserFactory->new(class => $alias); isa_ok($p, 'RPC::XML::Parser', "New'ing $alias: \$p"); isa_ok($p, $factory_class, "New'ing $alias: \$p"); } } } # Some negative tests $p = RPC::XML::ParserFactory->new(class => 'DoesNotExist'); ok(! $p, 'Factory-new fails with bad class argument'); like($RPC::XML::ERROR, qr/Error loading DoesNotExist/, 'Correct error message'); $p = RPC::XML::ParserFactory->new(class => 'BadParserClass'); ok(! $p, 'Factory-new fails with a bad parser class'); like($RPC::XML::ERROR, qr/is not a sub-class of/, 'Correct error message'); exit 0; RPC-XML-0.82/t/meth_good_3.xpl0000644000175000017500000000041111622765353014752 0ustar rjrayrjray test.rpc.xml.function 1.0 Simple test method for RPC::XML::Function class sub test { $_[0] } RPC-XML-0.82/t/svsm_text.gif0000644000175000017500000000341111356231360014552 0ustar rjrayrjrayGIF89acUUU999rrr!,cȉ8ͻ`(dVlpG @] IfD쓀-v9̱f kDɮWvg{=®Fuqk3@yAYD`ӃQrwuods@.n5p/t$[;r&;R]Nvjw,o~+!WLKL}># 6ɥP;Mï-gs Imgl6؉79F%v<`c]a,ě@6*R  |,@x_b"u'#x>[ 6AP ?AZ\3KcB@A_:d!  Uԧ ֖j ڄCZ"{eiY1"HD4VbIr4.o<9X%wo =B' Y$HuE$ qAaW[\[ σ73%ER{1QS"Mx:]! doPdh08a%Ip@ALx/@^=W2p.n H]c ]Wqne3ǡ;cQd#dbEX gQ$e.IHu/]y^J#kvELV"< C\\r49Rid闖Vu&GHTZEx*pFBwz*tLj&!{W`=h+ v_|rAIh14)%Q[irJPOȅf G]}h$MVcAavmGj"XCqNN8|m{/ڎiSFRoU91YBNt$XZ]\gJJA۬Mac$Q31P37w8ϢuywTd׊Z3u״Z($Pcmq48ol^7M冾/EwM "3$ wLHK@]ZuL)$)V>j=DjJ9*m.J{jI!NR޴F^2ەb Hj^'[::@DG=dSKD$B4YiHM3P-2GSj *\9IOY98>FPڻ' UAu*-DvEp+\ 2Oxͫ^$ `KػʰMbXd' WOl;RPC-XML-0.82/t/21_xml_libxml.t0000644000175000017500000004044613774651431014711 0ustar rjrayrjray#!/usr/bin/env perl # Test the RPC::XML::Parser::XMLLibXML class ## no critic(RequireInterpolationOfMetachars) ## no critic(RequireBriefOpen) ## no critic(RequireCheckedClose) use strict; use warnings; use Carp qw(carp croak); use Module::Load; use Test::More; use File::Spec; use RPC::XML ':all'; my ($p, $req, $res, $str, $badstr, $ret, $dir, $vol, $file, $fh); if (! eval { load XML::LibXML; 1; }) { plan skip_all => 'XML::LibXML not installed'; } else { load RPC::XML::Parser::XMLLibXML; plan tests => 110; } ($vol, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0)); $dir = File::Spec->catpath($vol, $dir, q{}); $file = File::Spec->catfile($dir, 'svsm_text.gif'); # The organization of the test suites is such that we assume anything that # runs before the current suite is 100%. Thus, no consistency checks on # RPC::XML::* classes are done, only on the data and return values of this # class under consideration, RPC::XML::Parser::XMLLibXML. $p = RPC::XML::Parser::XMLLibXML->new(); isa_ok($p, 'RPC::XML::Parser::XMLLibXML', '$p'); isa_ok($p, 'RPC::XML::Parser', '$p'); $req = RPC::XML::request->new('test.method'); $ret = $p->parse($req->as_string); isa_ok($ret, 'RPC::XML::request', '$ret'); is($ret->name, 'test.method', 'Correct request method name'); $res = RPC::XML::response->new(RPC::XML::string->new('test response')); $ret = $p->parse($res->as_string); isa_ok($ret, 'RPC::XML::response', '$ret'); is($ret->value->value, 'test response', 'Response value'); # Test some badly-formed data my $tmp = $res->as_string; $tmp =~ s/methodResponse/mR/g; $ret = $p->parse($tmp); ok(! ref($ret), 'Bad XML did not parse'); like($ret, qr/Unknown tag/, 'Parse failure returned error'); # Test parsing of faults $res = RPC::XML::response->new(RPC::XML::fault->new(1, 'foo')); $ret = $p->parse($res->as_string); isa_ok($ret, 'RPC::XML::response', 'fault parsing: $ret'); isa_ok($ret->value, 'RPC::XML::fault', 'fault parsing: $ret->value'); is($ret->value->code, 1, 'fault parsing: correct code value'); is($ret->value->string, 'foo', 'fault parsing: correct string value'); # Make sure that the parser can handle all of the core data-types. Easiest way # to do this is to create a fake request with a parameter of each type (except # base64, which is getting exercised later on). $req = RPC::XML::request->new( 'parserTest', RPC::XML::i4->new(1), RPC::XML::int->new(2), RPC::XML::i8->new(3), RPC::XML::double->new(4.5), RPC::XML::string->new('string'), RPC::XML::boolean->new('true'), RPC::XML::datetime_iso8601->new('2008-09-29T12:00:00-07:00'), [ 0, 1 ], # Array, auto-encoded { a => 1, b => 2 }, # Hash/struct, also auto-encoded ); $ret = $p->parse($req->as_string); isa_ok($ret, 'RPC::XML::request', 'Parse of RPC::XML::request block'); SKIP: { if (ref($ret) ne 'RPC::XML::request') { skip 'RPC::XML::request object not properly parsed, cannot test.', 20; } is($ret->name, 'parserTest', 'Properly parsed /methodCall/methodName'); my $args = $ret->args; is(scalar @{$args}, 9, 'Parser created correct-length args list'); # I could (and should) probably turn this into a loop with a table of # data, but I'm lazy right this moment. isa_ok($args->[0], 'RPC::XML::i4', 'Parse of argument'); is($args->[0]->value, 1, 'RPC::XML::i4 value parsed OK'); isa_ok($args->[1], 'RPC::XML::int', 'Parse of argument'); is($args->[1]->value, 2, 'RPC::XML::int value parsed OK'); isa_ok($args->[2], 'RPC::XML::i8', 'Parse of argument'); is($args->[2]->value, 3, 'RPC::XML::i8 value parsed OK'); isa_ok($args->[3], 'RPC::XML::double', 'Parse of argument'); is($args->[3]->value, 4.5, 'RPC::XML::double value parsed OK'); isa_ok($args->[4], 'RPC::XML::string', 'Parse of argument'); is($args->[4]->value, 'string', 'RPC::XML::string value parsed OK'); isa_ok($args->[5], 'RPC::XML::boolean', 'Parse of argument'); ok($args->[5]->value, 'RPC::XML::boolean value parsed OK'); isa_ok($args->[6], 'RPC::XML::datetime_iso8601', 'Parse of argument'); is($args->[6]->value, '20080929T12:00:00-07:00', 'RPC::XML::dateTime.iso8601 value parsed OK'); isa_ok($args->[7], 'RPC::XML::array', 'Parse of argument'); is(scalar(@{$args->[7]->value}), 2, 'RPC::XML::array value parsed OK'); isa_ok($args->[8], 'RPC::XML::struct', 'Parse of argument'); is(scalar(keys %{$args->[8]->value}), 2, 'RPC::XML::struct value parsed OK'); } # Prior to this, we've confirmed that spooling base64 data to files works. # Here, we test whether the parser (when configured to do so) can create # filehandles as well. $p = RPC::XML::Parser::XMLLibXML->new(base64_to_fh => 1); if (! open $fh, '<', $file) { croak "Error opening $file: $!"; } my $base64 = RPC::XML::base64->new($fh); $req = RPC::XML::request->new('method', $base64); # Start testing my $spool_ret = $p->parse($req->as_string); isa_ok($spool_ret, 'RPC::XML::request', '$spool_ret'); is($spool_ret->name, 'method', 'Request, base64 spooling, method name test'); ok(ref($spool_ret->args), 'Request, base64 spooling, return arg test'); my $new_base64 = $spool_ret->args->[0]; isa_ok($new_base64, 'RPC::XML::base64', '$new_base64'); is($new_base64->as_string, $base64->as_string(), 'Parse base64 spooling, value comparison'); isa_ok($new_base64->{value_fh}, 'GLOB', '$new_base64->{value_fh}'); # Per problem reported by Bill Moseley, check that messages parsed by the # parser class handle the core entities. $tmp = q{Entity test: & < > ' "}; $res = RPC::XML::response->new($tmp); $ret = $p->parse($res->as_string); is($ret->value->value, $tmp, 'RPC::XML::Parser handles core entities'); # The variables $req and $base64 are still in scope, and should still be OK. # In fact, I should be testing this functionality in the XML::Parser suite as # well, but the server tests exercise it for that parser. # Test the push-parser functionality. my $pp = RPC::XML::Parser::XMLLibXML->new->parse(); isa_ok($pp, 'RPC::XML::Parser::XMLLibXML', 'Push-parser instance'); my $string = $req->as_string; my $string1 = substr $string, 0, int(length($string)/2); my $string2 = substr $string, int(length($string)/2); $pp->parse_more($string1); $pp->parse_more($string2); $res = $pp->parse_done(); isa_ok($res, 'RPC::XML::request', 'parse_done() return value'); my $new_b64 = $res->args->[0]; isa_ok($new_b64, 'RPC::XML::base64', 'First args value'); is($new_b64->as_string, $base64->as_string(), 'Push-parse value comparison'); SKIP: { if ($^O eq 'MSWin32') { skip '/etc/passwd is not present on windows.', 1; } my $bad_entities = <<'EOX'; ]> metaWeblog.newPost Entity test: &foo; EOX $pp = RPC::XML::Parser::XMLLibXML->new->parse(); $ret = $pp->parse($bad_entities); my $args = $ret->args; is($args->[0]->value, 'Entity test: ', 'Bad entities ignored'); } # Now test passing of various references to the parser $p = RPC::XML::Parser::XMLLibXML->new(); $str = RPC::XML::request->new('test.method')->as_string; $ret = $p->parse(\$str); isa_ok($ret, 'RPC::XML::request', '$ret from scalar reference'); ok(ref($ret) && ($ret->name eq 'test.method'), 'Correct request method name'); my $tmpfile = File::Spec->catfile($dir, "tmp_$$.xml"); SKIP: { if (! open $fh, '+>', $tmpfile) { skip "Open of $tmpfile failed, cannot test on it ($!)", 2; } print {$fh} $str; seek $fh, 0, 0; $ret = $p->parse($fh); isa_ok($ret, 'RPC::XML::request', '$ret from glob reference'); ok((ref $ret and ($ret->name eq 'test.method')), 'Correct request method name'); close $fh; unlink $tmpfile; } # Tweak the XML to test the error cases $str =~ s{}{}; $ret = $p->parse(\$str); ok(! ref $ret, '$ret error from scalar reference'); like($ret, qr/parser error/, 'Correct error message'); SKIP: { if (! open $fh, '+>', $tmpfile) { skip "Open of $tmpfile failed, cannot test on it ($!)", 2; } print {$fh} $str; seek $fh, 0, 0; $ret = $p->parse($fh); ok(! ref $ret, '$ret error from glob reference'); like($ret, qr/parser error/, 'Correct error message'); close $fh; unlink $tmpfile; } # Try an unusable reference $ret = $p->parse([]); ok(! ref $ret, 'Unusable reference did not parse to anything'); like($ret, qr/Unusable reference type/, 'Correct error message'); # Negative testing-- try to break the parser $str = RPC::XML::request->new('name', 'foo')->as_string; ($badstr = $str) =~ s/>namebad^nameparse($badstr); ok(! ref $ret, 'Bad XML <1>'); like($ret, qr/methodName value.*not a valid name/, 'Correct error message'); ($badstr = $str) =~ s{.*}{}; $ret = $p->parse($badstr); ok(! ref $ret, 'Bad XML <2>'); like($ret, qr/missing "methodName" child-element/, 'Correct error message'); ($badstr = $str) =~ s{}{}; $ret = $p->parse($badstr); ok(! ref $ret, 'Bad XML <3>'); like($ret, qr/Extra content in "methodCall"/, 'Correct error message'); ($badstr = $str) =~ s{params>}{paramss>}g; $ret = $p->parse($badstr); ok(! ref $ret, 'Bad XML <4>'); like($ret, qr/Unknown tag "paramss"/, 'Correct error message'); $str = RPC::XML::response->new(1)->as_string; ($badstr = $str) =~ s{}{}; $ret = $p->parse($badstr); ok(! ref $ret, 'Bad XML <5>'); like($ret, qr/too many child elements/, 'Correct error message'); ($badstr = $str) =~ s{}{}; $ret = $p->parse($badstr); ok(! ref $ret, 'Bad XML <6>'); like($ret, qr/too many child elements/, 'Correct error message'); ($badstr = $str) =~ s{param>}{paramm>}g; $ret = $p->parse($badstr); ok(! ref $ret, 'Bad XML <7>'); like($ret, qr/Unknown tag "paramm"/, 'Correct error message'); ($badstr = $str) =~ s{}{}; $ret = $p->parse($badstr); ok(! ref $ret, 'Bad XML <8>'); like($ret, qr/too many child elements/, 'Correct error message'); ($badstr = $str) =~ s{value>}{valuee>}g; $ret = $p->parse($badstr); ok(! ref $ret, 'Bad XML <9>'); like($ret, qr/Unknown tag "valuee"/, 'Correct error message'); ($badstr = $str) =~ s{>1<}{>foo<}; $ret = $p->parse($badstr); ok(! ref $ret, 'Bad XML <10>'); like($ret, qr/Bad integer/, 'Correct error message'); ($badstr = $str) =~ s{params}{paramss}g; $ret = $p->parse($badstr); ok(! ref $ret, 'Bad XML <11>'); like($ret, qr/Illegal tag "paramss"/, 'Correct error message'); $str = RPC::XML::response->new(RPC::XML::fault->new(1, 'foo'))->as_string; ($badstr = $str) =~ s{}{}; $ret = $p->parse($badstr); ok(! ref $ret, 'Bad XML <12>'); like($ret, qr/too many child elements/, 'Correct error message'); ($badstr = $str) =~ s{}{}; $badstr =~ s{}{}; $ret = $p->parse($badstr); ok(! ref $ret, 'Bad XML <13>'); like($ret, qr/Unknown tag "valuee"/, 'Correct error message'); # These are a little more hairy, trying to pass an invalid fault structure. # Gonna hard-code the strings rather than trying to transform $str. $badstr = <<'EO_BADSTR'; str faultString foo faultCode 1 EO_BADSTR $ret = $p->parse($badstr); ok(! ref $ret, 'Bad XML <14>'); like($ret, qr/Bad tag within struct/, 'Correct error message'); $badstr = <<'EO_BADSTR'; faultString foo faultCode 1 extraMember 1 EO_BADSTR $ret = $p->parse($badstr); ok(! ref $ret, 'Bad XML <15>'); like($ret, qr/Extra struct fields not allowed/, 'Correct error message'); $RPC::XML::ALLOW_NIL = 1; $str = RPC::XML::response->new(undef)->as_string; ($badstr = $str) =~ s{}{undef}; $ret = $p->parse($badstr); ok(! ref $ret, 'Bad XML <16>'); like($ret, qr/nil tag must be empty/, 'Correct error message'); $str = RPC::XML::request->new('foo', 1)->as_string; ($badstr = $str) =~ s{}{}; $ret = $p->parse($badstr); ok(! ref $ret, 'Bad XML <17>'); like($ret, qr/Unknown tag in params: value/, 'Correct error message'); ($badstr = $str) =~ s{}{}; $badstr =~ s{}{}; $ret = $p->parse($badstr); ok(! ref $ret, 'Bad XML <18>'); like($ret, qr/Unknown tag in param: valuee/, 'Correct error message'); ($badstr = $str) =~ s{}{1}; $ret = $p->parse($badstr); ok(! ref $ret, 'Bad XML <19>'); like($ret, qr/Too many child-nodes for value tag/, 'Correct error message'); ($badstr = $str) =~ s{1}{foo}; $ret = $p->parse($badstr); ok(! ref $ret, 'Bad XML <20>'); like($ret, qr/Bad floating-point data read/, 'Correct error message'); # Parser errors specific to arrays: $str = RPC::XML::response->new([ 1 ])->as_string; ($badstr = $str) =~ s{}{}; $ret = $p->parse($badstr); ok(! ref $ret, 'Bad XML <21>'); like($ret, qr/array tag must have just one child element/, 'Correct error message'); ($badstr = $str) =~ s{}{}; $badstr =~ s{}{}; $ret = $p->parse($badstr); ok(! ref $ret, 'Bad XML <22>'); like($ret, qr/Bad tag within array: got "valuee"/, 'Correct error message'); ($badstr = $str) =~ s{1}{foo}; $ret = $p->parse($badstr); ok(! ref $ret, 'Bad XML <23>'); like($ret, qr/Bad integer data read/, 'Correct error message'); # Parser errors specific to structs: $str = RPC::XML::response->new({ foo => 1 })->as_string; ($badstr = $str) =~ s{}{}; $ret = $p->parse($badstr); ok(! ref $ret, 'Bad XML <24>'); like($ret, qr/Wrong number of nodes within struct/, 'Correct error message'); ($badstr = $str) =~ s{name>}{namee>}g; $ret = $p->parse($badstr); ok(! ref $ret, 'Bad XML <25>'); like($ret, qr/expected tags "name" and "value"/, 'Correct error message'); ($badstr = $str) =~ s{1}{foo}; $ret = $p->parse($badstr); ok(! ref $ret, 'Bad XML <26>'); like($ret, qr/Bad integer data/, 'Correct error message'); # Test the "none of the above" error case ($badstr = $str) =~ s/struct/structt/g; $ret = $p->parse($badstr); ok(! ref $ret, 'Bad XML <27>'); like($ret, qr/Unknown tag "structt"/, 'Correct error message'); # Test some of the failures related to Base64-spooling. This can only be tested # on non-Windows systems, as to cause some of the failures we'll need to create # an un-writable directory (and Windows doesn't have the same chmod concept we # have in other places). SKIP: { if ($^O eq 'MSWin32' || $^O eq 'cygwin') { skip 'Tests involving directory permissions skipped on Windows', 1; } # Also cannot be reliably run under root: if ($< == 0) { skip 'Tests involving directory permissions skipped under root', 1; } my $baddir = File::Spec->catdir(File::Spec->tmpdir(), "baddir_$$"); if (! mkdir $baddir) { skip "Skipping, failed to create dir $baddir: $!", 1; } if (! chmod oct(600), $baddir) { skip "Skipping, failed to chmod dir $baddir: $!", 1; } $p = RPC::XML::Parser::XMLLibXML->new( base64_to_fh => 1, base64_temp_dir => $baddir ); if (! open $fh, '<', $file) { croak "Error opening $file: $!"; } my $base64fail = RPC::XML::base64->new($fh); $req = RPC::XML::request->new('method', $base64fail); $ret = $p->parse($req->as_string); like($ret, qr/Error opening temp file for base64/, 'Opening Base64 spoolfile correctly failed'); if (! rmdir $baddir) { carp "Failed to remove temp-dir $baddir: $!"; } } exit 0; RPC-XML-0.82/t/BadParserClass.pm0000644000175000017500000000014411622765353015230 0ustar rjrayrjray# This is a dummy class used only for testing RPC::XML::ParserFactory. package BadParserClass; 1; RPC-XML-0.82/t/25_parser_negative.t0000644000175000017500000000345412420753461015713 0ustar rjrayrjray#!/usr/bin/env perl # Test the RPC::XML::Parser class negative conditions ## no critic(RequireInterpolationOfMetachars) ## no critic(ProhibitMultiplePackages) use strict; use warnings; use Test::More; my ($p, $error, $retval); plan tests => 14; # Create a dummy class to use for attempts to call methods within the # RPC::XML::Parser class: package BadParser; use base 'RPC::XML::Parser'; package main; # This is the pattern we are looking for in the error messages: my $errtext = qr/should have been overridden by the BadParser class/; # First, the constructor: if (! eval { $p = BadParser->new(); 1; }) { $error = $@; } ok(! defined $p, 'RPC::XML::Parser did not instantiate'); like($error, $errtext, 'Correctly-set error message in $@'); # Fine! We'll *force* an object into that class: $p = bless {}, 'BadParser'; # *Now* try and stop me from calling methods! $retval = eval { $p->parse(); 1 }; ok(! $retval, '::parse correctly failed to run'); like($@, $errtext, 'Correctly-set error message in $@'); $retval = eval { $p->parse_more(); 1 }; ok(! $retval, '::parse_more correctly failed to run'); like($@, $errtext, 'Correctly-set error message in $@'); $retval = eval { $p->parse_done(); 1 }; ok(! $retval, '::parse_done correctly failed to run'); like($@, $errtext, 'Correctly-set error message in $@'); # Try them as static methods: $retval = eval { BadParser->parse(); 1 }; ok(! $retval, '::parse correctly failed to run'); like($@, $errtext, 'Correctly-set error message in $@'); $retval = eval { BadParser->parse_more(); 1 }; ok(! $retval, '::parse_more correctly failed to run'); like($@, $errtext, 'Correctly-set error message in $@'); $retval = eval { BadParser->parse_done(); 1 }; ok(! $retval, '::parse_done correctly failed to run'); like($@, $errtext, 'Correctly-set error message in $@'); exit; RPC-XML-0.82/t/90_rt54494_blessed_refs.t0000644000175000017500000000274313774651431016325 0ustar rjrayrjray#!/usr/bin/env perl # https://rt.cpan.org/Ticket/Display.html?id=54494 # # Test that smart_encode() in RPC::XML can correctly deal with blessed refs # by treating them as non-blessed. ## no critic(RequireInterpolationOfMetachars) use strict; use warnings; use Test::More; use RPC::XML ':all'; plan tests => 8; my ($val, $obj, $result); $val = bless { integer => 10, string => 'foo' }, 'BlessedHash'; $result = eval { $obj = smart_encode($val); 1; }; isa_ok($obj, 'RPC::XML::struct', '$obj'); SKIP: { if (ref($obj) ne 'RPC::XML::struct') { skip 'Blessed hash did not encode', 2; } my $value = $obj->value; is($value->{integer}, 10, 'Converted hash integer value'); is($value->{string}, 'foo', 'Converted hash string value'); } $val = bless [ 10, 'foo' ], 'BlessedArray'; $result = eval { $obj = smart_encode($val); 1; }; isa_ok($obj, 'RPC::XML::array', '$obj'); SKIP: { if (ref($obj) ne 'RPC::XML::array') { skip 'Blessed array did not encode', 2; } my $value = $obj->value; is($value->[0], 10, 'Converted array integer value'); is($value->[1], 'foo', 'Converted array string value'); } $val = bless \do { my $elt = 'foo' }, 'BlessedScalar'; $result = eval { $obj = smart_encode($val); 1; }; isa_ok($obj, 'RPC::XML::string', '$obj'); SKIP: { if (ref($obj) ne 'RPC::XML::string') { skip 'Blessed scalar did not encode', 1; } my $value = $obj->value; is($value, 'foo', 'Converted scalar value'); } exit; RPC-XML-0.82/t/meth_good_1.xpl0000644000175000017500000000046711622765353014763 0ustar rjrayrjray test.rpc.xml.method 1.0 string Simple test method for RPC::XML::Method class sub test { $_[1]->{method_name} } RPC-XML-0.82/t/13_no_deep_recursion.t0000644000175000017500000000341713774651431016242 0ustar rjrayrjray#!/usr/bin/env perl # Test the changes in RPC::XML to prevent infinite recursion on cyclic refs use strict; use warnings; use Test::More; use RPC::XML 'smart_encode'; my ($val, $newval, $obj); plan tests => 17; $val = [ 'a' ]; push @{$val}, $val; $obj = smart_encode($val); isa_ok($obj, 'RPC::XML::array'); $newval = $obj->value; is(scalar(@{$newval}), 1, 'Cyclical array now length 1'); is($newval->[0], 'a', 'Cyclical array kept non-cyclic element'); $obj = RPC::XML::array->new($val); isa_ok($obj, 'RPC::XML::array'); $newval = $obj->value; # Because we used the constructor, the first level didn't count for the cyclic # tests. Instead, the first element is the potentially-cyclical array. $newval = $newval->[0]; is(scalar(@{$newval}), 1, 'Cyclical array <2> now length 1'); is($newval->[0], 'a', 'Cyclical array <2> kept non-cyclic element'); $val = {}; $val->{a} = 'a'; $val->{b} = [ qw(a b c) ]; $val->{c} = 1; $val->{b}->[1] = $val; $obj = smart_encode($val); isa_ok($obj, 'RPC::XML::struct'); $newval = $obj->value; is(scalar(keys %{$newval}), 3, 'Cyclical struct has correct num of keys'); is(scalar(@{$newval->{b}}), 2, 'Cyclical struct array elem is correct'); is($newval->{a}, 'a', 'Cyclical struct other key no. 1 correct'); is($newval->{c}, 1, 'Cyclical struct other key no. 2 correct'); $obj = RPC::XML::struct->new($val); isa_ok($obj, 'RPC::XML::struct'); $newval = $obj->value; is(scalar(keys %{$newval}), 3, 'Cyclical struct <2> has correct num of keys'); is(scalar(@{$newval->{b}}), 3, 'Cyclical struct <2> array elem is correct'); is($newval->{a}, 'a', 'Cyclical struct <2> other key no. 1 correct'); is($newval->{c}, 1, 'Cyclical struct <2> other key no. 2 correct'); is(scalar(keys %{$newval->{b}->[1]}), 2, 'Cyclical struct <2> nested hash has correct keys'); exit 0; RPC-XML-0.82/t/50_client.t0000644000175000017500000002232613774651431014017 0ustar rjrayrjray#!/usr/bin/env perl # Test the RPC::XML::Client class ## no critic(RequireBriefOpen); ## no critic(RequireInterpolationOfMetachars) use strict; use warnings; use subs qw(start_server stop_server find_port); use Carp qw(croak); use Module::Load; use Test::More; use LWP; use Digest::MD5 'md5_hex'; use File::Spec; use RPC::XML::Server; use RPC::XML::Client; my ($dir, $vol, $srv, $child, $port, $cli, $res, $flag, $srv_url); ($vol, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0)); $dir = File::Spec->catpath($vol, $dir, q{}); require File::Spec->catfile($dir, 'util.pl'); plan tests => 33; # The organization of the test suites is such that we assume anything that # runs before the current suite is 100%. Thus, no consistency checks on # any other classes are done, only on the data and return values of this # class under consideration, RPC::XML::Client. In this particular case, this # means that we can safely use RPC::XML::Server in creating a suitable test # environment. # Start with some very basic things, before actually firing up a live server. $cli = RPC::XML::Client->new(); ok(! ref $cli, 'RPC::XML::Client::new without endpoint fails'); like($cli, qr/Missing location argument/, 'Correct error message set'); if (($port = find_port) == -1) { croak 'No usable port found between 9000 and 11000, skipping'; } $cli = RPC::XML::Client->new("http://localhost:$port"); $cli->timeout(5); # to prevent long waiting for non-existing server isa_ok($cli, 'RPC::XML::Client', '$cli'); # With no server yet at that port, test the failure modes ok((! $cli->simple_request('system.identity')) && $RPC::XML::ERROR, 'Calling a server method without a server sets $RPC::XML::ERROR'); ok(! ref($cli->send_request('system.identity')), 'send_request returns a non-ref value when there is no server'); $res = $cli->send_request(); ok(! ref $res, 'Call to send_request without a method name fails'); like($res, qr/No request object/, 'Correct error message set'); $res = $cli->send_request('bad^method'); ok(! ref $res, 'Call to send_request with a bad method name fails'); like($res, qr/Error creating RPC::XML::request object/, 'Correct error message set'); # Test the error-handling callback $cli->error_handler(sub { $res++ }); $res = 0; $cli->simple_request('system.identity'); ok($res, 'error_handler callback system'); # Test clearing it $cli->error_handler(undef); $res = 0; $cli->simple_request('system.identity'); ok(! $res, 'Clearing the error_handler callback system'); # Test setting and clearing both with combined_handler $cli->combined_handler(sub { 1 }); ok($cli->error_handler() && ($cli->error_handler() eq $cli->fault_handler()), 'combined_handler set both error_handler and fault_handler'); $cli->combined_handler(undef); ok(! ($cli->error_handler() or $cli->fault_handler()), 'combined_handler clears both error_handler and fault_handler'); # Check the getting/setting of the timeout() value on the underlying UA is($cli->timeout(), $cli->useragent->timeout(), 'Client timeout() method, fetching'); $cli->timeout(60); is($cli->useragent->timeout(), 60, 'Client timeout() method, setting'); # Cool so far. Create and spawn the server. $srv = RPC::XML::Server->new(host => 'localhost', port => $port); if (! ref $srv) { croak "Failed to create server: $srv, stopped"; } # Due to issues with Strawberry Perl on Windows, have to explicitly set the # endpoint to what the server object thinks it is. Also, because of threading # issues with Strawberry, we need to save the URL value for later use while # the server is running. $srv_url = $srv->url; $cli->uri($srv_url); # Start the server... $child = start_server $srv; # NOW, this should work. Also, set $RPC::XML::ERROR to see if it clears $RPC::XML::ERROR = 'foo'; is($cli->simple_request('system.identity'), $srv->product_tokens, 'simple_request/system.identity returns correct value'); ok(! $RPC::XML::ERROR, 'simple_request/system.identity left $RPC::XML::ERROR empty'); # Using send_request should yield an RPC::XML::string object with that value $res = $cli->send_request('system.identity'); isa_ok($res, 'RPC::XML::string', 'system.identity response'); SKIP: { if (! ref $res) { skip 'Client response not a RPC::XML data object', 1; } is($res->value, $srv->product_tokens, 'system.identity response is correct'); } if (! ref $res) { # Assume that if an error occurred, the server might be in a confused # state. Kill and restart it. stop_server $child; $child = start_server $srv; } # See what comes back from bad (but successful) calls $res = $cli->simple_request('system.bad'); isa_ok($res, 'HASH', 'simple_request/system.bad response'); SKIP: { if (! ref $res) { skip 'Client response was not a RPC::XML data object', 2; } is(join(q{,} => sort keys %{$res}), 'faultCode,faultString', 'simple_request/system.bad hashref has correct keys'); like($res->{faultString}, qr/Unknown method/, 'simple_request/system.bad set correct faultString'); } if (! ref $res) { # Assume that if an error occurred, the server might be in a confused # state. Kill and restart it. stop_server $child; $child = start_server $srv; } # As opposed to a fault object: $res = $cli->send_request('system.bad'); isa_ok($res, 'RPC::XML::fault', 'send_request/system.bad response'); SKIP: { if (! ref $res) { skip 'Client response not a RPC::XML data object', 1; } like($res->string, qr/Unknown method/, 'send_request/system.bad set correct string() property'); } if (! ref $res) { # Assume that if an error occurred, the server might be in a confused # state. Kill and restart it. stop_server $child; $child = start_server $srv; } # Give the fault handler a whirl -- note the return value is the fault object $cli->fault_handler( sub { if ((ref($_[0]) eq 'RPC::XML::fault') && ($_[0]->string =~ /Unknown method/)) { $flag++; } $_[0] } ); $flag = 0; $res = $cli->send_request('system.bad'); # Did the callback run correctly? ok($flag, 'fault_handler correctly set $flag'); # Is the value returned correct? isa_ok($res, 'RPC::XML::fault', 'fault_handler returned value'); SKIP: { if (! ref $res) { skip 'Client response not a RPC::XML data object', 1; } like($res->string, qr/Unknown method/, 'fault_handler object has correct faultString'); } if (! ref $res) { # Assume that if an error occurred, the server might be in a confused # state. Kill and restart it. stop_server $child; $child = start_server $srv; } # Last tests-- is the uri() method working? is($cli->uri, $srv_url, 'RPC::XML::Client::uri method return value is correct'); # does calling it as an accesor change it at all? $cli->uri('http://www.oreilly.com/RPC'); is($cli->uri, 'http://www.oreilly.com/RPC', 'RPC::XML::Client::uri changes as expected'); # Kill the server long enough to add a new method stop_server $child; # Restore the server URL in the client. Due to some threading issues seen in # Strawberry Perl, must do this while $srv is not running. $cli->uri($srv->url); SKIP: { if ($LWP::VERSION <= 5.800) { skip 'Message-to-file spooling broken with LWP < 5.801', 4; } $srv->add_method( { name => 'cmpImg', signature => [ 'boolean base64 base64' ], code => sub { my ($self, $img1, $img2) = @_; return (md5_hex($img1) eq md5_hex($img2)); } } ); $child = start_server $srv; SKIP: { my ($fh1, $fh2); if (! (open $fh1, '<', File::Spec->catfile($dir, 'svsm_text.gif'))) { skip "Error opening svsm_text.gif: $!", 4; } if (! (open $fh2, '<', File::Spec->catfile($dir, 'svsm_text.gif'))) { skip "Error opening svsm_text.gif: $!", 4; } # Setting the size threshhold to the size of the GIF will guarantee a # file spool, since we're sending the GIF twice. $cli->message_file_thresh(-s $fh1); $cli->message_temp_dir($dir); $res = $cli->send_request(cmpImg => RPC::XML::base64->new($fh1), RPC::XML::base64->new($fh2)); isa_ok($res, 'RPC::XML::boolean', 'cmpImg return value'); SKIP: { if (! ref $res) { skip 'Client response not a RPC::XML data object', 1; } ok($res->value, 'cmpImg, file spooling, correct return'); } # Force the compression threshhold down, to test that branch $cli->compress_requests(1); $cli->compress_thresh(-s $fh1); $res = $cli->send_request(cmpImg => RPC::XML::base64->new($fh1), RPC::XML::base64->new($fh2)); isa_ok($res, 'RPC::XML::boolean', 'cmpImg return value (compression)'); SKIP: { if (! ref $res) { skip 'Client response not a RPC::XML data object', 1; } ok($res->value, 'cmpImg, file spooling+compression, correct return'); } } # Kill the server before exiting stop_server $child, 'final'; } exit; RPC-XML-0.82/t/40_server_xmllibxml.t0000644000175000017500000006404413775372465016151 0ustar rjrayrjray#!/usr/bin/env perl # Test the RPC::XML::Server class with XML::LibXML as the parser ## no critic(RequireInterpolationOfMetachars) use strict; use warnings; use subs qw(start_server stop_server); use Carp qw(croak); use File::Spec; use Module::Load; use List::Util 'none'; use Scalar::Util 'blessed'; use Socket (); use Test::More; use LWP::UserAgent; use HTTP::Request; use RPC::XML 'RPC_BASE64'; use RPC::XML::Server; use RPC::XML::ParserFactory; if (eval { load XML::LibXML; 1; }) { plan tests => 61; } else { plan skip_all => 'XML::LibXML not installed'; } my ($srv, $res, $bucket, $child, $parser, $xml, $req, $UA, @API_METHODS, $list, $meth, %seen, $dir, $vol); @API_METHODS = qw(system.identity system.introspection system.listMethods system.methodHelp system.methodSignature system.multicall system.status); ($vol, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0)); $dir = File::Spec->catpath($vol, $dir, q{}); require File::Spec->catfile($dir, 'util.pl'); sub failmsg { my ($msg, $line) = @_; return "$msg at line $line"; } # The organization of the test suites is such that we assume anything that # runs before the current suite is 100%. Thus, no consistency checks on # any other classes are done, only on the data and return values of this # class under consideration, RPC::XML::Server. In this particular case, this # also means that we cannot use RPC::XML::Client to test it. # Start with some very basic things, without actually firing up a live server. $srv = RPC::XML::Server->new(parser => [ class => 'XML::LibXML' ], no_http => 1, no_default => 1); isa_ok($srv, 'RPC::XML::Server', '$srv<1>'); if (! ref $srv) { croak "Server allocation failed, cannot continue. Message was: $srv"; } isa_ok($srv->parser, 'RPC::XML::Parser::XMLLibXML', '$srv<1> parser'); # Suppress "used only once" warning $_ = $RPC::XML::Server::VERSION; is($srv->version, $RPC::XML::Server::VERSION, 'RPC::XML::Server::version method'); ok(! $srv->started, 'RPC::XML::Server::started method'); like($srv->product_tokens, qr{/}, 'RPC::XML::Server::product_tokens method'); ok(! $srv->url, 'RPC::XML::Server::url method (empty)'); ok(! $srv->requests, 'RPC::XML::Server::requests method (0)'); ok($srv->response->isa('HTTP::Response'), 'RPC::XML::Server::response method returns HTTP::Response'); # Done with this one, let it go undef $srv; # This one will have a HTTP::Daemon server, but still no default methods $srv = RPC::XML::Server->new(no_default => 1, parser => [ class => 'XML::LibXML' ], host => 'localhost'); isa_ok($srv, 'RPC::XML::Server', '$srv<2>'); if (! ref $srv) { croak "Server allocation failed, cannot continue. Message was: $srv"; } # Test some of the simpler cases of add_method and get_method $res = $srv->add_method({ name => 'perl.test.suite.test1', signature => [ 'int' ], code => sub { return 1; } }); ok($res eq $srv, 'add_method return value test'); $res = $srv->get_method('perl.test.suite.test1'); isa_ok($res, 'RPC::XML::Method', 'get_method return value'); $res = $srv->get_method('perl.test.suite.not.added.yet'); ok(! ref($res), 'get_method for non-existent method'); # Here goes... $parser = RPC::XML::ParserFactory->new; $UA = LWP::UserAgent->new; $req = HTTP::Request->new(POST => $srv->url); $child = start_server $srv; $req->header(Content_Type => 'text/xml'); $req->content(RPC::XML::request->new('perl.test.suite.test1')->as_string); # Use alarm() to manage a resaonable time-out on the request local $SIG{ALRM} = sub { $bucket++ }; $bucket = 0; alarm 120; $res = $UA->request($req); alarm 0; ok(! $bucket, 'First live-request returned without timeout'); SKIP: { if ($bucket) { skip 'Server failed to respond within 120 seconds!', 4; } ok(! $res->is_error, 'First live req: Check that $res is not an error'); $xml = $res->content; $res = $parser->parse($xml); isa_ok($res, 'RPC::XML::response', 'First live req: parsed $res'); SKIP: { if (! (ref $res and $res->isa('RPC::XML::response'))) { skip 'Response content did not parse, cannot test', 2; } ok(! $res->is_fault, 'First live req: parsed $res is not a fault'); is($res->value->value, 1, 'First live req: $res value test'); } } stop_server $child; # Try deleting the method ok(ref $srv->delete_method('perl.test.suite.test1'), 'delete_method return value test'); # Start the server again # Add a method that echoes back socket-peer information $res = $srv->add_method({ name => 'perl.test.suite.peeraddr', signature => [ 'array' ], code => sub { my $server = shift; my $peerfamily = RPC_BASE64 $server->{peerfamily}; my $peeraddr = RPC_BASE64 $server->{peeraddr}; my $packet = pack_sockaddr_any( $server->{peerfamily}, $server->{peerhost}, $server->{peerport} ); $packet = RPC_BASE64 $packet; [ $peerfamily, $peeraddr, $packet, $server->{peerhost}, $server->{peerport} ]; } }); $child = start_server $srv; $bucket = 0; alarm 120; $res = $UA->request($req); alarm 0; ok(! $bucket, 'Second live-request returned without timeout'); SKIP: { if ($bucket) { skip 'Server failed to respond within 120 seconds!', 4; } ok(! $res->is_error, 'Second live req: Check that $res is not an error'); $res = $parser->parse($res->content); isa_ok($res, 'RPC::XML::response', 'Second live req: parsed $res'); SKIP: { if (! (ref $res and $res->isa('RPC::XML::response'))) { skip 'Response content did not parse, cannot test', 2; } ok($res->is_fault, 'Second live req: parsed $res is a fault'); like($res->value->value->{faultString}, qr/Unknown method/, 'Second live request: correct faultString'); } } stop_server $child; # Start the server again $child = start_server $srv; $bucket = 0; $req->content(RPC::XML::request->new('perl.test.suite.peeraddr')->as_string); alarm 120; $res = $UA->request($req); alarm 0; ok(! $bucket, 'Third live-request returned without timeout'); SKIP: { if ($bucket) { skip 'Server failed to respond within 120 seconds!', 4; } ok(! $res->is_error, 'Third live req: Check that $res is not an error'); $res = $parser->parse($res->content); isa_ok($res, 'RPC::XML::response', 'Third live req: parsed $res'); SKIP: { if (! (ref $res and $res->isa('RPC::XML::response'))) { skip 'Response content did not parse, cannot test', 3; } $res = $res->value->value; ok(grep({ $_ eq $res->[3]} resolve($res->[0], 'localhost')), 'Third live req: Correct IP addr from peerhost'); is($res->[1], Socket::inet_pton($res->[0], $res->[3]), 'Third request: peeraddr packet matches converted peerhost'); is($res->[2], pack_sockaddr_any($res->[0], $res->[3], $res->[4]), 'Third request: pack_sockaddr_any validates all'); } } stop_server $child; # Start the server again $child = start_server $srv; # Test the error-message-mixup problem reported in RT# 29351 # (http://rt.cpan.org/Ticket/Display.html?id=29351) my $tmp = <<'EOX'; test.method foo bar EOX $req->content($tmp); $bucket = 0; alarm 120; $res = $UA->request($req); alarm 0; ok(! $bucket, 'RT29351 live-request returned without timeout'); SKIP: { if ($bucket) { skip 'Server failed to respond within 120 seconds!', 4; } ok(! $res->is_error, 'RT29351 live req: $res is not an error'); $res = $parser->parse($res->content); isa_ok($res, 'RPC::XML::response', 'RT29351 live req: parsed $res'); SKIP: { if (! (ref $res and $res->isa('RPC::XML::response'))) { skip 'Response content did not parse, cannot test', 2; } ok($res->is_fault, 'RT29351 live req: parsed $res is a fault'); like($res->value->value->{faultString}, qr/Too many child-nodes/, 'RT29351 live request: correct faultString'); } } stop_server $child; # OK-- At this point, basic server creation and accessors have been validated. # We've run a remote method and we've correctly failed to run an unknown remote # method. Before moving into the more esoteric XPL-file testing, we will test # the provided introspection API. undef $srv; undef $req; $srv = RPC::XML::Server->new(parser => [ class => 'XML::LibXML' ], host => 'localhost'); # Did it create OK, with the requirement of loading the XPL code? isa_ok($srv, 'RPC::XML::Server', '$srv<3> (with default methods)'); if (! ref $srv) { croak "Server allocation failed, cannot continue. Message was: $srv"; } # Did it get all of them? is($srv->list_methods(), scalar(@API_METHODS), 'Correct number of methods (defaults)'); $req = HTTP::Request->new(POST => $srv->url); $child = start_server $srv; $req->header(Content_Type => 'text/xml'); $req->content(RPC::XML::request->new('system.listMethods')->as_string); # Use alarm() to manage a reasonable time-out on the request $bucket = 0; undef $res; alarm 120; $res = $UA->request($req); alarm 0; SKIP: { if ($bucket) { skip 'Server failed to respond within 120 seconds!', 2; } $res = ($res->is_error) ? q{} : $parser->parse($res->content); isa_ok($res, 'RPC::XML::response', 'system.listMethods response'); SKIP: { if (! (ref $res and $res->isa('RPC::XML::response'))) { skip 'Response content did not parse, cannot test', 1; } $list = (ref $res) ? $res->value->value : []; ok((ref($list) eq 'ARRAY') && (join(q{} => sort @{$list}) eq join q{} => sort @API_METHODS), 'system.listMethods return list correct'); } } stop_server $child; # Start the server again $child = start_server $srv; # Set the ALRM handler to something more serious, since we have passed that # hurdle already. local $SIG{ALRM} = sub { die "Server failed to respond within 120 seconds\n"; }; # Test the substring-parameter calling of system.listMethods $req->content(RPC::XML::request->new('system.listMethods', 'method')->as_string); alarm 120; $res = $UA->request($req); alarm 0; $res = ($res->is_error) ? q{} : $parser->parse($res->content); SKIP: { if (! $res) { skip 'Server response was error, cannot test', 1; } $list = $res->value->value; if ($res->is_fault) { fail(failmsg($res->value->string, __LINE__)); } else { is(join(q{,} => sort @{$list}), 'system.methodHelp,system.methodSignature', 'system.listMethods("method") return list correct'); } } # If the response was any kind of error, kill and re-start the server, as # HTTP::Message::content might have killed it already via croak(). if (! $res) { # $res was made null above if it was an error stop_server $child; # Start the server again $child = start_server $srv; } # Run again, with a pattern that will produce no matches $req->content(RPC::XML::request->new('system.listMethods', 'nomatch')->as_string); alarm 120; $res = $UA->request($req); alarm 0; $res = ($res->is_error) ? q{} : $parser->parse($res->content); SKIP: { if (! $res) { skip 'Server response was error, cannot test', 1; } $list = $res->value->value; if ($res->is_fault) { fail(failmsg($res->value->string, __LINE__)); } else { is(scalar(@{$list}), 0, 'system.listMethods("nomatch") return list correct'); } } # If the response was any kind of error, kill and re-start the server, as # HTTP::Message::content might have killed it already via croak(). if (! $res) { # $res was made null above if it was an error stop_server $child; # Start the server again $child = start_server $srv; } # system.identity $req->content(RPC::XML::request->new('system.identity')->as_string); alarm 120; $res = $UA->request($req); alarm 0; $res = ($res->is_error) ? q{} : $parser->parse($res->content); SKIP: { if (! $res) { skip 'Server response was error, cannot test', 1; } is($res->value->value, $srv->product_tokens, 'system.identity test'); } # If the response was any kind of error, kill and re-start the server, as # HTTP::Message::content might have killed it already via croak(). if (! $res) { # $res was made null above if it was an error stop_server $child; # Start the server again $child = start_server $srv; } # system.status $req->content(RPC::XML::request->new('system.status')->as_string); alarm 120; $res = $UA->request($req); alarm 0; $res = ($res->is_error) ? q{} : $parser->parse($res->content); SKIP: { if (! $res) { skip 'Server response was error, cannot test', 2; } $res = $res->value->value; my @keys = qw(host port name version path date date_int started started_int total_requests methods_known); my @seen_keys = grep { defined $res->{$_} } @keys; ok(@keys == @seen_keys, 'system.status hash has correct keys'); is($res->{total_requests}, 4, 'system.status reports correct total_requests'); } # If the response was any kind of error, kill and re-start the server, as # HTTP::Message::content might have killed it already via croak(). if (! $res) { # $res was made null above if it was an error stop_server $child; # Start the server again $child = start_server $srv; } # Test again, with a 'true' value passed to the method, which should prevent # the 'total_requests' key from incrementing. $req->content(RPC::XML::request->new('system.status', RPC::XML::boolean->new(1))->as_string); alarm 120; $res = $UA->request($req); alarm 0; $res = ($res->is_error) ? q{} : $parser->parse($res->content); SKIP: { if (! $res) { skip 'Server response was error, cannot test', 1; } $res = $res->value->value; is($res->{total_requests}, 4, 'system.status reports correct total_requests ("true" call)'); } # If the response was any kind of error, kill and re-start the server, as # HTTP::Message::content might have killed it already via croak(). if (! $res) { # $res was made null above if it was an error stop_server $child; # Start the server again $child = start_server $srv; } # system.methodHelp $req->content(RPC::XML::request->new('system.methodHelp', 'system.identity')->as_string); alarm 120; $res = $UA->request($req); alarm 0; $res = ($res->is_error) ? q{} : $parser->parse($res->content); SKIP: { if (! $res) { skip 'Server response was error, cannot test', 1; } $meth = $srv->get_method('system.identity'); if (! blessed $meth) { fail(failmsg($meth, __LINE__)); } else { is($res->value->value, $meth->{help}, 'system.methodHelp("system.identity") test'); } } # If the response was any kind of error, kill and re-start the server, as # HTTP::Message::content might have killed it already via croak(). if (! $res) { # $res was made null above if it was an error stop_server $child; # Start the server again $child = start_server $srv; } # system.methodHelp with multiple arguments $req->content(RPC::XML::request->new('system.methodHelp', [ 'system.identity', 'system.status' ])->as_string); alarm 120; $res = $UA->request($req); alarm 0; $res = ($res->is_error) ? q{} : $parser->parse($res->content); SKIP: { if (! $res) { skip 'Server response was error, cannot test', 1; } if ($res->is_fault) { fail(failmsg($res->value->string, __LINE__)); } else { is(join(q{} => @{ ref($res) ? $res->value->value : [] }), $srv->get_method('system.identity')->{help} . $srv->get_method('system.status')->{help}, 'system.methodHelp("system.identity", "system.status") test'); } } # If the response was any kind of error, kill and re-start the server, as # HTTP::Message::content might have killed it already via croak(). if (! $res) { # $res was made null above if it was an error stop_server $child; # Start the server again $child = start_server $srv; } # system.methodHelp with an invalid argument $req->content(RPC::XML::request->new('system.methodHelp', 'system.bad')->as_string); alarm 120; $res = $UA->request($req); alarm 0; $res = ($res->is_error) ? q{} : $parser->parse($res->content); SKIP: { if (! $res) { skip 'Server response was error, cannot test', 2; } ok($res->value->is_fault(), 'system.methodHelp returned fault for unknown method'); like($res->value->string, qr/Method.*unknown/, 'system.methodHelp("system.bad") correct faultString'); } # If the response was any kind of error, kill and re-start the server, as # HTTP::Message::content might have killed it already via croak(). if (! $res) { # $res was made null above if it was an error stop_server $child; # Start the server again $child = start_server $srv; } # system.methodSignature $req->content(RPC::XML::request->new('system.methodSignature', 'system.methodHelp')->as_string); alarm 120; $res = $UA->request($req); alarm 0; $res = ($res->is_error) ? q{} : $parser->parse($res->content); SKIP: { if (! $res) { skip 'Server response was error, cannot test', 1; } $meth = $srv->get_method('system.methodHelp'); if (! blessed $meth) { fail(failmsg($meth, __LINE__)); } else { is(join(q{}, sort map { join q{ } => @{$_} } @{ ref($res) ? $res->value->value : [] }), join(q{} => sort @{$meth->{signature}}), 'system.methodSignature("system.methodHelp") test'); } } # If the response was any kind of error, kill and re-start the server, as # HTTP::Message::content might have killed it already via croak(). if (! $res) { # $res was made null above if it was an error stop_server $child; # Start the server again $child = start_server $srv; } # system.methodSignature, with an invalid request $req->content(RPC::XML::request->new('system.methodSignature', 'system.bad')->as_string); alarm 120; $res = $UA->request($req); alarm 0; $res = ($res->is_error) ? q{} : $parser->parse($res->content); SKIP: { if (! ref $res) { skip 'Server response was error, cannot test', 2; } ok($res->value->is_fault(), 'system.methodSignature returned fault for unknown method'); like($res->value->string, qr/Method.*unknown/, 'system.methodSignature("system.bad") correct faultString'); } # If the response was any kind of error, kill and re-start the server, as # HTTP::Message::content might have killed it already via croak(). if (! $res) { # $res was made null above if it was an error stop_server $child; # Start the server again $child = start_server $srv; } # system.introspection $req->content(RPC::XML::request->new('system.introspection')->as_string); alarm 120; $res = $UA->request($req); alarm 0; $res = ($res->is_error) ? q{} : $parser->parse($res->content); SKIP: { if (! $res) { skip 'Server response was error, cannot test', 1; } if ($res->is_fault) { fail(failmsg($res->value->string, __LINE__)); } else { $list = $res->value->value; $bucket = 0; %seen = (); for my $result (@{$list}) { if ($seen{$result->{name}}++) { # If we somehow get the same name twice, that is a point off $bucket++; next; } $meth = $srv->get_method($result->{name}); if ($meth) { my $result_sig = join q{} => sort @{$result->{signature}}; my $method_sig = join q{} => sort @{$meth->{signature}}; # A point off unless all three of these match if (($meth->{help} ne $result->{help}) || ($meth->{version} ne $result->{version}) || ($result_sig ne $method_sig)) { $bucket++; } } else { # That is also a point $bucket++; } } ok(! $bucket, 'system.introspection passed with no errors'); } } # If the response was any kind of error, kill and re-start the server, as # HTTP::Message::content might have killed it already via croak(). if (! $res) { # $res was made null above if it was an error stop_server $child; # Start the server again $child = start_server $srv; } # system.multicall $req->content(RPC::XML::request->new('system.multicall', [ { methodName => 'system.identity' }, { methodName => 'system.listMethods', params => [ 'intro' ] } ])->as_string); alarm 120; $res = $UA->request($req); alarm 0; $res = ($res->is_error) ? q{} : $parser->parse($res->content); SKIP: { if (! $res) { skip 'Server response was error, cannot test', 2; } 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] : q{}), 'system.introspection', 'system.multicall response elt [1][0] is correct'); } } # If the response was any kind of error, kill and re-start the server, as # HTTP::Message::content might have killed it already via croak(). if (! $res) { # $res was made null above if it was an error stop_server $child; # Start the server again $child = start_server $srv; } # system.multicall, with an attempt at illegal recursion $req->content(RPC::XML::request->new('system.multicall', [ { methodName => 'system.identity' }, { methodName => 'system.multicall', params => [ 'intro' ] } ])->as_string); alarm 120; $res = $UA->request($req); alarm 0; $res = ($res->is_error) ? q{} : $parser->parse($res->content); SKIP: { if (! $res) { skip 'Server response was error, cannot test', 2; } $res = $res->value; ok($res->is_fault, 'system.multicall returned fault on attempt at recursion'); like($res->string, qr/Recursive/, 'system.multicall recursion attempt set correct faultString'); } # If the response was any kind of error, kill and re-start the server, as # HTTP::Message::content might have killed it already via croak(). if (! $res) { # $res was made null above if it was an error stop_server $child; # Start the server again $child = start_server $srv; } # system.multicall, with bad data on one of the call specifications $req->content(RPC::XML::request->new('system.multicall', [ { methodName => 'system.identity' }, { methodName => 'system.status', params => 'intro' } ])->as_string); alarm 120; $res = $UA->request($req); alarm 0; $res = ($res->is_error) ? q{} : $parser->parse($res->content); SKIP: { if (! $res) { skip 'Server response was error, cannot test', 2; } $res = $res->value; ok($res->is_fault, 'system.multicall returned fault when passed a bad param array'); like($res->string, qr/value for.*params.*not an array/i, 'system.multicall bad param array set correct faultString'); } # If the response was any kind of error, kill and re-start the server, as # HTTP::Message::content might have killed it already via croak(). if (! $res) { # $res was made null above if it was an error stop_server $child; # Start the server again $child = start_server $srv; } # system.multicall, with bad data in the request itself $req->content(RPC::XML::request->new('system.multicall', [ { methodName => 'system.identity' }, 'This is not acceptable data' ])->as_string); alarm 120; $res = $UA->request($req); alarm 0; $res = ($res->is_error) ? q{} : $parser->parse($res->content); SKIP: { if (! $res) { skip 'Server response was error, cannot test', 2; } $res = $res->value; ok($res->is_fault, 'system.multicall returned fault on bad input'); like($res->string, qr/one.*array element.*not a struct/i, 'system.multicall bad input set correct faultString'); } # If the response was any kind of error, kill and re-start the server, as # HTTP::Message::content might have killed it already via croak(). if (! $res) { # $res was made null above if it was an error stop_server $child; # Start the server again $child = start_server $srv; } # system.status, once more, to check the total_requests value $req->content(RPC::XML::request->new('system.status')->as_string); alarm 120; $res = $UA->request($req); alarm 0; $res = ($res->is_error) ? q{} : $parser->parse($res->content); SKIP: { if (! $res) { skip 'Server response was error, cannot test', 1; } $res = $res->value->value; is($res->{total_requests}, 20, 'system.status, final request tally'); } # Don't leave any children laying around stop_server $child, 'final'; exit; RPC-XML-0.82/t/40_server.t0000644000175000017500000010767313775372465014067 0ustar rjrayrjray#!/usr/bin/env perl # Test the RPC::XML::Server class ## no critic(RequireInterpolationOfMetachars) use strict; use warnings; use subs qw(start_server stop_server find_port_in_use); use Carp qw(croak); use IO::Socket; use File::Spec; use List::Util 'none'; use Scalar::Util 'blessed'; use Socket (); use Test::More; use LWP::UserAgent; use HTTP::Request; use RPC::XML 'RPC_BASE64'; use RPC::XML::Server; use RPC::XML::ParserFactory; plan tests => 90; my ($srv, $res, $bucket, $child, $parser, $xml, $req, $port, $UA, @API_METHODS, $list, $meth, %seen, $dir, $vol, $oldtable, $newtable, $value); @API_METHODS = qw(system.identity system.introspection system.listMethods system.methodHelp system.methodSignature system.multicall system.status); ($vol, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0)); $dir = File::Spec->catpath($vol, $dir, q{}); require File::Spec->catfile($dir, 'util.pl'); sub failmsg { my ($msg, $line) = @_; return sprintf '%s at line %d', $msg, $line; } # The organization of the test suites is such that we assume anything that # runs before the current suite is 100%. Thus, no consistency checks on # any other classes are done, only on the data and return values of this # class under consideration, RPC::XML::Server. In this particular case, this # also means that we cannot use RPC::XML::Client to test it. # Start with some very basic things, without actually firing up a live server. $srv = RPC::XML::Server->new(no_http => 1, no_default => 1); isa_ok($srv, 'RPC::XML::Server', '$srv<1>'); # This assignment is just to suppress "used only once" warnings $value = $RPC::XML::Server::VERSION; is($srv->version, $RPC::XML::Server::VERSION, 'RPC::XML::Server::version method'); ok(! $srv->started, 'RPC::XML::Server::started method'); like($srv->product_tokens, qr{/}, 'RPC::XML::Server::product_tokens method'); ok(! $srv->url, 'RPC::XML::Server::url method (empty)'); ok(! $srv->requests, 'RPC::XML::Server::requests method (0)'); ok($srv->response->isa('HTTP::Response'), 'RPC::XML::Server::response method returns HTTP::Response'); # Some negative tests: $res = $srv->new(); like($res, qr/Must be called as a static method/, 'Calling new() as an instance method fails'); $meth = $srv->method_from_file('does_not_exist.xpl'); ok(! ref $meth, 'Bad file did not result in method reference'); like($meth, qr/Error opening.*does_not_exist/, 'Correct error message'); # Test the functionality of manipulating the fault table. First get the vanilla # table from a simple server object. Then create a new server object with both # a fault-base offset and some user-defined faults. We use the existing $srv to # get the "plain" table. $oldtable = $srv->{__fault_table}; # Now re-assign $srv $srv = RPC::XML::Server->new( no_http => 1, no_default => 1, fault_code_base => 1000, fault_table => { myfault1 => [ 2000, 'test' ], myfault2 => 2001, } ); $newtable = $srv->{__fault_table}; # Compare number of faults, the values of the fault codes, and the presence of # the user-defined faults: ok((scalar(keys %{$oldtable}) + 2) == (scalar keys %{$newtable}), 'Proper number of relative keys'); $value = 1; for my $key (keys %{$oldtable}) { if ($newtable->{$key}->[0] != ($oldtable->{$key}->[0] + 1000)) { $value = 0; last; } } ok($value, 'Fault codes adjustment yielded correct new codes'); ok((exists $newtable->{myfault1} && exists $newtable->{myfault2} && ref($newtable->{myfault1}) eq 'ARRAY' && $newtable->{myfault2} == 2001 && $newtable->{myfault1}->[0] == 2000), 'User-supplied fault elements look OK'); # Done with this one, let it go undef $srv; # Test that the url() method behaves like we expect it for certain ports $srv = RPC::XML::Server->new( no_default => 1, no_http => 1, host => 'localhost', port => 80 ); SKIP: { if (ref($srv) ne 'RPC::XML::Server') { skip 'Failed to get port-80 server, cannot test', 1; } is($srv->url, 'http://localhost', 'Default URL for port-80 server'); } $srv = RPC::XML::Server->new( no_default => 1, no_http => 1, host => 'localhost', port => 443 ); SKIP: { if (ref($srv) ne 'RPC::XML::Server') { skip 'Failed to get port-443 server, cannot test', 1; } is($srv->url, 'https://localhost', 'Default URL for port-443 server'); } # Let's test that server creation properly fails if/when HTTP::Daemon fails. # First find a port in use, preferably under 1024: SKIP: { if ($< == 0) { skip 'Negative port-based test unreliable when run as root', 2; } $port = find_port_in_use; if ($port == -1) { skip 'No in-use port found for negative testing, skipped', 2; } $srv = RPC::XML::Server->new(port => $port); is(ref($srv), q{}, 'Bad new return is not an object'); like($srv, qr/Unable to create HTTP::Daemon/, 'Proper error message'); } # This one will have a HTTP::Daemon server, but still no default methods $srv = RPC::XML::Server->new(no_default => 1, host => 'localhost'); isa_ok($srv, 'RPC::XML::Server', '$srv<2>'); if (! ref $srv) { croak "Server allocation failed, cannot continue. Message was: $srv"; } # Test some of the simpler cases of add_method and get_method $res = $srv->add_method({ name => 'perl.test.suite.test1', signature => [ 'int' ], code => sub { return 1; } }); ok($res eq $srv, 'add_method return value test'); $res = $srv->get_method('perl.test.suite.test1'); isa_ok($res, 'RPC::XML::Method', 'get_method return value'); $res = $srv->get_method('perl.test.suite.not.added.yet'); ok(! ref($res), 'get_method for non-existent method'); # Throw junk at add_method/add_procedure/add_function $res = $srv->add_method([]); like($res, qr/file name, a hash reference or an object/, 'add_method() fails on bad data'); $res = $srv->add_method('file does not exist'); like($res, qr/Error loading from file/, 'add_method() fails on non-existent file'); $res = $srv->add_procedure({ name => 'procedure1', signature => [ 'int' ], code => sub { return 1; } }); ok($res eq $srv, 'add_procedure return value test'); $res = $srv->get_procedure('procedure1'); is(ref($res), 'RPC::XML::Procedure', 'get_procedure(procedure1) return value'); $res = $srv->add_function({ name => 'function1', code => sub { return 1; } }); ok($res eq $srv, 'add_function return value test'); $res = $srv->get_function('function1'); is(ref($res), 'RPC::XML::Function', 'get_function(function1) return value'); $res = $srv->add_method({ name => 'method1', type => 'bad', signature => [ 'int' ], code => sub { return 1; } }); like($res, qr/Unknown type: bad/, 'add_method, bad type param'); # Here goes... $parser = RPC::XML::ParserFactory->new; $UA = LWP::UserAgent->new; $req = HTTP::Request->new(POST => $srv->url); $child = start_server $srv; $req->header(Content_Type => 'text/xml'); $req->content(RPC::XML::request->new('perl.test.suite.test1')->as_string); # Use alarm() to manage a resaonable time-out on the request $bucket = 0; local $SIG{ALRM} = sub { $bucket++ }; alarm 120; $res = $UA->request($req); alarm 0; ok(! $bucket, 'First live-request returned without timeout'); SKIP: { if ($bucket) { skip 'Server failed to respond within 120 seconds!', 4; } ok(! $res->is_error, 'First live req: Check that $res is not an error'); $xml = $res->content; $res = $parser->parse($xml); isa_ok($res, 'RPC::XML::response', 'First live req: parsed $res'); SKIP: { if (! (ref $res and $res->isa('RPC::XML::response'))) { skip 'Response content did not parse, cannot test', 2; } ok(! $res->is_fault, 'First live req: parsed $res is not a fault'); is($res->value->value, 1, 'First live req: $res value test'); } } stop_server $child; # Try deleting the method ok(ref $srv->delete_method('perl.test.suite.test1'), 'delete_method return value test'); # Start the server again # Add a method that echoes back socket-peer information $res = $srv->add_method({ name => 'perl.test.suite.peeraddr', signature => [ 'array' ], code => sub { my $server = shift; my $peerfamily = RPC_BASE64 $server->{peerfamily}; my $peeraddr = RPC_BASE64 $server->{peeraddr}; my $packet = pack_sockaddr_any( $server->{peerfamily}, $server->{peerhost}, $server->{peerport} ); $packet = RPC_BASE64 $packet; [ $peerfamily, $peeraddr, $packet, $server->{peerhost}, $server->{peerport} ]; } }); $child = start_server $srv; $bucket = 0; alarm 120; $res = $UA->request($req); alarm 0; ok(! $bucket, 'Second live-request returned without timeout'); SKIP: { if ($bucket) { skip 'Server failed to respond within 120 seconds!', 4; } ok(! $res->is_error, 'Second live req: Check that $res is not an error'); $res = $parser->parse($res->content); isa_ok($res, 'RPC::XML::response', 'Second live req: parsed $res'); SKIP: { if (! (ref $res and $res->isa('RPC::XML::response'))) { skip 'Response content did not parse, cannot test', 2; } ok($res->is_fault, 'Second live req: parsed $res is a fault'); like($res->value->value->{faultString}, qr/Unknown method/, 'Second live request: correct faultString'); } } stop_server $child; # Start the server again $child = start_server $srv; $bucket = 0; $req->content(RPC::XML::request->new('perl.test.suite.peeraddr')->as_string); alarm 120; $res = $UA->request($req); alarm 0; ok(! $bucket, 'Third live-request returned without timeout'); SKIP: { if ($bucket) { skip 'Server failed to respond within 120 seconds!', 4; } ok(! $res->is_error, 'Third live req: Check that $res is not an error'); $res = $parser->parse($res->content); isa_ok($res, 'RPC::XML::response', 'Third live req: parsed $res'); SKIP: { if (! (ref $res and $res->isa('RPC::XML::response'))) { skip 'Response content did not parse, cannot test', 3; } $res = $res->value->value; ok(grep({ $_ eq $res->[3]} resolve($res->[0], 'localhost')), 'Third live req: Correct IP addr from peerhost'); is($res->[1], Socket::inet_pton($res->[0], $res->[3]), 'Third request: peeraddr packet matches converted peerhost'); is($res->[2], pack_sockaddr_any($res->[0], $res->[3], $res->[4]), 'Third request: pack_sockaddr_any validates all'); } } stop_server $child; # Start the server again # Add a method that echoes back info from the HTTP request object $res = $srv->add_method({ name => 'perl.test.suite.http_req', signature => [ 'array' ], code => sub { my $server = shift; [ $server->{request}->content_type, $server->{request}->header('X-Foobar') ] } }); $child = start_server $srv; $bucket = 0; $req->content(RPC::XML::request->new('perl.test.suite.http_req')->as_string); $req->header('X-Foobar', 'Wibble'); alarm 120; $res = $UA->request($req); alarm 0; ok(! $bucket, 'Fourth live-request returned without timeout'); SKIP: { if ($bucket) { skip 'Server failed to respond within 120 seconds!', 4; } ok(! $res->is_error, 'Fourth live req: Check that $res is not an error'); $res = $parser->parse($res->content); isa_ok($res, 'RPC::XML::response', 'Fourth live req: parsed $res'); SKIP: { if (! (ref $res and $res->isa('RPC::XML::response'))) { skip 'Response content did not parse, cannot test', 2; } $res = $res->value->value; is($res->[0], 'text/xml', 'Fourth request: Content type returned correctly'); is($res->[1], 'Wibble', 'Fourth live req: Correct value for request header X-Foobar'); } } # Clean up after ourselves. $req->remove_header('X-Foobar'); stop_server $child; # Start the server again $child = start_server $srv; # Test the error-message-mixup problem reported in RT# 29351 # (http://rt.cpan.org/Ticket/Display.html?id=29351) my $tmp = <<'EOX'; test.method foo bar EOX $req->content($tmp); $bucket = 0; alarm 120; $res = $UA->request($req); alarm 0; ok(! $bucket, 'RT29351 live-request returned without timeout'); SKIP: { if ($bucket) { skip 'Server failed to respond within 120 seconds!', 4; } ok(! $res->is_error, 'RT29351 live req: $res is not an error'); $res = $parser->parse($res->content); isa_ok($res, 'RPC::XML::response', 'RT29351 live req: parsed $res'); SKIP: { if (! (ref $res and $res->isa('RPC::XML::response'))) { skip 'Response content did not parse, cannot test', 2; } ok($res->is_fault, 'RT29351 live req: parsed $res is a fault'); like( $res->value->value->{faultString}, qr/Illegal content in param tag/, 'RT29351 live request: correct faultString' ); } } stop_server $child; # OK-- At this point, basic server creation and accessors have been validated. # We've run a remote method and we've correctly failed to run an unknown remote # method. Before moving into the more esoteric XPL-file testing, we will test # the provided introspection API. undef $srv; undef $req; $srv = RPC::XML::Server->new(host => 'localhost'); # Did it create OK, with the requirement of loading the XPL code? isa_ok($srv, 'RPC::XML::Server', '$srv<3> (with default methods)'); # Assume $srv is defined for the rest of the tests if (! ref $srv) { croak "Server allocation failed, cannot continue. Message was: $srv"; } # Did it get all of them? is($srv->list_methods(), scalar(@API_METHODS), 'Correct number of methods (defaults)'); $req = HTTP::Request->new(POST => $srv->url); $child = start_server $srv; $req->header(Content_Type => 'text/xml'); $req->content(RPC::XML::request->new('system.listMethods')->as_string); # Use alarm() to manage a reasonable time-out on the request $bucket = 0; undef $res; alarm 120; $res = $UA->request($req); alarm 0; SKIP: { if ($bucket) { skip 'Server failed to respond within 120 seconds!', 2; } $res = ($res->is_error) ? q{} : $parser->parse($res->content); isa_ok($res, 'RPC::XML::response', 'system.listMethods response'); SKIP: { if (! (ref $res and $res->isa('RPC::XML::response'))) { skip 'Response content did not parse, cannot test', 1; } $list = (ref $res) ? $res->value->value : []; ok((ref($list) eq 'ARRAY') && (join(q{} => sort @{$list}) eq join q{} => sort @API_METHODS), 'system.listMethods return list correct'); } } stop_server $child; # Start the server again $child = start_server $srv; # Set the ALRM handler to something more serious, since we have passed that # hurdle already. local $SIG{ALRM} = sub { die "Server failed to respond within 120 seconds\n"; }; # Test the substring-parameter calling of system.listMethods $req->content(RPC::XML::request->new('system.listMethods', 'method')->as_string); alarm 120; $res = $UA->request($req); alarm 0; $res = ($res->is_error) ? q{} : $parser->parse($res->content); SKIP: { if (! $res) { skip 'Server response was error, cannot test', 1; } $list = $res->value->value; if ($res->is_fault) { fail(failmsg($res->value->string, __LINE__)); } else { is(join(q{,} => sort @{$list}), 'system.methodHelp,system.methodSignature', 'system.listMethods("method") return list correct'); } } # If the response was any kind of error, kill and re-start the server, as # HTTP::Message::content might have killed it already via croak(). if (! $res) { # $res was made null above if it was an error stop_server $child; # Start the server again $child = start_server $srv; } # Run again, with a pattern that will produce no matches $req->content(RPC::XML::request->new('system.listMethods', 'nomatch')->as_string); alarm 120; $res = $UA->request($req); alarm 0; $res = ($res->is_error) ? q{} : $parser->parse($res->content); SKIP: { if (! $res) { skip 'Server response was error, cannot test', 1; } $list = $res->value->value; if ($res->is_fault) { fail(failmsg($res->value->string, __LINE__)); } else { is(scalar(@{$list}), 0, 'system.listMethods("nomatch") return list correct'); } } # If the response was any kind of error, kill and re-start the server, as # HTTP::Message::content might have killed it already via croak(). if (! $res) { # $res was made null above if it was an error stop_server $child; # Start the server again $child = start_server $srv; } # system.identity $req->content(RPC::XML::request->new('system.identity')->as_string); alarm 120; $res = $UA->request($req); alarm 0; $res = ($res->is_error) ? q{} : $parser->parse($res->content); SKIP: { if (! $res) { skip 'Server response was error, cannot test', 1; } is($res->value->value, $srv->product_tokens, 'system.identity test'); } # If the response was any kind of error, kill and re-start the server, as # HTTP::Message::content might have killed it already via croak(). if (! $res) { # $res was made null above if it was an error stop_server $child; # Start the server again $child = start_server $srv; } # system.status $req->content(RPC::XML::request->new('system.status')->as_string); alarm 120; $res = $UA->request($req); alarm 0; $res = ($res->is_error) ? q{} : $parser->parse($res->content); SKIP: { if (! $res) { skip 'Server response was error, cannot test', 2; } $res = $res->value->value; my @keys = qw(host port name version path date date_int started started_int total_requests methods_known); my @seen_keys = grep { defined $res->{$_} } @keys; ok(@keys == @seen_keys, 'system.status hash has correct keys'); is($res->{total_requests}, 4, 'system.status reports correct total_requests'); } # If the response was any kind of error, kill and re-start the server, as # HTTP::Message::content might have killed it already via croak(). if (! $res) { # $res was made null above if it was an error stop_server $child; # Start the server again $child = start_server $srv; } # Test again, with a 'true' value passed to the method, which should prevent # the 'total_requests' key from incrementing. $req->content(RPC::XML::request->new('system.status', RPC::XML::boolean->new(1))->as_string); alarm 120; $res = $UA->request($req); alarm 0; $res = ($res->is_error) ? q{} : $parser->parse($res->content); SKIP: { if (! $res) { skip 'Server response was error, cannot test', 1; } $res = $res->value->value; is($res->{total_requests}, 4, 'system.status reports correct total_requests ("true" call)'); } # If the response was any kind of error, kill and re-start the server, as # HTTP::Message::content might have killed it already via croak(). if (! $res) { # $res was made null above if it was an error stop_server $child; # Start the server again $child = start_server $srv; } # system.methodHelp $req->content(RPC::XML::request->new('system.methodHelp', 'system.identity')->as_string); alarm 120; $res = $UA->request($req); alarm 0; $res = ($res->is_error) ? q{} : $parser->parse($res->content); SKIP: { if (! $res) { skip 'Server response was error, cannot test', 1; } $meth = $srv->get_method('system.identity'); if (! blessed $meth) { fail(failmsg($meth, __LINE__)); } else { is($res->value->value, $meth->{help}, 'system.methodHelp("system.identity") test'); } } # If the response was any kind of error, kill and re-start the server, as # HTTP::Message::content might have killed it already via croak(). if (! $res) { # $res was made null above if it was an error stop_server $child; # Start the server again $child = start_server $srv; } # system.methodHelp with multiple arguments $req->content(RPC::XML::request->new('system.methodHelp', [ 'system.identity', 'system.status' ])->as_string); alarm 120; $res = $UA->request($req); alarm 0; $res = ($res->is_error) ? q{} : $parser->parse($res->content); SKIP: { if (! $res) { skip 'Server response was error, cannot test', 1; } if ($res->is_fault) { fail(failmsg($res->value->string, __LINE__)); } else { is(join(q{}, @{ ref($res) ? $res->value->value : [] }), $srv->get_method('system.identity')->{help} . $srv->get_method('system.status')->{help}, 'system.methodHelp("system.identity", "system.status") test'); } } # If the response was any kind of error, kill and re-start the server, as # HTTP::Message::content might have killed it already via croak(). if (! $res) { # $res was made null above if it was an error stop_server $child; # Start the server again $child = start_server $srv; } # system.methodHelp with an invalid argument $req->content(RPC::XML::request->new('system.methodHelp', 'system.bad')->as_string); alarm 120; $res = $UA->request($req); alarm 0; $res = ($res->is_error) ? q{} : $parser->parse($res->content); SKIP: { if (! $res) { skip 'Server response was error, cannot test', 2; } ok($res->value->is_fault(), 'system.methodHelp returned fault for unknown method'); like($res->value->string, qr/Method.*unknown/, 'system.methodHelp("system.bad") correct faultString'); } # If the response was any kind of error, kill and re-start the server, as # HTTP::Message::content might have killed it already via croak(). if (! $res) { # $res was made null above if it was an error stop_server $child; # Start the server again $child = start_server $srv; } # system.methodSignature $req->content(RPC::XML::request->new('system.methodSignature', 'system.methodHelp')->as_string); alarm 120; $res = $UA->request($req); alarm 0; $res = ($res->is_error) ? q{} : $parser->parse($res->content); SKIP: { if (! $res) { skip 'Server response was error, cannot test', 1; } $meth = $srv->get_method('system.methodHelp'); if (! blessed $meth) { fail(failmsg($meth, __LINE__)); } else { is(join(q{}, sort map { join q{ } => @{$_} } @{ ref($res) ? $res->value->value : [] }), join(q{} => sort @{$meth->{signature}}), 'system.methodSignature("system.methodHelp") test'); } } # If the response was any kind of error, kill and re-start the server, as # HTTP::Message::content might have killed it already via croak(). if (! $res) { # $res was made null above if it was an error stop_server $child; # Start the server again $child = start_server $srv; } # system.methodSignature, with an invalid request $req->content(RPC::XML::request->new('system.methodSignature', 'system.bad')->as_string); alarm 120; $res = $UA->request($req); alarm 0; $res = ($res->is_error) ? q{} : $parser->parse($res->content); SKIP: { if (! $res) { skip 'Server response was error, cannot test', 2; } ok($res->value->is_fault(), 'system.methodSignature returned fault for unknown method'); like($res->value->string, qr/Method.*unknown/, 'system.methodSignature("system.bad") correct faultString'); } # If the response was any kind of error, kill and re-start the server, as # HTTP::Message::content might have killed it already via croak(). if (! $res) { # $res was made null above if it was an error stop_server $child; # Start the server again $child = start_server $srv; } # system.introspection $req->content(RPC::XML::request->new('system.introspection')->as_string); alarm 120; $res = $UA->request($req); alarm 0; $res = ($res->is_error) ? q{} : $parser->parse($res->content); SKIP: { if (! $res) { skip 'Server response was error, cannot test', 1; } if ($res->is_fault) { fail(failmsg($res->value->string, __LINE__)); } else { $list = $res->value->value; $bucket = 0; %seen = (); for my $result (@{$list}) { if ($seen{$result->{name}}++) { # If we somehow get the same name twice, that is a point off $bucket++; next; } $meth = $srv->get_method($result->{name}); if ($meth) { my $result_sig = join q{} => sort @{$result->{signature}}; my $method_sig = join q{} => sort @{$meth->{signature}}; # A point off unless all three of these match if (($meth->{help} ne $result->{help}) || ($meth->{version} ne $result->{version}) || ($result_sig ne $method_sig)) { $bucket++; } } else { # That is also a point $bucket++; } } ok(! $bucket, 'system.introspection passed with no errors'); } } # If the response was any kind of error, kill and re-start the server, as # HTTP::Message::content might have killed it already via croak(). if (! $res) { # $res was made null above if it was an error stop_server $child; # Start the server again $child = start_server $srv; } # system.multicall $req->content(RPC::XML::request->new('system.multicall', [ { methodName => 'system.identity' }, { methodName => 'system.listMethods', params => [ 'intro' ] } ])->as_string); alarm 120; $res = $UA->request($req); alarm 0; $res = ($res->is_error) ? q{} : $parser->parse($res->content); SKIP: { if (! $res) { skip 'Server response was error, cannot test', 2; } 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] : q{}), 'system.introspection', 'system.multicall response elt [1][0] is correct'); } } # If the response was any kind of error, kill and re-start the server, as # HTTP::Message::content might have killed it already via croak(). if (! $res) { # $res was made null above if it was an error stop_server $child; # Start the server again $child = start_server $srv; } # system.multicall, with an attempt at illegal recursion $req->content(RPC::XML::request->new('system.multicall', [ { methodName => 'system.identity' }, { methodName => 'system.multicall', params => [ 'intro' ] } ])->as_string); alarm 120; $res = $UA->request($req); alarm 0; $res = ($res->is_error) ? q{} : $parser->parse($res->content); SKIP: { if (! $res) { skip 'Server response was error, cannot test', 2; } $res = $res->value; ok($res->is_fault, 'system.multicall returned fault on attempt at recursion'); like($res->string, qr/Recursive/, 'system.multicall recursion attempt set correct faultString'); } # If the response was any kind of error, kill and re-start the server, as # HTTP::Message::content might have killed it already via croak(). if (! $res) { # $res was made null above if it was an error stop_server $child; # Start the server again $child = start_server $srv; } # system.multicall, with bad data on one of the call specifications $req->content(RPC::XML::request->new('system.multicall', [ { methodName => 'system.identity' }, { methodName => 'system.status', params => 'intro' } ])->as_string); alarm 120; $res = $UA->request($req); alarm 0; $res = ($res->is_error) ? q{} : $parser->parse($res->content); SKIP: { if (! $res) { skip 'Server response was error, cannot test', 2; } $res = $res->value; ok($res->is_fault, 'system.multicall returned fault when passed a bad param array'); like($res->string, qr/value for.*params.*not an array/i, 'system.multicall bad param array set correct faultString'); } # If the response was any kind of error, kill and re-start the server, as # HTTP::Message::content might have killed it already via croak(). if (! $res) { # $res was made null above if it was an error stop_server $child; # Start the server again $child = start_server $srv; } # system.multicall, with bad data in the request itself $req->content(RPC::XML::request->new('system.multicall', [ { methodName => 'system.identity' }, 'This is not acceptable data' ])->as_string); alarm 120; $res = $UA->request($req); alarm 0; $res = ($res->is_error) ? q{} : $parser->parse($res->content); SKIP: { if (! $res) { skip 'Server response was error, cannot test', 2; } $res = $res->value; ok($res->is_fault, 'system.multicall returned fault on bad input'); like($res->string, qr/one.*array element.*not a struct/i, 'system.multicall bad input set correct faultString'); } # If the response was any kind of error, kill and re-start the server, as # HTTP::Message::content might have killed it already via croak(). if (! $res) { # $res was made null above if it was an error stop_server $child; # Start the server again $child = start_server $srv; } # system.status, once more, to check the total_requests value $req->content(RPC::XML::request->new('system.status')->as_string); alarm 120; $res = $UA->request($req); alarm 0; $res = ($res->is_error) ? q{} : $parser->parse($res->content); SKIP: { if (! $res) { skip 'Server response was error, cannot test', 1; } $res = $res->value->value; is($res->{total_requests}, 20, 'system.status, final request tally'); } # This time we have to stop the server regardless of whether the response was # an error. We're going to add some more methods to test some of the error code # and other bits in RPC::XML::Procedure. stop_server $child; $srv->add_method({ type => 'procedure', name => 'argcount.p', signature => [ 'int' ], code => sub { return scalar @_; }, }); $srv->add_method({ name => 'argcount.m', signature => [ 'int' ], code => sub { return scalar @_; }, }); $srv->add_method({ type => 'function', name => 'argcount.f', code => sub { return scalar @_; }, }); $srv->add_method({ name => 'die1', signature => [ 'int' ], code => sub { die "die\n"; }, }); { ## no critic(RequireCarping) $srv->add_method({ name => 'die2', signature => [ 'int' ], code => sub { die RPC::XML::fault->new(999, 'inner fault'); }, }); } # Start the server again, with the new methods $child = start_server $srv; # First, call the argcount.? routines, to see that we are getting the correct # number of args passed in. Up to now, everything running on $srv has been in # the RPC::XML::Method class. This will test some of the other code. my @returns = (); local $SIG{ALRM} = sub { $bucket++ }; for my $type (qw(p m f)) { $req->content(RPC::XML::request->new("argcount.$type")->as_string); $bucket = 0; alarm 120; $res = $UA->request($req); alarm 0; if ($bucket) { push @returns, 'timed-out'; } else { $res = $parser->parse($res->content); if (ref($res) ne 'RPC::XML::response') { push @returns, 'parse-error'; } else { push @returns, $res->value->value; } } } # Finally, test what we got from those three calls: is(join(q{,} => @returns), '0,1,0', 'Arg-count testing of procedure types'); # While we're at it... test that a ::Function can take any args list $req->content(RPC::XML::request->new('argcount.f', 1, 1, 1)->as_string); $bucket = 0; alarm 120; $res = $UA->request($req); alarm 0; SKIP: { if ($bucket) { skip 'Second call to argcount.f timed out', 1; } else { $res = $parser->parse($res->content); if (ref($res) ne 'RPC::XML::response') { skip 'Second call to argcount.f failed to parse', 1; } else { is($res->value->value, 3, 'A function takes any argslist'); } } } # And test that those that aren't ::Function recognize bad parameter lists $req->content(RPC::XML::request->new('argcount.p', 1, 1, 1)->as_string); $bucket = 0; alarm 120; $res = $UA->request($req); alarm 0; SKIP: { if ($bucket) { skip 'Second call to argcount.f timed out', 1; } else { $res = $parser->parse($res->content); if (ref($res) ne 'RPC::XML::response') { skip 'Second call to argcount.f failed to parse', 1; } else { if (! $res->is_fault) { skip 'Test did not return fault, cannot test', 2; } is($res->value->code, 201, 'Bad params list test: Correct faultCode'); like($res->value->string, qr/no matching signature for the argument list/, 'Bad params list test: Correct faultString'); } } } # Test behavior when the called function throws an exception my %die_tests = ( die1 => { code => 300, string => "Code execution error: Method die1 returned error: die\n", }, die2 => { code => 999, string => 'inner fault', }, ); for my $test (sort keys %die_tests) { $req->content(RPC::XML::request->new($test)->as_string); $bucket = 0; alarm 120; $res = $UA->request($req); alarm 0; SKIP: { if ($bucket) { skip "Test '$test' timed out, cannot test results", 2; } else { $res = $parser->parse($res->content); if (ref($res) ne 'RPC::XML::response') { skip "Test '$test' failed to parse, cannot test results", 2; } else { if (! $res->is_fault) { skip "Test '$test' did not return fault, cannot test", 2; } is($res->value->code, $die_tests{$test}{code}, "Test $test: Correct faultCode"); is($res->value->string, $die_tests{$test}{string}, "Test $test: Correct faultString"); } } } } # Don't leave any children laying around stop_server $child, 'final'; exit; sub find_port_in_use { my $start_at = shift; $start_at ||= 80; for my $port ($start_at .. ($start_at + 1000)) { my $sock = IO::Socket->new( Domain => AF_INET, PeerAddr => 'localhost', PeerPort => $port ); return $port if ref $sock; } return -1; } RPC-XML-0.82/t/90_rt50013_parser_bugs.t0000644000175000017500000000110012420753461016133 0ustar rjrayrjray#!/usr/bin/env perl # https://rt.cpan.org/Ticket/Display.html?id=50013 # # Ensure that RPC::XML::Parser::new() maintains backwards-compatibility use strict; use warnings; use Carp qw(croak); use Test::More; use RPC::XML::Parser; plan tests => 2; my $parser; # Since the changed behaviour was to die, to be safe use eval here if (! eval { $parser = RPC::XML::Parser->new(); 1; }) { croak "Creating the parser died, cannot continue: $@"; } isa_ok($parser, 'RPC::XML::Parser', 'Parser object'); isa_ok($parser, 'RPC::XML::Parser::XMLParser', 'Parser object'); exit; RPC-XML-0.82/t/namespace1.xpl0000644000175000017500000000047211356231360014575 0ustar rjrayrjray nstest1 Test::NS 1.0 string Namespace test method for RPC::XML::Method suite sub test { __PACKAGE__ } RPC-XML-0.82/t/15_serialize.t0000644000175000017500000001353513774651431014533 0ustar rjrayrjray#!/usr/bin/env perl # Test the serialization of XML structures to filehandles ## no critic(RequireBriefOpen) ## no critic(RequireCheckedClose) use strict; use warnings; use Carp qw(croak); use Test::More; use File::Spec; use IO::Handle; use RPC::XML ':all'; plan tests => 20; my ($dir, $vol, $fh, $file, $tmpfile, $faux_req, $faux_res, $ofh, $data); # We'll be using the extension here: $RPC::XML::ALLOW_NIL = 1; ($vol, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0)); $dir = File::Spec->catpath($vol, $dir, q{}); $file = File::Spec->catfile($dir, 'svsm_text.gif'); $tmpfile = File::Spec->catfile($dir, "__tmp__${$}__"); END { # Make sure we don't leave any droppings... if (-f $tmpfile) { unlink $tmpfile; } } if (! (open $fh, '<', $file)) { croak "Could not open $file for reading: $!"; } $faux_req = RPC::XML::request->new( 'test', RPC_STRING 'string', RPC_INT 10, RPC_I4 20, RPC_I8 4_294_967_296, RPC_DOUBLE 0.5, RPC_BOOLEAN 1, RPC_DATETIME_ISO8601 time2iso8601(), [ qw(a b c) ], { one => 2 }, RPC_NIL, RPC_BASE64 $fh ); # This is a good place to test the length() method, while we're at it is(length($faux_req->as_string), $faux_req->length, 'Testing length() method'); if (! (open $ofh, '+>', $tmpfile)) { croak "Could not open $tmpfile for read/write: $!"; } $ofh->autoflush(1); $faux_req->serialize($ofh); ok(1, 'serialize method did not croak'); # Just happy we made it this far. is(-s $ofh, length($faux_req->as_string), 'File size is correct'); seek $ofh, 0, 0; $data = q{}; read $ofh, $data, -s $ofh; is($data, $faux_req->as_string, 'File content is correct'); # Done with these for now close $fh; close $ofh; unlink $tmpfile; # We'll be doing this next set twice, as RPC::XML::response::serialize has a # slightly different code-path for faults and all other responses. if (! (open $ofh, '+>', $tmpfile)) { croak "Could not open $tmpfile for read/write: $!"; } $ofh->autoflush(1); $faux_res = RPC::XML::response->new(RPC::XML::fault->new(1, 'test')); is(length($faux_res->as_string), $faux_res->length, 'length() in fault response'); $faux_res->serialize($ofh); # Again, this means that all the triggered calls managed to not die ok(1, 'serialize method did not croak'); is(-s $ofh, length($faux_res->as_string), 'Fault-response file size OK'); seek $ofh, 0, 0; $data = q{}; read $ofh, $data, -s $ofh; # There have been some changes to how Perl handles iteration of hash keys. # As a result, this test has started failing a lot because of the order of # keys when serialized doesn't match the order of keys from as_string(). So # to get around this, just compare it to both variations that can occur. my $variant1 = '' . 'faultString' . 'testfaultCode' . '1'; my $variant2 = '' . 'faultCode1' . 'faultStringtest' . ''; ok( ($data eq $variant1) || ($data eq $variant2), 'Fault-response content is correct' ); close $ofh; unlink $tmpfile; # Round two, with normal response (not fault) if (! (open $ofh, '+>', $tmpfile)) { croak "Could not open $tmpfile for read/write: $!"; } $ofh->autoflush(1); $faux_res = RPC::XML::response->new('test'); is(length($faux_res->as_string), $faux_res->length, 'length() in normal response'); $faux_res->serialize($ofh); # Again, this means that all the triggered calls managed to not die ok(1, 'serialize method did not croak'); is(-s $ofh, length($faux_res->as_string), 'Normal response file size OK'); seek $ofh, 0, 0; $data = q{}; read $ofh, $data, -s $ofh; is($data, $faux_res->as_string, 'Normal response content OK'); close $ofh; unlink $tmpfile; # Test some extra code-paths in the base64 logic: # Route 1: In-memory content if (! (open $ofh, '+>', $tmpfile)) { croak "Could not open $tmpfile for read/write: $!"; } $ofh->autoflush(1); $faux_res = RPC::XML::response->new(RPC::XML::base64->new('a simple string')); is(length($faux_res->as_string), $faux_res->length, 'length() in normal response'); $faux_res->serialize($ofh); # Again, this means that all the triggered calls managed to not die ok(1, 'serialize method did not croak'); is(-s $ofh, length($faux_res->as_string), 'Normal response file size OK'); seek $ofh, 0, 0; $data = q{}; read $ofh, $data, -s $ofh; is($data, $faux_res->as_string, 'Normal response content OK'); close $ofh; unlink $tmpfile; # Route 2: Spool from a file that is already encoded if (! (open $ofh, '+>', $tmpfile)) { croak "Could not open $tmpfile for read/write: $!"; } $ofh->autoflush(1); $file = File::Spec->catfile($dir, 'svsm_text.b64'); if (! (open $fh, '<', $file)) { croak "Could not open $file for reading: $!"; } $faux_res = RPC::XML::response->new(RPC::XML::base64->new($fh, 'encoded')); is(length($faux_res->as_string), $faux_res->length, 'length() in normal response'); $faux_res->serialize($ofh); # Again, this means that all the triggered calls managed to not die ok(1, 'serialize method did not croak'); # If we're on Windows, then the re-spooling of the content of svsm_text.b64 # introduced 32 extra bytes (due to \n\r silliness). Set $offset to 0 or 32 # depending on the value of $^O. my $offset = ($^O =~ /mswin/i) ? 32 : 0; is(-s $ofh, length($faux_res->as_string) + $offset, 'Normal response file size OK'); seek $ofh, 0, 0; $data = q{}; read $ofh, $data, -s $ofh; is($data, $faux_res->as_string, 'Normal response content OK'); close $fh; close $ofh; unlink $tmpfile; exit; RPC-XML-0.82/t/12_nil.t0000644000175000017500000000253713774651431013323 0ustar rjrayrjray#!/usr/bin/env perl # Test the data-manipulation routines in RPC::XML ## no critic(RequireInterpolationOfMetachars) use strict; use warnings; use Test::More; use RPC::XML 'smart_encode'; my $obj; plan tests => 11; # First ensure that we can't actually create these objects unless we explicitly # enable the extension: $obj = RPC::XML::nil->new(); ok(! defined($obj), 'Did not create a nil without first enabling nil'); like($RPC::XML::ERROR, qr/RPC::XML::ALLOW_NIL must be set/, '$RPC::XML::ERROR correctly set'); # Enable and try again $RPC::XML::ALLOW_NIL = 1; $obj = RPC::XML::nil->new(); isa_ok($obj, 'RPC::XML::nil'); # Check stringification and length is($obj->as_string, '', 'Stringification'); is($obj->length, 6, 'Length of element'); # Test the convenience function { use RPC::XML 'RPC_NIL'; isa_ok(RPC_NIL, 'RPC::XML::nil'); } # Verify that anything passed to the constructor has no effect on the created # object: $obj = RPC::XML::nil->new('ignored'); isa_ok($obj, 'RPC::XML::nil'); is($obj->as_string, '', 'Stringification'); is($obj->length, 6, 'Length of element'); # With nil enabled, smart_encode() should now encode undef as a nil, not as a # null-length string: $obj = smart_encode(undef); is($obj->type, 'nil', 'smart_encode undef->string type'); is($obj->value, undef, 'smart_encode undef->string value'); exit 0; RPC-XML-0.82/t/35_namespaces.t0000644000175000017500000000345713774651431014667 0ustar rjrayrjray#!/usr/bin/env perl # Test the RPC::XML::Method class ## no critic(RequireInterpolationOfMetachars) use strict; use warnings; use File::Spec; use Test::More; use RPC::XML::Procedure; plan tests => 7; my ($obj, $obj2, $dir, $vol); ($vol, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0)); $dir = File::Spec->catpath($vol, $dir, q{}); # The organization of the test suites is such that we assume anything that # runs before the current suite is 100%. Thus, no consistency checks on # any other classes are done. $obj = RPC::XML::Method->new(File::Spec->catfile($dir, 'namespace1.xpl')); # We do an @ISA check again, because we've added the tag to the # mix isa_ok($obj, 'RPC::XML::Method', '$obj'); SKIP: { if (ref($obj) ne 'RPC::XML::Method') { skip 'Cannot test without object', 2; } is($obj->namespace(), 'Test::NS', 'Test namespace() method'); is($obj->code->(), 'Test::NS', 'Sub closure value of __PACKAGE__'); } $obj2 = RPC::XML::Method->new(File::Spec->catfile($dir, 'namespace2.xpl')); isa_ok($obj2, 'RPC::XML::Method'); SKIP: { if (ref($obj2) ne 'RPC::XML::Method') { skip 'Cannot test without object', 2; } is($obj2->namespace(), 'Test::NS', 'Test namespace() method (dotted namespace)'); is($obj2->code->(), 'Test::NS', 'Sub closure value of __PACKAGE__ (dotted namespace)'); } { ## no critic(ProhibitPackageVars) $Test::NS::value = 0; $Test::NS::value++; # Just to suppress the "used only once" warning $obj = RPC::XML::Method->new(File::Spec->catfile($dir, 'namespace3.xpl')); SKIP: { if (ref($obj) ne 'RPC::XML::Method') { skip 'Cannot test without object', 1; } ok($obj->code->(), 'Reading namespace-local value declared outside XPL'); } } exit; RPC-XML-0.82/t/20_xml_parser.t0000644000175000017500000004442313774651431014714 0ustar rjrayrjray#!/usr/bin/env perl # Test the RPC::XML::Parser::XMLParser class ## no critic(RequireInterpolationOfMetachars) ## no critic(RequireBriefOpen) ## no critic(RequireCheckedClose) use strict; use warnings; use Carp qw(carp croak); use Test::More; use File::Spec; use RPC::XML ':all'; use RPC::XML::Parser::XMLParser; my ($p, $req, $res, $ret, $dir, $vol, $file, $fh, $str, $badstr); plan tests => 137; ($vol, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0)); $dir = File::Spec->catpath($vol, $dir, q{}); $file = File::Spec->catfile($dir, 'svsm_text.gif'); # The organization of the test suites is such that we assume anything that # runs before the current suite is 100%. Thus, no consistency checks on # RPC::XML::* classes are done, only on the data and return values of this # class under consideration, RPC::XML::Parser::XMLParser. $p = RPC::XML::Parser::XMLParser->new(); isa_ok($p, 'RPC::XML::Parser::XMLParser', '$p'); isa_ok($p, 'RPC::XML::Parser', '$p'); # Make sure you can't call parse_more() or parse_done() on a vanilla # RPC::XML::Parser::XMLParser instance: $ret = eval { $p->parse_more(); 1; }; ok(! $ret, 'Calling parse_more on $p failed'); like($@, qr/Must be called on a push-parser instance/, 'Correct error message'); $ret = eval { $p->parse_done(); 1; }; ok(! $ret, 'Calling parse_done on $p failed'); like($@, qr/Must be called on a push-parser instance/, 'Correct error message'); $req = RPC::XML::request->new('test.method'); $ret = $p->parse($req->as_string); isa_ok($ret, 'RPC::XML::request', '$ret'); is($ret->name, 'test.method', 'Correct request method name'); # Try a request with no block at all: $str = <<'EO_STR'; test.method EO_STR $ret = $p->parse($str); isa_ok($ret, 'RPC::XML::request', '$ret'); is($ret->name, 'test.method', 'Correct request method name'); ok(ref($ret->args) eq 'ARRAY' && @{$ret->args} == 0, 'No block yields correct args list'); $res = RPC::XML::response->new(RPC::XML::string->new('test response')); $ret = $p->parse($res->as_string); isa_ok($ret, 'RPC::XML::response', '$ret'); is($ret->value->value, 'test response', 'Response value'); # Test some badly-formed data my $tmp = $res->as_string; $tmp =~ s/methodResponse/mR/g; $ret = $p->parse($tmp); ok(! ref($ret), 'Bad XML did not parse'); like($ret, qr/Unknown tag/, 'Parse failure returned error'); # Make sure that the parser can handle all of the core data-types. Easiest way # to do this is to create a fake request with a parameter of each type (except # base64, which is getting exercised later on). $req = RPC::XML::request->new( 'parserTest', RPC::XML::i4->new(1), RPC::XML::int->new(2), RPC::XML::i8->new(3), RPC::XML::double->new(4.5), RPC::XML::string->new('string'), RPC::XML::boolean->new('true'), RPC::XML::datetime_iso8601->new('2008-09-29T12:00:00-07:00'), [ 0, 1 ], # Array, auto-encoded { a => 1, b => 2 }, # Hash/struct, also auto-encoded ); $ret = $p->parse($req->as_string); isa_ok($ret, 'RPC::XML::request', 'Parse of RPC::XML::request block'); SKIP: { if (ref($ret) ne 'RPC::XML::request') { skip 'RPC::XML::request object not properly parsed, cannot test.', 20; } is($ret->name, 'parserTest', 'Properly parsed /methodCall/methodName'); my $args = $ret->args; is(scalar @{$args}, 9, 'Parser created correct-length args list'); # I could (and should) probably turn this into a loop with a table of # data, but I'm lazy right this moment. isa_ok($args->[0], 'RPC::XML::i4', 'Parse of argument'); is($args->[0]->value, 1, 'RPC::XML::i4 value parsed OK'); isa_ok($args->[1], 'RPC::XML::int', 'Parse of argument'); is($args->[1]->value, 2, 'RPC::XML::int value parsed OK'); isa_ok($args->[2], 'RPC::XML::i8', 'Parse of argument'); is($args->[2]->value, 3, 'RPC::XML::i8 value parsed OK'); isa_ok($args->[3], 'RPC::XML::double', 'Parse of argument'); is($args->[3]->value, 4.5, 'RPC::XML::double value parsed OK'); isa_ok($args->[4], 'RPC::XML::string', 'Parse of argument'); is($args->[4]->value, 'string', 'RPC::XML::string value parsed OK'); isa_ok($args->[5], 'RPC::XML::boolean', 'Parse of argument'); ok($args->[5]->value, 'RPC::XML::boolean value parsed OK'); isa_ok($args->[6], 'RPC::XML::datetime_iso8601', 'Parse of argument'); is($args->[6]->value, '20080929T12:00:00-07:00', 'RPC::XML::dateTime.iso8601 value parsed OK'); isa_ok($args->[7], 'RPC::XML::array', 'Parse of argument'); is(scalar(@{$args->[7]->value}), 2, 'RPC::XML::array value parsed OK'); isa_ok($args->[8], 'RPC::XML::struct', 'Parse of argument'); is(scalar(keys %{$args->[8]->value}), 2, 'RPC::XML::struct value parsed OK'); } # Prior to this, we've confirmed that spooling base64 data to files works. # Here, we test whether the parser (when configured to do so) can create # filehandles as well. $p = RPC::XML::Parser::XMLParser->new(base64_to_fh => 1); if (! open $fh, '<', $file) { croak "Error opening $file: $!"; } my $base64 = RPC::XML::base64->new($fh); $req = RPC::XML::request->new('method', $base64); # Start testing my $spool_ret = $p->parse($req->as_string); isa_ok($spool_ret, 'RPC::XML::request', '$spool_ret'); is($spool_ret->name, 'method', 'Request, base64 spooling, method name test'); ok(ref($spool_ret->args), 'Request, base64 spooling, return arg test'); my $new_base64 = $spool_ret->args->[0]; isa_ok($new_base64, 'RPC::XML::base64', '$new_base64'); is($base64->as_string(), $new_base64->as_string, 'Parse base64 spooling, value comparison'); isa_ok($new_base64->{value_fh}, 'GLOB', '$new_base64->{value_fh}'); # Per problem reported by Bill Moseley, check that messages parsed by the # parser class handle the core entities. $tmp = q{Entity test: & < > ' "}; $res = RPC::XML::response->new($tmp); $ret = $p->parse($res->as_string); is($ret->value->value, $tmp, 'RPC::XML::Parser handles core entities'); my $bad_entities = <<'EOX'; ]> metaWeblog.newPost Entity test: &foo; EOX $p = RPC::XML::Parser::XMLParser->new(); $ret = $p->parse($bad_entities); SKIP: { if (! ref $ret) { skip 'Weird entities parsing error in XML::Parser encountered', 1; } my $args = $ret->args; is($args->[0]->value, 'Entity test: ', 'Bad entities ignored'); } # Now test passing of various references to the parser $p = RPC::XML::Parser::XMLParser->new(); $str = RPC::XML::request->new('test.method')->as_string; $ret = $p->parse(\$str); isa_ok($ret, 'RPC::XML::request', '$ret from scalar reference'); ok(ref($ret) && ($ret->name eq 'test.method'), 'Correct request method name'); my $tmpfile = File::Spec->catfile($dir, "tmp_$$.xml"); SKIP: { if (! open $fh, '+>', $tmpfile) { skip "Open of $tmpfile failed, cannot test on it ($!)", 2; } print {$fh} $str; seek $fh, 0, 0; $ret = $p->parse($fh); isa_ok($ret, 'RPC::XML::request', '$ret from glob reference'); ok((ref $ret and ($ret->name eq 'test.method')), 'Correct request method name'); close $fh; unlink $tmpfile; } # Tweak the XML to test the error cases $str =~ s{}{}; $ret = $p->parse(\$str); ok(! ref $ret, '$ret error from scalar reference'); like($ret, qr/no element found/, 'Correct error message'); SKIP: { if (! open $fh, '+>', $tmpfile) { skip "Open of $tmpfile failed, cannot test on it ($!)", 2; } print {$fh} $str; seek $fh, 0, 0; $ret = $p->parse($fh); ok(! ref $ret, '$ret error from glob reference'); like($ret, qr/no element found/, 'Correct error message'); close $fh; unlink $tmpfile; } # Try an unusable reference $ret = $p->parse([]); ok(! ref $ret, 'Unusable reference did not parse to anything'); like($ret, qr/Unusable reference type/, 'Correct error message'); # Negative testing-- try to break the parser my $bad_counter = 1; sub test_bad_xml { my ($badstring, $message) = @_; $ret = $p->parse($badstring); ok(! ref $ret, "Bad XML <$bad_counter>"); like($ret, qr/$message/, 'Correct error message'); $bad_counter++; return; } $str = RPC::XML::request->new('name', 'foo')->as_string; ($badstr = $str) =~ s/>namebad^name.*}{}; test_bad_xml($badstr, 'No methodName tag detected'); ($badstr = $str) =~ s{}{}; test_bad_xml($badstr, 'Extra content in "methodCall"'); ($badstr = $str) =~ s{params>}{paramss>}g; test_bad_xml($badstr, 'Unknown tag encountered: paramss'); $str = RPC::XML::response->new(1)->as_string; ($badstr = $str) =~ s{}{}; test_bad_xml($badstr, 'Stack corruption detected'); ($badstr = $str) =~ s{}{}; test_bad_xml($badstr, 'No found within container'); ($badstr = $str) =~ s{param>}{paramm>}g; test_bad_xml($badstr, 'Unknown tag encountered: paramm'); ($badstr = $str) =~ s{}{}; test_bad_xml($badstr, 'Illegal content in param tag'); ($badstr = $str) =~ s{value>}{valuee>}g; test_bad_xml($badstr, 'Unknown tag encountered: valuee'); ($badstr = $str) =~ s{>1<}{>foo<}; test_bad_xml($badstr, 'Bad integer'); ($badstr = $str) =~ s{params}{paramss}g; test_bad_xml($badstr, 'Unknown tag encountered: paramss'); $str = RPC::XML::response->new(RPC::XML::fault->new(1, 'foo'))->as_string; ($badstr = $str) =~ s{}{}; test_bad_xml($badstr, 'Stack corruption detected'); ($badstr = $str) =~ s{}{}; $badstr =~ s{}{}; test_bad_xml($badstr, 'Unknown tag encountered: valuee'); # These are a little more hairy, trying to pass an invalid fault structure. # Gonna hard-code the strings rather than trying to transform $str. $badstr = <<'EO_BADSTR'; str faultString foo faultCode 1 EO_BADSTR test_bad_xml($badstr, 'Bad content inside struct block'); $badstr = <<'EO_BADSTR'; faultString foo faultCode 1 extraMember 1 EO_BADSTR test_bad_xml($badstr, 'Extra struct fields not allowed'); $badstr = <<'EO_BADSTR'; EO_BADSTR test_bad_xml($badstr, 'Stack corruption detected'); $badstr = <<'EO_BADSTR'; foo EO_BADSTR test_bad_xml($badstr, 'Only a value may be within a '); $RPC::XML::ALLOW_NIL = 1; $str = RPC::XML::response->new(undef)->as_string; ($badstr = $str) =~ s{}{undef}; test_bad_xml($badstr, ' element must be empty'); $str = RPC::XML::request->new('foo', 1)->as_string; ($badstr = $str) =~ s{}{}; test_bad_xml($badstr, 'Illegal content in params tag'); ($badstr = $str) =~ s{.*}{}; test_bad_xml($badstr, 'Illegal content in params tag'); ($badstr = $str) =~ s{}{}; $badstr =~ s{}{}; test_bad_xml($badstr, 'Unknown tag encountered: valuee'); ($badstr = $str) =~ s{}{1}; test_bad_xml($badstr, 'Stack corruption detected'); ($badstr = $str) =~ s{1}{foo}; test_bad_xml($badstr, 'Bad floating-point data read'); # Parser errors specific to arrays: $str = RPC::XML::response->new([ 1 ])->as_string; ($badstr = $str) =~ s{}{}; test_bad_xml($badstr, 'Illegal content in array tag'); ($badstr = $str) =~ s{}{}; $badstr =~ s{}{}; test_bad_xml($badstr, 'Unknown tag encountered: valuee'); ($badstr = $str) =~ s{1}{foo}; test_bad_xml($badstr, 'Bad integer data read'); $badstr = <<'EO_BADSTR'; 1 foo EO_BADSTR test_bad_xml($badstr, 'Bad content inside data block'); $badstr = <<'EO_BADSTR'; foo 1 EO_BADSTR test_bad_xml($badstr, 'Illegal content in data tag'); # Parser errors specific to structs: $str = RPC::XML::response->new({ foo => 1 })->as_string; ($badstr = $str) =~ s{}{}; test_bad_xml($badstr, 'Unknown tag encountered: foo'); ($badstr = $str) =~ s{name>}{namee>}g; test_bad_xml($badstr, 'Unknown tag encountered: namee'); ($badstr = $str) =~ s{1}{foo}; test_bad_xml($badstr, 'Bad integer data'); $badstr = <<'EO_BADSTR'; foo 1 1 EO_BADSTR test_bad_xml($badstr, 'Element mismatch, expected to see name'); $badstr = <<'EO_BADSTR'; 1 foo EO_BADSTR test_bad_xml($badstr, 'Element mismatch, expected to see value'); $badstr = <<'EO_BADSTR'; foo 1 1 EO_BADSTR test_bad_xml($badstr, 'Element mismatch, expected to see member'); $badstr = <<'EO_BADSTR'; 1 foo 1 EO_BADSTR test_bad_xml($badstr, 'Bad content inside struct block'); # Some corner-cases in responses $badstr = <<'EO_BADSTR'; 1 1 EO_BADSTR test_bad_xml($badstr, 'invalid: too many params'); $badstr = <<'EO_BADSTR'; EO_BADSTR test_bad_xml($badstr, 'invalid: no params'); $badstr = <<'EO_BADSTR'; EO_BADSTR test_bad_xml($badstr, 'No parameter was declared'); # Corner case(s) in requests $badstr = <<'EO_BADSTR'; foo foo EO_BADSTR test_bad_xml($badstr, 'methodName tag must immediately follow a methodCall'); # Test the "none of the above" error case ($badstr = $str) =~ s/struct/structt/g; test_bad_xml($badstr, 'Unknown tag encountered: structt'); # Test parse-end errors $badstr = <<'EO_BADSTR'; 1 EO_BADSTR test_bad_xml($badstr, 'End-of-parse error'); # Test some of the failures related to Base64-spooling. This can only be tested # on non-Windows systems, as to cause some of the failures we'll need to create # an un-writable directory (and Windows doesn't have the same chmod concept we # have in other places). SKIP: { if ($^O eq 'MSWin32' || $^O eq 'cygwin') { skip 'Tests involving directory permissions skipped on Windows', 1; } # Also cannot be reliably tested if running as root: if ($< == 0) { skip 'Tests involving directory permissions skipped under root', 1; } my $baddir = File::Spec->catdir(File::Spec->tmpdir(), "baddir_$$"); if (! mkdir $baddir) { skip "Skipping, failed to create dir $baddir: $!", 1; } if (! chmod oct(600), $baddir) { skip "Skipping, failed to chmod dir $baddir: $!", 1; } $p = RPC::XML::Parser::XMLParser->new( base64_to_fh => 1, base64_temp_dir => $baddir ); if (! open $fh, '<', $file) { croak "Error opening $file: $!"; } my $base64fail = RPC::XML::base64->new($fh); $req = RPC::XML::request->new('method', $base64fail); $ret = $p->parse($req->as_string); like($ret, qr/Error opening temp file for base64/, 'Opening Base64 spoolfile correctly failed'); if (! rmdir $baddir) { carp "Failed to remove temp-dir $baddir: $!"; } } exit 0; RPC-XML-0.82/t/90_rt58323_push_parser.t0000644000175000017500000000265112420753461016202 0ustar rjrayrjray#!/usr/bin/env perl # https://rt.cpan.org/Ticket/Display.html?id=58323 # # Test that the parser-factory instance classes correctly cause errors when # passed null strings or 0 as an argument to parse(). use strict; use warnings; use Module::Load; use Test::More; use RPC::XML::Parser::XMLParser; plan tests => 4; my ($parser, $parse_result); my $can_libxml = eval { load RPC::XML::Parser::XMLLibXML; 1; }; # To test this, instantiate each parser then call the ->parse() method with # both a null string and with 0 as an argument. Each call should throw an # error about failed parsing. If they don't, the test has failed. # First test the class we always have, RPC::XML::Parser::XMLParser $parser = RPC::XML::Parser::XMLParser->new(); # Empty string $parse_result = $parser->parse(q{}); ok(! ref($parse_result), 'RPC::XML::Parser::XMLParser null string'); # Zero $parse_result = $parser->parse(0); ok(! ref($parse_result), 'RPC::XML::Parser::XMLParser zero value'); # Next, test RPC::XML::Parser::XMLLibXML (which we might not have) SKIP: { if (! $can_libxml) { skip 'XML::LibXML not installed', 2; } $parser = RPC::XML::Parser::XMLLibXML->new(); # Empty string $parse_result = $parser->parse(q{}); ok(! ref($parse_result), 'RPC::XML::Parser::XMLLibXML null string'); # Zero $parse_result = $parser->parse(0); ok(! ref($parse_result), 'RPC::XML::Parser::XMLLibXML zero value'); } exit; RPC-XML-0.82/t/svsm_text.b640000644000175000017500000000460411622765353014417 0ustar rjrayrjrayR0lGODlhYwEcAOMAAAAAAFVVVTk5OR0dHaqqqo6OjnJycv///+Pj48fHxwAAAAAAAAAAAAAAAAAA AAAAACH5BAEAAAcALAAAAABjARwAAAT+8MiJiJ046827/2AojmQZVpeprmzrvnBHDEBdC0lmA4RE 7JOALRCDGXY5zLFmIAlrRMmuV5TRdriq5md7PaeZwq5GdXFrpTNAG/qOeRjwQR0cslnqskRg04O+ UQdyd3VvZIRzQC5uNQUZjHAvdCSTiFuGOwgTcpWAliY7gVJdTnajh5Zqhpp3lSyQooJvfiuuIbaf B1dMBEtMm30+igeeuSO7AhgJNsmlUMCoiLsABr07Ta3Dr4YYqtEtuB/hiAjXE2fNcxYErJUJ60nG bdpnsX+mst9s5TbYiTeExjkDwKdGvCUF9dXSdovhpzwYBBhg5WNdu2HvLMSbkMBAgAD+BjYq8whS pLoLCAp8LEDxko14X/yk/BiggMhi+SJ1o6knI4F4PlsKCzZBolAJHT+GlEGzWgZcM0veY0L0QEFf Os/RZMkhgdIKDpPWFApVpdSnGg8g8BiPwNaWauzpINoJn9qEQ1oiwHujZaZpWTHwi5aQIgJIAETh HDQH8ABWYp5J+HI0Loi9bwIIjTzm8TmGWCV3iImvD+MZb/wVGqIK8xg9tkInnpsYwZUeCRyXWYbF JLRIdUXbxiQKsI0BcY6/Qc5hV6DjGIzjW1zVWwrPg5nrAqiBNzPfEoYbEiX7+EVSk4l7+JKP+Zmc uzFRUyIfTXjpOl0hngoKZJ/Bb1D+ZJwAjmjAyTA4YSWAG0lwBkABDhaYE0EBTAPeF814F4gvAxRA AF6rPVcVMgRw1swurPTT3BsEbqAgg0hdYwpdGMn4hYQasIfiAQjBV9RxbmUSHhYzosehhzv+Y98B 3lETZCPQ4PVkYkUG4uAOHdIGHIKmAFggZ1EkFAWGv2XIGAYODqXTLkkASAV1qKjBii+a+NLDGeBd eRyOXkoApgS++COmmmukx912BI3WRUxW/SKHm6c8CKiQxAyzQ4HeFRhcohJckc5yATQ5gRgDqLYf f5FSsWkUlWQX6ZeWVnUmR0hUWgNFFniUHCpwRkKmmneqyNl68gXSKnRMlhhqiIT+/iYhexywV89g PRxoAyuD2gqAdpPI2V+zr67223ypcrRBAfhJaO2SxfiSDjE0KbklUYPM+lsPBWm3gQVy9EoFibna UKAdT8iFZrqTHgrvR119aMokTVZjQWHRduGdAO/5qG2hG0dqrCJYrYMOuBGvQ3FO706DsTh8bXsv uNqOaddT60ZSb1U52jHzHPu9WRq99fGno0L7tswcTh10JB2rilj3WsX2hcJdv1ySEspnpJxKSrdB 26ziqMtN5MFhYyRRM7Mxy1AzFTcT7ed3OIuHic+iydF1FJx5d1QHZNeK9AZaM71117QYWigk2FCN nhseY22f1vZxHTTbOG9sXgb+N9lN4+Km/N3N2uWGvu8UL0V3TQ6Ko6r5CiLDMyQUCnf1CBie08dM D8VIzkvr7EBdqJ6U81p11PhM4gbvKejuJO8pVj6H0Wo9uRFEGq9q+LtKBbs5Km0HpuUun8tKlL+N ewCYaoJJH/4hv04GUvCo5t60vYpG/sbLHRte6NXgMq724M7blfeQYgALAUgUDmpenIYnuFvF6Drh OkCaREe/PWQGA/5TS+pEJDzRcKFFCSvdBg6IJiF5i0nQoV6jJFOJQRTsQugZw6e2BwBsdY4ZjiuU K67TQI65EApmw1mu4rELfF1DE2rQztkMFwUS9o0/2Wpf9wo3AdngyApz2iD+/ia4wvyMwQN4EVsS X/eMJxJBCpjiXyWyBaD6cSyM+INUTgqEFVb4T45/ktePJNNG0Y3McLghHP6sZ0H5NOhSEcKfxjjg jY1gJQBF6qDqRjSEIukrJwZ7YH3K0LJaNWkAJZpGD2klMIf9wner0ckgEgJKLGqSIJHkGIdCKUJ3 XMqU5FokJkuELAnWRxRLTBsZLzgB/Ohrih+4nzIMMYCE0G2S0XBaYBjlAT3xb5hjCMTSHqaN/XgG lTBbZJPGYCoWCkNu2cwhBjHxTV1a8xuo6QyOqsdAZRgnFq7Bgl/E57Y9iqaKnXligciXQ+dxZm9P MU6WMHfPbgCGX9yxBSS82gk49AzmXacxDvrQ+ZjWNFSd6wyoAP1QnsK5JXv7skh4RMYR1z1lK+AR y1LQYgFcqdQDPvnJBsRCBRToNFlpqUhNM1ABnuwtMu8SR1Oo6AOYaiAqXDlJT1mKObM45QM+6UZQ hdq7l64EoSflClW7QRKbEHWsHLEqLUR2lKiMRR5wjStcCzJPudr1rnjNq173+omPJImvgAqsYAdL 2LvKsLCITaxiF8tYD5StsZCNrGQnC1dPgYeymIVsBAAAOw== RPC-XML-0.82/t/41_server_hang.t0000644000175000017500000000535413775372465015056 0ustar rjrayrjray#!/usr/bin/env perl # Test the RPC::XML::Server bug that causes a hang when a client terminates in # mid-message. Unlike 40_server.t, this isn't trying to fully exercise the # server class, just looking for and (trying to) tickle a specific bug. ## no critic(RequireCheckedClose) use strict; use warnings; use subs qw(start_server); use Carp qw(carp croak); use File::Spec; use IO::Socket::IP; use Test::More; use HTTP::Request; use RPC::XML::Server; my ($dir, $vol, $srv, $bucket, $child, $req, $port, $socket, $body); plan tests => 2; ($vol, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0)); $dir = File::Spec->catpath($vol, $dir, q{}); require File::Spec->catfile($dir, 'util.pl'); { package MyServer; use strict; use base qw(RPC::XML::Server); sub process_request { my $self = shift; $self->SUPER::process_request(@_); exit 1; } } SKIP: { if ($^O eq 'MSWin32' || $^O eq 'cygwin') { skip 'This suite does not run on MSWin/cygwin', 2; } $srv = MyServer->new(no_default => 1); isa_ok($srv, 'RPC::XML::Server', 'Server instance'); $srv->add_method({ name => 'echo', signature => [ 'string string' ], code => sub { shift; return shift; } }); $port = $srv->port; $req = HTTP::Request->new(POST => "http://localhost:$port/"); $body = RPC::XML::request->new('echo', 'foo')->as_string; $req->content($body); $req->protocol('HTTP/1.0'); $req->header(Content_Length => length $body); $req->header(Content_Type => 'text/xml'); $req = $req->as_string; $req = substr $req, 0, (length($req) - 32); $child = start_server $srv; $bucket = 0; local $SIG{CHLD} = sub { my $dead = wait; if ($dead == $child) { $bucket = $? >> 8; } else { carp 'PANIC: Unknown child return'; } }; # Create an IO::Socket object for the client-side. In order to fool the # server with a bad Content-Length and terminate early, we have to ditch # LWP and go old-skool. $socket = IO::Socket::IP->new(Proto => 'tcp', PeerAddr => 'localhost', PeerPort => $port) or croak "Error creating IO::Socket obj: $!"; print {$socket} $req; # This *should* force the server to drop the request. The bug relates to # the fact that (previously) the server just hangs: close $socket; # Give the server time to crap out: if (! $bucket) { sleep 95; } # If it still hasn't, kill it: local $SIG{CHLD} = 'IGNORE'; if (! $bucket) { kill 'KILL', $child; } is($bucket, 1, 'Check if server hangs on short requests'); } exit; RPC-XML-0.82/t/namespace2.xpl0000644000175000017500000000047111356231360014575 0ustar rjrayrjray nstest2 Test.NS 1.0 string Namespace test method for RPC::XML::Method suite sub test { __PACKAGE__ } RPC-XML-0.82/t/51_client_with_host_header.t0000644000175000017500000000220312420753461017401 0ustar rjrayrjray#!/usr/bin/env perl # Test the ability of requests to specify their own Host: header use strict; use warnings; use HTTP::Request; use Test::More; plan tests => 2; sub clone_with_host_header { my $req = shift; my $reqclone = $req->clone; if (! $reqclone->header('Host')) { $reqclone->header(Host => URI->new($reqclone->uri)->host); } return $reqclone; } subtest 'without_host_header' => sub { plan tests => 2; my $req = HTTP::Request->new(POST => 'http://example.com'); ok(! $req->header('Host'), 'Host: header not set'); my $reqclone = clone_with_host_header($req); is($reqclone->header('Host'), 'example.com', 'Host: header set properly'); }; subtest 'with_host_header' => sub { plan tests => 3; my $req = HTTP::Request->new(POST => 'http://example.com'); ok(! $req->header('Host'), 'Host: header not set'); $req->header('Host', 'google.com'); is($req->header('Host'), 'google.com', 'Host: header set properly'); my $reqclone = clone_with_host_header($req); is($reqclone->header('Host'), 'google.com', 'Host: header in clone is correct'); }; exit; RPC-XML-0.82/t/90_rt58065_allow_nil.t0000644000175000017500000000552612420753461015636 0ustar rjrayrjray#!/usr/bin/env perl # https://rt.cpan.org/Ticket/Display.html?id=58065 # # Test that the parser-factory instance classes allow the parsing of the # tag whether $RPC::XML::ALLOW_NIL is set or not. This is to allow # liberal acceptance of the tag in what we take in. Production of the tag is # still limited to only when the flag is set. ## no critic(RequireInterpolationOfMetachars) use strict; use warnings; use Module::Load; use Test::More; use RPC::XML; use RPC::XML::Parser::XMLParser; plan tests => 8; my ($parser, $req_message, $res_message, $parsed); my $can_libxml = eval { load RPC::XML::Parser::XMLLibXML; 1; }; # Create mock request and response messages that contain nils in them by first # setting the flag. We'll then unset the flag for the tests. $RPC::XML::ALLOW_NIL = 1; $req_message = RPC::XML::request->new( 'foo', RPC::XML::nil->new() ); $res_message = RPC::XML::response->new( RPC::XML::nil->new() ); $RPC::XML::ALLOW_NIL = 0; # To test this, instantiate each parser then call the ->parse() method with # both the request and response message that contain nil tags. # First test the class we always have, RPC::XML::Parser::XMLParser $parser = RPC::XML::Parser::XMLParser->new(); # Test-parse the request message $parsed = $parser->parse($req_message->as_string); isa_ok($parsed, 'RPC::XML::request', '$parsed content'); SKIP: { if (ref($parsed) ne 'RPC::XML::request') { skip 'Parsed value corrupted, cannot test nil value', 1; } isa_ok($parsed->args->[0], 'RPC::XML::nil', '$parsed->args->[0]'); } # Test-parse the response message $parsed = $parser->parse($res_message->as_string); isa_ok($parsed, 'RPC::XML::response', '$parsed content'); SKIP: { if (ref($parsed) ne 'RPC::XML::response') { skip 'Parsed value corrupted, cannot test nil value', 1; } isa_ok($parsed->value, 'RPC::XML::nil', '$parsed->value'); } # Next, test RPC::XML::Parser::XMLLibXML (which we might not have) SKIP: { if (! $can_libxml) { skip 'XML::LibXML not installed', 4; } $parser = RPC::XML::Parser::XMLLibXML->new(); # Test-parse the request message $parsed = $parser->parse($req_message->as_string); isa_ok($parsed, 'RPC::XML::request', '$parsed content'); SKIP: { if (ref($parsed) ne 'RPC::XML::request') { skip 'Parsed value corrupted, cannot test nil value', 1; } isa_ok($parsed->args->[0], 'RPC::XML::nil', '$parsed->args->[0]'); } # Test-parse the response message $parsed = $parser->parse($res_message->as_string); isa_ok($parsed, 'RPC::XML::response', '$parsed content'); SKIP: { if (ref($parsed) ne 'RPC::XML::response') { skip 'Parsed value corrupted, cannot test nil value', 1; } isa_ok($parsed->value, 'RPC::XML::nil', '$parsed->value'); } } exit; RPC-XML-0.82/t/util.pl0000644000175000017500000000404213775372465013365 0ustar rjrayrjray# Nothing exciting, just a couple of utility routines that are used in several # test suites use IO::Socket; use Socket (); use Carp (); sub start_server { my ($S, @args) = @_; my $pid; if (! defined($pid = fork)) { die "fork() error: $!, stopped"; } elsif ($pid) { return $pid; } else { $S->server_loop(@args); exit; # When the parent stops this server, we want to stop this child } } sub stop_server { my ($pid, $no_sleep) = @_; # Per RT 27778, use 'KILL' instead of 'INT' as the stop-server signal for # MSWin platforms: my $SIGNAL = ($^O eq 'MSWin32') ? 'KILL' : 'INT'; kill $SIGNAL, $pid; if (! $no_sleep) { sleep 2; # give the old sockets time to go away } return; } sub find_port { my $start_at = shift; $start_at ||= 9000; for my $port ($start_at .. ($start_at + 2000)) { my $sock = IO::Socket->new( Domain => AF_INET, PeerAddr => 'localhost', PeerPort => $port ); return $port if (! ref $sock); } return -1; } sub pack_sockaddr_any { my ($family, $address, $port) = @_; my $packed_address = Socket::inet_pton($family, $address); my $packet; if ($family == Socket::AF_INET) { $packet = Socket::pack_sockaddr_in($port, $packed_address); } elsif ($family == Socket::AF_INET6) { $packet = Socket::pack_sockaddr_in6($port, $packed_address); } else { Carp::croak "Unsupported address family: $family"; } return $packet; } sub resolve { my ($family, $hostname) = @_; my ($error, @res) = Socket::getaddrinfo($hostname, '', { socktype => Socket::SOCK_STREAM }); if ($error) { Carp::croak "Could not resolve $hostname: $error"; } my @addresses; while (my $ai = shift @res) { my ($error, $address) = Socket::getnameinfo($ai->{addr}, Socket::NI_NUMERICHOST, Socket::NIx_NOSERV); push @addresses, $address; } return @addresses; } 1; RPC-XML-0.82/t/11_base64_fh.t0000644000175000017500000001615113774651431014276 0ustar rjrayrjray#!/usr/bin/env perl # Test the usage of RPC::XML::base64 with filehandles ## no critic(RequireBriefOpen) ## no critic(RequireCheckedClose) ## no critic(RequireInterpolationOfMetachars) use strict; use warnings; use Carp qw(croak carp); use Test::More; use File::Spec; use IO::Handle; # Allow "$fh->autoflush(1)" for setting $| use Digest::MD5; use MIME::Base64; # This is what we're testing use RPC::XML; my ($dir, $vol, $file, $b64file, $tmpfile, $value, $enc_value, $obj, $fh, $pos, $md5_able, $md5, $size, $ofh); plan tests => 35; ($vol, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0)); $dir = File::Spec->catpath($vol, $dir, q{}); $file = File::Spec->catfile($dir, 'svsm_text.gif'); $b64file = File::Spec->catfile($dir, 'svsm_text.b64'); $tmpfile = File::Spec->catfile($dir, "__tmp__${$}__"); END { if (-f $tmpfile) { unlink $tmpfile; } } $value = 'Short string for easy tests'; $enc_value = encode_base64($value, q{}); if (! (open $fh, '+>', $tmpfile)) { croak "Error opening $tmpfile: $!"; } $fh->autoflush(1); print {$fh} $value; $pos = tell $fh; # We now have a ready-to-use FH, and we know the seek-pos on it $obj = RPC::XML::base64->new($fh); isa_ok($obj, 'RPC::XML::base64', '$obj'); is(tell $fh, $pos, 'object construction leaves pos() unchanged'); is($obj->value(), $value, 'object value is correct'); is(tell $fh, $pos, 'call to value() leaves pos() unchanged'); is($obj->as_string(), "$enc_value", 'object stringification is correct'); is(tell $fh, $pos, 'call to as_string leaves pos() unchanged'); # Done with this for now close $fh; unlink $tmpfile; # Same tests, but init the FH with the encoded data rather than the cleartext if (! (open $fh, '+>', $tmpfile)) { croak "Error opening $tmpfile: $!"; } $fh->autoflush(1); print {$fh} $enc_value; $pos = tell $fh; # We now have a ready-to-use FH, and we know the seek-pos on it $obj = RPC::XML::base64->new($fh, 'encoded'); isa_ok($obj, 'RPC::XML::base64', '$obj(encoded)'); is(tell $fh, $pos, 'object(encoded) construction leaves pos() unchanged'); is($obj->value(), $value, 'object(encoded) value is correct'); is(tell $fh, $pos, 'call to value() leaves pos() unchanged'); is($obj->as_string(), "$enc_value", 'object(encoded) stringification is correct'); is(tell $fh, $pos, 'call to as_string leaves pos() unchanged'); # Done with this for now close $fh; unlink $tmpfile; # Test old-style glob filehandles { ## no critic(ProhibitBarewordFilehandles) ## no critic(RequireBracedFileHandleWithPrint) if (! (open F, '+>', $tmpfile)) { croak "Error opening $tmpfile: $!"; } F->autoflush(1); print F $enc_value; $pos = tell F; # We now have a ready-to-use FH, and we know the seek-pos on it $obj = RPC::XML::base64->new(\*F, 'encoded'); isa_ok($obj, 'RPC::XML::base64', '$obj(glob)'); is(tell F, $pos, 'object(glob) construction leaves pos() unchanged'); is($obj->value(), $value, 'object(glob) value is correct'); is(tell F, $pos, 'call to value() leaves pos() unchanged'); is($obj->as_string(), "$enc_value", 'object(glob) stringification is correct'); is(tell F, $pos, 'call to as_string leaves pos() unchanged'); # Done with this for now close F; unlink $tmpfile; } # Test with a larger file if (! (open $fh, '<', $file)) { croak "Error opening $file: $!"; } $obj = RPC::XML::base64->new($fh); isa_ok($obj, 'RPC::XML::base64', '$obj'); $enc_value = q{}; $value = q{}; while (read $fh, $value, 60*57) { $enc_value .= encode_base64($value, q{}); } is($obj->as_string(), "$enc_value", 'from file, stringification'); is(length($obj->as_string), $obj->length, 'from file, length'); seek $fh, 0, 0; $md5 = Digest::MD5->new; $md5->addfile($fh); $value = $md5->hexdigest; $md5->new; # Clear the digest $md5->add($obj->value); is($value, $md5->hexdigest, 'MD5 checksum matches'); close $fh; # Test the to_file method if (! (open $fh, '<', $file)) { croak "Error opening $file: $!"; } $obj = RPC::XML::base64->new($fh); # Start by trying to write the new file $size = $obj->to_file($tmpfile); is($size, -s $file, 'to_file call returned correct number of bytes'); is(-s $tmpfile, -s $file, 'temp-file size matches file size'); $md5 = Digest::MD5->new; $md5->addfile($fh); $value = $md5->hexdigest; $md5->new; # Clear the digest # Now get an MD5 on the new file if (! (open $ofh, '<', $tmpfile)) { croak "Error opening $tmpfile for reading: $!"; } $md5->addfile($ofh); is($value, $md5->hexdigest, 'MD5 hexdigest matches'); close $ofh; unlink $tmpfile; close $fh; # Try with in-memory data $value = 'a simple in-memory string'; $obj = RPC::XML::base64->new($value); # Try to write it $size = $obj->to_file($tmpfile); is($size, length $value, 'to_file call returned correct number of bytes'); is(length $value, -s $tmpfile, 'temp-file size matches string'); unlink $tmpfile; # Try with a file-handle instead of a file name if (! (open $ofh, '>', $tmpfile)) { croak "Error opening $tmpfile for writing: $!"; } $ofh->autoflush(1); $size = $obj->to_file($ofh); is($size, length $value, 'to_file call on file-handle, correct size'); is(length $value, -s $ofh, 'temp-file size matches string'); close $ofh; unlink $tmpfile; # Try an unusable reference $size = $obj->to_file([]); is($size, -1, 'to_file call failed on unusable reference type'); like($RPC::XML::ERROR, qr/Unusable reference/, 'Correct error message'); SKIP: { # Test the failure to open a file. Cannot run this on Windows because # it doesn't have the concept of chmod... if ($^O eq 'MSWin32' || $^O eq 'cygwin') { skip 'Tests involving directory permissions skipped on Windows', 2; } # ...nor can we run it as root, because root. if ($< == 0) { skip 'Tests involving directory permissions skipped under root', 2; } my $baddir = File::Spec->catdir(File::Spec->tmpdir(), "baddir_$$"); if (! mkdir $baddir) { skip "Skipping, failed to create dir $baddir: $!", 2; } if (! chmod oct(600), $baddir) { skip "Skipping, failed to chmod dir $baddir: $!", 2; } my $badfile = File::Spec->catfile($baddir, 'file'); $size = $obj->to_file($badfile); is($size, -1, 'to_file call failed on un-openable file'); like($RPC::XML::ERROR, qr/Error opening/, 'Correct error message'); if (! rmdir $baddir) { carp "Failed to remove temp-dir $baddir: $!"; } } # Test to_file() with an encoded file in the file-handle if (! (open $fh, '<', $b64file)) { croak "Error opening $b64file for reading: $!"; } $obj = RPC::XML::base64->new($fh, 'encoded'); $size = $obj->to_file($tmpfile); is($size, -s $file, 'to_file() written size matches decoded file size'); if (! (open $fh, '<', $file)) { croak "Error opening $file: $!"; } $md5 = Digest::MD5->new; $md5->addfile($fh); $value = $md5->hexdigest; $md5->new; # Clear the digest # Now get an MD5 on the new file if (! (open $ofh, '<', $tmpfile)) { croak "Error opening $tmpfile for reading: $!"; } $md5->addfile($ofh); is($value, $md5->hexdigest, 'MD5 hexdigest matches'); close $ofh; unlink $tmpfile; close $fh; exit; RPC-XML-0.82/t/90_rt54183_sigpipe.t0000644000175000017500000000372112420753461015306 0ustar rjrayrjray#!/usr/bin/env perl # http://rt.cpan.org/Ticket/Display.html?id=54183 # # Test that the RPC::XML::Server class can handle SIGPIPE issues # Here, we don't care about the return value of eval's, because of the ALRM # signal handlers: ## no critic(RequireCheckingReturnValueOfEval) use strict; use warnings; use subs qw(start_server stop_server); use Test::More; use File::Spec; use RPC::XML::Server; use RPC::XML::Client; my ($dir, $vol, $srv, $child, $port, $cli, $res); # This suite doesn't run on Windows, since it's based on *NIX signals if ($^O eq 'MSWin32' || $^O eq 'cygwin') { plan skip_all => 'Skipping *NIX signals-based test on Windows platform'; exit; } ($vol, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0)); $dir = File::Spec->catpath($vol, $dir, q{}); require File::Spec->catfile($dir, 'util.pl'); $srv = RPC::XML::Server->new(host => 'localhost'); if (! ref $srv) { plan skip_all => "Creating server failed: $srv" } else { plan tests => 4; $port = $srv->port; } $cli = RPC::XML::Client->new("http://localhost:$port"); $srv->add_method({ name => 'test', signature => [ 'string' ], code => sub { my ($server) = @_; sleep 3; return 'foo'; } }); $child = start_server $srv; eval { local $SIG{ALRM} = sub { die "alarm\n" }; alarm 1; $res = $cli->send_request('test'); alarm 0; # Shouldn't reach here }; like($res, qr/alarm/, 'Initial request alarmed-out correctly'); eval { local $SIG{ALRM} = sub { die "alarm\n" }; alarm 6; $res = $cli->send_request('test'); alarm 0; # Shouldn't reach here }; unlike($res, qr/alarm/, 'Second request did not alarm-out'); ok(ref($res) && $res->value eq 'foo', 'Second request correct value'); eval { local $SIG{ALRM} = sub { die "alarm\n" }; alarm 2; $res = $cli->send_request('system.status'); alarm 0; }; ok(ref($res) && ref($res->value) eq 'HASH', 'Good system.status return'); stop_server $child, 'final'; exit; RPC-XML-0.82/t/meth_good_2.xpl0000644000175000017500000000045411622765353014760 0ustar rjrayrjray test.rpc.xml.procedure 1.0 string Simple test method for RPC::XML::Procedure class sub test { $_[0] } RPC-XML-0.82/t/10_data.t0000644000175000017500000005224113774651431013445 0ustar rjrayrjray#!/usr/bin/perl ## no critic(RequireInterpolationOfMetachars) ## no critic(ProhibitComplexRegexes) # Test the data-manipulation routines in RPC::XML use strict; use warnings; use Config; use Module::Load; use Test::More; use File::Spec; use RPC::XML ':all'; my ($val, $str, $obj, $class, %val_tbl, @values, $datetime_avail); $datetime_avail = eval { load DateTime; 1; }; plan tests => 252; # First, make sure we can't instantiate any of "abstract" classes directly, # and also make sure that certain base-class methods properly return when # (wrongly) called as static methods: $obj = RPC::XML::simple_type->new('foo'); ok(! ref $obj, 'Attempt to directly construct simple_type failed'); like($RPC::XML::ERROR, qr/Cannot instantiate/, 'Correct error message'); $val = RPC::XML::simple_type->value; ok(! defined $val, 'Static call to RPC::XML::simple_type::value fails'); like($RPC::XML::ERROR, qr/static method/, 'Correct error message'); ok(! RPC::XML::simple_type->as_string(), 'Static call to RPC::XML::simple_type::as_string fails'); like($RPC::XML::ERROR, qr/static method/, 'Correct error message'); # RPC::XML::double and RPC::XML::string have their own as_string methods ok(! RPC::XML::double->as_string(), 'Static call to RPC::XML::simple_type::as_string fails'); like($RPC::XML::ERROR, qr/static method/, 'Correct error message'); ok(! RPC::XML::string->as_string(), 'Static call to RPC::XML::simple_type::as_string fails'); like($RPC::XML::ERROR, qr/static method/, 'Correct error message'); # Try instantiating a non-scalar reference $obj = RPC::XML::int->new([]); ok(! ref $obj, 'Attempt to instantiate from non-scalar ref failed'); like($RPC::XML::ERROR, qr/not derived from scalar/, 'Correct error message'); # Next, the most basic data-types %val_tbl = ( 'int' => int(rand 10_000) + 1, i4 => int(rand 10_000) + 1, i8 => 2**32, double => 0.5, string => __FILE__, ); for (sort keys %val_tbl) { $val = $val_tbl{$_}; $class = "RPC::XML::$_"; $obj = $class->new($val); isa_ok($obj, $class, "Basic data-type $_"); is($obj->value, $val, "Basic data-type $_, value check"); is($obj->as_string, "<$_>$val", "Basic data-type $_, XML serialization"); is($obj->type, $_, "Basic data-type $_, type identification"); is(length($obj->as_string), $obj->length, "Basic data-type $_, length() method test"); } # Go again, with each of the values being a blessed scalar reference my @vals = (1, -1, 2**32, 0.5, __FILE__); %val_tbl = ( int => bless(\(shift @vals), 'Tmp::Scalar::Int'), i4 => bless(\(shift @vals), 'Tmp::Scalar::I4'), i8 => bless(\(shift @vals), 'Tmp::Scalar::I8'), double => bless(\(shift @vals), 'Tmp::Scalar::Double'), string => bless(\(shift @vals), 'Tmp::Scalar::String'), ); for my $type (sort keys %val_tbl) { $val = $val_tbl{$type}; $class = "RPC::XML::$type"; $obj = $class->new($val); isa_ok($obj, $class, "Data objects from blessed scalar refs, type $type"); is($obj->value, ${$val}, "Data objects from blessed scalar refs, type $type, value check"); is($obj->as_string, "<$type>${$val}", "Data objects from blessed scalar refs, type $type, XML serialization"); is($obj->type, $type, "Data objects from blessed scalar refs, type $type, type ident"); is(length($obj->as_string), $obj->length, "Data objects from blessed scalar refs, type $type, length() method"); } # A few extra tests for RPC::XML::double to make sure the stringification # doesn't lead to wonky values: $obj = RPC::XML::double->new(10.0); is($obj->as_string, '10.0', 'RPC::XML::double stringification [1]'); $obj = RPC::XML::double->new(0.50); is($obj->as_string, '0.5', 'RPC::XML::double stringification [2]'); # Another little test for RPC::XML::string, to check encoding $val = 'Subroutine &bogus not defined at <_> line -NaN'; $obj = RPC::XML::string->new($val); is($obj->value, $val, 'RPC::XML::string extra tests, value check'); is($obj->as_string, 'Subroutine &bogus not defined at <_> line -NaN', 'RPC::XML::string extra tests, XML serialization'); # Test for correct handling of encoding a 0 (false but defined) $val = 0; $obj = RPC::XML::string->new($val); is($obj->as_string, '0', q(RPC::XML::string, encoding '0')); # Type boolean is a little funky # Each of these should be OK for my $boolval (qw(0 1 yes no tRuE FaLsE)) { $val = ($boolval =~ /0|no|false/i) ? 0 : 1; $obj = RPC::XML::boolean->new($boolval); isa_ok($obj, 'RPC::XML::boolean', "\$obj($boolval)"); is($obj->value, $val, "RPC::XML::boolean($boolval), value check"); is($obj->as_string, "$val", "RPC::XML::boolean($boolval), XML serialization"); is($obj->type, 'boolean', "RPC::XML::boolean($boolval), type ident"); } # This should not $obj = RPC::XML::boolean->new('of course!'); ok(! ref $obj, 'RPC::XML::boolean, bad value did not yield referent'); like($RPC::XML::ERROR, qr/::new: Value must be one of/, 'RPC::XML::boolean, bad value correctly set $RPC::XML::ERROR'); # The dateTime.iso8601 type $val = time2iso8601(time); $obj = RPC::XML::datetime_iso8601->new($val); isa_ok($obj, 'RPC::XML::datetime_iso8601', '$obj'); is($obj->type, 'dateTime.iso8601', 'RPC::XML::datetime_iso8601, type identification'); is(length($obj->as_string), $obj->length, 'RPC::XML::datetime_iso8601, length() method test'); is($obj->value, $val, 'RPC::XML::datetime_iso8601, value() method test'); $obj = RPC::XML::datetime_iso8601->new(\$val); isa_ok($obj, 'RPC::XML::datetime_iso8601', '$obj'); is($obj->type, 'dateTime.iso8601', 'RPC::XML::datetime_iso8601, type identification (ref)'); is(length($obj->as_string), $obj->length, 'RPC::XML::datetime_iso8601, length() method test (ref)'); is($obj->value, $val, 'RPC::XML::datetime_iso8601, value() method test (ref)'); # Add a fractional part and try again chop $val; # Lose the 'Z' $val .= '.125Z'; $obj = RPC::XML::datetime_iso8601->new($val); isa_ok($obj, 'RPC::XML::datetime_iso8601', '$obj'); is($obj->type, 'dateTime.iso8601', 'RPC::XML::datetime_iso8601, type identification'); is(length($obj->as_string), $obj->length, 'RPC::XML::datetime_iso8601, length() method test'); is($obj->value, $val, 'RPC::XML::datetime_iso8601, value() method test'); # Test bad date-data $obj = RPC::XML::datetime_iso8601->new(); ok(! ref $obj, 'RPC::XML::datetime_iso8601, empty value did not yield referent'); like($RPC::XML::ERROR, qr/::new: Value required/, 'RPC::XML::datetime_iso8601, empty value correctly set $RPC::XML::ERROR'); $obj = RPC::XML::datetime_iso8601->new('not a date'); ok(! ref $obj, 'RPC::XML::datetime_iso8601, bad value did not yield referent'); like($RPC::XML::ERROR, qr/::new: Malformed data/, 'RPC::XML::datetime_iso8601, empty value correctly set $RPC::XML::ERROR'); # Test the slightly different date format $obj = RPC::XML::datetime_iso8601->new('2008-09-29T12:00:00-07:00'); isa_ok($obj, 'RPC::XML::datetime_iso8601', '$obj'); is($obj->type, 'dateTime.iso8601', 'RPC::XML::datetime_iso8601, type identification'); is($obj->value, '20080929T12:00:00-07:00', 'RPC::XML::datetime_iso8601, value() method test'); # Test interoperability with the DateTime package, if it is available SKIP: { if (! $datetime_avail) { skip 'Module DateTime not available', 4; } my $dt = DateTime->now(); (my $dt_str = "$dt") =~ s/-//g; $obj = RPC::XML::datetime_iso8601->new("$dt"); isa_ok($obj, 'RPC::XML::datetime_iso8601', '$obj'); is($obj->value, $dt_str, 'RPC::XML::datetime_iso8601, from DateTime'); $obj = smart_encode($dt); isa_ok($obj, 'RPC::XML::datetime_iso8601', '$obj'); is($obj->value, $dt_str, 'RPC::XML::datetime_iso8601, from DateTime via smart_encode'); } # Test the base64 type require MIME::Base64; $str = 'one reasonable-length string'; $val = MIME::Base64::encode_base64($str, q{}); $obj = RPC::XML::base64->new($str); isa_ok($obj, 'RPC::XML::base64', '$obj'); is($obj->as_string, "$val", 'RPC::XML::base64, XML serialization'); is($obj->value, $str, 'RPC::XML::base64, correct value()'); is(length($obj->as_string), $obj->length, 'RPC::XML::base64, length() method test'); # Test pre-encoded data $obj = RPC::XML::base64->new($val, 'pre-encoded'); isa_ok($obj, 'RPC::XML::base64', '$obj (pre-encoded)'); is($obj->value, $str, 'RPC::XML::base64(pre-encoded), value check'); # Test passing in a reference $obj = RPC::XML::base64->new(\$str); isa_ok($obj, 'RPC::XML::base64', '$obj'); is($obj->value, $str, 'RPC::XML::base64, correct value()'); # Test a null Base64 object $obj = RPC::XML::base64->new(); isa_ok($obj, 'RPC::XML::base64', '$obj'); is($obj->value, q{}, 'Zero-length base64 object value OK'); is($obj->as_string, '', 'Zero-length base64 object stringifies OK'); # Now we throw some junk at smart_encode() @values = smart_encode( __FILE__, # [0] string 10, # [1] int 3.14159, # [2] double '2112', # [3] int RPC::XML::string->new('2112'), # [4] string [], # [5] array {}, # [6] struct \'foo', # [7] string \2, # [8] int \1.414, # [9] double 2_147_483_647, # [10] int -2_147_483_648, # [11] int 9_223_372_036_854_775_807, # [12] i8 -9_223_372_036_854_775_808, # [13] i8 4_294_967_295, # [14] i8 '2009-09-03T10:25:00', # [15] dateTime.iso8601 '20090903T10:25:00Z', # [16] dateTime.iso8601 '2009-09-03T10:25:00.125', # [17] dateTime.iso8601 ); is($values[0]->type, 'string', 'smart_encode, string<1>'); is($values[1]->type, 'int', 'smart_encode, int<1>'); is($values[2]->type, 'double', 'smart_encode, double<1>'); # Should have been encoded int regardless of '' is($values[3]->type, 'int', 'smart_encode, int<2>'); # Was given an object explicitly is($values[4]->type, 'string', 'smart_encode, string<2>'); is($values[5]->type, 'array', 'smart_encode, array'); is($values[6]->type, 'struct', 'smart_encode, struct'); is($values[7]->type, 'string', 'smart_encode, string<3>'); is($values[8]->type, 'int', 'smart_encode, int<3>'); is($values[9]->type, 'double', 'smart_encode, double<2>'); is($values[10]->type, 'int', 'smart_encode, int<4>'); is($values[11]->type, 'int', 'smart_encode, int<5>'); SKIP: { if ($Config{longsize} != 8) { skip '64-bit architecture required to test these I8 values', 2; } is($values[12]->type, 'i8', 'smart_encode, i8<1>'); is($values[13]->type, 'i8', 'smart_encode, i8<2>'); } is($values[14]->type, 'i8', 'smart_encode, i8<3>'); is($values[15]->type, 'dateTime.iso8601', 'smart_encode, dateTime.iso8601'); is($values[16]->type, 'dateTime.iso8601', 'smart_encode, dateTime.iso8601<2>'); is($values[17]->type, 'dateTime.iso8601', 'smart_encode, dateTime.iso8601<3>'); # Without $RPC::XML::ALLOW_NIL set, smart_encode should encode this as a null # string: $obj = smart_encode(undef); is($obj->type, 'string', 'smart_encode undef->string type'); is($obj->value, q{}, 'smart_encode undef->string value'); # Check that smart_encode gives up on un-convertable references { my $badvalue; my $result = eval { $badvalue = smart_encode(\*STDIN); 1; }; ok(! ref($badvalue), 'smart_encode, bad reference argument did not yield referent'); like($@, qr/Un-convertable reference/, 'smart_encode, bad reference argument set $@ as expected'); } # Arrays $obj = RPC::XML::array->new(1 .. 10); isa_ok($obj, 'RPC::XML::array', '$obj'); is($obj->type, 'array', 'RPC::XML::array, type identification'); @values = @{$obj->value}; is(scalar(@values), 10, 'RPC::XML::array, array size test'); @values = @{$obj->value(1)}; ok(ref($values[0]) && ($values[0]->type eq 'int'), 'RPC::XML::array, array content is RPC::XML::* referent'); like($obj->as_string, qr{.*(\d+.*){10}.*}smx, 'RPC::XML::array, XML serialization'); is(length($obj->as_string), $obj->length, 'RPC::XML::array, length() method test'); # Blessed array references my $arrayobj = bless [ 1 .. 10 ], "Tmp::Array$$"; $obj = RPC::XML::array->new(from => $arrayobj); isa_ok($obj, 'RPC::XML::array', '$obj from blessed arrayref'); is($obj->type, 'array', 'RPC::XML::array from blessed arrayref, type identification'); @values = @{$obj->value}; is(scalar(@values), 10, 'RPC::XML::array from blessed arrayref, array size test'); @values = @{$obj->value(1)}; ok(ref($values[0]) && ($values[0]->type eq 'int'), 'RPC::XML::array from blessed arrayref, array content is referent'); like($obj->as_string, qr{.*(\d+.*){10}.*}smx, 'RPC::XML::array from blessed arrayref, XML serialization'); is(length($obj->as_string), $obj->length, 'RPC::XML::array from blessed arrayref, length() method test'); undef $arrayobj; # Structs $obj = RPC::XML::struct->new(key1 => 1, key2 => 2); isa_ok($obj, 'RPC::XML::struct', '$obj'); is($obj->type, 'struct', 'RPC::XML::struct, type identification'); $val = $obj->value; is(ref($val), 'HASH', 'RPC::XML::struct, ref-type of value()'); is(scalar(keys %{$val}), 2, 'RPC::XML::struct, correct number of keys'); is($val->{key1}, 1, q(RPC::XML::struct, 'key1' value test)); $val = $obj->value(1); ok(ref($val->{key1}) && ($val->{key1}->type eq 'int'), 'RPC::XML::struct, key-value is referent in shallow conversion'); $val->{key1} = RPC::XML::string->new('hello'); $obj = RPC::XML::struct->new($val); isa_ok($obj, 'RPC::XML::struct', '$obj(object-values)'); is(($obj->value)->{key1}, 'hello', q{RPC::XML::struct(object-values), 'key1' value test}); is(($obj->value(1))->{key1}->type, 'string', 'RPC::XML::struct(object-values), value-object type correctness'); like($obj->as_string, qr{ ( .* .* ){2} }smx, 'RPC::XML::struct, XML serialization'); is(length($obj->as_string), $obj->length, 'RPC::XML::struct, length() method test'); # Test handling of keys that contain XML special characters $obj = RPC::XML::struct->new(q{>} => 'these', q{<} => 'are', q{&} => 'special', q{<>} => 'XML', q{&&} => 'characters'); isa_ok($obj, 'RPC::XML::struct', '$obj(with XML special char keys)'); is((my $tmp = $obj->as_string) =~ tr/&/&/, 7, 'RPC::XML::struct, XML-encoding of serialized form with char entities'); # Blessed struct reference my $structobj = bless { key1 => 1, key2 => 2 }, "Tmp::Struct$$"; $obj = RPC::XML::struct->new($structobj); isa_ok($obj, 'RPC::XML::struct', '$obj(struct<1>)'); is($obj->type, 'struct', 'struct object type method'); $val = $obj->value; isa_ok($val, 'HASH', 'struct $obj->value'); is(scalar(keys %{$val}), 2, 'struct obj number of keys test'); is($val->{key1}, 1, 'struct obj "key1" test'); $val = $obj->value(1); isa_ok($val->{key1}, 'RPC::XML::int', '$val->{key1} (shallow eval)'); $val->{key1} = RPC::XML::string->new('hello'); $obj = RPC::XML::struct->new($val); isa_ok($obj, 'RPC::XML::struct', '$obj(struct<2>)'); is(($obj->value)->{key1}, 'hello', 'struct<2> "key1" test'); is(($obj->value(1))->{key1}->type, 'string', 'struct<2> "key1" type test'); like($obj->as_string, qr{ ( .* .* ){2} }smx, 'struct<2> XML serialization'); is(length($obj->as_string), $obj->length, 'struct<2> length() check'); # No need to re-test the XML character handling # Faults are a subclass of structs $obj = RPC::XML::fault->new(faultCode => 1, faultString => 'test'); isa_ok($obj, 'RPC::XML::fault', '$obj (fault)'); # Since it's a subclass, I won't waste cycles testing the similar methods $obj = RPC::XML::fault->new(faultCode => 1); ok(! ref $obj, 'fault class constructor fails on missing key(s)'); like($RPC::XML::ERROR, qr/:new: Missing required struct fields/, 'fault class failure set error string'); $obj = RPC::XML::fault->new(faultCode => 1, faultString => 'test', faultFail => 'extras are not allowed'); ok(! ref($obj), 'fault class rejects extra args'); like($RPC::XML::ERROR, qr/:new: Extra struct/, 'fault class failure set error string'); $obj = RPC::XML::fault->new(1, 'test'); isa_ok($obj, 'RPC::XML::fault', '$obj<2> (fault)'); is($obj->code, 1, 'fault code() method'); is($obj->string, 'test', 'fault string() method'); like($obj->as_string, qr{ ( .* .* .*){2} }smx, 'fault XML serialization'); is(length($obj->as_string), $obj->length, 'fault length() check'); # Requests $obj = RPC::XML::request->new('test.method'); isa_ok($obj, 'RPC::XML::request', '$obj (request)'); is($obj->name, 'test.method', 'request name method'); ok($obj->args && (@{$obj->args} == 0), 'request args method'); $obj = RPC::XML::request->new(); ok(! ref($obj), 'bad request contructor failed'); like($RPC::XML::ERROR, qr/:new: At least a method name/, 'bad request constructor set error string'); $obj = RPC::XML::request->new(q{#*}); # Bad method name, should fail ok(! ref($obj), 'Bad method name in constructor failed'); like($RPC::XML::ERROR, qr/Invalid method name/, 'Bad method name in constructor set error string'); $obj = RPC::XML::request->new('test.method', (1 .. 10)); ok($obj->args && (@{ $obj->args } == 10), 'request args method size test'); # The new() method uses smart_encode on the args, which has already been # tested. These are just to ensure that it *does* in fact call it is($obj->args->[0]->type, 'int', 'request args elt[0] type test'); is($obj->args->[9]->value, 10, 'request args elt[9] value test'); like($obj->as_string, qr{<[?]xml.*?> .* (.*){10} }smx, 'request XML serialization'); is(length($obj->as_string), $obj->length, 'request length() test'); # Responses $obj = RPC::XML::response->new('ok'); isa_ok($obj, 'RPC::XML::response', '$obj (response)'); is($obj->value->type, 'string', 'response value->type test'); is($obj->value->value, 'ok', 'response value->value test'); ok(! $obj->is_fault, 'response object not fault'); like($obj->as_string, qr{<[?]xml.*?> .* }smx, 'response XML serialization'); is(length($obj->as_string), $obj->length, 'response length() test'); $obj = RPC::XML::response->new(); ok(! ref($obj), 'bad response constructor failed'); like($RPC::XML::ERROR, qr/new: One of a datatype, value or a fault/, 'bad response constructor set error string'); $obj = RPC::XML::response->new(qw(one two)); ok(! ref($obj), 'bad response constructor failed'); like($RPC::XML::ERROR, qr/only one argument/, 'bad response constructor set error string'); $obj = RPC::XML::response->new(RPC::XML::fault->new(1, 'test')); isa_ok($obj, 'RPC::XML::response', '$obj (response/fault)'); # The other methods have already been tested ok($obj->is_fault, 'fault response creation is_fault test'); ### test for bug where encoding was done too freely, encoding ### any ^\d+$ as int, etc { my %map = ( 256 => 'int', 256**4+1 => 'i8', # will do *-1 as well 256**8+1 => 'double', 1e37+1 => 'string', ); while (my ($value, $type) = each %map) { for my $mod (1,-1) { { $obj = smart_encode($mod * $value); ok($obj, "smart_encode zealousness test, $mod * $value"); is($obj->type, $type, 'smart_encode zealousness, non-forced type'); } ### test force string encoding { ### double assign to silence -w local $RPC::XML::FORCE_STRING_ENCODING = 1; local $RPC::XML::FORCE_STRING_ENCODING = 1; $obj = smart_encode($mod * $value); ok($obj, "smart_encode zealousness test, $mod * $value (force)"); is($obj->type, 'string', 'smart_encode zealousness, forced to string'); } } } } # Test for RT# 31818, ensure that very small double values are expressed in # a format that conforms to the XML-RPC spec. is(RPC::XML::double->new(0.000005)->as_string, '0.000005', 'Floating-point format test, RT31818'); exit 0; RPC-XML-0.82/t/60_net_server.t0000644000175000017500000002514213775372465014725 0ustar rjrayrjray#!/usr/bin/env perl # Test the RPC::XML::Server class with Net::Server rather than HTTP::Daemon # This is run after the test suite for RPC::XML::Client, so we will use that # for the client-side of the tests. ## no critic(RequireCheckedClose) ## no critic(RequireInterpolationOfMetachars) use strict; use warnings; use subs qw(start_server find_port); use Carp qw(carp croak); use File::Spec; use Module::Load; use Test::More; use RPC::XML::Server; use RPC::XML::Client; my ($dir, $srv, $pid_file, $log_file, $port, $client, $res, @keys, $meth, $list, $bucket, %seen, $srv_hostname); if ($^O eq 'MSWin32') { # Can't run this (reliably) under Windows: plan skip_all => 'Net::Server tests not reliable on Windows platform'; } elsif (! eval { load Net::Server; 1; }) { # If they do not have Net::Server, quietly skip plan skip_all => 'Net::Server not available'; } else { # otherwise... plan tests => 30; } # Presently, there is a problem with Net::Server+IO::Socket::IP, when the IPv6 # entry for 'localhost' comes before the IPv4 entry in /etc/hosts. For now, to # get through the tests, look for that combination and substitute 127.0.0.1 for # 'localhost' (and hope they don't have a weird network configuration). # See RT#105679. if (eval { load IO::Socket::IP; 1; }) { carp 'Working around an issue with Net::Server+IO::Socket::IP'; $srv_hostname = '127.0.0.1'; } else { $srv_hostname = 'localhost'; } (undef, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0)); require File::Spec->catfile($dir, 'util.pl'); $pid_file = File::Spec->catfile($dir, 'net_server.pid'); $log_file = File::Spec->catfile($dir, 'net_server.log'); if (($port = find_port) == -1) { croak 'No usable port found between 9000 and 11000, skipping'; } unlink $log_file, $pid_file; # All this, and we haven't even created a server object or run a test yet $srv = RPC::XML::Server->new(no_http => 1); # Technically, this is overkill. But if it fails everything else blows up: isa_ok($srv, 'RPC::XML::Server'); if (! ref $srv) { croak "Server allocation failed, cannot continue. Message was: $srv"; } # All of these parameters are passed to the run() method of # Net::Server::MultiType start_server($srv, server_type => 'Single', log_file => $log_file, log_level => 4, pid_file => $pid_file, port => $port, host => $srv_hostname, background => 1); sleep 1; # Allow time for server to spin up # Unless we see "ok 2", we have a problem ok(-e $pid_file, 'server started, PID file exists'); # After this point, we have the obligation of killing the server manually $client = RPC::XML::Client->new("http://$srv_hostname:$port"); is($client->simple_request('system.identity'), $srv->product_tokens, 'system.identity matches $srv->product_tokens'); # At this point, most of this is copied from the first server test suite # (40_server.t). We do want to verify the full introspection API under # Net::Server, though. $res = $client->simple_request('system.listMethods'); @keys = $srv->list_methods; is(ref($res), 'ARRAY', 'system.listMethods returned ARRAY ref'); SKIP: { if (! ref $res) { skip 'server response not an ARRAY reference', 2; } is(scalar(@{$res}), scalar(@keys), 'system.listMethods returned correct number of names'); is(join(q{} => sort @{$res}), join(q{} => sort @keys), 'system.listMethods returned matching set of names'); } # Test the substring-parameter calling of system.listMethods $res = $client->simple_request('system.listMethods', 'method'); is(ref($res), 'ARRAY', 'system.listMethods returned ARRAY ref'); SKIP: { if (! ref $res) { skip 'server response not an ARRAY reference', 1; } is(join(q{,} => sort @{$res}), 'system.methodHelp,system.methodSignature', 'system.listMethods with pattern returned correct set of names'); } # Again, with a pattern that will produce no matches $res = $client->simple_request('system.listMethods', 'none_will_match'); is(ref($res), 'ARRAY', 'system.listMethods returned ARRAY ref'); SKIP: { if (! ref $res) { skip 'server response not an ARRAY reference', 1; } is(scalar(@{$res}), 0, 'system.listMethods with bad pattern returned none'); } # system.status $res = $client->simple_request('system.status'); @keys = qw(host port name version path date date_int started started_int total_requests methods_known); is(ref($res), 'HASH', 'system.status returned HASH ref'); SKIP: { if (! ref $res) { skip 'server response not a HASH reference', 2; } my @seen_keys = grep { defined $res->{$_} } @keys; ok(@keys == @seen_keys, 'system.status hash has correct keys'); is($res->{total_requests}, 5, 'system.status total_request count correct'); } # system.methodHelp $res = $client->simple_request('system.methodHelp', 'system.identity'); is($res, $srv->get_method('system.identity')->{help}, 'system.methodHelp returned correct string'); # system.methodHelp with multiple arguments $res = $client->simple_request('system.methodHelp', [ 'system.identity', 'system.status' ]); is(ref($res), 'ARRAY', 'system.methodHelp returned ARRAY ref'); SKIP: { if (! ref $res) { skip 'server response not an ARRAY reference', 1; } is(join(q{} => @{$res}), $srv->get_method('system.identity')->{help} . $srv->get_method('system.status')->{help}, 'system.methodHelp with specific methods returns correctly'); } # system.methodHelp with an invalid argument $res = $client->send_request('system.methodHelp', 'system.bad'); isa_ok($res, 'RPC::XML::fault', 'system.methodHelp (bad arg) response'); SKIP: { if (! ref $res) { skip 'server response not an RPC::XML data object', 1; } like($res->string(), qr/Method.*unknown/, 'system.methodHelp (bad arg) has correct faultString'); } # system.methodSignature $res = $client->simple_request('system.methodSignature', 'system.methodHelp'); is(ref($res), 'ARRAY', 'system.methodSignature returned ARRAY ref'); SKIP: { if (! ref $res) { skip 'server response not an ARRAY reference', 1; } my $return_sig = join q{} => sort map { join q{ } => @{$_} } @{$res}; my $method_sig = join q{} => sort @{$srv->get_method('system.methodHelp')->{signature}}; is($return_sig, $method_sig, 'system.methodSignature return value correct'); } # system.methodSignature, with an invalid request $res = $client->send_request('system.methodSignature', 'system.bad'); isa_ok($res, 'RPC::XML::fault', 'system.methodSignature (bad arg) response'); SKIP: { if (! ref $res) { skip 'server response not an RPC::XML data object', 1; } like($res->string(), qr/Method.*unknown/, 'system.methodSignature (bad arg) has correct faultString'); } # system.introspection $list = $client->simple_request('system.introspection'); $bucket = 0; %seen = (); SKIP: { if (ref($list) ne 'ARRAY') { skip 'system.introspection call did not return ARRAY ref', 1; } for my $result (@{$list}) { if ($seen{$result->{name}}++) { # If we somehow get the same name twice, that's a point off $bucket++; next; } $meth = $srv->get_method($result->{name}); if ($meth) { my $result_sig = join q{} => sort @{$result->{signature}}; my $method_sig = join q{} => sort @{$meth->{signature}}; # A point off unless all three of these match if (($meth->{help} ne $result->{help}) || ($meth->{version} ne $result->{version}) || ($result_sig ne $method_sig)) { $bucket++; } } else { # That's a point $bucket++; } } ok(! $bucket, 'system.introspection return data is correct'); } # system.multicall $res = $client->simple_request('system.multicall', [ { methodName => 'system.identity' }, { methodName => 'system.listMethods', params => [ 'intro' ] } ]); is(ref($res), 'ARRAY', 'system.multicall returned ARRAY ref'); SKIP: { if (! ref $res) { skip 'server response not an ARRAY reference', 2; } is($res->[0], $srv->product_tokens, 'system.multicall, first return value correct'); SKIP: { if (ref($res->[1]) ne 'ARRAY') { skip 'system.multicall return value second index not ARRAY ref', 1; } is(scalar(@{$res->[1]}), 1, 'system.multicall, second return value correct length'); is($res->[1]->[0], 'system.introspection', 'system.multicall, second return value correct value'); } } # system.multicall, with an attempt at illegal recursion $res = $client->send_request('system.multicall', [ { methodName => 'system.identity' }, { methodName => 'system.multicall', params => [ 'intro' ] } ]); SKIP: { if (ref($res) ne 'RPC::XML::fault') { skip 'system.multicall (recursion) response error, cannot test', 1; } like($res->string, qr/Recursive/, 'system.multicall recursion attempt set correct faultString'); } # system.multicall, with bad data on one of the call specifications $res = $client->send_request('system.multicall', [ { methodName => 'system.identity' }, { methodName => 'system.listMethods', params => 'intro' } ]); SKIP: { if (ref($res) ne 'RPC::XML::fault') { skip 'system.multicall (bad data) response error, cannot test', 1; } like($res->string, qr/value for.*params.*not an array/i, 'system.multicall bad param array set correct faultString'); } # system.status, once more, to check the total_requests value $res = $client->simple_request('system.status'); SKIP: { if (ref($res) ne 'HASH') { skip 'system.status response not HASH ref', 1; } is($res->{total_requests}, 19, 'system.status total_request correct at end of suite'); } # Now that we're done, kill the server and exit if (open my $fh, '<', $pid_file) { chomp(my $pid = <$fh>); close $fh; if ($pid =~ /^(\d+)$/) { kill 'INT', $1; } else { carp "WARNING: $pid_file appears corrupt, zombie processes may remain!"; } } else { carp "WARNING: Opening $pid_file failed: $! (zombie processes may remain)"; } exit; RPC-XML-0.82/t/meth_bad_2.xpl0000644000175000017500000000151311356231360014541 0ustar rjrayrjray system.identity 1.0 string Return the server name and version as a string ############################################################################### # # Sub Name: identity # # Description: Simply returns the server's identity as a string # # Arguments: First arg is server instance # # Globals: None. # # Returns: string # ############################################################################### sub identity { use strict; sprintf('%s/%s', ref($_[0]), $_[0]->version); } RPC-XML-0.82/t/30_procedure.t0000644000175000017500000004375013774651431014533 0ustar rjrayrjray#!/usr/bin/env perl # Test the RPC::XML::Procedure class (and the ::Method and ::Function classes) ## no critic(RequireBriefOpen) ## no critic(RequireCheckedClose) ## no critic(RequireInterpolationOfMetachars) use strict; use warnings; use Carp qw(croak); use File::Spec; use Test::More; use RPC::XML qw($ALLOW_NIL RPC_INT RPC_DATETIME_ISO8601 time2iso8601); use RPC::XML::Procedure; plan tests => 87; my ($obj, $obj2, $flag, $dir, $vol, $tmp, $tmpfile, $fh, $retval); ($vol, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0)); $dir = File::Spec->catpath($vol, $dir, q{}); $tmpfile = File::Spec->catfile($dir, "tmp_xpl_$$.xpl"); # The organization of the test suites is such that we assume anything that # runs before the current suite is 100%. Thus, no consistency checks on # any other classes are done, only on the data and return values of this # class under consideration, RPC::XML::Procedure. As such, we are not testing # any part of the RPC::XML::Server class here. Only the code for managing # methods. # Basic new() success, simple accessors and successful calling $obj = RPC::XML::Procedure->new({ name => 'test.test', signature => [ 'int' ], code => sub { $flag = 1; } }); isa_ok($obj, 'RPC::XML::Procedure', '$obj'); SKIP: { if (ref($obj) ne 'RPC::XML::Procedure') { skip 'Cannot test without object', 15; } # Arguments here don't matter, just testing that trying to call new() on a # referent fails: $obj2 = $obj->new(); like($obj2, qr/Must be called as a static method/, 'Correct error message from bad new()'); ok(($obj->name() eq 'test.test') && ($obj->namespace() eq q{}) && (scalar(@{$obj->signature}) == 1) && ($obj->signature->[0] eq 'int'), 'Basic accessors'); $flag = 0; $retval = eval { $obj->code->(); 1; }; ok($retval && $flag, 'Calling the code'); # What about the missing values? is($obj->help(), q{}, 'Null value for help()'); is($obj->namespace(), q{}, 'Null value for namespace()'); is($obj->version(), 0, 'Zero value for version()'); is($obj->hidden(), 0, 'Zero value for hidden()'); # Try changing the attributes that can change: $obj->help('help'); is($obj->help(), 'help', 'help() changes correctly'); $obj->version('1.1.1'); is($obj->version(), '1.1.1', 'version() changes correctly'); $obj->hidden(1); is($obj->hidden(), 1, 'hidden() changes correctly'); my $sub = sub { 'foo' }; $obj->code($sub); is($obj->code(), $sub, 'code() changes correctly'); # Try a value that should be rejected $obj->code([]); is($obj->code(), $sub, 'code() did not change to a bad value'); # Changing signature() is tricky $obj->signature([ 'int int', 'string string', 'double double' ]); is(scalar(@{$obj->signature}), 3, 'signature() changes correctly'); # This one should fail my $err = $obj->signature([ qw(int double) ]); like($err, qr/Cannot have two different return values/, 'signature() failed correctly on ambiguous data'); is(scalar(@{$obj->signature}), 3, 'signature() reverted to old value'); # This should fail for a different reason $err = $obj->signature(1); like($err, qr/Bad value '1'/, 'signature() failed correctly on bad input'); # What happens if I try reload() on it? $err = $obj->reload(); like($err, qr/No file associated with method/, 'reload() fails OK'); } # Basic new() using faux hash table input $obj = RPC::XML::Procedure->new( name => 'test.test', hidden => 1, signature => 'int int', signature => [ qw(string string) ], code => sub { return 'success'; } ); isa_ok($obj, 'RPC::XML::Procedure', '$obj<2>'); SKIP: { if (ref($obj) ne 'RPC::XML::Procedure') { skip 'Cannot test without object', 2; } ok(($obj->name() eq 'test.test') && ($obj->namespace() eq q{}) && (scalar(@{$obj->signature}) == 2) && ($obj->signature->[0] eq 'int int') && ($obj->signature->[1] eq 'string string'), 'Basic accessors <2>'); $retval = eval { $flag = $obj->code->(); 1; }; ok($retval && ($flag eq 'success'), 'Calling the code <2>'); } # This should succeed, but "hidden" is false because the second overrides the # first. $obj = RPC::XML::Procedure->new( name => 'test.test', hidden => 1, hidden => 0, signature => 'int int', signature => [ qw(string string) ], code => sub { 1; } ); isa_ok($obj, 'RPC::XML::Procedure', '$obj<3>'); is($obj->hidden(), 0, 'hidden() is correctly false'); # This should fail due to missing name $obj = RPC::XML::Procedure->new({ code => sub { 1; } }); like($obj, qr/Missing required data [(]name or code[)]/, 'Correct constructor failure [1]'); # This should fail due to missing code $obj = RPC::XML::Procedure->new({ name => 'test.test1' }); like($obj, qr/Missing required data [(]name or code[)]/, 'Correct constructor failure [2]'); # This should fail due to missing information (the signature) $obj = RPC::XML::Method->new({ name => 'test.test2', code => sub { $flag = 2; } }); like($obj, qr/Missing required data [(]signatures[)]/, 'Correct constructor failure [3]'); # This one fails because the signatures have a collision $obj = RPC::XML::Method->new({ name => 'test.test2', signature => [ 'int int', 'string int' ], code => sub { $flag = 2; } }); like($obj, qr/two different return values for one set of params/, 'Correct constructor failure [4]'); # Fails because of a null signature $obj = RPC::XML::Method->new({ name => 'test.test2', signature => [ q{} ], code => sub { $flag = 2; } }); like($obj, qr/Invalid signature, cannot be null/, 'Correct constructor failure [5]'); # Fails because of an unknown type in the return value slot $obj = RPC::XML::Method->new({ name => 'test.test2', signature => [ 'frob int' ], code => sub { $flag = 2; } }); like($obj, qr/Unknown return type 'frob'/, 'Correct constructor failure [6]'); # Fails because of an unknown type in the args-list $obj = RPC::XML::Method->new({ name => 'test.test2', signature => [ 'int string frob int' ], code => sub { $flag = 2; } }); like($obj, qr/One or more invalid types in signature/, 'Correct constructor failure [7]'); # This file will not load due to missing required information $obj = RPC::XML::Method->new(File::Spec->catfile($dir, 'meth_bad_1.xpl')); like($obj, qr/missing/i, 'Bad XPL [1] not loaded'); # This file will not load due to an XML parsing error $obj = RPC::XML::Method->new(File::Spec->catfile($dir, 'meth_bad_2.xpl')); like($obj, qr/error parsing/i, 'Bad XPL [2] not loaded'); # And the third bowl of porridge was _just_ _right_... $obj = RPC::XML::Method->new(File::Spec->catfile($dir, 'meth_good_1.xpl')); isa_ok($obj, 'RPC::XML::Method', '$obj'); SKIP: { if (ref($obj) ne 'RPC::XML::Method') { skip 'Cannot test without a value $obj', 20; } # Check the basics ok(ref($obj) && $obj->name() && scalar(@{$obj->signature}) && $obj->hidden() && $obj->version() && $obj->help(), 'Good XPL load, basic accessors'); # Is code() the type of ref we expect? ok(ref($obj) && (ref($obj->code) eq 'CODE'), 'Good XPL load, code() accessor'); # This looks more complex than it is. The code returns this specific key, # but because this is a RPC::XML::Method, it expects a ref as the first # argument, representing a RPC::XML::Server (or derived) instance. is($obj->code->(undef, { method_name => $obj->name }), $obj->name(), 'Good XPL load, code() invocation'); # Time to test cloning $obj2 = $obj->clone; # Did it? isa_ok($obj2, ref($obj), '$obj2'); SKIP: { if (ref($obj2) ne ref $obj) { skip 'Clone failed, cannot test without second object', 4; } # Primary accessors/data ok(($obj->name() eq $obj2->name()) && ($obj->version() eq $obj2->version()) && ($obj->help() eq $obj2->help()), 'Compare accessors of clone and source'); # Are the actual listrefs of signatures different? isnt($obj->signature(), $obj2->signature(), 'Clone signature() accessor has different listref'); # And yet, the contents are the same? ok((@{$obj->signature} == @{$obj2->signature}) && # There's only one signature in the list ($obj->signature->[0] eq $obj2->signature->[0]), 'Clone signature() value is same despite this'); # Lastly, and very importantly, the coderefs are still the same is($obj->code(), $obj2->code(), 'Clone code() ref value is same as source'); undef $obj2; # Don't need it anymore } # Now let's play around with signatures a bit # Basic test of match_signature() is($obj->match_signature(q{}), 'string', 'Test match_signature()'); # Add a new signature, simple is($obj->add_signature('int int'), $obj, 'Adding via add_signature() returns obj ref'); # There should now be two is(scalar(@{$obj->{signature}}), 2, 'Number of signatures after add_signature()'); # Does the new one match OK? is($obj->match_signature('int'), 'int', 'New signature matches correctly'); # Try matching it with an array-ref is($obj->match_signature([ 'int' ]), 'int', 'Signature matches arrayref'); # This addition should fail due to ambiguity isnt($tmp = $obj->add_signature([ 'double', 'int' ]), $obj, 'Correct failure of adding ambiguous signature'); # But did it fail for the right reasons? like($tmp, qr/make_sig_table/, 'Signature failure returned correct message'); # Test deletion is($obj->delete_signature('int int'), $obj, 'Test delete_signature()'); # Which means checking the count again is(scalar(@{$obj->{signature}}), 1, 'Correct signature count after delete'); # Try deleting the last signature my $err = $obj->delete_signature('string'); like($err, qr/Cannot delete last signature/, 'Deleting last signature fails'); # Note that deleting a non-existent signature "succeeds" is($obj->delete_signature([ 'int' ]), $obj, 'Attempt to delete non-existent signature'); is(scalar(@{$obj->{signature}}), 1, 'Correct signature count after useless delete'); # We're done with this one for now. undef $obj; } # Check the other two proc-types being loaded from files: $obj = RPC::XML::Procedure->new(File::Spec->catfile($dir, 'meth_good_2.xpl')); isa_ok($obj, 'RPC::XML::Procedure', '$obj'); # This should return an RPC::XML::Function object, despite being called via # RPC::XML::Procedure. $obj = RPC::XML::Procedure->new(File::Spec->catfile($dir, 'meth_good_3.xpl')); isa_ok($obj, 'RPC::XML::Function', '$obj'); # With this later object, test some of the routines that are overridden in # RPC::XML::Function: SKIP: { if (ref($obj) ne 'RPC::XML::Function') { skip 'Cannot test without RPC::XML::Function object', 8; } ok((ref($obj->signature) eq 'ARRAY' && (@{$obj->signature} == 1)), 'RPC::XML::Function valid return from signature() <1>'); is($obj->add_signature('int int'), $obj, 'RPC::XML::Function valid add_signature'); ok((ref($obj->signature) eq 'ARRAY' && (@{$obj->signature} == 1)), 'RPC::XML::Function valid return from signature() <2>'); is($obj->match_signature('int'), 'scalar', 'RPC::XML::Function correct signature match'); is($obj->delete_signature('int int'), $obj, 'RPC::XML::Function valid delete_signature'); ok((ref($obj->signature) eq 'ARRAY' && (@{$obj->signature} == 1)), 'RPC::XML::Function valid return from signature() <3>'); # Can we clone it? $obj2 = $obj->clone(); isa_ok($obj2, ref($obj), '$obj2'); ok(($obj->name() eq $obj2->name()) && ($obj->version() eq $obj2->version()) && ($obj->help() eq $obj2->help()), 'Compare accessors of clone and source'); is($obj->code(), $obj2->code(), 'Clone code() ref value is same as source'); } # But this should fail, as only RPC::XML::Procedure is allowed to act as a # factory constructor: $obj = RPC::XML::Method->new(File::Spec->catfile($dir, 'meth_good_3.xpl')); like($obj, qr/must match this calling class/, 'Correct error message on bad constructor call'); # Test procedures that utilize nil data-types $ALLOW_NIL = 1; # First a simple nil-return $obj = RPC::XML::Procedure->new({ name => 'test.test_nil', signature => [ 'nil' ], code => sub { return; } }); isa_ok($obj, 'RPC::XML::Procedure'); SKIP: { if (ref($obj) ne 'RPC::XML::Procedure') { skip 'Cannot test without object', 2; } my $val; $retval = eval { $val = $obj->call({}); 1; }; ok($retval, 'Calling test.test_nil'); isa_ok($val, 'RPC::XML::nil', 'Return value'); } # Nil return from a proc with argument(s) $obj = RPC::XML::Procedure->new({ name => 'test.test_nil2', signature => [ 'nil int' ], code => sub { my $int = shift; return; } }); isa_ok($obj, 'RPC::XML::Procedure'); SKIP: { if (ref($obj) ne 'RPC::XML::Procedure') { skip 'Cannot test without object', 2; } my $val; $retval = eval { $val = $obj->call({}, RPC_INT 1); 1; }; ok($retval, 'Calling test.test_nil2'); isa_ok($val, 'RPC::XML::nil', 'Return value'); } # Return value properly ignored when the signature types it as nil $obj = RPC::XML::Procedure->new({ name => 'test.test_nil3', signature => [ 'nil' ], code => sub { 1; } }); isa_ok($obj, 'RPC::XML::Procedure'); SKIP: { if (ref($obj) ne 'RPC::XML::Procedure') { skip 'Cannot test without object', 2; } my $val; $retval = eval { $val = $obj->call({}); 1; }; ok($retval, 'Calling test.test_nil3'); isa_ok($val, 'RPC::XML::nil', 'Return value'); } # Make sure that the presence of nil in a signature doesn't interfere with # proper look-ups $obj = RPC::XML::Procedure->new({ name => 'test.test_nil4', signature => [ 'nil int' ], code => sub { return; } }); isa_ok($obj, 'RPC::XML::Procedure'); SKIP: { if (ref($obj) ne 'RPC::XML::Procedure') { skip 'Cannot test without object', 2; } is($obj->match_signature('int'), 'nil', 'Test match_signature() with nil'); ok(! $obj->match_signature('string'), 'Test match_signature() with nil [2]'); } # This one will be fun. To truly test the reload() method, I need a file to # actually change. So create a file, load it as XPL, rewrite it and reload it. if (! (open $fh, '>', $tmpfile)) { croak "Error opening $tmpfile for writing: $!"; } print {$fh} <<'END'; test 1.0 string Simple test method for RPC::XML::Procedure class sub test { 'foo' } END close $fh; $obj = RPC::XML::Procedure->new($tmpfile); isa_ok($obj, 'RPC::XML::Procedure', '$obj'); SKIP: { if (ref($obj) ne 'RPC::XML::Procedure') { skip 'Cannot test without object', 3; } if (! (open $fh, '>', $tmpfile)) { croak "Error opening $tmpfile for writing: $!"; } print {$fh} <<'END'; test 1.0 string Simple test method for RPC::XML::Procedure class sub test { 'bar' } END close $fh; is($obj->reload(), $obj, 'reload() returns ok'); my $val; $retval = eval { $val = $obj->call(); 1; }; ok($retval && ($val->value eq 'bar'), 'Reloaded method gave correct value'); # Try to reload again, after unlinking the file unlink $tmpfile; $val = $obj->reload(); like($val, qr/Error loading/, 'Correct error from reload() after unlink'); } # Per RT#71452, I learned that I never tested dateTime.iso8601 in any of the # signatures/calls, and that as of release 0.76, I may have bugs... undef $obj; $obj = RPC::XML::Procedure->new( name => 'test.iso8601', signature => 'string dateTime.iso8601', code => sub { my $date = shift; return substr $date, 0, 4; }, ); isa_ok($obj, 'RPC::XML::Procedure', '$obj'); SKIP: { if (ref($obj) ne 'RPC::XML::Procedure') { skip 'Cannot test without object', 2; } is($obj->match_signature('dateTime.iso8601'), 'string', 'Test match_signature() with a dateTime.iso8601 input'); my $time = time2iso8601; my $year = substr $time, 0, 4; is($obj->call({}, RPC_DATETIME_ISO8601 $time)->value, $year, 'Test a call with a dateTime.iso8601 argument'); } $obj = RPC::XML::Procedure->new( name => 'test.iso8601', signature => 'dateTime.iso8601 int', code => sub { my $time = shift; return time2iso8601($time); }, ); isa_ok($obj, 'RPC::XML::Procedure', '$obj'); SKIP: { if (ref($obj) ne 'RPC::XML::Procedure') { skip 'Cannot test without object', 2; } is($obj->match_signature('int'), 'dateTime.iso8601', 'Test match_signature() with a dateTime.iso8601 output'); my $time = time; is($obj->call({}, RPC_INT $time)->value, time2iso8601($time), 'Test a call with a dateTime.iso8601 return value'); } END { # Just in case... if (-e $tmpfile) { unlink $tmpfile; } } exit 0; RPC-XML-0.82/t/14_datetime_iso8601.t0000644000175000017500000000440013774651431015517 0ustar rjrayrjray#!/usr/bin/env perl # Test the date-parsing facilities provided by the DateTime::Format::ISO8601 # module, if available use strict; use warnings; use Module::Load; use Test::More; use RPC::XML; my ($obj, @values, $formatter); my $datetime_format_iso8601_avail = eval { load DateTime::Format::ISO8601; 1; }; # Do not run this suite if the package is not available if (! $datetime_format_iso8601_avail) { plan skip_all => 'DateTime::Format::ISO8601 not available'; } # Otherwise, we have to calculate our tests from the content after __DATA__: while (defined(my $line = )) { next if ($line =~ /^#/); chomp $line; next if (! $line); push @values, [ split /[|]/, $line ]; } plan tests => (scalar(@values) * 2); # Create a formatter from the DateTime::Format::ISO8601 package, we'll use it # to determine what the constructor *should* return: $formatter = DateTime::Format::ISO8601->new(); for my $test (0 .. $#values) { my ($input, $is_error) = @{$values[$test]}; $obj = RPC::XML::datetime_iso8601->new($input); if (! $is_error) { my $match = $formatter->parse_datetime($input); $match =~ s/-//g; isa_ok($obj, 'RPC::XML::datetime_iso8601', "Input $test \$obj"); is($obj->value, $match, "Input '$input' yielded correct value"); } else { ok(! ref($obj), "Input $test yielded no object"); like($RPC::XML::ERROR, qr/Malformed data [(]$input[)]/, "Input '$input' yielded correct error message"); } } exit 0; __DATA__ # Format is: # | # # If the second field is non-blank, then the input should yield an error # # I am skipping some of the sillier formats, as I don't care if people use them # and get unexpected results. Caveat Programmer, and all that... 20110820 2011-08-20 2011-08 2011 110820 11-08-20 -1108 -11-08 --0820 --08-20 --08 ---20 2011232 2011-232 11232 11-232 -232 2011W336 2011-W33-6 2011W33 2011-W33 11W336 11-W33-6 11W33 11-W33 -1W336 -1-W33-6 -1W33 -1-W33 -W336 -W33-6 17:55:55 17:55 175555,50 17:55:55,50 175555.50 1755.50 17:55.50 17.50 -55:00 -5500,50 -55.50 --00.0 175555Z 17:55:55Z 1755Z 17:55Z 17Z 175555.0Z 17:55:55.0Z 175555-0700 17:55:55-07:00 175555-07 17:55:55-07 175555.0-0700 17:55:55.0-07:00 17,01|bad 20110820175555|bad RPC-XML-0.82/t/00_load.t0000644000175000017500000000235612420753461013445 0ustar rjrayrjray#!/usr/bin/env perl use strict; use warnings; use Module::Load; use Test::More; # Verify that the individual modules will load my @MODULES = qw( RPC::XML RPC::XML::Client RPC::XML::Parser RPC::XML::Parser::XMLParser RPC::XML::ParserFactory RPC::XML::Procedure RPC::XML::Server ); my @APACHE_MODULES = qw(Apache::RPC::Server Apache::RPC::Status); my @LIBXML_MODULES = qw(RPC::XML::Parser::XMLLibXML); # If mod_perl is not available, Apache::RPC::Server cannot be blamed my $do_apache = eval { load Apache; 1; }; # If XML::LibXML is not installed, also skip RPC::XML::Parser::XMLLibXML my $do_libxml = eval { load XML::LibXML; 1; }; plan tests => (@MODULES + @APACHE_MODULES + @LIBXML_MODULES); # Core modules for my $module (@MODULES) { use_ok $module; } # Test these only if XML::LibXML is available SKIP: { if (! $do_libxml) { skip 'No XML::LibXML detected', scalar @LIBXML_MODULES; } for my $module (@LIBXML_MODULES) { use_ok $module; } } # Test these only if Apache (v1) is available SKIP: { if (! $do_apache) { skip 'No mod_perl 1.X detected', scalar @APACHE_MODULES; } for my $module (@APACHE_MODULES) { use_ok $module; } } exit 0; RPC-XML-0.82/t/namespace3.xpl0000644000175000017500000000050011622765353014601 0ustar rjrayrjray nstest3 Test::NS 1.0 string Namespace test method for RPC::XML::Method suite sub test { no strict; $value } RPC-XML-0.82/t/70_compression_detect.t0000644000175000017500000000367212420753461016430 0ustar rjrayrjray#!/usr/bin/env perl # Test whether the client and server classes correctly detect the presence # or absence of compression support. use strict; use warnings; use Module::Load; use Symbol 'delete_package'; use Test::More; # These are the modules that need to correctly detect compression: our %TEST_PKGS = ('RPC::XML::Client' => 'RPC/XML/Client.pm', 'RPC::XML::Server' => 'RPC/XML/Server.pm'); plan tests => (2 * (scalar keys %TEST_PKGS)); # This will prevent Compress::Zlib from loading, regardless of whether it is # available: unshift @INC, sub { die "Force-failing Compress::Zlib\n" if ($_[1] eq 'Compress/Zlib.pm'); return; }; for my $pkg (sort keys %TEST_PKGS) { # Needed to soft-deref ${pkg}::COMPRESSION_AVAILABLE ## no critic (ProhibitNoStrict) no strict 'refs'; load $pkg; is(${"${pkg}::COMPRESSION_AVAILABLE"}, q{}, "$pkg correctly saw no Compress::Zlib"); # Remove from %INC so later tests still run clear($pkg, $TEST_PKGS{$pkg}); } # Determine if we actually *do* have Compress::Zlib available: shift @INC; # First drop the force-failure sub from above my $compression_available = eval { load Compress::Zlib; 1; }; SKIP: { # Test successful detection, but only if we actually have Compress::Zlib if (! $compression_available) { skip 'Compress::Zlib truly not available', (scalar keys %TEST_PKGS); } for my $pkg (sort keys %TEST_PKGS) { # Needed to soft-deref ${pkg}::COMPRESSION_AVAILABLE ## no critic (ProhibitNoStrict) no strict 'refs'; load $pkg; # I am not explicitly testing for "deflate" here, because that might # change in the future. What matters is that it is not null. isnt(${"${pkg}::COMPRESSION_AVAILABLE"}, q{}, "$pkg correctly detected Compress::Zlib"); } } exit; sub clear { my ($pkg, $file) = @_; delete $INC{$file}; delete_package($pkg); return; } RPC-XML-0.82/perlcritic.rc0000644000175000017500000015027213775213737014301 0ustar rjrayrjray# Globals severity = 1 # force = 0 # only = 0 # allow-unsafe = 0 # profile-strictness = warn # color = 0 # pager = # top = 0 # verbose = 4 # include = # exclude = # single-policy = # theme = # color-severity-highest = bold red # color-severity-high = magenta # color-severity-medium = # color-severity-low = # color-severity-lowest = # program-extensions = # Use `List::MoreUtils::any' instead of `grep' in boolean context. [BuiltinFunctions::ProhibitBooleanGrep] # set_themes = core pbp performance # add_themes = # severity = 2 # maximum_violations_per_document = no_limit # Map blocks should have a single statement. [BuiltinFunctions::ProhibitComplexMappings] # set_themes = complexity core maintenance pbp # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # The maximum number of statements to allow within a map block. # Minimum value 1. No maximum. # max_statements = 1 # Use 4-argument `substr' instead of writing `substr($foo, 2, 6) = $bar'. [BuiltinFunctions::ProhibitLvalueSubstr] # set_themes = core maintenance pbp # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # Forbid $b before $a in sort blocks. [BuiltinFunctions::ProhibitReverseSortBlock] # set_themes = core cosmetic pbp # add_themes = # severity = 1 # maximum_violations_per_document = no_limit # Use Time::HiRes instead of something like `select(undef, undef, undef, .05)'. [BuiltinFunctions::ProhibitSleepViaSelect] # set_themes = bugs core pbp # add_themes = # severity = 5 # maximum_violations_per_document = no_limit # Write `eval { my $foo; bar($foo) }' instead of `eval "my $foo; bar($foo);"'. [BuiltinFunctions::ProhibitStringyEval] # set_themes = bugs core pbp # add_themes = # severity = 5 # maximum_violations_per_document = no_limit # Allow eval of "use" and "require" strings. # allow_includes = 0 # Write `split /-/, $string' instead of `split '-', $string'. [BuiltinFunctions::ProhibitStringySplit] # set_themes = core cosmetic pbp # add_themes = # severity = 2 # maximum_violations_per_document = no_limit # Write `eval { $foo->can($name) }' instead of `UNIVERSAL::can($foo, $name)'. [BuiltinFunctions::ProhibitUniversalCan] # set_themes = core maintenance # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # Write `eval { $foo->isa($pkg) }' instead of `UNIVERSAL::isa($foo, $pkg)'. [BuiltinFunctions::ProhibitUniversalIsa] # set_themes = core maintenance # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # Don't use `grep' in void contexts. [BuiltinFunctions::ProhibitVoidGrep] # set_themes = core maintenance # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # Don't use `map' in void contexts. [BuiltinFunctions::ProhibitVoidMap] # set_themes = core maintenance # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # Write `grep { $_ =~ /$pattern/ } @list' instead of `grep /$pattern/, @list'. [BuiltinFunctions::RequireBlockGrep] # set_themes = bugs core pbp # add_themes = # severity = 4 # maximum_violations_per_document = no_limit # Write `map { $_ =~ /$pattern/ } @list' instead of `map /$pattern/, @list'. [BuiltinFunctions::RequireBlockMap] # set_themes = bugs core pbp # add_themes = # severity = 4 # maximum_violations_per_document = no_limit # Use `glob q{*}' instead of <*>. [BuiltinFunctions::RequireGlobFunction] # set_themes = bugs core pbp # add_themes = # severity = 5 # maximum_violations_per_document = no_limit # Sort blocks should have a single statement. [BuiltinFunctions::RequireSimpleSortBlock] # set_themes = complexity core maintenance pbp # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # AUTOLOAD methods should be avoided. [ClassHierarchies::ProhibitAutoloading] # set_themes = core maintenance pbp # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # Employ `use base' instead of `@ISA'. [ClassHierarchies::ProhibitExplicitISA] # set_themes = core maintenance pbp # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # Write `bless {}, $class;' instead of just `bless {};'. [ClassHierarchies::ProhibitOneArgBless] # set_themes = bugs core pbp # add_themes = # severity = 5 # maximum_violations_per_document = no_limit # Use spaces instead of tabs. [CodeLayout::ProhibitHardTabs] # set_themes = core cosmetic # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # Allow hard tabs before first non-whitespace character. # allow_leading_tabs = 1 # Write `open $handle, $path' instead of `open($handle, $path)'. [CodeLayout::ProhibitParensWithBuiltins] # set_themes = core cosmetic pbp # add_themes = # severity = 1 # maximum_violations_per_document = no_limit # Write `qw(foo bar baz)' instead of `('foo', 'bar', 'baz')'. [CodeLayout::ProhibitQuotedWordLists] # set_themes = core cosmetic # add_themes = # severity = 2 # maximum_violations_per_document = no_limit # The minimum number of words in a list that will be complained about. # Minimum value 1. No maximum. # min_elements = 2 # Complain even if there are non-word characters in the values. # strict = 0 # Don't use whitespace at the end of lines. [CodeLayout::ProhibitTrailingWhitespace] # set_themes = core maintenance # add_themes = # severity = 1 # maximum_violations_per_document = no_limit # Use the same newline through the source. [CodeLayout::RequireConsistentNewlines] # set_themes = bugs core # add_themes = # severity = 4 # maximum_violations_per_document = no_limit # Must run code through perltidy. [-CodeLayout::RequireTidyCode] # set_themes = core cosmetic pbp # add_themes = # severity = 1 # maximum_violations_per_document = no_limit # The Perl::Tidy configuration file to use, if any. # perltidyrc = # Put a comma at the end of every multi-line list declaration, including the last one. [CodeLayout::RequireTrailingCommas] # set_themes = core cosmetic pbp # add_themes = # severity = 1 # maximum_violations_per_document = no_limit # Write `for(0..20)' instead of `for($i=0; $i<=20; $i++)'. [ControlStructures::ProhibitCStyleForLoops] # set_themes = core maintenance pbp # add_themes = # severity = 2 # maximum_violations_per_document = no_limit # Don't write long "if-elsif-elsif-elsif-elsif...else" chains. [ControlStructures::ProhibitCascadingIfElse] # set_themes = complexity core maintenance pbp # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # The maximum number of alternatives that will be allowed. # Minimum value 1. No maximum. max_elsif = 6 # Don't write deeply nested loops and conditionals. [ControlStructures::ProhibitDeepNests] # set_themes = complexity core maintenance # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # The maximum number of nested constructs to allow. # Minimum value 1. No maximum. max_nests = 6 # Don't use labels that are the same as the special block names. [ControlStructures::ProhibitLabelsWithSpecialBlockNames] # set_themes = bugs core # add_themes = # severity = 4 # maximum_violations_per_document = no_limit # Don't modify `$_' in list functions. [ControlStructures::ProhibitMutatingListFunctions] # set_themes = bugs core pbp # add_themes = # severity = 5 # maximum_violations_per_document = no_limit # The base set of functions to check. # list_funcs = map grep List::Util::first List::MoreUtils::any List::MoreUtils::all List::MoreUtils::none List::MoreUtils::notall List::MoreUtils::true List::MoreUtils::false List::MoreUtils::firstidx List::MoreUtils::first_index List::MoreUtils::lastidx List::MoreUtils::last_index List::MoreUtils::insert_after List::MoreUtils::insert_after_string # The set of functions to check, in addition to those given in list_funcs. # add_list_funcs = # Don't use operators like `not', `!~', and `le' within `until' and `unless'. [ControlStructures::ProhibitNegativeExpressionsInUnlessAndUntilConditions] # set_themes = core maintenance pbp # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # Write `if($condition){ do_something() }' instead of `do_something() if $condition'. [ControlStructures::ProhibitPostfixControls] # set_themes = core cosmetic pbp # add_themes = # severity = 2 # maximum_violations_per_document = no_limit # The permitted postfix controls. # Valid values: for, foreach, if, unless, until, when, while. # allow = # The exempt flow control functions. # flowcontrol = carp cluck confess croak die exit goto warn # Write `if(! $condition)' instead of `unless($condition)'. [ControlStructures::ProhibitUnlessBlocks] # set_themes = core cosmetic pbp # add_themes = # severity = 2 # maximum_violations_per_document = no_limit # Don't write code after an unconditional `die, exit, or next'. [ControlStructures::ProhibitUnreachableCode] # set_themes = bugs core # add_themes = # severity = 4 # maximum_violations_per_document = no_limit # Write `while(! $condition)' instead of `until($condition)'. [ControlStructures::ProhibitUntilBlocks] # set_themes = core cosmetic pbp # add_themes = # severity = 2 # maximum_violations_per_document = no_limit # Check your spelling. [-Documentation::PodSpelling] # set_themes = core cosmetic pbp # add_themes = # severity = 1 # maximum_violations_per_document = no_limit # The command to invoke to check spelling. # spell_command = aspell list # The words to not consider as misspelled. # stop_words = # A file containing words to not consider as misspelled. # stop_words_file = # The `=head1 NAME' section should match the package. [Documentation::RequirePackageMatchesPodName] # set_themes = core cosmetic # add_themes = # severity = 1 # maximum_violations_per_document = no_limit # All POD should be after `__END__'. [Documentation::RequirePodAtEnd] # set_themes = core cosmetic pbp # add_themes = # severity = 1 # maximum_violations_per_document = no_limit # Provide text to display with your pod links. [Documentation::RequirePodLinksIncludeText] # set_themes = core maintenance # add_themes = # severity = 2 # maximum_violations_per_document = no_limit # Allow external sections without text. # allow_external_sections = 1 # Allow internal sections without text. # allow_internal_sections = 1 # Organize your POD into the customary sections. [Documentation::RequirePodSections] # set_themes = core maintenance pbp # add_themes = # severity = 2 # maximum_violations_per_document = no_limit # The sections to require for modules (separated by qr/\s* [|] \s*/xms). lib_sections = NAME | SYNOPSIS | DESCRIPTION | SUBROUTINES/METHODS | DIAGNOSTICS | BUGS | SUPPORT | LICENSE AND COPYRIGHT | AUTHOR # The sections to require for programs (separated by qr/\s* [|] \s*/xms). script_sections = NAME | SYNOPSIS | DESCRIPTION | REQUIRED ARGUMENTS | OPTIONS | EXIT STATUS | BUGS | SUPPORT | LICENSE AND COPYRIGHT | AUTHOR # The origin of sections to use. # Valid values: book, book_first_edition, module_starter_pbp, module_starter_pbp_0_0_3. # source = book_first_edition # The spelling of sections to use. # Valid values: en_AU, en_US. # language = # Use functions from Carp instead of `warn' or `die'. [ErrorHandling::RequireCarping] # set_themes = core maintenance pbp # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # Don't complain about die or warn if the message ends in a newline. # allow_messages_ending_with_newlines = 1 # Don't complain about die or warn in main::, unless in a subroutine. # allow_in_main_unless_in_subroutine = 0 # You can't depend upon the value of `$@'/`$EVAL_ERROR' to tell whether an `eval' failed. [ErrorHandling::RequireCheckingReturnValueOfEval] # set_themes = bugs core # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # Discourage stuff like `@files = `ls $directory`'. [InputOutput::ProhibitBacktickOperators] # set_themes = core maintenance # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # Allow backticks everywhere except in void contexts. # only_in_void_context = # Write `open my $fh, q{<}, $filename;' instead of `open FH, q{<}, $filename;'. [InputOutput::ProhibitBarewordFileHandles] # set_themes = bugs core pbp # add_themes = # severity = 5 # maximum_violations_per_document = no_limit # Use "<>" or "" or a prompting module instead of "". [InputOutput::ProhibitExplicitStdin] # set_themes = core maintenance pbp # add_themes = # severity = 4 # maximum_violations_per_document = no_limit # Use prompt() instead of -t. [InputOutput::ProhibitInteractiveTest] # set_themes = bugs core pbp # add_themes = # severity = 5 # maximum_violations_per_document = no_limit # Use `local $/ = undef' or File::Slurp instead of joined readline. [InputOutput::ProhibitJoinedReadline] # set_themes = core pbp performance # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # Never write `select($fh)'. [InputOutput::ProhibitOneArgSelect] # set_themes = bugs core pbp # add_themes = # severity = 4 # maximum_violations_per_document = no_limit # Write `while( $line = <> ){...}' instead of `for(<>){...}'. [InputOutput::ProhibitReadlineInForLoop] # set_themes = bugs core pbp # add_themes = # severity = 4 # maximum_violations_per_document = no_limit # Write `open $fh, q{<}, $filename;' instead of `open $fh, "<$filename";'. [InputOutput::ProhibitTwoArgOpen] # set_themes = bugs core pbp security # add_themes = # severity = 5 # maximum_violations_per_document = no_limit # Write `print {$FH} $foo, $bar;' instead of `print $FH $foo, $bar;'. [InputOutput::RequireBracedFileHandleWithPrint] # set_themes = core cosmetic pbp # add_themes = # severity = 1 # maximum_violations_per_document = no_limit # Close filehandles as soon as possible after opening them. [InputOutput::RequireBriefOpen] # set_themes = core maintenance pbp # add_themes = # severity = 4 # maximum_violations_per_document = no_limit # The maximum number of lines between an open() and a close(). # Minimum value 1. No maximum. # lines = 9 # Write `my $error = close $fh;' instead of `close $fh;'. [InputOutput::RequireCheckedClose] # set_themes = core maintenance # add_themes = # severity = 2 # maximum_violations_per_document = no_limit # Write `my $error = open $fh, $mode, $filename;' instead of `open $fh, $mode, $filename;'. [InputOutput::RequireCheckedOpen] # set_themes = core maintenance # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # Return value of flagged function ignored. [-InputOutput::RequireCheckedSyscalls] # set_themes = core maintenance # add_themes = # severity = 1 # maximum_violations_per_document = no_limit # The set of functions to require checking the return value of. # functions = open close print say # The set of functions to not require checking the return value of. # exclude_functions = # Write `open $fh, q{<:encoding(UTF-8)}, $filename;' instead of `open $fh, q{{<:utf8}, $filename;'. [InputOutput::RequireEncodingWithUTF8Layer] # set_themes = bugs core security # add_themes = # severity = 5 # maximum_violations_per_document = no_limit # Do not use `format'. [Miscellanea::ProhibitFormats] # set_themes = core maintenance pbp # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # Do not use `tie'. [Miscellanea::ProhibitTies] # set_themes = core maintenance pbp # add_themes = # severity = 2 # maximum_violations_per_document = no_limit # Forbid a bare `## no critic' [Miscellanea::ProhibitUnrestrictedNoCritic] # set_themes = core maintenance # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # Remove ineffective "## no critic" annotations. [Miscellanea::ProhibitUselessNoCritic] # set_themes = core maintenance # add_themes = # severity = 2 # maximum_violations_per_document = no_limit # Export symbols via `@EXPORT_OK' or `%EXPORT_TAGS' instead of `@EXPORT'. [Modules::ProhibitAutomaticExportation] # set_themes = bugs core # add_themes = # severity = 4 # maximum_violations_per_document = no_limit # Avoid putting conditional logic around compile-time includes. [Modules::ProhibitConditionalUseStatements] # set_themes = bugs core # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # Ban modules that aren't blessed by your shop. [Modules::ProhibitEvilModules] # set_themes = bugs core # add_themes = # severity = 5 # maximum_violations_per_document = no_limit # The names of or patterns for modules to forbid. # modules = Class::ISA {Found use of Class::ISA. This module is deprecated by the Perl 5 Porters.} Pod::Plainer {Found use of Pod::Plainer. This module is deprecated by the Perl 5 Porters.} Shell {Found use of Shell. This module is deprecated by the Perl 5 Porters.} Switch {Found use of Switch. This module is deprecated by the Perl 5 Porters.} # A file containing names of or patterns for modules to forbid. # modules_file = # Minimize complexity in code that is outside of subroutines. [Modules::ProhibitExcessMainComplexity] # set_themes = complexity core maintenance # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # The maximum complexity score allowed. # Minimum value 1. No maximum. # max_mccabe = 20 # Put packages (especially subclasses) in separate files. [Modules::ProhibitMultiplePackages] # set_themes = bugs core # add_themes = # severity = 4 # maximum_violations_per_document = no_limit # Write `require Module' instead of `require 'Module.pm''. [Modules::RequireBarewordIncludes] # set_themes = core portability # add_themes = # severity = 5 # maximum_violations_per_document = no_limit # End each module with an explicitly `1;' instead of some funky expression. [Modules::RequireEndWithOne] # set_themes = bugs core pbp # add_themes = # severity = 4 # maximum_violations_per_document = no_limit # Always make the `package' explicit. [Modules::RequireExplicitPackage] # set_themes = bugs core # add_themes = # severity = 4 # maximum_violations_per_document = 1 # Don't require programs to contain a package statement. # exempt_scripts = 1 # Allow the specified modules to be imported outside a package. allow_import_of = strict warnings # Package declaration must match filename. [Modules::RequireFilenameMatchesPackage] # set_themes = bugs core # add_themes = # severity = 5 # maximum_violations_per_document = no_limit # `use English' must be passed a `-no_match_vars' argument. [Modules::RequireNoMatchVarsWithUseEnglish] # set_themes = core performance # add_themes = # severity = 2 # maximum_violations_per_document = no_limit # Give every module a `$VERSION' number. [Modules::RequireVersionVar] # set_themes = core pbp readability # add_themes = # severity = 2 # maximum_violations_per_document = no_limit # Distinguish different program components by case. [NamingConventions::Capitalization] # set_themes = core cosmetic pbp # add_themes = # severity = 1 # maximum_violations_per_document = no_limit # How package name components should be capitalized. Valid values are :single_case, :all_lower, :all_upper:, :starts_with_lower, :starts_with_upper, :no_restriction, or a regex. # packages = :starts_with_upper # Package names that are exempt from capitalization rules. The values here are regexes that will be surrounded by \A and \z. # package_exemptions = main # How subroutine names should be capitalized. Valid values are :single_case, :all_lower, :all_upper, :starts_with_lower, :starts_with_upper, :no_restriction, or a regex. # subroutines = :single_case # Subroutine names that are exempt from capitalization rules. The values here are regexes that will be surrounded by \A and \z. # subroutine_exemptions = AUTOLOAD BUILD BUILDARGS CLEAR CLOSE DELETE DEMOLISH DESTROY EXISTS EXTEND FETCH FETCHSIZE FIRSTKEY GETC NEXTKEY POP PRINT PRINTF PUSH READ READLINE SCALAR SHIFT SPLICE STORE STORESIZE TIEARRAY TIEHANDLE TIEHASH TIESCALAR UNSHIFT UNTIE WRITE # How local lexical variables names should be capitalized. Valid values are :single_case, :all_lower, :all_upper, :starts_with_lower, :starts_with_upper, :no_restriction, or a regex. # local_lexical_variables = :single_case # Local lexical variable names that are exempt from capitalization rules. The values here are regexes that will be surrounded by \A and \z. # local_lexical_variable_exemptions = # How lexical variables that are scoped to a subset of subroutines, should be capitalized. Valid values are :single_case, :all_lower, :all_upper, :starts_with_lower, :starts_with_upper, :no_restriction, or a regex. # scoped_lexical_variables = :single_case # Names for variables in anonymous blocks that are exempt from capitalization rules. The values here are regexes that will be surrounded by \A and \z. # scoped_lexical_variable_exemptions = # How lexical variables at the file level should be capitalized. Valid values are :single_case, :all_lower, :all_upper, :starts_with_lower, :starts_with_upper, :no_restriction, or a regex. # file_lexical_variables = :single_case # File-scope lexical variable names that are exempt from capitalization rules. The values here are regexes that will be surrounded by \A and \z. # file_lexical_variable_exemptions = # How global (package) variables should be capitalized. Valid values are :single_case, :all_lower, :all_upper, :starts_with_lower, :starts_with_upper, :no_restriction, or a regex. # global_variables = :single_case # Global variable names that are exempt from capitalization rules. The values here are regexes that will be surrounded by \A and \z. # global_variable_exemptions = \$VERSION @ISA @EXPORT(?:_OK)? %EXPORT_TAGS \$AUTOLOAD %ENV %SIG \$TODO # How constant names should be capitalized. Valid values are :single_case, :all_lower, :all_upper, :starts_with_lower, :starts_with_upper, :no_restriction, or a regex. # constants = :all_upper # Constant names that are exempt from capitalization rules. The values here are regexes that will be surrounded by \A and \z. # constant_exemptions = # How labels should be capitalized. Valid values are :single_case, :all_lower, :all_upper, :starts_with_lower, :starts_with_upper, :no_restriction, or a regex. # labels = :all_upper # Labels that are exempt from capitalization rules. The values here are regexes that will be surrounded by \A and \z. # label_exemptions = # Don't use vague variable or subroutine names like 'last' or 'record'. [NamingConventions::ProhibitAmbiguousNames] # set_themes = core maintenance pbp # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # The variable names that are not to be allowed. # forbid = abstract bases close contract last left no record right second set # Prohibit indirect object call syntax. [Objects::ProhibitIndirectSyntax] # set_themes = core maintenance pbp # add_themes = # severity = 4 # maximum_violations_per_document = no_limit # Indirect method syntax is forbidden for these methods. # Values that are always included: new. # forbid = # Write `@{ $array_ref }' instead of `@$array_ref'. [References::ProhibitDoubleSigils] # set_themes = core cosmetic pbp # add_themes = # severity = 2 # maximum_violations_per_document = no_limit # Capture variable used outside conditional. [RegularExpressions::ProhibitCaptureWithoutTest] # set_themes = core maintenance pbp # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # Names of ways to generate exceptions. # Values that are always included: confess, croak, die. # exception_source = # Split long regexps into smaller `qr//' chunks. [RegularExpressions::ProhibitComplexRegexes] # set_themes = core maintenance pbp # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # The maximum number of characters to allow in a regular expression. # Minimum value 1. No maximum. # max_characters = 60 # Use named character classes instead of explicit character lists. [RegularExpressions::ProhibitEnumeratedClasses] # set_themes = core cosmetic pbp unicode # add_themes = # severity = 1 # maximum_violations_per_document = no_limit # Use character classes for literal meta-characters instead of escapes. [RegularExpressions::ProhibitEscapedMetacharacters] # set_themes = core cosmetic pbp # add_themes = # severity = 1 # maximum_violations_per_document = no_limit # Use `eq' or hash instead of fixed-pattern regexps. [RegularExpressions::ProhibitFixedStringMatches] # set_themes = core pbp performance # add_themes = # severity = 2 # maximum_violations_per_document = no_limit # Use `[abc]' instead of `a|b|c'. [RegularExpressions::ProhibitSingleCharAlternation] # set_themes = core pbp performance # add_themes = # severity = 1 # maximum_violations_per_document = no_limit # Only use a capturing group if you plan to use the captured value. [RegularExpressions::ProhibitUnusedCapture] # set_themes = core maintenance pbp # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # Use only `//' or `{}' to delimit regexps. [RegularExpressions::ProhibitUnusualDelimiters] # set_themes = core cosmetic pbp # add_themes = # severity = 1 # maximum_violations_per_document = no_limit # In addition to allowing '{}', allow '()', '[]', and '{}'. # allow_all_brackets = # Use `{' and `}' to delimit multi-line regexps. [RegularExpressions::RequireBracesForMultiline] # set_themes = core cosmetic pbp # add_themes = # severity = 1 # maximum_violations_per_document = no_limit # In addition to allowing '{}', allow '()', '[]', and '{}'. # allow_all_brackets = # Always use the `/s' modifier with regular expressions. [-RegularExpressions::RequireDotMatchAnything] # set_themes = core cosmetic pbp # add_themes = # severity = 2 # maximum_violations_per_document = no_limit # Always use the `/x' modifier with regular expressions. [RegularExpressions::RequireExtendedFormatting] # set_themes = core maintenance pbp # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # The number of characters that a regular expression must contain before this policy will complain. # Minimum value 0. No maximum. minimum_regex_length_to_complain_about = 40 # Should regexes that only contain whitespace and word characters be complained about?. # strict = 0 # Always use the `/m' modifier with regular expressions. [-RegularExpressions::RequireLineBoundaryMatching] # set_themes = core cosmetic pbp # add_themes = # severity = 2 # maximum_violations_per_document = no_limit # Don't call functions with a leading ampersand sigil. [Subroutines::ProhibitAmpersandSigils] # set_themes = core maintenance pbp # add_themes = # severity = 2 # maximum_violations_per_document = no_limit # Don't declare your own `open' function. [Subroutines::ProhibitBuiltinHomonyms] # set_themes = bugs core pbp # add_themes = # severity = 4 # maximum_violations_per_document = no_limit # Minimize complexity by factoring code into smaller subroutines. [Subroutines::ProhibitExcessComplexity] # set_themes = complexity core maintenance # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # The maximum complexity score allowed. # Minimum value 1. No maximum. # max_mccabe = 20 # Return failure with bare `return' instead of `return undef'. [Subroutines::ProhibitExplicitReturnUndef] # set_themes = bugs core pbp # add_themes = # severity = 5 # maximum_violations_per_document = no_limit # Too many arguments. [Subroutines::ProhibitManyArgs] # set_themes = core maintenance pbp # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # The maximum number of arguments to allow a subroutine to have. # Minimum value 1. No maximum. # max_arguments = 5 # `sub never { sub correct {} }'. [Subroutines::ProhibitNestedSubs] # set_themes = bugs core # add_themes = # severity = 5 # maximum_violations_per_document = no_limit # Behavior of `sort' is not defined if called in scalar context. [Subroutines::ProhibitReturnSort] # set_themes = bugs core # add_themes = # severity = 5 # maximum_violations_per_document = no_limit # Don't write `sub my_function (@@) {}'. [Subroutines::ProhibitSubroutinePrototypes] # set_themes = bugs core pbp # add_themes = # severity = 5 # maximum_violations_per_document = no_limit # Prevent unused private subroutines. [Subroutines::ProhibitUnusedPrivateSubroutines] # set_themes = core maintenance # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # Pattern that determines what a private subroutine is. # private_name_regex = \b_\w+\b # Subroutines matching the private name regex to allow under this policy. # allow = # Prevent access to private subs in other packages. [Subroutines::ProtectPrivateSubs] # set_themes = core maintenance # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # Pattern that determines what a private subroutine is. # private_name_regex = \b_\w+\b # Subroutines matching the private name regex to allow under this policy. # Values that are always included: POSIX::_PC_CHOWN_RESTRICTED, POSIX::_PC_LINK_MAX, POSIX::_PC_MAX_CANON, POSIX::_PC_MAX_INPUT, POSIX::_PC_NAME_MAX, POSIX::_PC_NO_TRUNC, POSIX::_PC_PATH_MAX, POSIX::_PC_PIPE_BUF, POSIX::_PC_VDISABLE, POSIX::_POSIX_ARG_MAX, POSIX::_POSIX_CHILD_MAX, POSIX::_POSIX_CHOWN_RESTRICTED, POSIX::_POSIX_JOB_CONTROL, POSIX::_POSIX_LINK_MAX, POSIX::_POSIX_MAX_CANON, POSIX::_POSIX_MAX_INPUT, POSIX::_POSIX_NAME_MAX, POSIX::_POSIX_NGROUPS_MAX, POSIX::_POSIX_NO_TRUNC, POSIX::_POSIX_OPEN_MAX, POSIX::_POSIX_PATH_MAX, POSIX::_POSIX_PIPE_BUF, POSIX::_POSIX_SAVED_IDS, POSIX::_POSIX_SSIZE_MAX, POSIX::_POSIX_STREAM_MAX, POSIX::_POSIX_TZNAME_MAX, POSIX::_POSIX_VDISABLE, POSIX::_POSIX_VERSION, POSIX::_SC_ARG_MAX, POSIX::_SC_CHILD_MAX, POSIX::_SC_CLK_TCK, POSIX::_SC_JOB_CONTROL, POSIX::_SC_NGROUPS_MAX, POSIX::_SC_OPEN_MAX, POSIX::_SC_PAGESIZE, POSIX::_SC_SAVED_IDS, POSIX::_SC_STREAM_MAX, POSIX::_SC_TZNAME_MAX, POSIX::_SC_VERSION, POSIX::_exit. # allow = # Always unpack `@_' first. [Subroutines::RequireArgUnpacking] # set_themes = core maintenance pbp # add_themes = # severity = 4 # maximum_violations_per_document = no_limit # The number of statements to allow without unpacking. # Minimum value 0. No maximum. # short_subroutine_statements = 0 # Should unpacking from array slices and elements be allowed?. # allow_subscripts = 0 # Allow the usual delegation idiom to these namespaces/subroutines. # Values that are always included: NEXT::, SUPER::. # allow_delegation_to = # End every path through a subroutine with an explicit `return' statement. [Subroutines::RequireFinalReturn] # set_themes = bugs core pbp # add_themes = # severity = 4 # maximum_violations_per_document = no_limit # The additional subroutines to treat as terminal. # Values that are always included: Carp::confess, Carp::croak, confess, croak, die, exec, exit, throw. # terminal_funcs = # Prohibit various flavors of `no strict'. [TestingAndDebugging::ProhibitNoStrict] # set_themes = bugs core pbp # add_themes = # severity = 5 # maximum_violations_per_document = no_limit # Allow vars, subs, and/or refs. # allow = # Prohibit various flavors of `no warnings'. [TestingAndDebugging::ProhibitNoWarnings] # set_themes = bugs core pbp # add_themes = # severity = 4 # maximum_violations_per_document = no_limit # Permitted warning categories. # allow = # Allow "no warnings" if it restricts the kinds of warnings that are turned off. # allow_with_category_restriction = 0 # Don't turn off strict for large blocks of code. [TestingAndDebugging::ProhibitProlongedStrictureOverride] # set_themes = bugs core pbp # add_themes = # severity = 4 # maximum_violations_per_document = no_limit # The maximum number of statements in a no strict block. # Minimum value 1. No maximum. # statements = 3 # Tests should all have labels. [TestingAndDebugging::RequireTestLabels] # set_themes = core maintenance tests # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # The additional modules to require labels for. # Values that are always included: Test::More. # modules = # Always `use strict'. [TestingAndDebugging::RequireUseStrict] # set_themes = bugs core pbp # add_themes = # severity = 5 # maximum_violations_per_document = 1 # The additional modules to treat as equivalent to "strict". # Values that are always included: Moose, Moose::Role, Moose::Util::TypeConstraints, strict. # equivalent_modules = # Always `use warnings'. [TestingAndDebugging::RequireUseWarnings] # set_themes = bugs core pbp # add_themes = # severity = 4 # maximum_violations_per_document = 1 # The additional modules to treat as equivalent to "warnings". # Values that are always included: Moose, Moose::Role, Moose::Util::TypeConstraints, warnings. # equivalent_modules = # Don't use the comma operator as a statement separator. [ValuesAndExpressions::ProhibitCommaSeparatedStatements] # set_themes = bugs core pbp # add_themes = # severity = 4 # maximum_violations_per_document = no_limit # Allow map and grep blocks to return lists. # allow_last_statement_to_be_comma_separated_in_map_and_grep = 0 # Prohibit version values from outside the module. [ValuesAndExpressions::ProhibitComplexVersion] # set_themes = core maintenance # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # Make "use version; our $VERSION = qv('1.2.3');" a violation of this policy. # forbid_use_version = 0 # Don't `use constant FOO => 15'. [ValuesAndExpressions::ProhibitConstantPragma] # set_themes = bugs core pbp # add_themes = # severity = 4 # maximum_violations_per_document = no_limit # Write `q{}' instead of `'''. [ValuesAndExpressions::ProhibitEmptyQuotes] # set_themes = core cosmetic pbp # add_themes = # severity = 2 # maximum_violations_per_document = no_limit # Write `"\N{DELETE}"' instead of `"\x7F"', etc. [ValuesAndExpressions::ProhibitEscapedCharacters] # set_themes = core cosmetic pbp # add_themes = # severity = 2 # maximum_violations_per_document = no_limit # Use concatenation or HEREDOCs instead of literal line breaks in strings. [-ValuesAndExpressions::ProhibitImplicitNewlines] # set_themes = core cosmetic pbp # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # Always use single quotes for literal strings. [ValuesAndExpressions::ProhibitInterpolationOfLiterals] # set_themes = core cosmetic pbp # add_themes = # severity = 1 # maximum_violations_per_document = no_limit # Kinds of delimiters to permit, e.g. "qq{", "qq(", "qq[", "qq/". # allow = # If the string contains ' characters, allow "" to quote it. # allow_if_string_contains_single_quote = 0 # Write `oct(755)' instead of `0755'. [ValuesAndExpressions::ProhibitLeadingZeros] # set_themes = bugs core pbp # add_themes = # severity = 5 # maximum_violations_per_document = no_limit # Don't allow any leading zeros at all. Otherwise builtins that deal with Unix permissions, e.g. chmod, don't get flagged. # strict = 0 # Long chains of method calls indicate tightly coupled code. [ValuesAndExpressions::ProhibitLongChainsOfMethodCalls] # set_themes = core maintenance # add_themes = # severity = 2 # maximum_violations_per_document = no_limit # The number of chained calls to allow. # Minimum value 1. No maximum. # max_chain_length = 3 # Don't use values that don't explain themselves. [-ValuesAndExpressions::ProhibitMagicNumbers] # set_themes = core maintenance # add_themes = # severity = 2 # maximum_violations_per_document = 10 # Individual and ranges of values to allow, and/or "all_integers". # allowed_values = 0 1 2 # Kind of literals to allow. # Valid values: Binary, Exp, Float, Hex, Octal. # allowed_types = Float # Should anything to the right of a "=>" be allowed?. # allow_to_the_right_of_a_fat_comma = 1 # Names of subroutines that create constants. # Values that are always included: Readonly, Readonly::Array, Readonly::Hash, Readonly::Scalar, const. # constant_creator_subroutines = # Don't mix numeric operators with string operands, or vice-versa. [ValuesAndExpressions::ProhibitMismatchedOperators] # set_themes = bugs core # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # Write ` !$foo && $bar || $baz ' instead of ` not $foo && $bar or $baz'. [ValuesAndExpressions::ProhibitMixedBooleanOperators] # set_themes = bugs core pbp # add_themes = # severity = 4 # maximum_violations_per_document = no_limit # Use `q{}' or `qq{}' instead of quotes for awkward-looking strings. [ValuesAndExpressions::ProhibitNoisyQuotes] # set_themes = core cosmetic pbp # add_themes = # severity = 2 # maximum_violations_per_document = no_limit # Don't use quotes (`'', `"', ``') as delimiters for the quote-like operators. [ValuesAndExpressions::ProhibitQuotesAsQuotelikeOperatorDelimiters] # set_themes = core maintenance # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # The operators to allow single-quotes as delimiters for. # Valid values: m, q, qq, qr, qw, qx, s, tr, y. # single_quote_allowed_operators = m s qr qx # The operators to allow double-quotes as delimiters for. # Valid values: m, q, qq, qr, qw, qx, s, tr, y. # double_quote_allowed_operators = # The operators to allow back-quotes (back-ticks) as delimiters for. # Valid values: m, q, qq, qr, qw, qx, s, tr, y. # back_quote_allowed_operators = # Don't write ` print <<'__END__' '. [ValuesAndExpressions::ProhibitSpecialLiteralHeredocTerminator] # set_themes = core maintenance # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # Don't use strings like `v1.4' or `1.4.5' when including other modules. [ValuesAndExpressions::ProhibitVersionStrings] # set_themes = core maintenance pbp # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # Require $VERSION to be a constant rather than a computed value. [-ValuesAndExpressions::RequireConstantVersion] # set_themes = core maintenance # add_themes = # severity = 2 # maximum_violations_per_document = no_limit # Allow qv() and version->new() without a 'use version' on the same line. # allow_version_without_use_on_same_line = 0 # Warns that you might have used single quotes when you really wanted double-quotes. [ValuesAndExpressions::RequireInterpolationOfMetachars] # set_themes = core cosmetic pbp # add_themes = # severity = 1 # maximum_violations_per_document = no_limit # RCS keywords to ignore in potential interpolation. # rcs_keywords = # Write ` 141_234_397.0145 ' instead of ` 141234397.0145 '. [ValuesAndExpressions::RequireNumberSeparators] # set_themes = core cosmetic pbp # add_themes = # severity = 2 # maximum_violations_per_document = no_limit # The minimum absolute value to require separators in. # Minimum value 10. No maximum. # min_value = 10_000 # Write ` print <<'THE_END' ' or ` print <<"THE_END" '. [ValuesAndExpressions::RequireQuotedHeredocTerminator] # set_themes = core maintenance pbp # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # Write ` <<'THE_END'; ' instead of ` <<'theEnd'; '. [ValuesAndExpressions::RequireUpperCaseHeredocTerminator] # set_themes = core cosmetic pbp # add_themes = # severity = 2 # maximum_violations_per_document = no_limit # Do not write ` my $foo .= 'bar'; '. [Variables::ProhibitAugmentedAssignmentInDeclaration] # set_themes = bugs core # add_themes = # severity = 4 # maximum_violations_per_document = no_limit # Do not write ` my $foo = $bar if $baz; '. [Variables::ProhibitConditionalDeclarations] # set_themes = bugs core # add_themes = # severity = 5 # maximum_violations_per_document = no_limit # Use `my' instead of `local', except when you have to. [Variables::ProhibitLocalVars] # set_themes = core maintenance pbp # add_themes = # severity = 2 # maximum_violations_per_document = no_limit # Avoid `$`', `$&', `$'' and their English equivalents. [Variables::ProhibitMatchVars] # set_themes = core pbp performance # add_themes = # severity = 4 # maximum_violations_per_document = no_limit # Eliminate globals declared with `our' or `use vars'. [Variables::ProhibitPackageVars] # set_themes = core maintenance pbp # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # The base set of packages to allow variables for. # packages = Data::Dumper File::Find FindBin Log::Log4perl # The set of packages to allow variables for, in addition to those given in "packages". # add_packages = # Use double colon (::) to separate package name components instead of single quotes ('). [Variables::ProhibitPerl4PackageNames] # set_themes = core maintenance # add_themes = # severity = 2 # maximum_violations_per_document = no_limit # Write `$EVAL_ERROR' instead of `$@'. [-Variables::ProhibitPunctuationVars] # set_themes = core cosmetic pbp # add_themes = # severity = 2 # maximum_violations_per_document = no_limit # The additional variables to allow. # Values that are always included: $1, $2, $3, $4, $5, $6, $7, $8, $9, $], $_, @_, _. # allow = # Controls checking interpolated strings for punctuation variables. # Valid values: disable, simple, thorough. # string_mode = thorough # Do not reuse a variable name in a lexical scope [Variables::ProhibitReusedNames] # set_themes = bugs core # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # The variables to not consider as duplicates. # allow = $self $class # Don't ask for storage you don't need. [Variables::ProhibitUnusedVariables] # set_themes = core maintenance # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # Prevent access to private vars in other packages. [Variables::ProtectPrivateVars] # set_themes = core maintenance # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # Write `local $foo = $bar;' instead of just `local $foo;'. [Variables::RequireInitializationForLocalVars] # set_themes = bugs core pbp # add_themes = # severity = 3 # maximum_violations_per_document = no_limit # Write `for my $element (@list) {...}' instead of `for $element (@list) {...}'. [Variables::RequireLexicalLoopIterators] # set_themes = bugs core pbp # add_themes = # severity = 5 # maximum_violations_per_document = no_limit # Magic variables should be assigned as "local". [Variables::RequireLocalizedPunctuationVars] # set_themes = bugs core pbp # add_themes = # severity = 4 # maximum_violations_per_document = no_limit # Global variables to exclude from this policy. # Values that are always included: $ARG, $_, @_. # allow = # Negative array index should be used. [Variables::RequireNegativeIndices] # set_themes = core maintenance pbp # add_themes = # severity = 4 # maximum_violations_per_document = no_limit RPC-XML-0.82/README0000644000175000017500000000436213775375451012473 0ustar rjrayrjrayRPC::XML - An implementation of XML-RPC Version: 0.82 WHAT IS IT The RPC::XML package is an implementation of XML-RPC. The module provides classes for sample client and server implementations, a server designed as an Apache location-handler, and a suite of data-manipulation classes that are used by them. USING RPC::XML There are not any pre-packaged executables in this distribution (except for a utility tool). Client usage will usually be along the lines of: use RPC::XML::Client; ... my $client = RPC::XML::Client->new( 'http://www.oreillynet.com/meerkat/xml-rpc/server.php' ); my $req = RPC::XML::request->new('meerkat.getChannelsBySubstring', 'perl'); my $res = $client->send_request($req); # This returns an object of the RPC::XML::response class. This double-call # of value() first gets a RPC::XML::* data object from the response, then # the actual data from it: my $value = $res->value->value; Running a simple server is not much more involved: use RPC::XML::Server; ... my $srv = RPC::XML::Server->new( host => 'localhost', port => 9000 ); # You would then use $srv->add_method to add some remotely-callable code ... $srv->accept_loop; # Stays in an accept/connect loop BUILDING/INSTALLING This package is set up to configure and build like a typical Perl extension. To build: perl Makefile.PL make && make test If RPC::XML passes all tests, then: make install You may need super-user access to install. PROBLEMS/BUG REPORTS Please send any reports of problems or bugs to rjray@blackperl.com or use the GitHub Issues page for this project: https://github.com/rjray/rpc-xml/issues SEE ALSO XML-RPC: http://www.xmlrpc.com/spec The Artistic 2.0: http://www.opensource.org/licenses/artistic-license-2.0.php The LGPL 2.1: http://www.opensource.org/licenses/lgpl-2.1.php CHANGES * Makefile.PL * lib/RPC/XML/Server.pm Bump version numbers. * Makefile.PL * lib/RPC/XML/Server.pm * t/40_server.t * t/40_server_xmllibxml.t * t/41_server_hang.t * t/60_net_server.t * t/util.pl RT #120472: Applied patch from Petr Písař for fixes to IPv6 support. Full detail in the message for this commit in the git repository. RPC-XML-0.82/META.yml0000664000175000017500000000175113775375652013070 0ustar rjrayrjray--- abstract: 'Data, client and server classes for XML-RPC' author: - 'Randy J. Ray' build_requires: ExtUtils::MakeMaker: '7.56' IO::Socket::IP: '0' Test::More: '1.302183' configure_requires: ExtUtils::MakeMaker: '7.56' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.56, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: RPC-XML no_index: directory: - t - inc recommends: DateTime: '1.54' DateTime::Format::ISO8601: '0.15' XML::LibXML: '2.0206' requires: Carp: '0' HTTP::Daemon: '6.12' HTTP::Message: '6.26' LWP: '6.51' Module::Load: '0.36' Scalar::Util: '1.55' Socket: '0' XML::Parser: '2.46' perl: '5.008008' resources: bugtracker: https://github.com/rjray/rpc-xml/issues homepage: http://github.com/rjray/rpc-xml repository: http://github.com/rjray/rpc-xml version: '0.82' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' RPC-XML-0.82/META.json0000664000175000017500000000336413775375652013242 0ustar rjrayrjray{ "abstract" : "Data, client and server classes for XML-RPC", "author" : [ "Randy J. Ray" ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.56, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "RPC-XML", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "7.56" } }, "runtime" : { "recommends" : { "DateTime" : "1.54", "DateTime::Format::ISO8601" : "0.15", "XML::LibXML" : "2.0206" }, "requires" : { "Carp" : "0", "HTTP::Daemon" : "6.12", "HTTP::Message" : "6.26", "LWP" : "6.51", "Module::Load" : "0.36", "Scalar::Util" : "1.55", "Socket" : "0", "XML::Parser" : "2.46", "perl" : "5.008008" } }, "test" : { "requires" : { "ExtUtils::MakeMaker" : "7.56", "IO::Socket::IP" : "0", "Test::More" : "1.302183" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/rjray/rpc-xml/issues" }, "homepage" : "http://github.com/rjray/rpc-xml", "repository" : { "url" : "http://github.com/rjray/rpc-xml" } }, "version" : "0.82", "x_serialization_backend" : "JSON::PP version 4.05" } RPC-XML-0.82/lib/0000755000175000017500000000000013775375652012357 5ustar rjrayrjrayRPC-XML-0.82/lib/Apache/0000755000175000017500000000000013775375652013540 5ustar rjrayrjrayRPC-XML-0.82/lib/Apache/RPC/0000755000175000017500000000000013775375652014164 5ustar rjrayrjrayRPC-XML-0.82/lib/Apache/RPC/Server.pm0000644000175000017500000010355611622775142015765 0ustar rjrayrjray############################################################################### # # This file copyright (c) 2001-2011 Randy J. Ray, all rights reserved # # Copying and distribution are permitted under the terms of the Artistic # License 2.0 (http://www.opensource.org/licenses/artistic-license-2.0.php) or # the GNU LGPL (http://www.opensource.org/licenses/lgpl-2.1.php). # ############################################################################### # # Description: This package implements a RPC server as an Apache/mod_perl # content handler. It uses the RPC::XML::Server package to # handle request decoding and response encoding. # # Functions: handler # init_handler # new # get_server # version # INSTALL_DIR # list_servers # # Libraries: RPC::XML::Server # # Global Consts: $VERSION # ############################################################################### package Apache::RPC::Server; use 5.008008; use strict; use warnings; use base qw(RPC::XML::Server); use Socket; use File::Spec; use Apache; use Apache::File; # For ease-of-use methods like set_last_modified use Apache::Constants ':common'; use RPC::XML; ## no critic (ProhibitSubroutinePrototypes) BEGIN { $Apache::RPC::Server::INSTALL_DIR = (File::Spec->splitpath(__FILE__))[1]; %Apache::RPC::Server::SERVER_TABLE = (); } our $VERSION = '1.40'; $VERSION = eval $VERSION; ## no critic (ProhibitStringyEval) sub version { return $Apache::RPC::Server::VERSION } sub INSTALL_DIR { return $Apache::RPC::Server::INSTALL_DIR } # Return a list (not list reference) of currently-known server objects, # represented as the text-keys from the hash table. sub list_servers { return keys %Apache::RPC::Server::SERVER_TABLE } # This is kinda funny, since I don't actually have a debug() method in the # RPC::XML::Server class at the moment... sub debug { my ($self, $fmt, @args) = @_; my $debug = ref($self) ? $self->SUPER::debug() : 1; if ($fmt && $debug) { Apache::log_error( sprintf "%p ($$): $fmt", (ref $self) ? $self : 0, @args ); } return $debug; } ############################################################################### # # Sub Name: handler # # Description: This is the default routine that Apache will look for # when we set this class up as a content handler. # # Arguments: NAME IN/OUT TYPE DESCRIPTION # $class in scalar Static name of the class we're # invoked in # $r in ref Blessed Apache::Request object # # Globals: $DEF_OBJ # # Returns: Response code # ############################################################################### sub handler ($$) ## no critic (ProhibitExcessComplexity) { my $class = shift; my $r = shift; my ($srv, $content, $resp, $hdrs, $hdrs_out, $compress, $length, $do_compress, $com_engine, $parser, $me, $resp_fh, $c, $peeraddr, $peerhost, $peerport); $srv = (ref $class) ? $class : $class->get_server($r); $me = (ref($class) || $class) . '::handler'; if (! ref $srv) { $r->log_error("$me: PANIC! " . $srv); return SERVER_ERROR; } # Set the relevant headers $hdrs_out = $r->headers_out; $hdrs = $srv->response->headers; for (keys %{$hdrs}) { $hdrs_out->{$_} = $hdrs->{$_} } $r->content_type('text/xml'); # We're essentially done if this was a HEAD request if ($r->header_only) { # These headers are either only sent for HEAD requests or are different # enough to move here from the above block $r->set_last_modified($srv->started); $r->send_http_header; } elsif ($r->method eq 'POST') { # Step 1: Do we have the correct content-type? if ($r->header_in('Content-Type') !~ m{text/xml}i) { return DECLINED; } $compress = $srv->compress; if ($compress and ($r->header_in('Content-Encoding') || q{}) =~ $srv->compress_re) { $do_compress = 1; } # Step 2: Read the request in and convert it to a request object # Note that this currently binds us to the Content-Length header a lot # more tightly than I like. Expect to see this change sometime soon. $length = $r->header_in('Content-Length'); $parser = $srv->parser->parse(); # Get the ExpatNB object if ($do_compress) { # Spin up the compression engine if (! ($com_engine = Compress::Zlib::inflateInit())) { $r->log_error("$me: Unable to init the Compress::Zlib engine"); return SERVER_ERROR; } } while ($length) { $r->read($content, ($length < 2048) ? $length : 2048); # If $content is undef, then the client has closed the connection # on its end, and we're done (like it or not). if (! defined $content) { $r->log_error("$me: Error reading request content"); return SERVER_ERROR; } $length -= length $content; if ($do_compress) { if (! ($content = $com_engine->inflate($content))) { $r->log_error("$me: Error inflating compressed data"); return SERVER_ERROR; } } if (! eval { $parser->parse_more($content); 1; }) { if ($@) { $r->log_error("$me: XML parse error: $@"); return SERVER_ERROR; } } } if (! eval { $content = $parser->parse_done; 1; }) { if ($@) { $r->log_error("$me: XML parse error at end: $@"); return SERVER_ERROR; } } # Step 3: Process the request and encode the outgoing response # Dispatch will always return a RPC::XML::response object { # We set some short-lifespan localized keys on $srv to let the # methods have access to client connection info $c = $r->connection; ($peerport, $peeraddr) = unpack_sockaddr_in($c->remote_addr); $peerhost = inet_ntoa($peeraddr); # Set localized keys on $srv, based on the connection info ## no critic (ProhibitLocalVars) local $srv->{peeraddr} = $peeraddr; local $srv->{peerhost} = $peerhost; local $srv->{peerport} = $peerport; $resp = $srv->dispatch($content); } # Step 4: Form up and send the headers and body of the response $r->no_cache(1); $do_compress = 0; # Clear it if ($compress and ($resp->length > $srv->compress_thresh) and (($r->header_in('Accept-Encoding') || q{}) =~ $srv->compress_re)) { $do_compress = 1; $hdrs_out->{'Content-Encoding'} = $compress; } # Determine if we need to spool this to a file due to size if ($srv->message_file_thresh and $srv->message_file_thresh < $resp->length) { if (! ($resp_fh = Apache::File->tmpfile)) { $r->log_error("$me: Error opening tmpfile"); return SERVER_ERROR; } # Now that we have it, spool the response to it. This is a # little hairy, since we still have to allow for compression. # And though the response could theoretically be HUGE, in # order to compress we have to write it to a second temp-file # first, so that we can compress it into the primary handle. if ($do_compress) { my $fh_compress = Apache::File->tmpfile; if (! $fh_compress) { $r->log_error("$me: Error opening second tmpfile"); return SERVER_ERROR; } # Write the request to the second FH $resp->serialize($fh_compress); seek $fh_compress, 0, 0; # Spin up the compression engine if (! ($com_engine = Compress::Zlib::deflateInit())) { $r->log_error("$me: Unable to initialize the " . 'Compress::Zlib engine'); return SERVER_ERROR; } # Spool from the second FH through the compression engine, # into the intended FH. my $buf = q{}; my $out; while (read $fh_compress, $buf, 4096) { if (! (defined($out = $com_engine->deflate(\$buf)))) { $r->log_error("$me: Compression failure in deflate()"); return SERVER_ERROR; } print {$resp_fh} $out; } # Make sure we have all that's left if (! defined($out = $com_engine->flush)) { $r->log_error("$me: Compression flush failure in deflate"); return SERVER_ERROR; } print {$resp_fh} $out; # Close the secondary FH. Rewinding the primary is done # later. close $fh_compress; ## no critic (RequireCheckedClose) } else { $resp->serialize($resp_fh); } seek $resp_fh, 0, 0; $r->set_content_length(-s $resp_fh); $r->send_http_header; $r->send_fd($resp_fh); } else { # Treat the content strictly in-memory $content = $resp->as_string; if ($do_compress) { $content = Compress::Zlib::compress($content); } $r->set_content_length(length $content); $r->send_http_header; $r->print($content); } } else { # Flag this as an error, since we don't permit the other methods return DECLINED; } return OK; } ############################################################################### # # Sub Name: init_handler # # Description: Provide a handler for the PerlChildInitHandler phase that # walks through the table of server objects and updates the # child_started time on each. # # Arguments: NAME IN/OUT TYPE DESCRIPTION # $class in scalar Calling class (this is a method # handler) # $r in ref Apache reference object # # Globals: %SERVER_TABLE # # Returns: 1 # ############################################################################### sub init_handler ($$) { my ($class, $r) = @_; for (values %Apache::RPC::Server::SERVER_TABLE) { $_->child_started(1); } return OK; } ############################################################################### # # Sub Name: new # # Description: Create a new server object, which is blessed into this # class and thus inherits most of the important bits from # RPC::XML::Server. # # Arguments: NAME IN/OUT TYPE DESCRIPTION # $class in scalar String or ref to ID the class # %argz in list Type and relevance of args is # variable. See text. # # Globals: $INSTALL_DIR # # Returns: Success: ref to new object # Failure: error string # ############################################################################### sub new ## no critic (ProhibitExcessComplexity) { my ($class, %argz) = @_; my ($R, $servid, $prefix, $self, @dirs, @files, $ret, $no_def, $do_auto, $do_mtime); $R = delete $argz{apache} || Apache->server; $servid = delete $argz{server_id}; $prefix = delete $argz{prefix} || q{}; if (! $argz{path}) { $argz{path} = $R->location; } if (! $servid) { $servid = substr $argz{path}, 1; } # For these Apache-conf type of settings, something explicitly passed in # via %argz is allowed to override the config file. So after pulling the # value, it is only applied if the corresponding key doesn't already exist if (! exists $argz{debug}) { # Is debugging requested? $argz{debug} = $R->dir_config("${prefix}RpcDebugLevel") || 0; } # Check for disabling of auto-loading or mtime-checking $do_auto = $R->dir_config("${prefix}RpcAutoMethods") || 0; $do_mtime = $R->dir_config("${prefix}RpcAutoUpdates") || 0; foreach ($do_auto, $do_mtime) { $_ = /yes/i ? 1 : 0 } if (! exists $argz{auto_methods}) { $argz{auto_methods} = $do_auto; } if (! exists $argz{auto_updates}) { $argz{auto_updates} = $do_mtime; } # If there is already an xpl_path, ensure that ours is on the top, # otherwise add it. if ($argz{xpl_path}) { push @{$argz{xpl_path}}, $Apache::RPC::Server::INSTALL_DIR; } else { $argz{xpl_path} = [ $Apache::RPC::Server::INSTALL_DIR ]; } # Create the object, ensuring that the defaults are not yet loaded: my $raux = (ref($R) eq 'Apache') ? $R->server : $R; $self = $class->SUPER::new(no_default => 1, no_http => 1, path => $argz{path}, host => $raux->server_hostname || 'localhost', port => $raux->port, %argz); # Non-ref means an error message if (! ref $self) { return $self; } $self->started('set'); # Check to see if we should suppress the default methods. # The default is "no" (don't suppress the default methods), so use || in # the evaluation in case neither were set. $no_def = $argz{no_default} ? 1 : (($R->dir_config("${prefix}RpcDefMethods") || q{}) =~ /no/i) ? 1 : 0; if (! $no_def) { $self->add_default_methods(-except => 'status.xpl'); # This should find the Apache version of system.status instead $self->add_method('status.xpl'); } # Determine what methods we are configuring for this server instance @dirs = split /:/, ($R->dir_config("${prefix}RpcMethodDir") || q{}); @files = split /:/, ($R->dir_config("${prefix}RpcMethod") || q{}); # Load the directories first, then the individual files. This allows the # files to potentially override entries in the directories. for (@dirs) { $ret = $self->add_methods_in_dir($_); if (! ref $ret) { return $ret; } } for (@files) { $ret = $self->add_method($_); if (! ref $ret) { return $ret; } } if (@dirs) { # If there were any dirs specified for wholesale inclusion, add them # to the search path for later reference. $ret = $self->xpl_path; unshift @{$ret}, @dirs; $self->xpl_path($ret); } return $Apache::RPC::Server::SERVER_TABLE{$servid} = $self; } # Accessor similar to started() that has a time localized to this child process sub child_started { my ($self, $set_started) = @_; my $old = $self->{__child_started} || $self->started || 0; if ($set_started) { $self->{__child_started} = time; } return $old; } ############################################################################### # # Sub Name: get_server # # Description: Retrieve the server object appropriate for this Server # instance passed in right after $self. If the second arg is # not a reference, assume they are asking for an existing # server by name. # # Arguments: NAME IN/OUT TYPE DESCRIPTION # $self in sc/ref Object ref or class name # $r in ref Apache interface object ref # # Globals: %SERVER_TABLE # # Returns: object ref, either specific or the default object. Sends a # text string if new() fails # ############################################################################### sub get_server { my ($self, $r) = @_; my ($prefix, $servid, $nocomp); if (ref $r) { # Presume $r to in fact be an Apache reference, and use it as such. # If the server that matches this is already in the table, return it. # If it isn't, create it from the information we have available. $prefix = $r->dir_config('RPCOptPrefix') || q{}; $servid = $r->dir_config("${prefix}RpcServer") || ''; $nocomp = $r->dir_config('NoCompression') || q{}; return $Apache::RPC::Server::SERVER_TABLE{$servid} || $self->new(apache => $r, server_id => $servid, prefix => $prefix, no_compress => $nocomp, path => $r->location); } else { # If $r isn't a reference, then this is likely been called as a class # method to get the server object for a specific name. Thus, if it # doesn't exist yet, we lack sufficient information to create it on # the fly. return $Apache::RPC::Server::SERVER_TABLE{$r} || "Error: No such server object '$r' known (yet)"; } } 1; __END__ =pod =head1 NAME Apache::RPC::Server - A subclass of RPC::XML::Server tuned for mod_perl =head1 SYNOPSIS # In httpd.conf: PerlModule Apache::RPC::Server PerlSetVar RpcMethodDir /var/www/rpc:/usr/lib/perl5/RPC-shared PerlChildInitHandler Apache::RPC::Server->init_handler ... SetHandler perl-script PerlHandler Apache::RPC::Server SetHandler perl-script PerlHandler Apache::RPC::Server PerlSetVar RPCOptPrefix RpcLimit PerlSetVar RpcLimitRpcServer Limited PerlSetVar RpcLimitRpcMethodDir /usr/lib/perl5/RPC-shared # In the start-up Perl file: use Apache::RPC::Server; =head1 DESCRIPTION The B module is a subclassing of B that is tuned and designed for use within Apache with mod_perl. Provided are phase-handlers for the general request-processing phase (C) and the child-process initialization phase (C). The module should be loaded either by inclusion in a server start-up Perl script or by directives in the server configuration file (generally F). One loaded, the configuration file may assign the module to handle one or more given locations with the general set of CLocationE> directives and familiar options. Additional configuration settings specific to this module are detailed below. Generally, externally-available methods are provided as files in the XML dialect explained in L. A subclass derived from this class may of course use the methods provided by this class and its parent class for adding and manipulating the method table. =head1 SUBROUTINES/METHODS The methods that the server publishes are provided by a combination of the installation files and Apache configuration values. Details on remote method syntax and semantics is covered in L. =head2 Methods In addition to inheriting all the methods from B, the following methods are either added or overloaded by B: =over 4 =item handler This is the default content-handler routine that B expects when the module is defined as managing the specified location. This is provided as a I, meaning that the first argument is either an object reference or a static string with the class name. This allows for other packages to easily subclass B. This routine takes care of examining the incoming request, choosing an appropriate server object to actually process the request, and returning the results of the remote method call to the client. =item init_handler This is another Apache-level handler, this one designed for installation as a C. At present, its only function is to iterate over all server object currently in the internal tables and invoke the C method (detailed below) on each. Setting this handler assures that each child has a correct impression of when it started as opposed to the start time of the server itself. Note that this is only applied to those servers known to the master Apache process. In most cases, this will only be the default server object as described above. That is because of the delayed-loading nature of all servers beyond the default, which are likely only in child-specific memory. There are some configuration options described in the next section that can affect and alter this. =item new(HASH) This is the class constructor. It calls the superclass C method, then performs some additional steps. These include installing the default methods (which includes an Apache-specific version of C), adding the installation directory of this module to the method search path, and adding any directories or explicitly-requested methods to the server object. The arguments to the constructor are regarded as a hash table (not a hash reference), and are mostly passed unchanged to the constructor for B. Three parameters are of concern to this class: =over 8 =item apache The value associated with this key is a reference to an B request object. If this is not passed, then it is assumed that this is being called in the start-up phase of the server and the value returned from C<< Apache->server >> (see L) is used. =item server_id This provides the server ID string for the RPC server (not to be confused with the Apache server) that is being configured. =item prefix The prefix is used in retrieving certain configuration settings from the Apache configuration file. =back The server identification string and prefix concepts are explained in more detail in the next section. See L for a full list of what additional arguments may be passed to B for eventual proxy to the parent class constructor. =item child_started([BOOLEAN]) This method is very similar to the C method provided by B. When called with no argument or an argument that evaluates to a false value, it returns the UNIX-style time value of when this child process was started. Due to the child-management model of Apache, this may very well be different from the value returned by C itself. If given an argument that evaluates as true, the current system time is set as the new child-start time. If the server has not been configured to set this at child initialization, then the main C value is returned. The name is different so that a child may specify both server-start and child-start times with clear distinction. =item get_server(APACHEREQ|STRING) Get the server object that corresponds to the argument passed. If the argument is a reference to an B request object, use it to determine the name (by path, etc.) and return that object. If the parameter is not a reference, it is assumed to be the specific name desired. If the requested server object does not yet exist, an attempt will be made to create it and add it to the internal table. The newly-created object is then returned. =item list_servers Return a list of the I used for all the current server instances. Does not return the server objects themselves (use B, above, for that). =item version This method behaves exactly like the B method, except that the version string returned is specific to this module instead. =item INSTALL_DIR As with B, this is an overload of the parent-class static method that returns the installation directory of this particular module. =back =head2 Apache configuration semantics In addition to the known directives such as C and C, configuration of this system is controlled through a variety of settings that are manipulated with the C and C directives. These variables are: =over 4 =item RPCOptPrefix [STRING] Sets a prefix string to be applied to all of the following names before trying to read their values. Useful for setting within a CLocationE> block to ensure that no settings from a higher point in the hierarchy influence the server being defined. =item RpcServer [STRING] Specify the name of the server to use for this location. If not passed, then the default server is used. This server may also be explicitly requested by the name "CdefaultE>>". If more than one server is going to be created within the same Apache environment, this setting should always be used outside the default area so that the default server is not loaded down with extra method definitions. If a sub-location changes the default server, those changes will be felt by any location that uses that server. Different locations may share the same server by specifying the name with this variable. This is useful for managing varied access schemes, traffic analysis, etc. =item RpcMethodDir [DIRECTORY] This variable specifies directories to be scanned for method C<*.xpl> files. To specify more than one directory, separate them with "C<:>" just as with any other directory-path expression. All directories are kept (in the order specified) as the search path for future loading of methods. =item RpcMethod [FILENAME] This is akin to the directory-specification option above, but only provides a single method at a time. It may also have multiple values separated by colons. The method is loaded into the server table. If the name is not an absolute pathname, then it is searched for in the directories that currently comprise the path. The directories above, however, have not been added to the search path yet. This is because these directives are processed immediately after the directory specifications, and thus do not need to be searched. This directive is designed to allow selective overriding of methods in the previously-specified directories. =item RpcDefMethods [YES|NO] If specified and set to "no" (case-insensitive), suppresses the loading of the system default methods that are provided with this package. The absence of this setting is interpreted as a "yes", so explicitly specifying such is not needed. =item RpcAutoMethods [YES|NO] If specified and set to "yes", enables the automatic searching for a requested remote method that is unknown to the server object handling the request. If set to "no" (or not set at all), then a request for an unknown function causes the object instance to report an error. If the routine is still not found, the error is reported. Enabling this is a security risk, and should only be permitted by a server administrator with fully informed acknowledgement and consent. =item RpcAutoUpdates [YES|NO] If specified and set to "yes", enables the checking of the modification time of the file from which a method was originally loaded. If the file has changed, the method is re-loaded before execution is handed off. As with the auto-loading of methods, this represents a potential security risk, and should only be permitted by a server administrator with fully informed acknowledgement and consent. =back =head2 Specifying methods to the server(s) Methods are provided to an B object in three ways: =over 4 =item Default methods Unless suppressed by a C option, the methods shipped with this package are loaded into the table. The B objects get a slightly different version of C than the parent class does. =item Configured directories All method files (those ending in a suffix of C<*.xpl>) in the directories specified in the relevant C settings are read next. These directories are also (after the next step) added to the search path the object uses. =item By specific inclusion Any methods specified directly by use of C settings are loaded last. This allows for them to override methods that may have been loaded from the system defaults or the specified directories. =back If a request is made for an unknown method, the object will first attempt to find it by searching the path of directories that were given in the configuration as well as those that are part of the system (installation-level directories). If it is still not found, then an error is reported back to the requestor. By using this technique, it is possible to add methods to a running server without restarting it. It is a potential security hole, however, and it is for that reason that the previously-documented C setting is provided. =head2 Usage Within Sections To truly unlock the power of having the RPC server attached to a B environment, the application and configuration of the server should be done within Perl-configuration blocks on the Apache server itself. In doing this, two immediate benefits are gained: =over 4 =item (1) The rpc-server object gets created in the master Apache process, rather than within each child as a side-effect of the first request. Especially in cases where there are going to be more than one server in use within the Apache environment, this boosts performance by allowing newly-created children to already have the server object and method table readily available. =item (2) It becomes possible to exert more detailed control over the creation and configuration of each server object. Combining the B and B operations permits "sharing" (of a sort) of methods between server objects. Recall from the B documentation that, when a method is invoked, the first argument is the server object that is marshalling it. =back The following example illustrates these concepts in a fairly simple environment: # In httpd.conf: # First, create and configure some Apache::RPC::Server objects # One regular one, with the standard settings: $main::defobj = Apache::RPC::Server->new(path => '/RPC', auto_methods => 1, auto_updates => 1); # One version without the default methods, and no auto-actions $main::secobj = Apache::RPC::Server->new(no_default => 1, path => '/rpc-secured'); # Imagine that add_method and/or add_methods_in_dir has been used to # add to the methods tables for those objects. Now assign them to # locations managed by Apache: $Location{'/RPC'} = { SetHandler => 'perl-script', PerlHandler => '$main::defobj' }; $Location{'/rpc-secure'} = { SetHandler => 'perl-script', PerlHandler => '$main::secobj', AuthUserFile => '/etc/some_file', AuthType => 'Basic', AuthName => 'SecuredRPC', 'require' => 'valid-user' }; Note that the assignment of the C value was a string representation of the object reference itself. B performs a sort of "thaw" of this string when the location is accessed. Since this class implements itself as a I, this causes the C method for each of the locations to be handed the B object directly. Note also that the value assigned to C cannot be a lexical variable, or it will be out of scope when the handler is called. =head1 DIAGNOSTICS 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. Where appropriate, the C method from the B package is called to note internal errors. =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 C, or through the web interface at L. 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 =item * AnnoCPAN: Annotated CPAN documentation L =item * CPAN Ratings L =item * Search CPAN L =item * MetaCPAN L =item * Source code on GitHub L =back =head1 LICENSE AND COPYRIGHT This file and the code within are copyright (c) 2011 by Randy J. Ray. Copying and distribution are permitted under the terms of the Artistic License 2.0 (L) or the GNU LGPL 2.1 (L). =head1 CREDITS The B standard is Copyright (c) 1998-2001, UserLand Software, Inc. See for more information about the B specification. =head1 SEE ALSO L, L =head1 AUTHOR Randy J. Ray C<< >> =cut RPC-XML-0.82/lib/Apache/RPC/status.base0000644000175000017500000000020611356231360016315 0ustar rjrayrjrayName: system.status Version: 1.2 Hidden: no Signature: struct Signature: struct boolean Helpfile: status.help Codefile: status.code RPC-XML-0.82/lib/Apache/RPC/Status.pm0000644000175000017500000011141411622765353015775 0ustar rjrayrjray############################################################################### # # This file copyright (c) 2001-2011 Randy J. Ray, all rights reserved # # Copying and distribution are permitted under the terms of the Artistic # License 2.0 (http://www.opensource.org/licenses/artistic-license-2.0.php) or # the GNU LGPL (http://www.opensource.org/licenses/lgpl-2.1.php). # ############################################################################### # # Description: This module is intended to provide a browser-friendly # status page on the RPC server(s) being managed by the # hosting Apache process. # # Some parts of this are borrowed from the Apache::Status # module. # # Functions: new # version # handler # init_handler # apache_status_attach # header # footer # make_url # main_screen # server_summary # server_detail # method_summary # method_detail # # Libraries: Apache # Apache::Constants # # Global Consts: $Apache::RPC::Status::VERSION # # Environment: None. # ############################################################################### package Apache::RPC::Status; use 5.008008; use strict; use warnings; use vars qw(%IS_INSTALLED $SERVER_VER $STARTED $PERL_VER $DEFAULT $SERVER_CLASS); use subs qw(header footer main_screen server_summary server_detail method_summary method_detail); 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::Procedure; $SERVER_CLASS = 'Apache::RPC::Server'; $STARTED = scalar localtime $^T; $PERL_VER = $^V ? sprintf 'v%vd', $^V : $]; our $VERSION = '1.13'; $VERSION = eval $VERSION; ## no critic (ProhibitStringyEval) # # %proto is the prototype set of screens/handlers that this class knows about. # It is used in new() to initialize the hash table. # my %proto = ( main => { title => 'Main Screen', call => \&main_screen }, server => { title => 'Server Detail Screen', call => \&server_detail }, method => { title => 'Method Detail Screen', call => \&method_detail }, ); # This is an artifact, but things don't seem to work without it my $newq = sub { CGI->new; }; # # This next bit graciously "borrowed" from Apache::Status # my %IS_INSTALLED = (); { local $SIG{__DIE__}; ## no critic (RequireInitializationForLocalVars) %IS_INSTALLED = map { ($_, (eval("require $_") || 0)); ## no critic (ProhibitStringyEval) } qw(Data::Dumper Devel::Symdump B Apache::Request Apache::Peek Apache::Symbol); } # Simple token-response method sub version { return $Apache::RPC::Status::VERSION } sub new { my ($class, @args) = @_; my %self = %proto; return bless \%self, $class; } # This retrieves the default object for use within handler() below. Basically, # handler() needs a blessed reference to operate on so that it can call the # header() and footer() routines as methods to allow for subclassing. sub default_object { my ($class, @args) = @_; return $DEFAULT if (ref $DEFAULT); return $DEFAULT = $class->new(@args); } ############################################################################### # # Sub Name: handler # # Description: This is the basic entry point for the majority of uses # for this module. It handles requests at the usual content # phase of the request cycle. # # Arguments: NAME IN/OUT TYPE DESCRIPTION # $self in scalar Either a class name (if static) # or a reference # $r in Apache The request object # # Returns: Apache code (either OK or DECLINED) # ############################################################################### sub handler ($$) { my $self = shift; my $r = shift; my ($qs, $pick); if (! ref $self) { $self = $self->default_object(); } $qs = $newq->($r); $pick = $qs->param('screen') || 'main'; # One last check if (! exists $self->{$pick}) { return DECLINED } $self->header($r, $self->{$pick}{title}); $r->print(@{$self->{$pick}{call}->($self, $r, $qs)}); $self->footer($r); return OK; } ############################################################################### # # Sub Name: init_handler # # Description: Perform any child-proc-specific initialization. Must be # set as a PerlChildInitHandler. # # Arguments: NAME IN/OUT TYPE DESCRIPTION # $class in scalar Class or handler reference # $r in Apache Request object # # Globals: $SERVER_CLASS # # Returns: Apache code (currently always OK) # ############################################################################### sub init_handler ($$) { my ($class, $r) = @_; if (my $val = $r->dir_config('ServerClass')) { $SERVER_CLASS = $val; } return OK; } ############################################################################### # # Sub Name: apache_status_attach # # Description: Attach to the Apache::Status mechanism, if possible. The # object that calls this method will be used to dispatch # any future requests. That means that there is a dangling # reference to it in the closure that is created here, and # which likely lives somewhere within Apache::Status. Just # in case you some day wonder why your object appears to # linger... # # Arguments: NAME IN/OUT TYPE DESCRIPTION # $self in ref Object reference # # Returns: void # ############################################################################### sub apache_status_attach { my $self = shift; my $class = ref($self) || $self; if (Apache->module('Apache::Status')) { Apache::Status-> menu_item(XMLRPC => "$class Monitor", sub { my ($r, $q) = @_; #request and CGI objects my $hook = $q->param('screen') || 'main'; $self->{$hook}{call}->($self, $r, $q, 1); }); } return; } ############################################################################### # # Sub Name: header # # Description: Produce the HTML header to start a generic page # # Arguments: NAME IN/OUT TYPE DESCRIPTION # $self in ref Class object # $r in ref Apache request object # $title in scalar If passed, extra text for the # title # # Globals: $SERVER_VER # $STARTED # $PERL_VER # # Returns: void # ############################################################################### sub header { my ($self, $r, $title) = @_; if (! $SERVER_VER) { $SERVER_VER = SERVER_VERSION; } if ($title) { $title = " - $title"; } $title = ref($self) . $title; $r->send_http_header('text/html'); $r->print(<<"EOF"); $title

Perl version $PERL_VER for $SERVER_VER process $$,
running since $STARTED


EOF return; } ############################################################################### # # Sub Name: footer # # Description: Close out the current HTML page # # Arguments: NAME IN/OUT TYPE DESCRIPTION # $self in ref Class object # $r in ref Apache request object # # Returns: void # ############################################################################### sub footer { my ($self, $r) = @_; my $name = ref $self; my $vers = $self->version; my $date = scalar localtime; $r->print(<<"EOF");
$name $vers $date
EOF return; } ############################################################################### # # Sub Name: make_url # # Description: Simple url-generation routine that preserves params from # the CGI (or Apache) object, and pays attention to whether # the URL should be patterned for use under Apache::Status # # Arguments: NAME IN/OUT TYPE DESCRIPTION # $class in scalar Class, ignored # $query in ref Query or Apache object ref # $flag in scalar If passed and true, create a # URI for Apache::Status # # Returns: string # ############################################################################### sub make_url { my ($class, $query, $flag) = @_; if (ref $query ne 'CGI') { $query = $newq->($query); } my @params = map { ($_ eq 'keywords') ? () : "$_=" . $query->param($_) } ($query->param()); my $text = $query->url(-path => 1) . q{?}; if ($flag) { unshift @params, 'RPCXML'; } $text .= join q{&} => @params; return $text; } ############################################################################### # # Sub Name: main_screen # # Description: Produce the HTML body for the main status screen. # # Arguments: NAME IN/OUT TYPE DESCRIPTION # $self in ref Object of this class # $R in ref Apache object reference # $Q in CGI Query object # $flag in scalar If passed and true, this means # that the call is coming from # within Apache::Status # # Globals: $SERVER_CLASS # ############################################################################### sub main_screen { my ($self, $R, $Q, $flag) = @_; my (@servers, $server, $uri, @lines); # Set (or override) the param value for 'screen' before calling make_url $Q->param(-name => 'screen', -value => 'server'); $uri = $self->make_url($Q, $flag); @servers = sort $SERVER_CLASS->list_servers(); push @lines, $Q->p($Q->b('Apache XML-RPC Status Monitor')); push @lines, sprintf '

There %s %d server%s configured:

', (@servers == 1) ? ('is', 1, q{}) : ('are', scalar(@servers), q{s}); push @lines, $Q->table({ -cellpadding => 15, -width => '75%', -border => 0 }, (map { ## no critic (ProhibitComplexMappings) ($server = $_) =~ s/TR({ -valign => 'top' }, $Q->td({ -width => '35%' }, # I'm adding server=n here to avoid extra # calls to make_url() $Q->a({ -href => "$uri&server=$_" }, $server)), $Q->td(server_summary($Q, $SERVER_CLASS-> get_server($_)))); } (@servers))); return \@lines; } ############################################################################### # # Sub Name: server_summary # # Description: Produce the summary table of server info for the main # status page. # # Arguments: NAME IN/OUT TYPE DESCRIPTION # $Q in CGI Query object (for HTML bits) # $srv in ref Server object reference # # Returns: text chunk # ############################################################################### sub server_summary { my ($Q, $srv) = @_; return $Q->table($Q->TR({ -valign => 'top' }, $Q->td($Q->b($Q->tt('URI:'))), $Q->td($srv->url())), $Q->TR({ -valign => 'top' }, $Q->td($Q->b($Q->tt('Requests:'))), $Q->td($srv->requests())), $Q->TR({ -valign => 'top' }, $Q->td($Q->b($Q->tt('Started:'))), $Q->td(scalar localtime $srv->started())), $Q->TR({ -valign => 'top' }, $Q->td($Q->b($Q->tt('Available methods:'))), $Q->td(scalar($srv->list_methods)))); } ############################################################################### # # Sub Name: server_detail # # Description: Provide a detailed break-down screen for a single # server object. # # Arguments: NAME IN/OUT TYPE DESCRIPTION # $self in ref Object of this class # $R in ref Apache object reference # $Q in CGI Query object # $flag in scalar If passed and true, means that # we are called from with the # Apache::Status module # # Globals: $SERVER_CLASS # ############################################################################### sub server_detail { my ($self, $R, $Q, $flag) = @_; my ($srv, $server, @lines, @methods, $meth_left, $meth_right, $base_url); $server = $Q->param('server'); # Override this before calling make_url: $Q->param(-name => 'screen', -value => 'method'); # Now create the base URL string for method_summary to use $base_url = $self->make_url($Q, $flag); if (! $server) { return [ 'Error: No server name specified when screen invoked' ]; } elsif (! ref($srv = $SERVER_CLASS->get_server($server))) { return [ "Error fetching server named $server: $srv" ]; } push @lines, '
', $Q->b('Server: '), $Q->tt($server); push @lines, $Q->br(), $Q->br(); push @lines, ''; push @lines, $Q->TR({ -valign => 'top' }, $Q->td($Q->b('Server Tokens:')), $Q->td($Q->tt($srv->product_tokens))); push @lines, $Q->TR({ -valign => 'top' }, $Q->td($Q->b('Server URL:')), $Q->td($Q->tt($srv->url))); push @lines, $Q->TR({ -valign => 'top' }, $Q->td($Q->b('Server Started:')), $Q->td($Q->tt(scalar localtime $srv->started()))); push @lines, $Q->TR({ -valign => 'top' }, $Q->td($Q->b('This Child Started:')), $Q->td($Q->tt(scalar localtime $srv->child_started))); push @lines, $Q->TR({ -valign => 'top' }, $Q->td($Q->b('Requests Handled:')), $Q->td($Q->tt($srv->requests))); push @lines, $Q->TR({ -valign => 'top' }, $Q->td($Q->b('Method Search Path:')), $Q->td($Q->tt(join $Q->br() => @{$srv->xpl_path}))); push @lines, $Q->TR($Q->td({ colspan => 2 }, ' ')); @methods = sort $srv->list_methods; if (@methods) { push @lines, $Q->TR($Q->td({ colspan => 2, -align => 'center' }, $Q->b('Known Methods: '), sprintf '(%d)', scalar @methods)); push @lines, ''; } push @lines, '
'; while (@methods) { ($meth_left, $meth_right) = splice @methods, 0, 2; push @lines, ''; } push @lines, '
'; push @lines, method_summary($Q, $server, $srv->get_method($meth_left), $base_url); push @lines, ''; if ($meth_right) { push @lines, method_summary($Q, $server, $srv->get_method($meth_right), $base_url); } else { push @lines, ' '; } push @lines, '
'; return \@lines; } ############################################################################### # # Sub Name: method_summary # # Description: Create the HTML table for a method-object summary # # Arguments: NAME IN/OUT TYPE DESCRIPTION # $Q in CGI Query object (for HTML stuff) # $server in scalar Name (ident) of server this # method is from # $meth in ref RPC::XML::Method (or deriv.) # reference # $base_url in scalar Base URL to use when making # links # # Returns: text # ############################################################################### sub method_summary { my ($Q, $server, $meth, $base_url) = @_; return $Q->table({ -width => '100%' }, $Q->TR({ -valign => 'top' }, $Q->td({ -width => '33%' }, $Q->b('Name:')), $Q->td($Q->tt($Q->a({ -href => "$base_url&method=" . $meth->name }, $meth->name)))), $Q->TR({ -valign => 'top' }, $Q->td($Q->b('Version:')), $Q->td($Q->tt($meth->version))), $Q->TR({ -valign => 'top' }, $Q->td($Q->b('Hidden status:')), $Q->td($Q->tt($meth->hidden() ? 'Hidden' : 'Visible'))), $Q->TR({ -valign => 'top' }, $Q->td($Q->b('Calls:')), $Q->td($Q->tt($meth->{called} || 0)))); } ############################################################################### # # Sub Name: method_detail # # Description: Provide a detailed description and statistics for the # specified method. # # Arguments: NAME IN/OUT TYPE DESCRIPTION # $self in ref Object of this class # $R in ref Apache object reference # $Q in CGI Query object # $flag in scalar If passed and true, means that # we are called from with the # Apache::Status module # # Globals: $SERVER_CLASS # ############################################################################### sub method_detail { my ($self, $R, $Q, $flag) = @_; # $flag has no relevance in this routine my ($server, $srv, $method, $meth, $version, $help, @lines); $server = $Q->param('server'); $method = $Q->param('method'); if (! $server) { return [ 'Error: No server name specified when screen invoked' ]; } elsif (! ref($srv = $SERVER_CLASS->get_server($server))) { return [ "Error fetching server named $server: $srv" ]; } if (! $method) { return [ 'Error: No method name specified when screen invoked' ]; } elsif (! ref($meth = $srv->get_method($method))) { return [ "Error: No method named $method found on server $server" ]; } push @lines, '
', $Q->b('Method: '), $Q->tt($method); push @lines, $Q->br(), $Q->br(); push @lines, ''; if ($version = $meth->version) { push @lines, $Q->TR({ -valign => 'top' }, $Q->td($Q->b('Version:')), $Q->td($Q->tt($version))); } push @lines, $Q->TR({ -valign => 'top' }, $Q->td({ -width => '30%' }, $Q->b('Hidden from API:')), $Q->td($Q->tt($meth->hidden() ? 'Yes' : 'No'))); push @lines, $Q->TR({ -valign => 'top' }, $Q->td($Q->b('Calls:')), $Q->td($Q->tt($meth->{called}))); if ($meth->{file}) { push @lines, $Q->TR({ -valign => 'top' }, $Q->td($Q->b('Loaded from:')), $Q->td($Q->tt($meth->{file}))); push @lines, $Q->TR({ -valign => 'top' }, $Q->td($Q->b('File last updated:')), $Q->td($Q->tt(scalar localtime $meth->{mtime}))); } push @lines, $Q->TR({ -valign => 'top' }, $Q->td($Q->b('Signatures:')), $Q->td($Q->tt(join '
' => @{$meth->signature}))); if ($help = $meth->help) { push @lines, $Q->TR($Q->td({ -colspan => 2 }, $Q->b('Help string:'))); push @lines, $Q->TR($Q->td({ -colspan => 2 }, $Q->pre($Q->tt($help)))); } push @lines, '
'; return \@lines; } 1; __END__ =head1 NAME Apache::RPC::Status - A status monitor similar to Apache::Status for RPC =head1 SYNOPSIS # In httpd.conf: SetHandler perl-script PerlHandler Apache::RPC::Status # In the start-up Perl file: use Apache::RPC::Status; =head1 DESCRIPTION The B package is provided as a simple status monitor for XML-RPC servers running in a B environment, using the B class (or derivative of). Patterned after the status system provided with B itself, information is broken down into a series of screens providing information ranging from the RPC servers currently configured down to the individual methods provided by the servers. =head2 Information Screens There are three basic screens provided by the stock B package: =over 4 =item Main: Listing of Servers This screen is the first screen that comes up when the location for which this class was assigned as a handler is invoked. It lists the server objects that this running Apache process knows of. Note that if the servers are defined in such a way as to mean on-demand creation, then a given child process may not have all the configured servers in memory. This is by design, it is not a bug. See LPerlE Sections> for details on configuring the RPC servers such that they are pre-loaded into all child processes. =item Server: Details of a Server Each of the known servers in the main screen links to this screen, which provides details on the specific server. Information such as when the server was started (which usually matches the time that Apache was started), when the specific child was started (which may not be the same), number of requests servered, and so forth is provided. Additionally, each of the methods that the server provides is listed in alphanumeric order, with a link to the next screen. =item Method: Details of a Specific Method For each of the known methods published by a server, this screen summarizes all that is known about the method itself. The signatures, help text and hidden status (whether the method is visible to the introspection API that is shipped with B) are all shown. Some optional information is shown if available: if the method has a version number associated with it, that is displayed. If the method was loaded from an external XPL file, the file path and modification-time are also displayed. =back The primary purpose of this status system is to allow for checking the availability and sanity of the RPC servers themselves. For example, if a server is configured to auto-load methods, and automatically check for updates, the status system could confirm that a method is available or is at the correct version. (Note that auto-loading and auto-updating are done on demand, when a call is made to the method in question. Thus, the status might not reflect changes until at least one call has been made. Further, if there are very many child processes handling the RPC servers, several calls may be necessary to ensure that the child process answering the status request also has the most up-to-date impression of the server.) =head1 SUBROUTINES/METHODS This package is implemented as a method handler for Apache/mod_perl. This means that is should be relatively easy to subclass this package to implement an extended version of status reporting, or to provide handlers for phases of the request lifecycle not otherwise addressed. =head2 Class Methods There are three class methods defined in this package. One is the constructor, the other two are handlers for specific phases in the Apache request lifecycle. =over 4 =item new(CLASS, ARGS) This creates a new object of this class and returns a reference to it. The first argument is the class being created into, the remaining arguments are treated as key/value pairs (note: not a hash reference). At present, the only additional argument recognized is: =over 8 =item serverclass This is used when the status monitor is being used with a server class other than B directly. Because several methods from that class are invoked, it is presumed that the class named here is a subclass of B. If not, the status monitor may not work correctly, or at all. In the absence of this value, C is assumed. This value may also be set with the mod_perl B directive. See the documentation for C, below. =back =item handler(CLASS, REQUEST) This is the primary entry-point for the package. This is the handler defined for assignment to C in a location configuration block. It is invoked by mod_perl as a method handler, thus the first argument is either the name of the class (in the case of class-method, or static, invocation) or the object configured as the handler. The second argument is the Apache request object itself. This method derives the query parameters for the request from the Apache object, and treats them according to the type of information screen requested: =over 8 =item screen This specifies which screen of the status monitor is to be displayed. In absence, the value defaults to "main", which is the internal identifier for the primary screen of the status monitor system. If the value of this parameter does not match a known interface hook, then the handler will signify to mod_perl that it cannot handler the request, by replying with the C> response code. =item server When the B parameter is set to C, the monitor displays the server detail screen. In that case, this parameter specifies which server should be displayed. Servers are given unique identifiers when they are created, usually derived from the URL path that they are attached to. If the value here does not match any known servers, a warning is sent to the browser. =item method When the B parameter is set to C, this calls for the method detail screen. The provided interface hook to deal with these requests looks for both the B parameter above and this one, which specifies by name the method to be laid out in detail. As with the B parameter, if the value in this parameter does not match any known data, an error is reported to the browser. =back Any additional parameters will be preserved by B call detailed below. These are merely the specific ones recognized by the status monitor as written. =item init_handler(CLASS, REQUEST) This is a very simple handler designed for the B phase. At present, it only does one simple task (and thus makes no direct use of either parameter passed to it by mod_perl). However, it is included mainly as a placeholder for possible future expansion. The current behavior is to check for the existence of directory-configuration item called C, and record the value if it is set. This is used to specifiy the class from which the RPC server objects are created, if something other than B. If this information is passed via the C parameter to the B method above, that value overrides any value here. However, that requires actually creating an object to use as the handler, whereas this handler may be used directly, as a static handler. It would be configured outside of any ELocationE blocks, a requirement for the B phase. It is designed to stack cleanly with any other handlers for that phase, provided your mod_perl installation supports stacked handlers. =back =head2 Additional Methods In addition to the class methods above, the following are provided. In most cases, these do not rely on any data contained within the actual object itself. Many may also be called as static methods (these are so noted). They are provided as a utility, implemented as methods so as to avoid namespace issues: =over 4 =item version (May be called as a static method.) Returns the current version of this module. =item apache_status_attach Attach the B module to the main screen of the B display. =item default_object (May be called as a static method.) Returns a default B instance when called as a static method. Returns the calling reference itself, otherwise. =item header(REQUEST, TITLE) Produces the HTML header for a page. Uses the passed-in title parameter to give the page a title, and extracts any request-specific information from the B request object passed as the first parameter. =item footer(REQUEST) Produces the HTML footer. =item make_url(QUERY|REQUEST, FLAG) (May be called as a static method.) This creates a URL string for use as a hyperlink. It makes certain to preserve all parameters in a CGI-like fashion. Additionally, it can make the URL in such a fashion as to allow better integration with the B package. If the C parameter is passed and is any true value, then the resulting URL will be tailored for use with B. The first argument must be either the original request object as passed by mod_perl, or a reference to a CGI object created from the request (see L for more on the CGI class). =item main_screen(REQUEST, QUERY, INTERNAL) Renders the HTML (minus the header and footer) for the main screen. The arguments are the B request object, a B query object created from the request, and a boolean flag indicating whether the call into this method was made from within this module or made from the B page. =item server_summary(SERVER) Creates an HTML snippet to provide a summary for the server passed in as an argument. The passed-in value should be the server object, not the name. =item server_detail(REQUEST, QUERY, INTERNAL) Renders the HTML (minus header and footer) for a screen describing a server instance in detail. The server is specified by name in the query parameters. The arguments are the same as for C. =item method_summary(SERVER, METHOD, BASEURL) Creates and HTML snippet to provide a summary for the specified method of the specified server. The third argument is a base-URL to use for making links to the detailed method page. =item method_detail(REQUEST, QUERY, INTERNAL) Renders the HTML (minus header and footer) for a screen describing a method on a specific server instance, in detail. The method and server are specified by name in the query parameters. The arguments are the same as for C. =back =head2 Use and Extension Within Perl Sections Some extension may be done without necessarily subclassing this package. The class object are implemented simply as hash references. When a request is received, the B parameter (see above) is extracted, and used to look up in the hash table. If there is a value for that key, the value is assumed to be a hash reference with at least two keys (described below). If it does not exist, the handler routine declines to handle the request. Thus, some degree of extension may be done without the need for developing a new class, if the configuration and manipulation are done within EPerlE configuration blocks. Adding a new screen means writing a routine to handle the requests, and then adding a hook into that routine to the object that is the handler for the Apache location that serves RPC status requests. The routines that are written to handle a request should expect four arguments (in order): =over 4 =item The object reference for the location handler =item The Apache request object reference =item A query object reference (see below) =item A flag that is only passed when called from Apache::Status =back The routines are given both the original request object and a query object reference for sake of ease. The query object is already available prior to the dispatch, so there is no reason to have each hook routine write the same few lines to derive a query object from an Apache request. At the same time, the hooks themselves may need the Apache object to call methods on. The query object is an instance of B. The flag parameter is passed by the linkage from this status package to B. The primary use for it is to pass to routines such as B that are sensitive to the B context. The return value from these routines must be a reference to a list of lines of text. It is passed to the B method of the B class. This is necessary for compatibility with the B environment. To add a new hook, merely assign it to the object directly. The key is the value of the C parameter defined above, and the value is a hash reference with two keys: =over 4 =item title A string that is incorporated into the HTML title for the page. =item call A reference to a subroutine or closure that implements the hook, and conforms to the conventions described above. =back A sample addition: $stat_obj->{dbi} = { title => 'RPC-side DBI Pool', call => \&show_dbi_pool }; =head1 INTEGRATION WITH Apache::Status This package is designed to integrate with the B package that is a part of mod_perl. However, this is not currently functional. When this has been debugged, the details will be presented here. =head1 CAVEATS This is the newest part of the RPC-XML package. While the package as a whole is now considered beta, this piece may yet undergo some alpha-like enhancements to the interface and such. However, the design and planning of this were carefully considered, so any such changes should be minimal. =head1 DIAGNOSTICS Diagnostics are not handled well in this module. =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. 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 =item * AnnoCPAN: Annotated CPAN documentation L =item * CPAN Ratings L =item * Search CPAN L =item * MetaCPAN L =item * Source code on GitHub L =back =head1 LICENSE AND COPYRIGHT This file and the code within are copyright (c) 2011 by Randy J. Ray. Copying and distribution are permitted under the terms of the Artistic License 2.0 (L) or the GNU LGPL 2.1 (L). =head1 CREDITS The B standard is Copyright (c) 1998-2001, UserLand Software, Inc. See for more information about the B specification. =head1 SEE ALSO L, L, L =head1 AUTHOR Randy J. Ray C<< >> =cut RPC-XML-0.82/lib/Apache/RPC/status.code0000644000175000017500000000323012713703551016321 0ustar rjrayrjray############################################################################### # # Sub Name: status # # Description: Create a status-reporting struct and returns it. # # Arguments: NAME IN/OUT TYPE DESCRIPTION # $srv in ref Server object instance # # Globals: None. # # Environment: None. # # Returns: hashref # ############################################################################### sub status { use strict; my $srv = shift; my $no_inc = shift || 0; my $status = {}; my $time = time; my $URI; require URI; $status->{name} = ref($srv); $status->{version} = RPC::XML::string->new( $srv->version ); $status->{host} = $srv->host || $srv->{host} || ''; $status->{port} = $srv->port || $srv->{port} || ''; $status->{path} = RPC::XML::string->new( $srv->path ); $status->{child_pid} = $$; $status->{date} = RPC::XML::datetime_iso8601 ->new(RPC::XML::time2iso8601($time)); $status->{started} = RPC::XML::datetime_iso8601 ->new(RPC::XML::time2iso8601($srv->started)); $status->{child_started} = RPC::XML::datetime_iso8601 ->new(RPC::XML::time2iso8601($srv->child_started)); $status->{date_int} = $time; $status->{started_int} = $srv->started; $status->{child_started_int} = $srv->child_started; $status->{total_requests} = $srv->requests; # In special cases where the call to system.status is not going to incr # the total, don't add the extra here, either... $status->{total_requests}++ unless $no_inc; $status->{methods_known} = scalar($srv->list_methods); $status; } RPC-XML-0.82/lib/Apache/RPC/status.help0000644000175000017500000000567211356231360016347 0ustar rjrayrjrayReport on the various status markers of the server itself. The return value is a STRUCT with the following members: Key Type Value host STRING Name of the (possibly virtual) host name to which requests are sent. port INT TCP/IP port the server is listening on. name STRING The name of the server software, as it identifies itself in transport headers. version STRING The software version. Note that this is defined as a STRING, not a DOUBLE, to allow for non-numeric values. path STRING URL path portion, for use when sending POST request messages. child_pid INT The process ID of the child serving this request. date ISO8601 The current date and time on the server, as an ISO 8601 date string. date_int INT The current date as a UNIX time() value. This is encoded as an INT rather than the dateTime.int type, so that it is readable by older clients. started ISO8601 The date and time when the current server started accepting connections, as an ISO 8601 string. started_int INT The server start-time as a UNIX time() value. This is also encoded as INT for the same reasons as the "date_int" value above. child_started ISO8601 The date and time when this child process was created by the master Apache/mod_perl process. child_started_int INT As above. total_requests INT Total number of requests served thus far (including the current one). This will not include requests for which there was no matching method, or HTTP-HEAD requests. methods_known INT The number of different methods the server has registered for serving requests. This is a slightly different system.struct implementation instrumented for use in an Apache/mod_perl environment. If this method is called with a single boolean value, that value determines whether the current call should be counted against the value of the "total_requests" field. This is also handled at the server level. Setting this boolean value to a "true" value causes the server (and the resulting data structure returned) to not count this call. This feature allows external tools (monitors, etc.) to check the status regularly without falsely running up the value of "total_requests". RPC-XML-0.82/lib/RPC/0000755000175000017500000000000013775375652013003 5ustar rjrayrjrayRPC-XML-0.82/lib/RPC/XML.pm0000644000175000017500000020123112713703551013760 0ustar rjrayrjray############################################################################### # # This file copyright (c) 2001-2014 Randy J. Ray, all rights reserved # # Copying and distribution are permitted under the terms of the Artistic # License 2.0 (http://www.opensource.org/licenses/artistic-license-2.0.php) or # the GNU LGPL (http://www.opensource.org/licenses/lgpl-2.1.php). # ############################################################################### # # Description: This module provides the core XML <-> RPC conversion and # structural management. # # Functions: This module contains many, many subclasses. Better to # examine them individually. # # Libraries: RPC::XML::base64 uses MIME::Base64 # DateTime::Format::ISO8601 is used if available # # Global Consts: $VERSION # ############################################################################### package RPC::XML; use 5.008008; use strict; use warnings; use vars qw(@EXPORT_OK %EXPORT_TAGS $VERSION $ERROR %XMLMAP $XMLRE $ENCODING $FORCE_STRING_ENCODING $ALLOW_NIL $DATETIME_REGEXP $DATETIME_ISO8601_AVAILABLE); use subs qw(time2iso8601 smart_encode); use base 'Exporter'; use Module::Load; use Scalar::Util qw(blessed reftype); # The RPC_* convenience-encoders need prototypes: ## no critic (ProhibitSubroutinePrototypes) # This module declares all the data-type packages: ## no critic (ProhibitMultiplePackages) # The data-type package names trigger this one: ## no critic (Capitalization) # The XML escape map now has CR in it but I don't want to use charnames: ## no critic (ProhibitEscapedCharacters) BEGIN { # Default encoding: $ENCODING = 'us-ascii'; # force strings? $FORCE_STRING_ENCODING = 0; # Allow the extension? $ALLOW_NIL = 0; # Determine if the DateTime::Format::ISO8601 module is available for # RPC::XML::datetime_iso8601 to use: $DATETIME_ISO8601_AVAILABLE = eval { load DateTime::Format::ISO8601; 1; }; } @EXPORT_OK = qw(time2iso8601 smart_encode RPC_BOOLEAN RPC_INT RPC_I4 RPC_I8 RPC_DOUBLE RPC_DATETIME_ISO8601 RPC_BASE64 RPC_STRING RPC_NIL $ENCODING $FORCE_STRING_ENCODING $ALLOW_NIL); %EXPORT_TAGS = (types => [ qw(RPC_BOOLEAN RPC_INT RPC_I4 RPC_I8 RPC_DOUBLE RPC_STRING RPC_DATETIME_ISO8601 RPC_BASE64 RPC_NIL) ], all => [ @EXPORT_OK ]); $VERSION = '1.61'; $VERSION = eval $VERSION; ## no critic (ProhibitStringyEval) # Global error string $ERROR = q{}; # These are used for stringifying XML-sensitive characters that may appear # in struct keys: %XMLMAP = ( q{>} => '>', q{<} => '<', q{&} => '&', q{"} => '"', q{'} => ''', "\x0d" => ' ', ); $XMLRE = join q{} => keys %XMLMAP; $XMLRE = qr/([$XMLRE])/; # The XMLRPC spec only allows for the incorrect iso8601 format # without dashes, but dashes are part of the standard so we include # them. Note that the actual RPC::XML::datetime_iso8601 class will strip # them out if present. my $date_re = qr{ (\d{4})-? ([01]\d)-? ([0123]\d) }x; my $time_re = qr{ ([012]\d): ([0-5]\d): ([0-5]\d)([.,]\d+)? (Z|[-+]\d\d:\d\d)? }x; $DATETIME_REGEXP = qr{^${date_re}T?${time_re}$}; # All of the RPC_* functions are convenience-encoders sub RPC_STRING ($) { return RPC::XML::string->new(shift); } sub RPC_BOOLEAN ($) { return RPC::XML::boolean->new(shift); } sub RPC_INT ($) { return RPC::XML::int->new(shift); } sub RPC_I4 ($) { return RPC::XML::i4->new(shift); } sub RPC_I8 ($) { return RPC::XML::i8->new(shift); } sub RPC_DOUBLE ($) { return RPC::XML::double->new(shift); } sub RPC_DATETIME_ISO8601 ($) { return RPC::XML::datetime_iso8601->new(shift); } sub RPC_BASE64 ($;$) { return RPC::XML::base64->new(shift, shift); } sub RPC_NIL () { return RPC::XML::nil->new(); } # This is a dead-simple ISO8601-from-UNIX-time stringifier. Always expresses # time in UTC. The format isn't strictly ISO8601, though, as the XML-RPC spec # fucked it up. sub time2iso8601 { my $time = shift || time; my @time = gmtime $time; $time = sprintf '%4d%02d%02dT%02d:%02d:%02dZ', $time[5] + 1900, $time[4] + 1, @time[3, 2, 1, 0]; return $time; } # This is a (futile?) attempt to provide a "smart" encoding method that will # take a Perl scalar and promote it to the appropriate RPC::XML::_type_. { # The regex for ints and floats uses [0-9] instead of \d on purpose, to # only match ASCII digits. ## no critic (ProhibitEnumeratedClasses) # The regex for floats is long, but I don't feel like factoring it out # right now. ## no critic (ProhibitComplexRegexes) my $MAX_INT = 2_147_483_647; my $MIN_INT = -2_147_483_648; my $MAX_BIG_INT = 9_223_372_036_854_775_807; my $MIN_BIG_INT = -9_223_372_036_854_775_808; my $MAX_DOUBLE = 1e37; my $MIN_DOUBLE = $MAX_DOUBLE * -1; sub smart_encode ## no critic (ProhibitExcessComplexity) { my @values = @_; my ($type, $seenrefs, @newvalues); # Look for sooper-sekrit pseudo-blessed hashref as first argument. # It means this is a recursive call, and it contains a map of any # references we've already seen. if ((blessed $values[0]) && ($values[0]->isa('RPC::XML::refmap'))) { # Peel it off of the list $seenrefs = shift @values; } else { # Create one just in case we need it $seenrefs = bless {}, 'RPC::XML::refmap'; } for my $value (@values) { if (! defined $value) { $type = $ALLOW_NIL ? RPC::XML::nil->new() : RPC::XML::string->new(q{}); } elsif (ref $value) { # Skip any that we've already seen next if $seenrefs->{$value}++; if (blessed($value) && ($value->isa('RPC::XML::datatype') || $value->isa('DateTime'))) { # Only if the reference is a datatype or a DateTime # instance, do we short-cut here... if ($value->isa('RPC::XML::datatype')) { # Pass through any that have already been encoded $type = $value; } else { # Must be a DateTime object, convert to ISO8601 $type = RPC::XML::datetime_iso8601 ->new($value->clone->set_time_zone('UTC')); } } elsif (reftype($value) eq 'HASH') { # Per RT 41063, to catch circular refs I can't delegate # to the struct constructor, I have to create my own # copy of the hash with locally-recursively-encoded # values my %newhash; for my $key (keys %{$value}) { # 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, $value->{$key})) { $newhash{$key} = $value[0]; } } $type = RPC::XML::struct->new(\%newhash); } elsif (reftype($value) eq 'ARRAY') { # This is a somewhat-ugly approach, but I don't want to # dereference @$value, but I also want people to be able to # pass array-refs in to this constructor and have them # be treated as single elements, as one would expect # (see RT 35106) # Per RT 41063, looks like I get to deref $value after all... $type = RPC::XML::array->new( from => [ smart_encode($seenrefs, @{$value}) ] ); } elsif (reftype($value) eq 'SCALAR') { # This is a rare excursion into recursion, since the scalar # nature (de-refed from the object, so no longer magic) # will prevent further recursing. $type = smart_encode($seenrefs, ${$value}); } else { # If the user passed in a reference that didn't pass one # of the above tests, we can't do anything with it: $type = reftype $value; die "Un-convertable reference: $type, cannot use\n"; } $seenrefs->{$value}--; } # You have to check ints first, because they match the # next pattern (for doubles) too elsif (! $FORCE_STRING_ENCODING && $value =~ /^[-+]?[0-9]+$/ && $value >= $MIN_BIG_INT && $value <= $MAX_BIG_INT) { if (($value > $MAX_INT) || ($value < $MIN_INT)) { $type = RPC::XML::i8->new($value); } else { $type = RPC::XML::int->new($value); } } # Pattern taken from perldata(1) elsif (! $FORCE_STRING_ENCODING && $value =~ m{ ^ [+-]? (?=[0-9]|[.][0-9]) [0-9]* (?:[.][0-9]*)? (?:[Ee](?:[+-]?[0-9]+))? $ }x && $value > $MIN_DOUBLE && $value < $MAX_DOUBLE) { $type = RPC::XML::double->new($value); } elsif ($value =~ /$DATETIME_REGEXP/) { $type = RPC::XML::datetime_iso8601->new($value); } else { $type = RPC::XML::string->new($value); } push @newvalues, $type; } return (wantarray ? @newvalues : $newvalues[0]); } } # This is a (mostly) empty class used as a common superclass for simple and # complex types, so that their derivatives may be universally type-checked. package RPC::XML::datatype; sub type { my $self = shift; my $class = ref($self) || $self; $class =~ s/.*://; return $class; } sub is_fault { return 0; } ############################################################################### # # Package: RPC::XML::simple_type # # Description: A base class for the simpler type-classes to inherit from, # for default constructor, stringification, etc. # ############################################################################### package RPC::XML::simple_type; use strict; use base 'RPC::XML::datatype'; use Scalar::Util 'reftype'; # new - a generic constructor that presumes the value being stored is scalar sub new { my $class = shift; my $value = shift; $RPC::XML::ERROR = q{}; $class = ref($class) || $class; if ($class eq 'RPC::XML::simple_type') { $RPC::XML::ERROR = 'RPC::XML::simple_type::new: Cannot instantiate ' . 'this class directly'; return; } if (ref $value) { # If it is a scalar reference, just deref if (reftype($value) eq 'SCALAR') { $value = ${$value}; } else { # We can only manage scalar references (or blessed scalar refs) $RPC::XML::ERROR = "${class}::new: Cannot instantiate from a " . 'reference not derived from scalar'; return; } } return bless \$value, $class; } # value - a generic accessor sub value { my $self = shift; if (! ref $self) { $RPC::XML::ERROR = "{$self}::value: Cannot be called as a static method"; return; } return ${$self}; } # as_string - return the value as an XML snippet sub as_string { my $self = shift; my $class = ref $self; if (! $class) { $RPC::XML::ERROR = "{$self}::as_string: Cannot be called as a static method"; return; } $class =~ s/^.*\://; $class =~ s/_/./g; if (substr($class, 0, 8) eq 'datetime') { substr $class, 0, 8, 'dateTime'; } return "<$class>${$self}"; } # Serialization for simple types is just a matter of sending as_string over sub serialize { my ($self, $fh) = @_; utf8::encode(my $str = $self->as_string); print {$fh} $str; return; } # The switch to serialization instead of in-memory strings means having to # calculate total size in bytes for Content-Length headers: sub length ## no critic (ProhibitBuiltinHomonyms) { my $self = shift; utf8::encode(my $str = $self->as_string); return length $str; } ############################################################################### # # Package: RPC::XML::int # # Description: Data-type class for integers # ############################################################################### package RPC::XML::int; use strict; use base 'RPC::XML::simple_type'; ############################################################################### # # Package: RPC::XML::i4 # # Description: Data-type class for i4. Forces data into an int object. # ############################################################################### package RPC::XML::i4; use strict; use base 'RPC::XML::simple_type'; ############################################################################### # # Package: RPC::XML::i8 # # Description: Data-type class for i8. Forces data into a 8-byte int. # ############################################################################### package RPC::XML::i8; use strict; use base 'RPC::XML::simple_type'; ############################################################################### # # Package: RPC::XML::double # # Description: The "double" type-class # ############################################################################### package RPC::XML::double; use strict; use base 'RPC::XML::simple_type'; sub as_string { my $self = shift; if (! ref $self) { $RPC::XML::ERROR = "{$self}::as_string: Cannot be called as a static method"; return; } my $class = $self->type; (my $value = sprintf '%.20f', ${$self}) =~ s/([.]\d+?)0+$/$1/; return "<$class>$value"; } ############################################################################### # # Package: RPC::XML::string # # Description: The "string" type-class # ############################################################################### package RPC::XML::string; use strict; use base 'RPC::XML::simple_type'; # as_string - return the value as an XML snippet sub as_string { my $self = shift; my ($class, $value); if (! ref $self) { $RPC::XML::ERROR = "{$self}::as_string: Cannot be called as a static method"; return; } $class = $self->type; ($value = defined ${$self} ? ${$self} : q{} ) =~ s/$RPC::XML::XMLRE/$RPC::XML::XMLMAP{$1}/ge; return "<$class>$value"; } ############################################################################### # # Package: RPC::XML::boolean # # Description: The type-class for boolean data. Handles some "extra" cases # ############################################################################### package RPC::XML::boolean; use strict; use base 'RPC::XML::simple_type'; # This constructor allows any of true, false, yes or no to be specified sub new { my $class = shift; my $value = shift || 0; $RPC::XML::ERROR = q{}; if ($value =~ /true|yes|1/i) { $value = 1; } elsif ($value =~ /false|no|0/i) { $value = 0; } else { $class = ref($class) || $class; $RPC::XML::ERROR = "${class}::new: Value must be one of yes, no, " . 'true, false, 1, 0 (case-insensitive)'; return; } return bless \$value, $class; } ############################################################################### # # Package: RPC::XML::datetime_iso8601 # # Description: This is the class to manage ISO8601-style date/time values # ############################################################################### package RPC::XML::datetime_iso8601; use strict; use base 'RPC::XML::simple_type'; use Scalar::Util 'reftype'; sub type { return 'dateTime.iso8601'; }; # Check the value passed in for sanity, and normalize the string representation sub new { my ($class, $value) = @_; my $newvalue; if (ref($value) && reftype($value) eq 'SCALAR') { $value = ${$value}; } if (defined $value) { if ($value =~ /$RPC::XML::DATETIME_REGEXP/) { # This is *not* a valid ISO 8601 format, but it's the way it is # given in the spec, so assume that other implementations can only # accept this form. Also, this should match the form that # time2iso8601 produces. $newvalue = $7 ? "$1$2$3T$4:$5:$6$7" : "$1$2$3T$4:$5:$6"; if ($8) { $newvalue .= $8; } } elsif ($RPC::XML::DATETIME_ISO8601_AVAILABLE) { $newvalue = eval { DateTime::Format::ISO8601->parse_datetime($value) }; if ($newvalue) { # This both removes the dashes (*sigh*) and forces it from an # object to an ordinary string: $newvalue =~ s/-//g; } } if (! $newvalue) { $RPC::XML::ERROR = "${class}::new: Malformed data ($value) " . 'passed as dateTime.iso8601'; return; } } else { $RPC::XML::ERROR = "${class}::new: Value required in constructor"; return; } return bless \$newvalue, $class; } ############################################################################### # # Package: RPC::XML::nil # # Description: The "nil" type-class extension # ############################################################################### package RPC::XML::nil; use strict; use base 'RPC::XML::simple_type'; # no value need be passed to this method sub new { my ($class, $value, $flag) = @_; # We need $value so we can bless a reference to it. But regardless of # what was passed, it needs to be undef to be a proper "nil". undef $value; if (! $RPC::XML::ALLOW_NIL && ! $flag) { $RPC::XML::ERROR = "${class}::new: \$RPC::XML::ALLOW_NIL must be set" . ' for RPC::XML::nil objects to be supported'; return; } return bless \$value, $class; } # Stringification and serialsation are trivial.. sub as_string { return ''; } sub serialize { my ($self, $fh) = @_; print {$fh} $self->as_string; # In case someone sub-classes this return; } ############################################################################### # # Package: RPC::XML::array # # Description: This class encapsulates the array data type. Each element # within the array should be one of the datatype classes. # ############################################################################### package RPC::XML::array; use strict; use base 'RPC::XML::datatype'; use Scalar::Util qw(blessed reftype); # The constructor for this class mainly needs to sanity-check the value data sub new { my ($class, @args) = @_; # Special-case time: If the args-list has exactly two elements, and the # first element is "from" and the second element is an array-ref (or a # type derived from), then copy the ref's contents into @args. if ((2 == @args) && ($args[0] eq 'from') && (reftype($args[1]) eq 'ARRAY')) { @args = @{$args[1]}; } # Ensure that each argument passed in is itself one of the data-type # class instances. return bless [ RPC::XML::smart_encode(@args) ], $class; } # This became more complex once it was shown that there may be a need to fetch # the value while preserving the underlying objects. sub value { my $self = shift; my $no_recurse = shift || 0; my $ret; if ($no_recurse) { $ret = [ @{$self} ]; } else { $ret = [ map { $_->value } @{$self} ]; } return $ret; } sub as_string { my $self = shift; return join q{}, '', (map { ('', $_->as_string(), '') } (@{$self})), ''; } # Serialization for arrays is not as straight-forward as it is for simple # types. One or more of the elements may be a base64 object, which has a # non-trivial serialize() method. Thus, rather than just sending the data from # as_string down the pipe, instead call serialize() recursively on all of the # elements. sub serialize { my ($self, $fh) = @_; print {$fh} ''; for (@{$self}) { print {$fh} ''; $_->serialize($fh); print {$fh} ''; } print {$fh} ''; return; } # Length calculation starts to get messy here, due to recursion sub length ## no critic (ProhibitBuiltinHomonyms) { my $self = shift; # Start with the constant components in the text my $len = 28; # That the part for (@{$self}) { $len += (15 + $_->length) } # 15 is for return $len; } ############################################################################### # # Package: RPC::XML::struct # # Description: This is the "struct" data class. The struct is like Perl's # hash, with the constraint that all values are instances # of the datatype classes. # ############################################################################### package RPC::XML::struct; use strict; use base 'RPC::XML::datatype'; use Scalar::Util qw(blessed reftype); # The constructor for this class mainly needs to sanity-check the value data sub new { my ($class, @args) = @_; my %args = (ref $args[0] and reftype($args[0]) eq 'HASH') ? %{$args[0]} : @args; # RT 41063: If all the values are datatype objects, either they came in # that way or we've already laundered them through smart_encode(). If there # is even one that isn't, then we have to pass the whole mess to be # encoded. my $ref = (grep { ! (blessed($_) && $_->isa('RPC::XML::datatype')) } values %args) ? RPC::XML::smart_encode(\%args) : \%args; return bless $ref, $class; } # This became more complex once it was shown that there may be a need to fetch # the value while preserving the underlying objects. sub value { my $self = shift; my $no_recurse = shift || 0; my %value; if ($no_recurse) { %value = map { ($_, $self->{$_}) } (keys %{$self}); } else { %value = map { ($_, $self->{$_}->value) } (keys %{$self}); } return \%value; } sub as_string { my $self = shift; my $key; # Clean the keys of $self, in case they have any HTML-special characters my %clean; for (keys %{$self}) { ($key = $_) =~ s/$RPC::XML::XMLRE/$RPC::XML::XMLMAP{$1}/ge; $clean{$key} = $self->{$_}->as_string; } return join q{}, '', (map { ("$_", $clean{$_}, '') } (keys %clean)), ''; } # As with the array type, serialization here isn't cut and dried, since one or # more values may be base64. sub serialize { my ($self, $fh) = @_; my $key; print {$fh} ''; for (keys %{$self}) { ($key = $_) =~ s/$RPC::XML::XMLRE/$RPC::XML::XMLMAP{$1}/ge; utf8::encode($key); print {$fh} "$key"; $self->{$_}->serialize($fh); print {$fh} ''; } print {$fh} ''; return; } # Length calculation is a real pain here. But not as bad as base64 promises sub length ## no critic (ProhibitBuiltinHomonyms) { my $self = shift; my $len = 17; # for my $key (keys %{$self}) { $len += 45; # For all the constant XML presence $len += $self->{$key}->length; utf8::encode($key); $len += length $key; } return $len; } ############################################################################### # # Package: RPC::XML::base64 # # Description: This is the base64-encoding type. Plain data is passed in, # plain data is returned. Plain is always returned. All the # encoding/decoding is done behind the scenes. # ############################################################################### package RPC::XML::base64; use strict; use base 'RPC::XML::datatype'; use Scalar::Util 'reftype'; sub new { my ($class, $value, $encoded) = @_; require MIME::Base64; my $self = {}; $RPC::XML::ERROR = q{}; $self->{encoded} = $encoded ? 1 : 0; # Is this already Base-64? $self->{inmem} = 0; # To signal in-memory vs. filehandle # First, determine if the call sent actual data, a reference to actual # data, or an open filehandle. if (ref $value and reftype($value) eq 'GLOB') { # This is a seekable filehandle (or acceptable substitute thereof). # This assignment increments the ref-count, and prevents destruction # in other scopes. binmode $value; $self->{value_fh} = $value; $self->{fh_pos} = tell $value; } else { # Not a filehandle. Might be a scalar ref, but other than that it's # in-memory data. $self->{inmem}++; $self->{value} = ref($value) ? ${$value} : ($value || q{}); # We want in-memory data to always be in the clear, to reduce the tests # needed in value(), below. if ($self->{encoded}) { local $^W = 0; # Disable warnings in case the data is underpadded $self->{value} = MIME::Base64::decode_base64($self->{value}); $self->{encoded} = 0; } } return bless $self, $class; } sub value { my ($self, $flag) = @_; my $as_base64 = (defined $flag and $flag) ? 1 : 0; # There are six cases here, based on whether or not the data exists in # Base-64 or clear form, and whether the data is in-memory or needs to be # read from a filehandle. if ($self->{inmem}) { # This is simplified into two cases (rather than four) since we always # keep in-memory data as cleartext return $as_base64 ? MIME::Base64::encode_base64($self->{value}, q{}) : $self->{value}; } else { # This is trickier with filehandle-based data, since we chose not to # change the state of the data. Thus, the behavior is dependant not # only on $as_base64, but also on $self->{encoded}. This is why we # took pains to explicitly set $as_base64 to either 0 or 1, rather than # just accept whatever non-false value the caller sent. It makes this # first test possible. my ($accum, $pos, $res); $accum = q{}; $self->{fh_pos} = tell $self->{value_fh}; seek $self->{value_fh}, 0, 0; if ($as_base64 == $self->{encoded}) { $pos = 0; while ($res = read $self->{value_fh}, $accum, 1024, $pos) { $pos += $res; } } else { if ($as_base64) { # We're reading cleartext and converting it to Base-64. Read in # multiples of 57 bytes for best Base-64 calculation. The # choice of 60 for the multiple is purely arbitrary. $res = q{}; while (read $self->{value_fh}, $res, 60*57) { $accum .= MIME::Base64::encode_base64($res, q{}); } } else { # Reading Base-64 and converting it back to cleartext. If the # Base-64 data doesn't have any line-breaks, no telling how # much memory this will eat up. local $^W = 0; # Disable padding-length warnings $pos = $self->{value_fh}; while (defined($res = <$pos>)) { $accum .= MIME::Base64::decode_base64($res); } } } seek $self->{value_fh}, $self->{fh_pos}, 0; return $accum; } } # The value needs to be encoded before being output sub as_string { my $self = shift; return '' . $self->value('encoded') . ''; } # If it weren't for Tellme and their damnable WAV files, and ViAir and their # half-baked XML-RPC server, I wouldn't have to do any of this... # # (On the plus side, at least here I don't have to worry about encodings...) sub serialize { my ($self, $fh) = @_; # If the data is in-memory, just call as_string and pass it down the pipe if ($self->{inmem}) { print {$fh} $self->as_string; } else { # If it's a filehandle, at least we take comfort in knowing that we # always want Base-64 at this level. my $buf = q{}; $self->{fh_pos} = tell $self->{value_fh}; seek $self->{value_fh}, 0, 0; print {$fh} ''; if ($self->{encoded}) { # Easy-- just use read() to send it down in palatably-sized chunks while (read $self->{value_fh}, $buf, 4096) { print {$fh} $buf; } } else { # This actually requires work. As with value(), the 60*57 is based # on ideal Base-64 chunks, with the 60 part being arbitrary. while (read $self->{value_fh}, $buf, 60*57) { print {$fh} MIME::Base64::encode_base64($buf, q{}); } } print {$fh} ''; seek $self->{value_fh}, $self->{fh_pos}, 0; } return; } # This promises to be a big enough pain that I seriously considered opening # an anon-temp file (one that's unlinked for security, and survives only as # long as the FH is open) and passing that to serialize just to -s on the FH. # But I'll do this the "right" way instead... sub length ## no critic (ProhibitBuiltinHomonyms) { my $self = shift; # Start with the constant bits my $len = 17; # if ($self->{inmem}) { # If it's in-memory, it's cleartext. Size the encoded version $len += length(MIME::Base64::encode_base64($self->{value}, q{})); } else { if ($self->{encoded}) { # We're lucky, it's already encoded in the file, and -s will do $len += -s $self->{value_fh}; } else { # Oh bugger. We have to encode it. my $buf = q{}; my $cnt = 0; $self->{fh_pos} = tell $self->{value_fh}; seek $self->{value_fh}, 0, 0; while ($cnt = read $self->{value_fh}, $buf, 60*57) { $len += length(MIME::Base64::encode_base64($buf, q{})); } seek $self->{value_fh}, $self->{fh_pos}, 0; } } return $len; } # This allows writing the decoded data to an arbitrary file. It's useful when # an application has gotten a RPC::XML::base64 object back from a request, and # knows that it needs to go straight to a file without being completely read # into memory, first. sub to_file { my ($self, $file) = @_; my ($fh, $buf, $do_close, $count) = (undef, q{}, 0, 0); if (ref $file) { if (reftype($file) eq 'GLOB') { $fh = $file; } else { $RPC::XML::ERROR = 'Unusable reference type passed to to_file'; return -1; } } else { if (! open $fh, '>', $file) ## no critic (RequireBriefOpen) { $RPC::XML::ERROR = "Error opening $file for writing: $!"; return -1; } binmode $fh; $do_close++; } # If all the data is in-memory, then we know that it's clear, and we # don't have to jump through hoops in moving it to the filehandle. if ($self->{inmem}) { print {$fh} $self->{value}; $count = CORE::length($self->{value}); } else { # Filehandle-to-filehandle transfer. # Now determine if the data can be copied over directly, or if we have # to decode it along the way. $self->{fh_pos} = tell $self->{value_fh}; seek $self->{value_fh}, 0, 0; if ($self->{encoded}) { # As with the caveat in value(), if the base-64 data doesn't have # any line-breaks, no telling how much memory this will eat up. local $^W = 0; # Disable padding-length warnings my $tmp_fh = $self->{value_fh}; while (defined($_ = <$tmp_fh>)) { $buf = MIME::Base64::decode_base64($_); print {$fh} $buf; $count += CORE::length($buf); } } else { # If the data is already decoded in the filehandle, then just copy # it over. my $size; while ($size = read $self->{value_fh}, $buf, 4096) { print {$fh} $buf; $count += $size; } } # Restore the position of the file-pointer for the internal FH seek $self->{value_fh}, $self->{fh_pos}, 0; } if ($do_close) { if (! close $fh) { $RPC::XML::ERROR = "Error closing $file after writing: $!"; return -1; } } return $count; } ############################################################################### # # Package: RPC::XML::fault # # Description: This is the class that encapsulates the data for a RPC # fault-response. Like the others, it takes the relevant # information and maintains it internally. This is put # at the end of the datum types, though it isn't really a # data type in the sense that it cannot be passed in to a # request. But it is separated so as to better generalize # responses. # ############################################################################### package RPC::XML::fault; use strict; use base 'RPC::XML::struct'; use Scalar::Util 'blessed'; # For our new(), we only need to ensure that we have the two required members sub new { my ($class, @args) = @_; my %args; $RPC::XML::ERROR = q{}; if (blessed $args[0] and $args[0]->isa('RPC::XML::struct')) { # Take the keys and values from the struct object as our own %args = %{$args[0]->value('shallow')}; } elsif ((@args == 2) && ($args[0] =~ /^-?\d+$/) && length $args[1]) { # This is a special convenience-case to make simple new() calls clearer %args = (faultCode => RPC::XML::int->new($args[0]), faultString => RPC::XML::string->new($args[1])); } else { %args = @args; } if (! ($args{faultCode} and $args{faultString})) { $class = ref($class) || $class; $RPC::XML::ERROR = "${class}::new: Missing required struct fields"; return; } if (scalar(keys %args) > 2) { $class = ref($class) || $class; $RPC::XML::ERROR = "${class}::new: Extra struct fields not allowed"; return; } return $class->SUPER::new(%args); } # This only differs from the display of a struct in that it has some extra # wrapped around it. Let the superclass as_string method do most of the work. sub as_string { my $self = shift; return '' . $self->SUPER::as_string . ''; } # Again, only differs from struct in that it has some extra wrapped around it. sub serialize { my ($self, $fh) = @_; print {$fh} ''; $self->SUPER::serialize($fh); print {$fh} ''; return; } # Because of the slight diff above, length() has to be different from struct sub length ## no critic (ProhibitBuiltinHomonyms) { my $self = shift; return $self->SUPER::length + 30; # For constant XML content } # Convenience methods: sub code { return shift->{faultCode}->value; } sub string { return shift->{faultString}->value; } # This is the only one to override this method, for obvious reasons sub is_fault { return 1; } ############################################################################### # # Package: RPC::XML::request # # Description: This is the class that encapsulates the data for a RPC # request. It takes the relevant information and maintains # it internally until asked to stringify. Only then is the # XML generated, encoding checked, etc. This allows for # late-selection of or as a # containing tag. # # This class really only needs a constructor and a method # to stringify. # ############################################################################### package RPC::XML::request; use strict; use Scalar::Util 'blessed'; ############################################################################### # # Sub Name: new # # Description: Creating a new request object, in this (reference) case, # means checking the list of arguments for sanity and # packaging it up for later use. # # Arguments: NAME IN/OUT TYPE DESCRIPTION # $class in scalar Class/ref to bless into # @argz in list The exact disposition of the # arguments is based on the # type of the various elements # # Returns: Success: object ref # Failure: undef, error in $RPC::XML::ERROR # ############################################################################### sub new { my ($class, @argz) = @_; my $name; $class = ref($class) || $class; $RPC::XML::ERROR = q{}; if (! @argz) { $RPC::XML::ERROR = 'RPC::XML::request::new: At least a method name ' . 'must be specified'; return; } # This is the method name to be called $name = shift @argz; # Is it valid? if ($name !~ m{^[\w.:/]+$}) { $RPC::XML::ERROR = 'RPC::XML::request::new: Invalid method name specified'; return; } # All the remaining args must be data. @argz = RPC::XML::smart_encode(@argz); return bless { args => [ @argz ], name => $name }, $class; } # Accessor methods sub name { return shift->{name}; } sub args { return shift->{args}; } ############################################################################### # # Sub Name: as_string # # Description: This is a fair bit more complex than the simple as_string # methods for the datatypes. Express the invoking object as # a well-formed XML document. # # Arguments: NAME IN/OUT TYPE DESCRIPTION # $self in ref Invoking object # $indent in scalar Indention level for output # # Returns: Success: text # Failure: undef # ############################################################################### sub as_string { my $self = shift; my $text; $RPC::XML::ERROR = q{}; $text = qq(); $text .= "$self->{name}"; for (@{$self->{args}}) { $text .= '' . $_->as_string . ''; } $text .= ''; return $text; } # The difference between stringifying and serializing a request is much like # the difference was for structs and arrays. The boilerplate is the same, but # the destination is different in a sensitive way. sub serialize { my ($self, $fh) = @_; utf8::encode(my $name = $self->{name}); print {$fh} qq(); print {$fh} "$name"; for (@{$self->{args}}) { print {$fh} ''; $_->serialize($fh); print {$fh} ''; } print {$fh} ''; return; } # Compared to base64, length-calculation here is pretty easy, much like struct sub length ## no critic (ProhibitBuiltinHomonyms) { my $self = shift; my $len = 100 + length $RPC::XML::ENCODING; # All the constant XML present utf8::encode(my $name = $self->{name}); $len += length $name; for (@{$self->{args}}) { $len += 30; # Constant XML $len += $_->length; } return $len; } ############################################################################### # # Package: RPC::XML::response # # Description: This is the class that encapsulates the data for a RPC # response. As above, it takes the information and maintains # it internally until asked to stringify. Only then is the # XML generated, encoding checked, etc. This allows for # late-selection of or # as above. # ############################################################################### package RPC::XML::response; use strict; use Scalar::Util 'blessed'; ############################################################################### # # Sub Name: new # # Description: Creating a new response object, in this (reference) case, # means checking the outgoing parameter(s) for sanity. # # Arguments: NAME IN/OUT TYPE DESCRIPTION # $class in scalar Class/ref to bless into # @argz in list The exact disposition of the # arguments is based on the # type of the various elements # # Returns: Success: object ref # Failure: undef, error in $RPC::XML::ERROR # ############################################################################### sub new { my ($class, @argz) = @_; $class = ref($class) || $class; $RPC::XML::ERROR = q{}; if (! @argz) { $RPC::XML::ERROR = 'RPC::XML::response::new: One of a datatype, ' . 'value or a fault object must be specified'; return; } elsif (@argz > 1) { $RPC::XML::ERROR = 'RPC::XML::response::new: Responses may take ' . 'only one argument'; return; } $argz[0] = RPC::XML::smart_encode($argz[0]); return bless { value => $argz[0] }, $class; } # Accessor/status methods sub value { return shift->{value}; } sub is_fault { return shift->{value}->is_fault; } ############################################################################### # # Sub Name: as_string # # Description: This is a fair bit more complex than the simple as_string # methods for the datatypes. Express the invoking object as # a well-formed XML document. # # Arguments: NAME IN/OUT TYPE DESCRIPTION # $self in ref Invoking object # $indent in scalar Indention level for output # # Returns: Success: text # Failure: undef # ############################################################################### sub as_string { my $self = shift; my $text; $RPC::XML::ERROR = q{}; $text = qq(); $text .= ''; if ($self->{value}->isa('RPC::XML::fault')) { $text .= $self->{value}->as_string; } else { $text .= '' . $self->{value}->as_string . ''; } $text .= ''; return $text; } # See the comment for serialize() above in RPC::XML::request sub serialize { my ($self, $fh) = @_; print {$fh} qq(); print {$fh} ''; if ($self->{value}->isa('RPC::XML::fault')) { # A fault lacks the params-boilerplate $self->{value}->serialize($fh); } else { print {$fh} ''; $self->{value}->serialize($fh); print {$fh} ''; } print {$fh} ''; return; } # Compared to base64, length-calculation here is pretty easy, much like struct sub length ## no critic (ProhibitBuiltinHomonyms) { my $self = shift; my $len = 66 + length $RPC::XML::ENCODING; # All the constant XML present # This boilerplate XML is only present when it is NOT a fault if (! $self->{value}->isa('RPC::XML::fault')) { $len += 47; } $len += $self->{value}->length; return $len; } 1; __END__ =head1 NAME RPC::XML - A set of classes for core data, message and XML handling =head1 SYNOPSIS use RPC::XML; $req = RPC::XML::request->new('fetch_prime_factors', RPC::XML::int->new(985_120_528)); ... $resp = RPC::XML::ParserFactory->new()->parse(STREAM); if (ref($resp)) { return $resp->value->value; } else { die $resp; } =head1 DESCRIPTION The B package is an implementation of the B standard. The package as a whole provides classes for data, for clients, for servers and for parsers (based on the L and L packages from CPAN). This module provides a set of classes for creating values to pass to the constructors for requests and responses. These are lightweight objects, most of which are implemented as blessed scalar references so as to associate specific type information with the value. Classes are also provided for requests, responses and faults (errors). This module does not actually provide any transport implementation or server basis. For these, see L and L, respectively. =head1 SUBROUTINES/METHODS At present, two subroutines are available for import. They must be explicitly imported as part of the C statement, or with a direct call to C: =over 4 =item time2iso8601([$time]) Convert the integer time value in C<$time> (which defaults to calling the built-in C