package CodeFirst; use Moose; use Carp; use Scalar::Util qw(blessed); use XML::LibXML; use parent qw(Attribute::Handlers); our $VERSION = 0.1; my %ACTION_MAP_OF; my %ACTION_DATA_OF; my %SCHEMA_DATA_OF; has 'schema' => is => 'rw'; has 'typeMap' => is => 'rw', isa => 'CodeFirst::Types', default => sub { CodeFirst::Types->new() }; sub WebMethod : ATTR { my ( $class, $symbol, $referent, $attr, $data, $phase, $filename, $linenum ) = @_; my %parameter_of; eval { %parameter_of = @{$data} }; if ($@) { die "Cannot parse :WebMethod arguments: $@ at " . Carp::shortmess; } $ACTION_MAP_OF{$class}->{$parameter_of{action}} = $symbol; $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}, }}; $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' ); # 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;