view release on metacpan or  search on metacpan

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

}

sub new {
    my $class = shift;
    #print "HTTP.pm DEBUG: in sub new\n";

    return $class if ref $class;    # skip if we're already object...

    if ( !grep { $_ eq $USERAGENT_CLASS } @ISA ) {
        push @ISA, $USERAGENT_CLASS;
    }

    eval("require $USERAGENT_CLASS")
      or die "Could not load UserAgent class $USERAGENT_CLASS: $@";

    require HTTP::Request;
    require HTTP::Headers;

    patch() if $SOAP::Constants::PATCH_HTTP_KEEPALIVE;

    my ( @params, @methods );
    while (@_) {
        $class->can( $_[0] )
          ? push( @methods, shift() => shift )
          : push( @params,  shift );
    }
    my $self = $class->SUPER::new(@params);

    die
"SOAP::Transport::HTTP::Client must inherit from LWP::UserAgent, or one of its subclasses"
      if !$self->isa("LWP::UserAgent");

    $self->agent( join '/', 'SOAP::Lite', 'Perl',
        $SOAP::Transport::HTTP::VERSION );
    $self->options( {} );

    $self->http_request( HTTP::Request->new() );

    while (@methods) {
        my ( $method, $params ) = splice( @methods, 0, 2 );
        # ssl_opts takes a hash, not a ref - see RT 107924
        if (ref $params eq 'HASH' && $method eq 'ssl_opts') {
            $self->$method( %$params );
            next;
        }
        $self->$method( ref $params eq 'ARRAY' ? @$params : $params );
    }

    SOAP::Trace::objects('()');

    $self->setDebugLogger(\&SOAP::Trace::debug);

    return $self;
}

sub send_receive {
    my ( $self, %parameters ) = @_;
    my ( $context, $envelope, $endpoint, $action, $encoding, $parts ) =
      @parameters{qw(context envelope endpoint action encoding parts)};

    $encoding ||= 'UTF-8';

    $endpoint ||= $self->endpoint;

    my $method = 'POST';
    $COMPRESS = 'gzip';

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

    # Initialize the basic about the HTTP Request object
    my $http_request = $self->http_request()->clone();

    # $self->http_request(HTTP::Request->new);
    $http_request->headers( HTTP::Headers->new );

    # TODO - add application/dime
    $http_request->header(
        Accept => ['text/xml', 'multipart/*', 'application/soap'] );
    $http_request->method($method);
    $http_request->url($endpoint);

    no strict 'refs';
    if ($parts) {
        my $packager = $context->packager;
        $envelope = $packager->package( $envelope, $context );
        for my $hname ( keys %{$packager->headers_http} ) {
            $http_request->headers->header(
                $hname => $packager->headers_http->{$hname} );
        }

        # TODO - DIME support
    }

  COMPRESS: {
        my $compressed =
             !exists $nocompress{$endpoint}
          && $self->options->{is_compress}
          && ( $self->options->{compress_threshold} || 0 ) < length $envelope;


        my $original_encoding = $http_request->content_encoding;

        while (1) {

            # check cache for redirect
            $endpoint = $redirect{$endpoint} if exists $redirect{$endpoint};

            # check cache for M-POST
            $method = 'M-POST' if exists $mpost{$endpoint};

          # what's this all about?
          # unfortunately combination of LWP and Perl 5.6.1 and later has bug
          # in sending multibyte characters. LWP uses length() to calculate
          # content-length header and starting 5.6.1 length() calculates chars
          # instead of bytes. 'use bytes' in THIS file doesn't work, because
          # it's lexically scoped. Unfortunately, content-length we calculate
          # here doesn't work either, because LWP overwrites it with
          # content-length it calculates (which is wrong) AND uses length()
          # during syswrite/sysread, so we are in a bad shape anyway.