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


line stmt bran cond sub pod time code
1             package W3C::SOAP::WSDL;
2              
3             # Created on: 2012-05-27 18:57:16
4             # Create by: Ivan Wills
5             # $Id$
6             # $Revision$, $HeadURL$, $Date$
7             # $Revision$, $Source$, $Date$
8              
9 1     1   1253 use Moose;
  1         3  
  1         7  
10 1     1   5001 use warnings;
  1         2  
  1         24  
11 1     1   4 use version;
  1         3  
  1         6  
12 1     1   59 use Carp;
  1         1  
  1         64  
13 1     1   5 use Data::Dumper qw/Dumper/;
  1         2  
  1         86  
14 1     1   6 use English qw/ -no_match_vars /;
  1         1  
  1         7  
15 1     1   335 use Try::Tiny;
  1         2  
  1         1136  
16              
17             extends 'W3C::SOAP::Client';
18              
19             our $VERSION = version->new('0.11');
20              
21             has header => (
22             is => 'rw',
23             isa => 'W3C::SOAP::Header',
24             predicate => 'has_header',
25             builder => '_header',
26             );
27              
28             sub _request {
29 0     0     my ($self, $action, @args) = @_;
30 0           my $meta = $self->meta;
31 0           my $method = $self->_get_operation_method($action);
32 0           my $operation = $method->wsdl_operation;
33 0           my $resp;
34              
35 0 0 0       if ( $method->has_in_class && $method->has_in_attribute ) {
36 0           my $class = $method->in_class;
37 0           my $att = $method->in_attribute;
38              
39 0 0         my $att_args = @args == 1 ? $args[0] : {@args};
40              
41 0   0       my $header_args = delete $att_args->{header} || {};
42              
43 0           my $xsd = $class->new( $att => $att_args);
44              
45 0 0 0       if ( $method->has_in_header_class && $method->has_in_header_attribute) {
46 0           my $header_class = $method->in_header_class;
47 0           my $header_att = $method->in_header_attribute;
48              
49 0           my $header = $header_class->new($header_att => $header_args);
50              
51 0           $self->header->message($header);
52             }
53 0           my $xsd_ns = $xsd->xsd_ns;
54 0 0         if ( $xsd_ns !~ m{/$} ) {
55 0           $xsd_ns .= '/';
56             }
57 0           $resp = $self->request( "$xsd_ns$operation" => $xsd );
58             }
59             else {
60 0           $resp = $self->request( $operation, @args );
61             }
62              
63 0 0 0       if ( $method->has_out_class && $method->has_out_attribute ) {
64 0           my $class = $method->out_class;
65 0           my $att = $method->out_attribute;
66 0           return $class->new($resp)->$att;
67             }
68             else {
69 0           return $resp;
70             }
71             }
72              
73             sub request {
74 0     0     my ($self, $action, $body) = @_;
75 0           my $xml = $self->build_request_xml($body);
76              
77 0 0         if ( $self->has_header ) {
78 0           my $node = $self->header->to_xml($xml);
79 0           $xml->firstChild->insertBefore($node, $xml->getDocumentElement->firstChild);
80             }
81              
82 0           return $self->send($action, $xml);
83             }
84              
85             sub build_request_xml {
86 0     0     my ($self, $body) = @_;
87 0           my $xml = XML::LibXML->load_xml(string => <<'XML');
88             <?xml version="1.0" encoding="UTF-8"?>
89             <soapenv:Envelope xmlns:soapenv="http://schemas.xmlsoap.org/soap/envelope/">
90             <soapenv:Body/>
91             </soapenv:Envelope>
92             XML
93              
94 0           my $xc = XML::LibXML::XPathContext->new($xml);
95 0           $xc->registerNs('soapenv' => 'http://schemas.xmlsoap.org/soap/envelope/' );
96 0           my ($soap_body) = $xc->findnodes('//soapenv:Body');
97 0 0         if ( !blessed $body ) {
    0          
    0          
98 0           $soap_body->appendChild( $xml->createTextNode($body) );
99             }
100             elsif ( $body->isa('XML::LibXNL::Node') ) {
101 0           $soap_body->appendChild( $body );
102             }
103             elsif ( $body->can('to_xml') ) {
104 0           for my $node ( $body->to_xml($xml) ) {
105 0           $soap_body->appendChild( $node );
106             }
107             }
108             else {
109 0           W3C::SOAP::Exception::BadInput->throw(
110             faultcode => 'UNKNOWN SOAP BODY',
111             message => "Don't know how to process ". (ref $body) ."\n",
112             error => '',
113             );
114             }
115              
116 0           return $xml;
117             }
118              
119             sub send {
120 0     0     my ($self, $action, $xml) = @_;
121 0           my $content;
122              
123 0 0         $self->log->debug("$action REQUEST\n" . $xml->toString) if $self->has_log;
124             try {
125 0     0     $content = $self->post($action, $xml);
126             }
127             catch {
128 0 0   0     $self->log->error("$action RESPONSE \n" . $self->response->decoded_content) if $self->has_log;
129              
130 0           W3C::SOAP::Exception::HTTP->throw(
131             faultcode => $self->response->code,
132             message => $self->response->message,
133             error => $_,
134             );
135 0           };
136 0 0         $self->log->debug("$action RESPONSE \n$content") if $self->has_log;
137              
138 0           my $xml_response = XML::LibXML->load_xml( string => $content );
139 0           my $ns = $self->_envelope_ns($xml_response);
140              
141 0           my ($fault) = $xml_response->findnodes("//$ns\:Body/$ns:Fault");
142 0 0         if ($fault) {
143 0           my $faultcode = join ' ', map {$_->toString} map {$_->childNodes} $fault->findnodes("faultcode");
  0            
  0            
144 0           my $faultstring = join ' ', map {$_->toString} map {$_->childNodes} $fault->findnodes("faultstring");
  0            
  0            
145 0           my $faultactor = join ' ', map {$_->toString} map {$_->childNodes} $fault->findnodes("faultactor");
  0            
  0            
146 0           my $detail = join ' ', map {$_->toString} map {$_->childNodes} $fault->findnodes("detail");
  0            
  0            
147              
148 0           W3C::SOAP::Exception->throw(
149             faultcode => $faultcode,
150             faultstring => $faultstring,
151             faultactor => $faultactor,
152             detail => $detail,
153             );
154             }
155              
156 0           my ($node) = $xml_response->findnodes("//$ns\:Body");
157              
158 0           return $node;
159             }
160              
161             sub _get_operation_method {
162 0     0     my ($self, $action) = @_;
163              
164 0           my $method = $self->meta->get_method($action);
165 0 0 0       return $method if $method && $method->meta->name eq 'W3C::SOAP::WSDL::Meta::Method';
166              
167 0           for my $super ( $self->meta->superclasses ) {
168 0 0         next unless $super->can('_get_operation_method');
169 0           $method = $super->_get_operation_method($action);
170 0 0 0       return $method if $method && $method->meta->name eq 'W3C::SOAP::WSDL::Meta::Method';
171             }
172              
173 0           confess "Could not find any methods called $action!";
174             }
175              
176             sub _envelope_ns {
177 0     0     my ($self, $xml) = @_;
178 0           my %map
179 0           = map {$_->name =~ /^xmlns:?(.*)$/; ($_->value => $1)}
  0            
180 0           grep { $_->name =~ /^xmlns/ }
181             $xml->firstChild->getAttributes;
182              
183 0           return $map{'http://schemas.xmlsoap.org/soap/envelope/'};
184             }
185              
186             sub _header {
187 0     0     return W3C::SOAP::Header->new;
188             }
189              
190             1;
191              
192             __END__
193              
194             =head1 NAME
195              
196             W3C::SOAP::WSDL - A SOAP WSDL Client object
197              
198             =head1 VERSION
199              
200             This documentation refers to W3C::SOAP::WSDL version 0.11.
201              
202              
203             =head1 SYNOPSIS
204              
205             use W3C::SOAP::WSDL;
206              
207             # Brief but working code example(s) here showing the most common usage(s)
208             # This section will be as far as many users bother reading, so make it as
209             # educational and exemplary as possible.
210              
211              
212             =head1 DESCRIPTION
213              
214             Inherits from L<W3C::SOAP::Client>
215              
216             =head1 SUBROUTINES/METHODS
217              
218             =over 4
219              
220             =item C<request ($action, $body)>
221              
222             Converts the body object to XML and adds any headers, then calls C<send()>
223              
224             =item C<build_request_xml ($action, $body)>
225              
226             Creates the XML representation of C<$body>
227              
228             =item C<send ($action, $xml)>
229              
230             Makes the HTTP request of the soap action and returns the resultant body node
231              
232             =back
233              
234             =head1 DIAGNOSTICS
235              
236             =head1 CONFIGURATION AND ENVIRONMENT
237              
238             =head1 DEPENDENCIES
239              
240             =head1 INCOMPATIBILITIES
241              
242             =head1 BUGS AND LIMITATIONS
243              
244             There are no known bugs in this module.
245              
246             Please report problems to Ivan Wills (ivan.wills@gmail.com).
247              
248             Patches are welcome.
249              
250             =head1 AUTHOR
251              
252             Ivan Wills - (ivan.wills@gmail.com)
253              
254             =head1 LICENSE AND COPYRIGHT
255              
256             Copyright (c) 2012 Ivan Wills (14 Mullion Close, Hornsby Heights, NSW Australia 2077).
257             All rights reserved.
258              
259             This module is free software; you can redistribute it and/or modify it under
260             the same terms as Perl itself. See L<perlartistic>. This program is
261             distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
262             without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
263             PARTICULAR PURPOSE.
264              
265             =cut