Initial Commit

database/perl/vendor/lib/SOAP/Transport/HTTP.pm

@@ -0,0 +1,953 @@
+# ======================================================================
+#
+# Copyright (C) 2000-2004 Paul Kulchenko (paulclinger@yahoo.com)
+# SOAP::Lite is free software; you can redistribute it
+# and/or modify it under the same terms as Perl itself.
+#
+# ======================================================================
+
+package SOAP::Transport::HTTP;
+
+use strict;
+
+our $VERSION = '1.27'; # VERSION
+
+use SOAP::Lite;
+use SOAP::Packager;
+
+# ======================================================================
+
+package SOAP::Transport::HTTP::Client;
+
+use vars qw(@ISA $COMPRESS $USERAGENT_CLASS);
+$USERAGENT_CLASS = 'LWP::UserAgent';
+@ISA             = qw(SOAP::Client);
+
+$COMPRESS = 'deflate';
+
+my ( %redirect, %mpost, %nocompress );
+
+# hack for HTTP connection that returns Keep-Alive
+# miscommunication (?) between LWP::Protocol and LWP::Protocol::http
+# dies after timeout, but seems like we could make it work
+my $_patched = 0;
+
+sub patch {
+    return if $_patched;
+    BEGIN { local ($^W) = 0; }
+    {
+        local $^W = 0;
+        sub LWP::UserAgent::redirect_ok;
+        *LWP::UserAgent::redirect_ok = sub { 1 }
+    }
+    {
+
+        package
+            LWP::Protocol;
+        local $^W = 0;
+        my $collect = \&collect;    # store original
+        *collect = sub {
+            if ( defined $_[2]->header('Connection')
+                && $_[2]->header('Connection') eq 'Keep-Alive' ) {
+                my $data = $_[3]->();
+                my $next =
+                  $_[2]->header('Content-Length') &&
+                    SOAP::Utils::bytelength($$data) ==
+                        $_[2]->header('Content-Length')
+                  ? sub { my $str = ''; \$str; }
+                  : $_[3];
+                my $done = 0;
+                $_[3] = sub {
+                    $done++ ? &$next : $data;
+                };
+            }
+            goto &$collect;
+        };
+    }
+    $_patched++;
+}
+
+sub DESTROY { SOAP::Trace::objects('()') }
+
+sub http_request {
+    my $self = shift;
+    if (@_) { $self->{'_http_request'} = shift; return $self }
+    return $self->{'_http_request'};
+}
+
+sub http_response {
+    my $self = shift;
+    if (@_) { $self->{'_http_response'} = shift; return $self }
+    return $self->{'_http_response'};
+}
+
+sub setDebugLogger {
+    my ($self,$logger) = @_;
+    $self->{debug_logger} = $logger;
+}
+
+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.
+          #
+          # what to do? we calculate proper content-length (using
+          # bytelength() function from SOAP::Utils) and then drop utf8 mark
+          # from string (doing pack with 'C0A*' modifier) if length and
+          # bytelength are not the same
+            my $bytelength = SOAP::Utils::bytelength($envelope);
+            if ($] < 5.008) {
+                $envelope = pack( 'C0A*', $envelope );
+            }
+            else {
+                require Encode;
+                $envelope = Encode::encode($encoding, $envelope);
+                $bytelength = SOAP::Utils::bytelength($envelope);
+            }
+            #  if !$SOAP::Constants::DO_NOT_USE_LWP_LENGTH_HACK
+            #      && length($envelope) != $bytelength;
+
+            # compress after encoding
+            # doing it before breaks the compressed content (#74577)
+            $envelope = Compress::Zlib::memGzip($envelope) if $compressed;
+
+            $http_request->content($envelope);
+            $http_request->protocol('HTTP/1.1');
+
+            $http_request->proxy_authorization_basic( $ENV{'HTTP_proxy_user'},
+                $ENV{'HTTP_proxy_pass'} )
+              if ( $ENV{'HTTP_proxy_user'} && $ENV{'HTTP_proxy_pass'} );
+
+            # by Murray Nesbitt
+            if ( $method eq 'M-POST' ) {
+                my $prefix = sprintf '%04d', int( rand(1000) );
+                $http_request->header(
+                    Man => qq!"$SOAP::Constants::NS_ENV"; ns=$prefix! );
+                $http_request->header( "$prefix-SOAPAction" => $action )
+                  if defined $action;
+            }
+            else {
+                $http_request->header( SOAPAction => $action )
+                  if defined $action;
+            }
+
+            #            $http_request->header(Expect => '100-Continue');
+
+            # allow compress if present and let server know we could handle it
+            $http_request->header( 'Accept-Encoding' =>
+                  [$SOAP::Transport::HTTP::Client::COMPRESS] )
+              if $self->options->{is_compress};
+
+            $http_request->content_encoding(
+                $SOAP::Transport::HTTP::Client::COMPRESS)
+              if $compressed;
+
+            if ( !$http_request->content_type ) {
+                $http_request->content_type(
+                    join '; ',
+                    $SOAP::Constants::DEFAULT_HTTP_CONTENT_TYPE,
+                    !$SOAP::Constants::DO_NOT_USE_CHARSET && $encoding
+                    ? 'charset=' . lc($encoding)
+                    : () );
+            }
+            elsif ( !$SOAP::Constants::DO_NOT_USE_CHARSET && $encoding ) {
+                my $tmpType = $http_request->headers->header('Content-type');
+
+                # $http_request->content_type($tmpType.'; charset=' . lc($encoding));
+                my $addition = '; charset=' . lc($encoding);
+                $http_request->content_type( $tmpType . $addition )
+                  if ( $tmpType !~ /$addition/ );
+            }
+
+            $http_request->content_length($bytelength) unless $compressed;
+            SOAP::Trace::transport($http_request);
+            &{$self->{debug_logger}}($http_request->as_string);
+
+            $self->SUPER::env_proxy if $ENV{'HTTP_proxy'};
+
+            # send and receive the stuff.
+            # TODO maybe eval this? what happens on connection close?
+            $self->http_response( $self->SUPER::request($http_request) );
+            SOAP::Trace::transport( $self->http_response );
+            &{$self->{debug_logger}}($self->http_response->as_string);
+
+            # 100 OK, continue to read?
+            if ( (
+                       $self->http_response->code == 510
+                    || $self->http_response->code == 501
+                )
+                && $method ne 'M-POST'
+              ) {
+                $mpost{$endpoint} = 1;
+            }
+            elsif ( $self->http_response->code == 415 && $compressed ) {
+
+                # 415 Unsupported Media Type
+                $nocompress{$endpoint} = 1;
+                $envelope = Compress::Zlib::memGunzip($envelope);
+                $http_request->headers->remove_header('Content-Encoding');
+                redo COMPRESS;    # try again without compression
+            }
+            else {
+                last;
+            }
+        }
+    }
+
+    $redirect{$endpoint} = $self->http_response->request->url
+      if $self->http_response->previous
+          && $self->http_response->previous->is_redirect;
+
+    $self->code( $self->http_response->code );
+    $self->message( $self->http_response->message );
+    $self->is_success( $self->http_response->is_success );
+    $self->status( $self->http_response->status_line );
+
+    # Pull out any cookies from the response headers
+    $self->{'_cookie_jar'}->extract_cookies( $self->http_response )
+      if $self->{'_cookie_jar'};
+
+    my $content =
+      ( $self->http_response->content_encoding || '' ) =~
+      /\b$SOAP::Transport::HTTP::Client::COMPRESS\b/o
+      && $self->options->{is_compress}
+      ? Compress::Zlib::memGunzip( $self->http_response->content )
+      : ( $self->http_response->content_encoding || '' ) =~ /\S/ ? die
+"Can't understand returned Content-Encoding (@{[$self->http_response->content_encoding]})\n"
+      : $self->http_response->content;
+
+    return $self->http_response->content_type =~ m!^multipart/!i
+      ? join( "\n", $self->http_response->headers_as_string, $content )
+      : $content;
+}
+
+# ======================================================================
+
+package SOAP::Transport::HTTP::Server;
+
+use vars qw(@ISA $COMPRESS);
+@ISA = qw(SOAP::Server);
+
+use URI;
+
+$COMPRESS = 'deflate';
+
+sub DESTROY { SOAP::Trace::objects('()') }
+
+sub setDebugLogger {
+    my ($self,$logger) = @_;
+    $self->{debug_logger} = $logger;
+}
+
+sub new {
+    require LWP::UserAgent;
+    my $self = shift;
+    return $self if ref $self;    # we're already an object
+
+    my $class = $self;
+    $self = $class->SUPER::new(@_);
+    $self->{'_on_action'} = sub {
+        ( my $action = shift || '' ) =~ s/^(\"?)(.*)\1$/$2/;
+        die
+"SOAPAction shall match 'uri#method' if present (got '$action', expected '@{[join('#', @_)]}'\n"
+          if $action
+              && $action ne join( '#', @_ )
+              && $action ne join( '/', @_ )
+              && ( substr( $_[0], -1, 1 ) ne '/'
+                  || $action ne join( '', @_ ) );
+    };
+    SOAP::Trace::objects('()');
+
+    $self->setDebugLogger(\&SOAP::Trace::debug);
+
+    return $self;
+}
+
+sub BEGIN {
+    no strict 'refs';
+    for my $method (qw(request response)) {
+        my $field = '_' . $method;
+        *$method = sub {
+            my $self = shift->new;
+            @_
+              ? ( $self->{$field} = shift, return $self )
+              : return $self->{$field};
+        };
+    }
+}
+
+sub handle {
+    my $self = shift->new;
+
+    &{$self->{debug_logger}}($self->request->content);
+
+    if ( $self->request->method eq 'POST' ) {
+        $self->action( $self->request->header('SOAPAction') || undef );
+    }
+    elsif ( $self->request->method eq 'M-POST' ) {
+        return $self->response(
+            HTTP::Response->new(
+                510,    # NOT EXTENDED
+"Expected Mandatory header with $SOAP::Constants::NS_ENV as unique URI"
+            ) )
+          if $self->request->header('Man') !~
+              /^"$SOAP::Constants::NS_ENV";\s*ns\s*=\s*(\d+)/;
+        $self->action( $self->request->header("$1-SOAPAction") || undef );
+    }
+    else {
+        return $self->response(
+            HTTP::Response->new(405) )    # METHOD NOT ALLOWED
+    }
+
+    my $compressed =
+      ( $self->request->content_encoding || '' ) =~ /\b$COMPRESS\b/;
+    $self->options->{is_compress} ||=
+      $compressed && eval { require Compress::Zlib };
+
+    # signal error if content-encoding is 'deflate', but we don't want it OR
+    # something else, so we don't understand it
+    return $self->response(
+        HTTP::Response->new(415) )        # UNSUPPORTED MEDIA TYPE
+      if $compressed && !$self->options->{is_compress}
+          || !$compressed
+          && ( $self->request->content_encoding || '' ) =~ /\S/;
+
+    my $content_type = $self->request->content_type || '';
+
+# in some environments (PerlEx?) content_type could be empty, so allow it also
+# anyway it'll blow up inside ::Server::handle if something wrong with message
+# TBD: but what to do with MIME encoded messages in THOSE environments?
+    return $self->make_fault( $SOAP::Constants::FAULT_CLIENT,
+            "Content-Type must be 'text/xml,' 'multipart/*,' "
+          . "'application/soap+xml,' 'or 'application/dime' instead of '$content_type'"
+      )
+      if !$SOAP::Constants::DO_NOT_CHECK_CONTENT_TYPE
+          && $content_type
+          && $content_type ne 'application/soap+xml'
+          && $content_type ne 'text/xml'
+          && $content_type ne 'application/dime'
+          && $content_type !~ m!^multipart/!;
+
+    # 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
+    my $chunked = (defined $ENV{'HTTP_TRANSFER_ENCODING'}
+        && $ENV{'HTTP_TRANSFER_ENCODING'} =~ /^chunked.*$/) || 0;
+
+
+    my $content = q{};
+
+    if ($chunked) {
+        my $buffer;
+        binmode(STDIN);
+        while ( read( STDIN, my $buffer, 1024 ) ) {
+            $content .= $buffer;
+        }
+        $length = length($content);
+    }
+
+    if ( !$length ) {
+        $self->response( HTTP::Response->new(411) )    # LENGTH REQUIRED
+    }
+    elsif ( defined $SOAP::Constants::MAX_CONTENT_SIZE
+        && $length > $SOAP::Constants::MAX_CONTENT_SIZE ) {
+        $self->response( HTTP::Response->new(413) ) # REQUEST ENTITY TOO LARGE
+    }
+    else {
+        if ( exists $ENV{EXPECT} && $ENV{EXPECT} =~ /\b100-Continue\b/i ) {
+            print "HTTP/1.1 100 Continue\r\n\r\n";
+        }
+
+        #my $content = q{};
+        if ( !$chunked ) {
+            my $buffer;
+            binmode(STDIN);
+            if ( defined $ENV{'MOD_PERL'} ) {
+                while ( read( STDIN, $buffer, $length ) ) {
+                    $content .= $buffer;
+                    last if ( length($content) >= $length );
+                }
+            } else {
+                while ( sysread( STDIN, $buffer, $length ) ) {
+                    $content .= $buffer;
+                    last if ( length($content) >= $length );
+                }
+            }
+        }
+
+        $self->request(
+            HTTP::Request->new(
+                $ENV{'REQUEST_METHOD'} || '' => $ENV{'SCRIPT_NAME'},
+                HTTP::Headers->new(
+                    map { (
+                              /^HTTP_(.+)/i
+                            ? ( $1 =~ m/SOAPACTION/ )
+                                  ? ('SOAPAction')
+                                  : ($1)
+                            : $_
+                          ) => $ENV{$_}
+                      } keys %ENV
+                ),
+                $content,
+            ) );
+        $self->SUPER::handle;
+    }
+
+    # imitate nph- cgi for IIS (pointed by Murray Nesbitt)
+    my $status =
+      defined( $ENV{'SERVER_SOFTWARE'} )
+      && $ENV{'SERVER_SOFTWARE'} =~ /IIS/
+      ? $ENV{SERVER_PROTOCOL} || 'HTTP/1.0'
+      : 'Status:';
+    my $code = $self->response->code;
+
+    binmode(STDOUT);
+
+    print STDOUT "$status $code ", HTTP::Status::status_message($code),
+      "\015\012", $self->response->headers_as_string("\015\012"), "\015\012",
+      $self->response->content;
+}
+
+# ======================================================================
+
+package SOAP::Transport::HTTP::Daemon;
+
+use Carp ();
+use vars qw($AUTOLOAD @ISA);
+@ISA = qw(SOAP::Transport::HTTP::Server);
+
+sub DESTROY { SOAP::Trace::objects('()') }
+
+#sub new { require HTTP::Daemon;
+sub new {
+    my $self = shift;
+    return $self if ( ref $self );
+
+    my $class = $self;
+
+    my ( @params, @methods );
+    while (@_) {
+        $class->can( $_[0] )
+          ? push( @methods, shift() => shift )
+          : push( @params,  shift );
+    }
+    $self = $class->SUPER::new;
+
+    # Added in 0.65 - Thanks to Nils Sowen
+    # use SSL if there is any parameter with SSL_* in the name
+    $self->SSL(1) if !$self->SSL && grep /^SSL_/, @params;
+    my $http_daemon = $self->http_daemon_class;
+    eval "require $http_daemon"
+      or Carp::croak $@
+      unless $http_daemon->can('new');
+
+    $self->{_daemon} = $http_daemon->new(@params)
+      or Carp::croak "Can't create daemon: $!";
+
+    # End SSL patch
+
+    $self->myuri( URI->new( $self->url )->canonical->as_string );
+
+    while (@methods) {
+        my ( $method, $params ) = splice( @methods, 0, 2 );
+        $self->$method(
+            ref $params eq 'ARRAY'
+            ? @$params
+            : $params
+        );
+    }
+    SOAP::Trace::objects('()');
+
+    return $self;
+}
+
+sub SSL {
+    my $self = shift->new;
+    if (@_) {
+        $self->{_SSL} = shift;
+        return $self;
+    }
+    return $self->{_SSL};
+}
+
+sub http_daemon_class { shift->SSL ? 'HTTP::Daemon::SSL' : 'HTTP::Daemon' }
+
+sub AUTOLOAD {
+    my $method = substr( $AUTOLOAD, rindex( $AUTOLOAD, '::' ) + 2 );
+    return if $method eq 'DESTROY';
+
+    no strict 'refs';
+    *$AUTOLOAD = sub { shift->{_daemon}->$method(@_) };
+    goto &$AUTOLOAD;
+}
+
+sub handle {
+    my $self = shift->new;
+    while ( my $c = $self->accept ) {
+        while ( my $r = $c->get_request ) {
+            $self->request($r);
+            $self->SUPER::handle;
+            eval {
+                local $SIG{PIPE} = sub {die "SIGPIPE"};
+                $c->send_response( $self->response );
+            };
+            if ($@ && $@ !~ /^SIGPIPE/) {
+                die $@;
+            }
+        }
+
+# replaced ->close, thanks to Sean Meisner <Sean.Meisner@VerizonWireless.com>
+# shutdown() doesn't work on AIX. close() is used in this case. Thanks to Jos Clijmans <jos.clijmans@recyfin.be>
+        $c->can('shutdown')
+          ? $c->shutdown(2)
+          : $c->close();
+        $c->close;
+    }
+}
+
+# ======================================================================
+
+package SOAP::Transport::HTTP::Apache;
+
+use vars qw(@ISA);
+@ISA = qw(SOAP::Transport::HTTP::Server);
+
+sub DESTROY { SOAP::Trace::objects('()') }
+
+sub new {
+    my $self = shift;
+    unless ( ref $self ) {
+        my $class = ref($self) || $self;
+        $self = $class->SUPER::new(@_);
+        SOAP::Trace::objects('()');
+    }
+
+    # Added this code thanks to JT Justman
+    # This code improves and provides more robust support for
+    # multiple versions of Apache and mod_perl
+
+    # mod_perl 2.0
+    if ( defined $ENV{MOD_PERL_API_VERSION}
+        && $ENV{MOD_PERL_API_VERSION} >= 2 ) {
+        require Apache2::RequestRec;
+        require Apache2::RequestIO;
+        require Apache2::Const;
+        require Apache2::RequestUtil;
+        require APR::Table;
+        Apache2::Const->import( -compile => 'OK' );
+        Apache2::Const->import( -compile => 'HTTP_BAD_REQUEST' );
+        $self->{'MOD_PERL_VERSION'} = 2;
+        $self->{OK} = &Apache2::Const::OK;
+    }
+    else {    # mod_perl 1.xx
+        die "Could not find or load mod_perl"
+          unless ( eval "require mod_perl" );
+        die "Could not detect your version of mod_perl"
+          if ( !defined($mod_perl::VERSION) );
+        if ( $mod_perl::VERSION < 1.99 ) {
+            require Apache;
+            require Apache::Constants;
+            Apache::Constants->import('OK');
+            Apache::Constants->import('HTTP_BAD_REQUEST');
+            $self->{'MOD_PERL_VERSION'} = 1;
+            $self->{OK} = &Apache::Constants::OK;
+        }
+        else {
+            require Apache::RequestRec;
+            require Apache::RequestIO;
+            require Apache::Const;
+            Apache::Const->import( -compile => 'OK' );
+            Apache::Const->import( -compile => 'HTTP_BAD_REQUEST' );
+            $self->{'MOD_PERL_VERSION'} = 1.99;
+            $self->{OK} = &Apache::OK;
+        }
+    }
+
+    return $self;
+}
+
+sub handler {
+    my $self = shift->new;
+    my $r    = shift;
+
+    # Begin patch from JT Justman
+    if ( !$r ) {
+        if ( $self->{'MOD_PERL_VERSION'} < 2 ) {
+            $r = Apache->request();
+        }
+        else {
+            $r = Apache2::RequestUtil->request();
+        }
+    }
+
+    my $cont_len;
+    if ( $self->{'MOD_PERL_VERSION'} < 2 ) {
+        $cont_len = $r->header_in('Content-length');
+    }
+    else {
+        $cont_len = $r->headers_in->get('Content-length');
+    }
+
+    # End patch from JT Justman
+
+    my $content = "";
+    if ( $cont_len > 0 ) {
+        my $buf;
+
+        # attempt to slurp in the content at once...
+        $content .= $buf while ( $r->read( $buf, $cont_len ) > 0 );
+    }
+    else {
+
+        # throw appropriate error for mod_perl 2
+        return Apache2::Const::HTTP_BAD_REQUEST()
+          if ( $self->{'MOD_PERL_VERSION'} >= 2 );
+        return Apache::Constants::BAD_REQUEST();
+    }
+
+    my %headers;
+    if ( $self->{'MOD_PERL_VERSION'} < 2 ) {
+        %headers = $r->headers_in; # Apache::Table structure
+    } else {
+        %headers = %{ $r->headers_in }; # Apache2::RequestRec structure
+    }
+
+    $self->request(
+        HTTP::Request->new(
+            $r->method() => $r->uri,
+            HTTP::Headers->new( %headers ),
+            $content
+        ) );
+    $self->SUPER::handle;
+
+    # we will specify status manually for Apache, because
+    # if we do it as it has to be done, returning SERVER_ERROR,
+    # Apache will modify our content_type to 'text/html; ....'
+    # which is not what we want.
+    # will emulate normal response, but with custom status code
+    # which could also be 500.
+    if ($self->{'MOD_PERL_VERSION'} < 2 ) {
+        $r->status( $self->response->code );
+    }
+    else {
+        $r->status_line($self->response->code);
+    }
+
+    # Begin JT Justman patch
+    if ( $self->{'MOD_PERL_VERSION'} > 1 ) {
+        $self->response->headers->scan(sub { $r->headers_out->add(@_) });
+        $r->content_type( join '; ', $self->response->content_type );
+    }
+    else {
+        $self->response->headers->scan( sub { $r->header_out(@_) } );
+        $r->send_http_header( join '; ', $self->response->content_type );
+    }
+
+    $r->print( $self->response->content );
+    return $self->{OK};
+
+    # End JT Justman patch
+}
+
+sub configure {
+    my $self   = shift->new;
+    my $config = shift->dir_config;
+    for (%$config) {
+        $config->{$_} =~ /=>/
+          ? $self->$_( {split /\s*(?:=>|,)\s*/, $config->{$_}} )
+          : ref $self->$_() ? ()    # hm, nothing can be done here
+          : $self->$_( split /\s+|\s*,\s*/, $config->{$_} )
+          if $self->can($_);
+    }
+    return $self;
+}
+
+{
+
+    # just create alias
+    sub handle;
+    *handle = \&handler
+}
+
+# ======================================================================
+#
+# Copyright (C) 2001 Single Source oy (marko.asplund@kronodoc.fi)
+# a FastCGI transport class for SOAP::Lite.
+# Updated formatting and removed dead code in new() in 2008
+# by Martin Kutter
+#
+# ======================================================================
+
+package SOAP::Transport::HTTP::FCGI;
+
+use vars qw(@ISA);
+@ISA = qw(SOAP::Transport::HTTP::CGI);
+
+sub DESTROY { SOAP::Trace::objects('()') }
+
+sub new {
+
+    require FCGI;
+    Exporter::require_version( 'FCGI' => 0.47 )
+      ;    # requires thread-safe interface
+
+    my $class = shift;
+    return $class if ref $class;
+
+    my $self = $class->SUPER::new(@_);
+    $self->{_fcgirq} = FCGI::Request( \*STDIN, \*STDOUT, \*STDERR );
+    SOAP::Trace::objects('()');
+
+    return $self;
+}
+
+sub handle {
+    my $self = shift->new;
+
+    my ( $r1, $r2 );
+    my $fcgirq = $self->{_fcgirq};
+
+    while ( ( $r1 = $fcgirq->Accept() ) >= 0 ) {
+        $r2 = $self->SUPER::handle;
+    }
+
+    return undef;
+}
+
+# ======================================================================
+
+1;

database/perl/vendor/lib/SOAP/Transport/IO.pm

@@ -0,0 +1,79 @@
+# ======================================================================
+#
+# Copyright (C) 2000-2001 Paul Kulchenko (paulclinger@yahoo.com)
+# SOAP::Lite is free software; you can redistribute it
+# and/or modify it under the same terms as Perl itself.
+#
+# ======================================================================
+
+package SOAP::Transport::IO;
+
+use strict;
+
+our $VERSION = '1.27'; # VERSION
+
+use IO::File;
+use SOAP::Lite;
+# ======================================================================
+
+package SOAP::Transport::IO::Server;
+
+use strict;
+use Carp ();
+use vars qw(@ISA);
+@ISA = qw(SOAP::Server);
+
+sub new {
+    my $class = shift;
+
+    return $class if ref $class;
+    my $self = $class->SUPER::new(@_);
+
+    return $self;
+}
+
+sub in {
+    my $self = shift;
+    $self = $self->new() if not ref $self;
+
+    return $self->{ _in } if not @_;
+
+    my $file = shift;
+    $self->{_in} = (defined $file && !ref $file && !defined fileno($file))
+        ? IO::File->new($file, 'r')
+        : $file;
+    return $self;
+}
+
+sub out {
+    my $self = shift;
+    $self = $self->new() if not ref $self;
+
+    return $self->{ _out } if not @_;
+
+    my $file = shift;
+    $self->{_out} = (defined $file && !ref $file && !defined fileno($file))
+        ? IO::File->new($file, 'w')
+        : $file;
+    return $self;
+}
+
+sub handle {
+    my $self = shift->new;
+
+    $self->in(*STDIN)->out(*STDOUT) unless defined $self->in;
+    my $in = $self->in;
+    my $out = $self->out;
+
+    my $result = $self->SUPER::handle(join '', <$in>);
+    no strict 'refs';
+    print {$out} $result
+        if defined $out;
+    return;
+}
+
+# ======================================================================
+
+1;
+
+__END__

database/perl/vendor/lib/SOAP/Transport/LOCAL.pm

@@ -0,0 +1,66 @@
+# ======================================================================
+#
+# Copyright (C) 2000-2001 Paul Kulchenko (paulclinger@yahoo.com)
+# SOAP::Lite is free software; you can redistribute it
+# and/or modify it under the same terms as Perl itself.
+#
+# ======================================================================
+
+package SOAP::Transport::LOCAL;
+
+use strict;
+
+our $VERSION = '1.27'; # VERSION
+
+# ======================================================================
+
+package SOAP::Transport::LOCAL::Client;
+
+use SOAP::Lite;
+
+use vars qw(@ISA);
+our @ISA = qw(SOAP::Client SOAP::Server);
+
+sub new {
+    my $class = shift;
+    return $class if ref $class;
+    my @method_from;
+    while (@_) {
+        if ($class->can($_[0])) {
+            push(@method_from, shift() => shift);
+        }
+        else
+        {
+            # ignore unknown arguments
+            shift;
+        }
+    }
+    my $self = $class->SUPER::new();
+    $self->is_success(1);     # it's difficult to fail in this module
+    $self->dispatch_to(@INC);
+    while (@method_from) {
+        my($method, $param_ref) = splice(@method_from,0,2);
+        $self->$method(ref $param_ref eq 'ARRAY'
+            ? @$param_ref
+            : $param_ref)
+    }
+    return $self;
+}
+
+sub send_receive {
+    my ($self, %parameters) = @_;
+    my ($envelope, $endpoint, $action) =
+        @parameters{qw(envelope endpoint action)};
+
+    SOAP::Trace::debug($envelope);
+    my $response = $self->SUPER::handle($envelope);
+    SOAP::Trace::debug($response);
+
+    return $response;
+}
+
+# ======================================================================
+
+1;
+
+__END__

database/perl/vendor/lib/SOAP/Transport/LOOPBACK.pm

@@ -0,0 +1,80 @@
+# ======================================================================
+#
+# Copyright (C) 2007 Martin Kutter.
+# Part of SOAP-Lite, Copyright (C) 2000-2001 Paul Kulchenko
+#  (paulclinger@yahoo.com)
+# You may distribute/modify this file under the same terms as perl itself.
+#
+# $ID: $
+#
+# ======================================================================
+
+package SOAP::Transport::LOOPBACK;
+use strict;
+
+package SOAP::Transport::LOOPBACK::Client;
+use strict;
+
+our $VERSION = '1.27'; # VERSION
+
+use vars qw(@ISA);
+use SOAP::Lite;
+@ISA = qw(SOAP::Client);
+
+sub new {
+    return $_[0] if ref $_[0];
+    return bless {}, $_[0];
+}
+
+sub send_receive {
+    my($self, %parameters) = @_;
+
+    $self->code(200);
+    $self->message('OK');
+    $self->is_success(1);
+    $self->status('200 OK');
+
+    return $parameters{envelope};
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+SOAP::Transport::LOOPBACK - Test loopback transport backend (Client only)
+
+=head1 DESCRIPTION
+
+SOAP::Transport::LOOPBACK is a test transport backend for SOAP::Lite.
+
+It just returns the XML request as response, thus allowing to test the
+complete application stack of client applications from the front end down to
+the transport layer without actually sending data over the wire.
+
+Using this transport backend is triggered by setting a loopback:// URL.
+
+Sending requests through this transport backend alway succeeds with the
+following states:
+
+ status: 200 OK
+ code: 200
+ message: OK
+
+=head1 COPYRIGHT
+
+Copyright (C) 2007 Martin Kutter. All rights reserved.
+
+This file is part of SOAP-Lite, Copyright (C) 2000-2001 Paul Kulchenko.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=head1 AUTHOR
+
+Martin Kutter E<lt>martin.kutter fen-net.deE<gt>
+
+=cut

database/perl/vendor/lib/SOAP/Transport/MAILTO.pm

@@ -0,0 +1,93 @@
+# ======================================================================
+#
+# Copyright (C) 2000-2001 Paul Kulchenko (paulclinger@yahoo.com)
+# SOAP::Lite is free software; you can redistribute it
+# and/or modify it under the same terms as Perl itself.
+#
+# ======================================================================
+
+package SOAP::Transport::MAILTO;
+
+use strict;
+
+our $VERSION = '1.27'; # VERSION
+
+use MIME::Lite;
+use URI;
+
+# ======================================================================
+
+package SOAP::Transport::MAILTO::Client;
+use SOAP::Lite;
+use vars qw(@ISA);
+@ISA = qw(SOAP::Client);
+
+sub DESTROY { SOAP::Trace::objects('()') }
+
+sub new {
+    my $class = shift;
+    return $class if ref $class;
+
+    my(@params, @methods);
+    while (@_) { $class->can($_[0]) ? push(@methods, shift() => shift) : push(@params, shift) }
+    my $self = bless {@params} => $class;
+    while (@methods) { my($method, $params) = splice(@methods,0,2);
+        $self->$method(ref $params eq 'ARRAY' ? @$params : $params)
+    }
+    SOAP::Trace::objects('()');
+
+    return $self;
+}
+
+sub send_receive {
+    my($self, %parameters) = @_;
+    my($envelope, $endpoint, $action) =
+        @parameters{qw(envelope endpoint action)};
+
+    $endpoint ||= $self->endpoint;
+    my $uri = URI->new($endpoint);
+    %parameters = (%$self,
+        map {URI::Escape::uri_unescape($_)}
+            map {split/=/,$_,2}
+                split /[&;]/, $uri->query || '');
+
+    my $msg = MIME::Lite->new(
+        To         => $uri->to,
+        Type       => 'text/xml',
+        Encoding   => $parameters{Encoding} || 'base64',
+        Data       => $envelope,
+        $parameters{From}
+            ? (From => $parameters{From})
+            : (),
+        $parameters{'Reply-To'}
+            ? ('Reply-To' => $parameters{'Reply-To'})
+            : (),
+        $parameters{Subject}
+            ? (Subject    => $parameters{Subject})
+            : (),
+    );
+    $msg->replace('X-Mailer' => join '/', 'SOAP::Lite', 'Perl', SOAP::Transport::MAILTO->VERSION);
+    $msg->add(SOAPAction => $action);
+
+    SOAP::Trace::transport($msg);
+    SOAP::Trace::debug($msg->as_string);
+
+    MIME::Lite->send(map {exists $parameters{$_}
+        ? ($_ => $parameters{$_})
+        : ()} 'smtp', 'sendmail');
+    eval { local $SIG{__DIE__}; $MIME::Lite::AUTO_CC = 0; $msg->send };
+    (my $code = $@) =~ s/ at .*\n//;
+
+    $self->code($code);
+    $self->message($code);
+    $self->is_success(!defined $code || $code eq '');
+    $self->status($code);
+
+    return;
+}
+
+# ======================================================================
+
+1;
+
+__END__

database/perl/vendor/lib/SOAP/Transport/POP3.pm

@@ -0,0 +1,121 @@
+# ======================================================================
+#
+# Copyright (C) 2000-2001 Paul Kulchenko (paulclinger@yahoo.com)
+# SOAP::Lite is free software; you can redistribute it
+# and/or modify it under the same terms as Perl itself.
+#
+# ======================================================================
+
+package SOAP::Transport::POP3;
+
+use strict;
+
+our $VERSION = '1.27'; # VERSION
+
+use Net::POP3;
+use URI;
+
+# ======================================================================
+
+package SOAP::Transport::POP3::Server;
+
+use Carp ();
+use vars qw(@ISA $AUTOLOAD);
+@ISA = qw(SOAP::Server);
+
+sub DESTROY { my $self = shift; $self->quit if $self->{_pop3server} }
+
+sub new {
+    my $class = shift;
+    return $class if ref $class;
+
+    my $address = shift;
+    Carp::carp "URLs without 'pop://' scheme are deprecated. Still continue"
+      if $address =~ s!^(pop://)?!pop://!i && !$1;
+    my $server = URI->new($address);
+    my $self = $class->SUPER::new(@_);
+    $self->{_pop3server} = Net::POP3->new($server->host_port)
+        or Carp::croak "Can't connect to '@{[$server->host_port]}': $!";
+    my $method = ! $server->auth || $server->auth eq '*'
+        ? 'login'
+        : $server->auth eq '+APOP'
+            ? 'apop'
+            : Carp::croak "Unsupported authentication scheme '@{[$server->auth]}'";
+    $self->{_pop3server}->$method( split m{:}, $server->user() )
+        or Carp::croak "Can't authenticate to '@{[$server->host_port]}' with '$method' method"
+            if defined $server->user;
+    return $self;
+}
+
+sub AUTOLOAD {
+  my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2);
+  return if $method eq 'DESTROY';
+
+  no strict 'refs';
+  *$AUTOLOAD = sub { shift->{_pop3server}->$method(@_) };
+  goto &$AUTOLOAD;
+}
+
+sub handle {
+  my $self = shift->new;
+  my $messages = $self->list or return;
+  # fixes [ 1.17700 ] POP3 Processes Messages Out of Order
+  foreach my $msgid (sort { $a <=> $b } (keys(%{$messages}) ) ) {
+  # foreach my $msgid (keys %$messages) {
+    $self->SUPER::handle(join '', @{$self->get($msgid)});
+  } continue {
+    $self->delete($msgid);
+  }
+  return scalar keys %$messages;
+}
+
+sub make_fault { return }
+
+# ======================================================================
+
+1;
+
+__END__
+
+=head1 NAME
+
+SOAP::Transport::POP3 - Server side POP3 support for SOAP::Lite
+
+=head1 SYNOPSIS
+
+  use SOAP::Transport::POP3;
+
+  my $server = SOAP::Transport::POP3::Server
+    -> new('pop://pop.mail.server')
+    # if you want to have all in one place
+    # -> new('pop://user:password@pop.mail.server')
+    # or, if you have server that supports MD5 protected passwords
+    # -> new('pop://user:password;AUTH=+APOP@pop.mail.server')
+    # specify list of objects-by-reference here
+    -> objects_by_reference(qw(My::PersistentIterator My::SessionIterator My::Chat))
+    # specify path to My/Examples.pm here
+    -> dispatch_to('/Your/Path/To/Deployed/Modules', 'Module::Name', 'Module::method')
+  ;
+  # you don't need to use next line if you specified your password in new()
+  $server->login('user' => 'password') or die "Can't authenticate to POP3 server\n";
+
+  # handle will return number of processed mails
+  # you can organize loop if you want
+  do { $server->handle } while sleep 10;
+
+  # you may also call $server->quit explicitly to purge deleted messages
+
+=head1 DESCRIPTION
+
+=head1 COPYRIGHT
+
+Copyright (C) 2000-2001 Paul Kulchenko. All rights reserved.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=head1 AUTHOR
+
+Paul Kulchenko (paulclinger@yahoo.com)
+
+=cut

database/perl/vendor/lib/SOAP/Transport/TCP.pm

@@ -0,0 +1,313 @@
+# ======================================================================
+#
+# Copyright (C) 2000-2001 Paul Kulchenko (paulclinger@yahoo.com)
+# SOAP::Lite is free software; you can redistribute it
+# and/or modify it under the same terms as Perl itself.
+#
+# $Id: TCP.pm 384 2011-08-16 17:08:08Z kutterma $
+#
+# ======================================================================
+
+package SOAP::Transport::TCP;
+
+use strict;
+
+our $VERSION = '1.27'; # VERSION
+
+use URI;
+use IO::Socket;
+use IO::Select;
+use IO::SessionData;
+
+# ======================================================================
+
+package # hide from PAUSE
+    URI::tcp; # ok, let's do 'tcp://' scheme
+
+our $VERSION = 0.715;
+
+require URI::_server;
+@URI::tcp::ISA=qw(URI::_server);
+
+# ======================================================================
+
+package SOAP::Transport::TCP::Client;
+
+our $VERSION = 0.715;
+
+use vars qw(@ISA);
+require SOAP::Lite;
+@ISA = qw(SOAP::Client);
+
+sub DESTROY { SOAP::Trace::objects('()') }
+
+sub new {
+  my $self = shift;
+
+  unless (ref $self) {
+    my $class = ref($self) || $self;
+    my(@params, @methods);
+    while (@_) { $class->can($_[0]) ? push(@methods, shift() => shift) : push(@params, shift) }
+    $self = bless {@params} => $class;
+    while (@methods) { my($method, $params) = splice(@methods,0,2);
+      $self->$method(ref $params eq 'ARRAY' ? @$params : $params)
+    }
+    # use SSL if there is any parameter with SSL_* in the name
+    $self->SSL(1) if !$self->SSL && grep /^SSL_/, keys %$self;
+    SOAP::Trace::objects('()');
+  }
+  return $self;
+}
+
+sub SSL {
+  my $self = shift->new;
+  @_ ? ($self->{_SSL} = shift, return $self) : return $self->{_SSL};
+}
+
+sub io_socket_class { shift->SSL ? 'IO::Socket::SSL' : 'IO::Socket::INET' }
+
+sub syswrite {
+  my($self, $sock, $data) = @_;
+
+  my $timeout = $sock->timeout;
+
+  my $select = IO::Select->new($sock);
+
+  my $len = length $data;
+  while (length $data > 0) {
+    return unless $select->can_write($timeout);
+    local $SIG{PIPE} = 'IGNORE';
+    # added length() to make it work on Mac. Thanks to Robin Fuller <rfuller@broadjump.com>
+    my $wc = syswrite($sock, $data, length($data));
+    if (defined $wc) {
+      substr($data, 0, $wc) = '';
+    } elsif (!IO::SessionData::WOULDBLOCK($!)) {
+      return;
+    }
+  }
+  return $len;
+}
+
+sub sysread {
+  my($self, $sock) = @_;
+
+  my $timeout = $sock->timeout;
+  my $select = IO::Select->new($sock);
+
+  my $result = '';
+  my $data;
+  while (1) {
+    return unless $select->can_read($timeout);
+    my $rc = sysread($sock, $data, 4096);
+    if ($rc) {
+      $result .= $data;
+    } elsif (defined $rc) {
+      return $result;
+    } elsif (!IO::SessionData::WOULDBLOCK($!)) {
+      return;
+    }
+  }
+}
+
+sub send_receive {
+  my($self, %parameters) = @_;
+  my($envelope, $endpoint, $action) =
+    @parameters{qw(envelope endpoint action)};
+
+  $endpoint ||= $self->endpoint;
+  warn "URLs with 'tcp:' scheme are deprecated. Use 'tcp://'. Still continue\n"
+    if $endpoint =~ s!^tcp:(//)?!tcp://!i && !$1;
+  my $uri = URI->new($endpoint);
+
+  local($^W, $@, $!);
+  my $socket = $self->io_socket_class;
+  eval "require $socket" or Carp::croak $@ unless UNIVERSAL::can($socket => 'new');
+  my $sock = $socket->new (
+    PeerAddr => $uri->host, PeerPort => $uri->port, Proto => $uri->scheme, %$self
+  );
+
+  SOAP::Trace::debug($envelope);
+
+  # bytelength hack. See SOAP::Transport::HTTP.pm for details.
+  my $bytelength = SOAP::Utils::bytelength($envelope);
+  $envelope = pack('C0A*', $envelope)
+    if !$SOAP::Constants::DO_NOT_USE_LWP_LENGTH_HACK && length($envelope) != $bytelength;
+
+  my $result;
+  if ($sock) {
+    $sock->blocking(0);
+    $self->syswrite($sock, $envelope)  and
+     $sock->shutdown(1)                and # stop writing
+     $result = $self->sysread($sock);
+  }
+
+  SOAP::Trace::debug($result);
+
+  my $code = $@ || $!;
+
+  $self->code($code);
+  $self->message($code);
+  $self->is_success(!defined $code || $code eq '');
+  $self->status($code);
+
+  return $result;
+}
+
+# ======================================================================
+
+package SOAP::Transport::TCP::Server;
+
+use IO::SessionSet;
+
+use Carp ();
+use vars qw($AUTOLOAD @ISA);
+@ISA = qw(SOAP::Server);
+
+our $VERSION = 0.715;
+
+sub DESTROY { SOAP::Trace::objects('()') }
+
+sub new {
+  my $self = shift;
+
+  unless (ref $self) {
+    my $class = ref($self) || $self;
+
+    my(@params, @methods);
+    while (@_) { $class->can($_[0]) ? push(@methods, shift() => shift) : push(@params, shift) }
+    $self = $class->SUPER::new(@methods);
+
+    # use SSL if there is any parameter with SSL_* in the name
+    $self->SSL(1) if !$self->SSL && grep /^SSL_/, @params;
+
+    my $socket = $self->io_socket_class;
+    eval "require $socket" or Carp::croak $@ unless UNIVERSAL::can($socket => 'new');
+    $self->{_socket} = $socket->new(Proto => 'tcp', @params)
+      or Carp::croak "Can't open socket: $!";
+
+    SOAP::Trace::objects('()');
+  }
+  return $self;
+}
+
+sub SSL {
+  my $self = shift->new;
+  @_ ? ($self->{_SSL} = shift, return $self) : return $self->{_SSL};
+}
+
+sub io_socket_class { shift->SSL ? 'IO::Socket::SSL' : 'IO::Socket::INET' }
+
+sub AUTOLOAD {
+  my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2);
+  return if $method eq 'DESTROY';
+
+  no strict 'refs';
+  *$AUTOLOAD = sub { shift->{_socket}->$method(@_) };
+  goto &$AUTOLOAD;
+}
+
+sub handle {
+  my $self = shift->new;
+  my $sock = $self->{_socket};
+  my $session_set = IO::SessionSet->new($sock);
+  my %data;
+  while (1) {
+    my @ready = $session_set->wait($sock->timeout);
+    for my $session (grep { defined } @ready) {
+      my $data;
+      if (my $rc = $session->read($data, 4096)) {
+        $data{$session} .= $data if $rc > 0;
+      } else {
+        $session->write($self->SUPER::handle(delete $data{$session}));
+        $session->close;
+      }
+    }
+  }
+}
+
+# ======================================================================
+
+1;
+
+__END__
+
+
+=head1 NAME
+
+SOAP::Transport::TCP - TCP Transport Support for SOAP::Lite
+
+=head2 SOAP::Transport::TCP
+
+The classes provided by this module implement direct TCP/IP communications methods for both clients and servers.
+
+The connections don't use HTTP or any other higher-level protocol. These classes are selected when the client or server object being created uses an endpoint URI that starts with tcp://. Both client and server classes support using Secure Socket Layer if it is available. If any of the parameters to a new method from either of the classes begins with SSL_ (such as SSL_server in place of Server), the class attempts to load the IO::Socket::SSL package and use it to create socket objects.
+
+Both of the following classes catch methods that are intended for the socket objects and pass them along, allowing calls such as $client->accept( ) without including the socket class in the inheritance tree.
+
+=head3 SOAP::Transport::TCP::Client
+
+Inherits from: L<SOAP::Client>.
+
+The TCP client class defines only two relevant methods beyond new and send_receive. These methods are:
+
+=over
+
+=item SSL(I<optional new boolean value>)
+
+    if ($client->SSL) # Execute only if in SSL mode
+
+Reflects the attribute that denotes whether the client object is using SSL sockets for communications.
+
+=item io_socket_class
+
+    ($client->io_socket_class)->new(%options);
+
+Returns the name of the class to use when creating socket objects for internal use in communications. As implemented, it returns one of IO::Socket::INET or IO::Socket::SSL, depending on the return value of the previous SSL method.
+
+=back
+
+If an application creates a subclass that inherits from this client class, either method is a likely target for overloading.
+
+The new method behaves identically to most other classes, except that it detects the presence of SSL-targeted values in the parameter list and sets the SSL method appropriately if they are present.
+
+The send_receive method creates a socket of the appropriate class and connects to the configured endpoint. It then sets the socket to nonblocking I/O, sends the message, shuts down the client end of the connection (preventing further writing), and reads the response back from the server. The socket object is discarded after the response and
+appropriate status codes are set on the client object.
+
+=head3 SOAP::Transport::TCP::Server
+
+Inherits from: L<SOAP::Server>.
+
+The server class also defines the same two additional methods as in the client class:
+
+=over
+
+=item SSL(I<optional new boolean value>)
+
+    if ($client->SSL) # Execute only if in SSL mode
+
+Reflects the attribute that denotes whether the client object is using SSL sockets for communications.
+
+=item io_socket_class
+
+    ($client->io_socket_class)->new(%options);
+
+Returns the name of the class to use when creating socket objects for internal use in communications. As implemented, it returns one of IO::Socket::INET or IO::Socket::SSL, depending on the return value of the previous SSL method. The new method also manages the automatic selection of SSL in the same fashion as the client class does.
+
+The handle method in this server implementation isn't designed to be called once with each new request. Rather, it is called with no arguments, at which time it enters into an infinite loop of waiting for a connection, reading the request, routing the request and sending back the serialized response. This continues until the process itself is interrupted by an untrapped signal or similar means.
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright (C) 2000-2004 Paul Kulchenko. All rights reserved.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=head1 AUTHORS
+
+Written by Paul Kulchenko.
+
+Split from SOAP::Lite and SOAP-Transport-TCP packaging by Martin Kutter
+
+=cut