1# Copyrights 2007-2021 by [Mark Overmeer <markov@cpan.org>].
2#  For other contributors see ChangeLog.
3# See the manual pages for details on the licensing terms.
4# Pod stripped from pm file by OODoc 2.02.
5# This code is part of distribution XML-Compile-SOAP.  Meta-POD processed
6# with OODoc into POD and HTML manual-pages.  See README.md
7# Copyright Mark Overmeer.  Licensed under the same terms as Perl itself.
8
9package XML::Compile::SOAP::Client;
10use vars '$VERSION';
11$VERSION = '3.27';
12
13
14use warnings;
15use strict;
16
17use Log::Report        'xml-compile-soap';
18
19use XML::Compile::Util qw/unpack_type/;
20use XML::Compile::SOAP::Trace;
21use Time::HiRes        qw/time/;
22
23
24sub new(@) { panic __PACKAGE__." only secundary in multiple inheritance" }
25sub init($) { shift }
26
27#--------------
28
29my $rr = 'request-response';
30
31sub compileClient(@)
32{   my ($self, %args) = @_;
33
34    my $name = $args{name};
35    my $kind = $args{kind} || $rr;
36    $kind eq $rr || $kind eq 'one-way'
37        or error __x"operation direction `{kind}' not supported for {name}"
38             , rr => $rr, kind => $kind, name => $name;
39
40    my $encode = $args{encode}
41        or error __x"encode for client {name} required", name => $name;
42
43    my $decode = $args{decode}
44        or error __x"decode for client {name} required", name => $name;
45
46    my $transport = $args{transport}
47        or error __x"transport for client {name} required", name => $name;
48
49    if(ref $transport eq 'CODE') { ; }
50    elsif(UNIVERSAL::isa($transport, 'XML::Compile::Transport::SOAPHTTP'))
51    {   $transport = $transport->compileClient(soap => $args{soap});
52    }
53    else
54    {   error __x"transport for client {name} is code ref or {type} object, not {is}"
55          , name => $name, type => 'XML::Compile::Transport::SOAPHTTP'
56          , is => (ref $transport || $transport);
57    }
58
59    my $output_handler = sub {
60        my ($ans, $trace, $xops) = @_;
61        wantarray or return
62            UNIVERSAL::isa($ans, 'XML::LibXML::Node') ? $decode->($ans) : $ans;
63
64        if(UNIVERSAL::isa($ans, 'XML::LibXML::Node'))
65        {   $ans = try { $decode->($ans) };
66            if($@)
67            {   $trace->{decode_errors} = $@;
68                my $fatal = $@->wasFatal;
69                $trace->{errors} = [$fatal];
70                $fatal->message($fatal->message->concat('decode error: ', 1));
71            }
72
73            my $end = time;
74            $trace->{decode_elapse} = $end - $trace->{transport_end};
75            $trace->{elapse} = $end - $trace->{start};
76        }
77        else
78        {   $trace->{elapse} = $trace->{transport_end} - $trace->{start}
79                if defined $trace->{transport_end};
80        }
81        ($ans, XML::Compile::SOAP::Trace->new($trace), $xops);
82    };
83
84    $args{async}
85    ? sub  # Asynchronous call, f.i. X::C::Transfer::SOAPHTTP::AnyEvent
86      { my ($data, $charset)
87          = UNIVERSAL::isa($_[0], 'HASH') ? @_
88          : @_%2==0 ? ({@_}, undef)
89          : error __x"operation `{name}' called with odd length parameter list"
90              , name => $name;
91
92        my $callback = delete $data->{_callback}
93            or error __x"operation `{name}' is async, so requires _callback";
94
95        my $trace = {start => time};
96        my ($req, $mtom) = $encode->($data, $charset);
97        $trace->{encode_elapse} = time - $trace->{start};
98
99        $transport->($req, $trace, $mtom
100          , sub { $callback->($output_handler->(@_)) }
101          );
102      }
103    : sub # Synchronous call, f.i. XML::Compile::Transfer::SOAPHTTP
104      { my ($data, $charset)
105          = UNIVERSAL::isa($_[0], 'HASH') ? @_
106          : @_%2==0 ? ({@_}, undef)
107          : panic(__x"operation `{name}' called with odd length parameter list"
108              , name => $name);
109
110        $data->{_callback}
111            and error __x"operation `{name}' called with _callback, but "
112                  . "compiled without async flag", name => $name;
113
114        my $trace = {start => time};
115        my ($req, $mtom) = $encode->($data, $charset);
116        my ($ans, $xops) = $transport->($req, $trace, $mtom);
117        wantarray || !$xops || ! keys %$xops
118            or warning "loosing received XOPs";
119
120        $trace->{encode_elapse} = $trace->{transport_start} - $trace->{start};
121        $output_handler->($ans, $trace, $xops);
122      };
123}
124
125#------------------------------------------------
126
127
1281;
129