The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/env perl
use strict;
use warnings;

use RPC::Async::Client;
use IO::EventMux;

# Run with ./wsdldump.pl | xmlindent

my $target_namespace = 'http://soap.netlookup.dk/test'; 
#
# FIXME: http://msdn2.microsoft.com/en-us/library/ms996486.aspx#understand_topic2

my %types = (
    integer8   => 'byte',
    integer16  => 'short',
    integer32  => 'int',
    integer64  => 'long',
    float32    => 'float',
    float64    => 'double',
    uinteger8  => 'unsignedByte',
    uinteger16 => 'unsignedShort',
    uinteger32 => 'unsignedInt',
    uinteger64 => 'unsignedLong',
    boolean    => 'boolean',
    utf8string => 'string',
);


my $wsdl_header = 
qq{<?xml version="1.0" encoding="utf-8"?>
<wsdl:definitions name="netlookup"
        targetNamespace="$target_namespace"
        xmlns:tns="$target_namespace"
        xmlns:xsd="http://www.w3.org/2001/XMLSchema"
        xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"
        xmlns:soap="http://schemas.xmlsoap.org/wsdl/soap/"
        xmlns:wsdl="http://schemas.xmlsoap.org/wsdl/"
        xmlns:http="http://schemas.xmlsoap.org/wsdl/http/"
        xmlns:soapenc="http://schemas.xmlsoap.org/soap/encoding/"
        xmlns:mime="http://schemas.xmlsoap.org/wsdl/mime/"
        xmlns="http://schemas.xmlsoap.org/wsdl/">
};

my $wsdl_footer = qq{</wsdl:definitions>\n};

my $types_header =
qq{<wsdl:types>
<xsd:schema elementFormDefault="qualified" targetNamespace="$target_namespace">
};

my $types_footer =
qq{</xsd:schema>
</wsdl:types>
};

my $complex_start = 
qq{<xsd:complexType>
<xsd:sequence>
};
my $complex_end = 
qq{</xsd:sequence>
</xsd:complexType>
};

my $end = "/>\n";

my $element_start = qq{<xsd:element minOccurs="0" maxOccurs="1"};

my $mux = IO::EventMux->new();

# Set the user for the server to run under.
$ENV{'IO_URL_USER'} ||= 'root';

my $rpc = RPC::Async::Client->new($mux, "perl://./test-server.pl") or die;

$rpc->methods(defs => 1, sub {
    my (%ans) = @_;
    my $proxy = "testd";
    my $location = "http://localhost:1981/soap";
    my $method = "sum";

    my $types = '';
    my $messages = 
        qq{<wsdl:message name="${method}_input">\n}.
        qq{<wsdl:part name="parameters" element="tns:${method}_input"/>\n}.
        qq{</wsdl:message>\n}.
        qq{<wsdl:message name="${method}_output">\n}.
        qq{<wsdl:part name="parameters" element="tns:${method}_output"/>\n}.
        qq{</wsdl:message>\n};
   
    my $porttypes = 
        qq{<wsdl:portType name="${proxy}_interface">\n}.
        qq{<wsdl:operation name="${method}">\n}.
        qq{<wsdl:input message="tns:${method}_input"/>\n}.
        qq{<wsdl:output message="tns:${method}_output"/>\n}.
        qq{</wsdl:operation>\n}.
        qq{</wsdl:portType>\n};

    my $bindings =
        qq{<wsdl:binding name="${proxy}_bindings" type="tns:${proxy}_interface">\n}.
        qq{<soap:binding style="document" transport="http://schemas.xmlsoap.org/soap/http"/>\n}.
        qq{<wsdl:operation name="$method">\n}.
        qq{<soap:operation soapAction="$target_namespace/$method" style="document"/>\n}.
        qq{<wsdl:input name="${method}_input">\n}.
        qq{<soap:body use="literal"/>\n}.
        qq{</wsdl:input>\n}.
        qq{<wsdl:output name="${method}_output">\n}.
        qq{<soap:body use="literal"/>\n}.
        qq{</wsdl:output>\n}.
        qq{</wsdl:operation>\n}.
        qq{</wsdl:binding>\n};
    
    my $services =
        qq{<wsdl:service name="${proxy}_service">}.
        qq{<wsdl:port name="${proxy}_soap" binding="tns:${proxy}_bindings">}.
        qq{<soap:address location="$location"/>}.
        qq{</wsdl:port>}.
        qq{</wsdl:service>};

    $types .= $types_header;
    $types .= qq{<xsd:element name="${method}_input">\n};
    foreach my $parmname (sort keys %{$ans{methods}{$method}{in}}) {
        my $type = $ans{methods}{$method}{in}{$parmname}; 

        if(ref $type eq '') {
            $type = ($types{$type} or die "Unknown type: $type");
            $types .= "$complex_start";
            $types .= qq{$element_start name="$parmname" type="xsd:$type"$end};
            $types .= "$complex_end";
        
        } elsif(ref $type eq 'ARRAY') {

        } elsif(ref $type eq 'HASH') {

        }
    }
    $types .= qq{</xsd:element>\n};
    
    $types .= qq{<xsd:element name="${method}_output">\n};
    foreach my $parmname (sort keys %{$ans{methods}{$method}{out}}) {
        my $type = $ans{methods}{$method}{out}{$parmname}; 
        
        # FIXME: Make hash map for looking up wsdl types to map to.
        # This parameter map directly to a soap base type
        if(ref $type eq '') {
            $type = ($types{$type} or die "Unknown type: $type");
            $types .= "$complex_start";
            $types .= qq{$element_start name="$parmname" type="xsd:$type"$end};
            $types .= "$complex_end";
        }
    }
    $types .= qq{</xsd:element>\n};
    $types .= $types_footer;
    
    print "$wsdl_header".
        "$types$messages$porttypes$bindings$services".
        "$wsdl_footer";

#    use Data::Dumper;
#    print Dumper($ans{methods}{add_numbers});
#    print Dumper(\%ans);
    #is(, 'integer32:pos', 
    #    "Check that rpc_get_id was converted");
});

while ($rpc->has_requests) {
    my $event = $mux->mux;
    $rpc->io($event);
}

$rpc->disconnect;