945 lines
28 KiB
Perl
945 lines
28 KiB
Perl
# ======================================================================
|
|
#
|
|
# 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.17;
|
|
|
|
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 );
|
|
$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);
|
|
}
|
|
# 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;
|
|
|
|
$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
|
|
),
|
|
( $] > 5.007 )
|
|
? do { require Encode; Encode::encode( $encoding, $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;
|