Initial Commit

This commit is contained in:
Riley Schneider
2025-12-03 16:38:10 +01:00
parent c5e26bf594
commit b732d8d4b5
17680 changed files with 5977495 additions and 2 deletions

View File

@@ -0,0 +1,79 @@
# ======================================================================
#
# Copyright (C) 2000-2004 Paul Kulchenko (paulclinger@yahoo.com)
#
# SOAP::Lite is free software; you can redistribute it
# and/or modify it under the same terms as Perl itself.
#
# ======================================================================
=pod
=head1 NAME
SOAP::Client - exists purely as a superclass for client classes declared by the various SOAP::Lite transport modules.
=head1 DESCRIPTION
The SOAP::Client class exists purely as a superclass for client classes
declared by the various SOAP::Lite transport modules. The methods it
provides are all simple accessors; they return the current value when
called with no arguments or set the attribute value and return the object
reference when called with an argument. These attributes include:
=head1 METHODS
=over
=item code, message, status
Stores the response code, message, and status from the most-recent send attempt. For some protocols, such as FTP, the same value is used for all three because of the lack of finer-grained detail (the default is to ensure that all three attributes contain data, even if redundant). Other protocols (such as HTTP) have distinct values in each.
=item endpoint
Identifies the current endpoint to which messages are being sent. This should match the value of the transport method from the L<SOAP::Transport> class, but setting this doesn't propagate to the transport object. It is better to use the transport object (or the shortcut via the SOAP::Lite object itself) when setting this.
=item is_success
The success or failure of the most-recent transmission is noted here as a boolean value.
=item options
The options attribute keeps a hash-table reference of additional options and their values. At present, only one option is used by any of the transport modules:
=over
=item compress_threshold
The value of this option should be a numerical value. If set, and if the Compress::Zlib library is available, messages whose size in bytes exceeds this value will be compressed before sending. Both ends of the conversation must have it enabled.
=back
Other options may be defined using this mechanism. Note that setting the options using this accessor requires a full hash reference be passed. To set just one or a few values, consider retrieving the current reference value and using it to set the key(s).
=back
=head1 SEE ALSO
L<SOAP::Server>
=head1 ACKNOWLEDGEMENTS
Special thanks to O'Reilly publishing which has graciously allowed SOAP::Lite to republish and redistribute large excerpts from I<Programming Web Services with Perl>, mainly the SOAP::Lite reference found in Appendix B.
=head1 COPYRIGHT
Copyright (C) 2000-2004 Paul Kulchenko. All rights reserved.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=head1 AUTHORS
Paul Kulchenko (paulclinger@yahoo.com)
Randy J. Ray (rjray@blackperl.com)
Byrne Reese (byrne@majordojo.com)
=cut

View File

@@ -0,0 +1,187 @@
# ======================================================================
#
# Copyright (C) 2000-2004 Paul Kulchenko (paulclinger@yahoo.com)
#
# SOAP::Lite is free software; you can redistribute it
# and/or modify it under the same terms as Perl itself.
#
# ======================================================================
package SOAP::Constants;
use strict;
use SOAP::Lite;
our $VERSION = '1.27'; # VERSION
use constant URI_1999_SCHEMA_XSD => "http://www.w3.org/1999/XMLSchema";
use constant URI_1999_SCHEMA_XSI => "http://www.w3.org/1999/XMLSchema-instance";
use constant URI_2000_SCHEMA_XSD => "http://www.w3.org/2000/10/XMLSchema";
use constant URI_2000_SCHEMA_XSI => "http://www.w3.org/2000/10/XMLSchema-instance";
use constant URI_2001_SCHEMA_XSD => "http://www.w3.org/2001/XMLSchema";
use constant URI_2001_SCHEMA_XSI => "http://www.w3.org/2001/XMLSchema-instance";
use constant URI_LITERAL_ENC => "";
use constant URI_SOAP11_ENC => "http://schemas.xmlsoap.org/soap/encoding/";
use constant URI_SOAP11_ENV => "http://schemas.xmlsoap.org/soap/envelope/";
use constant URI_SOAP11_NEXT_ACTOR => "http://schemas.xmlsoap.org/soap/actor/next";
use constant URI_SOAP12_ENC => "http://www.w3.org/2003/05/soap-encoding";
use constant URI_SOAP12_ENV => "http://www.w3.org/2003/05/soap-envelope";
use constant URI_SOAP12_NOENC => "http://www.w3.org/2003/05/soap-envelope/encoding/none";
use constant URI_SOAP12_NEXT_ACTOR => "http://www.w3.org/2003/05/soap-envelope/role/next";
use vars qw($NSMASK $ELMASK);
$NSMASK = '[a-zA-Z_:][\w.\-:]*';
$ELMASK = '^(?![xX][mM][lL])[a-zA-Z_][\w.\-]*$';
use vars qw($NEXT_ACTOR $NS_ENV $NS_ENC $NS_APS
$FAULT_CLIENT $FAULT_SERVER $FAULT_VERSION_MISMATCH
$HTTP_ON_FAULT_CODE $HTTP_ON_SUCCESS_CODE $FAULT_MUST_UNDERSTAND
$NS_XSI_ALL $NS_XSI_NILS %XML_SCHEMAS $DEFAULT_XML_SCHEMA
$DEFAULT_HTTP_CONTENT_TYPE
$SOAP_VERSION %SOAP_VERSIONS $WRONG_VERSION
$NS_SL_HEADER $NS_SL_PERLTYPE $PREFIX_ENV $PREFIX_ENC
$DO_NOT_USE_XML_PARSER $DO_NOT_CHECK_MUSTUNDERSTAND
$DO_NOT_USE_CHARSET $DO_NOT_PROCESS_XML_IN_MIME
$DO_NOT_USE_LWP_LENGTH_HACK $DO_NOT_CHECK_CONTENT_TYPE
$MAX_CONTENT_SIZE $PATCH_HTTP_KEEPALIVE $DEFAULT_PACKAGER
@SUPPORTED_ENCODING_STYLES $OBJS_BY_REF_KEEPALIVE
$DEFAULT_CACHE_TTL
%XML_SCHEMA_OF
$HAS_ENCODE
);
$FAULT_CLIENT = 'Client';
$FAULT_SERVER = 'Server';
$FAULT_VERSION_MISMATCH = 'VersionMismatch';
$FAULT_MUST_UNDERSTAND = 'MustUnderstand';
$HTTP_ON_SUCCESS_CODE = 200; # OK
$HTTP_ON_FAULT_CODE = 500; # INTERNAL_SERVER_ERROR
@SUPPORTED_ENCODING_STYLES = ( URI_LITERAL_ENC,URI_SOAP11_ENC,URI_SOAP12_ENC,URI_SOAP12_NOENC );
$WRONG_VERSION = 'Wrong SOAP version specified.';
$SOAP_VERSION = '1.1';
%SOAP_VERSIONS = (
1.1 => {
NEXT_ACTOR => URI_SOAP11_NEXT_ACTOR,
NS_ENV => URI_SOAP11_ENV,
NS_ENC => URI_SOAP11_ENC,
DEFAULT_XML_SCHEMA => URI_2001_SCHEMA_XSD,
DEFAULT_HTTP_CONTENT_TYPE => 'text/xml',
},
1.2 => {
NEXT_ACTOR => URI_SOAP12_NEXT_ACTOR,
NS_ENV => URI_SOAP12_ENV,
NS_ENC => URI_SOAP12_ENC,
DEFAULT_XML_SCHEMA => URI_2001_SCHEMA_XSD,
DEFAULT_HTTP_CONTENT_TYPE => 'application/soap+xml',
},
);
# schema namespaces
%XML_SCHEMAS = ( # The '()' is necessary to put constants in SCALAR form
URI_1999_SCHEMA_XSD() => 'SOAP::XMLSchema1999',
URI_2001_SCHEMA_XSD() => 'SOAP::XMLSchema2001',
URI_SOAP11_ENC() => 'SOAP::XMLSchemaSOAP1_1',
URI_SOAP12_ENC() => 'SOAP::XMLSchemaSOAP1_2',
);
# schema namespaces
%XML_SCHEMA_OF = ( # The '()' is necessary to put constants in SCALAR form
URI_1999_SCHEMA_XSD() => 'XMLSchema1999',
URI_2001_SCHEMA_XSD() => 'XMLSchema2001',
URI_SOAP11_ENC() => 'XMLSchemaSOAP1_1',
URI_SOAP12_ENC() => 'XMLSchemaSOAP1_2',
);
$NS_XSI_ALL = join join('|', map {"$_-instance"} grep {/XMLSchema/} keys %XML_SCHEMAS), '(?:', ')';
$NS_XSI_NILS = join join('|', map { my $class = $XML_SCHEMAS{$_} . '::Serializer'; "\{($_)-instance\}" . $class->nilValue
} grep {/XMLSchema/} keys %XML_SCHEMAS),
'(?:', ')';
# ApacheSOAP namespaces
$NS_APS = 'http://xml.apache.org/xml-soap';
# SOAP::Lite namespace
$NS_SL_HEADER = 'http://namespaces.soaplite.com/header';
$NS_SL_PERLTYPE = 'http://namespaces.soaplite.com/perl';
# default prefixes
$PREFIX_ENV = 'soap';
$PREFIX_ENC = 'soapenc';
# others
$DO_NOT_USE_XML_PARSER = 0;
$DO_NOT_CHECK_MUSTUNDERSTAND = 0;
$DO_NOT_USE_CHARSET = 0;
$DO_NOT_PROCESS_XML_IN_MIME = 0;
$DO_NOT_USE_LWP_LENGTH_HACK = 0;
$DO_NOT_CHECK_CONTENT_TYPE = 0;
$PATCH_HTTP_KEEPALIVE = 1;
$OBJS_BY_REF_KEEPALIVE = 600; # seconds
# TODO - use default packager constant somewhere
$DEFAULT_PACKAGER = "SOAP::Packager::MIME";
$DEFAULT_CACHE_TTL = 0;
$HAS_ENCODE = eval "require Encode; 1";
1;
__END__
=pod
=head1 NAME
SOAP::Constants - SOAP::Lite provides several variables to allows programmers and users to modify the behavior of SOAP::Lite in specific ways.
=head1 DESCRIPTION
A number of "constant" values are provided by means of this namespace. The values aren't constants in the strictest sense; the purpose of the values detailed here is to allow the application to change them if it desires to alter the specific behavior governed.
=head1 CONSTANTS
=head2 $DO_NOT_USE_XML_PARSER
The SOAP::Lite package attempts to locate and use the L<XML::Parser> package, falling back on an internal, pure-Perl parser in its absence. This package is a fast parser, based on the Expat parser developed by James Clark. If the application sets this value to 1, there will be no attempt to locate or use XML::Parser. There are several reasons you might choose to do this. If the package will never be made available, there is no reason to perform the test. Setting this parameter is less time-consuming than the test for the package would be. Also, the XML::Parser code links against the Expat libraries for the C language. In some environments, this could cause a problem when mixed with other applications that may be linked against a different version of the same libraries. This was once the case with certain combinations of Apache, mod_perl and XML::Parser.
=head2 $DO_NOT_USE_CHARSET
Unless this parameter is set to 1, outgoing Content-Type headers will include specification of the character set used in encoding the message itself. Not all endpoints (client or server) may be able to properly deal with that data on the content header, however. If dealing with an endpoint that expects to do a more literal examination of the header as whole (as opposed to fully parsing it), this parameter may prove useful.
=head2 $DO_NOT_CHECK_CONTENT_TYPE
The content-type itself for a SOAP message is rather clearly defined, and in most cases, an application would have no reason to disable the testing of that header. This having been said, the content-type for SOAP 1.2 is still only a recommended draft, and badly coded endpoints might send valid messages with invalid Content-Type headers. While the "right" thing to do would be to reject such messages, that isn't always an option. Setting this parameter to 1 allows the toolkit to skip the content-type test.
=head2 $PATCH_HTTP_KEEPALIVE
SOAP::Lite's HTTP Transport module attempts to provide a simple patch to
LWP::Protocol to enable HTTP Keep Alive. By default, this patch is turned
off, if however you would like to turn on the experimental patch change the
constant like so:
$SOAP::Constants::PATCH_HTTP_KEEPALIVE = 1;
=head1 ACKNOWLEDGEMENTS
Special thanks to O'Reilly publishing which has graciously allowed SOAP::Lite to republish and redistribute large excerpts from I<Programming Web Services with Perl>, mainly the SOAP::Lite reference found in Appendix B.
=head1 COPYRIGHT
Copyright (C) 2000-2004 Paul Kulchenko. All rights reserved.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=head1 AUTHORS
Paul Kulchenko (paulclinger@yahoo.com)
Randy J. Ray (rjray@blackperl.com)
Byrne Reese (byrne@majordojo.com)
=cut

237
database/perl/vendor/lib/SOAP/Data.pod vendored Normal file
View File

@@ -0,0 +1,237 @@
# ======================================================================
#
# Copyright (C) 2000-2003 Paul Kulchenko (paulclinger@yahoo.com)
# SOAP::Lite is free software; you can redistribute it
# and/or modify it under the same terms as Perl itself.
#
# ======================================================================
=pod
=head1 NAME
SOAP::Data - this class provides the means by which to explicitly manipulate and control all aspects of the way in which Perl data gets expressed as SOAP data entities.
=head1 DESCRIPTION
The SOAP::Data class provides the means by which to explicitly manipulate and control all aspects of the way in which Perl data gets expressed as SOAP data entities. Most of the methods are accessors, which like those in SOAP::Lite are designed to return the current value if no new one is passed, while returning the object reference otherwise (allowing for chained method calls). Note that most accessors (except value) accept a new value for the data object as a second argument.
=head1 METHODS
=over
=item new(optional key/value pairs)
$obj = SOAP::Data->new(name => 'idx', value => 5);
This is the class constructor. Almost all of the attributes related to the class may be passed to the constructor as key/value pairs. This method isn't often used directly because SOAP::Data objects are generally created for temporary use. It is available for those situations that require it.
=item name(new name, optional value)
$obj->name('index');
Gets or sets the current value of the name, as the object regards it. The name is what the serializer will use for the tag when generating the XML for this object. It is what will become the accessor for the data element. Optionally, the object's value may be updated if passed as a second argument.
=item type(new type, optional value)
$obj->type('int');
Gets or sets the type associated with the current value in the object. This is useful for those cases where the SOAP::Data object is used to explicitly specify the type of data that would otherwise be interpreted as a different type completely (such as perceiving the string 123 as an integer, instead). Allows the setting of the object's value, if passed as a second argument to the method.
=item uri(new uri, optional value)
$obj->uri('http://www.perl.com/SOAP');
Gets or sets the URI that will be used as the namespace for the resulting XML entity, if one is desired. This doesn't set the label for the namespace. If one isn't provided by means of the prefix method, one is generated automatically when needed. Also allows the setting of the object's value, if passed as a second argument to the method.
=item prefix(new prefix, optional value)
$obj->prefix('perl');
Provides the prefix, or label, for use when associating the data object with a specific namespace. Also allows the setting of the object's value, if passed as a second argument to the method.
=item attr(hash reference of attributes, optional value)
$obj->attr({ attr1 => 'value' });
Allows for the setting of arbitrary attributes on the data object. Keep in mind the requirement that any attributes not natively known to SOAP must be namespace-qualified. Also allows the setting of the object's value, if passed as a second argument to the method.
=item value(new value)
$obj->value(10);
Fetches the current value encapsulated by the object, or explicitly sets it.
=back
The last four methods are convenience shortcuts for the attributes that SOAP itself supports. Each also permits inclusion of a new value, as an optional second argument.
=over
=item actor(new actor, optional value)
$obj->actor($new_actor_name);
Gets or sets the value of the actor attribute; useful only when the object generates an entity for the message header.
=item mustUnderstand(boolean, optional value)
$obj->mustUnderstand(0);
Manipulates the mustUnderstand attribute, which tells the SOAP processor whether it is required to understand the entity in question.
=item encodingStyle(new encoding URN, optional value)
$obj->encodingStyle($soap_11_encoding);
This method is most likely to be used in places outside the header creation. Sets encodingStyle, which specifies an encoding that differs from the one that would otherwise be defaulted to.
=item root(boolean, optional value)
$obj->root(1);
When the application must explicitly specify which data element is to be regarded as the root element for the sake of generating the object model, this method provides the access to the root attribute.
=back
=head1 TYPE DETECTION
SOAP::Lite's serializer will detect the type of any scalar passed in as a SOAP::Data object's value. Because Perl is loosely typed, the serializer is only able to detect types based upon a predetermined set of regular expressions. Therefore, type detection is not always 100% accurate. In such a case you may need to explicitly set the type of the element being encoded. For example, by default the following code will be serialized as an integer:
$elem = SOAP::Data->name('idx')->value(5);
If, however, you need to serialize this into a long, then the following code will do so:
$elem = SOAP::Data->name('idx')->value(5)->type('long');
=head1 EXAMPLES
=head2 SIMPLE TYPES
The following example will all produce the same XML:
$elem1 = SOAP::Data->new(name => 'idx', value => 5);
$elem2 = SOAP::Data->name('idx' => 5);
$elem3 = SOAP::Data->name('idx')->value(5);
=head2 COMPLEX TYPES
A common question is how to do you created nested XML elements using SOAP::Lite. The following example demonstrates how:
SOAP::Data->name('foo' => \SOAP::Data->value(
SOAP::Data->name('bar' => '123')));
The above code will produce the following XML:
<foo>
<bar>123</bar>
</foo>
=head2 ARRAYS
The following code:
$elem1 = SOAP::Data->name('item' => 123)->type('SomeObject');
$elem2 = SOAP::Data->name('item' => 456)->type('SomeObject');
push(@array,$elem1);
push(@array,$elem2);
my $client = SOAP::Lite
->readable(1)
->uri($NS)
->proxy($HOST);
$temp_elements = SOAP::Data
->name("CallDetails" => \SOAP::Data->value(
SOAP::Data->name("elem1" => 'foo'),
SOAP::Data->name("elem2" => 'baz'),
SOAP::Data->name("someArray" => \SOAP::Data->value(
SOAP::Data->name("someArrayItem" => @array)
->type("SomeObject"))
)->type("ArrayOf_SomeObject") ))
->type("SomeObject");
$response = $client->someMethod($temp_elements);
Will produce the following XML:
<?xml version="1.0" encoding="UTF-8"?>
<SOAP-ENV:Envelope
xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"
xmlns:SOAP-ENC="http://schemas.xmlsoap.org/soap/encoding/"
xmlns:SOAP-ENV="http://schemas.xmlsoap.org/soap/envelope/"
xmlns:xsd="http://www.w3.org/2001/XMLSchema"
xmlns:namesp2="http://namespaces.soaplite.com/perl"
SOAP-ENV:encodingStyle="http://schemas.xmlsoap.org/soap/encoding/">
<SOAP-ENV:Body>
<namesp1:someMethod xmlns:namesp1="urn:TemperatureService">
<CallDetails xsi:type="namesp2:SomeObject">
<elem1 xsi:type="xsd:string">foo</elem1>
<elem2 xsi:type="xsd:string">baz</elem2>
<someArray xsi:type="namesp2:ArrayOf_SomeObject">
<item xsi:type="namesp2:SomeObject">123</bar>
<item xsi:type="namesp2:SomeObject">456</bar>
</someArray>
</CallDetails>
</namesp1:test>
</SOAP-ENV:Body>
</SOAP-ENV:Envelope>
In the code above, the @array variable can be an array of anything. If you pass
in an array of numbers, then SOAP::Lite will properly serialize that into such.
If however you need to encode an array of complex types, then simply pass in an
array of other SOAP::Data objects and you are all set.
=head2 COMPOSING MESSAGES USING RAW XML
In some circumstances you may need to encode a message using raw unserialized
XML text. To instantiate a SOAP::Data object using raw XML, do the following:
$xml_content = "<foo><bar>123</bar></foo>";
$elem = SOAP::Data->type('xml' => $xml_content);
SOAP::Lite's serializer simple takes whatever text is passed to it, and inserts
into the encoded SOAP::Data element I<verbatim>. The text input is NOT validated to
ensure it is valid XML, nor is the resulting SOAP::Data element validated to
ensure that it will produce valid XML. Therefore, it is incumbent upon the
developer to ensure that any XML data used in this fashion is valid and will
result in a valid XML document.
=head2 MULTIPLE NAMESPACES
When working with complex types it may be necessary to declare multiple namespaces. The following code demonstrates how to do so:
$elem = SOAP::Data->name("myElement" => "myValue")
->attr( { 'xmlns:foo2' => 'urn:Foo2',
'xmlns:foo3' => 'urn:Foo3' } );
This will produce the following XML:
<myElement xmlns:foo2="urn:Foo2" xmlns:foo3="urn:Foo3">myValue</myElement>
=head1 SEE ALSO
L<SOAP::Header>, L<SOAP::SOM>, L<SOAP::Serializer>
=head1 ACKNOWLEDGEMENTS
Special thanks to O'Reilly publishing which has graciously allowed SOAP::Lite to republish and redistribute large excerpts from I<Programming Web Services with Perl>, mainly the SOAP::Lite reference found in Appendix B.
=head1 COPYRIGHT
Copyright (C) 2000-2004 Paul Kulchenko. All rights reserved.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=head1 AUTHORS
Paul Kulchenko (paulclinger@yahoo.com)
Randy J. Ray (rjray@blackperl.com)
Byrne Reese (byrne@majordojo.com)
=cut

View File

@@ -0,0 +1,63 @@
# ======================================================================
#
# Copyright (C) 2000-2004 Paul Kulchenko (paulclinger@yahoo.com)
# SOAP::Lite is free software; you can redistribute it
# and/or modify it under the same terms as Perl itself.
#
# ======================================================================
=pod
=head1 NAME
SOAP::Deserializer - the means by which the toolkit manages the conversion of XML into an object manageable by a developer
=head1 DESCRIPTION
SOAP::Deserializer provides the means by which incoming XML is decoded into a Perl data structure.
=head1 METHODS
=over
=item context
This provides access to the calling context of C<SOAP::Deserializer>. In a client side context the often means a reference to an instance of SOAP::Lite. In a server side context this means a reference to a SOAP::Server instance.
=back
=head1 EXAMPLES
=head2 DESERIALIZING RAW XML INTO A SOAP::SOM OBJECT
A useful utility for SOAP::Deserializer is for parsing raw XML documents or fragments into a SOAP::SOM object. SOAP::Lite developers use this technique to write unit tests for the SOAP::Lite module itself. It is a lot more efficient for testing aspects of the toolkit than generating client calls over the network. This is a perfect way for developers to write unit tests for their custom data types for example.
Here is an example of how raw XML content can be parsed into a SOAP::SOM object by using SOAP::Deserializer:
$xml = <<END_XML;
<foo>
<person>
<foo>123</foo>
<foo>456</foo>
</person>
<person>
<foo>789</foo>
<foo>012</foo>
</person>
</foo>
END_XML
my $som = SOAP::Deserializer->deserialize($xml);
=head1 COPYRIGHT
Copyright (C) 2000-2004 Paul Kulchenko. All rights reserved.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=head1 AUTHORS
Byrne Reese (byrne@majordojo.com)
=cut

89
database/perl/vendor/lib/SOAP/Fault.pod vendored Normal file
View File

