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; }