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