@@ -0,0 +1,89 @@
# ======================================================================
#
# Copyright (C) 2000-2003 Paul Kulchenko (paulclinger@yahoo.com)
# SOAP::Lite is free software; you can redistribute it
# and/or modify it under the same terms as Perl itself.
#
# ======================================================================
=pod
=head1 NAME
SOAP::Fault - encapsulates SOAP faults prior to their serialization or after their deserialization
=head1 DESCRIPTION
This class encapsulates SOAP faults prior to their serialization or after their deserialization. The methods available are a constructor and four accessors. Each accessor creates an object on demand, just as the other classes do, when called as a static method. Like other accessors in the SOAP::Lite package, they return the object itself when setting the attribute.
=head1 GENERATING A SOAP FAULT
To generate a SOAP Fault simply issue a Perl die command on the server side as you might normally. The SOAP processor will intercept the die command and return a SOAP Fault, using the string passed to the die command as the faultstring, to the client making the call. If you require having more control over the SOAP Fault returned to the client, then simply pass a SOAP::Fault object to the die command and the SOAP processor will behave accordingly. For example:
die SOAP::Fault->faultcode('Server.Custom') # will be qualified
->faultstring('Died in server method')
->faultdetail(bless {code => 1} => 'BadError')
->faultactor('http://www.soaplite.com/custom');
=head1 METHODS
=over
=item new(optional data)
$fault = SOAP::Fault->new(faultcode => 'Server');
Explicitly creates a new SOAP::Fault object. Any of the four attributes represented next by accessor methods may be passed in the argument list with values immediately following their attribute name.
=item faultcode(optional value)
$fault->faultcode('MethodUnknown');
Returns the current fault code or sets it if a value is given.
=item faultstring(optional value)
$fault->faultstring("There is no $method here");
Returns or sets the fault string.
=item faultactor(optional value)
$fault->faultcode($header->actor);
Returns or sets the fault-actor element. Note that the actor isn't always required in a SOAP fault.
=item faultdetail(optional value)
$fault->faultcode(bless { proxy => $ip }, 'Err');
Returns or sets the fault's detail element. Like the actor, this isn't always a required element. Note that fault detail content in a message is represented as tag blocks. Thus, the values passed to this accessor when setting the value are either SOAP::Data objects, or more general blessed hash references.
=back
In addition to these methods, the SOAP::Fault package also provides detail as an alias for faultdetail. The former is the actual name of the element with SOAP faults, but the latter name is less ambiguous when regarded with the rest of the SOAP::Lite package. Objects of this class also have a special stringification enabled. If an object is printed or otherwise stringified, the value produced is faultcode: faultstring, with the attribute values of the object.
=head1 SEE ALSO
L<SOAP::Data>, L<SOAP::Header>, L<SOAP::SOM>
=head1 ACKNOWLEDGEMENTS
Special thanks to O'Reilly publishing which has graciously allowed SOAP::Lite to republish and redistribute large excerpts from I<Programming Web Services with Perl>, mainly the SOAP::Lite reference found in Appendix B.
=head1 COPYRIGHT
Copyright (C) 2000-2004 Paul Kulchenko. All rights reserved.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=head1 AUTHORS
Paul Kulchenko (paulclinger@yahoo.com)
Randy J. Ray (rjray@blackperl.com)
Byrne Reese (byrne@majordojo.com)
=cut

View File

@@ -0,0 +1,43 @@
# ======================================================================
#
# Copyright (C) 2000-2003 Paul Kulchenko (paulclinger@yahoo.com)
# SOAP::Lite is free software; you can redistribute it
# and/or modify it under the same terms as Perl itself.
#
# ======================================================================
=pod
=head1 NAME
SOAP::Header - similar to SOAP::Data elements, a SOAP::Header object simply is encoded in the SOAP Header block
=head1 DESCRIPTION
Objects instantiated from the SOAP::Header class are functionally the same as SOAP::Data objects, and as such share all the methods from that class. The distinction may be cosmetic, but it is present so that applications may more easily distinguish header blocks from more generic data elements.
=head1 SEE ALSO
L<SOAP::Data>
=head1 ACKNOWLEDGEMENTS
Special thanks to O'Reilly publishing which has graciously allowed SOAP::Lite to republish and redistribute large excerpts from I<Programming Web Services with Perl>, mainly the SOAP::Lite reference found in Appendix B.
=head1 COPYRIGHT
Copyright (C) 2000-2004 Paul Kulchenko. All rights reserved.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=head1 AUTHORS
Paul Kulchenko (paulclinger@yahoo.com)
Randy J. Ray (rjray@blackperl.com)
Byrne Reese (byrne@majordojo.com)
=cut

5765
database/perl/vendor/lib/SOAP/Lite.pm vendored Normal file

File diff suppressed because it is too large Load Diff

View File

@@ -0,0 +1,48 @@
package SOAP::Lite::Deserializer::XMLSchema1999;
use strict;
our $VERSION = '1.27'; # VERSION
use SOAP::Lite::Deserializer::XMLSchemaSOAP1_1;
sub anyTypeValue { 'ur-type' }
# use as_string and as_boolean from SOAP1_1 Deserializer
sub as_string; *as_string = \&SOAP::Lite::Deserializer::XMLSchemaSOAP1_1::as_string;
sub as_boolean; *as_boolean = \&SOAP::Lite::Deserializer::XMLSchemaSOAP1_1::as_boolean;
sub as_hex {
shift;
my $value = shift;
$value =~ s/([a-zA-Z0-9]{2})/chr oct '0x'.$1/ge;
$value
}
sub as_ur_type { $_[1] }
sub as_undef {
shift;
my $value = shift;
$value eq '1' || $value eq 'true'
? 1
: $value eq '0' || $value eq 'false'
? 0
: die "Wrong null/nil value '$value'\n";
}
BEGIN {
no strict 'refs';
for my $method (qw(
float double decimal timeDuration recurringDuration uriReference
integer nonPositiveInteger negativeInteger long int short byte
nonNegativeInteger unsignedLong unsignedInt unsignedShort unsignedByte
positiveInteger timeInstant time timePeriod date month year century
recurringDate recurringDay language
)) {
my $name = 'as_' . $method;
*$name = sub { $_[1] };
}
}
1;

View File

@@ -0,0 +1,34 @@
package SOAP::Lite::Deserializer::XMLSchema2001;
use strict;
our $VERSION = '1.27'; # VERSION
use SOAP::Lite::Deserializer::XMLSchema1999;
use SOAP::Lite::Deserializer::XMLSchemaSOAP1_1;
use SOAP::Lite::Deserializer::XMLSchemaSOAP1_2;
sub anyTypeValue { 'anyType' }
sub as_string; *as_string = \&SOAP::Lite::Deserializer::XMLSchema1999::as_string;
sub as_anyURI; *as_anyURI = \&SOAP::Lite::Deserializer::XMLSchemaSOAP1_1::as_anyURI;
sub as_boolean; *as_boolean = \&SOAP::Lite::Deserializer::XMLSchemaSOAP1_2::as_boolean;
sub as_base64Binary; *as_base64Binary = \&SOAP::Lite::Deserializer::XMLSchemaSOAP1_2::as_base64;
sub as_hexBinary; *as_hexBinary = \&SOAP::Lite::Deserializer::XMLSchema1999::as_hex;
sub as_undef; *as_undef = \&SOAP::Lite::Deserializer::XMLSchema1999::as_undef;
BEGIN {
no strict 'refs';
for my $method (qw(
anyType anySimpleType
float double decimal dateTime timePeriod gMonth gYearMonth gYear
century gMonthDay gDay duration recurringDuration
language integer nonPositiveInteger negativeInteger long int short
byte nonNegativeInteger unsignedLong unsignedInt unsignedShort
unsignedByte positiveInteger date time QName
)) {
my $name = 'as_' . $method;
*$name = sub { $_[1] }
}
}
1;

View File

@@ -0,0 +1,35 @@
package SOAP::Lite::Deserializer::XMLSchemaSOAP1_1;
use strict;
our $VERSION = '1.27'; # VERSION
sub anyTypeValue { 'ur-type' }
sub as_boolean {
shift;
my $value = shift;
$value eq '1' || $value eq 'true'
? 1
: $value eq '0' || $value eq 'false'
? 0
: die "Wrong boolean value '$value'\n"
}
sub as_base64 { shift; require MIME::Base64; MIME::Base64::decode_base64(shift) }
sub as_ur_type { $_[1] }
sub as_anyURI { $_[1] }
BEGIN {
no strict 'refs';
for my $method (qw(
string float double decimal timeDuration recurringDuration uriReference
integer nonPositiveInteger negativeInteger long int short byte
nonNegativeInteger unsignedLong unsignedInt unsignedShort unsignedByte
positiveInteger timeInstant time timePeriod date month year century
recurringDate recurringDay language
)) { my $name = 'as_' . $method; *$name = sub { $_[1] } }
}
1;

View File

@@ -0,0 +1,28 @@
package SOAP::Lite::Deserializer::XMLSchemaSOAP1_2;
use strict;
our $VERSION = '1.27'; # VERSION
use SOAP::Lite::Deserializer::XMLSchemaSOAP1_1;
sub anyTypeValue { 'anyType' }
sub as_boolean; *as_boolean = \&SOAP::Lite::Deserializer::XMLSchemaSOAP1_1::as_boolean;
sub as_base64 { shift; require MIME::Base64; MIME::Base64::decode_base64(shift) }
BEGIN {
no strict 'refs';
for my $method (qw(
anyType
string float double decimal dateTime timePeriod gMonth gYearMonth gYear
century gMonthDay gDay duration recurringDuration anyURI
language integer nonPositiveInteger negativeInteger long int short byte
nonNegativeInteger unsignedLong unsignedInt unsignedShort unsignedByte
positiveInteger date time
)) {
my $name = 'as_' . $method;
*$name = sub { $_[1] };
}
}
1;

View File

@@ -0,0 +1,562 @@
# ======================================================================
#
# Copyright (C) 2000-2004 Paul Kulchenko (paulclinger@yahoo.com)
# SOAP::Lite is free software; you can redistribute it
# and/or modify it under the same terms as Perl itself.
#
# ======================================================================
package SOAP::Lite::Packager;
use strict;
our $VERSION = '1.27'; # VERSION
use vars;
use vars qw($SUPPORTED_TYPES);
$SUPPORTED_TYPES = { };
sub BEGIN {
no strict 'refs';
for my $method ( qw(parser headers_http persist_parts) ) {
my $field = '_' . $method;
*$method = sub {
my $self = shift;
if (@_) {
$self->{$field} = shift;
return $self
}
return $self->{$field};
}
}
}
sub new {
my($class) = shift;
my(%params) = @_;
bless {
"_parts" => [ ],
"_parser" => undef,
"_persist_parts" => 0,
}, $class;
}
sub is_supported_part {
my $self = shift;
return $SUPPORTED_TYPES->{ref $_[0]};
}
sub parts {
my $self = shift;
if (@_) {
$self->{'_parts'} = shift;
}
return $self->{'_parts'};
}
# This is a static method that helps find the right Packager
sub find_packager {
# TODO - Input:
# * the mimetype of the data to be decoded raw data that needs
# * the data to be decoded
# Returns:
# * the proper SOAP::Lite::Packager instance
}
sub push_part {
my $self = shift;
my ($part) = @_;
push @{$self->{'_parts'}}, $part;
}
sub package {
# do nothing
die "SOAP::Lite::Packager::package() must be implemented";
}
sub unpackage {
my $self = shift;
$self->{'_parts'} = [] if !$self->persist_parts; # experimental
}
# ======================================================================
package SOAP::Lite::Packager::MIME;
use strict;
use vars qw(@ISA);
@ISA = qw(SOAP::Lite::Packager);
sub BEGIN {
no strict 'refs';
for my $method ( qw(transfer_encoding env_id env_location) ) {
my $field = '_' . $method;
*$method = sub {
my $self = shift;
if (@_) {
$self->{$field} = shift;
return $self
}
return $self->{$field};
}
}
}
sub new {
my ($classname) = @_;
my $self = SOAP::Lite::Packager::new(@_);
$self->{'_content_encoding'} = '8bit';
$self->{'_env_id'} = '<main_envelope>';
$self->{'_env_location'} = '/main_envelope';
bless $self, $classname;
$SOAP::Lite::Packager::SUPPORTED_TYPES->{"MIME::Entity"} = 1;
return $self;
}
sub initialize_parser {
my $self = shift;
eval "require MIME::Parser;";
die "Could not find MIME::Parser - is MIME::Tools installed? Aborting." if $@;
$self->{'_parser'} = MIME::Parser->new;
$self->{'_parser'}->output_to_core('ALL');
$self->{'_parser'}->tmp_to_core(1);
$self->{'_parser'}->ignore_errors(1);
$self->{'_parser'}->extract_nested_messages(0);
}
sub generate_random_string {
my ($self,$len) = @_;
my @chars=('a'..'z','A'..'Z','0'..'9','_');
my $random_string;
foreach (1..$len) {
$random_string .= $chars[rand @chars];
}
return $random_string;
}
sub get_multipart_id {
my ($id) = shift;
($id || '') =~ /^<?([^>]+)>?$/; $1 || '';
}
sub package {
my $self = shift;
my ($envelope,$context) = @_;
return $envelope if (!$self->parts); # if there are no parts,
# then there is nothing to do
require MIME::Entity;
local $MIME::Entity::BOUNDARY_DELIMITER = "\r\n";
my $top = MIME::Entity->build('Type' => "Multipart/Related");
my $soapversion = defined($context) ? $context->soapversion : '1.1';
$top->attach('Type' => $soapversion == 1.1 ? "text/xml" : "application/soap+xml",
'Content-Transfer-Encoding' => $self->transfer_encoding(),
'Content-Location' => $self->env_location(),
'Content-ID' => $self->env_id(),
'Data' => $envelope );
# consume the attachments that come in as input by 'shift'ing
no strict 'refs';
while (my $part = shift(@{$self->parts})) {
$top->add_part($part);
}
# determine MIME boundary
my $boundary = $top->head->multipart_boundary;
$self->headers_http({ 'Content-Type' => 'Multipart/Related; type="text/xml"; start="<main_envelope>"; boundary="'.$boundary.'"'});
return $top->stringify_body;
}
sub unpackage {
my $self = shift;
my ($raw_input,$context) = @_;
$self->SUPER::unpackage();
# Parse the raw input into a MIME::Entity structure.
# - fail if the raw_input is not MIME formatted
$self->initialize_parser() if !defined($self->parser);
my $entity = eval { $self->parser->parse_data($raw_input) }
or die "Something wrong with MIME message: @{[$@ || $self->parser->last_error]}\n";
my $env = undef;
# major memory bloat below! TODO - fix!
if (lc($entity->head->mime_type) eq 'multipart/form-data') {
$env = $self->process_form_data($entity);
}
elsif (lc($entity->head->mime_type) eq 'multipart/related') {
$env = $self->process_related($entity);
}
elsif (lc($entity->head->mime_type) eq 'text/xml') {
# I don't think this ever gets called.
# warn "I am somewhere in the SOAP::Lite::Packager::MIME code I didn't know I would be in!";
$env = $entity->bodyhandle->as_string;
}
else {
die "Can't handle MIME messsage with specified type (@{[$entity->head->mime_type]})\n";
}
# return the envelope
if ($env) {
return $env;
}
elsif ($entity->bodyhandle->as_string) {
return $entity->bodyhandle->as_string;
}
else {
die "No content in MIME message\n";
}
}
sub process_form_data {
my ($self, $entity) = @_;
my $env = undef;
foreach my $part ($entity->parts()) {
my $name = $part->head()->mime_attr('content-disposition.name');
$name eq 'payload' ?
$env = $part->bodyhandle()->as_string()
: $self->push_part($part);
}
return $env;
}
sub process_related {
my $self = shift;
my ($entity) = @_;
die "Multipart MIME messages MUST declare Multipart/Related content-type"
if ($entity->head->mime_attr('content-type') !~ /^multipart\/related/i);
# As it turns out, the Content-ID and start parameters are optional
# according to the MIME and SOAP specs. In the event that the head cannot
# be found, the head/root entity is used as a starting point.
my $start = get_multipart_id($entity->head->mime_attr('content-type.start'));
if (!defined($start) || $start eq "") {
$start = $self->generate_random_string(10);
$entity->parts(0)->head->add('content-id',$start);
}
my $location = $entity->head->mime_attr('content-location')
|| 'thismessage:/';
my $env;
foreach my $part ($entity->parts) {
next if !UNIVERSAL::isa($part => "MIME::Entity");
# Weird, the following use of head->get(SCALAR[,INDEX]) doesn't work as
# expected. Work around is to eliminate the INDEX.
my $pid = get_multipart_id($part->head->mime_attr('content-id'));
# If Content-ID is not supplied, then generate a random one (HACK - because
# MIME::Entity does not do this as it should... content-id is required
# according to MIME specification)
$pid = $self->generate_random_string(10) if $pid eq '';
my $type = $part->head->mime_type;
# If a Content-Location header cannot be found, this will look for an
# alternative in the following MIME Header attributes
my $plocation = $part->head->get('content-location')
|| $part->head->mime_attr('Content-Disposition.filename')
|| $part->head->mime_attr('Content-Type.name');
if ($start && $pid eq $start) {
$env = $part->bodyhandle->as_string;
}
else {
$self->push_part($part) if (defined($part->bodyhandle));
}
}
return $env;
}
# ======================================================================
package SOAP::Lite::Packager::DIME;
use strict;
use vars qw(@ISA);
@ISA = qw(SOAP::Lite::Packager);
sub BEGIN {
no strict 'refs';
for my $method ( qw(foo) ) {
my $field = '_' . $method;
*$method = sub {
my $self = shift;
if (@_) { $self->{$field} = shift; return $self }
return $self->{$field};
}
}
}
sub new {
my ($classname) = @_;
my $self = SOAP::Lite::Packager::new(@_);
bless $self, $classname;
$SOAP::Lite::Packager::SUPPORTED_TYPES->{"DIME::Payload"} = 1;
return $self;
}
sub initialize_parser {
my $self = shift;
print STDERR "Initializing parser\n";
eval "require DIME::Parser;";
die "Could not find DIME::Parser - is DIME::Tools installed? Aborting." if $@;
$self->{'_parser'} = DIME::Parser->new;
}
sub package {
my $self = shift;
my ($envelope,$context) = @_;
return $envelope if (!$self->parts); # if there are no parts,
# then there is nothing to do
require DIME::Message;
require DIME::Payload;
my $message = DIME::Message->new;
my $top = DIME::Payload->new;
my $soapversion = defined($context) ? $context->soapversion : '1.1';
$top->attach('MIMEType' => $soapversion == 1.1 ?
"http://schemas.xmlsoap.org/soap/envelope/" : "application/soap+xml",
'Data' => $envelope );
$message->add_payload($top);
# consume the attachments that come in as input by 'shift'ing
no strict 'refs';
while (my $part = shift(@{$self->parts})) {
die "You are only allowed to add parts of type DIME::Payload to a DIME::Message"
if (!$part->isa('DIME::Payload'));
# print STDERR "Adding payload to DIME message: ".ref($part)."\n";
$message->add_payload($part);
# print STDERR "Payload's payload is: ".${$part->print_content_data}."\n";
}
$self->headers_http({ 'Content-Type' => 'application/dime' });
return $message->print_data;
}
sub unpackage {
my $self = shift;
my ($raw_input,$context) = @_;
$self->SUPER::unpackage();
# Parse the raw input into a DIME::Message structure.
# - fail if the raw_input is not DIME formatted
print STDERR "raw_data: $raw_input\n";
$self->initialize_parser() if !defined($self->parser);
my $message = eval { $self->parser->parse_data(\$raw_input) }
or die "Something wrong with DIME message: @{[$@]}\n";
# The first payload is always the SOAP Message
# TODO - Error check
my @payloads = @{$message->{'_PAYLOADS'}};
my $env = shift(@payloads);
my $env_str = $env->print_content_data;
print STDERR "Received this envelope: ".$env_str."\n";
while (my $p = shift(@payloads)) {
print STDERR "Adding part to Packager\n";
$self->push_part($p);
}
return $env_str;
}
1;
__END__
=pod
=head1 NAME
SOAP::Lite::Packager - this class is an abstract class which allows for multiple types of packaging agents such as MIME and DIME.
=head1 DESCRIPTION
The SOAP::Lite::Packager class is responsible for managing a set of "parts." Parts are
additional pieces of information, additional documents, or virtually anything that
needs to be associated with the SOAP Envelope/payload. The packager then will take
these parts and encode/decode or "package"/"unpackage" them as they come and go
over the wire.
=head1 METHODS
=over
=item new
Instantiates a new instance of a SOAP::Lite::Packager.
=item parts
Contains an array of parts. The contents of this array and their types are completely
dependent upon the Packager being used. For example, when using MIME, the content
of this array is MIME::Entity's.
=item push_part
Adds a part to set of parts managed by the current instance of SOAP::Lite::Packager.
=item parser
Returns the parser used to parse attachments out of a data stream.
=item headers_http
This is a hook into the HTTP layer. It provides a way for a packager to add and/or modify
HTTP headers in a request/response. For example, most packaging layers will need to
override the Content-Type (e.g. multipart/related, or application/dime).
=back
=head1 ABSTRACT METHODS
If you wish to implement your own SOAP::Lite::Packager, then the methods below must be
implemented by you according to the prescribed input and output requirements.
=over
=item package()
The C<package> subroutine takes as input the SOAP envelope in string/SCALAR form.
This will serve as the content of the root part. The packager then encapsulates the
envelope with the parts contained within C<parts> and returns the properly
encapsulated envelope in string/SCALAR form.
=item unpackage()
The C<unpackage> subroutines takes as input raw data that needs to be parsed into
a set of parts. It is responsible for extracting the envelope from the input, and
populating C<parts> with an ARRAY of parts extracted from the input. It then returns
the SOAP Envelope in string/SCALAR form so that SOAP::Lite can parse it.
=back
=head1 SUPPORTED PACKAGING FORMATS
=head2 SOAP::Lite::Packager::MIME
C<SOAP::Lite::Packager::MIME> utilizes L<MIME::Tools> to provides the ability to send
and receive Multipart/Related and Multipart/Form-Data formatted requests and
responses.
=head3 MIME METHODS
The following methods are used when composing a MIME formatted message.
=over
=item transfer_encoding
The value of the root part's Content-Transfer-Encoding MIME Header. Default is: 8bit.
=item env_id
The value of the root part's Content-Id MIME Header. Default is: <main_envelope>.
=item env_location
The value of the root part's Content-Location MIME Header. Default is: /main_envelope.
=item env_type
The value of the root part's Content-Type MIME Header. Default is: text/xml.
=back
=head3 OPTIMIZING THE MIME PARSER
The use of attachments can often result in a heavy drain on system resources depending
upon how your MIME parser is configured. For example, you can instruct the parser to
store attachments in memory, or to use temp files. Using one of the other can affect
performance, disk utilization, and/or reliability. Therefore you should consult the
following URL for optimization techniques and trade-offs:
http://search.cpan.org/dist/MIME-tools/lib/MIME/Parser.pm#OPTIMIZING_YOUR_PARSER
To modify the parser's configuration options consult the following code sample,
which incidentally shows how to minimize memory utilization:
my $packager = SOAP::Lite::Packager::MIME->new;
# $packager->parser->decode_headers(1); # no difference
# $packager->parser->extract_nested_messages(1); # no difference
$packager->parser->output_to_core(0); # much less memory
$packager->parser->tmp_to_core(0); # much less memory
$packager->parser->tmp_recycling(0); # promotes faster garbage collection
$packager->parser->use_inner_files(1); # no difference
my $client = SOAP::Lite->uri($NS)->proxy($URL)->packager($packager);
$client->someMethod();
=head3 CLIENT SIDE EXAMPLE
The following code sample shows how to use attachments within the context of a
SOAP::Lite client.
#!/usr/bin/perl
use SOAP::Lite;
use MIME::Entity;
my $ent = build MIME::Entity
Type => "text/plain",
Path => "attachment.txt",
Filename => "attachment.txt",
Disposition => "attachment";
$NS = "urn:Majordojo:TemperatureService";
$HOST = "http://localhost/cgi-bin/soaplite.cgi";
my $client = SOAP::Lite
->packager(SOAP::Lite::Packager::MIME->new)
->parts([ $ent ])
->uri($NS)
->proxy($HOST);
$response = $client->c2f(SOAP::Data->name("temperature" => '100'));
print $response->valueof('//c2fResponse/foo');
=head3 SERVER SIDE EXAMPLE
The following code shows how to use attachments within the context of a CGI
script. It shows how to read incoming attachments, and to return attachments to
the client.
#!/usr/bin/perl -w
use SOAP::Transport::HTTP;
use MIME::Entity;
SOAP::Transport::HTTP::CGI
->packager(SOAP::Lite::Packager::MIME->new)
->dispatch_with({'urn:Majordojo:TemperatureService' => 'TemperatureService'})
->handle;
BEGIN {
package TemperatureService;
use vars qw(@ISA);
@ISA = qw(Exporter SOAP::Server::Parameters);
use SOAP::Lite;
sub c2f {
my $self = shift;
my $envelope = pop;
my $temp = $envelope->dataof("//c2f/temperature");
use MIME::Entity;
my $ent = build MIME::Entity
Type => "text/plain",
Path => "printenv",
Filename => "printenv",
Disposition => "attachment";
# read attachments
foreach my $part (@{$envelope->parts}) {
print STDERR "soaplite.cgi: attachment found! (".ref($part).")\n";
print STDERR "soaplite.cgi: contents => ".$part->stringify."\n";
}
# send attachments
return SOAP::Data->name('convertedTemp' => (((9/5)*($temp->value)) + 32)),
$ent;
}
}
=head2 SOAP::Lite::Packager::DIME
TODO
=head1 SEE ALSO
L<MIME::Tools>, L<DIME::Tools>
=head1 COPYRIGHT
Copyright (C) 2000-2007 Paul Kulchenko. All rights reserved.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=head1 AUTHORS
Byrne Reese
Martin Kutter E<lt>martin.kutter fen-net.deE<gt>
=cut

