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

import SOAP-WSDL 2.00_33 from CPAN

Browse Source 
git-cpan-module:   SOAP-WSDL
git-cpan-version:  2.00_33
git-cpan-authorid: MKUTTER
git-cpan-file:     authors/id/M/MK/MKUTTER/SOAP-WSDL-2.00_33.tar.gz
This commit is contained in:
Martin Kutter
2009-12-12 19:48:28 -08:00
committed by Michael G. Schwern
parent 51db446428
commit 0cbf981665
146 changed files with 3364 additions and 1280 deletions
Download Patch File Download Diff File Expand all files Collapse all files
lib/SOAP/WSDL/Generator/Visitor/Typemap.pm
+39 -125
View File
@@ -9,13 +9,11 @@ our $VERSION = q{2.00_25};
my %path_of :ATTR(:name<path> :default<[]>);
my %typemap_of :ATTR(:name<typemap> :default<()>);
my %type_prefix_of :ATTR(:name<type_prefix> :default<()>);
my %element_prefix_of :ATTR(:name<element_prefix> :default<()>);
my %resolver_of :ATTR(:name<resolver> :default<()>);
sub START {
my ($self, $ident, $arg_ref) = @_;
$type_prefix_of{ $ident } ||= 'MyTypes';
$element_prefix_of{ $ident } ||= 'MyElements';
$resolver_of { $ident } = $arg_ref->{ resolver };
}
sub set_typemap_entry {
@@ -41,105 +39,6 @@ sub add_element_path {
# . $element->get_name();
}
sub visit_Definitions {
my ( $self, $ident, $definitions ) = ( $_[0], ident $_[0], $_[1] );
$self->set_definitions( $definitions );
for ( @{ $definitions->get_service() } ){
$_->_accept($self);
}
}
sub visit_Service {
my ( $self, $service ) = ( $_[0], $_[1] );
for ( @{ $service->get_port() } ) { $_->_accept($self); }
}
sub visit_Port {
my ( $self, $ident, $port ) = ( $_[0], ident $_[0], $_[1] );
# This is a false assumption - typemaps may be valid for non-soap
# bindings as well.
# TODO check and correct
return if not $port->first_address();
return if not $port->first_address()->isa('SOAP::WSDL::SOAP::Address');
my $binding = $self->get_definitions()
->find_binding( $port->expand( $port->get_binding() ) )
or die 'binding ' . $port->get_binding() . ' not found!';
$binding->_accept($self);
}
sub visit_Binding {
my ( $self, $ident, $binding ) = ( $_[0], ident $_[0], $_[1] );
my $portType = $self->get_definitions()
->find_portType( $binding->expand( $binding->get_type ) )
or die 'portType not found: ' . $binding->binding_type;
for my $operation ( @{ $binding->get_operation() } ) {
my $name = $operation->get_name();
# get the equally named operation from the portType
my ($op) = grep { $_->get_name eq $name }
@{ $portType->get_operation() }
or die "operation <$name> not found";
# visit every input, output and fault message...
for ( @{ $op->get_input }, @{ $op->get_output }, @{ $op->get_fault } ) {
$_->_accept($self);
}
}
}
sub visit_OpMessage {
my ( $self, $ident, $operation_message ) = ( $_[0], ident $_[0], $_[1] );
return if not( $operation_message->get_message() ); # we're in binding
# TODO maybe allow more messages && overloading by specifying name
# find message referenced in operation
my $message = $self->get_definitions()->find_message(
$operation_message->expand( $operation_message->get_message() ) );
for my $part ( @{ $message->get_part() } ) {
$part->_accept($self);
}
}
sub visit_Part {
my ( $self, $ident, $part ) = ( $_[0], ident $_[0], $_[1] );
my $types_ref = $self->get_definitions()->first_types()
or warn "Empty part" . $part->get_name();
# resolve type
# If we have a type, this type is to be used in document/literal
# as global type. However this is forbidden, at least by WS-I.
# We should store the style/encoding somewhere, and regard it.
# TODO: auto-generate element for RPC bindings
if ( my $type_name = $part->get_type ) {
# FIXME support RPC-style calls
die "unsupported global type <$type_name> found in part ". $part->get_name();
}
# TODO factor out iterator or replace by lookup (probably better)
if ( my $element_name = $part->get_element() ) {
my $element = $types_ref->find_element(
$part->expand($element_name) )
|| die "no element $element_name found for part " . $part->get_name();
$element->_accept($self);
return;
}
warn 'neither type nor element - do not know what to do for part '
. $part->get_name();
return;
}
sub process_referenced_type {
my ( $self, $ns, $localname ) = @_;
return if not $localname;
@@ -149,18 +48,13 @@ sub process_referenced_type {
# Caveat: visits type if it's a referenced type from the
# a ? b : c operation.
my ($type, $typeclass);
if ( $ns eq 'http://www.w3.org/2001/XMLSchema' ) {
$typeclass = "SOAP::WSDL::XSD::Typelib::Builtin::$localname";
}
else {
$type = $self->get_definitions()->first_types()->find_type( $ns, $localname );
$typeclass = join( q{::}, $type_prefix_of{$ident}, $type->get_name() );
}
$type = $self->get_definitions()->first_types()->find_type( $ns, $localname );
$typeclass = $self->get_resolver()->create_xsd_name($type);
# set before to allow it to be used from inside _accept
$self->set_typemap_entry($typeclass);
$type->_accept($self) if ($type);
$type->_accept($self) if ($ns ne 'http://www.w3.org/2001/XMLSchema');
# set afterwards again (just to be sure...)
$self->set_typemap_entry($typeclass);
@@ -202,17 +96,21 @@ sub visit_XSD_Element {
if ($element->get_simpleType()) {
# warn "simpleType " . $element->get_name();
my @path = @{ $path_of{ ${ $self } } };
my $typeclass = defined ($parent)
? join '::_', $parent , $element->get_name()
: join q{::}, $element_prefix_of{$ident}, $element->get_name();
my $typeclass = $self->get_resolver()->create_subpackage_name($element);
# my $typeclass = defined ($parent)
# ? join q{::_}, $parent , $element->get_name()
# : join q{::}, $self->resolver()->get_element_prefix( $element->get_targetNamespace), $element->get_name();
$self->set_typemap_entry($typeclass);
$typeclass =~s{\.}{::}g;
$typeclass =~s{\-}{_}g;
last SWITCH;
}
# for atomic and complex types , and ref elements
my $typeclass = join q{::}, $element_prefix_of{$ident}, $element->get_name();
$typeclass =~s{\.}{::}g;
$typeclass =~s{\-}{_}g;
my $typeclass = $self->get_resolver()->create_subpackage_name($element);
# my $typeclass = join q{::}, $self->get_resolver()->get_element_prefix( $element->get_targetNamespace), $element->get_name();
# $typeclass =~s{\.}{::}g;
# $typeclass =~s{\-}{_}g;
$self->set_typemap_entry($typeclass);
$self->process_atomic_type( $element->first_complexType()
@@ -226,9 +124,10 @@ sub visit_XSD_Element {
# a normal (not atomic) type, we just override it here
if (not defined($parent)) {
# for atomic and complex types , and ref elements
my $typeclass = join q{::}, $element_prefix_of{$ident}, $element->get_name();
$typeclass =~s{\.}{::}g;
$typeclass =~s{\-}{_}g;
my $typeclass = $self->get_resolver()->create_xsd_name($element);
# my $typeclass = join q{::}, $self->get_resolver()->get_element_prefix($element->get_targetNamespace), $element->get_name();
# $typeclass =~s{\.}{::}g;
# $typeclass =~s{\-}{_}g;
$self->set_typemap_entry($typeclass);
}
@@ -238,11 +137,12 @@ sub visit_XSD_Element {
sub visit_XSD_ComplexType {
my ($self, $ident, $type) = ($_[0], ident $_[0], $_[1] );
my $content_model = $type->get_flavor();
# TODO is this allowed ? or should we better die ?
return if not $content_model; # empty complexType
my $variety = $type->get_variety();
my $content_model = $type->get_contentModel;
return if not $variety; # empty complexType
return if ($content_model eq 'simpleContent');
if ( grep { $_ eq $content_model} qw(all sequence choice) )
if ( grep { $_ eq $variety} qw(all sequence choice) )
{
# visit child elements
for (@{ $type->get_element() || [] }) {
@@ -251,7 +151,21 @@ sub visit_XSD_ComplexType {
return;
}
warn "unsupported content model $content_model found in "
if (grep { $_ eq $variety } qw(restriction extension) ) {
# resolve base / get atomic type and run on elements
if (my $type_name = $type->get_base()) {
my $subtype = $self->get_definitions()
->first_types()->find_type( $type->expand($type_name) );
# visit child elements
for (@{ $subtype->get_element() || [] }) {
$_->_accept( $self );
}
# that's all for restriction
return if ($variety eq 'restriction');
}
}
warn "unsupported content model $variety found in "
. "complex type " . $type->get_name()
. " - typemap may be incomplete";
}