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 |
# $Id: HTTP.pm,v 1.19 2006/06/15 18:23:28 byrnereese Exp $ |
8 |
# |
9 |
# ====================================================================== |
10 |
|
11 |
package SOAP::Transport::HTTP; |
12 |
|
13 |
use strict; |
14 |
use vars qw($VERSION); |
15 |
#$VERSION = sprintf("%d.%s", map {s/_//g; $_} q$Name: $ =~ /-(\d+)_([\d_]+)/); |
16 |
$VERSION = $SOAP::Lite::VERSION; |
17 |
|
18 |
use SOAP::Lite; |
19 |
use SOAP::Packager; |
20 |
|
21 |
# ====================================================================== |
22 |
|
23 |
package SOAP::Transport::HTTP::Client; |
24 |
|
25 |
use vars qw(@ISA $COMPRESS $USERAGENT_CLASS); |
26 |
$USERAGENT_CLASS = 'LWP::UserAgent'; |
27 |
@ISA = qw(SOAP::Client); |
28 |
#@ISA = ("SOAP::Client",$USERAGENT_CLASS); |
29 |
|
30 |
$COMPRESS = 'deflate'; |
31 |
|
32 |
my(%redirect, %mpost, %nocompress); |
33 |
|
34 |
# hack for HTTP connection that returns Keep-Alive |
35 |
# miscommunication (?) between LWP::Protocol and LWP::Protocol::http |
36 |
# dies after timeout, but seems like we could make it work |
37 |
sub patch { |
38 |
BEGIN { local ($^W) = 0; } |
39 |
no warnings "redefine"; |
40 |
{ sub LWP::UserAgent::redirect_ok; *LWP::UserAgent::redirect_ok = sub {1} } |
41 |
{ package LWP::Protocol; |
42 |
my $collect = \&collect; # store original |
43 |
*collect = sub { |
44 |
if (defined $_[2]->header('Connection') && $_[2]->header('Connection') eq 'Keep-Alive') { |
45 |
my $data = $_[3]->(); |
46 |
my $next = SOAP::Utils::bytelength($$data) == $_[2]->header('Content-Length') ? sub { my $str = ''; \$str; } : $_[3]; |
47 |
my $done = 0; $_[3] = sub { $done++ ? &$next : $data }; |
48 |
} |
49 |
goto &$collect; |
50 |
}; |
51 |
} |
52 |
*patch = sub {}; |
53 |
}; |
54 |
|
55 |
sub DESTROY { SOAP::Trace::objects('()') } |
56 |
|
57 |
sub http_request { |
58 |
my $self = shift; |
59 |
if (@_) { $self->{'_http_request'} = shift; return $self } |
60 |
return $self->{'_http_request'}; |
61 |
} |
62 |
|
63 |
sub http_response { |
64 |
my $self = shift; |
65 |
if (@_) { $self->{'_http_response'} = shift; return $self } |
66 |
return $self->{'_http_response'}; |
67 |
} |
68 |
|
69 |
sub simple_cookie { |
70 |
my $self = shift; |
71 |
if (@_) { $self->{'_simple_cookie'} = shift; return $self } |
72 |
return $self->{'_simple_cookie'}; |
73 |
} |
74 |
|
75 |
sub new { |
76 |
my $self = shift; |
77 |
return $self if ref $self; |
78 |
push @ISA,$USERAGENT_CLASS; |
79 |
eval("require $USERAGENT_CLASS") or die "Could not load UserAgent class $USERAGENT_CLASS: $@"; |
80 |
require HTTP::Request; |
81 |
require HTTP::Headers; |
82 |
patch() if $SOAP::Constants::PATCH_HTTP_KEEPALIVE; |
83 |
unless (ref $self) { |
84 |
my $class = ref($self) || $self; |
85 |
my(@params, @methods); |
86 |
while (@_) { $class->can($_[0]) ? push(@methods, shift() => shift) : push(@params, shift) } |
87 |
$self = $class->SUPER::new(@params); |
88 |
die "SOAP::Transport::HTTP::Client must inherit from LWP::UserAgent, or one of its subclasses" |
89 |
if !$self->isa("LWP::UserAgent"); |
90 |
$self->agent(join '/', 'SOAP::Lite', 'Perl', SOAP::Transport::HTTP->VERSION); |
91 |
$self->options({}); |
92 |
$self->http_request(HTTP::Request->new); |
93 |
$self->http_request->headers(HTTP::Headers->new); |
94 |
# TODO - add application/dime |
95 |
$self->http_request->header(Accept => ['text/xml', 'multipart/*', 'application/soap']); |
96 |
while (@methods) { my($method, $params) = splice(@methods,0,2); |
97 |
$self->$method(ref $params eq 'ARRAY' ? @$params : $params) |
98 |
} |
99 |
SOAP::Trace::objects('()'); |
100 |
} |
101 |
return $self; |
102 |
} |
103 |
|
104 |
sub send_receive { |
105 |
my ($self, %parameters) = @_; |
106 |
my ($context, $envelope, $endpoint, $action, $encoding, $parts) = |
107 |
@parameters{qw(context envelope endpoint action encoding parts)}; |
108 |
$endpoint ||= $self->endpoint; |
109 |
|
110 |
my $method = 'POST'; |
111 |
$COMPRESS = 'gzip'; |
112 |
|
113 |
$self->options->{is_compress} |
114 |
||= exists $self->options->{compress_threshold} |
115 |
&& eval { require Compress::Zlib }; |
116 |
|
117 |
# Initialize the basic about the HTTP Request object |
118 |
$self->http_request->method($method); |
119 |
$self->http_request->url($endpoint); |
120 |
|
121 |
no strict 'refs'; |
122 |
if ($parts) { |
123 |
my $packager = $context->packager; |
124 |
$envelope = $packager->package($envelope,$context); |
125 |
foreach my $hname (keys %{$packager->headers_http}) { |
126 |
$self->http_request->headers->header($hname => $packager->headers_http->{$hname}); |
127 |
} |
128 |
# TODO - DIME support |
129 |
} |
130 |
|
131 |
COMPRESS: { |
132 |
my $compressed |
133 |
= !exists $nocompress{$endpoint} && |
134 |
$self->options->{is_compress} && |
135 |
($self->options->{compress_threshold} || 0) < length $envelope; |
136 |
$envelope = Compress::Zlib::memGzip($envelope) if $compressed; |
137 |
my $original_encoding = $self->http_request->content_encoding; |
138 |
|
139 |
while (1) { |
140 |
# check cache for redirect |
141 |
$endpoint = $redirect{$endpoint} if exists $redirect{$endpoint}; |
142 |
# check cache for M-POST |
143 |
$method = 'M-POST' if exists $mpost{$endpoint}; |
144 |
|
145 |
# what's this all about? |
146 |
# unfortunately combination of LWP and Perl 5.6.1 and later has bug |
147 |
# in sending multibyte characters. LWP uses length() to calculate |
148 |
# content-length header and starting 5.6.1 length() calculates chars |
149 |
# instead of bytes. 'use bytes' in THIS file doesn't work, because |
150 |
# it's lexically scoped. Unfortunately, content-length we calculate |
151 |
# here doesn't work either, because LWP overwrites it with |
152 |
# content-length it calculates (which is wrong) AND uses length() |
153 |
# during syswrite/sysread, so we are in a bad shape anyway. |
154 |
|
155 |
# what to do? we calculate proper content-length (using |
156 |
# bytelength() function from SOAP::Utils) and then drop utf8 mark |
157 |
# from string (doing pack with 'C0A*' modifier) if length and |
158 |
# bytelength are not the same |
159 |
my $bytelength = SOAP::Utils::bytelength($envelope); |
160 |
$envelope = pack('C0A*', $envelope) |
161 |
if !$SOAP::Constants::DO_NOT_USE_LWP_LENGTH_HACK && length($envelope) != $bytelength; |
162 |
|
163 |
$self->http_request->content($envelope); |
164 |
$self->http_request->protocol('HTTP/1.1'); |
165 |
|
166 |
$self->http_request->proxy_authorization_basic($ENV{'HTTP_proxy_user'}, |
167 |
$ENV{'HTTP_proxy_pass'}) |
168 |
if ($ENV{'HTTP_proxy_user'} && $ENV{'HTTP_proxy_pass'}); |
169 |
# by Murray Nesbitt |
170 |
|
171 |
if ($method eq 'M-POST') { |
172 |
my $prefix = sprintf '%04d', int(rand(1000)); |
173 |
$self->http_request->header(Man => qq!"$SOAP::Constants::NS_ENV"; ns=$prefix!); |
174 |
$self->http_request->header("$prefix-SOAPAction" => $action) if defined $action; |
175 |
} else { |
176 |
$self->http_request->header(SOAPAction => $action) if defined $action; |
177 |
} |
178 |
|
179 |
|
180 |
# allow compress if present and let server know we could handle it |
181 |
$self->http_request->header('Accept-Encoding' => |
182 |
[$SOAP::Transport::HTTP::Client::COMPRESS]) |
183 |
if $self->options->{is_compress}; |
184 |
$self->http_request->content_encoding($SOAP::Transport::HTTP::Client::COMPRESS) |
185 |
if $compressed; |
186 |
|
187 |
if(!$self->http_request->content_type){ |
188 |
$self->http_request->content_type(join '; ', |
189 |
$SOAP::Constants::DEFAULT_HTTP_CONTENT_TYPE, |
190 |
!$SOAP::Constants::DO_NOT_USE_CHARSET && $encoding ? |
191 |
'charset=' . lc($encoding) : ()); |
192 |
} elsif (!$SOAP::Constants::DO_NOT_USE_CHARSET && $encoding ){ |
193 |
my $tmpType = $self->http_request->headers->header('Content-type'); |
194 |
# $self->http_request->content_type($tmpType.'; charset=' . lc($encoding)); |
195 |
my $addition = '; charset=' . lc($encoding); |
196 |
$self->http_request->content_type($tmpType.$addition) if ($tmpType !~ /$addition/); |
197 |
} |
198 |
|
199 |
$self->http_request->content_length($bytelength); |
200 |
SOAP::Trace::transport($self->http_request); |
201 |
SOAP::Trace::debug($self->http_request->as_string); |
202 |
|
203 |
$self->SUPER::env_proxy if $ENV{'HTTP_proxy'}; |
204 |
|
205 |
$self->http_response($self->SUPER::request($self->http_request)); |
206 |
SOAP::Trace::transport($self->http_response); |
207 |
SOAP::Trace::debug($self->http_response->as_string); |
208 |
|
209 |
# 100 OK, continue to read? |
210 |
if (($self->http_response->code == 510 || $self->http_response->code == 501) && $method ne 'M-POST') { |
211 |
$mpost{$endpoint} = 1; |
212 |
} elsif ($self->http_response->code == 415 && $compressed) { |
213 |
# 415 Unsupported Media Type |
214 |
$nocompress{$endpoint} = 1; |
215 |
$envelope = Compress::Zlib::memGunzip($envelope); |
216 |
# $self->http_request->content_encoding($original_encoding); |
217 |
$self->http_request->headers->remove_header('Content-Encoding'); |
218 |
redo COMPRESS; # try again without compression |
219 |
} else { |
220 |
last; |
221 |
} |
222 |
} |
223 |
} |
224 |
|
225 |
$redirect{$endpoint} = $self->http_response->request->url |
226 |
if $self->http_response->previous && $self->http_response->previous->is_redirect; |
227 |
|
228 |
$self->code($self->http_response->code); |
229 |
$self->message($self->http_response->message); |
230 |
$self->is_success($self->http_response->is_success); |
231 |
$self->status($self->http_response->status_line); |
232 |
|
233 |
my $content = |
234 |
($self->http_response->content_encoding || '') |
235 |
=~ /\b$SOAP::Transport::HTTP::Client::COMPRESS\b/o && |
236 |
$self->options->{is_compress} ? |
237 |
Compress::Zlib::memGunzip($self->http_response->content) |
238 |
: ($self->http_response->content_encoding || '') =~ /\S/ |
239 |
? die "Can't understand returned Content-Encoding (@{[$self->http_response->content_encoding]})\n" |
240 |
: $self->http_response->content; |
241 |
$self->http_response->content_type =~ m!^multipart/!i ? |
242 |
join("\n", $self->http_response->headers_as_string, $content) |
243 |
: $content; |
244 |
} |
245 |
|
246 |
# ====================================================================== |
247 |
|
248 |
package SOAP::Transport::HTTP::Server; |
249 |
|
250 |
use vars qw(@ISA $COMPRESS); |
251 |
@ISA = qw(SOAP::Server); |
252 |
|
253 |
use URI; |
254 |
|
255 |
$COMPRESS = 'deflate'; |
256 |
|
257 |
sub DESTROY { SOAP::Trace::objects('()') } |
258 |
|
259 |
sub new { require LWP::UserAgent; |
260 |
my $self = shift; |
261 |
|
262 |
unless (ref $self) { |
263 |
my $class = ref($self) || $self; |
264 |
$self = $class->SUPER::new(@_); |
265 |
$self->{'_on_action'} = sub { |
266 |
(my $action = shift || '') =~ s/^(\"?)(.*)\1$/$2/; |
267 |
die "SOAPAction shall match 'uri#method' if present (got '$action', expected '@{[join('#', @_)]}'\n" |
268 |
if $action && $action ne join('#', @_) |
269 |
&& $action ne join('/', @_) |
270 |
&& (substr($_[0], -1, 1) ne '/' || $action ne join('', @_)); |
271 |
}; |
272 |
SOAP::Trace::objects('()'); |
273 |
} |
274 |
return $self; |
275 |
} |
276 |
|
277 |
sub BEGIN { |
278 |
no strict 'refs'; |
279 |
for my $method (qw(request response)) { |
280 |
my $field = '_' . $method; |
281 |
*$method = sub { |
282 |
my $self = shift->new; |
283 |
@_ ? ($self->{$field} = shift, return $self) : return $self->{$field}; |
284 |
} |
285 |
} |
286 |
} |
287 |
|
288 |
sub handle { |
289 |
my $self = shift->new; |
290 |
|
291 |
# XXX DbP -- process cookies from request |
292 |
use Data::Dump qw/dump/; |
293 |
warn "options = ",dump( $self->options, $self->request ); |
294 |
if ( my $simple_cookie = $self->options->{simple_cookie} ) { |
295 |
die 'simple_cookie is not CGI::Simple::Cookie but ', ref($simple_cookie) unless (ref($simple_cookie) eq 'CGI::Simple::Cookie'); |
296 |
$simple_cookie->parse( $self->request->header('Cookie') ); |
297 |
print "current simple_cookie ", dump( $simple_cookie->as_string ); |
298 |
} |
299 |
|
300 |
if ($self->request->method eq 'POST') { |
301 |
$self->action($self->request->header('SOAPAction') || undef); |
302 |
} elsif ($self->request->method eq 'M-POST') { |
303 |
return $self->response(HTTP::Response->new(510, # NOT EXTENDED |
304 |
"Expected Mandatory header with $SOAP::Constants::NS_ENV as unique URI")) |
305 |
if $self->request->header('Man') !~ /^"$SOAP::Constants::NS_ENV";\s*ns\s*=\s*(\d+)/; |
306 |
$self->action($self->request->header("$1-SOAPAction") || undef); |
307 |
} else { |
308 |
return $self->response(HTTP::Response->new(405)) # METHOD NOT ALLOWED |
309 |
} |
310 |
|
311 |
my $compressed = ($self->request->content_encoding || '') =~ /\b$COMPRESS\b/; |
312 |
$self->options->{is_compress} ||= $compressed && eval { require Compress::Zlib }; |
313 |
|
314 |
# signal error if content-encoding is 'deflate', but we don't want it OR |
315 |
# something else, so we don't understand it |
316 |
return $self->response(HTTP::Response->new(415)) # UNSUPPORTED MEDIA TYPE |
317 |
if $compressed && !$self->options->{is_compress} || |
318 |
!$compressed && ($self->request->content_encoding || '') =~ /\S/; |
319 |
|
320 |
my $content_type = $self->request->content_type || ''; |
321 |
# in some environments (PerlEx?) content_type could be empty, so allow it also |
322 |
# anyway it'll blow up inside ::Server::handle if something wrong with message |
323 |
# TBD: but what to do with MIME encoded messages in THOSE environments? |
324 |
return $self->make_fault($SOAP::Constants::FAULT_CLIENT, "Content-Type must be 'text/xml,' 'multipart/*,' or 'application/dime' instead of '$content_type'") |
325 |
if $content_type && |
326 |
$content_type ne 'text/xml' && |
327 |
$content_type ne 'application/dime' && |
328 |
$content_type !~ m!^multipart/!; |
329 |
|
330 |
# TODO - Handle the Expect: 100-Continue HTTP/1.1 Header |
331 |
if (defined($self->request->header("Expect")) && |
332 |
($self->request->header("Expect") eq "100-Continue")) { |
333 |
|
334 |
} |
335 |
|
336 |
|
337 |
# TODO - this should query SOAP::Packager to see what types it supports, |
338 |
# I don't like how this is hardcoded here. |
339 |
my $content = $compressed ? |
340 |
Compress::Zlib::uncompress($self->request->content) |
341 |
: $self->request->content; |
342 |
my $response = $self->SUPER::handle( |
343 |
$self->request->content_type =~ m!^multipart/! ? |
344 |
join("\n", $self->request->headers_as_string, $content) |
345 |
: $content |
346 |
) or return; |
347 |
|
348 |
$self->make_response($SOAP::Constants::HTTP_ON_SUCCESS_CODE, $response); |
349 |
} |
350 |
|
351 |
sub make_fault { |
352 |
my $self = shift; |
353 |
$self->make_response($SOAP::Constants::HTTP_ON_FAULT_CODE => $self->SUPER::make_fault(@_)); |
354 |
return; |
355 |
} |
356 |
|
357 |
sub make_response { |
358 |
my $self = shift; |
359 |
my($code, $response) = @_; |
360 |
|
361 |
my $encoding = $1 |
362 |
if $response =~ /^<\?xml(?: version="1.0"| encoding="([^\"]+)")+\?>/; |
363 |
$response =~ s!(\?>)!$1<?xml-stylesheet type="text/css"?>! |
364 |
if $self->request->content_type eq 'multipart/form-data'; |
365 |
|
366 |
$self->options->{is_compress} ||= |
367 |
exists $self->options->{compress_threshold} && eval { require Compress::Zlib }; |
368 |
|
369 |
my $compressed = $self->options->{is_compress} && |
370 |
grep(/\b($COMPRESS|\*)\b/, $self->request->header('Accept-Encoding')) && |
371 |
($self->options->{compress_threshold} || 0) < SOAP::Utils::bytelength $response; |
372 |
$response = Compress::Zlib::compress($response) if $compressed; |
373 |
# this next line does not look like a good test to see if something is multipart |
374 |
# perhaps a /content-type:.*multipart\//gi is a better regex? |
375 |
my ($is_multipart) = ($response =~ /content-type:.* boundary="([^\"]*)"/im); |
376 |
$self->response(HTTP::Response->new( |
377 |
$code => undef, |
378 |
HTTP::Headers->new( |
379 |
'SOAPServer' => $self->product_tokens, |
380 |
$compressed ? ('Content-Encoding' => $COMPRESS) : (), |
381 |
'Content-Type' => join('; ', 'text/xml', |
382 |
!$SOAP::Constants::DO_NOT_USE_CHARSET && |
383 |
$encoding ? 'charset=' . lc($encoding) : ()), |
384 |
'Content-Length' => SOAP::Utils::bytelength $response), |
385 |
$response, |
386 |
)); |
387 |
$self->response->headers->header('Content-Type' => 'Multipart/Related; type="text/xml"; start="<main_envelope>"; boundary="'.$is_multipart.'"') if $is_multipart; |
388 |
|
389 |
# XXX DbP - insert cookie headers |
390 |
if ( my $simple_cookie = $self->options->{simple_cookie} ) { |
391 |
die 'simple_cookie is not CGI::Simple::Cookie but ', ref($simple_cookie) unless (ref($simple_cookie) eq 'CGI::Simple::Cookie'); |
392 |
$self->response->headers->header('Set-Cookie' => $simple_cookie->as_string ); |
393 |
print "new response = ", dump( $self->response ); |
394 |
} |
395 |
|
396 |
$self->response; |
397 |
} |
398 |
|
399 |
sub product_tokens { join '/', 'SOAP::Lite', 'Perl', SOAP::Transport::HTTP->VERSION } |
400 |
|
401 |
# ====================================================================== |
402 |
|
403 |
package SOAP::Transport::HTTP::CGI; |
404 |
|
405 |
use vars qw(@ISA); |
406 |
@ISA = qw(SOAP::Transport::HTTP::Server); |
407 |
|
408 |
sub DESTROY { SOAP::Trace::objects('()') } |
409 |
|
410 |
sub new { |
411 |
my $self = shift; |
412 |
unless (ref $self) { |
413 |
my $class = ref($self) || $self; |
414 |
$self = $class->SUPER::new(@_); |
415 |
SOAP::Trace::objects('()'); |
416 |
} |
417 |
return $self; |
418 |
} |
419 |
|
420 |
sub make_response { |
421 |
my $self = shift; |
422 |
$self->SUPER::make_response(@_); |
423 |
} |
424 |
|
425 |
sub handle { |
426 |
my $self = shift->new; |
427 |
|
428 |
my $length = $ENV{'CONTENT_LENGTH'} || 0; |
429 |
|
430 |
if (!$length) { |
431 |
$self->response(HTTP::Response->new(411)) # LENGTH REQUIRED |
432 |
} elsif (defined $SOAP::Constants::MAX_CONTENT_SIZE && $length > $SOAP::Constants::MAX_CONTENT_SIZE) { |
433 |
$self->response(HTTP::Response->new(413)) # REQUEST ENTITY TOO LARGE |
434 |
} else { |
435 |
if ($ENV{EXPECT} =~ /\b100-Continue\b/i) { |
436 |
print "HTTP/1.1 100 Continue\r\n\r\n"; |
437 |
} |
438 |
my $content; |
439 |
binmode(STDIN); |
440 |
read(STDIN,$content,$length); |
441 |
$self->request(HTTP::Request->new( |
442 |
$ENV{'REQUEST_METHOD'} || '' => $ENV{'SCRIPT_NAME'}, |
443 |
# HTTP::Headers->new(map {(/^HTTP_(.+)/i ? $1 : $_) => $ENV{$_}} keys %ENV), |
444 |
HTTP::Headers->new(map {(/^HTTP_(.+)/i ? ($1=~m/SOAPACTION/) ?('SOAPAction'):($1) : $_) => $ENV{$_}} keys %ENV), |
445 |
$content, |
446 |
)); |
447 |
$self->SUPER::handle; |
448 |
} |
449 |
|
450 |
# imitate nph- cgi for IIS (pointed by Murray Nesbitt) |
451 |
my $status = defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/ |
452 |
? $ENV{SERVER_PROTOCOL} || 'HTTP/1.0' : 'Status:'; |
453 |
my $code = $self->response->code; |
454 |
binmode(STDOUT); print STDOUT |
455 |
"$status $code ", HTTP::Status::status_message($code), |
456 |
"\015\012", $self->response->headers_as_string("\015\012"), |
457 |
"\015\012", $self->response->content; |
458 |
} |
459 |
|
460 |
|
461 |
# ====================================================================== |
462 |
|
463 |
package SOAP::Transport::HTTP::Daemon; |
464 |
|
465 |
use Carp (); |
466 |
use vars qw($AUTOLOAD @ISA); |
467 |
@ISA = qw(SOAP::Transport::HTTP::Server); |
468 |
|
469 |
sub DESTROY { SOAP::Trace::objects('()') } |
470 |
|
471 |
#sub new { require HTTP::Daemon; |
472 |
sub new { |
473 |
my $self = shift; |
474 |
unless (ref $self) { |
475 |
my $class = ref($self) || $self; |
476 |
|
477 |
my(@params, @methods); |
478 |
while (@_) { $class->can($_[0]) ? push(@methods, shift() => shift) : push(@params, shift) } |
479 |
$self = $class->SUPER::new; |
480 |
|
481 |
# Added in 0.65 - Thanks to Nils Sowen |
482 |
# use SSL if there is any parameter with SSL_* in the name |
483 |
$self->SSL(1) if !$self->SSL && grep /^SSL_/, @params; |
484 |
my $http_daemon = $self->http_daemon_class; |
485 |
eval "require $http_daemon" or Carp::croak $@ unless |
486 |
UNIVERSAL::can($http_daemon => 'new'); |
487 |
$self->{_daemon} = $http_daemon->new(@params) or Carp::croak "Can't create daemon: $!"; |
488 |
# End SSL patch |
489 |
# $self->{_daemon} = HTTP::Daemon->new(@params) or Carp::croak "Can't create daemon: $!"; |
490 |
$self->myuri(URI->new($self->url)->canonical->as_string); |
491 |
while (@methods) { my($method, $params) = splice(@methods,0,2); |
492 |
$self->$method(ref $params eq 'ARRAY' ? @$params : $params) |
493 |
} |
494 |
SOAP::Trace::objects('()'); |
495 |
} |
496 |
return $self; |
497 |
} |
498 |
|
499 |
sub SSL { |
500 |
my $self = shift->new; |
501 |
@_ ? ($self->{_SSL} = shift, return $self) : return |
502 |
$self->{_SSL}; |
503 |
} |
504 |
|
505 |
sub http_daemon_class { shift->SSL ? 'HTTP::Daemon::SSL' : 'HTTP::Daemon' } |
506 |
|
507 |
sub AUTOLOAD { |
508 |
my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2); |
509 |
return if $method eq 'DESTROY'; |
510 |
|
511 |
no strict 'refs'; |
512 |
*$AUTOLOAD = sub { shift->{_daemon}->$method(@_) }; |
513 |
goto &$AUTOLOAD; |
514 |
} |
515 |
|
516 |
sub handle { |
517 |
my $self = shift->new; |
518 |
while (my $c = $self->accept) { |
519 |
while (my $r = $c->get_request) { |
520 |
$self->request($r); |
521 |
$self->SUPER::handle; |
522 |
$c->send_response($self->response) |
523 |
} |
524 |
# replaced ->close, thanks to Sean Meisner <Sean.Meisner@VerizonWireless.com> |
525 |
# shutdown() doesn't work on AIX. close() is used in this case. Thanks to Jos Clijmans <jos.clijmans@recyfin.be> |
526 |
UNIVERSAL::isa($c, 'shutdown') ? $c->shutdown(2) : $c->close(); |
527 |
$c->close; |
528 |
} |
529 |
} |
530 |
|
531 |
# ====================================================================== |
532 |
|
533 |
package SOAP::Transport::HTTP::Apache; |
534 |
|
535 |
use vars qw(@ISA); |
536 |
@ISA = qw(SOAP::Transport::HTTP::Server); |
537 |
|
538 |
sub DESTROY { SOAP::Trace::objects('()') } |
539 |
|
540 |
sub new { |
541 |
my $self = shift; |
542 |
unless (ref $self) { |
543 |
my $class = ref($self) || $self; |
544 |
$self = $class->SUPER::new(@_); |
545 |
SOAP::Trace::objects('()'); |
546 |
} |
547 |
|
548 |
# die "Could not find or load mod_perl" |
549 |
# unless (eval "require mod_perl"); |
550 |
# die "Could not detect your version of mod_perl" |
551 |
# if (!defined($mod_perl::VERSION)); |
552 |
# if ($mod_perl::VERSION < 1.99) { |
553 |
# require Apache; |
554 |
# require Apache::Constants; |
555 |
# Apache::Constants->import('OK'); |
556 |
# $self->{'MOD_PERL_VERSION'} = 1; |
557 |
# } elsif ($mod_perl::VERSION < 3) { |
558 |
# require Apache2::RequestRec; |
559 |
# require Apache2::RequestIO; |
560 |
# require Apache2::Const; |
561 |
# Apache2::Const->import(-compile => 'OK'); |
562 |
# $self->{'MOD_PERL_VERSION'} = 2; |
563 |
# } else { |
564 |
# die "Unsupported version of mod_perl"; |
565 |
# } |
566 |
|
567 |
# Added this code thanks to JT Justman |
568 |
# This code improves and provides more robust support for |
569 |
# multiple versions of Apache and mod_perl |
570 |
if( defined $ENV{MOD_PERL_API_VERSION} && |
571 |
$ENV{MOD_PERL_API_VERSION} >= 2) { # mod_perl 2.0 |
572 |
require Apache2::RequestRec; |
573 |
require Apache2::RequestIO; |
574 |
require Apache2::Const; |
575 |
require APR::Table; |
576 |
Apache2::Const->import(-compile => 'OK'); |
577 |
$self->{'MOD_PERL_VERSION'} = 2; |
578 |
$self->{OK} = &Apache2::Const::OK; |
579 |
} else { # mod_perl 1.xx |
580 |
die "Could not find or load mod_perl" |
581 |
unless (eval "require mod_perl"); |
582 |
die "Could not detect your version of mod_perl" |
583 |
if (!defined($mod_perl::VERSION)); |
584 |
if ($mod_perl::VERSION < 1.99) { |
585 |
require Apache; |
586 |
require Apache::Constants; |
587 |
Apache::Constants->import('OK'); |
588 |
$self->{'MOD_PERL_VERSION'} = 1; |
589 |
$self->{OK} = &Apache::Constants::OK; |
590 |
} else { |
591 |
require Apache::RequestRec; |
592 |
require Apache::RequestIO; |
593 |
require Apache::Const; |
594 |
Apache::Const->import(-compile => 'OK'); |
595 |
$self->{'MOD_PERL_VERSION'} = 1.99; |
596 |
$self->{OK} = &Apache::OK; |
597 |
} |
598 |
} |
599 |
|
600 |
|
601 |
return $self; |
602 |
} |
603 |
|
604 |
sub handler { |
605 |
my $self = shift->new; |
606 |
my $r = shift; |
607 |
|
608 |
# Pre 0.68 code |
609 |
# $r = Apache->request if (!$r && $self->{'MOD_PERL_VERSION'} == 1); |
610 |
# if ($r->header_in('Expect') =~ /\b100-Continue\b/i) { |
611 |
# $r->print("HTTP/1.1 100 Continue\r\n\r\n"); |
612 |
# } |
613 |
|
614 |
# Begin patch from JT Justman |
615 |
if (!$r) { |
616 |
if ( $self->{'MOD_PERL_VERSION'} < 2 ) { |
617 |
$r = Apache->request(); |
618 |
} else { |
619 |
$r = Apache2::RequestUtil->request(); |
620 |
} |
621 |
} |
622 |
|
623 |
my $cont_len; |
624 |
if ( $self->{'MOD_PERL_VERSION'} == 1 ) { |
625 |
$cont_len = $r->header_in ('Content-length'); |
626 |
} else { |
627 |
$cont_len = $r->headers_in->get('Content-length'); |
628 |
} |
629 |
if ($r->headers_in->{'Expect'} =~ /\b100-Continue\b/i) { |
630 |
$r->print("HTTP/1.1 100 Continue\r\n\r\n"); |
631 |
} |
632 |
# End patch from JT Justman |
633 |
|
634 |
$self->request(HTTP::Request->new( |
635 |
$r->method() => $r->uri, |
636 |
HTTP::Headers->new($r->headers_in), |
637 |
do { |
638 |
my ($c,$buf); |
639 |
while ($r->read($buf,$cont_len)) { |
640 |
$c.=$buf; |
641 |
} |
642 |
$c; |
643 |
} |
644 |
)); |
645 |
$self->SUPER::handle; |
646 |
|
647 |
# we will specify status manually for Apache, because |
648 |
# if we do it as it has to be done, returning SERVER_ERROR, |
649 |
# Apache will modify our content_type to 'text/html; ....' |
650 |
# which is not what we want. |
651 |
# will emulate normal response, but with custom status code |
652 |
# which could also be 500. |
653 |
$r->status($self->response->code); |
654 |
|
655 |
# pre 0.68 |
656 |
# $self->response->headers->scan(sub { $r->header_out(@_) }); |
657 |
# $r->send_http_header(join '; ', $self->response->content_type); |
658 |
# $r->print($self->response->content); |
659 |
# return $self->{'MOD_PERL_VERSION'} == 2 ? &Apache::OK : &Apache::Constants::OK; |
660 |
|
661 |
# Begin JT Justman patch |
662 |
if ( $self->{'MOD_PERL_VERSION'} > 1 ) { |
663 |
$self->response->headers->scan(sub { $r->headers_out->set(@_) }); |
664 |
$r->content_type(join '; ', $self->response->content_type); |
665 |
} else { |
666 |
$self->response->headers->scan(sub { $r->header_out(@_) }); |
667 |
$r->send_http_header(join '; ', $self->response->content_type); |
668 |
} |
669 |
$r->print($self->response->content); |
670 |
return $self->{OK}; |
671 |
# End JT Justman patch |
672 |
|
673 |
} |
674 |
|
675 |
sub configure { |
676 |
my $self = shift->new; |
677 |
my $config = shift->dir_config; |
678 |
foreach (%$config) { |
679 |
$config->{$_} =~ /=>/ |
680 |
? $self->$_({split /\s*(?:=>|,)\s*/, $config->{$_}}) |
681 |
: ref $self->$_() ? () # hm, nothing can be done here |
682 |
: $self->$_(split /\s+|\s*,\s*/, $config->{$_}) |
683 |
if $self->can($_); |
684 |
} |
685 |
$self; |
686 |
} |
687 |
|
688 |
{ sub handle; *handle = \&handler } # just create alias |
689 |
|
690 |
# ====================================================================== |
691 |
# |
692 |
# Copyright (C) 2001 Single Source oy (marko.asplund@kronodoc.fi) |
693 |
# a FastCGI transport class for SOAP::Lite. |
694 |
# |
695 |
# ====================================================================== |
696 |
|
697 |
package SOAP::Transport::HTTP::FCGI; |
698 |
|
699 |
use vars qw(@ISA); |
700 |
@ISA = qw(SOAP::Transport::HTTP::CGI); |
701 |
|
702 |
sub DESTROY { SOAP::Trace::objects('()') } |
703 |
|
704 |
sub new { require FCGI; Exporter::require_version('FCGI' => 0.47); # requires thread-safe interface |
705 |
my $self = shift; |
706 |
|
707 |
if (!ref($self)) { |
708 |
my $class = ref($self) || $self; |
709 |
$self = $class->SUPER::new(@_); |
710 |
$self->{_fcgirq} = FCGI::Request(\*STDIN, \*STDOUT, \*STDERR); |
711 |
SOAP::Trace::objects('()'); |
712 |
} |
713 |
return $self; |
714 |
} |
715 |
|
716 |
sub handle { |
717 |
my $self = shift->new; |
718 |
|
719 |
my ($r1, $r2); |
720 |
my $fcgirq = $self->{_fcgirq}; |
721 |
|
722 |
while (($r1 = $fcgirq->Accept()) >= 0) { |
723 |
$r2 = $self->SUPER::handle; |
724 |
} |
725 |
|
726 |
return undef; |
727 |
} |
728 |
|
729 |
# ====================================================================== |
730 |
|
731 |
1; |