import SOAP-WSDL 2.00.10 from CPAN
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
committed by
Michael G. Schwern
Michael G. Schwern
parent
3b30e8d0e2
commit
9023aa06a4
Regular → Executable
+229
-41
@@ -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;
|
||||
|
||||
Reference in New Issue
Block a user