1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
|
# Copyrights 2007-2019 by [Mark Overmeer <markov@cpan.org>].
# For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 2.02.
# This code is part of distribution XML-Compile-SOAP. Meta-POD processed
# with OODoc into POD and HTML manual-pages. See README.md
# Copyright Mark Overmeer. Licensed under the same terms as Perl itself.
package XML::Compile::Transport;
use vars '$VERSION';
$VERSION = '3.26';
use base 'XML::Compile::SOAP::Extension';
use warnings;
use strict;
use Log::Report 'xml-compile-soap';
use Log::Report::Exception ();
use XML::LibXML ();
use Time::HiRes qw/time/;
sub init($)
{ my ($self, $args) = @_;
$self->SUPER::init($args);
$self->{charset} = $args->{charset} || 'UTF-8';
my $addr = $args->{address} || 'http://localhost';
my @addrs = ref $addr eq 'ARRAY' ? @$addr : $addr;
$self->{addrs} = \@addrs;
$self;
}
#-------------------------------------
sub charset() {shift->{charset}}
sub addresses() { @{shift->{addrs}} }
sub address()
{ my $addrs = shift->{addrs};
@$addrs==1 ? $addrs->[0] : $addrs->[rand @$addrs];
}
#-------------------------------------
sub compileClient(@)
{ my ($self, %args) = @_;
my $call = $self->_prepare_call(\%args);
my $kind = $args{kind} || 'request-response';
my $format = $args{xml_format} || 0;
sub
{ my ($xmlout, $trace, $mtom) = @_;
my $start = time;
my $textout = ref $xmlout ? $xmlout->toString($format) : $xmlout;
#warn $xmlout->toString(1); # show message sent
my $stringify = time;
$trace->{stringify_elapse} = $stringify - $start;
$trace->{transport_start} = $start;
my ($textin, $xops) = try { $call->(\$textout, $trace, $mtom) };
my $connected = time;
$trace->{connect_elapse} = $connected - $stringify;
if($@)
{ $trace->{errors} = [$@->wasFatal];
return;
}
my $xmlin;
if($textin)
{ $xmlin = try {XML::LibXML->load_xml(string => $$textin)};
if($@) { $trace->{errors} = [$@->wasFatal] }
else { $trace->{response_dom} = $xmlin }
}
my $answer = $xmlin;
if($kind eq 'one-way')
{ my $response = $trace->{http_response};
my $code = defined $response ? $response->code : -1;
if($code==202) { $answer ||= {} }
else
{ push @{$trace->{errors}}, Log::Report::Exception->new
(reason => 'error', message => __"call failed with code $code")
}
}
elsif(!$xmlin)
{ push @{$trace->{errors}}, Log::Report::Exception->new
(reason => 'error', message => __"no xml as answer");
}
my $end = $trace->{transport_end} = time;
$trace->{parse_elapse} = $end - $connected;
$trace->{transport_elapse} = $end - $start;
wantarray || ! keys %$xops
or warning "loosing received XOPs";
wantarray ? ($answer, $xops) : $answer;
}
}
sub _prepare_call($) { panic "not implemented" }
#--------------------------------------
{ my %registered;
sub register($) { my ($class, $uri) = @_; $registered{$uri} = $class }
sub plugin($) { my ($class, $uri) = @_; $registered{$uri} }
sub registered($) { values %registered }
}
#--------------------------------------
1;
|
