view release on metacpan or  search on metacpan

lib/SOAP/Transport/HTTP.pm  view on Meta::CPAN

    # TODO - Handle the Expect: 100-Continue HTTP/1.1 Header
    if ( defined( $self->request->header("Expect") )
        && ( $self->request->header("Expect") eq "100-Continue" ) ) {

    }

    # TODO - this should query SOAP::Packager to see what types it supports,
    #      I don't like how this is hardcoded here.
    my $content =
      $compressed
      ? Compress::Zlib::uncompress( $self->request->content )
      : $self->request->content;

    my $response = $self->SUPER::handle(
        $self->request->content_type =~ m!^multipart/!
        ? join( "\n", $self->request->headers_as_string, $content )
        : $content
    ) or return;

    &{$self->{debug_logger}}($response);

    $self->make_response( $SOAP::Constants::HTTP_ON_SUCCESS_CODE, $response );
}

sub make_fault {
    my $self = shift;
    $self->make_response(
        $SOAP::Constants::HTTP_ON_FAULT_CODE => $self->SUPER::make_fault(@_)
    );
    return;
}

sub make_response {
    my ( $self, $code, $response ) = @_;

    my $encoding = $1
      if $response =~ /^<\?xml(?: version="1.0"| encoding="([^\"]+)")+\?>/;

    $response =~ s!(\?>)!$1<?xml-stylesheet type="text/css"?>!
      if $self->request->content_type eq 'multipart/form-data';

    $self->options->{is_compress} ||=
      exists $self->options->{compress_threshold}
      && eval { require Compress::Zlib };

    my $compressed = $self->options->{is_compress}
      && grep( /\b($COMPRESS|\*)\b/,
        $self->request->header('Accept-Encoding') )
      && ( $self->options->{compress_threshold} || 0 ) <
      SOAP::Utils::bytelength $response;

    if ($] > 5.007 && $encoding) {
        require Encode;
        $response = Encode::encode( $encoding, $response );
    }

    $response = Compress::Zlib::compress($response) if $compressed;

# this next line does not look like a good test to see if something is multipart
# perhaps a /content-type:.*multipart\//gi is a better regex?
    my ($is_multipart) =
      ( $response =~ /^content-type:.* boundary="([^\"]*)"/im );

    $self->response(
        HTTP::Response->new(
            $code => undef,
            HTTP::Headers->new(
                'SOAPServer' => $self->product_tokens,
                $compressed ? ( 'Content-Encoding' => $COMPRESS ) : (),
                'Content-Type' => join( '; ',
                    'text/xml',
                    !$SOAP::Constants::DO_NOT_USE_CHARSET
                      && $encoding ? 'charset=' . lc($encoding) : () ),
                'Content-Length' => SOAP::Utils::bytelength $response
            ),
            $response,
        ) );

    $self->response->headers->header( 'Content-Type' =>
'Multipart/Related; type="text/xml"; start="<main_envelope>"; boundary="'
          . $is_multipart
          . '"' )
      if $is_multipart;
}

# ->VERSION leaks a scalar every call - no idea why.
sub product_tokens {
    join '/', 'SOAP::Lite', 'Perl', $SOAP::Transport::HTTP::VERSION;
}

# ======================================================================

package SOAP::Transport::HTTP::CGI;

use vars qw(@ISA);
@ISA = qw(SOAP::Transport::HTTP::Server);

sub DESTROY { SOAP::Trace::objects('()') }

sub new {
    my $self = shift;
    return $self if ref $self;

    my $class = ref($self) || $self;
    $self = $class->SUPER::new(@_);
    SOAP::Trace::objects('()');

    return $self;
}

sub make_response {
    my $self = shift;
    $self->SUPER::make_response(@_);
}

sub handle {
    my $self = shift->new;

    my $length = $ENV{'CONTENT_LENGTH'} || 0;

    # if the HTTP_TRANSFER_ENCODING env is defined, set $chunked if it's chunked*
    # else to false