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