View File

@@ -0,0 +1,31 @@
package SOAP::Lite::Utils;
use strict;
our $VERSION = '1.27'; # VERSION
sub import {
my $caller = caller();
no strict qw(refs);
*{ "$caller\::__mk_accessors" } = \&__mk_accessors;
}
sub __mk_accessors {
my ($class, @method_from) = @_;
no strict 'refs';
for my $method ( @method_from ) {
my $field = '_' . $method;
*{ "$class\::$method" } = sub {
my $self = ref $_[0] ? shift : shift->new();
if (@_) {
$self->{$field} = shift;
return $self
}
return $self->{$field};
}
}
}
1;
__END__

View File

@@ -0,0 +1,553 @@
# ======================================================================
#
# Copyright (C) 2000-2004 Paul Kulchenko (paulclinger@yahoo.com)
# SOAP::Lite is free software; you can redistribute it
# and/or modify it under the same terms as Perl itself.
#
# ======================================================================
package SOAP::Packager;
use strict;
use vars;
our $VERSION = '1.27'; # VERSION
our $SUPPORTED_TYPES = { };
sub BEGIN {
no strict 'refs';
for my $method ( qw(parser headers_http persist_parts) ) {
my $field = '_' . $method;
*$method = sub {
my $self = shift;
if (@_) { $self->{$field} = shift; return $self }
return $self->{$field};
}
}
}
sub new {
my($class) = shift;
my(%params) = @_;
bless {
"_parts" => [ ],
"_parser" => undef,
"_persist_parts" => 0,
}, $class;
}
sub is_supported_part {
my $self = shift;
return $SUPPORTED_TYPES->{ref $_[0]};
}
sub parts {
my $self = shift;
if (@_) {
$self->{'_parts'} = shift;
}
return $self->{'_parts'};
}
# This is a static method that helps find the right Packager
sub find_packager {
# TODO - Input:
# * the mimetype of the data to be decoded raw data that needs
# * the data to be decoded
# Returns:
# * the proper SOAP::Packager instance
}
sub push_part {
my $self = shift;
my ($part) = @_;
push @{$self->{'_parts'}}, $part;
}
sub package {
# do nothing
die "SOAP::Packager::package() must be implemented";
}
sub unpackage {
my $self = shift;
$self->{'_parts'} = [] if !$self->persist_parts; # experimental
}
# ======================================================================
package SOAP::Packager::MIME;
use strict;
use vars qw(@ISA);
@ISA = qw(SOAP::Packager);
sub BEGIN {
no strict 'refs';
for my $method ( qw(transfer_encoding env_id env_location) ) {
my $field = '_' . $method;
*$method = sub {
my $self = shift;
if (@_) { $self->{$field} = shift; return $self }
return $self->{$field};
}
}
}
sub new {
my ($classname) = @_;
my $self = SOAP::Packager::new(@_);
$self->{'_content_encoding'} = '8bit';
$self->{'_env_id'} = '<main_envelope>';
$self->{'_env_location'} = '/main_envelope';
bless $self, $classname;
$SOAP::Packager::SUPPORTED_TYPES->{"MIME::Entity"} = 1;
return $self;
}
sub initialize_parser {
my $self = shift;
eval "require MIME::Parser;";
die "Could not find MIME::Parser - is MIME::Tools installed? Aborting." if $@;
$self->{'_parser'} = MIME::Parser->new;
$self->{'_parser'}->output_to_core('ALL');
$self->{'_parser'}->tmp_to_core(1);
$self->{'_parser'}->ignore_errors(1);
$self->{'_parser'}->extract_nested_messages(0);
}
sub generate_random_string {
my ($self,$len) = @_;
my @chars=('a'..'z','A'..'Z','0'..'9','_');
my $random_string;
foreach (1..$len) {
$random_string .= $chars[rand @chars];
}
return $random_string;
}
sub get_multipart_id {
my ($id) = shift;
($id || '') =~ /^<?([^>]+)>?$/; $1 || '';
}
sub package {
my $self = shift;
my ($envelope,$context) = @_;
return $envelope if (!$self->parts); # if there are no parts,
# then there is nothing to do
require MIME::Entity;
local $MIME::Entity::BOUNDARY_DELIMITER = "\r\n";
my $top = MIME::Entity->build('Type' => "Multipart/Related");
my $soapversion = defined($context) ? $context->soapversion : '1.1';
$top->attach('Type' => $soapversion == 1.1 ? "text/xml" : "application/soap+xml",
'Content-Transfer-Encoding' => $self->transfer_encoding(),
'Content-Location' => $self->env_location(),
'Content-ID' => $self->env_id(),
'Data' => $envelope );
# consume the attachments that come in as input by 'shift'ing
no strict 'refs';
while (my $part = shift(@{$self->parts})) {
$top->add_part($part);
}
# determine MIME boundary
my $boundary = $top->head->multipart_boundary;
$self->headers_http({ 'Content-Type' => 'Multipart/Related; type="text/xml"; start="<main_envelope>"; boundary="'.$boundary.'"'});
return $top->stringify_body;
}
sub unpackage {
my $self = shift;
my ($raw_input,$context) = @_;
$self->SUPER::unpackage();
# Parse the raw input into a MIME::Entity structure.
# - fail if the raw_input is not MIME formatted
$self->initialize_parser() if !defined($self->parser);
my $entity = eval { $self->parser->parse_data($raw_input) }
or die "Something wrong with MIME message: @{[$@ || $self->parser->last_error]}\n";
my $env = undef;
# major memory bloat below! TODO - fix!
if (lc($entity->head->mime_type) eq 'multipart/form-data') {
$env = $self->process_form_data($entity);
} elsif (lc($entity->head->mime_type) eq 'multipart/related') {
$env = $self->process_related($entity);
} elsif (lc($entity->head->mime_type) eq 'text/xml') {
# I don't think this ever gets called.
# warn "I am somewhere in the SOAP::Packager::MIME code I didn't know I would be in!";
$env = $entity->bodyhandle->as_string;
} else {
die "Can't handle MIME messsage with specified type (@{[$entity->head->mime_type]})\n";
}
# return the envelope
if ($env) {
return $env;
} elsif ($entity->bodyhandle->as_string) {
return $entity->bodyhandle->as_string;
} else {
die "No content in MIME message\n";
}
}
sub process_form_data {
my ($self, $entity) = @_;
my $env = undef;
foreach my $part ($entity->parts) {
my $name = $part->head->mime_attr('content-disposition.name');
$name eq 'payload' ?
$env = $part->bodyhandle->as_string
: $self->push_part($part);
}
return $env;
}
sub process_related {
my $self = shift;
my ($entity) = @_;
die "Multipart MIME messages MUST declare Multipart/Related content-type"
if ($entity->head->mime_attr('content-type') !~ /^multipart\/related/i);
# As it turns out, the Content-ID and start parameters are optional
# according to the MIME and SOAP specs. In the event that the head cannot
# be found, the head/root entity is used as a starting point.
# [19 Mar 2008] Modified by Feng Li <feng.li@sybase.com>
# Check optional start parameter, then optional Content-ID, then create/add
# Content-ID (the same approach as in SOAP::Lite 0.66)
#my $start = get_multipart_id($entity->head->mime_attr('content-type.start'));
my $start = get_multipart_id($entity->head->mime_attr('content-type.start'))
|| get_multipart_id($entity->parts(0)->head->mime_attr('content-id'));
if (!defined($start) || $start eq "") {
$start = $self->generate_random_string(10);
$entity->parts(0)->head->add('content-id',$start);
}
my $location = $entity->head->mime_attr('content-location') ||
'thismessage:/';
my $env;
foreach my $part ($entity->parts) {
next if !UNIVERSAL::isa($part => "MIME::Entity");
# Weird, the following use of head->get(SCALAR[,INDEX]) doesn't work as
# expected. Work around is to eliminate the INDEX.
my $pid = get_multipart_id($part->head->mime_attr('content-id'));
# If Content-ID is not supplied, then generate a random one (HACK - because
# MIME::Entity does not do this as it should... content-id is required
# according to MIME specification)
$pid = $self->generate_random_string(10) if $pid eq '';
my $type = $part->head->mime_type;
# If a Content-Location header cannot be found, this will look for an
# alternative in the following MIME Header attributes
my $plocation = $part->head->get('content-location') ||
$part->head->mime_attr('Content-Disposition.filename') ||
$part->head->mime_attr('Content-Type.name');
if ($start && $pid eq $start) {
$env = $part->bodyhandle->as_string;
} else {
$self->push_part($part);
}
}
# die "Can't find 'start' parameter in multipart MIME message\n"
# if @{$self->parts} > 1 && !$start;
return $env;
}
# ======================================================================
package SOAP::Packager::DIME;
use strict;
use vars qw(@ISA);
@ISA = qw(SOAP::Packager);
sub BEGIN {
no strict 'refs';
for my $method ( qw(foo) ) {
my $field = '_' . $method;
*$method = sub {
my $self = shift;
if (@_) { $self->{$field} = shift; return $self }
return $self->{$field};
}
}
}
sub new {
my ($classname) = @_;
my $self = SOAP::Packager::new(@_);
bless $self, $classname;
$SOAP::Packager::SUPPORTED_TYPES->{"DIME::Payload"} = 1;
return $self;
}
sub initialize_parser {
my $self = shift;
print STDERR "Initializing parser\n";
eval "require DIME::Parser;";
die "Could not find DIME::Parser - is DIME::Tools installed? Aborting." if $@;
$self->{'_parser'} = DIME::Parser->new;
}
sub package {
my $self = shift;
my ($envelope,$context) = @_;
return $envelope if (!$self->parts); # if there are no parts,
# then there is nothing to do
require DIME::Message;
require DIME::Payload;
my $message = DIME::Message->new;
my $top = DIME::Payload->new;
my $soapversion = defined($context) ? $context->soapversion : '1.1';
$top->attach('MIMEType' => $soapversion == 1.1 ?
"http://schemas.xmlsoap.org/soap/envelope/" : "application/soap+xml",
'Data' => \$envelope );
$message->add_payload($top);
# consume the attachments that come in as input by 'shift'ing
no strict 'refs';
while (my $part = shift(@{$self->parts})) {
die "You are only allowed to add parts of type DIME::Payload to a DIME::Message"
if (!$part->isa('DIME::Payload'));
# print STDERR "Adding payload to DIME message: ".ref($part)."\n";
$message->add_payload($part);
# print STDERR "Payload's payload is: ".${$part->print_content_data}."\n";
}
$self->headers_http({ 'Content-Type' => 'application/dime' });
return $message->print_data;
}
sub unpackage {
my $self = shift;
my ($raw_input,$context) = @_;
$self->SUPER::unpackage();
# Parse the raw input into a DIME::Message structure.
# - fail if the raw_input is not DIME formatted
print STDERR "raw_data: $raw_input\n";
$self->initialize_parser() if !defined($self->parser);
my $message = eval { $self->parser->parse_data(\$raw_input) }
or die "Something wrong with DIME message: @{[$@]}\n";
# The first payload is always the SOAP Message
# TODO - Error check
my @payloads = @{$message->{'_PAYLOADS'}};
my $env = shift(@payloads);
my $env_str = $env->print_content_data;
print STDERR "Received this envelope: ".$env_str."\n";
while (my $p = shift(@payloads)) {
print STDERR "Adding part to Packager\n";
$self->push_part($p);
}
return $env_str;
}
1;
__END__
=pod
=head1 NAME
SOAP::Packager - this class is an abstract class which allows for multiple types of packaging agents such as MIME and DIME.
=head1 DESCRIPTION
The SOAP::Packager class is responsible for managing a set of "parts." Parts are
additional pieces of information, additional documents, or virtually anything that
needs to be associated with the SOAP Envelope/payload. The packager then will take
these parts and encode/decode or "package"/"unpackage" them as they come and go
over the wire.
=head1 METHODS
=over
=item new
Instantiates a new instance of a SOAP::Packager.
=item parts
Contains an array of parts. The contents of this array and their types are completely
dependent upon the Packager being used. For example, when using MIME, the content
of this array is MIME::Entity's.
=item push_part
Adds a part to set of parts managed by the current instance of SOAP::Packager.
=item parser
Returns the parser used to parse attachments out of a data stream.
=item headers_http
This is a hook into the HTTP layer. It provides a way for a packager to add and/or modify
HTTP headers in a request/response. For example, most packaging layers will need to
override the Content-Type (e.g. multipart/related, or application/dime).
=back
=head1 ABSTRACT METHODS
If you wish to implement your own SOAP::Packager, then the methods below must be
implemented by you according to the prescribed input and output requirements.
=over
=item package()
The C<package> subroutine takes as input the SOAP envelope in string/SCALAR form.
This will serve as the content of the root part. The packager then encapsulates the
envelope with the parts contained within C<parts> and returns the properly
encapsulated envelope in string/SCALAR form.
=item unpackage()
The C<unpackage> subroutines takes as input raw data that needs to be parsed into
a set of parts. It is responsible for extracting the envelope from the input, and
populating C<parts> with an ARRAY of parts extracted from the input. It then returns
the SOAP Envelope in string/SCALAR form so that SOAP::Lite can parse it.
=back
=head1 SUPPORTED PACKAGING FORMATS
=head2 SOAP::Packager::MIME
C<SOAP::Packager::MIME> utilizes L<MIME::Tools> to provides the ability to send
and receive Multipart/Related and Multipart/Form-Data formatted requests and
responses.
=head3 MIME METHODS
The following methods are used when composing a MIME formatted message.
=over
=item transfer_encoding
The value of the root part's Content-Transfer-Encoding MIME Header. Default is: 8bit.
=item env_id
The value of the root part's Content-Id MIME Header. Default is: <main_envelope>.
=item env_location
The value of the root part's Content-Location MIME Header. Default is: /main_envelope.
=item env_type
The value of the root part's Content-Type MIME Header. Default is: text/xml.
=back
=head3 OPTIMIZING THE MIME PARSER
The use of attachments can often result in a heavy drain on system resources depending
upon how your MIME parser is configured. For example, you can instruct the parser to
store attachments in memory, or to use temp files. Using one of the other can affect
performance, disk utilization, and/or reliability. Therefore you should consult the
following URL for optimization techniques and trade-offs:
http://search.cpan.org/dist/MIME-tools/lib/MIME/Parser.pm#OPTIMIZING_YOUR_PARSER
To modify the parser's configuration options consult the following code sample,
which incidentally shows how to minimize memory utilization:
my $packager = SOAP::Packager::MIME->new;
# $packager->parser->decode_headers(1); # no difference
# $packager->parser->extract_nested_messages(1); # no difference
$packager->parser->output_to_core(0); # much less memory
$packager->parser->tmp_to_core(0); # much less memory
$packager->parser->tmp_recycling(0); # promotes faster garbage collection
$packager->parser->use_inner_files(1); # no difference
my $client = SOAP::Lite->uri($NS)->proxy($URL)->packager($packager);
$client->someMethod();
=head3 CLIENT SIDE EXAMPLE
The following code sample shows how to use attachments within the context of a
SOAP::Lite client.
#!/usr/bin/perl
use SOAP::Lite;
use MIME::Entity;
my $ent = build MIME::Entity
Type => "text/plain",
Path => "attachment.txt",
Filename => "attachment.txt",
Disposition => "attachment";
my $NS = "urn:Majordojo:TemperatureService";
my $HOST = "http://localhost/cgi-bin/soaplite.cgi";
my $client = SOAP::Lite
->packager(SOAP::Packager::MIME->new)
->parts([ $ent ])
->uri($NS)
->proxy($HOST);
my $response = $client->c2f(SOAP::Data->name("temperature" => '100'));
print $response->valueof('//c2fResponse/foo');
=head3 SERVER SIDE EXAMPLE
The following code shows how to use attachments within the context of a CGI
script. It shows how to read incoming attachments, and to return attachments to
the client.
#!/usr/bin/perl -w
use SOAP::Transport::HTTP;
use MIME::Entity;
SOAP::Transport::HTTP::CGI
->packager(SOAP::Packager::MIME->new)
->dispatch_with({'urn:Majordojo:TemperatureService' => 'TemperatureService'})
->handle;
BEGIN {
package TemperatureService;
use vars qw(@ISA);
@ISA = qw(Exporter SOAP::Server::Parameters);
use SOAP::Lite;
sub c2f {
my $self = shift;
my $envelope = pop;
my $temp = $envelope->dataof("//c2f/temperature");
use MIME::Entity;
my $ent = build MIME::Entity
Type => "text/plain",
Path => "printenv",
Filename => "printenv",
Disposition => "attachment";
# read attachments
foreach my $part (@{$envelope->parts}) {
print STDERR "soaplite.cgi: attachment found! (".ref($part).")\n";
print STDERR "soaplite.cgi: contents => ".$part->stringify."\n";
}
# send attachments
return SOAP::Data->name('convertedTemp' => (((9/5)*($temp->value)) + 32)),
$ent;
}
}
=head2 SOAP::Packager::DIME
TODO
=head1 SEE ALSO
L<MIME::Tools>, L<DIME::Tools>
=head1 COPYRIGHT
Copyright (C) 2000-2004 Paul Kulchenko. All rights reserved.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=head1 AUTHORS
Byrne Reese (byrne@majordojo.com)
=cut

313
database/perl/vendor/lib/SOAP/SOM.pod vendored Normal file
View File

@@ -0,0 +1,313 @@
# ======================================================================
#
# Copyright (C) 2000-2003 Paul Kulchenko (paulclinger@yahoo.com)
# SOAP::Lite is free software; you can redistribute it
# and/or modify it under the same terms as Perl itself.
#
# ======================================================================
=pod
=head1 NAME
SOAP::SOM - provides access to the values contained in SOAP Response
=head1 DESCRIPTION
Objects from the SOAP::SOM class aren't generally instantiated directly by an application. Rather, they are handed back by the deserialization of a message. In other words, developers will almost never do this:
$som = SOAP::SOM->new;
SOAP::SOM objects are returned by a SOAP::Lite call in a client context. For example:
my $client = SOAP::Lite
->readable(1)
->uri($NS)
->proxy($HOST)
$som = $client->someMethod();
=head1 METHODS
=over
=item new(message)
$som = SOAP::SOM->new($message_as_xml);
As said, the need to actually create an object of this class should be very rare. However, if the need arises, the syntax must be followed. The single argument to new must be a valid XML document the parser will understand as a SOAP response.
=back
The following group of methods provide general data retrieval from the SOAP::SOM object. The model for this is an abbreviated form of XPath. Following this group are methods that are geared towards specific retrieval of commonly requested elements.
=over
=item match(path)
$som->match('/Envelope/Body/[1]');
This method sets the internal pointers within the data structure so that the retrieval methods that follow will have access to the desired data. In the example path, the match is being made against the method entity, which is the first child tag of the body in a SOAP response. The enumeration of container children starts at 1 in this syntax, not 0. The returned value is dependent on the context of the call. If the call is made in a boolean context (such as C<< if ($som->match($path)) >>), the return value is a boolean indicating whether the requested path matched at all. Otherwise, an object reference is returned. The returned object is also a SOAP::SOM instance but is smaller, containing the subset of the document tree matched by the expression.
=item valueof(node)
$res = $som->valueof('[1]');
When the SOAP::SOM object has matched a path internally with the match method, this method allows retrieval of the data within any of the matched nodes. The data comes back as native Perl data, not a class instance (see dataof). In a scalar context, this method returns just the first element from a matched node set. In an array context, all elements are returned. Assuming that the earlier call happens after the earlier call to match, it retrieves the result entity from the method response that is contained in C<$som>, as this is the first child element in a method-response tag.
=item dataof(node)
$resobj = $som->dataof('[1]');
Performs the same operation as the earlier valueof method, except that the data is left in its L<SOAP::Data> form, rather than being deserialized. This allows full access to all the attributes that were serialized along with the data, such as namespace and encoding.
=item headerof(node)
$resobj = $som->headerof('[1]');
Acts much like dataof, except that it returns an object of the L<SOAP::Header> class (covered later in this chapter), rather than SOAP::Data. This is the preferred interface for manipulating the header entities in a message.
=item namespaceuriof(node)
$ns = $som->namespaceof('[1]');
Retrieves the namespace URI that governs the requested node. Note that namespaces are inherited, so this method will return the relevant value, even if it derives from a parent or other ancestor node.
=back
The following methods provide more direct access to the message envelope. All these methods return some form of a Perl value, most often a hash reference, when called. Context is also relevant: in a scalar context only the first matching node is returned, while in an array context, all matching nodes are. When called as a static method or as a regular function (such as C<SOAP::SOM::envelope>), any of the following methods returns the XPath string that is used with the match method to retrieve the data.
=over
=item root
$root = $som->root;
Returns the value of the root element as a hash reference. It behaves exactly as C<$som->valueof('/')> does.
=item envelope
$envelope = $som->envelope;
Retrieves the "Envelope" element of the message, returning it and its data as a hash reference. Keys in the hash will be Header and Body (plus any optional elements that may be present in a SOAP 1.1 envelope), whose values will be the serialized header and body, respectively.
=item header
$header = $som->header;
Retrieves the header portion of the envelope as a hash reference. All data within it will have been deserialized. If the attributes of the header are desired, the static form of the method can be combined with match to fetch the header as a SOAP::Data object:
$header = $som->match(SOAP::SOM::header)->dataof;
=item headers
@hdrs = $som->headers;
Retrieves the node set of values with deserialized headers from within the Header container. This is different from the earlier header method in that it returns the whole header as a single structure, and this returns the child elements as an array. In other words, the following expressions yield the same data structure:
$header = ($som->headers)[0];
$header = $som->valueof(SOAP::SOM::header.'/[1]');
=item body
$body = $som->body;
Retrieves the message body as a hash reference. The entity tags act as keys, with their deserialized content providing the values.
=item fault
if ($som->fault) { die $som->fault->faultstring }
Acts both as a boolean test whether a fault occurred, and as a way to retrieve the Fault entity itself from the message body as a hash reference. If the message contains a fault, the next four methods (faultcode, faultstring, faultactor, and faultdetail) may be used to retrieve the respective parts of the fault (which are also available on the hash reference as keys). If fault in a boolean context is true, the C<result>, C<paramsin>, C<paramsout>, and C<method> methods all return C<undef>.
=item faultcode
$code = $som->faultcode;
Returns the faultcode element of the fault if there is a fault; undef otherwise.
=item faultstring
$string = $som->faultstring;
Returns the faultstring element of the fault if there is a fault; undef otherwise.
=item faultactor
$actor = $som->faultactor;
Returns the faultactor element of the fault, if there is a fault and if the actor was specified within it. The faultactor element is optional in the serialization of a fault, so it may not always be present. This element is usually a string.
=item faultdetail
$detail = $som->faultdetail;
Returns the content of the detail element of the fault, if there is a fault and if the detail element was provided. Note that the name of the element isn't the same as the method, due to the possibility for confusion had the method been called simply, detail. As with the faultactor element, this isn't always a required component of a fault, so it isn't guaranteed to be present. The specification for the detail portion of a fault calls for it to contain a series of element tags, so the application may expect a hash reference as a return value when detail information is available (and undef otherwise).
=item method
$method = $som->method
Retrieves the "method" element of the message, as a hash reference. This includes all input parameters when called on a request message or all result/output parameters when called on a response message. If there is a fault present in the message, it returns undef.
=item result
$value = $som->result;
Returns the value that is the result of a SOAP response. The value will be already deserialized into a native Perl datatype.
=item paramsin
@list = $som->paramsin;
Retrieves the parameters being passed in on a SOAP request. If called in a scalar context, the first parameter is returned. When called in a list context, the full list of all parameters is returned. Each parameter is a hash reference, following the established structure for such return values.
=item paramsout
@list = $som->paramsout;
Returns the output parameters from a SOAP response. These are the named parameters that are returned in addition to the explicit response entity itself. It shares the same scalar/list context behavior as the paramsin method.
=item paramsall
@list = $som->paramsall;
Returns all parameters from a SOAP response, including the result entity itself, as one array.
=item parts()
Return an array of C<MIME::Entity>'s if the current payload contains attachments, or returns undefined if payload is not MIME multipart.
=item is_multipart()
Returns true if payload is MIME multipart, false otherwise.
=back
=head1 EXAMPLES
=head2 ACCESSING ELEMENT VALUES
Suppose for the following SOAP Envelope:
<Envelope>
<Body>
<fooResponse>
<bar>abcd</bar>
</fooResponse>
</Body>
</Envelope>
And suppose you wanted to access the value of the bar element, then use the following code:
my $soap = SOAP::Lite
->uri($SOME_NS)
->proxy($SOME_HOST);
my $som = $soap->foo();
print $som->valueof('//fooResponse/bar');
=head2 ACCESSING ATTRIBUTE VALUES
Suppose the following SOAP Envelope:
<Envelope>
<Body>
<c2fResponse>
<convertedTemp test="foo">98.6</convertedTemp>
</c2fResponse>
</Body>
</Envelope>
Then to print the attribute 'test' use the following code:
print "The attribute is: " .
$som->dataof('//c2fResponse/convertedTemp')->attr->{'test'};
=head2 ITERATING OVER AN ARRAY
Suppose for the following SOAP Envelope:
<Envelope>
<Body>
<catalog>
<product>
<title>Programming Web Service with Perl</title>
<price>$29.95</price>
</product>
<product>
<title>Perl Cookbook</title>
<price>$49.95</price>
</product>
</catalog>
</Body>
</Envelope>
If the SOAP Envelope returned contained an array, use the following code to iterate over the array:
for my $t ($som->valueof('//catalog/product')) {
print $t->{title} . " - " . $t->{price} . "\n";
}
=head2 DETECTING A SOAP FAULT
A SOAP::SOM object is returned by a SOAP::Lite client regardless of whether the call succeeded or not. Therefore, a SOAP Client is responsible for determining if the returned value is a fault or not. To do so, use the fault() method which returns 1 if the SOAP::SOM object is a fault and 0 otherwise.
my $som = $client->someMethod(@parameters);
if ($som->fault) {
print $som->faultdetail;
} else {
# do something
}
=head2 PARSING ARRAYS OF ARRAYS
The most efficient way To parse and to extract data out of an array containing another array encoded in a SOAP::SOM object is the following:
$xml = <<END_XML;
<foo>
<person>
<foo>123</foo>
<foo>456</foo>
</person>
<person>
<foo>789</foo>
<foo>012</foo>
</person>
</foo>
END_XML
my $som = SOAP::Deserializer->deserialize($xml);
my $i = 0;
foreach my $a ($som->dataof("//person/*")) {
$i++;
my $j = 0;
foreach my $b ($som->dataof("//person/[$i]/*")) {
$j++;
# do something
}
}
=head1 SEE ALSO
L<SOAP::Data>, L<SOAP::Serializer>
=head1 ACKNOWLEDGEMENTS
Special thanks to O'Reilly publishing which has graciously allowed SOAP::Lite to republish and redistribute large excerpts from I<Programming Web Services with Perl>, mainly the SOAP::Lite reference found in Appendix B.
=head1 COPYRIGHT
Copyright (C) 2000-2004 Paul Kulchenko. All rights reserved.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=head1 AUTHORS
Paul Kulchenko (paulclinger@yahoo.com)
Randy J. Ray (rjray@blackperl.com)
Byrne Reese (byrne@majordojo.com)
=cut

