I've got the same problem and quick-fixed it in the SOAP::Transport::HTTP module.
in the perl module you'll find a package named SOAP::Transport::HTTP::Server, below is my code.
I've only adjusted the code for the send_response function, but here is the entire package anyway.
I've placed comment behind the adjusted lines for this package.
package SOAP::Transport::HTTP::Server;
use vars qw(@ISA $COMPRESS);
@ISA = qw(SOAP::Server);
use URI;
$COMPRESS = 'deflate';
sub DESTROY { SOAP::Trace::objects('()') }
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('()');
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;
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/*,' or 'application/dime' instead of '$content
+_type'")
if $content_type
&& $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->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) = @_;
if(scalar(@{$self->packager->parts}) > 0){ # This is added, check if there are files
$response = $self->packager->package($response); # This is added, Package these
} # This is added, files according to the packager
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?
# Added comment: don't check using header settings,
# Added comment: but instead read the last line of the response message and
# Added comment: check if it matches the End of Message block for multipart messages.
my ($is_multipart) = ($response =~ /\n--([^\"]+)--\s*$/); # This is adjusted
$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,
$response,
));
$self->response->headers->header('Content-Type' => 'Multipart/Related; type="text/xml"; start="
+<main_envelope>"; boundary="'.$is_multipart.'"') if $is_multipart;
}
Hope that this fix works for you.
Regards,
Beld.
