File Coverage

blib/lib/W3C/SOAP/WSDL.pm

Criterion	Covered	Total	%
statement	21	107	19.6
branch	0	32	0.0
condition	0	17	0.0
subroutine	7	16	43.7
pod			n/a
total	28	172	16.2

package W3C::SOAP::WSDL;

# Created on: 2012-05-27 18:57:16
# Create by:  Ivan Wills
# $Id$
# $Revision$, $HeadURL$, $Date$
# $Revision$, $Source$, $Date$

use Moose;
use warnings;
use version;
use Carp;
use Data::Dumper qw/Dumper/;
use English qw/ -no_match_vars /;
use Try::Tiny;

extends 'W3C::SOAP::Client';

our $VERSION = version->new('0.11');

has header => (
    is        => 'rw',
    isa       => 'W3C::SOAP::Header',
    predicate => 'has_header',
    builder   => '_header',
);

sub _request {
    my ($self, $action, @args) = @_;
    my $meta      = $self->meta;
    my $method    = $self->_get_operation_method($action);
    my $operation = $method->wsdl_operation;
    my $resp;

    if ( $method->has_in_class && $method->has_in_attribute ) {
        my $class = $method->in_class;
        my $att   = $method->in_attribute;

        my $att_args = @args == 1 ? $args[0] : {@args};

        my $header_args = delete $att_args->{header} || {};

        my $xsd   = $class->new( $att => $att_args);

        if ( $method->has_in_header_class && $method->has_in_header_attribute) {
            my $header_class   = $method->in_header_class;
            my $header_att     = $method->in_header_attribute;

            my $header = $header_class->new($header_att => $header_args);

            $self->header->message($header);
        }
        my $xsd_ns = $xsd->xsd_ns;
        if ( $xsd_ns !~ m{/$} ) {
            $xsd_ns .= '/';
        }
        $resp = $self->request( "$xsd_ns$operation" => $xsd );
    }
    else {
        $resp = $self->request( $operation, @args );
    }

    if ( $method->has_out_class && $method->has_out_attribute ) {
        my $class = $method->out_class;
        my $att   = $method->out_attribute;
        return $class->new($resp)->$att;
    }
    else {
        return $resp;
    }
}

sub request {
    my ($self, $action, $body) = @_;
    my $xml = $self->build_request_xml($body);

    if ( $self->has_header ) {
        my $node = $self->header->to_xml($xml);
        $xml->firstChild->insertBefore($node, $xml->getDocumentElement->firstChild);
    }

    return $self->send($action, $xml);
}

sub build_request_xml {
    my ($self, $body) = @_;
    my $xml = XML::LibXML->load_xml(string => <<'XML');
<?xml version="1.0" encoding="UTF-8"?>
<soapenv:Envelope xmlns:soapenv="http://schemas.xmlsoap.org/soap/envelope/">
    <soapenv:Body/>
</soapenv:Envelope>
XML

    my $xc = XML::LibXML::XPathContext->new($xml);
    $xc->registerNs('soapenv' => 'http://schemas.xmlsoap.org/soap/envelope/' );
    my ($soap_body) = $xc->findnodes('//soapenv:Body');
    if ( !blessed $body ) {
        $soap_body->appendChild( $xml->createTextNode($body) );
    }
    elsif ( $body->isa('XML::LibXNL::Node') ) {
        $soap_body->appendChild( $body );
    }
    elsif ( $body->can('to_xml') ) {
        for my $node ( $body->to_xml($xml) ) {
            $soap_body->appendChild( $node );
        }
    }
    else {
        W3C::SOAP::Exception::BadInput->throw(
            faultcode => 'UNKNOWN SOAP BODY',
            message   => "Don't know how to process ". (ref $body) ."\n",
            error     => '',
        );
    }

    return $xml;
}