132
database/perl/vendor/lib/SOAP/Schema.pod vendored Normal file
View File

@@ -0,0 +1,132 @@
# ======================================================================
#
# Copyright (C) 2000-2003 Paul Kulchenko (paulclinger@yahoo.com)
# SOAP::Lite is free software; you can redistribute it
# and/or modify it under the same terms as Perl itself.
#
# ======================================================================
=pod
=head1 NAME
SOAP::Schema - provides an umbrella for the way in which SOAP::Lite manages service description schemas
=head1 DESCRIPTION
This class provides an umbrella for the way in which SOAP::Lite manages service description schemas. Currently, the only support present is for the Web Services Description Language (WSDL). This is another of the classes not generally designed to be directly instantiated by an application, though it can be if so desired.
=head1 METHODS
=over
=item new(optional key/value pairs)
$schema = SOAP::Schema->new(parse => $schema_uri);
This is the class constructor. With no arguments, it creates a blank object of the class. Any arguments that are passed are treated as key/value pairs in which the key represents one of the methods described here, and the value is what gets passed when the method itself gets invoked.
=item parse(service description URI)
$schema->parse('http://schemas.w3.org/soap.wsdl');
Parses the internal representation of the service description prior to the generation of stub routines to provide method-like access to the remote services.
=item access(service description URI)
$schema->access('http://soap.org/service.wsdl');
Loads the specified service description from the given URL, using the current value of the schema accessor if none is provided. The full content of the URL is returned on success, or an exception is thrown (via C<die>) on error.
=item load
$schema->load;
Takes the internal representation of the service and generates code stubs for the remote methods, allowing them to be called as local object methods. Stubs are generated for all the functions declared in the WSDL description with this call because it's enough of a class framework to allow for basic object creation for use as handles.
=item schema
$current_schema = $schema->schema;
Gets (or sets) the current schema representation to be used by this object. The value to be passed when setting this is just the URI of the schema. This gets passed to other methods such as access for loading the actual content.
=item services
$hashref = $schema->services;
Gets or sets the services currently stored on the object. The services are kept as a hash reference, whose keys and values are the list of returned values from the WSDL parser. Keys represent the names of the services themselves (names have been normalized into Perl-compatible identifiers), with values that are also hash references to the internal representation of the service itself.
=item stub
Returns the autogenerated Perl code as a string. This code is generated from the WSDL provided by the C<service> method call. The code contains a package definition for the service being called.
my $client = SOAP::Lite->new;
my $code = $client->service($WSDL_URL)->stub;
open FILE,">ServicePackage.pm";
print FILE $code;
close FILE;
=item cache_dir
Sets/retrieves the value of the directory where generated stubs will be cached. If C<cache_dir> is null, then no caching will be performed.
my $client = SOAP::Lite->new;
my $code = $client->cache_dir("/tmp")->service($WSDL_URL)->stub;
If C<cache_dir> is undefined, no caching will take place.
=item cache_ttl
Sets/retrieves the value of the time to live (in seconds) for cached files. This is only relevant when used in conjunction with C<cache_dir>.
If C<cache_ttl> is set to 0, the cache will never expire. Files will have to be removed manually in order for the cache to be refreshed.
my $client = SOAP::Lite->new;
my $code = $client->cache_ttl(3600)->cache_dir("/tmp")->service($WSDL_URL)->stub;
The default time to live is 0.
=item useragent(LWP::UserAgent)
my $client = SOAP::Lite->new;
$ua = $client->schema->useragent;
$ua->agent("Fubar! 0.1");
my $response = $client->service("http://localhost/some.wsdl")
->someMethod("Foo");
Gets or sets the classes UserAgent used for retrieving schemas over the web.
This allows users to have direct access to the UserAgent so that they may control
the credentials passed to a remote server, or the specific configuration of their
HTTP agent.
=back
=head1 SOAP::Schema::WSDL
At present, the SOAP::Lite toolkit supports only loading of service descriptions in the WSDL syntax. This class manages the parsing and storing of these service specifications. As a general rule, this class should be even less likely to be used directly by an application because its presence should be completely abstracted by the previous class (SOAP::Schema). None of the methods are defined here; the class is only mentioned for sake of reference.
=head1 ACKNOWLEDGEMENTS
Special thanks to O'Reilly publishing which has graciously allowed SOAP::Lite to republish and redistribute large excerpts from I<Programming Web Services with Perl>, mainly the SOAP::Lite reference found in Appendix B.
=head1 COPYRIGHT
Copyright (C) 2000-2004 Paul Kulchenko. All rights reserved.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=head1 AUTHORS
Paul Kulchenko (paulclinger@yahoo.com)
Randy J. Ray (rjray@blackperl.com)
Byrne Reese (byrne@majordojo.com)
=cut

View File

