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