line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# ====================================================================== |
2
|
|
|
|
|
|
|
# |
3
|
|
|
|
|
|
|
# Copyright (C) 2000-2004 Paul Kulchenko (paulclinger@yahoo.com) |
4
|
|
|
|
|
|
|
# SOAP::Lite is free software; you can redistribute it |
5
|
|
|
|
|
|
|
# and/or modify it under the same terms as Perl itself. |
6
|
|
|
|
|
|
|
# |
7
|
|
|
|
|
|
|
# ====================================================================== |
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
package SOAP::Transport::HTTP; |
10
|
|
|
|
|
|
|
|
11
|
13
|
|
|
13
|
|
2019
|
use strict; |
|
13
|
|
|
|
|
24
|
|
|
13
|
|
|
|
|
772
|
|
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
our $VERSION = 1.12; |
14
|
|
|
|
|
|
|
|
15
|
13
|
|
|
13
|
|
72
|
use SOAP::Lite; |
|
13
|
|
|
|
|
21
|
|
|
13
|
|
|
|
|
94
|
|
16
|
13
|
|
|
13
|
|
76
|
use SOAP::Packager; |
|
13
|
|
|
|
|
16
|
|
|
13
|
|
|
|
|
497
|
|
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
# ====================================================================== |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
package SOAP::Transport::HTTP::Client; |
21
|
|
|
|
|
|
|
|
22
|
13
|
|
|
13
|
|
68
|
use vars qw(@ISA $COMPRESS $USERAGENT_CLASS); |
|
13
|
|
|
|
|
22
|
|
|
13
|
|
|
|
|
1803
|
|
23
|
|
|
|
|
|
|
$USERAGENT_CLASS = 'LWP::UserAgent'; |
24
|
|
|
|
|
|
|
@ISA = qw(SOAP::Client); |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
$COMPRESS = 'deflate'; |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
my ( %redirect, %mpost, %nocompress ); |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
# hack for HTTP connection that returns Keep-Alive |
31
|
|
|
|
|
|
|
# miscommunication (?) between LWP::Protocol and LWP::Protocol::http |
32
|
|
|
|
|
|
|
# dies after timeout, but seems like we could make it work |
33
|
|
|
|
|
|
|
my $_patched = 0; |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
sub patch { |
36
|
12
|
50
|
|
12
|
|
59
|
return if $_patched; |
37
|
13
|
|
|
13
|
|
11410
|
BEGIN { local ($^W) = 0; } |
38
|
|
|
|
|
|
|
{ |
39
|
12
|
|
|
|
|
30
|
local $^W = 0; |
|
12
|
|
|
|
|
61
|
|
40
|
|
|
|
|
|
|
sub LWP::UserAgent::redirect_ok; |
41
|
0
|
|
|
0
|
|
0
|
*LWP::UserAgent::redirect_ok = sub { 1 } |
42
|
12
|
|
|
|
|
245
|
} |
43
|
|
|
|
|
|
|
{ |
44
|
|
|
|
|
|
|
|
45
|
12
|
|
|
|
|
37
|
package |
46
|
|
|
|
|
|
|
LWP::Protocol; |
47
|
12
|
|
|
|
|
44
|
local $^W = 0; |
48
|
12
|
|
|
|
|
41
|
my $collect = \&collect; # store original |
49
|
|
|
|
|
|
|
*collect = sub { |
50
|
1
|
50
|
33
|
1
|
|
2605106
|
if ( defined $_[2]->header('Connection') |
51
|
|
|
|
|
|
|
&& $_[2]->header('Connection') eq 'Keep-Alive' ) { |
52
|
0
|
|
|
|
|
0
|
my $data = $_[3]->(); |
53
|
|
|
|
|
|
|
my $next = |
54
|
|
|
|
|
|
|
$_[2]->header('Content-Length') && |
55
|
|
|
|
|
|
|
SOAP::Utils::bytelength($$data) == |
56
|
|
|
|
|
|
|
$_[2]->header('Content-Length') |
57
|
0
|
|
|
0
|
|
0
|
? sub { my $str = ''; \$str; } |
|
0
|
|
|
|
|
0
|
|
58
|
0
|
0
|
0
|
|
|
0
|
: $_[3]; |
59
|
0
|
|
|
|
|
0
|
my $done = 0; |
60
|
|
|
|
|
|
|
$_[3] = sub { |
61
|
0
|
0
|
|
0
|
|
0
|
$done++ ? &$next : $data; |
62
|
0
|
|
|
|
|
0
|
}; |
63
|
|
|
|
|
|
|
} |
64
|
1
|
|
|
|
|
103
|
goto &$collect; |
65
|
12
|
|
|
|
|
97
|
}; |
66
|
|
|
|
|
|
|
} |
67
|
12
|
|
|
|
|
36
|
$_patched++; |
68
|
|
|
|
|
|
|
} |
69
|
|
|
|
|
|
|
|
70
|
11
|
|
|
11
|
|
41
|
sub DESTROY { SOAP::Trace::objects('()') } |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
sub http_request { |
73
|
23
|
|
|
23
|
|
913
|
my $self = shift; |
74
|
23
|
100
|
|
|
|
89
|
if (@_) { $self->{'_http_request'} = shift; return $self } |
|
12
|
|
|
|
|
61
|
|
|
12
|
|
|
|
|
32
|
|
75
|
11
|
|
|
|
|
73
|
return $self->{'_http_request'}; |
76
|
|
|
|
|
|
|
} |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
sub http_response { |
79
|
165
|
|
|
165
|
|
655947
|
my $self = shift; |
80
|
165
|
100
|
|
|
|
386
|
if (@_) { $self->{'_http_response'} = shift; return $self } |
|
11
|
|
|
|
|
35
|
|
|
11
|
|
|
|
|
27
|
|
81
|
154
|
|
|
|
|
767
|
return $self->{'_http_response'}; |
82
|
|
|
|
|
|
|
} |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
sub setDebugLogger { |
85
|
12
|
|
|
12
|
|
31
|
my ($self,$logger) = @_; |
86
|
|
|
|
|
|
|
#print "HTTP.pm DEBUG: setDebugLogger: self=$self\n"; |
87
|
12
|
|
|
|
|
40
|
$self->{debug_logger} = $logger; |
88
|
|
|
|
|
|
|
} |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
sub new { |
91
|
12
|
|
|
12
|
|
28
|
my $class = shift; |
92
|
|
|
|
|
|
|
#print "HTTP.pm DEBUG: in sub new\n"; |
93
|
|
|
|
|
|
|
|
94
|
12
|
50
|
|
|
|
54
|
return $class if ref $class; # skip if we're already object... |
95
|
|
|
|
|
|
|
|
96
|
12
|
50
|
|
|
|
51
|
if ( !grep { $_ eq $USERAGENT_CLASS } @ISA ) { |
|
12
|
|
|
|
|
219
|
|
97
|
12
|
|
|
|
|
164
|
push @ISA, $USERAGENT_CLASS; |
98
|
|
|
|
|
|
|
} |
99
|
|
|
|
|
|
|
|
100
|
12
|
50
|
|
|
|
888
|
eval("require $USERAGENT_CLASS") |
101
|
|
|
|
|
|
|
or die "Could not load UserAgent class $USERAGENT_CLASS: $@"; |
102
|
|
|
|
|
|
|
|
103
|
12
|
|
|
|
|
521312
|
require HTTP::Request; |
104
|
12
|
|
|
|
|
55
|
require HTTP::Headers; |
105
|
|
|
|
|
|
|
|
106
|
12
|
50
|
|
|
|
82
|
patch() if $SOAP::Constants::PATCH_HTTP_KEEPALIVE; |
107
|
|
|
|
|
|
|
|
108
|
12
|
|
|
|
|
22
|
my ( @params, @methods ); |
109
|
12
|
|
|
|
|
55
|
while (@_) { |
110
|
12
|
50
|
|
|
|
308
|
$class->can( $_[0] ) |
111
|
|
|
|
|
|
|
? push( @methods, shift() => shift ) |
112
|
|
|
|
|
|
|
: push( @params, shift ); |
113
|
|
|
|
|
|
|
} |
114
|
12
|
|
|
|
|
151
|
my $self = $class->SUPER::new(@params); |
115
|
|
|
|
|
|
|
|
116
|
12
|
50
|
|
|
|
35831
|
die |
117
|
|
|
|
|
|
|
"SOAP::Transport::HTTP::Client must inherit from LWP::UserAgent, or one of its subclasses" |
118
|
|
|
|
|
|
|
if !$self->isa("LWP::UserAgent"); |
119
|
|
|
|
|
|
|
|
120
|
12
|
|
|
|
|
213
|
$self->agent( join '/', 'SOAP::Lite', 'Perl', |
121
|
|
|
|
|
|
|
$SOAP::Transport::HTTP::VERSION ); |
122
|
12
|
|
|
|
|
966
|
$self->options( {} ); |
123
|
|
|
|
|
|
|
|
124
|
12
|
|
|
|
|
107
|
$self->http_request( HTTP::Request->new() ); |
125
|
|
|
|
|
|
|
|
126
|
12
|
|
|
|
|
138
|
while (@methods) { |
127
|
12
|
|
|
|
|
55
|
my ( $method, $params ) = splice( @methods, 0, 2 ); |
128
|
12
|
50
|
|
|
|
106
|
$self->$method( ref $params eq 'ARRAY' ? @$params : $params ); |
129
|
|
|
|
|
|
|
} |
130
|
|
|
|
|
|
|
|
131
|
12
|
|
|
|
|
81
|
SOAP::Trace::objects('()'); |
132
|
|
|
|
|
|
|
|
133
|
12
|
|
|
|
|
67
|
$self->setDebugLogger(\&SOAP::Trace::debug); |
134
|
12
|
|
|
|
|
2146
|
return $self; |
135
|
|
|
|
|
|
|
} |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
sub send_receive { |
138
|
11
|
|
|
11
|
|
88
|
my ( $self, %parameters ) = @_; |
139
|
11
|
|
|
|
|
54
|
my ( $context, $envelope, $endpoint, $action, $encoding, $parts ) = |
140
|
|
|
|
|
|
|
@parameters{qw(context envelope endpoint action encoding parts)}; |
141
|
|
|
|
|
|
|
|
142
|
11
|
|
50
|
|
|
41
|
$encoding ||= 'UTF-8'; |
143
|
|
|
|
|
|
|
|
144
|
11
|
|
33
|
|
|
86
|
$endpoint ||= $self->endpoint; |
145
|
|
|
|
|
|
|
|
146
|
11
|
|
|
|
|
23
|
my $method = 'POST'; |
147
|
11
|
|
|
|
|
39
|
$COMPRESS = 'gzip'; |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
$self->options->{is_compress} ||= |
150
|
|
|
|
|
|
|
exists $self->options->{compress_threshold} |
151
|
11
|
|
33
|
|
|
60
|
&& eval { require Compress::Zlib }; |
|
|
|
33
|
|
|
|
|
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
# Initialize the basic about the HTTP Request object |
154
|
11
|
|
|
|
|
52
|
my $http_request = $self->http_request()->clone(); |
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
# $self->http_request(HTTP::Request->new); |
157
|
11
|
|
|
|
|
2590
|
$http_request->headers( HTTP::Headers->new ); |
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
# TODO - add application/dime |
160
|
11
|
|
|
|
|
308
|
$http_request->header( |
161
|
|
|
|
|
|
|
Accept => ['text/xml', 'multipart/*', 'application/soap'] ); |
162
|
11
|
|
|
|
|
1013
|
$http_request->method($method); |
163
|
11
|
|
|
|
|
127
|
$http_request->url($endpoint); |
164
|
|
|
|
|
|
|
|
165
|
13
|
|
|
13
|
|
94
|
no strict 'refs'; |
|
13
|
|
|
|
|
25
|
|
|
13
|
|
|
|
|
13087
|
|
166
|
11
|
50
|
|
|
|
96130
|
if ($parts) { |
167
|
0
|
|
|
|
|
0
|
my $packager = $context->packager; |
168
|
0
|
|
|
|
|
0
|
$envelope = $packager->package( $envelope, $context ); |
169
|
0
|
|
|
|
|
0
|
for my $hname ( keys %{$packager->headers_http} ) { |
|
0
|
|
|
|
|
0
|
|
170
|
0
|
|
|
|
|
0
|
$http_request->headers->header( |
171
|
|
|
|
|
|
|
$hname => $packager->headers_http->{$hname} ); |
172
|
|
|
|
|
|
|
} |
173
|
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
# TODO - DIME support |
175
|
|
|
|
|
|
|
} |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
COMPRESS: { |
178
|
11
|
|
33
|
|
|
28
|
my $compressed = |
|
11
|
|
|
|
|
137
|
|
179
|
|
|
|
|
|
|
!exists $nocompress{$endpoint} |
180
|
|
|
|
|
|
|
&& $self->options->{is_compress} |
181
|
|
|
|
|
|
|
&& ( $self->options->{compress_threshold} || 0 ) < length $envelope; |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
|
184
|
11
|
|
|
|
|
217
|
my $original_encoding = $http_request->content_encoding; |
185
|
|
|
|
|
|
|
|
186
|
11
|
|
|
|
|
1172
|
while (1) { |
187
|
|
|
|
|
|
|
|
188
|
|
|
|
|
|
|
# check cache for redirect |
189
|
11
|
50
|
|
|
|
57
|
$endpoint = $redirect{$endpoint} if exists $redirect{$endpoint}; |
190
|
|
|
|
|
|
|
|
191
|
|
|
|
|
|
|
# check cache for M-POST |
192
|
11
|
50
|
|
|
|
44
|
$method = 'M-POST' if exists $mpost{$endpoint}; |
193
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
# what's this all about? |
195
|
|
|
|
|
|
|
# unfortunately combination of LWP and Perl 5.6.1 and later has bug |
196
|
|
|
|
|
|
|
# in sending multibyte characters. LWP uses length() to calculate |
197
|
|
|
|
|
|
|
# content-length header and starting 5.6.1 length() calculates chars |
198
|
|
|
|
|
|
|
# instead of bytes. 'use bytes' in THIS file doesn't work, because |
199
|
|
|
|
|
|
|
# it's lexically scoped. Unfortunately, content-length we calculate |
200
|
|
|
|
|
|
|
# here doesn't work either, because LWP overwrites it with |
201
|
|
|
|
|
|
|
# content-length it calculates (which is wrong) AND uses length() |
202
|
|
|
|
|
|
|
# during syswrite/sysread, so we are in a bad shape anyway. |
203
|
|
|
|
|
|
|
# |
204
|
|
|
|
|
|
|
# what to do? we calculate proper content-length (using |
205
|
|
|
|
|
|
|
# bytelength() function from SOAP::Utils) and then drop utf8 mark |
206
|
|
|
|
|
|
|
# from string (doing pack with 'C0A*' modifier) if length and |
207
|
|
|
|
|
|
|
# bytelength are not the same |
208
|
11
|
|
|
|
|
75
|
my $bytelength = SOAP::Utils::bytelength($envelope); |
209
|
11
|
50
|
|
|
|
60
|
if ($] < 5.008) { |
210
|
0
|
|
|
|
|
0
|
$envelope = pack( 'C0A*', $envelope ); |
211
|
|
|
|
|
|
|
} |
212
|
|
|
|
|
|
|
else { |
213
|
11
|
|
|
|
|
120
|
require Encode; |
214
|
11
|
|
|
|
|
77
|
$envelope = Encode::encode($encoding, $envelope); |
215
|
|
|
|
|
|
|
} |
216
|
|
|
|
|
|
|
# if !$SOAP::Constants::DO_NOT_USE_LWP_LENGTH_HACK |
217
|
|
|
|
|
|
|
# && length($envelope) != $bytelength; |
218
|
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
# compress after encoding |
220
|
|
|
|
|
|
|
# doing it before breaks the compressed content (#74577) |
221
|
11
|
50
|
|
|
|
2253
|
$envelope = Compress::Zlib::memGzip($envelope) if $compressed; |
222
|
|
|
|
|
|
|
|
223
|
11
|
|
|
|
|
101
|
$http_request->content($envelope); |
224
|
11
|
|
|
|
|
384
|
$http_request->protocol('HTTP/1.1'); |
225
|
|
|
|
|
|
|
|
226
|
11
|
50
|
33
|
|
|
216
|
$http_request->proxy_authorization_basic( $ENV{'HTTP_proxy_user'}, |
227
|
|
|
|
|
|
|
$ENV{'HTTP_proxy_pass'} ) |
228
|
|
|
|
|
|
|
if ( $ENV{'HTTP_proxy_user'} && $ENV{'HTTP_proxy_pass'} ); |
229
|
|
|
|
|
|
|
|
230
|
|
|
|
|
|
|
# by Murray Nesbitt |
231
|
11
|
50
|
|
|
|
50
|
if ( $method eq 'M-POST' ) { |
232
|
0
|
|
|
|
|
0
|
my $prefix = sprintf '%04d', int( rand(1000) ); |
233
|
0
|
|
|
|
|
0
|
$http_request->header( |
234
|
|
|
|
|
|
|
Man => qq!"$SOAP::Constants::NS_ENV"; ns=$prefix! ); |
235
|
0
|
0
|
|
|
|
0
|
$http_request->header( "$prefix-SOAPAction" => $action ) |
236
|
|
|
|
|
|
|
if defined $action; |
237
|
|
|
|
|
|
|
} |
238
|
|
|
|
|
|
|
else { |
239
|
11
|
50
|
|
|
|
186
|
$http_request->header( SOAPAction => $action ) |
240
|
|
|
|
|
|
|
if defined $action; |
241
|
|
|
|
|
|
|
} |
242
|
|
|
|
|
|
|
|
243
|
|
|
|
|
|
|
# $http_request->header(Expect => '100-Continue'); |
244
|
|
|
|
|
|
|
|
245
|
|
|
|
|
|
|
# allow compress if present and let server know we could handle it |
246
|
11
|
50
|
|
|
|
859
|
$http_request->header( 'Accept-Encoding' => |
247
|
|
|
|
|
|
|
[$SOAP::Transport::HTTP::Client::COMPRESS] ) |
248
|
|
|
|
|
|
|
if $self->options->{is_compress}; |
249
|
|
|
|
|
|
|
|
250
|
11
|
50
|
|
|
|
43
|
$http_request->content_encoding( |
251
|
|
|
|
|
|
|
$SOAP::Transport::HTTP::Client::COMPRESS) |
252
|
|
|
|
|
|
|
if $compressed; |
253
|
|
|
|
|
|
|
|
254
|
11
|
50
|
0
|
|
|
136
|
if ( !$http_request->content_type ) { |
|
|
0
|
|
|
|
|
|
255
|
11
|
100
|
66
|
|
|
592
|
$http_request->content_type( |
256
|
|
|
|
|
|
|
join '; ', |
257
|
|
|
|
|
|
|
$SOAP::Constants::DEFAULT_HTTP_CONTENT_TYPE, |
258
|
|
|
|
|
|
|
!$SOAP::Constants::DO_NOT_USE_CHARSET && $encoding |
259
|
|
|
|
|
|
|
? 'charset=' . lc($encoding) |
260
|
|
|
|
|
|
|
: () ); |
261
|
|
|
|
|
|
|
} |
262
|
|
|
|
|
|
|
elsif ( !$SOAP::Constants::DO_NOT_USE_CHARSET && $encoding ) { |
263
|
0
|
|
|
|
|
0
|
my $tmpType = $http_request->headers->header('Content-type'); |
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
# $http_request->content_type($tmpType.'; charset=' . lc($encoding)); |
266
|
0
|
|
|
|
|
0
|
my $addition = '; charset=' . lc($encoding); |
267
|
0
|
0
|
|
|
|
0
|
$http_request->content_type( $tmpType . $addition ) |
268
|
|
|
|
|
|
|
if ( $tmpType !~ /$addition/ ); |
269
|
|
|
|
|
|
|
} |
270
|
|
|
|
|
|
|
|
271
|
11
|
|
|
|
|
258
|
$http_request->content_length($bytelength); |
272
|
11
|
|
|
|
|
604
|
SOAP::Trace::transport($http_request); |
273
|
11
|
|
|
|
|
62
|
&{$self->{debug_logger}}( $http_request->as_string ); |
|
11
|
|
|
|
|
3569
|
|
274
|
|
|
|
|
|
|
|
275
|
11
|
50
|
|
|
|
66
|
$self->SUPER::env_proxy if $ENV{'HTTP_proxy'}; |
276
|
|
|
|
|
|
|
|
277
|
|
|
|
|
|
|
# send and receive the stuff. |
278
|
|
|
|
|
|
|
# TODO maybe eval this? what happens on connection close? |
279
|
11
|
|
|
|
|
182
|
$self->http_response( $self->SUPER::request($http_request) ); |
280
|
11
|
|
|
|
|
41
|
SOAP::Trace::transport( $self->http_response ); |
281
|
11
|
|
|
|
|
35
|
&{$self->{debug_logger}}( $self->http_response->as_string ); |
|
11
|
|
|
|
|
1621
|
|
282
|
|
|
|
|
|
|
|
283
|
|
|
|
|
|
|
# 100 OK, continue to read? |
284
|
11
|
50
|
33
|
|
|
43
|
if ( ( |
|
|
50
|
33
|
|
|
|
|
|
|
|
33
|
|
|
|
|
285
|
|
|
|
|
|
|
$self->http_response->code == 510 |
286
|
|
|
|
|
|
|
|| $self->http_response->code == 501 |
287
|
|
|
|
|
|
|
) |
288
|
|
|
|
|
|
|
&& $method ne 'M-POST' |
289
|
|
|
|
|
|
|
) { |
290
|
0
|
|
|
|
|
0
|
$mpost{$endpoint} = 1; |
291
|
|
|
|
|
|
|
} |
292
|
|
|
|
|
|
|
elsif ( $self->http_response->code == 415 && $compressed ) { |
293
|
|
|
|
|
|
|
|
294
|
|
|
|
|
|
|
# 415 Unsupported Media Type |
295
|
0
|
|
|
|
|
0
|
$nocompress{$endpoint} = 1; |
296
|
0
|
|
|
|
|
0
|
$envelope = Compress::Zlib::memGunzip($envelope); |
297
|
0
|
|
|
|
|
0
|
$http_request->headers->remove_header('Content-Encoding'); |
298
|
0
|
|
|
|
|
0
|
redo COMPRESS; # try again without compression |
299
|
|
|
|
|
|
|
} |
300
|
|
|
|
|
|
|
else { |
301
|
11
|
|
|
|
|
135
|
last; |
302
|
|
|
|
|
|
|
} |
303
|
|
|
|
|
|
|
} |
304
|
|
|
|
|
|
|
} |
305
|
|
|
|
|
|
|
|
306
|
11
|
50
|
33
|
|
|
43
|
$redirect{$endpoint} = $self->http_response->request->url |
307
|
|
|
|
|
|
|
if $self->http_response->previous |
308
|
|
|
|
|
|
|
&& $self->http_response->previous->is_redirect; |
309
|
|
|
|
|
|
|
|
310
|
11
|
|
|
|
|
128
|
$self->code( $self->http_response->code ); |
311
|
11
|
|
|
|
|
47
|
$self->message( $self->http_response->message ); |
312
|
11
|
|
|
|
|
47
|
$self->is_success( $self->http_response->is_success ); |
313
|
11
|
|
|
|
|
44
|
$self->status( $self->http_response->status_line ); |
314
|
|
|
|
|
|
|
|
315
|
|
|
|
|
|
|
# Pull out any cookies from the response headers |
316
|
11
|
50
|
|
|
|
64
|
$self->{'_cookie_jar'}->extract_cookies( $self->http_response ) |
317
|
|
|
|
|
|
|
if $self->{'_cookie_jar'}; |
318
|
|
|
|
|
|
|
|
319
|
11
|
50
|
33
|
|
|
44
|
my $content = |
|
|
50
|
50
|
|
|
|
|
320
|
|
|
|
|
|
|
( $self->http_response->content_encoding || '' ) =~ |
321
|
|
|
|
|
|
|
/\b$SOAP::Transport::HTTP::Client::COMPRESS\b/o |
322
|
|
|
|
|
|
|
&& $self->options->{is_compress} |
323
|
|
|
|
|
|
|
? Compress::Zlib::memGunzip( $self->http_response->content ) |
324
|
|
|
|
|
|
|
: ( $self->http_response->content_encoding || '' ) =~ /\S/ ? die |
325
|
0
|
|
|
|
|
0
|
"Can't understand returned Content-Encoding (@{[$self->http_response->content_encoding]})\n" |
326
|
|
|
|
|
|
|
: $self->http_response->content; |
327
|
|
|
|
|
|
|
|
328
|
11
|
50
|
|
|
|
130
|
return $self->http_response->content_type =~ m!^multipart/!i |
329
|
|
|
|
|
|
|
? join( "\n", $self->http_response->headers_as_string, $content ) |
330
|
|
|
|
|
|
|
: $content; |
331
|
|
|
|
|
|
|
} |
332
|
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
# ====================================================================== |
334
|
|
|
|
|
|
|
|
335
|
|
|
|
|
|
|
package SOAP::Transport::HTTP::Server; |
336
|
|
|
|
|
|
|
|
337
|
13
|
|
|
13
|
|
96
|
use vars qw(@ISA $COMPRESS); |
|
13
|
|
|
|
|
26
|
|
|
13
|
|
|
|
|
959
|
|
338
|
|
|
|
|
|
|
@ISA = qw(SOAP::Server); |
339
|
|
|
|
|
|
|
|
340
|
13
|
|
|
13
|
|
78
|
use URI; |
|
13
|
|
|
|
|
26
|
|
|
13
|
|
|
|
|
3661
|
|
341
|
|
|
|
|
|
|
|
342
|
|
|
|
|
|
|
$COMPRESS = 'deflate'; |
343
|
|
|
|
|
|
|
|
344
|
0
|
|
|
0
|
|
|
sub DESTROY { SOAP::Trace::objects('()') } |
345
|
|
|
|
|
|
|
|
346
|
|
|
|
|
|
|
sub new { |
347
|
0
|
|
|
0
|
|
|
require LWP::UserAgent; |
348
|
0
|
|
|
|
|
|
my $self = shift; |
349
|
0
|
0
|
|
|
|
|
return $self if ref $self; # we're already an object |
350
|
|
|
|
|
|
|
|
351
|
0
|
|
|
|
|
|
my $class = $self; |
352
|
0
|
|
|
|
|
|
$self = $class->SUPER::new(@_); |
353
|
|
|
|
|
|
|
$self->{'_on_action'} = sub { |
354
|
0
|
|
0
|
0
|
|
|
( my $action = shift || '' ) =~ s/^(\"?)(.*)\1$/$2/; |
355
|
0
|
0
|
0
|
|
|
|
die |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
356
|
0
|
|
|
|
|
|
"SOAPAction shall match 'uri#method' if present (got '$action', expected '@{[join('#', @_)]}'\n" |
357
|
|
|
|
|
|
|
if $action |
358
|
|
|
|
|
|
|
&& $action ne join( '#', @_ ) |
359
|
|
|
|
|
|
|
&& $action ne join( '/', @_ ) |
360
|
|
|
|
|
|
|
&& ( substr( $_[0], -1, 1 ) ne '/' |
361
|
|
|
|
|
|
|
|| $action ne join( '', @_ ) ); |
362
|
0
|
|
|
|
|
|
}; |
363
|
0
|
|
|
|
|
|
SOAP::Trace::objects('()'); |
364
|
|
|
|
|
|
|
|
365
|
0
|
|
|
|
|
|
return $self; |
366
|
|
|
|
|
|
|
} |
367
|
|
|
|
|
|
|
|
368
|
|
|
|
|
|
|
sub BEGIN { |
369
|
13
|
|
|
13
|
|
80
|
no strict 'refs'; |
|
13
|
|
|
|
|
23
|
|
|
13
|
|
|
|
|
1157
|
|
370
|
13
|
|
|
13
|
|
42
|
for my $method (qw(request response)) { |
371
|
26
|
|
|
|
|
55
|
my $field = '_' . $method; |
372
|
|
|
|
|
|
|
*$method = sub { |
373
|
0
|
|
|
0
|
|
0
|
my $self = shift->new; |
374
|
|
|
|
|
|
|
@_ |
375
|
0
|
0
|
|
|
|
0
|
? ( $self->{$field} = shift, return $self ) |
376
|
|
|
|
|
|
|
: return $self->{$field}; |
377
|
26
|
|
|
|
|
15739
|
}; |
378
|
|
|
|
|
|
|
} |
379
|
|
|
|
|
|
|
} |
380
|
|
|
|
|
|
|
|
381
|
|
|
|
|
|
|
sub handle { |
382
|
0
|
|
|
0
|
|
|
my $self = shift->new; |
383
|
|
|
|
|
|
|
|
384
|
0
|
|
|
|
|
|
&{$self->{debug_logger}}( $self->request->content ); |
|
0
|
|
|
|
|
|
|
385
|
|
|
|
|
|
|
|
386
|
0
|
0
|
|
|
|
|
if ( $self->request->method eq 'POST' ) { |
|
|
0
|
|
|
|
|
|
387
|
0
|
|
0
|
|
|
|
$self->action( $self->request->header('SOAPAction') || undef ); |
388
|
|
|
|
|
|
|
} |
389
|
|
|
|
|
|
|
elsif ( $self->request->method eq 'M-POST' ) { |
390
|
0
|
0
|
|
|
|
|
return $self->response( |
391
|
|
|
|
|
|
|
HTTP::Response->new( |
392
|
|
|
|
|
|
|
510, # NOT EXTENDED |
393
|
|
|
|
|
|
|
"Expected Mandatory header with $SOAP::Constants::NS_ENV as unique URI" |
394
|
|
|
|
|
|
|
) ) |
395
|
|
|
|
|
|
|
if $self->request->header('Man') !~ |
396
|
|
|
|
|
|
|
/^"$SOAP::Constants::NS_ENV";\s*ns\s*=\s*(\d+)/; |
397
|
0
|
|
0
|
|
|
|
$self->action( $self->request->header("$1-SOAPAction") || undef ); |
398
|
|
|
|
|
|
|
} |
399
|
|
|
|
|
|
|
else { |
400
|
0
|
|
|
|
|
|
return $self->response( |
401
|
|
|
|
|
|
|
HTTP::Response->new(405) ) # METHOD NOT ALLOWED |
402
|
|
|
|
|
|
|
} |
403
|
|
|
|
|
|
|
|
404
|
0
|
|
0
|
|
|
|
my $compressed = |
405
|
|
|
|
|
|
|
( $self->request->content_encoding || '' ) =~ /\b$COMPRESS\b/; |
406
|
|
|
|
|
|
|
$self->options->{is_compress} ||= |
407
|
0
|
|
0
|
|
|
|
$compressed && eval { require Compress::Zlib }; |
|
|
|
0
|
|
|
|
|
408
|
|
|
|
|
|
|
|
409
|
|
|
|
|
|
|
# signal error if content-encoding is 'deflate', but we don't want it OR |
410
|
|
|
|
|
|
|
# something else, so we don't understand it |
411
|
0
|
0
|
0
|
|
|
|
return $self->response( |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
412
|
|
|
|
|
|
|
HTTP::Response->new(415) ) # UNSUPPORTED MEDIA TYPE |
413
|
|
|
|
|
|
|
if $compressed && !$self->options->{is_compress} |
414
|
|
|
|
|
|
|
|| !$compressed |
415
|
|
|
|
|
|
|
&& ( $self->request->content_encoding || '' ) =~ /\S/; |
416
|
|
|
|
|
|
|
|
417
|
0
|
|
0
|
|
|
|
my $content_type = $self->request->content_type || ''; |
418
|
|
|
|
|
|
|
|
419
|
|
|
|
|
|
|
# in some environments (PerlEx?) content_type could be empty, so allow it also |
420
|
|
|
|
|
|
|
# anyway it'll blow up inside ::Server::handle if something wrong with message |
421
|
|
|
|
|
|
|
# TBD: but what to do with MIME encoded messages in THOSE environments? |
422
|
0
|
0
|
0
|
|
|
|
return $self->make_fault( $SOAP::Constants::FAULT_CLIENT, |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
423
|
|
|
|
|
|
|
"Content-Type must be 'text/xml,' 'multipart/*,' " |
424
|
|
|
|
|
|
|
. "'application/soap+xml,' 'or 'application/dime' instead of '$content_type'" |
425
|
|
|
|
|
|
|
) |
426
|
|
|
|
|
|
|
if !$SOAP::Constants::DO_NOT_CHECK_CONTENT_TYPE |
427
|
|
|
|
|
|
|
&& $content_type |
428
|
|
|
|
|
|
|
&& $content_type ne 'application/soap+xml' |
429
|
|
|
|
|
|
|
&& $content_type ne 'text/xml' |
430
|
|
|
|
|
|
|
&& $content_type ne 'application/dime' |
431
|
|
|
|
|
|
|
&& $content_type !~ m!^multipart/!; |
432
|
|
|
|
|
|
|
|
433
|
|
|
|
|
|
|
# TODO - Handle the Expect: 100-Continue HTTP/1.1 Header |
434
|
0
|
0
|
0
|
|
|
|
if ( defined( $self->request->header("Expect") ) |
435
|
|
|
|
|
|
|
&& ( $self->request->header("Expect") eq "100-Continue" ) ) { |
436
|
|
|
|
|
|
|
|
437
|
|
|
|
|
|
|
} |
438
|
|
|
|
|
|
|
|
439
|
|
|
|
|
|
|
# TODO - this should query SOAP::Packager to see what types it supports, |
440
|
|
|
|
|
|
|
# I don't like how this is hardcoded here. |
441
|
0
|
0
|
|
|
|
|
my $content = |
442
|
|
|
|
|
|
|
$compressed |
443
|
|
|
|
|
|
|
? Compress::Zlib::uncompress( $self->request->content ) |
444
|
|
|
|
|
|
|
: $self->request->content; |
445
|
|
|
|
|
|
|
|
446
|
0
|
0
|
|
|
|
|
my $response = $self->SUPER::handle( |
|
|
0
|
|
|
|
|
|
447
|
|
|
|
|
|
|
$self->request->content_type =~ m!^multipart/! |
448
|
|
|
|
|
|
|
? join( "\n", $self->request->headers_as_string, $content ) |
449
|
|
|
|
|
|
|
: $content |
450
|
|
|
|
|
|
|
) or return; |
451
|
|
|
|
|
|
|
|
452
|
0
|
|
|
|
|
|
&{$self->{debug_logger}}($response); |
|
0
|
|
|
|
|
|
|
453
|
|
|
|
|
|
|
|
454
|
0
|
|
|
|
|
|
$self->make_response( $SOAP::Constants::HTTP_ON_SUCCESS_CODE, $response ); |
455
|
|
|
|
|
|
|
} |
456
|
|
|
|
|
|
|
|
457
|
|
|
|
|
|
|
sub make_fault { |
458
|
0
|
|
|
0
|
|
|
my $self = shift; |
459
|
0
|
|
|
|
|
|
$self->make_response( |
460
|
|
|
|
|
|
|
$SOAP::Constants::HTTP_ON_FAULT_CODE => $self->SUPER::make_fault(@_) |
461
|
|
|
|
|
|
|
); |
462
|
0
|
|
|
|
|
|
return; |
463
|
|
|
|
|
|
|
} |
464
|
|
|
|
|
|
|
|
465
|
|
|
|
|
|
|
sub make_response { |
466
|
0
|
|
|
0
|
|
|
my ( $self, $code, $response ) = @_; |
467
|
|
|
|
|
|
|
|
468
|
0
|
0
|
|
|
|
|
my $encoding = $1 |
469
|
|
|
|
|
|
|
if $response =~ /^<\?xml(?: version="1.0"| encoding="([^\"]+)")+\?>/; |
470
|
|
|
|
|
|
|
|
471
|
0
|
0
|
|
|
|
|
$response =~ s!(\?>)!$1! |
472
|
|
|
|
|
|
|
if $self->request->content_type eq 'multipart/form-data'; |
473
|
|
|
|
|
|
|
|
474
|
|
|
|
|
|
|
$self->options->{is_compress} ||= |
475
|
|
|
|
|
|
|
exists $self->options->{compress_threshold} |
476
|
0
|
|
0
|
|
|
|
&& eval { require Compress::Zlib }; |
|
|
|
0
|
|
|
|
|
477
|
|
|
|
|
|
|
|
478
|
0
|
|
0
|
|
|
|
my $compressed = $self->options->{is_compress} |
479
|
|
|
|
|
|
|
&& grep( /\b($COMPRESS|\*)\b/, |
480
|
|
|
|
|
|
|
$self->request->header('Accept-Encoding') ) |
481
|
|
|
|
|
|
|
&& ( $self->options->{compress_threshold} || 0 ) < |
482
|
|
|
|
|
|
|
SOAP::Utils::bytelength $response; |
483
|
|
|
|
|
|
|
|
484
|
0
|
0
|
|
|
|
|
$response = Compress::Zlib::compress($response) if $compressed; |
485
|
|
|
|
|
|
|
|
486
|
|
|
|
|
|
|
# this next line does not look like a good test to see if something is multipart |
487
|
|
|
|
|
|
|
# perhaps a /content-type:.*multipart\//gi is a better regex? |
488
|
0
|
|
|
|
|
|
my ($is_multipart) = |
489
|
|
|
|
|
|
|
( $response =~ /^content-type:.* boundary="([^\"]*)"/im ); |
490
|
|
|
|
|
|
|
|
491
|
|
|
|
|
|
|
$self->response( |
492
|
|
|
|
|
|
|
HTTP::Response->new( |
493
|
|
|
|
|
|
|
$code => undef, |
494
|
|
|
|
|
|
|
HTTP::Headers->new( |
495
|
|
|
|
|
|
|
'SOAPServer' => $self->product_tokens, |
496
|
|
|
|
|
|
|
$compressed ? ( 'Content-Encoding' => $COMPRESS ) : (), |
497
|
|
|
|
|
|
|
'Content-Type' => join( '; ', |
498
|
|
|
|
|
|
|
'text/xml', |
499
|
|
|
|
|
|
|
!$SOAP::Constants::DO_NOT_USE_CHARSET |
500
|
|
|
|
|
|
|
&& $encoding ? 'charset=' . lc($encoding) : () ), |
501
|
|
|
|
|
|
|
'Content-Length' => SOAP::Utils::bytelength $response |
502
|
|
|
|
|
|
|
), |
503
|
|
|
|
|
|
|
( $] > 5.007 ) |
504
|
0
|
0
|
0
|
|
|
|
? do { require Encode; Encode::encode( $encoding, $response ) } |
|
0
|
0
|
|
|
|
|
|
|
0
|
0
|
|
|
|
|
|
505
|
|
|
|
|
|
|
: $response, |
506
|
|
|
|
|
|
|
) ); |
507
|
|
|
|
|
|
|
|
508
|
0
|
0
|
|
|
|
|
$self->response->headers->header( 'Content-Type' => |
509
|
|
|
|
|
|
|
'Multipart/Related; type="text/xml"; start=""; boundary="' |
510
|
|
|
|
|
|
|
. $is_multipart |
511
|
|
|
|
|
|
|
. '"' ) |
512
|
|
|
|
|
|
|
if $is_multipart; |
513
|
|
|
|
|
|
|
} |
514
|
|
|
|
|
|
|
|
515
|
|
|
|
|
|
|
# ->VERSION leaks a scalar every call - no idea why. |
516
|
|
|
|
|
|
|
sub product_tokens { |
517
|
0
|
|
|
0
|
|
|
join '/', 'SOAP::Lite', 'Perl', $SOAP::Transport::HTTP::VERSION; |
518
|
|
|
|
|
|
|
} |
519
|
|
|
|
|
|
|
|
520
|
|
|
|
|
|
|
# ====================================================================== |
521
|
|
|
|
|
|
|
|
522
|
|
|
|
|
|
|
package SOAP::Transport::HTTP::CGI; |
523
|
|
|
|
|
|
|
|
524
|
13
|
|
|
13
|
|
101
|
use vars qw(@ISA); |
|
13
|
|
|
|
|
25
|
|
|
13
|
|
|
|
|
9938
|
|
525
|
|
|
|
|
|
|
@ISA = qw(SOAP::Transport::HTTP::Server); |
526
|
|
|
|
|
|
|
|
527
|
0
|
|
|
0
|
|
|
sub DESTROY { SOAP::Trace::objects('()') } |
528
|
|
|
|
|
|
|
|
529
|
|
|
|
|
|
|
sub new { |
530
|
0
|
|
|
0
|
|
|
my $self = shift; |
531
|
0
|
0
|
|
|
|
|
return $self if ref $self; |
532
|
|
|
|
|
|
|
|
533
|
0
|
|
0
|
|
|
|
my $class = ref($self) || $self; |
534
|
0
|
|
|
|
|
|
$self = $class->SUPER::new(@_); |
535
|
0
|
|
|
|
|
|
SOAP::Trace::objects('()'); |
536
|
|
|
|
|
|
|
|
537
|
0
|
|
|
|
|
|
return $self; |
538
|
|
|
|
|
|
|
} |
539
|
|
|
|
|
|
|
|
540
|
|
|
|
|
|
|
sub make_response { |
541
|
0
|
|
|
0
|
|
|
my $self = shift; |
542
|
0
|
|
|
|
|
|
$self->SUPER::make_response(@_); |
543
|
|
|
|
|
|
|
} |
544
|
|
|
|
|
|
|
|
545
|
|
|
|
|
|
|
sub handle { |
546
|
0
|
|
|
0
|
|
|
my $self = shift->new; |
547
|
|
|
|
|
|
|
|
548
|
0
|
|
0
|
|
|
|
my $length = $ENV{'CONTENT_LENGTH'} || 0; |
549
|
|
|
|
|
|
|
|
550
|
|
|
|
|
|
|
# if the HTTP_TRANSFER_ENCODING env is defined, set $chunked if it's chunked* |
551
|
|
|
|
|
|
|
# else to false |
552
|
0
|
|
0
|
|
|
|
my $chunked = (defined $ENV{'HTTP_TRANSFER_ENCODING'} |
553
|
|
|
|
|
|
|
&& $ENV{'HTTP_TRANSFER_ENCODING'} =~ /^chunked.*$/) || 0; |
554
|
|
|
|
|
|
|
|
555
|
|
|
|
|
|
|
|
556
|
0
|
|
|
|
|
|
my $content = q{}; |
557
|
|
|
|
|
|
|
|
558
|
0
|
0
|
|
|
|
|
if ($chunked) { |
559
|
0
|
|
|
|
|
|
my $buffer; |
560
|
0
|
|
|
|
|
|
binmode(STDIN); |
561
|
0
|
|
|
|
|
|
while ( read( STDIN, my $buffer, 1024 ) ) { |
562
|
0
|
|
|
|
|
|
$content .= $buffer; |
563
|
|
|
|
|
|
|
} |
564
|
0
|
|
|
|
|
|
$length = length($content); |
565
|
|
|
|
|
|
|
} |
566
|
|
|
|
|
|
|
|
567
|
0
|
0
|
0
|
|
|
|
if ( !$length ) { |
|
|
0
|
|
|
|
|
|
568
|
0
|
|
|
|
|
|
$self->response( HTTP::Response->new(411) ) # LENGTH REQUIRED |
569
|
|
|
|
|
|
|
} |
570
|
|
|
|
|
|
|
elsif ( defined $SOAP::Constants::MAX_CONTENT_SIZE |
571
|
|
|
|
|
|
|
&& $length > $SOAP::Constants::MAX_CONTENT_SIZE ) { |
572
|
0
|
|
|
|
|
|
$self->response( HTTP::Response->new(413) ) # REQUEST ENTITY TOO LARGE |
573
|
|
|
|
|
|
|
} |
574
|
|
|
|
|
|
|
else { |
575
|
0
|
0
|
0
|
|
|
|
if ( exists $ENV{EXPECT} && $ENV{EXPECT} =~ /\b100-Continue\b/i ) { |
576
|
0
|
|
|
|
|
|
print "HTTP/1.1 100 Continue\r\n\r\n"; |
577
|
|
|
|
|
|
|
} |
578
|
|
|
|
|
|
|
|
579
|
|
|
|
|
|
|
#my $content = q{}; |
580
|
0
|
0
|
|
|
|
|
if ( !$chunked ) { |
581
|
0
|
|
|
|
|
|
my $buffer; |
582
|
0
|
|
|
|
|
|
binmode(STDIN); |
583
|
0
|
0
|
|
|
|
|
if ( defined $ENV{'MOD_PERL'} ) { |
584
|
0
|
|
|
|
|
|
while ( read( STDIN, $buffer, $length ) ) { |
585
|
0
|
|
|
|
|
|
$content .= $buffer; |
586
|
0
|
0
|
|
|
|
|
last if ( length($content) >= $length ); |
587
|
|
|
|
|
|
|
} |
588
|
|
|
|
|
|
|
} else { |
589
|
0
|
|
|
|
|
|
while ( sysread( STDIN, $buffer, $length ) ) { |
590
|
0
|
|
|
|
|
|
$content .= $buffer; |
591
|
0
|
0
|
|
|
|
|
last if ( length($content) >= $length ); |
592
|
|
|
|
|
|
|
} |
593
|
|
|
|
|
|
|
} |
594
|
|
|
|
|
|
|
} |
595
|
|
|
|
|
|
|
|
596
|
|
|
|
|
|
|
$self->request( |
597
|
0
|
0
|
|
|
|
|
HTTP::Request->new( |
|
|
0
|
|
|
|
|
|
598
|
|
|
|
|
|
|
$ENV{'REQUEST_METHOD'} || '' => $ENV{'SCRIPT_NAME'}, |
599
|
|
|
|
|
|
|
HTTP::Headers->new( |
600
|
0
|
|
0
|
|
|
|
map { ( |
601
|
|
|
|
|
|
|
/^HTTP_(.+)/i |
602
|
|
|
|
|
|
|
? ( $1 =~ m/SOAPACTION/ ) |
603
|
|
|
|
|
|
|
? ('SOAPAction') |
604
|
|
|
|
|
|
|
: ($1) |
605
|
|
|
|
|
|
|
: $_ |
606
|
|
|
|
|
|
|
) => $ENV{$_} |
607
|
|
|
|
|
|
|
} keys %ENV |
608
|
|
|
|
|
|
|
), |
609
|
|
|
|
|
|
|
$content, |
610
|
|
|
|
|
|
|
) ); |
611
|
0
|
|
|
|
|
|
$self->SUPER::handle; |
612
|
|
|
|
|
|
|
} |
613
|
|
|
|
|
|
|
|
614
|
|
|
|
|
|
|
# imitate nph- cgi for IIS (pointed by Murray Nesbitt) |
615
|
0
|
0
|
0
|
|
|
|
my $status = |
|
|
|
0
|
|
|
|
|
616
|
|
|
|
|
|
|
defined( $ENV{'SERVER_SOFTWARE'} ) |
617
|
|
|
|
|
|
|
&& $ENV{'SERVER_SOFTWARE'} =~ /IIS/ |
618
|
|
|
|
|
|
|
? $ENV{SERVER_PROTOCOL} || 'HTTP/1.0' |
619
|
|
|
|
|
|
|
: 'Status:'; |
620
|
0
|
|
|
|
|
|
my $code = $self->response->code; |
621
|
|
|
|
|
|
|
|
622
|
0
|
|
|
|
|
|
binmode(STDOUT); |
623
|
|
|
|
|
|
|
|
624
|
0
|
|
|
|
|
|
print STDOUT "$status $code ", HTTP::Status::status_message($code), |
625
|
|
|
|
|
|
|
"\015\012", $self->response->headers_as_string("\015\012"), "\015\012", |
626
|
|
|
|
|
|
|
$self->response->content; |
627
|
|
|
|
|
|
|
} |
628
|
|
|
|
|
|
|
|
629
|
|
|
|
|
|
|
# ====================================================================== |
630
|
|
|
|
|
|
|
|
631
|
|
|
|
|
|
|
package SOAP::Transport::HTTP::Daemon; |
632
|
|
|
|
|
|
|
|
633
|
13
|
|
|
13
|
|
102
|
use Carp (); |
|
13
|
|
|
|
|
1643
|
|
|
13
|
|
|
|
|
347
|
|
634
|
13
|
|
|
13
|
|
70
|
use vars qw($AUTOLOAD @ISA); |
|
13
|
|
|
|
|
30
|
|
|
13
|
|
|
|
|
6271
|
|
635
|
|
|
|
|
|
|
@ISA = qw(SOAP::Transport::HTTP::Server); |
636
|
|
|
|
|
|
|
|
637
|
0
|
|
|
0
|
|
|
sub DESTROY { SOAP::Trace::objects('()') } |
638
|
|
|
|
|
|
|
|
639
|
|
|
|
|
|
|
#sub new { require HTTP::Daemon; |
640
|
|
|
|
|
|
|
sub new { |
641
|
0
|
|
|
0
|
|
|
my $self = shift; |
642
|
0
|
0
|
|
|
|
|
return $self if ( ref $self ); |
643
|
|
|
|
|
|
|
|
644
|
0
|
|
|
|
|
|
my $class = $self; |
645
|
|
|
|
|
|
|
|
646
|
0
|
|
|
|
|
|
my ( @params, @methods ); |
647
|
0
|
|
|
|
|
|
while (@_) { |
648
|
0
|
0
|
|
|
|
|
$class->can( $_[0] ) |
649
|
|
|
|
|
|
|
? push( @methods, shift() => shift ) |
650
|
|
|
|
|
|
|
: push( @params, shift ); |
651
|
|
|
|
|
|
|
} |
652
|
0
|
|
|
|
|
|
$self = $class->SUPER::new; |
653
|
|
|
|
|
|
|
|
654
|
|
|
|
|
|
|
# Added in 0.65 - Thanks to Nils Sowen |
655
|
|
|
|
|
|
|
# use SSL if there is any parameter with SSL_* in the name |
656
|
0
|
0
|
0
|
|
|
|
$self->SSL(1) if !$self->SSL && grep /^SSL_/, @params; |
657
|
0
|
|
|
|
|
|
my $http_daemon = $self->http_daemon_class; |
658
|
0
|
0
|
0
|
|
|
|
eval "require $http_daemon" |
659
|
|
|
|
|
|
|
or Carp::croak $@ |
660
|
|
|
|
|
|
|
unless $http_daemon->can('new'); |
661
|
|
|
|
|
|
|
|
662
|
0
|
0
|
|
|
|
|
$self->{_daemon} = $http_daemon->new(@params) |
663
|
|
|
|
|
|
|
or Carp::croak "Can't create daemon: $!"; |
664
|
|
|
|
|
|
|
|
665
|
|
|
|
|
|
|
# End SSL patch |
666
|
|
|
|
|
|
|
|
667
|
0
|
|
|
|
|
|
$self->myuri( URI->new( $self->url )->canonical->as_string ); |
668
|
|
|
|
|
|
|
|
669
|
0
|
|
|
|
|
|
while (@methods) { |
670
|
0
|
|
|
|
|
|
my ( $method, $params ) = splice( @methods, 0, 2 ); |
671
|
0
|
0
|
|
|
|
|
$self->$method( |
672
|
|
|
|
|
|
|
ref $params eq 'ARRAY' |
673
|
|
|
|
|
|
|
? @$params |
674
|
|
|
|
|
|
|
: $params |
675
|
|
|
|
|
|
|
); |
676
|
|
|
|
|
|
|
} |
677
|
0
|
|
|
|
|
|
SOAP::Trace::objects('()'); |
678
|
|
|
|
|
|
|
|
679
|
0
|
|
|
|
|
|
return $self; |
680
|
|
|
|
|
|
|
} |
681
|
|
|
|
|
|
|
|
682
|
|
|
|
|
|
|
sub SSL { |
683
|
0
|
|
|
0
|
|
|
my $self = shift->new; |
684
|
0
|
0
|
|
|
|
|
if (@_) { |
685
|
0
|
|
|
|
|
|
$self->{_SSL} = shift; |
686
|
0
|
|
|
|
|
|
return $self; |
687
|
|
|
|
|
|
|
} |
688
|
0
|
|
|
|
|
|
return $self->{_SSL}; |
689
|
|
|
|
|
|
|
} |
690
|
|
|
|
|
|
|
|
691
|
0
|
0
|
|
0
|
|
|
sub http_daemon_class { shift->SSL ? 'HTTP::Daemon::SSL' : 'HTTP::Daemon' } |
692
|
|
|
|
|
|
|
|
693
|
|
|
|
|
|
|
sub AUTOLOAD { |
694
|
0
|
|
|
0
|
|
|
my $method = substr( $AUTOLOAD, rindex( $AUTOLOAD, '::' ) + 2 ); |
695
|
0
|
0
|
|
|
|
|
return if $method eq 'DESTROY'; |
696
|
|
|
|
|
|
|
|
697
|
13
|
|
|
13
|
|
91
|
no strict 'refs'; |
|
13
|
|
|
|
|
22
|
|
|
13
|
|
|
|
|
3464
|
|
698
|
0
|
|
|
0
|
|
|
*$AUTOLOAD = sub { shift->{_daemon}->$method(@_) }; |
|
0
|
|
|
|
|
|
|
699
|
0
|
|
|
|
|
|
goto &$AUTOLOAD; |
700
|
|
|
|
|
|
|
} |
701
|
|
|
|
|
|
|
|
702
|
|
|
|
|
|
|
sub handle { |
703
|
0
|
|
|
0
|
|
|
my $self = shift->new; |
704
|
0
|
|
|
|
|
|
while ( my $c = $self->accept ) { |
705
|
0
|
|
|
|
|
|
while ( my $r = $c->get_request ) { |
706
|
0
|
|
|
|
|
|
$self->request($r); |
707
|
0
|
|
|
|
|
|
$self->SUPER::handle; |
708
|
0
|
|
|
|
|
|
eval { |
709
|
0
|
|
|
0
|
|
|
local $SIG{PIPE} = sub {die "SIGPIPE"}; |
|
0
|
|
|
|
|
|
|
710
|
0
|
|
|
|
|
|
$c->send_response( $self->response ); |
711
|
|
|
|
|
|
|
}; |
712
|
0
|
0
|
0
|
|
|
|
if ($@ && $@ !~ /^SIGPIPE/) { |
713
|
0
|
|
|
|
|
|
die $@; |
714
|
|
|
|
|
|
|
} |
715
|
|
|
|
|
|
|
} |
716
|
|
|
|
|
|
|
|
717
|
|
|
|
|
|
|
# replaced ->close, thanks to Sean Meisner |
718
|
|
|
|
|
|
|
# shutdown() doesn't work on AIX. close() is used in this case. Thanks to Jos Clijmans |
719
|
0
|
0
|
|
|
|
|
$c->can('shutdown') |
720
|
|
|
|
|
|
|
? $c->shutdown(2) |
721
|
|
|
|
|
|
|
: $c->close(); |
722
|
0
|
|
|
|
|
|
$c->close; |
723
|
|
|
|
|
|
|
} |
724
|
|
|
|
|
|
|
} |
725
|
|
|
|
|
|
|
|
726
|
|
|
|
|
|
|
# ====================================================================== |
727
|
|
|
|
|
|
|
|
728
|
|
|
|
|
|
|
package SOAP::Transport::HTTP::Apache; |
729
|
|
|
|
|
|
|
|
730
|
13
|
|
|
13
|
|
80
|
use vars qw(@ISA); |
|
13
|
|
|
|
|
24
|
|
|
13
|
|
|
|
|
13882
|
|
731
|
|
|
|
|
|
|
@ISA = qw(SOAP::Transport::HTTP::Server); |
732
|
|
|
|
|
|
|
|
733
|
0
|
|
|
0
|
|
|
sub DESTROY { SOAP::Trace::objects('()') } |
734
|
|
|
|
|
|
|
|
735
|
|
|
|
|
|
|
sub new { |
736
|
0
|
|
|
0
|
|
|
my $self = shift; |
737
|
0
|
0
|
|
|
|
|
unless ( ref $self ) { |
738
|
0
|
|
0
|
|
|
|
my $class = ref($self) || $self; |
739
|
0
|
|
|
|
|
|
$self = $class->SUPER::new(@_); |
740
|
0
|
|
|
|
|
|
SOAP::Trace::objects('()'); |
741
|
|
|
|
|
|
|
} |
742
|
|
|
|
|
|
|
|
743
|
|
|
|
|
|
|
# Added this code thanks to JT Justman |
744
|
|
|
|
|
|
|
# This code improves and provides more robust support for |
745
|
|
|
|
|
|
|
# multiple versions of Apache and mod_perl |
746
|
|
|
|
|
|
|
|
747
|
|
|
|
|
|
|
# mod_perl 2.0 |
748
|
0
|
0
|
0
|
|
|
|
if ( defined $ENV{MOD_PERL_API_VERSION} |
749
|
|
|
|
|
|
|
&& $ENV{MOD_PERL_API_VERSION} >= 2 ) { |
750
|
0
|
|
|
|
|
|
require Apache2::RequestRec; |
751
|
0
|
|
|
|
|
|
require Apache2::RequestIO; |
752
|
0
|
|
|
|
|
|
require Apache2::Const; |
753
|
0
|
|
|
|
|
|
require Apache2::RequestUtil; |
754
|
0
|
|
|
|
|
|
require APR::Table; |
755
|
0
|
|
|
|
|
|
Apache2::Const->import( -compile => 'OK' ); |
756
|
0
|
|
|
|
|
|
Apache2::Const->import( -compile => 'HTTP_BAD_REQUEST' ); |
757
|
0
|
|
|
|
|
|
$self->{'MOD_PERL_VERSION'} = 2; |
758
|
0
|
|
|
|
|
|
$self->{OK} = &Apache2::Const::OK; |
759
|
|
|
|
|
|
|
} |
760
|
|
|
|
|
|
|
else { # mod_perl 1.xx |
761
|
0
|
0
|
|
|
|
|
die "Could not find or load mod_perl" |
762
|
|
|
|
|
|
|
unless ( eval "require mod_perl" ); |
763
|
0
|
0
|
|
|
|
|
die "Could not detect your version of mod_perl" |
764
|
|
|
|
|
|
|
if ( !defined($mod_perl::VERSION) ); |
765
|
0
|
0
|
|
|
|
|
if ( $mod_perl::VERSION < 1.99 ) { |
766
|
0
|
|
|
|
|
|
require Apache; |
767
|
0
|
|
|
|
|
|
require Apache::Constants; |
768
|
0
|
|
|
|
|
|
Apache::Constants->import('OK'); |
769
|
0
|
|
|
|
|
|
Apache::Constants->import('HTTP_BAD_REQUEST'); |
770
|
0
|
|
|
|
|
|
$self->{'MOD_PERL_VERSION'} = 1; |
771
|
0
|
|
|
|
|
|
$self->{OK} = &Apache::Constants::OK; |
772
|
|
|
|
|
|
|
} |
773
|
|
|
|
|
|
|
else { |
774
|
0
|
|
|
|
|
|
require Apache::RequestRec; |
775
|
0
|
|
|
|
|
|
require Apache::RequestIO; |
776
|
0
|
|
|
|
|
|
require Apache::Const; |
777
|
0
|
|
|
|
|
|
Apache::Const->import( -compile => 'OK' ); |
778
|
0
|
|
|
|
|
|
Apache::Const->import( -compile => 'HTTP_BAD_REQUEST' ); |
779
|
0
|
|
|
|
|
|
$self->{'MOD_PERL_VERSION'} = 1.99; |
780
|
0
|
|
|
|
|
|
$self->{OK} = &Apache::OK; |
781
|
|
|
|
|
|
|
} |
782
|
|
|
|
|
|
|
} |
783
|
|
|
|
|
|
|
|
784
|
0
|
|
|
|
|
|
return $self; |
785
|
|
|
|
|
|
|
} |
786
|
|
|
|
|
|
|
|
787
|
|
|
|
|
|
|
sub handler { |
788
|
0
|
|
|
0
|
|
|
my $self = shift->new; |
789
|
0
|
|
|
|
|
|
my $r = shift; |
790
|
|
|
|
|
|
|
|
791
|
|
|
|
|
|
|
# Begin patch from JT Justman |
792
|
0
|
0
|
|
|
|
|
if ( !$r ) { |
793
|
0
|
0
|
|
|
|
|
if ( $self->{'MOD_PERL_VERSION'} < 2 ) { |
794
|
0
|
|
|
|
|
|
$r = Apache->request(); |
795
|
|
|
|
|
|
|
} |
796
|
|
|
|
|
|
|
else { |
797
|
0
|
|
|
|
|
|
$r = Apache2::RequestUtil->request(); |
798
|
|
|
|
|
|
|
} |
799
|
|
|
|
|
|
|
} |
800
|
|
|
|
|
|
|
|
801
|
0
|
|
|
|
|
|
my $cont_len; |
802
|
0
|
0
|
|
|
|
|
if ( $self->{'MOD_PERL_VERSION'} < 2 ) { |
803
|
0
|
|
|
|
|
|
$cont_len = $r->header_in('Content-length'); |
804
|
|
|
|
|
|
|
} |
805
|
|
|
|
|
|
|
else { |
806
|
0
|
|
|
|
|
|
$cont_len = $r->headers_in->get('Content-length'); |
807
|
|
|
|
|
|
|
} |
808
|
|
|
|
|
|
|
|
809
|
|
|
|
|
|
|
# End patch from JT Justman |
810
|
|
|
|
|
|
|
|
811
|
0
|
|
|
|
|
|
my $content = ""; |
812
|
0
|
0
|
|
|
|
|
if ( $cont_len > 0 ) { |
813
|
0
|
|
|
|
|
|
my $buf; |
814
|
|
|
|
|
|
|
|
815
|
|
|
|
|
|
|
# attempt to slurp in the content at once... |
816
|
0
|
|
|
|
|
|
$content .= $buf while ( $r->read( $buf, $cont_len ) > 0 ); |
817
|
|
|
|
|
|
|
} |
818
|
|
|
|
|
|
|
else { |
819
|
|
|
|
|
|
|
|
820
|
|
|
|
|
|
|
# throw appropriate error for mod_perl 2 |
821
|
0
|
0
|
|
|
|
|
return Apache2::Const::HTTP_BAD_REQUEST() |
822
|
|
|
|
|
|
|
if ( $self->{'MOD_PERL_VERSION'} >= 2 ); |
823
|
0
|
|
|
|
|
|
return Apache::Constants::BAD_REQUEST(); |
824
|
|
|
|
|
|
|
} |
825
|
|
|
|
|
|
|
|
826
|
0
|
|
|
|
|
|
my %headers; |
827
|
0
|
0
|
|
|
|
|
if ( $self->{'MOD_PERL_VERSION'} < 2 ) { |
828
|
0
|
|
|
|
|
|
%headers = $r->headers_in; # Apache::Table structure |
829
|
|
|
|
|
|
|
} else { |
830
|
0
|
|
|
|
|
|
%headers = %{ $r->headers_in }; # Apache2::RequestRec structure |
|
0
|
|
|
|
|
|
|
831
|
|
|
|
|
|
|
} |
832
|
|
|
|
|
|
|
|
833
|
0
|
|
|
|
|
|
$self->request( |
834
|
|
|
|
|
|
|
HTTP::Request->new( |
835
|
|
|
|
|
|
|
$r->method() => $r->uri, |
836
|
|
|
|
|
|
|
HTTP::Headers->new( %headers ), |
837
|
|
|
|
|
|
|
$content |
838
|
|
|
|
|
|
|
) ); |
839
|
0
|
|
|
|
|
|
$self->SUPER::handle; |
840
|
|
|
|
|
|
|
|
841
|
|
|
|
|
|
|
# we will specify status manually for Apache, because |
842
|
|
|
|
|
|
|
# if we do it as it has to be done, returning SERVER_ERROR, |
843
|
|
|
|
|
|
|
# Apache will modify our content_type to 'text/html; ....' |
844
|
|
|
|
|
|
|
# which is not what we want. |
845
|
|
|
|
|
|
|
# will emulate normal response, but with custom status code |
846
|
|
|
|
|
|
|
# which could also be 500. |
847
|
0
|
0
|
|
|
|
|
if ($self->{'MOD_PERL_VERSION'} < 2 ) { |
848
|
0
|
|
|
|
|
|
$r->status( $self->response->code ); |
849
|
|
|
|
|
|
|
} |
850
|
|
|
|
|
|
|
else { |
851
|
0
|
|
|
|
|
|
$r->status_line($self->response->code); |
852
|
|
|
|
|
|
|
} |
853
|
|
|
|
|
|
|
|
854
|
|
|
|
|
|
|
# Begin JT Justman patch |
855
|
0
|
0
|
|
|
|
|
if ( $self->{'MOD_PERL_VERSION'} > 1 ) { |
856
|
0
|
|
|
0
|
|
|
$self->response->headers->scan(sub { $r->headers_out->add(@_) }); |
|
0
|
|
|
|
|
|
|
857
|
0
|
|
|
|
|
|
$r->content_type( join '; ', $self->response->content_type ); |
858
|
|
|
|
|
|
|
} |
859
|
|
|
|
|
|
|
else { |
860
|
0
|
|
|
0
|
|
|
$self->response->headers->scan( sub { $r->header_out(@_) } ); |
|
0
|
|
|
|
|
|
|
861
|
0
|
|
|
|
|
|
$r->send_http_header( join '; ', $self->response->content_type ); |
862
|
|
|
|
|
|
|
} |
863
|
|
|
|
|
|
|
|
864
|
0
|
|
|
|
|
|
$r->print( $self->response->content ); |
865
|
0
|
|
|
|
|
|
return $self->{OK}; |
866
|
|
|
|
|
|
|
|
867
|
|
|
|
|
|
|
# End JT Justman patch |
868
|
|
|
|
|
|
|
} |
869
|
|
|
|
|
|
|
|
870
|
|
|
|
|
|
|
sub configure { |
871
|
0
|
|
|
0
|
|
|
my $self = shift->new; |
872
|
0
|
|
|
|
|
|
my $config = shift->dir_config; |
873
|
0
|
|
|
|
|
|
for (%$config) { |
874
|
0
|
0
|
|
|
|
|
$config->{$_} =~ /=>/ |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
875
|
|
|
|
|
|
|
? $self->$_( {split /\s*(?:=>|,)\s*/, $config->{$_}} ) |
876
|
|
|
|
|
|
|
: ref $self->$_() ? () # hm, nothing can be done here |
877
|
|
|
|
|
|
|
: $self->$_( split /\s+|\s*,\s*/, $config->{$_} ) |
878
|
|
|
|
|
|
|
if $self->can($_); |
879
|
|
|
|
|
|
|
} |
880
|
0
|
|
|
|
|
|
return $self; |
881
|
|
|
|
|
|
|
} |
882
|
|
|
|
|
|
|
|
883
|
|
|
|
|
|
|
{ |
884
|
|
|
|
|
|
|
|
885
|
|
|
|
|
|
|
# just create alias |
886
|
|
|
|
|
|
|
sub handle; |
887
|
|
|
|
|
|
|
*handle = \&handler |
888
|
|
|
|
|
|
|
} |
889
|
|
|
|
|
|
|
|
890
|
|
|
|
|
|
|
# ====================================================================== |
891
|
|
|
|
|
|
|
# |
892
|
|
|
|
|
|
|
# Copyright (C) 2001 Single Source oy (marko.asplund@kronodoc.fi) |
893
|
|
|
|
|
|
|
# a FastCGI transport class for SOAP::Lite. |
894
|
|
|
|
|
|
|
# Updated formatting and removed dead code in new() in 2008 |
895
|
|
|
|
|
|
|
# by Martin Kutter |
896
|
|
|
|
|
|
|
# |
897
|
|
|
|
|
|
|
# ====================================================================== |
898
|
|
|
|
|
|
|
|
899
|
|
|
|
|
|
|
package SOAP::Transport::HTTP::FCGI; |
900
|
|
|
|
|
|
|
|
901
|
13
|
|
|
13
|
|
141
|
use vars qw(@ISA); |
|
13
|
|
|
|
|
22
|
|
|
13
|
|
|
|
|
3721
|
|
902
|
|
|
|
|
|
|
@ISA = qw(SOAP::Transport::HTTP::CGI); |
903
|
|
|
|
|
|
|
|
904
|
0
|
|
|
0
|
|
|
sub DESTROY { SOAP::Trace::objects('()') } |
905
|
|
|
|
|
|
|
|
906
|
|
|
|
|
|
|
sub new { |
907
|
|
|
|
|
|
|
|
908
|
0
|
|
|
0
|
|
|
require FCGI; |
909
|
0
|
|
|
|
|
|
Exporter::require_version( 'FCGI' => 0.47 ) |
910
|
|
|
|
|
|
|
; # requires thread-safe interface |
911
|
|
|
|
|
|
|
|
912
|
0
|
|
|
|
|
|
my $class = shift; |
913
|
0
|
0
|
|
|
|
|
return $class if ref $class; |
914
|
|
|
|
|
|
|
|
915
|
0
|
|
|
|
|
|
my $self = $class->SUPER::new(@_); |
916
|
0
|
|
|
|
|
|
$self->{_fcgirq} = FCGI::Request( \*STDIN, \*STDOUT, \*STDERR ); |
917
|
0
|
|
|
|
|
|
SOAP::Trace::objects('()'); |
918
|
|
|
|
|
|
|
|
919
|
0
|
|
|
|
|
|
return $self; |
920
|
|
|
|
|
|
|
} |
921
|
|
|
|
|
|
|
|
922
|
|
|
|
|
|
|
sub handle { |
923
|
0
|
|
|
0
|
|
|
my $self = shift->new; |
924
|
|
|
|
|
|
|
|
925
|
0
|
|
|
|
|
|
my ( $r1, $r2 ); |
926
|
0
|
|
|
|
|
|
my $fcgirq = $self->{_fcgirq}; |
927
|
|
|
|
|
|
|
|
928
|
0
|
|
|
|
|
|
while ( ( $r1 = $fcgirq->Accept() ) >= 0 ) { |
929
|
0
|
|
|
|
|
|
$r2 = $self->SUPER::handle; |
930
|
|
|
|
|
|
|
} |
931
|
|
|
|
|
|
|
|
932
|
0
|
|
|
|
|
|
return undef; |
933
|
|
|
|
|
|
|
} |
934
|
|
|
|
|
|
|
|
935
|
|
|
|
|
|
|
# ====================================================================== |
936
|
|
|
|
|
|
|
|
937
|
|
|
|
|
|
|
1; |