@@ -0,0 +1,272 @@
# ======================================================================
#
# Copyright (C) 2000-2004 Paul Kulchenko (paulclinger@yahoo.com)
# SOAP::Lite is free software; you can redistribute it
# and/or modify it under the same terms as Perl itself.
#
# ======================================================================
=pod
=head1 NAME
SOAP::Serializer - the means by which the toolkit manages the expression of data as XML
=head1 DESCRIPTION
The SOAP::Serializer class is the means by which the toolkit manages the expression of data as XML. The object that a SOAP::Lite instance uses by default is generally enough for the task, with no need for the application to create its own. The main purpose of this class is to provide a place for applications to extend the serializer by defining additional methods for handling new datatypes.
=head1 METHODS
=over
=item new(optional key/value pairs)
$serialize = SOAP::Serializer->new( );
This is the constructor method for the class. In addition to creating a basic object and initializing it with default values, the constructor can also take names and values for most of the accessor methods that the class supports.
=item envelope(method, data arguments)
$serialize->envelope(fault => $fault_obj);
Provides the core purpose for the SOAP::Serializer class. It creates the full SOAP envelope based on the input passed in to it. The data arguments passed in the list of parameters to the method are divided into two sublists: any parameters that are L<SOAP::Header> objects or derivatives of go into one list, while the remainder go into the other. The nonheader objects are used as the content for the message body, with the body itself being largely dependent on the value of the first argument in the list. This argument is expected to be a string and should be one of the following:
=item context
$serialize->context->packager();
This provides access to the calling context of C<SOAP::Serializer>. In a client side context the often means a reference to an instance of SOAP::Lite. In a server side context this means a reference to a SOAP::Server instance.
=over
=item method
The envelope is being created to encapsulate a RPC-style method call.
=item response
The message being created is that of a response stemming from a RPC-style method call.
=item fault
For this specifier, the envelope being created is to transmit a fault.
=item freeform
This identifier is used as a general-case encoding style for messages that
don't fit into any of the previous cases. The arguments are encoded into the
envelope's Body tag without any sort of context sensitivity.
=back
Any value other than these four results in an error.
=item envprefix(optional value)
$serialize->envprefix('env');
Gets or sets the prefix that labels the SOAP envelope namespace. This defaults to SOAP-ENV.
=item encprefix(optional value)
$serialize->envprefix('enc');
Gets or sets the prefix that labels the SOAP encoding namespace. Defaults to SOAP-ENC.
=item soapversion(optional value)
$serialize->soapversion('1.2');
If no parameter is given, returns the current version of SOAP that is being used as the basis for serializing messages. If a parameter is given, attempts to set that as the version of SOAP being used. The value should be either 1.1 or 1.2. When the SOAP version is being set, the package selects new URNs for envelope and encoding spaces and also calls the xmlschema method to set the appropriate schema definition.
=item xmlschema(optional value)
$serialize->xmlschema($xml_schema_1999);
Gets or sets the URN for the schema being used to express the structure of the XML generated by the serializer. If setting the value, the input must be the full URN for the new schema and is checked against the list of known SOAP schemas.
=item register_ns
The register_ns subroutine allows users to register a global namespace
with the SOAP Envelope. The first parameter is the namespace, the second
parameter to this subroutine is an optional prefix. If a prefix is not
provided, one will be generated automatically for you. All namespaces
registered with the serializer get declared in the <soap:Envelope />
element.
=item find_prefix
The find_prefix subroutine takes a namespace as a parameter and returns
the assigned prefix to that namespace. This eliminates the need to declare
and redeclare namespaces within an envelope. This subroutine is especially
helpful in determining the proper prefix when assigning a type to a
SOAP::Data element. A good example of how this might be used is as follows:
SOAP::Data->name("foo" => $inputParams{'foo'})
->type($client->serializer->find_prefix('urn:Foo').':Foo');
=back
=head1 CUSTOM DATA TYPES
When serializing an object, or blessed hash reference, into XML, C<SOAP::Serializer> first checks to see if a subroutine has been defined for the corresponding class name. For example, in the code below, C<SOAP::Serializer> will check to see if a subroutine called C<as_MyModule__MyPackage> has been defined. If so, then it will pass C<$foo> to that subroutine along with other data known about the C<SOAP::Data> element being encoded.
$foo = MyModule::MyPackage->new;
my $client = SOAP::Lite
->uri($NS)
->proxy($HOST);
$som = $client->someMethod(SOAP::Data->name("foo" => $foo));
=head1 as_TypeName SUBROUTINE REQUIREMENTS
=over
=item Naming Convention
The subroutine should always be prepended with C<as_> followed by the type's name. The type's name must have all colons (':') substituted with an underscore ('_').
=item Input
The input to C<as_TypeName> will have at least one parameter, and at most four parameters. The first parameter will always be the value or the object to be encoded. The following three parameters depend upon the context of the value/object being encoded.
If the value/object being encoded was part of a C<SOAP::Data> object (as in the above example), then the second, third and fourth parameter will be the C<SOAP::Data> element's name, type, and attribute set respectively. If on the other hand, the value/object being encoded is I<not> part of a C<SOAP::Data> object, as in the code below:
$foo = MyModule::MyPackage->new;
my $client = SOAP::Lite
->uri($NS)
->proxy($HOST);
$som = $client->someMethod($foo);
Then the second and third parameters will be the class name of the value/object being encoded (e.g. "MyModule::MyPackage" in the example above), and the fourth parameter will be an empty hash.
=item Output
The encoding subroutine must return an array containing three elements: 1) the name of the XML element, 2) a hash containing the attributes to be placed into the element, and 3) the value of the element.
=back
=head1 AUTOTYPING
When the type of an element has not been declared explicitly, SOAP::Lite must "guess" at the object's type. That is due to the fact that the only form of introspection that Perl provides (through the use of the C<ref> subroutine) does not provide enough information to C<SOAP::Serializer> to allow SOAP::Lite to determine the exact type of an element being serialized.
To work around this limitation, the C<SOAP::Serializer::typelookup> hash was created. This hash is populated with all the data types that the current C<SOAP::Serializer> can auto detect. Users and developers are free to modify the contents of this hash allowing them to register new data types with the system.
When C<SOAP::Serializer> is asked to encode an object into XML, it goes through the following steps. First, C<SOAP::Serializer> checks to see if a type has been explicitly stated for the current object. If a type has been provided C<SOAP::Serializer> checks to see if an C<as_TypeName> subroutine as been defined for that type. If such a subroutine exists, then C<SOAP::Serializer> passes the object to it to be encoded. If the subroutine does not exist, or the type has not been provided, then C<SOAP::Serializer> must attempt to "guess" the type of the object being serialized.
To do so, C<SOAP::Serializer> runs in sequence a set of tests stored in the C<SOAP::Serializer::typelookup> hash. C<SOAP::Serializer> continues to run each test until one of the tests returns true, indicating that the type of the object has been detected. When the type of the object has been detected, then C<SOAP::Serializer> passes the object to the encoding subroutine that corresponds with the test that was passed. If all the tests fail, and the type was not determined, then C<SOAP::Serializer> will as a last resort encode the object based on one of the four basic data types known to Perl: REF, SCALAR, ARRAY and HASH.
The following table contains the set of data types detectable by C<SOAP::Lite> by default and the order in which their corresponding test subroutine will be run, according to their precedence value.
Table 1 - Autotyping Precedence
TYPENAME PRECEDENCE VALUE
----------------------------
base64 10
int 20
long 25
float 30
gMonth 35
gDay 40
gYear 45
gMonthDay 50
gYearMonth 55
date 60
time 70
dateTime 75
duration 80
boolean 90
anyURI 95
string 100
=head2 REGISTERING A NEW DATA TYPE
To register a new data type that can be automatically detected by C<SOAP::Lite> and then serialized into XML, the developer must provide the following four things:
=over
=item *
The name of the new data type.
=item *
A subroutine that is capable of detecting whether a value passed to it is of the corresponding data type.
=item *
A number representing the test subroutine's precedence relative to all the other types' test subroutinestypes. See I<Table 1 - Autotyping Precedence>.
=item *
A subroutine that is capable of providing C<SOAP::Serializer> with the information necessary to serialize an object of the corresponding data type into XML.
=back
=head3 EXAMPLE 1
If, for example, you wish to create a new datatype called C<uriReference> for which you would like Perl values to be automatically detected and serialized into, then you follow these steps.
B<Step 1: Write a Test Subroutine>
The test subroutine will have passed to it by C<SOAP::Serializer> a value to be tested. The test subroutine must return 1 if the value passed to it is of the corresponding type, or else it must return 0.
sub SOAP::Serializer::uriReferenceTest {
my ($value) = @_;
return 1 if ($value =~ m!^http://!);
return 0;
}
B<Step 2: Write an Encoding Subroutine>
The encoding subroutine provides C<SOAP::Serializer> with the data necessary to encode the value passed to it into XML. The encoding subroutine name's should be of the following format: C<as_><Type Name>.
The encoding subroutine will have passed to it by C<SOAP::Serializer> four parameters: the value to be encoded, the name of the element being encoded, the assumed type of the element being encoded, and a reference to a hash containing the attributes of the element being encoded. The encoding subroutine must return an array representing the encoded datatype. C<SOAP::Serializer> will use the contents of this array to generate the corresponding XML of the value being encoded, or serialized. This array contains the following 3 elements: the name of the XML element, a hash containing the attributes to be placed into the element, and the value of the element.
sub SOAP::Serializer::as_uriReference {
my $self = shift;
my($value, $name, $type, $attr) = @_;
return [$name, {'xsi:type' => 'xsd:uriReference', %$attr}, $value];
}
B<Step 3: Register the New Data Type>
To register the new data type, simply add the type to the C<SOAP::Serializer::typelookup> hash using the type name as the key, and an array containing the precedence value, the test subroutine, and the encoding subroutine.
$s->typelookup->{uriReference}
= [11, \&uriReferenceTest, 'as_uriReference'];
I<Tip: As a short hand, you could just as easily use an anonymous test subroutine when registering the new datatype in place of the C<urlReferenceTest> subroutine above. For example:>
$s->typelookup->{uriReference}
= [11, sub { $_[0] =~ m!^http://! }, 'as_uriReference'];
Once complete, C<SOAP::Serializer> will be able to serialize the following C<SOAP::Data> object into XML:
$elem = SOAP::Data->name("someUri" => 'http://yahoo.com')->type('uriReference');
C<SOAP::Serializer> will also be able to automatically determine and serialize the following untyped C<SOAP::Data> object into XML:
$elem = SOAP::Data->name("someUri" => 'http://yahoo.com');
=head1 ACKNOWLEDGEMENTS
Special thanks to O'Reilly publishing which has graciously allowed SOAP::Lite to republish and redistribute large excerpts from I<Programming Web Services with Perl>, mainly the SOAP::Lite reference found in Appendix B.
=head1 COPYRIGHT
Copyright (C) 2000-2004 Paul Kulchenko. All rights reserved.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=head1 AUTHORS
Paul Kulchenko (paulclinger@yahoo.com)
Randy J. Ray (rjray@blackperl.com)
Byrne Reese (byrne@majordojo.com)
=cut

262
database/perl/vendor/lib/SOAP/Server.pod vendored Normal file
View File

@@ -0,0 +1,262 @@
# ======================================================================
#
# Copyright (C) 2000-2003 Paul Kulchenko (paulclinger@yahoo.com)
# SOAP::Lite is free software; you can redistribute it
# and/or modify it under the same terms as Perl itself.
#
# ======================================================================
=pod
=head1 NAME
SOAP::Server - provides the basic framework for the transport-specific server classes to build upon
=head1 DESCRIPTION
The SOAP::Server class provides the basic framework for the transport-specific server classes to build upon. Note that in none of the code examples provided with SOAP::Lite is this class used directly. Instead, it is designed to be a superclass within more specific implementation classes. The methods provided by SOAP::Server itself are:
=head1 METHODS
=over
=item new(optional key/value pairs)
$server = SOAP::Server->new(%options);
Creates a new object of the class. Various default instance values are set up, and like many of the constructors in this module, most of the class methods described here may be passed in the construction call by giving the name followed by the parameter (or an array reference if there are multiple parameters).
=item action(optional new value)
$action = $server->action
Retrieves or sets the value of the action attribute on the server object. This attribute is used when mapping the request to an appropriate namespace or routine. For example, the HTTP library sets the attribute to the value of the SOAPAction header when processing of the request begins, so that the find_target method described later may retrieve the value to match it against the server's configuration. Returns the object itself when setting the attribute.
=item myuri(optional new value)
$server->myuri("http://localhost:9000/SOAP");
Gets or sets the myuri attribute. This specifies the specific URI that the server is answering requests to (which may be different from the value specified in action or in the SOAPAction header).
=item serializer(optional new value)
=item deserializer(optional new value)
$serializer = $server->serializer;
$server->deserializer($new_deser_obj);
As with the client objects, these methods provide direct access to the serialization and deserialization objects the server object uses to transform input and output from and to XML. There is generally little or no need to explicitly set these to new values.
=item options(optional new value)
$server->options({compress_threshold => 10000});
Sets (or retrieves) the current server options as a hash-table reference. At present, only one option is used within the SOAP::Lite libraries themselves:
=over
=item compress_threshold
The value of this option is expected to be a numerical value. If set, and if the Compress::Zlib library is available to use, messages whose size in bytes exceeds this value are compressed for transmission. Both
ends of the conversation have to support this and have it enabled.
=back
Other options may be defined and passed around using this mechanism. Note that setting the options using this accessor requires a full hash reference be passed. To set just one or a few values, retrieve the current reference value and use it to set the key(s).
=item dispatch_with(optional new value)
$server->dispatch_with($new_table);
Represents one of two ways in which a SOAP::Server (or derived) object may specify mappings of incoming requests to server-side subroutines or namespaces. The value of the attribute is a hash-table reference. To set the attribute, you must pass a new hash reference. The hash table's keys are URI strings (literal URIs or the potential values of the SOAPAction header), and the corresponding values are one of a class name or an object reference. Requests that come in for a URI found in the table are routed to the specified class or through the specified object.
=item dispatch_to(optional list of new values)
$server->dispatch_to($dir, 'Module', 'Mod::meth');
This is the more traditional way to specify modules and packages for routing requests. This is also an accessor, but it returns a list of values when called with no arguments (rather than a single one). Each item in the list of values passed to this method is expected to be one of four things:
=over
=item I<Directory path>
If the value is a directory path, all modules located in that path are available for remote use.
=item I<Package name>
When the value is a package name (without including a specific method name), all routines within the package are available remotely.
=item I<Fully qualified method name>
Alternately, when the value is a package-qualified name of a subroutine or method, that specific routine is made available. This allows the server to make selected methods available without opening the entire package.
=item I<Object reference>
If the value is an object reference, the object itself routes the request.
The list of values held by the dispatch_to table are compared only after the URI mapping table from the dispatch_with attribute has been consulted. If the request's URI or SOAPAction header don't map to a specific configuration, the path specified by the action header (or in absence, the URI) is converted to a package name and compared against this set of values.
=back
=item objects_by_reference(optional list of new values)
$server->objects_by_reference(qw(My:: Class));
This also returns a list of values when retrieving the current attribute value,
as opposed to a single value.
This method doesn't directly specify classes for request routing so much as it
modifies the behavior of the routing for the specified classes. The classes that
are given as arguments to this method are marked to be treated as producing
persistent objects. The client is given an object representation that contains
just a handle on a local object with a default persistence of 600 idle seconds.
Each operation on the object resets the idle timer to zero. This facility is
considered experimental in the current version of SOAP::Lite.
A global variable/"constant" allows developers to specify the amount of time
an object will be persisted. The default value is 600 idle seconds. This value
can be changed using the following code:
$SOAP::Constants::OBJS_BY_REF_KEEPALIVE = 1000;
=item on_action(optional new value)
$server->on_action(sub { ...new code });
Gets or sets the reference to a subroutine that is used for executing the on_action hook. Where the client code uses this hook to construct the action-request data (such as for a SOAPAction header), the server uses the on_action hook to do any last-minute tests on the request itself, before it gets routed to a final destination. When called, the hook routine is passed three arguments:
=over
=item action
The action URI itself, retrieved from the action method described earlier.
=item method_uri
The URI of the XML namespace the method name is labeled with.
=item method_name
The name of the method being called by the request.
=back
=item on_dispatch(optional new value)
($uri, $name) = $server->on_dispatch->($request);
Gets or sets the subroutine reference used for the on_dispatch hook. This hook is called at the start of the request-routing phase and is given a single argument when called:
=over
=item request
An object of the L<SOAP::SOM> class, containing the deserialized request from the client.
=back
=item find_target
($class, $uri, $name) = $server->find_target($req)
Taking as its argument an object of the SOAP::SOM class that contains the deserialized request, this method returns a three-element list describing the method that is to be called. The elements are:
=over
=item class
The class into which the method call should be made. This may come back as either a string or an objectreference, if the dispatching is configured using an object instance.
=item uri
The URN associated with the request method. This is the value that was used when configuring the method routing on the server object.
=item name
The name of the method to call.
=back
=item handle
$server->handle($request_text);
Implements the main functionality of the serving process, in which the server takes an incoming request and dispatches it to the correct server-side subroutine. The parameter taken as input is either plain XML or MIME-encoded content (if MIME-encoding support is enabled).
=item make_fault
return $server->makefault($code, $message);
Creates a SOAP::Fault object from the data passed in. The order of arguments is: code, message, detail, actor. The first two are required (because they must be present in all faults), but the last two may be omitted unless needed.
=back
=head2 SOAP::Server::Parameters
This class provides two methods, but the primary purpose from the developer's point of view is to allow classes that a SOAP server exposes to inherit from it. When a class inherits from the SOAP::Server::Parameters class, the list of parameters passed to a called method includes the deserialized request in the form of a L<SOAP::SOM> object. This parameter is passed at the end of the arguments list, giving methods the option of ignoring it unless it is needed.
The class provides two subroutines (not methods), for retrieving parameters from the L<SOAP::SOM> object. These are designed to be called without an object reference in the parameter list, but with an array reference instead (as the first parameter). The remainder of the arguments list is expected to be the list from the method-call itself, including the SOAP::SOM object at the end of the list. The routines may be useful to understand if an application wishes to subclass SOAP::Server::Parameters and inherit from the new class instead.
=over
=item byNameOrOrder(order, parameter list, envelope)
@args = SOAP::Server::Parameters::byNameOrOrder ([qw(a b)], @_);
Using the list of argument names passed in the initial argument as an array reference, this routine returns a list of the parameter values for the parameters matching those names, in that order. If none of the names given in the initial array-reference exist in the parameter list, the values are returned in the order in which they already appear within the list of parameters. In this case, the number of returned values may differ from the length of the requested-parameters list.
=item byName(order, parameter list, envelope)
@args = SOAP::Server::Parameters::byName ([qw(a b c)], @_);
Acts in a similar manner to the previous, with the difference that it always returns as many values as requested, even if some (or all) don't exist. Parameters that don't exist in the parameter list are returned as undef values.
=back
=head3 EXAMPLE
The following is an example CGI based Web Service that utilizes a Perl module that inherits from the C<SOAP::Server::Parameters> class. This allows the methods of that class to access its input by name.
#!/usr/bin/perl
use SOAP::Transport::HTTP;
SOAP::Transport::HTTP::CGI
->dispatch_to('C2FService')
->handle;
BEGIN {
package C2FService;
use vars qw(@ISA);
@ISA = qw(Exporter SOAP::Server::Parameters);
use SOAP::Lite;
sub c2f {
my $self = shift;
my $envelope = pop;
my $temp = $envelope->dataof("//c2f/temperature");
return SOAP::Data->name('convertedTemp' => (((9/5)*($temp->value)) + 32));
}
}
=head1 SEE ALSO
L<SOAP::SOM>, L<SOAP::Transport::HTTP>
=head1 ACKNOWLEDGEMENTS
Special thanks to O'Reilly publishing which has graciously allowed SOAP::Lite to republish and redistribute large excerpts from I<Programming Web Services with Perl>, mainly the SOAP::Lite reference found in Appendix B.
=head1 COPYRIGHT
Copyright (C) 2000-2004 Paul Kulchenko. All rights reserved.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=head1 AUTHORS
Paul Kulchenko (paulclinger@yahoo.com)
Randy J. Ray (rjray@blackperl.com)
Byrne Reese (byrne@majordojo.com)
=cut

406
database/perl/vendor/lib/SOAP/Test.pm vendored Normal file
View File

@@ -0,0 +1,406 @@
# ======================================================================
#
# Copyright (C) 2000-2001 Paul Kulchenko (paulclinger@yahoo.com)
# SOAP::Lite is free software; you can redistribute it
# and/or modify it under the same terms as Perl itself.
#
# ======================================================================
package SOAP::Test;
use 5.006;
our $VERSION = '1.27'; # VERSION
our $TIMEOUT = 5;
# ======================================================================
package # hide from PAUSE
My::PingPong; # we'll use this package in our tests
sub new {
my $self = shift;
my $class = ref($self) || $self;
bless {_num=>shift} => $class;
}
sub next {
my $self = shift;
$self->{_num}++;
}
sub value {
my $self = shift;
$self->{_num};
}
# ======================================================================
package SOAP::Test::Server;
use strict;
use Test;
use SOAP::Lite;
sub run_for {
my $proxy = shift or die "Proxy/endpoint is not specified";
# ------------------------------------------------------
my $s = SOAP::Lite->uri('http://something/somewhere')->proxy($proxy)->on_fault(sub{});
eval { $s->transport->timeout($SOAP::Test::TIMEOUT) };
my $r = $s->test_connection;
unless (defined $r && defined $r->envelope) {
print "1..0 # Skip: ", $s->transport->status, "\n";
exit;
}
# ------------------------------------------------------
plan tests => 53;
eval q!use SOAP::Lite on_fault => sub{ref $_[1] ? $_[1] : new SOAP::SOM}; 1! or die;
print STDERR "Perl SOAP server test(s)...\n";
$s = SOAP::Lite
-> uri('urn:/My/Examples')
-> proxy($proxy);
ok($s->getStateName(1)->result eq 'Alabama');
ok($s->getStateNames(1,4,6,13)->result =~ /^Alabama\s+Arkansas\s+Colorado\s+Illinois\s*$/);
$r = $s->getStateList([1,2,3,4])->result;
ok(ref $r && $r->[0] eq 'Alabama');
$r = $s->getStateStruct({item1 => 1, item2 => 4})->result;
ok(ref $r && $r->{item2} eq 'Arkansas');
print $s->transport->status, "\n";
{
my $autoresult = $s->autoresult;
$s->autoresult(1);
ok($s->getStateName(1) eq 'Alabama');
$s->autoresult($autoresult);
}
print STDERR "Autobinding of output parameters test(s)...\n";
$s->uri('urn:/My/Parameters');
my $param1 = 10;
my $param2 = SOAP::Data->name('myparam' => 12);
my $result = $s->autobind($param1, $param2)->result;
ok($result == $param1 && $param2->value == 24);
print STDERR "Header manipulation test(s)...\n";
$a = $s->addheader(2, SOAP::Header->name(my => 123));
ok(ref $a->header && $a->header->{my} eq '123123');
ok($a->headers eq '123123');
print STDERR "Echo untyped data test(s)...\n";
$a = $s->echotwo(11, 12);
ok($a->result == 11);
print STDERR "mustUnderstand test(s)...\n";
$s->echo(SOAP::Header->name(somethingelse => 123)
->mustUnderstand(1));
ok($s->call->faultstring =~ /[Hh]eader has mustUnderstand attribute/);
if ($proxy =~ /^http/) {
ok($s->transport->status =~ /^500/);
} else {
skip('No Status checks for non http protocols on server side' => undef);
}
$s->echo(SOAP::Header->name(somethingelse => 123)
->mustUnderstand(1)
->actor('http://notme/'));
ok(!defined $s->call->fault);
print STDERR "dispatch_from test(s)...\n";
eval "use SOAP::Lite
uri => 'http://my.own.site.com/My/Examples',
dispatch_from => ['A', 'B'],
proxy => '$proxy',
; 1" or die;
eval { C->c };
ok($@ =~ /Can't locate object method "c"/);
eval { A->a };
ok(!$@ && SOAP::Lite->self->call->faultstring =~ /Failed to access class \(A\)/);
eval "use SOAP::Lite
dispatch_from => 'A',
uri => 'http://my.own.site.com/My/Examples',
proxy => '$proxy',
; 1" or die;
eval { A->a };
ok(!$@ && SOAP::Lite->self->call->faultstring =~ /Failed to access class \(A\)/);
print STDERR "Object autobinding and SOAP:: prefix test(s)...\n";
eval "use SOAP::Lite +autodispatch =>
uri => 'urn:', proxy => '$proxy'; 1" or die;
ok(SOAP::Lite->autodispatched);
eval { SOAP->new(1) };
ok($@ =~ /^URI is not specified/);
eval "use SOAP::Lite +autodispatch =>
uri => 'urn:/A/B', proxy => '$proxy'; 1" or die;
# should call My::PingPong, not A::B
my $p = My::PingPong->SOAP::new(10);
ok(ref $p && $p->SOAP::next+1 == $p->value);
# forget everything
SOAP::Lite->self(undef);
$s = SOAP::Lite
-> uri('urn:/My/PingPong')
-> proxy($proxy)
;
# should return object EXACTLY as after My::PingPong->SOAP::new(10)
$p = $s->SOAP::new(10);
ok(ref $p && $s->SOAP::next($p)+1 == $p->value);
print STDERR "VersionMismatch test(s)...\n";
{
local $SOAP::Constants::NS_ENV = 'http://schemas.xmlsoap.org/new/envelope/';
my $s = SOAP::Lite
-> uri('http://my.own.site.com/My/Examples')
-> proxy($proxy)
-> on_fault(sub{})
;
$r = $s->dosomething;
ok(ref $r && $r->faultcode =~ /:VersionMismatch/);
}
print STDERR "Objects-by-reference test(s)...\n";
eval "use SOAP::Lite +autodispatch =>
uri => 'urn:', proxy => '$proxy'; 1" or die;
print STDERR "Session iterator\n";
$r = My::SessionIterator->new(10);
if (!ref $r || exists $r->{id}) {
ok(ref $r && $r->next && $r->next == 11);
} else {
skip('No persistent objects (o-b-r) supported on server side' => undef);
}
print STDERR "Persistent iterator\n";
$r = My::PersistentIterator->new(10);
if (!ref $r || exists $r->{id}) {
my $first = ($r->next, $r->next) if ref $r;
$r = My::PersistentIterator->new(10);
ok(ref $r && $r->next && $r->next == $first+2);
} else {
skip('No persistent objects (o-b-r) supported on server side' => undef);
}
{ local $^W; # disable warnings about deprecated AUTOLOADing for nonmethods
print STDERR "Parameters-by-name test(s)...\n";
print STDERR "You can see warning about AUTOLOAD for non-method...\n" if $^W;
eval "use SOAP::Lite +autodispatch =>
uri => 'http://my.own.site.com/My/Parameters', proxy => '$proxy'; 1" or die;
my @parameters = (
SOAP::Data->name(b => 222),
SOAP::Data->name(c => 333),
SOAP::Data->name(a => 111)
);
# switch to 'main' package, because nonqualified methods should be there
ok(main::byname(@parameters) eq "a=111, b=222, c=333");
ok(main::bynameororder(@parameters) eq "a=111, b=222, c=333");
ok(main::bynameororder(111, 222, 333) eq "a=111, b=222, c=333");
print STDERR "Function call test(s)...\n";
print STDERR "You can see warning about AUTOLOAD for non-method...\n" if $^W;
ok(main::echo(11) == 11);
}
print STDERR "SOAPAction test(s)...\n";
if ($proxy =~ /^tcp:/) {
for (1..2) {skip('No SOAPAction checks for tcp: protocol on server side' => undef)}
} else {
my $s = SOAP::Lite
-> uri('http://my.own.site.com/My/Examples')
-> proxy($proxy)
-> on_action(sub{'""'})
;
ok($s->getStateName(1)->result eq 'Alabama');
$s->on_action(sub{'"wrong_SOAPAction_here"'});
ok($s->getStateName(1)->faultstring =~ /SOAPAction shall match/);
}
print STDERR "UTF8 test(s)...\n";
if (!eval "pack('U*', 0)") {
for (1) {skip('No UTF8 test. No support for pack("U*") modifier' => undef)}
} else {
$s = SOAP::Lite
-> uri('http://my.own.site.com/My/Parameters')
-> proxy($proxy);
my $latin1 = '<27><EFBFBD><E0A8A2>';
my $utf8 = pack('U*', unpack('C*', $latin1));
my $result = $s->echo(SOAP::Data->type(string => $utf8))->result;
ok(pack('U*', unpack('C*', $result)) eq $utf8 # should work where XML::Parser marks resulting strings as UTF-8
|| join('', unpack('C*', $result)) eq join('', unpack('C*', $utf8)) # should work where it doesn't
);
}
{
my $on_fault_was_called = 0;
print STDERR "Die in server method test(s)...\n";
my $s = SOAP::Lite
-> uri('http://my.own.site.com/My/Parameters')
-> proxy($proxy)
-> on_fault(sub{$on_fault_was_called++;return})
;
ok($s->die_simply()->faultstring =~ /Something bad/);
ok($on_fault_was_called > 0);
my $detail = $s->die_with_object()->dataof(SOAP::SOM::faultdetail . '/[1]');
ok($on_fault_was_called > 1);
ok(ref $detail && $detail->name =~ /(^|:)something$/);
# get Fault as hash of subelements
my $fault = $s->die_with_fault()->fault;
ok($fault->{faultcode} =~ ':Server.Custom');
ok($fault->{faultstring} eq 'Died in server method');
ok(ref $fault->{detail}->{BadError} eq 'BadError');
ok($fault->{faultactor} eq 'http://www.soaplite.com/custom');
}
print STDERR "Method with attributes test(s)...\n";
$s = SOAP::Lite
-> uri('urn:/My/Examples')
-> proxy($proxy)
;
ok($s->call(SOAP::Data->name('getStateName')->attr({xmlns => 'urn:/My/Examples'}), 1)->result eq 'Alabama');
print STDERR "Call with empty uri test(s)...\n";
$s = SOAP::Lite
-> uri('')
-> proxy($proxy)
;
ok($s->getStateName(1)->faultstring =~ /Denied access to method \(getStateName\) in class \(main\)/);
ok($s->call('a:getStateName' => 1)->faultstring =~ /Denied access to method \(getStateName\) in class \(main\)/);
print STDERR "Number of parameters test(s)...\n";
$s = SOAP::Lite
-> uri('http://my.own.site.com/My/Parameters')
-> proxy($proxy)
;
{ my @all = $s->echo->paramsall; ok(@all == 0) }
{ my @all = $s->echo(1)->paramsall; ok(@all == 1) }
{ my @all = $s->echo((1) x 10)->paramsall; ok(@all == 10) }
print STDERR "Memory refresh test(s)...\n";
# Funny test.
# Let's forget about ALL settings we did before with 'use SOAP::Lite...'
SOAP::Lite->self(undef);
ok(!defined SOAP::Lite->self);
print STDERR "Call without uri test(s)...\n";
$s = SOAP::Lite
-> proxy($proxy)
;
ok($s->getStateName(1)->faultstring =~ /Denied access to method \(getStateName\) in class \(main\)/);
print STDERR "Different settings for method and namespace test(s)...\n";
ok($s->call(SOAP::Data
->name('getStateName')
->attr({xmlns => 'urn:/My/Examples'}), 1)->result eq 'Alabama');
ok($s->call(SOAP::Data
->name('a:getStateName')
->uri('urn:/My/Examples'), 1)->result eq 'Alabama');
ok($s->call(SOAP::Data
->name('getStateName')
->uri('urn:/My/Examples'), 1)->result eq 'Alabama');
ok($s->call(SOAP::Data
->name('a:getStateName')
->attr({'xmlns:a' => 'urn:/My/Examples'}), 1)->result eq 'Alabama');
eval { $s->call(SOAP::Data->name('a:getStateName')) };
ok($@ =~ /Can't find namespace for method \(a:getStateName\)/);
$s->serializer->namespaces->{'urn:/My/Examples'} = '';
ok($s->getStateName(1)->result eq 'Alabama');
eval "use SOAP::Lite
uri => 'urn:/My/Examples', proxy => '$proxy'; 1" or die;
print STDERR "Global settings test(s)...\n";
$s = new SOAP::Lite;
ok($s->getStateName(1)->result eq 'Alabama');
SOAP::Trace->import(transport =>
sub {$_[0]->content_type('something/wrong') if UNIVERSAL::isa($_[0] => 'HTTP::Request')}
);
if ($proxy =~ /^tcp:/) {
skip('No Content-Type checks for tcp: protocol on server side' => undef);
} else {
ok($s->getStateName(1)->faultstring =~ /Content-Type must be/);
}
}
# ======================================================================
1;
__END__
=head1 NAME
SOAP::Test - Test framework for SOAP::Lite
=head1 SYNOPSIS
use SOAP::Test;
SOAP::Test::Server::run_for('http://localhost/cgi-bin/soap.cgi');
=head1 DESCRIPTION
SOAP::Test provides simple framework for testing server implementations.
Specify your address (endpoint) and run provided tests against your server.
See t/1*.t for examples.
=head1 COPYRIGHT
Copyright (C) 2000-2001 Paul Kulchenko. All rights reserved.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=head1 AUTHOR
Paul Kulchenko (paulclinger@yahoo.com)
=cut

160
database/perl/vendor/lib/SOAP/Trace.pod vendored Normal file
View File

@@ -0,0 +1,160 @@
# ======================================================================
#
# Copyright (C) 2000-2003 Paul Kulchenko (paulclinger@yahoo.com)
# SOAP::Lite is free software; you can redistribute it
# and/or modify it under the same terms as Perl itself.
#
# ======================================================================
=pod
=head1 NAME
SOAP::Trace - used only to manage and manipulate the runtime tracing of execution within the toolkit
=head1 DESCRIPTION
This class has no methods or objects. It is used only to manage and manipulate the runtime tracing of execution within the toolkit. In absence of methods, this section reviews the events that may be configured and the ways of configuring them.
=head1 SYNOPSIS
Tracing is enabled by the SOAP::Lite import method. This is usually done at compile-time, though it may be done explicitly by calling import directly. The commands for setting up tracing start with the keyword +trace. Alternately, +debug may be used; the two are interchangeable. After the initial keyword, one or more of the signals detailed here may be specified, optionally with a callback to handle them. When specifying multiple signals to be handled by a single callback, it is sufficient to list all of them first, followed finally by the callback, as in:
use SOAP::Lite +trace =>
method => fault => \&message_level,
trace => objects => \&lower_level;
In the fragment, the reference to message_level is installed as the callback for both method and fault signals, while lower_level is installed for trace and object events. If callbacks aren't explicitly provided, the default tracing action is to log a message to Perl's STDOUT file descriptor. Callbacks should expect a one or more arguments passed in, though the nature of the arguments varies based on the signal.
Any signal can be disabled by prefacing the name with a hyphen, such as -result. This is useful with the pseudosignal "all," which is shorthand for the full list of signals. The following fragment disables only the two signals, while still enabling the rest:
SOAP::Lite->import(+trace => all => -result => -parameters);
If the keyword +trace (or +debug) is used without any signals specified, it enables all signals (as if all were implied).
The signals and their meaning follow. Each also bears a note as to whether the signal is relevant to a server application, client application, or both.
=head1 TRACE SIGNALS
=over
=item transport I<Client only>
Triggered in the transport layer just before a request is sent and immediately after a response is received. Each time the signal is sent, the sole argument to the callback is the relevant object. On requests, this is a L<HTTP::Request> object; for responses, it's a L<HTTP::Response> object.
=item dispatch I<Server only>
Triggered with the full name of the method being dispatched, just before execution is passed to it. It is currently disabled in SOAP::Lite 0.55.
=item result I<Server only>
Triggered after the method has been dispatched and is passed the results returned from the method as a list. The result values have not yet been serialized when this signal is sent.
=item parameters I<Server only>
Triggered before a method call is actually dispatched, with the data that is intended for the call itself. The parameters for the method call are passed in as a list, after having been deserialized into Perl data.
=item headers I<Server only>
This signal should be for triggering on the headers of an incoming message, but it isn't implemented as of SOAP::Lite 0.55.
=item objects I<Client or server>
Highlights when an object is instantiated or destroyed. It is triggered in the new and DESTROY methods of the various SOAP::Lite classes.
=item method I<Client or server>
Triggered with the list of arguments whenever the envelope method of L<SOAP::Serializer> is invoked with an initial argument of method. The initial string itself isn't passed to the callback.
=item fault I<Client or server>
As with the method signal earlier, except that this signal is triggered when SOAP::Serializer::envelope is called with an initial argument of fault.
=item freeform I<Client or server>
Like the two previous, this signal is triggered when the method SOAP::Serializer::envelope is called with an initial parameter of freeform. This syntax is used when the method is creating SOAP::Data objects from free-form input data.
=item trace I<Client or server>
Triggered at the entry-point of many of the more-significant functions. Not all the functions within the SOAP::Lite classes trigger this signal. Those that do are primarily the highly visible functions described in the interface descriptions for the various classes.
=item debug I<Client or server>
Used in the various transport modules to track the contents of requests and responses (as ordinary strings, not as objects) at different points along the way.
=back
=head1 EXAMPLES
=head2 SELECTING SIGNALS TO TRACE
The following code snippet will enable tracing for all signals:
use SOAP::Lite +trace => 'all';
You can disable tracing for a set of signals by prefixing the signal name with a hyphen. Therefore, if you wish to enable tracing for every signal EXCEPT transport signals, then you would use the code below:
use SOAP::Lite +trace => [ qw(all -transport) ];
=head2 LOGGING SIGNALS TO A FILE
You can optionally provide a subroutine or callback to each signal trace you declare. Each time a signal is received, it is passed to the corresponding subroutine. For example, the following code effectively logs all fault signals to a file called fault.log:
use SOAP::Lite +trace => [ fault => \&log_faults ];
sub log_faults {
open LOGFILE,">fault.log";
print LOGFILE, $_[0] . "\n";
close LOGFILE;
}
You can also use a single callback for multiple signals using the code below:
use SOAP::Lite +trace => [ method, fault => \&log ];
=head2 LOGGING MESSAGE CONTENTS
The transport signal is unique in the that the signal is not a text string, but the actually HTTP::Request being sent (just prior to be sent), or HTTP::Response object (immediately after it was received). The following code sample shows how to make use of this:
use SOAP::Lite +trace => [ transport => \&log_message ];
sub log_message {
my ($in) = @_;
if (class($in) eq "HTTP::Request") {
# do something...
print $in->contents; # ...for example
} elsif (class($in) eq "HTTP::Response") {
# do something
}
}
=head2 ON_DEBUG
The C<on_debug> method is available, as in:
use SOAP::Lite;
my $client = SOAP::Lite
->uri($NS)
->proxy($HOST)
->on_debug( sub { print @_; } );
=head1 ACKNOWLEDGEMENTS
Special thanks to O'Reilly publishing which has graciously allowed SOAP::Lite to republish and redistribute large excerpts from I<Programming Web Services with Perl>, mainly the SOAP::Lite reference found in Appendix B.
=head1 COPYRIGHT
Copyright (C) 2000-2004 Paul Kulchenko. All rights reserved.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=head1 AUTHORS
Paul Kulchenko (paulclinger@yahoo.com)
Randy J. Ray (rjray@blackperl.com)
Byrne Reese (byrne@majordojo.com)
=cut

View File

@@ -0,0 +1,571 @@
# ======================================================================
#
# Copyright (C) 2000-2003 Paul Kulchenko (paulclinger@yahoo.com)
# SOAP::Lite is free software; you can redistribute it
# and/or modify it under the same terms as Perl itself.
#
# ======================================================================
=pod
=head1 NAME
SOAP::Transport - an abstract class extended by more specialized transport modules
=head1 DESCRIPTION
Objects of the SOAP::Transport class manage two roles: they manage both the parameters related to transport as set through the containing SOAP::Lite object, and they abstract the selection and loading of an appropriate transport module. This is done with an AUTOLOAD function within the class that intercepts all methods beyond the two defined next and reroutes them to the underlying transport implementation code.
=head1 METHODS
=over
=item new
$trans = SOAP::Transport->new;
This is the constructor, which isn't usually called by an application directly. An application can use this to create a fresh new SOAP::Transport object, which may be installed using the SOAP::Lite->transport method defined earlier. No arguments are recognized.
=item proxy(optional URL string)
$trans->proxy('http://www.blackperl.com/SOAP');
Gets or sets the proxy (endpoint). This method must be called before any other methods are called. The proper transport code is loaded based on the scheme specified by the URL itself (http, jabber, etc.). Until this method is called the first time with a URL string, the underlying code has yet to be loaded, and the methods aren't available. When getting the current proxy (calling with no parameters), the returned value is a reference to the client object created from the protocol class that matched the endpoint, not the endpoint itself.
=back
=head1 SOAP Transport Sub-Classes
Because the bulk of the work is done within the C<SOAP::Lite> module itself, many of the transport-level modules are very simple in their implementations. Transport modules are expected to define both client and server classes within their files. If a module defines only one of the types, it is assumed that the transport protocol itself supports only that side of the conversation. An example is L<SOAP::Transport::FTP>, which provides only a C<SOAP::Transport::FTP::Client> class.
L</"SOAP::Transport::FTP"> - Client class only
L</"SOAP::Transport::HTTP"> - Client, and server classes for CGI, FCGI, Daemon and mod_perl
L</"SOAP::Transport::IO"> - Server class only
L</"SOAP::Transport::JABBER"> - Server and Client classes
L</"SOAP::Transport::LOCAL"> - Client class only
L</"SOAP::Transport::MAILTO"> - Client class only
L</"SOAP::Transport::MQ"> - Server and Client classes
L</"SOAP::Transport::POP3"> - Server class only
L</"SOAP::Transport::TCP"> - Server and Client classes
=head2 METHODS
Each SOAP::Transport sub-class is expected to define (or inherit, if it is subclassing another transport class) at least two methods. Any newly developed transport classes are also expected to adhere to this interface. Clients are expected to implement the C<new> and C<send_receive> methods, and servers are expected to implement the C<new> and C<handle> methods. Here they are:
=over
=item new(optional key/value pairs)
$object = $class->new(%params);
Creates a new object instance and returns it. Like the constructors for both C<SOAP::Lite> and L<SOAP::Server> classes, all arguments passed in are treated as key/value pairs, where the key is expected to be one of the methods the class supports, and the value is the argument (or list reference of arguments) to the method.
=item send_receive(key/value pairs)
$client->send_recieve(%hash_table);
(Required for client classes only) When the SOAP::Lite objects attempt to send out requests, the means for doing so is to attempt to call this method on the object held within the SOAP::Transport object contained within the client itself. All clients are expected to provide this, and the call to this method always passes four values for the hash keys:
=over
=item action
The URI specifying the action being performed, usually the result from the on_action hook on the client object.
=item encoding
The URI of the encoding scheme that governs the message being sent.
=item endpoint
The URI specifying the endpoint to which the message is being sent.
=item envelope
The XML content of the message to be sent. It is generally the return value of the envelope method from the L<SOAP::Serializer> object instance that the client object maintains.
=item parts
Attachments to add to the request. Currently this only supports an array of MIME::Entity objects, but in theory could support attachments of any format.
=back
=item handle
$server->handle;
(Required for server classes only.) This method is the central point for the various server classes to provide an interface to handling requests. The exact set and nature of parameters generally varies based on the classes themselves.
=back
=head2 SOAP::Transport::HTTP
The most commonly used transport module is the HTTP implementation. This is loaded whenever an endpoint is given that starts with the characters, http:// or https://. This is also the most involved of the transport modules, defining not only a client class but several different server classes as well.
=head3 HTTP PROXY SETTINGS
Because C<SOAP::Client> inherits from C<LWP::UserAgent>, you can use any of C<LWP::UserAgent>'s proxy settings. For example:
SOAP::Lite->proxy("http://endpoint.server/",
proxy => ["http" => "http://my.proxy.server"]);
or
$soap->transport->proxy("http" => "http://my.proxy.server");
The above code samples should specify a proxy server for you. And should you use C<HTTP_proxy_user>
and C<HTTP_proxy_pass> for proxy authorization, C<SOAP::Lite> will handle it properly.
=head3 HTTP BASIC AUTHENTICATION
HTTP Basic authentication is accomplished by overriding the get_basic_credentials subroutine in C<LWP::UserAgent> (which C<SOAP::Transport::HTTP::Client> is a subclass):
BEGIN {
sub SOAP::Transport::HTTP::Client::get_basic_credentials {
return 'username' => 'password';
}
}
=head3 COOKIE-BASED AUTHENTICATION
use HTTP::Cookies;
my $cookies = HTTP::Cookies->new(ignore_discard => 1);
# you may also add 'file' if you want to keep them between sessions
my $soap = SOAP::Lite->proxy('http://localhost/');
$soap->transport->cookie_jar($cookies);
Or, alternatively, you can do the above on a single line:
$soap->proxy('http://localhost/',
cookie_jar => HTTP::Cookies->new(ignore_discard => 1));
Cookies will be taken from the response and provided to the request. You may access and manipulate cookies received, as well as add cookies of your own by using the C<HTTP::Cookies> interfaces.
=head3 SSL CERTIFICATE AUTHENTICATION
The default SSL implementation for the HTTP client library L<LWP::UserAgent> used by SOAP::Lite is L<IO::Socket::SSL>.
To enable certificate based authentication, you'll have to pass your certificate and key as additional options to the
proxy() method like this:
$soap->proxy( $url, ssl_opts => {
SSL_cert_file => 'client-cert.pem',
SSL_key_file => 'client-key.pem'
});
Or you can set them later like this:
$soap->transport->ssl_opts(
SSL_cert_file => 'client-cert.pem',
SSL_key_file => 'client-key.pem'
);
If you're using L<Crypt::SSLeay>, the following applies:
To get certificate authentication working you need to set three environment variables: C<HTTPS_CERT_FILE>, C<HTTPS_KEY_FILE>, and optionally C<HTTPS_CERT_PASS>. This can be done either through the command line, or directly within your Perl script using the C<$ENV> variable:
$ENV{HTTPS_CERT_FILE} = 'client-cert.pem';
$ENV{HTTPS_KEY_FILE} = 'client-key.pem';
These settings are referenced by C<Crypt::SSLeay>. Other options (e.g. CA peer verification) can be specified in a similar way. See L<Crypt::SSLeay> documentation for more information.
Please note that you probably should not be using L<Crypt::SSLeay> because it does not perform hostname verification; LWP::UserAgent uses IO::Socket::SSL by default. See also L<https://metacpan.org/pod/Crypt::SSLeay#DO-YOU-NEED-Crypt::SSLeay>.
Those who would like to use encrypted keys may find the following thread in the SOAP::Lite newsgroup helpful:
http://groups.yahoo.com/group/soaplite/message/729
=head3 COMPRESSION
SOAP::Lite provides you with the option for enabling compression over the wire using HTTP I<only> in both the server and client contexts, provided that you have L<Compress::Zlib> installed. Compression and decompression is done transparently to your application.
A server will respond with an encoded/compressed message only if the client has asserted that it can accept it (indicated by client sending an C<Accept-Encoding> HTTP header with a 'deflate' or '*' value).
C<SOAP::Lite> clients all have fallback logic implemented so that if a server doesn't understand the specified encoding (i.e. "Content-Encoding: deflate") and returns the proper HTTP status code (415 NOT ACCEPTABLE), the client will repeat the request without using encoding/compression. The client will then store this server in a per-session cache, so that all subsequent requests to that server will be transmitted without encoding.
Compression is enabled on the client side by specifying the C<compress_threshold> option, and if the size of the current request exceeds that threshold.
B<Client Code Sample>
print SOAP::Lite
->uri('http://localhost/My/Parameters')
->proxy('http://localhost/', options => {compress_threshold => 10000})
->echo(1 x 10000)
->result;
Servers will respond with a compressed message if the C<compress_threshold> option has been specified, if the size of the current response exceeds that threshold, and if the calling client transmitted the proper C<Accept-Encoding> HTTP Header.
B<Server Code Sample>
my $server = SOAP::Transport::HTTP::CGI
->dispatch_to('My::Parameters')
->options({compress_threshold => 10000})
->handle;
See also: L<Compress::Zlib>
=head3 SOAP::Transport::HTTP::Client
Inherits from: L<SOAP::Client>, L<LWP::UserAgent> (from the LWP package).
With this class, clients are able to use HTTP for sending messages. This class provides just the basic new and send_receive methods. Objects of this class understand the compress_threshold option and use it if the server being communicated to also understands it.
=head4 CHANGING THE DEFAULT USERAGENT CLASS
By default, C<SOAP::Transport::HTTP::Client> extends C<LWP::UserAgent>.
But under some circumstances, a user may wish to change the default
UserAgent class with their in order to better handle persist connections, or
to C<LWP::UserAgent::ProxyAny>, for example, which has better Win32/Internet
Explorer interoperability.
One can use the code below as an example of how to change the default UserAgent class.
use SOAP::Lite;
use SOAP::Transport::HTTP;
$SOAP::Transport::HTTP::Client::USERAGENT_CLASS = "My::UserAgent";
my $client = SOAP::Lite->proxy(..)->uri(..);
my $som = $client->myMethod();
There is one caveat, however. The UserAgent class you use, I<MUST> also be a subclass of C<LWP::UserAgent>. If it is not, then C<SOAP::Lite> will issue the following error: "Could not load UserAgent class <USERAGENT CLASS>."
=head4 HTTP-KEEP-ALIVE, TIMEOUTS, AND MORE
Because C<SOAP::Transport::HTTP::Client> extends C<LWP::UserAgent>, all methods available C<LWP::UserAgent> are also available to your SOAP Clients. For example, using C<LWP::UserAgent> HTTP keep alive's are accomplished using the following code:
my $ua = LWP::UserAgent->new(
keep_alive => 1,
timeout => 30
);
Therefore, the same initialization parameters you would pass to C<LWP::UserAgent> can also be passed to your SOAP::Lite client's C<proxy> subroutine like so:
my $soap = SOAP::Lite
->uri($uri)
->proxy($proxyUrl,
timeout => 30,
keep_alive => 1,
);
This is true for all initialization parameters and methods of C<LWP::UserAgent>.
=head4 METHODS
=over
=item http_request
This method gives you access to a prototype of the HTTP Request object that
will be transmitted to a SOAP::Server. The actual request used is a copy of
that object.
Do not use this method for anything else than setting prototypic behaviour for
the client object.
=item http_response
This method gives you access to the HTTP Response object that will be, or was
transmitted to a SOAP Server. It returns a L<HTTP::Response> object.
=back
=head3 SOAP::Transport::HTTP::Server
Inherits from: L<SOAP::Server>.
This is the most basic of the HTTP server implementations. It provides the
basic methods, new and handle. The handle method's behavior is defined here,
along with other methods specific to this class. The role of this class is
primarily to act as a superclass for the other HTTP-based server classes.
=over
=item handle
$server->handle;
Expects the request method to have been used to associate a HTTP::Request
object with the server object prior to being called. This method retrieves
that object reference to get at the request being handled.
=item request(I<optional value>)
$server->request($req_object)
Gets or sets the HTTP::Request object reference that the server will process within the handle method.
=item response(I<optional value>)
$server->response(HTTP::Response->new(...));
Gets or sets the HTTP::Response object reference that the server has prepared for sending back to the client.
=item make_response(I<code>, I<body>)
$server->make_response(200, $body_xml);
Constructs and returns an object of the HTTP::Response class, using the response code and content provided.
=item make_fault(I<fault arguments>)
$server->response($server->make_fault(@data));
Creates a HTTP::Response object reference using a predefined HTTP response code to signify that a fault has occurred. The arguments are the same as those for the make_fault method of the SOAP::Server class.
=item product_tokens
This method takes no arguments and simply returns a string identifying the elements of the server class itself. It is similar to the product_tokens methods in the HTTP::Daemon and Apache classes.
=back
=head3 SOAP::Transport::HTTP::CGI
Inherits from: L<SOAP::Transport::HTTP::Server>.
This class is a direct subclass of SOAP::Transport::HTTP::Server and defines no additional methods. It includes logic in its implementation of the handle method that deals with the request headers and parameters specific to a CGI environment.
=head4 EXAMPLE CGI
The following code sample is a CGI based Web Service that converts celsius to fahrenheit:
#!/usr/bin/perl
use SOAP::Transport::HTTP;
SOAP::Transport::HTTP::CGI
->dispatch_to('C2FService')
->handle;
BEGIN {
package C2FService;
use vars qw(@ISA);
@ISA = qw(Exporter SOAP::Server::Parameters);
use SOAP::Lite;
sub c2f {
my $self = shift;
my $envelope = pop;
my $temp = $envelope->dataof("//c2f/temperature");
return SOAP::Data->name('convertedTemp' => (((9/5)*($temp->value)) + 32));
}
}
=head4 EXAMPLE APACHE::REGISTRY USAGE
Using a strictly CGI based Web Service has certain performance drawbacks. Running the same CGI under the Apache::Registery system has certain performance gains.
B<httpd.conf>
Alias /mod_perl/ "/Your/Path/To/Deployed/Modules"
<Location /mod_perl>
SetHandler perl-script
PerlHandler Apache::Registry
PerlSendHeader On
Options +ExecCGI
</Location>
B<soap.cgi>
use SOAP::Transport::HTTP;
SOAP::Transport::HTTP::CGI
->dispatch_to('/Your/Path/To/Deployed/Modules', 'Module::Name', 'Module::method')
->handle;
I<WARNING: Dynamic deployments with C<Apache::Registry> will fail because the module will be only loaded dynamically the first time. Subsequent calls will produce "denied access" errors because once the module is already in memory C<SOAP::Lite> will bypass dynamic deployment. To work around this, simply specify both the full PATH and MODULE name in C<dispatch_to()> and the module will be loaded dynamically, but will then work as if under static deployment. See F<examples/server/soap.mod_cgi> as an example.>
=head3 SOAP::Transport::HTTP::Daemon
Inherits from: L<SOAP::Transport::HTTP::Server>.
The SOAP::Transport::HTTP::Daemon class encapsulates a reference to an object of the HTTP::Daemon class (from the LWP package). The class catches methods that aren't provided locally or by the superclass and attempts to call them on the HTTP::Daemon object. Thus, all methods defined in the documentation for that class are available to this class as well. Any that conflict with methods in SOAP::Transport::HTTP::Server (such as product_tokens) go to the superclass. Additionally, the behavior of the handle method is specific to this class:
=over
=item handle
When invoked, this method enters into the typical accept loop in which it waits for a request on the socket that the daemon object maintains and deals with the content of the request. When all requests from the connection returned by the accept method of the HTTP::Daemon object have been processed, this method returns.
=back
=head4 REUSING SOCKETS ON RESTART
Often when implementing an HTTP daemon, sockets will get tied up when you try to restart the daemon server. This prevents the server from restarting. Often users will see an error like "Cannot start server: port already in use." To circumvent this, instruct SOAP::Lite to reuse open sockets using C<< Reuse => 1 >>:
my $daemon = SOAP::Transport::HTTP::Daemon
-> new (LocalPort => 80000, Reuse => 1)
=head4 EXAMPLE DAEMON SERVER
use SOAP::Transport::HTTP;
# change LocalPort to 81 if you want to test it with soapmark.pl
my $daemon = SOAP::Transport::HTTP::Daemon
-> new (LocalAddr => 'localhost', LocalPort => 80)
# specify list of objects-by-reference here
-> objects_by_reference(qw(My::PersistentIterator My::SessionIterator My::Chat))
# specify path to My/Examples.pm here
-> dispatch_to('/Your/Path/To/Deployed/Modules', 'Module::Name', 'Module::method')
;
print "Contact to SOAP server at ", $daemon->url, "\n";
$daemon->handle;
=head3 SOAP::Transport::HTTP::Apache
Inherits from: L<SOAP::Transport::HTTP::Server>.
This class provides an integration of the SOAP::Server base class with the mod_perl extension for Apache. To work as a location handler, the package provides a method called handler, for which handle is made an alias. The new method isn't functionally different from the superclass. Here are the other methods provided by this class:
=over
=item handler(I<Apache request>)
$server->handler($r)
Defines the basis for a location handler in the mod_perl fashion. The method expects an Apache request object as the parameter, from which it pulls the body of the request and calls the superclass handle method.
Note that in this class, the local method named handle is aliased to this method.
=item configure(I<Apache request>)
$server->configure(Apache->request);
Per-location configuration information can be provided to the server object using the Apache DirConfig directive and calling this method on the object itself. When invoked, the method reads the directory configuration information from Apache and looks for lines of the form:
method => param
Each line that matches the pattern is regarded as a potential method to call on the server object, with the remaining token taken as the parameter to the method. Methods that take hash references as arguments may be specified as:
method => key => param, key => param
The key/value pairs will be made into a hash reference on demand. If the server object doesn't recognize the named method as valid, it ignores the line.
=back
=head4 EXAMPLE APACHE MOD_PERL SERVER
See F<examples/server/Apache.pm> and L<Apache::SOAP> for more information.
B<httpd.conf>
<Location /soap>
SetHandler perl-script
PerlHandler SOAP::Apache
PerlSetVar options "compress_threshold => 10000"
</Location>
B<SOAP::Apache.pm>
package SOAP::Apache;
use SOAP::Transport::HTTP;
my $server = SOAP::Transport::HTTP::Apache
->dispatch_to('/Your/Path/To/Deployed/Modules', 'Module::Name', 'Module::method');
sub handler { $server->handler(@_) }
1;
See also L<Apache::SOAP>.
=head3 SOAP::Transport::HTTP::FCGI
Inherits from: L<SOAP::Transport::HTTP::CGI>.
This is an extension of the SOAP::Transport::HTTP::CGI that implements the differences needed for the FastCGI protocol. None of the methods are functionally different.
=head2 SOAP::Transport::IO
The SOAP::Transport::IO-based class allows for a sort of I/O proxying by allowing the application to configure what files or filehandles are used. This module supplies only a server class.
=head3 SOAP::Transport::IO::Server
Inherits from: L<SOAP::Server>.
The server class defined here inherits all methods from SOAP::Server, and adds two additional methods specific to the nature of the class:
=over
=item in
$server->in(IO::File->new($file));
Gets or sets the current filehandle being used as the input source.
=item out
$server->out(\*STDERR);
Gets or sets the filehandle being used as the output destination.
=back
=head2 SOAP::Transport::LOCAL
The SOAP::Transport::LOCAL module is designed to provide a no-transport client class for tracing and debugging communications traffic. It links SOAP::Client and SOAP::Server so that the same object that "sends" the request also "receives" it.
=head3 SOAP::Transport::LOCAL::Client
Inherits from: L<SOAP::Client>, L<SOAP::Server>.
The implementations of the new and send_receive methods aren't noticeably different in their interface. Their behavior warrants description, however:
=over
=item new
When the constructor creates a new object of this class, it sets up a few things beyond the usual SOAP::Client layout. The is_success method is set to a default value of 1. The dispatch_to method inherited from SOAP::Server is called with the current value of the global array @INC, allowing the client to call any methods that can be found in the current valid search path. And as with most of the constructors in this module, the optional key/value pairs are treated as method names and parameters.
=item send_receive
The implementation of this method simply passes the envelope portion of the input data to the handle method of SOAP::Server. While no network traffic results (directly) from this, it allows for debug signals to be sent through the SOAP::Trace facility.
=back
=head2 SOAP::Transport::MAILTO
This transport class manages SMTP-based sending of messages from a client perspective. It doesn't provide a server class. The class gets selected when a client object passes a URI to proxy or endpoint that starts with the characters, mailto:.
=head3 SOAP::Transport::MAILTO::Client
Inherits from: L<SOAP::Client>.
The client class for this protocol doesn't define any new methods. The constructor functions in the same style as the others class constructors. The functionality of the send_receive method is slightly different from other classes, however.
When invoked, the send_receive method uses the MIME::Lite package to encapsulate and transmit the message. Because mail messages are one-way communications (the reply being a separate process), there is no response message to be returned by the method. Instead, all the status-related attributes (code, message, status, is_success) are set, and no value is explicitly returned.
=head2 SOAP::Transport::POP3
POP3 support is limited to a server implementation. Just as the MAILTO class detailed earlier operates by sending requests without expecting to process a response, the server described here accepts request messages and dispatches them without regard for sending a response other than that which POP3 defines for successful delivery of a message.
=head3 SOAP::Transport::POP3::Server
Inherits from: L<SOAP::Server>.
The new method of this class creates an object of the Net::POP3 class to use internally for polling a specified POP3 server for incoming messages. When an object of this class is created, it expects an endpoint to be specified with a URI that begins with the characters pop:// and includes user ID and password information as well as the hostname itself.
The handle method takes the messages present in the remote mailbox and passes them (one at a time) to the superclass handle method. Each message is deleted after being routed. All messages in the POP3 mailbox are presumed to be SOAP messages.
Methods for the Net::POP3 object are detected and properly routed, allowing operations such as $server->ping( ).
This means that the endpoint string doesn't need to provide the user ID and password because the login method from the POP3 API may be used directly.
=head1 ACKNOWLEDGEMENTS
Special thanks to O'Reilly publishing which has graciously allowed SOAP::Lite to republish and redistribute large excerpts from I<Programming Web Services with Perl>, mainly the SOAP::Lite reference found in Appendix B.
=head1 COPYRIGHT
Copyright (C) 2000-2004 Paul Kulchenko. All rights reserved.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=head1 AUTHORS
Paul Kulchenko (paulclinger@yahoo.com)
Randy J. Ray (rjray@blackperl.com)
Byrne Reese (byrne@majordojo.com)
=cut

View File

@@ -0,0 +1,953 @@
# ======================================================================
#
# Copyright (C) 2000-2004 Paul Kulchenko (paulclinger@yahoo.com)
# SOAP::Lite is free software; you can redistribute it
# and/or modify it under the same terms as Perl itself.
#
# ======================================================================
package SOAP::Transport::HTTP;
use strict;
our $VERSION = '1.27'; # VERSION
use SOAP::Lite;
use SOAP::Packager;
# ======================================================================
package SOAP::Transport::HTTP::Client;
use vars qw(@ISA $COMPRESS $USERAGENT_CLASS);
$USERAGENT_CLASS = 'LWP::UserAgent';
@ISA = qw(SOAP::Client);
$COMPRESS = 'deflate';
my ( %redirect, %mpost, %nocompress );
# hack for HTTP connection that returns Keep-Alive
# miscommunication (?) between LWP::Protocol and LWP::Protocol::http
# dies after timeout, but seems like we could make it work
my $_patched = 0;
sub patch {
return if $_patched;
BEGIN { local ($^W) = 0; }
{
local $^W = 0;
sub LWP::UserAgent::redirect_ok;
*LWP::UserAgent::redirect_ok = sub { 1 }
}
{
package
LWP::Protocol;
local $^W = 0;
my $collect = \&collect; # store original
*collect = sub {
if ( defined $_[2]->header('Connection')
&& $_[2]->header('Connection') eq 'Keep-Alive' ) {
my $data = $_[3]->();
my $next =
$_[2]->header('Content-Length') &&
SOAP::Utils::bytelength($$data) ==
$_[2]->header('Content-Length')
? sub { my $str = ''; \$str; }
: $_[3];
my $done = 0;
$_[3] = sub {
$done++ ? &$next : $data;
};
}
goto &$collect;
};
}
$_patched++;
}
sub DESTROY { SOAP::Trace::objects('()') }
sub http_request {
my $self = shift;
if (@_) { $self->{'_http_request'} = shift; return $self }
return $self->{'_http_request'};
}
sub http_response {
my $self = shift;
if (@_) { $self->{'_http_response'} = shift; return $self }
return $self->{'_http_response'};
}
sub setDebugLogger {
my ($self,$logger) = @_;
$self->{debug_logger} = $logger;
}
sub new {
my $class = shift;
#print "HTTP.pm DEBUG: in sub new\n";
return $class if ref $class; # skip if we're already object...
if ( !grep { $_ eq $USERAGENT_CLASS } @ISA ) {
push @ISA, $USERAGENT_CLASS;
}
eval("require $USERAGENT_CLASS")
or die "Could not load UserAgent class $USERAGENT_CLASS: $@";
require HTTP::Request;
require HTTP::Headers;
patch() if $SOAP::Constants::PATCH_HTTP_KEEPALIVE;
my ( @params, @methods );
while (@_) {
$class->can( $_[0] )
? push( @methods, shift() => shift )
: push( @params, shift );
}
my $self = $class->SUPER::new(@params);
die
"SOAP::Transport::HTTP::Client must inherit from LWP::UserAgent, or one of its subclasses"
if !$self->isa("LWP::UserAgent");
$self->agent( join '/', 'SOAP::Lite', 'Perl',
$SOAP::Transport::HTTP::VERSION );
$self->options( {} );
$self->http_request( HTTP::Request->new() );
while (@methods) {
my ( $method, $params ) = splice( @methods, 0, 2 );
# ssl_opts takes a hash, not a ref - see RT 107924
if (ref $params eq 'HASH' && $method eq 'ssl_opts') {
$self->$method( %$params );
next;
}
$self->$method( ref $params eq 'ARRAY' ? @$params : $params );
}
SOAP::Trace::objects('()');
$self->setDebugLogger(\&SOAP::Trace::debug);
return $self;
}
sub send_receive {
my ( $self, %parameters ) = @_;
my ( $context, $envelope, $endpoint, $action, $encoding, $parts ) =
@parameters{qw(context envelope endpoint action encoding parts)};
$encoding ||= 'UTF-8';
$endpoint ||= $self->endpoint;
my $method = 'POST';
$COMPRESS = 'gzip';
$self->options->{is_compress} ||=
exists $self->options->{compress_threshold}
&& eval { require Compress::Zlib };
# Initialize the basic about the HTTP Request object
my $http_request = $self->http_request()->clone();
# $self->http_request(HTTP::Request->new);
$http_request->headers( HTTP::Headers->new );
# TODO - add application/dime
$http_request->header(
Accept => ['text/xml', 'multipart/*', 'application/soap'] );
$http_request->method($method);
$http_request->url($endpoint);
no strict 'refs';
if ($parts) {
my $packager = $context->packager;
$envelope = $packager->package( $envelope, $context );
for my $hname ( keys %{$packager->headers_http} ) {
$http_request->headers->header(
$hname => $packager->headers_http->{$hname} );
}
# TODO - DIME support
}
COMPRESS: {
my $compressed =
!exists $nocompress{$endpoint}
&& $self->options->{is_compress}
&& ( $self->options->{compress_threshold} || 0 ) < length $envelope;
my $original_encoding = $http_request->content_encoding;
while (1) {
# check cache for redirect
$endpoint = $redirect{$endpoint} if exists $redirect{$endpoint};
# check cache for M-POST
$method = 'M-POST' if exists $mpost{$endpoint};
# what's this all about?
# unfortunately combination of LWP and Perl 5.6.1 and later has bug
# in sending multibyte characters. LWP uses length() to calculate
# content-length header and starting 5.6.1 length() calculates chars
# instead of bytes. 'use bytes' in THIS file doesn't work, because
# it's lexically scoped. Unfortunately, content-length we calculate
# here doesn't work either, because LWP overwrites it with
# content-length it calculates (which is wrong) AND uses length()
# during syswrite/sysread, so we are in a bad shape anyway.
#
# what to do? we calculate proper content-length (using
# bytelength() function from SOAP::Utils) and then drop utf8 mark
# from string (doing pack with 'C0A*' modifier) if length and
# bytelength are not the same
my $bytelength = SOAP::Utils::bytelength($envelope);
if ($] < 5.008) {
$envelope = pack( 'C0A*', $envelope );
}
else {
require Encode;
$envelope = Encode::encode($encoding, $envelope);
$bytelength = SOAP::Utils::bytelength($envelope);
}
# if !$SOAP::Constants::DO_NOT_USE_LWP_LENGTH_HACK
# && length($envelope) != $bytelength;
# compress after encoding
# doing it before breaks the compressed content (#74577)
$envelope = Compress::Zlib::memGzip($envelope) if $compressed;
$http_request->content($envelope);
$http_request->protocol('HTTP/1.1');
$http_request->proxy_authorization_basic( $ENV{'HTTP_proxy_user'},
$ENV{'HTTP_proxy_pass'} )
if ( $ENV{'HTTP_proxy_user'} && $ENV{'HTTP_proxy_pass'} );
# by Murray Nesbitt
if ( $method eq 'M-POST' ) {
my $prefix = sprintf '%04d', int( rand(1000) );
$http_request->header(
Man => qq!"$SOAP::Constants::NS_ENV"; ns=$prefix! );
$http_request->header( "$prefix-SOAPAction" => $action )
if defined $action;
}
else {
$http_request->header( SOAPAction => $action )
if defined $action;
}
# $http_request->header(Expect => '100-Continue');
# allow compress if present and let server know we could handle it
$http_request->header( 'Accept-Encoding' =>
[$SOAP::Transport::HTTP::Client::COMPRESS] )
if $self->options->{is_compress};
$http_request->content_encoding(
$SOAP::Transport::HTTP::Client::COMPRESS)
if $compressed;
if ( !$http_request->content_type ) {
$http_request->content_type(
join '; ',
$SOAP::Constants::DEFAULT_HTTP_CONTENT_TYPE,
!$SOAP::Constants::DO_NOT_USE_CHARSET && $encoding
? 'charset=' . lc($encoding)
: () );
}
elsif ( !$SOAP::Constants::DO_NOT_USE_CHARSET && $encoding ) {
my $tmpType = $http_request->headers->header('Content-type');
# $http_request->content_type($tmpType.'; charset=' . lc($encoding));
my $addition = '; charset=' . lc($encoding);
$http_request->content_type( $tmpType . $addition )
if ( $tmpType !~ /$addition/ );
}
$http_request->content_length($bytelength) unless $compressed;
SOAP::Trace::transport($http_request);
&{$self->{debug_logger}}($http_request->as_string);
$self->SUPER::env_proxy if $ENV{'HTTP_proxy'};
# send and receive the stuff.
# TODO maybe eval this? what happens on connection close?
$self->http_response( $self->SUPER::request($http_request) );
SOAP::Trace::transport( $self->http_response );
&{$self->{debug_logger}}($self->http_response->as_string);
# 100 OK, continue to read?
if ( (
$self->http_response->code == 510
|| $self->http_response->code == 501
)
&& $method ne 'M-POST'
) {
$mpost{$endpoint} = 1;
}
elsif ( $self->http_response->code == 415 && $compressed ) {
# 415 Unsupported Media Type
$nocompress{$endpoint} = 1;
$envelope = Compress::Zlib::memGunzip($envelope);
$http_request->headers->remove_header('Content-Encoding');
redo COMPRESS; # try again without compression
}
else {
last;
}
}
}
$redirect{$endpoint} = $self->http_response->request->url
if $self->http_response->previous
&& $self->http_response->previous->is_redirect;
$self->code( $self->http_response->code );
$self->message( $self->http_response->message );
$self->is_success( $self->http_response->is_success );
$self->status( $self->http_response->status_line );
# Pull out any cookies from the response headers
$self->{'_cookie_jar'}->extract_cookies( $self->http_response )
if $self->{'_cookie_jar'};
my $content =
( $self->http_response->content_encoding || '' ) =~
/\b$SOAP::Transport::HTTP::Client::COMPRESS\b/o
&& $self->options->{is_compress}
? Compress::Zlib::memGunzip( $self->http_response->content )
: ( $self->http_response->content_encoding || '' ) =~ /\S/ ? die
"Can't understand returned Content-Encoding (@{[$self->http_response->content_encoding]})\n"
: $self->http_response->content;
return $self->http_response->content_type =~ m!^multipart/!i
? join( "\n", $self->http_response->headers_as_string, $content )
: $content;
}
# ======================================================================
package SOAP::Transport::HTTP::Server;
use vars qw(@ISA $COMPRESS);
@ISA = qw(SOAP::Server);
use URI;
$COMPRESS = 'deflate';
sub DESTROY { SOAP::Trace::objects('()') }
sub setDebugLogger {
my ($self,$logger) = @_;
$self->{debug_logger} = $logger;
}
sub new {
require LWP::UserAgent;
my $self = shift;
return $self if ref $self; # we're already an object
my $class = $self;
$self = $class->SUPER::new(@_);
$self->{'_on_action'} = sub {
( my $action = shift || '' ) =~ s/^(\"?)(.*)\1$/$2/;
die
"SOAPAction shall match 'uri#method' if present (got '$action', expected '@{[join('#', @_)]}'\n"
if $action
&& $action ne join( '#', @_ )
&& $action ne join( '/', @_ )
&& ( substr( $_[0], -1, 1 ) ne '/'
|| $action ne join( '', @_ ) );
};
SOAP::Trace::objects('()');
$self->setDebugLogger(\&SOAP::Trace::debug);
return $self;
}
sub BEGIN {
no strict 'refs';
for my $method (qw(request response)) {
my $field = '_' . $method;
*$method = sub {
my $self = shift->new;
@_
? ( $self->{$field} = shift, return $self )
: return $self->{$field};
};
}
}
sub handle {
my $self = shift->new;
&{$self->{debug_logger}}($self->request->content);
if ( $self->request->method eq 'POST' ) {
$self->action( $self->request->header('SOAPAction') || undef );
}
elsif ( $self->request->method eq 'M-POST' ) {
return $self->response(
HTTP::Response->new(
510, # NOT EXTENDED
"Expected Mandatory header with $SOAP::Constants::NS_ENV as unique URI"
) )
if $self->request->header('Man') !~
/^"$SOAP::Constants::NS_ENV";\s*ns\s*=\s*(\d+)/;
$self->action( $self->request->header("$1-SOAPAction") || undef );
}
else {
return $self->response(
HTTP::Response->new(405) ) # METHOD NOT ALLOWED
}
my $compressed =
( $self->request->content_encoding || '' ) =~ /\b$COMPRESS\b/;
$self->options->{is_compress} ||=
$compressed && eval { require Compress::Zlib };
# signal error if content-encoding is 'deflate', but we don't want it OR
# something else, so we don't understand it
return $self->response(
HTTP::Response->new(415) ) # UNSUPPORTED MEDIA TYPE
if $compressed && !$self->options->{is_compress}
|| !$compressed
&& ( $self->request->content_encoding || '' ) =~ /\S/;
my $content_type = $self->request->content_type || '';
# in some environments (PerlEx?) content_type could be empty, so allow it also
# anyway it'll blow up inside ::Server::handle if something wrong with message
# TBD: but what to do with MIME encoded messages in THOSE environments?
return $self->make_fault( $SOAP::Constants::FAULT_CLIENT,
"Content-Type must be 'text/xml,' 'multipart/*,' "
. "'application/soap+xml,' 'or 'application/dime' instead of '$content_type'"
)
if !$SOAP::Constants::DO_NOT_CHECK_CONTENT_TYPE
&& $content_type
&& $content_type ne 'application/soap+xml'
&& $content_type ne 'text/xml'
&& $content_type ne 'application/dime'
&& $content_type !~ m!^multipart/!;
# TODO - Handle the Expect: 100-Continue HTTP/1.1 Header
if ( defined( $self->request->header("Expect") )
&& ( $self->request->header("Expect") eq "100-Continue" ) ) {
}
# TODO - this should query SOAP::Packager to see what types it supports,
# I don't like how this is hardcoded here.
my $content =
$compressed
? Compress::Zlib::uncompress( $self->request->content )
: $self->request->content;
my $response = $self->SUPER::handle(
$self->request->content_type =~ m!^multipart/!
? join( "\n", $self->request->headers_as_string, $content )
: $content
) or return;
&{$self->{debug_logger}}($response);
$self->make_response( $SOAP::Constants::HTTP_ON_SUCCESS_CODE, $response );
}
sub make_fault {
my $self = shift;
$self->make_response(
$SOAP::Constants::HTTP_ON_FAULT_CODE => $self->SUPER::make_fault(@_)
);
return;
}
sub make_response {
my ( $self, $code, $response ) = @_;
my $encoding = $1
if $response =~ /^<\?xml(?: version="1.0"| encoding="([^\"]+)")+\?>/;
$response =~ s!(\?>)!$1<?xml-stylesheet type="text/css"?>!
if $self->request->content_type eq 'multipart/form-data';
$self->options->{is_compress} ||=
exists $self->options->{compress_threshold}
&& eval { require Compress::Zlib };
my $compressed = $self->options->{is_compress}
&& grep( /\b($COMPRESS|\*)\b/,
$self->request->header('Accept-Encoding') )
&& ( $self->options->{compress_threshold} || 0 ) <
SOAP::Utils::bytelength $response;
if ($] > 5.007 && $encoding) {
require Encode;
$response = Encode::encode( $encoding, $response );
}
$response = Compress::Zlib::compress($response) if $compressed;
# this next line does not look like a good test to see if something is multipart
# perhaps a /content-type:.*multipart\//gi is a better regex?
my ($is_multipart) =
( $response =~ /^content-type:.* boundary="([^\"]*)"/im );
$self->response(
HTTP::Response->new(
$code => undef,
HTTP::Headers->new(
'SOAPServer' => $self->product_tokens,
$compressed ? ( 'Content-Encoding' => $COMPRESS ) : (),
'Content-Type' => join( '; ',
'text/xml',
!$SOAP::Constants::DO_NOT_USE_CHARSET
&& $encoding ? 'charset=' . lc($encoding) : () ),
'Content-Length' => SOAP::Utils::bytelength $response
),
$response,
) );
$self->response->headers->header( 'Content-Type' =>
'Multipart/Related; type="text/xml"; start="<main_envelope>"; boundary="'
. $is_multipart
. '"' )
if $is_multipart;
}
# ->VERSION leaks a scalar every call - no idea why.
sub product_tokens {
join '/', 'SOAP::Lite', 'Perl', $SOAP::Transport::HTTP::VERSION;
}
# ======================================================================
package SOAP::Transport::HTTP::CGI;
use vars qw(@ISA);
@ISA = qw(SOAP::Transport::HTTP::Server);
sub DESTROY { SOAP::Trace::objects('()') }
sub new {
my $self = shift;
return $self if ref $self;
my $class = ref($self) || $self;
$self = $class->SUPER::new(@_);
SOAP::Trace::objects('()');
return $self;
}
sub make_response {
my $self = shift;
$self->SUPER::make_response(@_);
}
sub handle {
my $self = shift->new;
my $length = $ENV{'CONTENT_LENGTH'} || 0;
# if the HTTP_TRANSFER_ENCODING env is defined, set $chunked if it's chunked*
# else to false
my $chunked = (defined $ENV{'HTTP_TRANSFER_ENCODING'}
&& $ENV{'HTTP_TRANSFER_ENCODING'} =~ /^chunked.*$/) || 0;
my $content = q{};
if ($chunked) {
my $buffer;
binmode(STDIN);
while ( read( STDIN, my $buffer, 1024 ) ) {
$content .= $buffer;
}
$length = length($content);
}
if ( !$length ) {
$self->response( HTTP::Response->new(411) ) # LENGTH REQUIRED
}
elsif ( defined $SOAP::Constants::MAX_CONTENT_SIZE
&& $length > $SOAP::Constants::MAX_CONTENT_SIZE ) {
$self->response( HTTP::Response->new(413) ) # REQUEST ENTITY TOO LARGE
}
else {
if ( exists $ENV{EXPECT} && $ENV{EXPECT} =~ /\b100-Continue\b/i ) {
print "HTTP/1.1 100 Continue\r\n\r\n";
}
#my $content = q{};
if ( !$chunked ) {
my $buffer;
binmode(STDIN);
if ( defined $ENV{'MOD_PERL'} ) {
while ( read( STDIN, $buffer, $length ) ) {
$content .= $buffer;
last if ( length($content) >= $length );
}
} else {
while ( sysread( STDIN, $buffer, $length ) ) {
$content .= $buffer;
last if ( length($content) >= $length );
}
}
}
$self->request(
HTTP::Request->new(
$ENV{'REQUEST_METHOD'} || '' => $ENV{'SCRIPT_NAME'},
HTTP::Headers->new(
map { (
/^HTTP_(.+)/i
? ( $1 =~ m/SOAPACTION/ )
? ('SOAPAction')
: ($1)
: $_
) => $ENV{$_}
} keys %ENV
),
$content,
) );
$self->SUPER::handle;
}
# imitate nph- cgi for IIS (pointed by Murray Nesbitt)
my $status =
defined( $ENV{'SERVER_SOFTWARE'} )
&& $ENV{'SERVER_SOFTWARE'} =~ /IIS/
? $ENV{SERVER_PROTOCOL} || 'HTTP/1.0'
: 'Status:';
my $code = $self->response->code;
binmode(STDOUT);
print STDOUT "$status $code ", HTTP::Status::status_message($code),
"\015\012", $self->response->headers_as_string("\015\012"), "\015\012",
$self->response->content;
}
# ======================================================================
package SOAP::Transport::HTTP::Daemon;
use Carp ();
use vars qw($AUTOLOAD @ISA);
@ISA = qw(SOAP::Transport::HTTP::Server);
sub DESTROY { SOAP::Trace::objects('()') }
#sub new { require HTTP::Daemon;
sub new {
my $self = shift;
return $self if ( ref $self );
my $class = $self;
my ( @params, @methods );
while (@_) {
$class->can( $_[0] )
? push( @methods, shift() => shift )
: push( @params, shift );
}
$self = $class->SUPER::new;
# Added in 0.65 - Thanks to Nils Sowen
# use SSL if there is any parameter with SSL_* in the name
$self->SSL(1) if !$self->SSL && grep /^SSL_/, @params;
my $http_daemon = $self->http_daemon_class;
eval "require $http_daemon"
or Carp::croak $@
unless $http_daemon->can('new');
$self->{_daemon} = $http_daemon->new(@params)
or Carp::croak "Can't create daemon: $!";
# End SSL patch
$self->myuri( URI->new( $self->url )->canonical->as_string );
while (@methods) {
my ( $method, $params ) = splice( @methods, 0, 2 );
$self->$method(
ref $params eq 'ARRAY'
? @$params
: $params
);
}
SOAP::Trace::objects('()');
return $self;
}
sub SSL {
my $self = shift->new;
if (@_) {
$self->{_SSL} = shift;
return $self;
}
return $self->{_SSL};
}
sub http_daemon_class { shift->SSL ? 'HTTP::Daemon::SSL' : 'HTTP::Daemon' }
sub AUTOLOAD {
my $method = substr( $AUTOLOAD, rindex( $AUTOLOAD, '::' ) + 2 );
return if $method eq 'DESTROY';
no strict 'refs';
*$AUTOLOAD = sub { shift->{_daemon}->$method(@_) };
goto &$AUTOLOAD;
}
sub handle {
my $self = shift->new;
while ( my $c = $self->accept ) {
while ( my $r = $c->get_request ) {
$self->request($r);
$self->SUPER::handle;
eval {
local $SIG{PIPE} = sub {die "SIGPIPE"};
$c->send_response( $self->response );
};
if ($@ && $@ !~ /^SIGPIPE/) {
die $@;
}
}
# replaced ->close, thanks to Sean Meisner <Sean.Meisner@VerizonWireless.com>
# shutdown() doesn't work on AIX. close() is used in this case. Thanks to Jos Clijmans <jos.clijmans@recyfin.be>
$c->can('shutdown')
? $c->shutdown(2)
: $c->close();
$c->close;
}
}
# ======================================================================
package SOAP::Transport::HTTP::Apache;
use vars qw(@ISA);
@ISA = qw(SOAP::Transport::HTTP::Server);
sub DESTROY { SOAP::Trace::objects('()') }
sub new {
my $self = shift;
unless ( ref $self ) {
my $class = ref($self) || $self;
$self = $class->SUPER::new(@_);
SOAP::Trace::objects('()');
}
# Added this code thanks to JT Justman
# This code improves and provides more robust support for
# multiple versions of Apache and mod_perl
# mod_perl 2.0
if ( defined $ENV{MOD_PERL_API_VERSION}
&& $ENV{MOD_PERL_API_VERSION} >= 2 ) {
require Apache2::RequestRec;
require Apache2::RequestIO;
require Apache2::Const;
require Apache2::RequestUtil;
require APR::Table;
Apache2::Const->import( -compile => 'OK' );
Apache2::Const->import( -compile => 'HTTP_BAD_REQUEST' );
$self->{'MOD_PERL_VERSION'} = 2;
$self->{OK} = &Apache2::Const::OK;
}
else { # mod_perl 1.xx
die "Could not find or load mod_perl"
unless ( eval "require mod_perl" );
die "Could not detect your version of mod_perl"
if ( !defined($mod_perl::VERSION) );
if ( $mod_perl::VERSION < 1.99 ) {
require Apache;
require Apache::Constants;
Apache::Constants->import('OK');
Apache::Constants->import('HTTP_BAD_REQUEST');
$self->{'MOD_PERL_VERSION'} = 1;
$self->{OK} = &Apache::Constants::OK;
}
else {
require Apache::RequestRec;
require Apache::RequestIO;
require Apache::Const;
Apache::Const->import( -compile => 'OK' );
Apache::Const->import( -compile => 'HTTP_BAD_REQUEST' );
$self->{'MOD_PERL_VERSION'} = 1.99;
$self->{OK} = &Apache::OK;
}
}
return $self;
}
sub handler {
my $self = shift->new;
my $r = shift;
# Begin patch from JT Justman
if ( !$r ) {
if ( $self->{'MOD_PERL_VERSION'} < 2 ) {
$r = Apache->request();
}
else {
$r = Apache2::RequestUtil->request();
}
}
my $cont_len;
if ( $self->{'MOD_PERL_VERSION'} < 2 ) {
$cont_len = $r->header_in('Content-length');
}
else {
$cont_len = $r->headers_in->get('Content-length');
}
# End patch from JT Justman
my $content = "";
if ( $cont_len > 0 ) {
my $buf;
# attempt to slurp in the content at once...
$content .= $buf while ( $r->read( $buf, $cont_len ) > 0 );
}
else {
# throw appropriate error for mod_perl 2
return Apache2::Const::HTTP_BAD_REQUEST()
if ( $self->{'MOD_PERL_VERSION'} >= 2 );
return Apache::Constants::BAD_REQUEST();
}
my %headers;
if ( $self->{'MOD_PERL_VERSION'} < 2 ) {
%headers = $r->headers_in; # Apache::Table structure
} else {
%headers = %{ $r->headers_in }; # Apache2::RequestRec structure
}
$self->request(
HTTP::Request->new(
$r->method() => $r->uri,
HTTP::Headers->new( %headers ),
$content
) );
$self->SUPER::handle;
# we will specify status manually for Apache, because
# if we do it as it has to be done, returning SERVER_ERROR,
# Apache will modify our content_type to 'text/html; ....'
# which is not what we want.
# will emulate normal response, but with custom status code
# which could also be 500.
if ($self->{'MOD_PERL_VERSION'} < 2 ) {
$r->status( $self->response->code );
}
else {
$r->status_line($self->response->code);
}
# Begin JT Justman patch
if ( $self->{'MOD_PERL_VERSION'} > 1 ) {
$self->response->headers->scan(sub { $r->headers_out->add(@_) });
$r->content_type( join '; ', $self->response->content_type );
}
else {
$self->response->headers->scan( sub { $r->header_out(@_) } );
$r->send_http_header( join '; ', $self->response->content_type );
}
$r->print( $self->response->content );
return $self->{OK};
# End JT Justman patch
}
sub configure {
my $self = shift->new;
my $config = shift->dir_config;
for (%$config) {
$config->{$_} =~ /=>/
? $self->$_( {split /\s*(?:=>|,)\s*/, $config->{$_}} )
: ref $self->$_() ? () # hm, nothing can be done here
: $self->$_( split /\s+|\s*,\s*/, $config->{$_} )
if $self->can($_);
}
return $self;
}
{
# just create alias
sub handle;
*handle = \&handler
}
# ======================================================================
#
# Copyright (C) 2001 Single Source oy (marko.asplund@kronodoc.fi)
# a FastCGI transport class for SOAP::Lite.
# Updated formatting and removed dead code in new() in 2008
# by Martin Kutter
#
# ======================================================================
package SOAP::Transport::HTTP::FCGI;
use vars qw(@ISA);
@ISA = qw(SOAP::Transport::HTTP::CGI);
sub DESTROY { SOAP::Trace::objects('()') }
sub new {
require FCGI;
Exporter::require_version( 'FCGI' => 0.47 )
; # requires thread-safe interface
my $class = shift;
return $class if ref $class;
my $self = $class->SUPER::new(@_);
$self->{_fcgirq} = FCGI::Request( \*STDIN, \*STDOUT, \*STDERR );
SOAP::Trace::objects('()');
return $self;
}
sub handle {
my $self = shift->new;
my ( $r1, $r2 );
my $fcgirq = $self->{_fcgirq};
while ( ( $r1 = $fcgirq->Accept() ) >= 0 ) {
$r2 = $self->SUPER::handle;
}
return undef;
}
# ======================================================================
1;

View File

@@ -0,0 +1,79 @@
# ======================================================================
#
# Copyright (C) 2000-2001 Paul Kulchenko (paulclinger@yahoo.com)
# SOAP::Lite is free software; you can redistribute it
# and/or modify it under the same terms as Perl itself.
#
# ======================================================================
package SOAP::Transport::IO;
use strict;
our $VERSION = '1.27'; # VERSION
use IO::File;
use SOAP::Lite;
# ======================================================================
package SOAP::Transport::IO::Server;
use strict;
use Carp ();
use vars qw(@ISA);
@ISA = qw(SOAP::Server);
sub new {
my $class = shift;
return $class if ref $class;
my $self = $class->SUPER::new(@_);
return $self;
}
sub in {
my $self = shift;
$self = $self->new() if not ref $self;
return $self->{ _in } if not @_;
my $file = shift;
$self->{_in} = (defined $file && !ref $file && !defined fileno($file))
? IO::File->new($file, 'r')
: $file;
return $self;
}
sub out {
my $self = shift;
$self = $self->new() if not ref $self;
return $self->{ _out } if not @_;
my $file = shift;
$self->{_out} = (defined $file && !ref $file && !defined fileno($file))
? IO::File->new($file, 'w')
: $file;
return $self;
}
sub handle {
my $self = shift->new;
$self->in(*STDIN)->out(*STDOUT) unless defined $self->in;
my $in = $self->in;
my $out = $self->out;
my $result = $self->SUPER::handle(join '', <$in>);
no strict 'refs';
print {$out} $result
if defined $out;
return;
}
# ======================================================================
1;
__END__

View File

@@ -0,0 +1,66 @@
# ======================================================================
#
# Copyright (C) 2000-2001 Paul Kulchenko (paulclinger@yahoo.com)
# SOAP::Lite is free software; you can redistribute it
# and/or modify it under the same terms as Perl itself.
#
# ======================================================================
package SOAP::Transport::LOCAL;
use strict;
our $VERSION = '1.27'; # VERSION
# ======================================================================
package SOAP::Transport::LOCAL::Client;
use SOAP::Lite;
use vars qw(@ISA);
our @ISA = qw(SOAP::Client SOAP::Server);
sub new {
my $class = shift;
return $class if ref $class;
my @method_from;
while (@_) {
if ($class->can($_[0])) {
push(@method_from, shift() => shift);
}
else
{
# ignore unknown arguments
shift;
}
}
my $self = $class->SUPER::new();
$self->is_success(1); # it's difficult to fail in this module
$self->dispatch_to(@INC);
while (@method_from) {
my($method, $param_ref) = splice(@method_from,0,2);
$self->$method(ref $param_ref eq 'ARRAY'
? @$param_ref
: $param_ref)
}
return $self;
}
sub send_receive {
my ($self, %parameters) = @_;
my ($envelope, $endpoint, $action) =
@parameters{qw(envelope endpoint action)};
SOAP::Trace::debug($envelope);
my $response = $self->SUPER::handle($envelope);
SOAP::Trace::debug($response);
return $response;
}
# ======================================================================
1;
__END__

View File

@@ -0,0 +1,80 @@
# ======================================================================
#
# Copyright (C) 2007 Martin Kutter.
# Part of SOAP-Lite, Copyright (C) 2000-2001 Paul Kulchenko
# (paulclinger@yahoo.com)
# You may distribute/modify this file under the same terms as perl itself.
#
# $ID: $
#
# ======================================================================
package SOAP::Transport::LOOPBACK;
use strict;
package SOAP::Transport::LOOPBACK::Client;
use strict;
our $VERSION = '1.27'; # VERSION
use vars qw(@ISA);
use SOAP::Lite;
@ISA = qw(SOAP::Client);
sub new {
return $_[0] if ref $_[0];
return bless {}, $_[0];
}
sub send_receive {
my($self, %parameters) = @_;
$self->code(200);
$self->message('OK');
$self->is_success(1);
$self->status('200 OK');
return $parameters{envelope};
}
1;
__END__
=pod
=head1 NAME
SOAP::Transport::LOOPBACK - Test loopback transport backend (Client only)
=head1 DESCRIPTION
SOAP::Transport::LOOPBACK is a test transport backend for SOAP::Lite.
It just returns the XML request as response, thus allowing to test the
complete application stack of client applications from the front end down to
the transport layer without actually sending data over the wire.
Using this transport backend is triggered by setting a loopback:// URL.
Sending requests through this transport backend alway succeeds with the
following states:
status: 200 OK
code: 200
message: OK
=head1 COPYRIGHT
Copyright (C) 2007 Martin Kutter. All rights reserved.
This file is part of SOAP-Lite, Copyright (C) 2000-2001 Paul Kulchenko.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=head1 AUTHOR
Martin Kutter E<lt>martin.kutter fen-net.deE<gt>
=cut

View File

@@ -0,0 +1,93 @@
# ======================================================================
#
# Copyright (C) 2000-2001 Paul Kulchenko (paulclinger@yahoo.com)
# SOAP::Lite is free software; you can redistribute it
# and/or modify it under the same terms as Perl itself.
#
# ======================================================================
package SOAP::Transport::MAILTO;
use strict;
our $VERSION = '1.27'; # VERSION
use MIME::Lite;
use URI;
# ======================================================================
package SOAP::Transport::MAILTO::Client;
use SOAP::Lite;
use vars qw(@ISA);
@ISA = qw(SOAP::Client);
sub DESTROY { SOAP::Trace::objects('()') }
sub new {
my $class = shift;
return $class if ref $class;
my(@params, @methods);
while (@_) { $class->can($_[0]) ? push(@methods, shift() => shift) : push(@params, shift) }
my $self = bless {@params} => $class;
while (@methods) { my($method, $params) = splice(@methods,0,2);
$self->$method(ref $params eq 'ARRAY' ? @$params : $params)
}
SOAP::Trace::objects('()');
return $self;
}
sub send_receive {
my($self, %parameters) = @_;
my($envelope, $endpoint, $action) =
@parameters{qw(envelope endpoint action)};
$endpoint ||= $self->endpoint;
my $uri = URI->new($endpoint);
%parameters = (%$self,
map {URI::Escape::uri_unescape($_)}
map {split/=/,$_,2}
split /[&;]/, $uri->query || '');
my $msg = MIME::Lite->new(
To => $uri->to,
Type => 'text/xml',
Encoding => $parameters{Encoding} || 'base64',
Data => $envelope,
$parameters{From}
? (From => $parameters{From})
: (),
$parameters{'Reply-To'}
? ('Reply-To' => $parameters{'Reply-To'})
: (),
$parameters{Subject}
? (Subject => $parameters{Subject})
: (),
);
$msg->replace('X-Mailer' => join '/', 'SOAP::Lite', 'Perl', SOAP::Transport::MAILTO->VERSION);
$msg->add(SOAPAction => $action);
SOAP::Trace::transport($msg);
SOAP::Trace::debug($msg->as_string);
MIME::Lite->send(map {exists $parameters{$_}
? ($_ => $parameters{$_})
: ()} 'smtp', 'sendmail');
eval { local $SIG{__DIE__}; $MIME::Lite::AUTO_CC = 0; $msg->send };
(my $code = $@) =~ s/ at .*\n//;
$self->code($code);
$self->message($code);
$self->is_success(!defined $code || $code eq '');
$self->status($code);
return;
}
# ======================================================================
1;
__END__

View File

@@ -0,0 +1,121 @@
# ======================================================================
#
# Copyright (C) 2000-2001 Paul Kulchenko (paulclinger@yahoo.com)
# SOAP::Lite is free software; you can redistribute it
# and/or modify it under the same terms as Perl itself.
#
# ======================================================================
package SOAP::Transport::POP3;
use strict;
our $VERSION = '1.27'; # VERSION
use Net::POP3;
use URI;
# ======================================================================
package SOAP::Transport::POP3::Server;
use Carp ();
use vars qw(@ISA $AUTOLOAD);
@ISA = qw(SOAP::Server);
sub DESTROY { my $self = shift; $self->quit if $self->{_pop3server} }
sub new {
my $class = shift;
return $class if ref $class;
my $address = shift;
Carp::carp "URLs without 'pop://' scheme are deprecated. Still continue"
if $address =~ s!^(pop://)?!pop://!i && !$1;
my $server = URI->new($address);
my $self = $class->SUPER::new(@_);
$self->{_pop3server} = Net::POP3->new($server->host_port)
or Carp::croak "Can't connect to '@{[$server->host_port]}': $!";
my $method = ! $server->auth || $server->auth eq '*'
? 'login'
: $server->auth eq '+APOP'
? 'apop'
: Carp::croak "Unsupported authentication scheme '@{[$server->auth]}'";
$self->{_pop3server}->$method( split m{:}, $server->user() )
or Carp::croak "Can't authenticate to '@{[$server->host_port]}' with '$method' method"
if defined $server->user;
return $self;
}
sub AUTOLOAD {
my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2);
return if $method eq 'DESTROY';
no strict 'refs';
*$AUTOLOAD = sub { shift->{_pop3server}->$method(@_) };
goto &$AUTOLOAD;
}
sub handle {
my $self = shift->new;
my $messages = $self->list or return;
# fixes [ 1.17700 ] POP3 Processes Messages Out of Order
foreach my $msgid (sort { $a <=> $b } (keys(%{$messages}) ) ) {
# foreach my $msgid (keys %$messages) {
$self->SUPER::handle(join '', @{$self->get($msgid)});
} continue {
$self->delete($msgid);
}
return scalar keys %$messages;
}
sub make_fault { return }
# ======================================================================
1;
__END__
=head1 NAME
SOAP::Transport::POP3 - Server side POP3 support for SOAP::Lite
=head1 SYNOPSIS
use SOAP::Transport::POP3;
my $server = SOAP::Transport::POP3::Server
-> new('pop://pop.mail.server')
# if you want to have all in one place
# -> new('pop://user:password@pop.mail.server')
# or, if you have server that supports MD5 protected passwords
# -> new('pop://user:password;AUTH=+APOP@pop.mail.server')
# specify list of objects-by-reference here
-> objects_by_reference(qw(My::PersistentIterator My::SessionIterator My::Chat))
# specify path to My/Examples.pm here
-> dispatch_to('/Your/Path/To/Deployed/Modules', 'Module::Name', 'Module::method')
;
# you don't need to use next line if you specified your password in new()
$server->login('user' => 'password') or die "Can't authenticate to POP3 server\n";
# handle will return number of processed mails
# you can organize loop if you want
do { $server->handle } while sleep 10;
# you may also call $server->quit explicitly to purge deleted messages
=head1 DESCRIPTION
=head1 COPYRIGHT
Copyright (C) 2000-2001 Paul Kulchenko. All rights reserved.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=head1 AUTHOR
Paul Kulchenko (paulclinger@yahoo.com)
=cut

View File

@@ -0,0 +1,313 @@
# ======================================================================
#
# Copyright (C) 2000-2001 Paul Kulchenko (paulclinger@yahoo.com)
# SOAP::Lite is free software; you can redistribute it
# and/or modify it under the same terms as Perl itself.
#
# $Id: TCP.pm 384 2011-08-16 17:08:08Z kutterma $
#
# ======================================================================
package SOAP::Transport::TCP;
use strict;
our $VERSION = '1.27'; # VERSION
use URI;
use IO::Socket;
use IO::Select;
use IO::SessionData;
# ======================================================================
package # hide from PAUSE
URI::tcp; # ok, let's do 'tcp://' scheme
our $VERSION = 0.715;
require URI::_server;
@URI::tcp::ISA=qw(URI::_server);
# ======================================================================
package SOAP::Transport::TCP::Client;
our $VERSION = 0.715;
use vars qw(@ISA);
require SOAP::Lite;
@ISA = qw(SOAP::Client);
sub DESTROY { SOAP::Trace::objects('()') }
sub new {
my $self = shift;
unless (ref $self) {
my $class = ref($self) || $self;
my(@params, @methods);
while (@_) { $class->can($_[0]) ? push(@methods, shift() => shift) : push(@params, shift) }
$self = bless {@params} => $class;
while (@methods) { my($method, $params) = splice(@methods,0,2);
$self->$method(ref $params eq 'ARRAY' ? @$params : $params)
}
# use SSL if there is any parameter with SSL_* in the name
$self->SSL(1) if !$self->SSL && grep /^SSL_/, keys %$self;
SOAP::Trace::objects('()');
}
return $self;
}
sub SSL {
my $self = shift->new;
@_ ? ($self->{_SSL} = shift, return $self) : return $self->{_SSL};
}
sub io_socket_class { shift->SSL ? 'IO::Socket::SSL' : 'IO::Socket::INET' }
sub syswrite {
my($self, $sock, $data) = @_;
my $timeout = $sock->timeout;
my $select = IO::Select->new($sock);
my $len = length $data;
while (length $data > 0) {
return unless $select->can_write($timeout);
local $SIG{PIPE} = 'IGNORE';
# added length() to make it work on Mac. Thanks to Robin Fuller <rfuller@broadjump.com>
my $wc = syswrite($sock, $data, length($data));
if (defined $wc) {
substr($data, 0, $wc) = '';
} elsif (!IO::SessionData::WOULDBLOCK($!)) {
return;
}
}
return $len;
}
sub sysread {
my($self, $sock) = @_;
my $timeout = $sock->timeout;
my $select = IO::Select->new($sock);
my $result = '';
my $data;
while (1) {
return unless $select->can_read($timeout);
my $rc = sysread($sock, $data, 4096);
if ($rc) {
$result .= $data;
} elsif (defined $rc) {
return $result;
} elsif (!IO::SessionData::WOULDBLOCK($!)) {
return;
}
}
}
sub send_receive {
my($self, %parameters) = @_;
my($envelope, $endpoint, $action) =
@parameters{qw(envelope endpoint action)};
$endpoint ||= $self->endpoint;
warn "URLs with 'tcp:' scheme are deprecated. Use 'tcp://'. Still continue\n"
if $endpoint =~ s!^tcp:(//)?!tcp://!i && !$1;
my $uri = URI->new($endpoint);
local($^W, $@, $!);
my $socket = $self->io_socket_class;
eval "require $socket" or Carp::croak $@ unless UNIVERSAL::can($socket => 'new');
my $sock = $socket->new (
PeerAddr => $uri->host, PeerPort => $uri->port, Proto => $uri->scheme, %$self
);
SOAP::Trace::debug($envelope);
# bytelength hack. See SOAP::Transport::HTTP.pm for details.
my $bytelength = SOAP::Utils::bytelength($envelope);
$envelope = pack('C0A*', $envelope)
if !$SOAP::Constants::DO_NOT_USE_LWP_LENGTH_HACK && length($envelope) != $bytelength;
my $result;
if ($sock) {
$sock->blocking(0);
$self->syswrite($sock, $envelope) and
$sock->shutdown(1) and # stop writing
$result = $self->sysread($sock);
}
SOAP::Trace::debug($result);
my $code = $@ || $!;
$self->code($code);
$self->message($code);
$self->is_success(!defined $code || $code eq '');
$self->status($code);
return $result;
}
# ======================================================================
package SOAP::Transport::TCP::Server;
use IO::SessionSet;
use Carp ();
use vars qw($AUTOLOAD @ISA);
@ISA = qw(SOAP::Server);
our $VERSION = 0.715;
sub DESTROY { SOAP::Trace::objects('()') }
sub new {
my $self = shift;
unless (ref $self) {
my $class = ref($self) || $self;
my(@params, @methods);
while (@_) { $class->can($_[0]) ? push(@methods, shift() => shift) : push(@params, shift) }
$self = $class->SUPER::new(@methods);
# use SSL if there is any parameter with SSL_* in the name
$self->SSL(1) if !$self->SSL && grep /^SSL_/, @params;
my $socket = $self->io_socket_class;
eval "require $socket" or Carp::croak $@ unless UNIVERSAL::can($socket => 'new');
$self->{_socket} = $socket->new(Proto => 'tcp', @params)
or Carp::croak "Can't open socket: $!";
SOAP::Trace::objects('()');
}
return $self;
}
sub SSL {
my $self = shift->new;
@_ ? ($self->{_SSL} = shift, return $self) : return $self->{_SSL};
}
sub io_socket_class { shift->SSL ? 'IO::Socket::SSL' : 'IO::Socket::INET' }
sub AUTOLOAD {
my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2);
return if $method eq 'DESTROY';
no strict 'refs';
*$AUTOLOAD = sub { shift->{_socket}->$method(@_) };
goto &$AUTOLOAD;
}
sub handle {
my $self = shift->new;
my $sock = $self->{_socket};
my $session_set = IO::SessionSet->new($sock);
my %data;
while (1) {
my @ready = $session_set->wait($sock->timeout);
for my $session (grep { defined } @ready) {
my $data;
if (my $rc = $session->read($data, 4096)) {
$data{$session} .= $data if $rc > 0;
} else {
$session->write($self->SUPER::handle(delete $data{$session}));
$session->close;
}
}
}
}
# ======================================================================
1;
__END__
=head1 NAME
SOAP::Transport::TCP - TCP Transport Support for SOAP::Lite
=head2 SOAP::Transport::TCP
The classes provided by this module implement direct TCP/IP communications methods for both clients and servers.
The connections don't use HTTP or any other higher-level protocol. These classes are selected when the client or server object being created uses an endpoint URI that starts with tcp://. Both client and server classes support using Secure Socket Layer if it is available. If any of the parameters to a new method from either of the classes begins with SSL_ (such as SSL_server in place of Server), the class attempts to load the IO::Socket::SSL package and use it to create socket objects.
Both of the following classes catch methods that are intended for the socket objects and pass them along, allowing calls such as $client->accept( ) without including the socket class in the inheritance tree.
=head3 SOAP::Transport::TCP::Client
Inherits from: L<SOAP::Client>.
The TCP client class defines only two relevant methods beyond new and send_receive. These methods are:
=over
=item SSL(I<optional new boolean value>)
if ($client->SSL) # Execute only if in SSL mode
Reflects the attribute that denotes whether the client object is using SSL sockets for communications.
=item io_socket_class
($client->io_socket_class)->new(%options);
Returns the name of the class to use when creating socket objects for internal use in communications. As implemented, it returns one of IO::Socket::INET or IO::Socket::SSL, depending on the return value of the previous SSL method.
=back
If an application creates a subclass that inherits from this client class, either method is a likely target for overloading.
The new method behaves identically to most other classes, except that it detects the presence of SSL-targeted values in the parameter list and sets the SSL method appropriately if they are present.
The send_receive method creates a socket of the appropriate class and connects to the configured endpoint. It then sets the socket to nonblocking I/O, sends the message, shuts down the client end of the connection (preventing further writing), and reads the response back from the server. The socket object is discarded after the response and
appropriate status codes are set on the client object.
=head3 SOAP::Transport::TCP::Server
Inherits from: L<SOAP::Server>.
The server class also defines the same two additional methods as in the client class:
=over
=item SSL(I<optional new boolean value>)
if ($client->SSL) # Execute only if in SSL mode
Reflects the attribute that denotes whether the client object is using SSL sockets for communications.
=item io_socket_class
($client->io_socket_class)->new(%options);
Returns the name of the class to use when creating socket objects for internal use in communications. As implemented, it returns one of IO::Socket::INET or IO::Socket::SSL, depending on the return value of the previous SSL method. The new method also manages the automatic selection of SSL in the same fashion as the client class does.
The handle method in this server implementation isn't designed to be called once with each new request. Rather, it is called with no arguments, at which time it enters into an infinite loop of waiting for a connection, reading the request, routing the request and sending back the serialized response. This continues until the process itself is interrupted by an untrapped signal or similar means.
=back
=head1 COPYRIGHT
Copyright (C) 2000-2004 Paul Kulchenko. All rights reserved.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=head1 AUTHORS
Written by Paul Kulchenko.
Split from SOAP::Lite and SOAP-Transport-TCP packaging by Martin Kutter
=cut

43
database/perl/vendor/lib/SOAP/Utils.pod vendored Normal file
View File

@@ -0,0 +1,43 @@
# ======================================================================
#
# Copyright (C) 2000-2003 Paul Kulchenko (paulclinger@yahoo.com)
# SOAP::Lite is free software; you can redistribute it
# and/or modify it under the same terms as Perl itself.
#
# ======================================================================
=pod
=head1 NAME
SOAP::Utils - a utility package for SOAP::Lite
=head1 DESCRIPTION
This class gives you access to a number of subroutines to assist in data formatting, encoding, etc. Many of the subroutines are private, and are not documented here, but a few are made public.
=head1 METHODS
=over
=item format_datetime
Returns a valid xsd:datetime string given a time object returned by Perl's localtime function. Usage:
print SOAP::Utils::format_datetime(localtime);
=back
=head1 COPYRIGHT
Copyright (C) 2000-2004 Paul Kulchenko. All rights reserved.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=head1 AUTHORS
Byrne Reese (byrne@majordojo.com)
=cut