sub send {
    my ($self, $action, $xml) = @_;
    my $content;

    $self->log->debug("$action REQUEST\n" . $xml->toString) if $self->has_log;
    try {
        $content = $self->post($action, $xml);
    }
    catch  {
        $self->log->error("$action RESPONSE \n" . $self->response->decoded_content) if $self->has_log;

        W3C::SOAP::Exception::HTTP->throw(
            faultcode => $self->response->code,
            message   => $self->response->message,
            error     => $_,
        );
    };
    $self->log->debug("$action RESPONSE \n$content") if $self->has_log;

    my $xml_response = XML::LibXML->load_xml( string => $content );
    my $ns = $self->_envelope_ns($xml_response);

    my ($fault) = $xml_response->findnodes("//$ns\:Body/$ns:Fault");
    if ($fault) {
        my $faultcode   = join ' ', map {$_->toString} map {$_->childNodes} $fault->findnodes("faultcode");
        my $faultstring = join ' ', map {$_->toString} map {$_->childNodes} $fault->findnodes("faultstring");
        my $faultactor  = join ' ', map {$_->toString} map {$_->childNodes} $fault->findnodes("faultactor");
        my $detail      = join ' ', map {$_->toString} map {$_->childNodes} $fault->findnodes("detail");

        W3C::SOAP::Exception->throw(
            faultcode   => $faultcode,
            faultstring => $faultstring,
            faultactor  => $faultactor,
            detail      => $detail,
        );
    }

    my ($node) = $xml_response->findnodes("//$ns\:Body");

    return $node;
}

sub _get_operation_method {
    my ($self, $action) = @_;

    my $method = $self->meta->get_method($action);
    return $method if $method && $method->meta->name eq 'W3C::SOAP::WSDL::Meta::Method';

    for my $super ( $self->meta->superclasses ) {
        next unless $super->can('_get_operation_method');
        $method = $super->_get_operation_method($action);
        return $method if $method && $method->meta->name eq 'W3C::SOAP::WSDL::Meta::Method';
    }

    confess "Could not find any methods called $action!";
}

sub _envelope_ns {
    my ($self, $xml) = @_;
    my %map
        = map {$_->name =~ /^xmlns:?(.*)$/; ($_->value => $1)}
        grep { $_->name =~ /^xmlns/ }
        $xml->firstChild->getAttributes;

    return $map{'http://schemas.xmlsoap.org/soap/envelope/'};
}

sub _header {
    return W3C::SOAP::Header->new;
}

1;

__END__

=head1 NAME

W3C::SOAP::WSDL - A SOAP WSDL Client object

=head1 VERSION

This documentation refers to W3C::SOAP::WSDL version 0.11.


=head1 SYNOPSIS

   use W3C::SOAP::WSDL;

   # Brief but working code example(s) here showing the most common usage(s)
   # This section will be as far as many users bother reading, so make it as
   # educational and exemplary as possible.


=head1 DESCRIPTION

Inherits from L<W3C::SOAP::Client>

=head1 SUBROUTINES/METHODS

=over 4

=item C<request ($action, $body)>

Converts the body object to XML and adds any headers, then calls C<send()>

=item C<build_request_xml ($action, $body)>

Creates the XML representation of C<$body>

=item C<send ($action, $xml)>

Makes the HTTP request of the soap action and returns the resultant body node

=back

=head1 DIAGNOSTICS

=head1 CONFIGURATION AND ENVIRONMENT

=head1 DEPENDENCIES

=head1 INCOMPATIBILITIES

=head1 BUGS AND LIMITATIONS

There are no known bugs in this module.

Please report problems to Ivan Wills ([e-mail]).

Patches are welcome.

=head1 AUTHOR

Ivan Wills - ([e-mail])

=head1 LICENSE AND COPYRIGHT

Copyright (c) 2012 Ivan Wills (14 Mullion Close, Hornsby Heights, NSW Australia 2077).
All rights reserved.

This module is free software; you can redistribute it and/or modify it under
the same terms as Perl itself. See L<perlartistic>.  This program is
distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE.

=cut