SOAP-WSDL/t/lib/CodeFirst.pm

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' );

    # 		<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;