dinislage/SOAP-WSDL
1
0 Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

import SOAP-WSDL 2.00.10 from CPAN

Browse Source 
git-cpan-module:   SOAP-WSDL
git-cpan-version:  2.00.10
git-cpan-authorid: MKUTTER
git-cpan-file:     authors/id/M/MK/MKUTTER/SOAP-WSDL-2.00.10.tar.gz
This commit is contained in:
Martin Kutter authored and Michael G. Schwern committed 2009-12-12 19:49:03 -08:00
1 parent 3b30e8d0e2
commit 9023aa06a4
97 files changed
+895 -375
Download Patch File Download Diff File Expand all files Collapse all files

No files matched your search

t/CodeFirst/ComplexType.pm
Regular → Executable
View File
File mode changed.
t/CodeFirst/element.pm
Regular → Executable
View File
File mode changed.
t/CodeFirst/sequence.pm
Regular → Executable
View File
File mode changed.
t/CodeFirst/test.pl
Regular → Executable
+68 -9
View File
@@ -5,26 +5,85 @@ use lib '../lib';
use base q{CodeFirst};
sub test :WebMethod(
action => "test",
returns => "bar",
header => "bam",
body => "baz"
name => "sayHello",
action => "uri:helloWorld/sayHello",
request_body => "CodeFirst::HelloRequest",
response_body => "CodeFirst::HelloResponse"
) {
# return either [ \%body, \%header ]
# or \%body
# or [ Body->new(), Header->new ]
# or even [ Body->new(), [ Header1->new(), Header2->new() ]]
# or any combination of that
return [{
},
{
}];
}
=pod
... would translate to
<element name="test">
<complexType>
<sequence>
<element name="testRequest" type="bam"/>
</sequence>
</complexType>
</element>
=cut
=pod
sub test2 :WebMethod(
action => "test2",
returns => "bar",
header => "bam",
body => "baz"
request_header => "bar",
reqest_body => "bam",
response_header => "bam",
response_body => "baz"
) {
}
=cut
package main;
use Data::Dumper;
my $test = testCodeFirst->new();
# print Dumper $test->_action_map;
print Dumper $test->get_transport()->get_action_map_ref();
# print Dumper $test->_action_map;
# print Dumper $test->get_transport()->get_action_map_ref();
#print $test->get_wsdl("http://localhost/foo")->toString();
use CodeFirst::Serializer;
use CodeFirst::Deserializer;
use CodeFirst::HelloResponse;
use CodeFirst::HelloRequest;
my $serializer = CodeFirst::Serializer->new();
#print $serializer->serialize("sayHelloResponse", "uri:MooseX.SOAP.CodeFirst", CodeFirst::HelloResponse->new(
# Result => "Test"
#))->toString;
#
my $xml = $serializer->serialize("sayHello", "uri:MooseX.SOAP.testCodeFirst", CodeFirst::HelloRequest->new(
Name => 'Flint',
GivenName => 'Erol',
))->toString;
#print "\n\n";
print $xml, "\n";
print $test->get_wsdl()->toString(), "\n";
my $deserializer = CodeFirst::Deserializer->new();
$deserializer->schema( $test->schema );
print Dumper $deserializer->deserialize($xml, 'CodeFirst::HelloRequest');
1;
t/SOAP/WSDL/Client.t
+70 -40
View File
@@ -1,66 +1,96 @@
package FaultDeserializer;
use strict;
use warnings;
use Test::More tests => 15;
use SOAP::WSDL::SOAP::Typelib::Fault11;
sub new { bless {}, shift }
sub deserialize {
die SOAP::WSDL::SOAP::Typelib::Fault11->new( {} );
}
package main;
use strict;
use warnings;
use Test::More tests => 16;
use SOAP::WSDL::Transport::Loopback;
use Scalar::Util qw(blessed);
use_ok qw(SOAP::WSDL::Client);
{
no warnings qw(redefine once);
*SOAP::WSDL::Factory::Transport::get_transport = sub {
my ($self, $url , %args_of) = @_;
my ( $self, $url, %args_of ) = @_;
if (%args_of) {
is $args_of{foo}, 'bar';
}
};
}
ok my $client = SOAP::WSDL::Client->new();
ok $client = SOAP::WSDL::Client->new({
proxy => 'http://localhost',
});
sub test_client_basics {
ok my $client = SOAP::WSDL::Client->new();
ok $client = SOAP::WSDL::Client->new( {proxy => 'http://localhost',} );
is $client->get_content_type(), 'text/xml; charset=utf-8';
is $client->get_endpoint(), 'http://localhost';
$client->set_proxy( 'http://localhost', foo => 'bar', );
is $client->get_content_type(), 'text/xml; charset=utf-8';
#TODO is this behaviour still required? declare as deprecated and remove...
$client->set_proxy( ['http://localhost', foo => 'bar',] );
is $client->get_endpoint(), 'http://localhost';
is $client->get_proxy(), $client->get_transport(),
'get_proxy returns same as get_transport';
$client->set_proxy('http://localhost',
foo => 'bar',
);
ok $client->set_soap_version('1.1');
is $client->get_soap_version(), '1.1';
#TODO is this behaviour still required? declare as deprecated and remove...
$client->set_proxy(
[ 'http://localhost',
foo => 'bar',
]
);
$client->set_deserializer_args( {strict => 0} );
is $client->get_deserializer_args()->{strict}, 0;
}
sub test_call {
my $client = SOAP::WSDL::Client->new();
$client->no_dispatch(1);
$client->set_serializer('main');
my $serialize = $client->call(
{operation => 'testMethod'},
{foo => 'bar'},
{bar => 'baz'} );
is $serialize->{body}->{foo}, 'bar';
is $serialize->{header}->{bar}, 'baz';
is $client->get_proxy(), $client->get_transport(), 'get_proxy returns same as get_transport';
# Old calling style compatibility test - foo => bar is body...
$serialize = $client->call( {operation => 'testMethod'}, foo => 'bar' );
is $serialize->{body}->{foo}, 'bar';
ok $client->set_soap_version('1.1');
is $client->get_soap_version(), '1.1';
$client->no_dispatch(1);
$client->set_serializer('main');
my $serialize = $client->call({
operation => 'testMethod'
}, { foo => 'bar'}, { bar => 'baz'});
is $serialize->{ body }->{ foo }, 'bar';
is $serialize->{ header }->{ bar }, 'baz';
# Old calling style compatibility test - foo => bar is body...
$serialize = $client->call({
operation => 'testMethod'
}, foo => 'bar');
is $serialize->{ body }->{ foo }, 'bar';
# Old calling style compatibility test - foo => bar is body...
$serialize = $client->call('testMethod', foo => 'bar');
is $serialize->{ body }->{ foo }, 'bar';
# Old calling style compatibility test - foo => bar is body...
$serialize = $client->call( 'testMethod', foo => 'bar' );
is $serialize->{body}->{foo}, 'bar';
}
sub serialize {
my $self = shift;
return shift;
}
$client->set_deserializer_args({ strict => 0 });
is $client->get_deserializer_args()->{ strict }, 0;
sub test_deserializer_fault {
my $client = SOAP::WSDL::Client->new();
$client->set_deserializer( FaultDeserializer->new() );
$client->set_transport( SOAP::WSDL::Transport::Loopback->new() );
my $fault = $client->call(
{operation => 'testMethod'},
{foo => 'bar'},
{bar => 'baz'} );
ok( (blessed $fault and $fault->isa('SOAP::WSDL::SOAP::Typelib::Fault11')),
'Return fault on throwing during deserialization ' . $@);
}
test_client_basics();
test_call();
test_deserializer_fault();
t/SOAP/WSDL/Generator/XSD_dot_names.t
+3 -1
View File
@@ -1,4 +1,4 @@
use Test::More tests => 14;
use Test::More tests => 15;
use File::Basename qw(dirname);
use File::Spec;
use File::Path;
@@ -63,6 +63,8 @@ use_ok qw(MyInterfaces::My::SOAP::testService::testPort);
use_ok qw(MyServer::My::SOAP::testService::testPort);
use_ok qw(MyTypes::testComplexTypeRestriction);
use_ok qw(MyTypes::testComplexTypeAll);
# type with dot in name including atomic type
use_ok qw(MyTypes::test::ComplexTypeElementAtomicSimpleType);
SKIP: {
eval { require Test::Pod::Content; }
or skip 'Cannot test pod content without Test::Pod::Content', 6;
t/SOAP/WSDL/XSD/Typelib/ComplexType.t
+11 -9
View File
@@ -73,16 +73,18 @@ __PACKAGE__->_factory(
);
package MyElementSimpleContent;
use base qw(
SOAP::WSDL::XSD::Typelib::Element
SOAP::WSDL::XSD::Typelib::ComplexType
SOAP::WSDL::XSD::Typelib::Builtin::string
);
{
use base qw(
SOAP::WSDL::XSD::Typelib::Element
SOAP::WSDL::XSD::Typelib::ComplexType
SOAP::WSDL::XSD::Typelib::Builtin::string
);
__PACKAGE__->__set_name( 'MyElementSimpleContent' );
sub __get_attr_class { 'MyElement::_ATTR' };
__PACKAGE__->__set_name( 'MyElementSimpleContent' );
sub __get_attr_class { 'MyElement::_ATTR' };
sub get_xmlns { 'http://www.w3.org/2001/XMLSchema' }
}
package main;
use Test::More tests => 127;
use Storable;
@@ -392,4 +394,4 @@ ok ! exists $obj->as_hash_ref(1)->{ xmlattr };
local $SOAP::WSDL::XSD::Typelib::ComplexType::AS_HASH_REF_WITHOUT_ATTRIBUTES = 1;
ok ! exists $obj->as_hash_ref()->{ xmlattr };
ok ! exists $obj->as_hash_ref(1)->{ xmlattr };
}
}
t/acceptance/wsdl/generator_test_dot_names.wsdl
+6 -6
View File
@@ -104,7 +104,7 @@
</xsd:complexContent>
</xsd:complexType>
<xsd:complexType name="testComplexTypeChoice">
<xsd:complexType name="test.ComplexTypeChoice">
<xsd:annotation>
<xsd:documentation>ComplexType Test</xsd:documentation>
</xsd:annotation>
@@ -179,14 +179,14 @@
<xsd:element name="Header" type="tns:testComplexTypeSequence" />
<xsd:element name="testHeader" type="tns:testComplexTypeSequence" />
<xsd:element name="testChoice" type="tns:testComplexTypeChoice" />
<xsd:element name="test.Choice" type="tns:test.ComplexTypeChoice" />
<xsd:complexType name="testComplexTypeElementAtomicSimpleType">
<xsd:complexType name="test.ComplexTypeElementAtomicSimpleType">
<xsd:sequence>
<xsd:element name="testString" type="xsd:string"
minOccurs="0" />
<xsd:element name="testAtomicSimpleTypeElement"
<xsd:element name="test.AtomicSimpleTypeElement"
minOccurs="0">
<xsd:simpleType>
<xsd:restriction base="xsd:decimal">
@@ -209,7 +209,7 @@
</xsd:schema>
</types>
<message name="testChoice">
<part name="parameters" element="tns:testChoice" />
<part name="parameters" element="tns:test.Choice" />
</message>
<message name="testRequest">
<part name="testAll" element="tns:testElementString" />
@@ -219,7 +219,7 @@
</message>
<message name="testMultiPartWarning">
<part name="testAll" element="tns:testElementString" />
<part name="parameters" element="tns:testChoice" />
<part name="parameters" element="tns:test.Choice" />
</message>
<message name="testHeaderRequest">
<part name="testBody" element="tns:testHeader" />
t/lib/CodeFirst.pm
Regular → Executable
+229 -41
View File
@@ -1,63 +1,251 @@
package CodeFirst;
use strict;
use warnings;
use Moose;
use Carp;
use Class::Std::Fast::Storable;
use Scalar::Util qw(blessed);
use XML::LibXML;
use parent qw(Attribute::Handlers);
our $VERSION = 0.1;
$Carp::Internal{attributes}++;
my %ACTION_MAP_OF;
my %ACTION_DATA_OF;
my %SCHEMA_DATA_OF;
my %transport_class_of :ATTR(:name<transport_class> :default<SOAP::WSDL::Server::CGI>);
my %transport_of : ATTR(:name<transport> :default<()>);
my %dispatch_to : ATTR(:name<dispatch_to> :default<()>);
has 'schema' => is => 'rw';
sub START {
my ( $self, $ident, $arg_ref ) = @_;
my $class = ref $self;
eval "require $transport_class_of{ $ident }"
or die "Cannot load transport class $transport_class_of{ $ident }: $@";
$transport_of{$ident} = $transport_class_of{$ident}->new( {
action_map_ref => $ACTION_MAP_OF{$class},
dispatch_to => $self
} );
}
has 'typeMap' => is => 'rw',
isa => 'CodeFirst::Types',
default => sub { CodeFirst::Types->new() };
sub handle {
$transport_of{${$_[0]}}->handle( @_[1 .. $#_] );
}
sub WebMethod : ATTR {
my (
$class, $symbol, $referent, $attr,
$data, $phase, $filename, $linenum
) = @_;
sub _action_map {
my $class = ref $_[0];
return $ACTION_MAP_OF{$class};
}
no warnings qw(redefine);
sub MODIFY_CODE_ATTRIBUTES {
my ( $class, $code, @attribute_from ) = @_;
my ($content) = grep { $_ =~ m{^WebMethod}xms } @attribute_from
or return @attribute_from;
$content =~ s{^WebMethod}{}xms;
my %parameter_of = eval $content;
my %parameter_of;
eval { %parameter_of = @{$data} };
if ($@) {
die "Cannot parse :WebMethod arguments: $@ at " . Carp::shortmess;
}
$ACTION_MAP_OF{$class}->{$parameter_of{action}} = $code;
$ACTION_MAP_OF{$class}->{$parameter_of{action}} = $symbol;
# print Dumper \%ACTION_MAP_OF;
$ACTION_DATA_OF{$class}->{$parameter_of{action}} = {
name => $parameter_of{name},
request => {
body => $parameter_of{request_body},
header => $parameter_of{request_header},
},
response => {
body => $parameter_of{response_body},
header => $parameter_of{response_header},
}};
return Class::Std::Fast::MODIFY_CODE_ATTRIBUTES( $class, $code,
@attribute_from );
$SCHEMA_DATA_OF{$class}->{$parameter_of{request_header}} = undef
if ( $parameter_of{request_header} );
$SCHEMA_DATA_OF{$class}->{$parameter_of{request_body}} = undef
if ( $parameter_of{request_body} );
$SCHEMA_DATA_OF{$class}->{$parameter_of{response_header}} = undef
if ( $parameter_of{response_header} );
$SCHEMA_DATA_OF{$class}->{$parameter_of{response_body}} = undef
if ( $parameter_of{response_body} );
#use Data::Dumper;
#print Dumper \%ACTION_DATA_OF;
#return Class::Std::Fast::MODIFY_CODE_ATTRIBUTES( $class, $code,
# @attribute_from );
return; # @attribute_from;
}
sub get_wsdl {
my $self = shift;
my $class = ref $self;
my $address = shift;
my $className = $class;
$className =~ s{::}{.}xg;
my XML::LibXML::Document $doc = XML::LibXML::Document->new();
my $root = XML::LibXML::Element->new("definitions");
$root->setNamespace( 'http://schemas.xmlsoap.org/wsdl/', undef, 1 );
$root->setNamespace( 'http://www.w3.org/2001/XMLSchema', 'xs', 0 );
$root->setNamespace( 'http://schemas.xmlsoap.org/wsdl/soap/', 'soap', 0 );
$root->setNamespace( 'uri:MooseX.SOAP.' . $className, 'tns', 0 );
$root->setAttribute( 'targetNamespace', 'uri:MooseX.SOAP.' . $className );
$doc->setDocumentElement($root);
my $type = XML::LibXML::Element->new('types');
$root->appendChild($type);
my $schema = $self->create_schema($className);
$type->appendChild($schema);
my $portType = XML::LibXML::Element->new('portType');
$portType->setAttribute( 'name', $className . 'SOAP11' );
my $binding = XML::LibXML::Element->new('binding');
$binding->setAttribute( 'name', $className . 'SOAP11Binding' );
$binding->setAttribute( 'type', 'tns:' . $className . 'SOAP11' );
# <soap:binding transport="http://schemas.xmlsoap.org/soap/http"
# style="document" />
my $soapBinding = XML::LibXML::Element->new('binding');
$soapBinding->setNamespace( 'http://schemas.xmlsoap.org/wsdl/soap/',
'soap', 1 );
$soapBinding->setAttribute( 'transport',
'http://schemas.xmlsoap.org/soap/http' );
$soapBinding->setAttribute( 'style', 'document' );
$binding->appendChild($soapBinding);
for my $method ( keys %{$ACTION_DATA_OF{$class}} ) {
my $methodName = $ACTION_DATA_OF{$class}->{$method}->{name};
my $inElement = XML::LibXML::Element->new('element');
$inElement->setAttribute( 'name', $methodName );
$schema->appendChild($inElement);
my $outElement = XML::LibXML::Element->new('element');
$outElement->setAttribute( 'name', $methodName . 'Response' );
$schema->appendChild($outElement);
my $inMessage = XML::LibXML::Element->new('message');
$inMessage->setAttribute( 'name', $methodName . 'SoapIn' );
$root->appendChild($inMessage);
my $inMessageBodyPart = XML::LibXML::Element->new('part');
$inMessageBodyPart->setAttribute( 'name', 'input' );
$inMessageBodyPart->setAttribute( 'element', 'tns:' . $methodName );
$inMessage->appendChild($inMessageBodyPart);
my $outMessage = XML::LibXML::Element->new('message');
$outMessage->setAttribute( 'name', $methodName . 'SoapOut' );
$root->appendChild($outMessage);
my $outMessageBodyPart = XML::LibXML::Element->new('part');
$outMessageBodyPart->setAttribute( 'name', 'output' );
$outMessageBodyPart->setAttribute( 'element',
'tns:' . $methodName . 'Response' );
$outMessage->appendChild($outMessageBodyPart);
my $portOperation = XML::LibXML::Element->new('operation');
$portOperation->setAttribute( 'name', $methodName );
$portType->appendChild($portOperation);
my $inputMessage = XML::LibXML::Element->new('input');
$inputMessage->setAttribute( 'message',
'tns:' . $methodName . 'SoapIn' );
$portOperation->appendChild($inputMessage);
my $outputMessage = XML::LibXML::Element->new('output');
$outputMessage->setAttribute( 'message',
'tns:' . $methodName . 'SoapOut' );
$portOperation->appendChild($outputMessage);
my $bindingOperation = XML::LibXML::Element->new('operation');
$bindingOperation->setAttribute( 'name', $methodName );
$binding->appendChild($bindingOperation);
my $soapOperation = XML::LibXML::Element->new('operation');
$soapOperation->setNamespace( 'http://schemas.xmlsoap.org/wsdl/soap/',
'soap', 1 );
$soapOperation->setAttribute( 'soapAction', $method );
$soapOperation->setAttribute( 'style', 'document' );
$bindingOperation->appendChild($soapOperation);
my $bindingInput = XML::LibXML::Element->new('input');
$bindingOperation->appendChild($bindingInput);
my $soapInputBody = XML::LibXML::Element->new('body');
$soapInputBody->setNamespace( 'http://schemas.xmlsoap.org/wsdl/soap/',
'soap', 1 );
$soapInputBody->setAttribute( 'use', 'literal' );
$bindingInput->appendChild($soapInputBody);
my $bindingOutput = XML::LibXML::Element->new('output');
$bindingOperation->appendChild($bindingOutput);
my $soapOutputBody = XML::LibXML::Element->new('body');
$soapOutputBody->setNamespace(
'http://schemas.xmlsoap.org/wsdl/soap/',
'soap', 1 );
$soapOutputBody->setAttribute( 'use', 'literal' );
$bindingOutput->appendChild($soapOutputBody);
}
$root->appendChild($portType);
$root->appendChild($binding);
my $service = XML::LibXML::Element->new('service');
$service->setAttribute( 'name', $className );
$root->appendChild($service);
my $port = XML::LibXML::Element->new('port');
$port->setAttribute( 'name', $className . 'PortSOAP' );
$port->setAttribute( 'binding', 'tns:' . $className . 'SOAP11Binding' );
my $soapAddress = XML::LibXML::Element->new('address');
$soapAddress->setNamespace( 'http://schemas.xmlsoap.org/wsdl/soap/',
'soap', 1 );
$soapAddress->setAttribute( 'location', $address );
$port->appendChild($soapAddress);
$service->appendChild($port);
$self->schema($schema);
return $doc;
}
sub create_schema {
my ( $self, $className ) = @_;
my $class = ref $self;
my $schema = XML::LibXML::Element->new('schema');
$schema->setAttribute( 'targetNamespace',
'uri:MooseX.SOAP.' . $className );
$schema->setNamespace( 'http://www.w3.org/2001/XMLSchema', undef, 1 );
$schema->setNamespace( 'http://www.w3.org/2001/XMLSchema', 'xs', 0 );
$schema->setNamespace( 'uri:MooseX.SOAP.' . $className, 'tns', 0 );
for my $type ( keys %{$SCHEMA_DATA_OF{$class}} ) {
eval "require $type";
$schema->appendChild( $self->create_xsd_type($type) );
}
return $schema;
}
sub create_xsd_type {
my $self = shift;
my $type = shift;
my $name = $type;
$name =~ s{::}{\.}xg;
my $node = XML::LibXML::Element->new('complexType');
$node->setNamespace( 'http://www.w3.org/2001/XMLSchema', undef, 1 );
$node->setAttribute( 'name', $name );
my $sequence = XML::LibXML::Element->new('sequence');
$node->appendChild($sequence);
my $typeMap = $self->typeMap->types();
for my $attribute ( reverse $type->meta()->get_all_attributes() ) {
my $attributeNode = XML::LibXML::Element->new('element');
$attributeNode->setAttribute( 'name', $attribute->name );
$attributeNode->setAttribute( 'type',
$typeMap->{$attribute->type_constraint} );
$sequence->appendChild($attributeNode);
}
return $node;
}
1;
1;