andre/scripts
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

init III

Browse Source
This commit is contained in:
Andre Geißler
2024-10-14 00:08:40 +02:00
parent dbfba56f66
commit 1462d52e13
4572 changed files with 2658864 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

187
Perl OTRS/Kernel/cpan-lib/SOAP/Constants.pm Normal file
View File

@@ -0,0 +1,187 @@
# ======================================================================
#
# 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::Constants;
use strict;
use SOAP::Lite;
our $VERSION = 1.17;
use constant URI_1999_SCHEMA_XSD => "http://www.w3.org/1999/XMLSchema";
use constant URI_1999_SCHEMA_XSI => "http://www.w3.org/1999/XMLSchema-instance";
use constant URI_2000_SCHEMA_XSD => "http://www.w3.org/2000/10/XMLSchema";
use constant URI_2000_SCHEMA_XSI => "http://www.w3.org/2000/10/XMLSchema-instance";
use constant URI_2001_SCHEMA_XSD => "http://www.w3.org/2001/XMLSchema";
use constant URI_2001_SCHEMA_XSI => "http://www.w3.org/2001/XMLSchema-instance";
use constant URI_LITERAL_ENC => "";
use constant URI_SOAP11_ENC => "http://schemas.xmlsoap.org/soap/encoding/";
use constant URI_SOAP11_ENV => "http://schemas.xmlsoap.org/soap/envelope/";
use constant URI_SOAP11_NEXT_ACTOR => "http://schemas.xmlsoap.org/soap/actor/next";
use constant URI_SOAP12_ENC => "http://www.w3.org/2003/05/soap-encoding";
use constant URI_SOAP12_ENV => "http://www.w3.org/2003/05/soap-envelope";
use constant URI_SOAP12_NOENC => "http://www.w3.org/2003/05/soap-envelope/encoding/none";
use constant URI_SOAP12_NEXT_ACTOR => "http://www.w3.org/2003/05/soap-envelope/role/next";
use vars qw($NSMASK $ELMASK);
$NSMASK = '[a-zA-Z_:][\w.\-:]*';
$ELMASK = '^(?![xX][mM][lL])[a-zA-Z_][\w.\-]*$';
use vars qw($NEXT_ACTOR $NS_ENV $NS_ENC $NS_APS
$FAULT_CLIENT $FAULT_SERVER $FAULT_VERSION_MISMATCH
$HTTP_ON_FAULT_CODE $HTTP_ON_SUCCESS_CODE $FAULT_MUST_UNDERSTAND
$NS_XSI_ALL $NS_XSI_NILS %XML_SCHEMAS $DEFAULT_XML_SCHEMA
$DEFAULT_HTTP_CONTENT_TYPE
$SOAP_VERSION %SOAP_VERSIONS $WRONG_VERSION
$NS_SL_HEADER $NS_SL_PERLTYPE $PREFIX_ENV $PREFIX_ENC
$DO_NOT_USE_XML_PARSER $DO_NOT_CHECK_MUSTUNDERSTAND
$DO_NOT_USE_CHARSET $DO_NOT_PROCESS_XML_IN_MIME
$DO_NOT_USE_LWP_LENGTH_HACK $DO_NOT_CHECK_CONTENT_TYPE
$MAX_CONTENT_SIZE $PATCH_HTTP_KEEPALIVE $DEFAULT_PACKAGER
@SUPPORTED_ENCODING_STYLES $OBJS_BY_REF_KEEPALIVE
$DEFAULT_CACHE_TTL
%XML_SCHEMA_OF
$HAS_ENCODE
);
$FAULT_CLIENT = 'Client';
$FAULT_SERVER = 'Server';
$FAULT_VERSION_MISMATCH = 'VersionMismatch';
$FAULT_MUST_UNDERSTAND = 'MustUnderstand';
$HTTP_ON_SUCCESS_CODE = 200; # OK
$HTTP_ON_FAULT_CODE = 500; # INTERNAL_SERVER_ERROR
@SUPPORTED_ENCODING_STYLES = ( URI_LITERAL_ENC,URI_SOAP11_ENC,URI_SOAP12_ENC,URI_SOAP12_NOENC );
$WRONG_VERSION = 'Wrong SOAP version specified.';
$SOAP_VERSION = '1.1';
%SOAP_VERSIONS = (
1.1 => {
NEXT_ACTOR => URI_SOAP11_NEXT_ACTOR,
NS_ENV => URI_SOAP11_ENV,
NS_ENC => URI_SOAP11_ENC,
DEFAULT_XML_SCHEMA => URI_2001_SCHEMA_XSD,
DEFAULT_HTTP_CONTENT_TYPE => 'text/xml',
},
1.2 => {
NEXT_ACTOR => URI_SOAP12_NEXT_ACTOR,
NS_ENV => URI_SOAP12_ENV,
NS_ENC => URI_SOAP12_ENC,
DEFAULT_XML_SCHEMA => URI_2001_SCHEMA_XSD,
DEFAULT_HTTP_CONTENT_TYPE => 'application/soap+xml',
},
);
# schema namespaces
%XML_SCHEMAS = ( # The '()' is necessary to put constants in SCALAR form
URI_1999_SCHEMA_XSD() => 'SOAP::XMLSchema1999',
URI_2001_SCHEMA_XSD() => 'SOAP::XMLSchema2001',
URI_SOAP11_ENC() => 'SOAP::XMLSchemaSOAP1_1',
URI_SOAP12_ENC() => 'SOAP::XMLSchemaSOAP1_2',
);
# schema namespaces
%XML_SCHEMA_OF = ( # The '()' is necessary to put constants in SCALAR form
URI_1999_SCHEMA_XSD() => 'XMLSchema1999',
URI_2001_SCHEMA_XSD() => 'XMLSchema2001',
URI_SOAP11_ENC() => 'XMLSchemaSOAP1_1',
URI_SOAP12_ENC() => 'XMLSchemaSOAP1_2',
);
$NS_XSI_ALL = join join('|', map {"$_-instance"} grep {/XMLSchema/} keys %XML_SCHEMAS), '(?:', ')';
$NS_XSI_NILS = join join('|', map { my $class = $XML_SCHEMAS{$_} . '::Serializer'; "\{($_)-instance\}" . $class->nilValue
} grep {/XMLSchema/} keys %XML_SCHEMAS),
'(?:', ')';
# ApacheSOAP namespaces
$NS_APS = 'http://xml.apache.org/xml-soap';
# SOAP::Lite namespace
$NS_SL_HEADER = 'http://namespaces.soaplite.com/header';
$NS_SL_PERLTYPE = 'http://namespaces.soaplite.com/perl';
# default prefixes
$PREFIX_ENV = 'soap';
$PREFIX_ENC = 'soapenc';
# others
$DO_NOT_USE_XML_PARSER = 0;
$DO_NOT_CHECK_MUSTUNDERSTAND = 0;
$DO_NOT_USE_CHARSET = 0;
$DO_NOT_PROCESS_XML_IN_MIME = 0;
$DO_NOT_USE_LWP_LENGTH_HACK = 0;
$DO_NOT_CHECK_CONTENT_TYPE = 0;
$PATCH_HTTP_KEEPALIVE = 1;
$OBJS_BY_REF_KEEPALIVE = 600; # seconds
# TODO - use default packager constant somewhere
$DEFAULT_PACKAGER = "SOAP::Packager::MIME";
$DEFAULT_CACHE_TTL = 0;
$HAS_ENCODE = eval "require Encode; 1";
1;
__END__
=pod
=head1 NAME
SOAP::Constants - SOAP::Lite provides several variables to allows programmers and users to modify the behavior of SOAP::Lite in specific ways.
=head1 DESCRIPTION
A number of "constant" values are provided by means of this namespace. The values aren't constants in the strictest sense; the purpose of the values detailed here is to allow the application to change them if it desires to alter the specific behavior governed.
=head1 CONSTANTS
=head2 $DO_NOT_USE_XML_PARSER
The SOAP::Lite package attempts to locate and use the L<XML::Parser> package, falling back on an internal, pure-Perl parser in its absence. This package is a fast parser, based on the Expat parser developed by James Clark. If the application sets this value to 1, there will be no attempt to locate or use XML::Parser. There are several reasons you might choose to do this. If the package will never be made available, there is no reason to perform the test. Setting this parameter is less time-consuming than the test for the package would be. Also, the XML::Parser code links against the Expat libraries for the C language. In some environments, this could cause a problem when mixed with other applications that may be linked against a different version of the same libraries. This was once the case with certain combinations of Apache, mod_perl and XML::Parser.
=head2 $DO_NOT_USE_CHARSET
Unless this parameter is set to 1, outgoing Content-Type headers will include specification of the character set used in encoding the message itself. Not all endpoints (client or server) may be able to properly deal with that data on the content header, however. If dealing with an endpoint that expects to do a more literal examination of the header as whole (as opposed to fully parsing it), this parameter may prove useful.
=head2 $DO_NOT_CHECK_CONTENT_TYPE
The content-type itself for a SOAP message is rather clearly defined, and in most cases, an application would have no reason to disable the testing of that header. This having been said, the content-type for SOAP 1.2 is still only a recommended draft, and badly coded endpoints might send valid messages with invalid Content-Type headers. While the "right" thing to do would be to reject such messages, that isn't always an option. Setting this parameter to 1 allows the toolkit to skip the content-type test.
=head2 $PATCH_HTTP_KEEPALIVE
SOAP::Lite's HTTP Transport module attempts to provide a simple patch to
LWP::Protocol to enable HTTP Keep Alive. By default, this patch is turned
off, if however you would like to turn on the experimental patch change the
constant like so:
$SOAP::Constants::PATCH_HTTP_KEEPALIVE = 1;
=head1 ACKNOWLEDGEMENTS
Special thanks to O'Reilly publishing which has graciously allowed SOAP::Lite to republish and redistribute large excerpts from I<Programming Web Services with Perl>, mainly the SOAP::Lite reference found in Appendix B.
=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
Paul Kulchenko (paulclinger@yahoo.com)
Randy J. Ray (rjray@blackperl.com)
Byrne Reese (byrne@majordojo.com)
=cut

5752
Perl OTRS/Kernel/cpan-lib/SOAP/Lite.pm Normal file
View File

File diff suppressed because it is too large Load Diff

46
Perl OTRS/Kernel/cpan-lib/SOAP/Lite/Deserializer/XMLSchema1999.pm Normal file
View File

@@ -0,0 +1,46 @@
package SOAP::Lite::Deserializer::XMLSchema1999;
use strict;
use SOAP::Lite::Deserializer::XMLSchemaSOAP1_1;
sub anyTypeValue { 'ur-type' }
# use as_string and as_boolean from SOAP1_1 Deserializer
sub as_string; *as_string = \&SOAP::Lite::Deserializer::XMLSchemaSOAP1_1::as_string;
sub as_boolean; *as_boolean = \&SOAP::Lite::Deserializer::XMLSchemaSOAP1_1::as_boolean;
sub as_hex {
shift;
my $value = shift;
$value =~ s/([a-zA-Z0-9]{2})/chr oct '0x'.$1/ge;
$value
}
sub as_ur_type { $_[1] }
sub as_undef {
shift;
my $value = shift;
$value eq '1' || $value eq 'true'
? 1
: $value eq '0' || $value eq 'false'
? 0
: die "Wrong null/nil value '$value'\n";
}
BEGIN {
no strict 'refs';
for my $method (qw(
float double decimal timeDuration recurringDuration uriReference
integer nonPositiveInteger negativeInteger long int short byte
nonNegativeInteger unsignedLong unsignedInt unsignedShort unsignedByte
positiveInteger timeInstant time timePeriod date month year century
recurringDate recurringDay language
)) {
my $name = 'as_' . $method;
*$name = sub { $_[1] };
}
}
1;

31
Perl OTRS/Kernel/cpan-lib/SOAP/Lite/Deserializer/XMLSchema2001.pm Normal file
View File

@@ -0,0 +1,31 @@
package SOAP::Lite::Deserializer::XMLSchema2001;
use strict;
use SOAP::Lite::Deserializer::XMLSchema1999;
use SOAP::Lite::Deserializer::XMLSchemaSOAP1_1;
use SOAP::Lite::Deserializer::XMLSchemaSOAP1_2;
sub anyTypeValue { 'anyType' }
sub as_string; *as_string = \&SOAP::Lite::Deserializer::XMLSchema1999::as_string;
sub as_anyURI; *as_anyURI = \&SOAP::Lite::Deserializer::XMLSchemaSOAP1_1::as_anyURI;
sub as_boolean; *as_boolean = \&SOAP::Lite::Deserializer::XMLSchemaSOAP1_2::as_boolean;
sub as_base64Binary; *as_base64Binary = \&SOAP::Lite::Deserializer::XMLSchemaSOAP1_2::as_base64;
sub as_hexBinary; *as_hexBinary = \&SOAP::Lite::Deserializer::XMLSchema1999::as_hex;
sub as_undef; *as_undef = \&SOAP::Lite::Deserializer::XMLSchema1999::as_undef;
BEGIN {
no strict 'refs';
for my $method (qw(
anyType anySimpleType
float double decimal dateTime timePeriod gMonth gYearMonth gYear
century gMonthDay gDay duration recurringDuration
language integer nonPositiveInteger negativeInteger long int short
byte nonNegativeInteger unsignedLong unsignedInt unsignedShort
unsignedByte positiveInteger date time QName
)) {
my $name = 'as_' . $method;
*$name = sub { $_[1] }
}
}
1;

33
Perl OTRS/Kernel/cpan-lib/SOAP/Lite/Deserializer/XMLSchemaSOAP1_1.pm Normal file
View File

@@ -0,0 +1,33 @@
package SOAP::Lite::Deserializer::XMLSchemaSOAP1_1;
use strict;
sub anyTypeValue { 'ur-type' }
sub as_boolean {
shift;
my $value = shift;
$value eq '1' || $value eq 'true'
? 1
: $value eq '0' || $value eq 'false'
? 0
: die "Wrong boolean value '$value'\n"
}
sub as_base64 { shift; require MIME::Base64; MIME::Base64::decode_base64(shift) }
sub as_ur_type { $_[1] }
sub as_anyURI { $_[1] }
BEGIN {
no strict 'refs';
for my $method (qw(
string float double decimal timeDuration recurringDuration uriReference
integer nonPositiveInteger negativeInteger long int short byte
nonNegativeInteger unsignedLong unsignedInt unsignedShort unsignedByte
positiveInteger timeInstant time timePeriod date month year century
recurringDate recurringDay language
)) { my $name = 'as_' . $method; *$name = sub { $_[1] } }
}
1;

25
Perl OTRS/Kernel/cpan-lib/SOAP/Lite/Deserializer/XMLSchemaSOAP1_2.pm Normal file
View File

@@ -0,0 +1,25 @@
package SOAP::Lite::Deserializer::XMLSchemaSOAP1_2;
use strict;
use SOAP::Lite::Deserializer::XMLSchemaSOAP1_1;
sub anyTypeValue { 'anyType' }
sub as_boolean; *as_boolean = \&SOAP::Lite::Deserializer::XMLSchemaSOAP1_1::as_boolean;
sub as_base64 { shift; require MIME::Base64; MIME::Base64::decode_base64(shift) }
BEGIN {
no strict 'refs';
for my $method (qw(
anyType
string float double decimal dateTime timePeriod gMonth gYearMonth gYear
century gMonthDay gDay duration recurringDuration anyURI
language integer nonPositiveInteger negativeInteger long int short byte
nonNegativeInteger unsignedLong unsignedInt unsignedShort unsignedByte
positiveInteger date time
)) {
my $name = 'as_' . $method;
*$name = sub { $_[1] };
}
}
1;

559
Perl OTRS/Kernel/cpan-lib/SOAP/Lite/Packager.pm Normal file
View File

@@ -0,0 +1,559 @@
# ======================================================================
#
# 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::Lite::Packager;
use strict;
use vars;
use vars qw($SUPPORTED_TYPES);
$SUPPORTED_TYPES = { };
sub BEGIN {
no strict 'refs';
for my $method ( qw(parser headers_http persist_parts) ) {
my $field = '_' . $method;
*$method = sub {
my $self = shift;
if (@_) {
$self->{$field} = shift;
return $self
}
return $self->{$field};
}
}
}
sub new {
my($class) = shift;
my(%params) = @_;
bless {
"_parts" => [ ],
"_parser" => undef,
"_persist_parts" => 0,
}, $class;
}
sub is_supported_part {
my $self = shift;
return $SUPPORTED_TYPES->{ref $_[0]};
}
sub parts {
my $self = shift;
if (@_) {
$self->{'_parts'} = shift;
}
return $self->{'_parts'};
}
# This is a static method that helps find the right Packager
sub find_packager {
# TODO - Input:
# * the mimetype of the data to be decoded raw data that needs
# * the data to be decoded
# Returns:
# * the proper SOAP::Lite::Packager instance
}
sub push_part {
my $self = shift;
my ($part) = @_;
push @{$self->{'_parts'}}, $part;
}
sub package {
# do nothing
die "SOAP::Lite::Packager::package() must be implemented";
}
sub unpackage {
my $self = shift;
$self->{'_parts'} = [] if !$self->persist_parts; # experimental
}
# ======================================================================
package SOAP::Lite::Packager::MIME;
use strict;
use vars qw(@ISA);
@ISA = qw(SOAP::Lite::Packager);
sub BEGIN {
no strict 'refs';
for my $method ( qw(transfer_encoding env_id env_location) ) {
my $field = '_' . $method;
*$method = sub {
my $self = shift;
if (@_) {
$self->{$field} = shift;
return $self
}
return $self->{$field};
}
}
}
sub new {
my ($classname) = @_;
my $self = SOAP::Lite::Packager::new(@_);
$self->{'_content_encoding'} = '8bit';
$self->{'_env_id'} = '<main_envelope>';
$self->{'_env_location'} = '/main_envelope';
bless $self, $classname;
$SOAP::Lite::Packager::SUPPORTED_TYPES->{"MIME::Entity"} = 1;
return $self;
}
sub initialize_parser {
my $self = shift;
eval "require MIME::Parser;";
die "Could not find MIME::Parser - is MIME::Tools installed? Aborting." if $@;
$self->{'_parser'} = MIME::Parser->new;
$self->{'_parser'}->output_to_core('ALL');
$self->{'_parser'}->tmp_to_core(1);
$self->{'_parser'}->ignore_errors(1);
$self->{'_parser'}->extract_nested_messages(0);
}
sub generate_random_string {
my ($self,$len) = @_;
my @chars=('a'..'z','A'..'Z','0'..'9','_');
my $random_string;
foreach (1..$len) {
$random_string .= $chars[rand @chars];
}
return $random_string;
}
sub get_multipart_id {
my ($id) = shift;
($id || '') =~ /^<?([^>]+)>?$/; $1 || '';
}
sub package {
my $self = shift;
my ($envelope,$context) = @_;
return $envelope if (!$self->parts); # if there are no parts,
# then there is nothing to do
require MIME::Entity;
local $MIME::Entity::BOUNDARY_DELIMITER = "\r\n";
my $top = MIME::Entity->build('Type' => "Multipart/Related");
my $soapversion = defined($context) ? $context->soapversion : '1.1';
$top->attach('Type' => $soapversion == 1.1 ? "text/xml" : "application/soap+xml",
'Content-Transfer-Encoding' => $self->transfer_encoding(),
'Content-Location' => $self->env_location(),
'Content-ID' => $self->env_id(),
'Data' => $envelope );
# consume the attachments that come in as input by 'shift'ing
no strict 'refs';
while (my $part = shift(@{$self->parts})) {
$top->add_part($part);
}
# determine MIME boundary
my $boundary = $top->head->multipart_boundary;
$self->headers_http({ 'Content-Type' => 'Multipart/Related; type="text/xml"; start="<main_envelope>"; boundary="'.$boundary.'"'});
return $top->stringify_body;
}
sub unpackage {
my $self = shift;
my ($raw_input,$context) = @_;
$self->SUPER::unpackage();
# Parse the raw input into a MIME::Entity structure.
# - fail if the raw_input is not MIME formatted
$self->initialize_parser() if !defined($self->parser);
my $entity = eval { $self->parser->parse_data($raw_input) }
or die "Something wrong with MIME message: @{[$@ || $self->parser->last_error]}\n";
my $env = undef;
# major memory bloat below! TODO - fix!
if (lc($entity->head->mime_type) eq 'multipart/form-data') {
$env = $self->process_form_data($entity);
}
elsif (lc($entity->head->mime_type) eq 'multipart/related') {
$env = $self->process_related($entity);
}
elsif (lc($entity->head->mime_type) eq 'text/xml') {
# I don't think this ever gets called.
# warn "I am somewhere in the SOAP::Lite::Packager::MIME code I didn't know I would be in!";
$env = $entity->bodyhandle->as_string;
}
else {
die "Can't handle MIME messsage with specified type (@{[$entity->head->mime_type]})\n";
}
# return the envelope
if ($env) {
return $env;
}
elsif ($entity->bodyhandle->as_string) {
return $entity->bodyhandle->as_string;
}
else {
die "No content in MIME message\n";
}
}
sub process_form_data {
my ($self, $entity) = @_;
my $env = undef;
foreach my $part ($entity->parts()) {
my $name = $part->head()->mime_attr('content-disposition.name');
$name eq 'payload' ?
$env = $part->bodyhandle()->as_string()
: $self->push_part($part);
}
return $env;
}
sub process_related {
my $self = shift;
my ($entity) = @_;
die "Multipart MIME messages MUST declare Multipart/Related content-type"
if ($entity->head->mime_attr('content-type') !~ /^multipart\/related/i);
# As it turns out, the Content-ID and start parameters are optional
# according to the MIME and SOAP specs. In the event that the head cannot
# be found, the head/root entity is used as a starting point.
my $start = get_multipart_id($entity->head->mime_attr('content-type.start'));
if (!defined($start) || $start eq "") {
$start = $self->generate_random_string(10);
$entity->parts(0)->head->add('content-id',$start);
}
my $location = $entity->head->mime_attr('content-location')
|| 'thismessage:/';
my $env;
foreach my $part ($entity->parts) {
next if !UNIVERSAL::isa($part => "MIME::Entity");
# Weird, the following use of head->get(SCALAR[,INDEX]) doesn't work as
# expected. Work around is to eliminate the INDEX.
my $pid = get_multipart_id($part->head->mime_attr('content-id'));
# If Content-ID is not supplied, then generate a random one (HACK - because
# MIME::Entity does not do this as it should... content-id is required
# according to MIME specification)
$pid = $self->generate_random_string(10) if $pid eq '';
my $type = $part->head->mime_type;
# If a Content-Location header cannot be found, this will look for an
# alternative in the following MIME Header attributes
my $plocation = $part->head->get('content-location')
|| $part->head->mime_attr('Content-Disposition.filename')
|| $part->head->mime_attr('Content-Type.name');
if ($start && $pid eq $start) {
$env = $part->bodyhandle->as_string;
}
else {
$self->push_part($part) if (defined($part->bodyhandle));
}
}
return $env;
}
# ======================================================================
package SOAP::Lite::Packager::DIME;
use strict;
use vars qw(@ISA);
@ISA = qw(SOAP::Lite::Packager);
sub BEGIN {
no strict 'refs';
for my $method ( qw(foo) ) {
my $field = '_' . $method;
*$method = sub {
my $self = shift;
if (@_) { $self->{$field} = shift; return $self }
return $self->{$field};
}
}
}
sub new {
my ($classname) = @_;
my $self = SOAP::Lite::Packager::new(@_);
bless $self, $classname;
$SOAP::Lite::Packager::SUPPORTED_TYPES->{"DIME::Payload"} = 1;
return $self;
}
sub initialize_parser {
my $self = shift;
print STDERR "Initializing parser\n";
eval "require DIME::Parser;";
die "Could not find DIME::Parser - is DIME::Tools installed? Aborting." if $@;
$self->{'_parser'} = DIME::Parser->new;
}
sub package {
my $self = shift;
my ($envelope,$context) = @_;
return $envelope if (!$self->parts); # if there are no parts,
# then there is nothing to do
require DIME::Message;
require DIME::Payload;
my $message = DIME::Message->new;
my $top = DIME::Payload->new;
my $soapversion = defined($context) ? $context->soapversion : '1.1';
$top->attach('MIMEType' => $soapversion == 1.1 ?
"http://schemas.xmlsoap.org/soap/envelope/" : "application/soap+xml",
'Data' => $envelope );
$message->add_payload($top);
# consume the attachments that come in as input by 'shift'ing
no strict 'refs';
while (my $part = shift(@{$self->parts})) {
die "You are only allowed to add parts of type DIME::Payload to a DIME::Message"
if (!$part->isa('DIME::Payload'));
# print STDERR "Adding payload to DIME message: ".ref($part)."\n";
$message->add_payload($part);
# print STDERR "Payload's payload is: ".${$part->print_content_data}."\n";
}
$self->headers_http({ 'Content-Type' => 'application/dime' });
return $message->print_data;
}
sub unpackage {
my $self = shift;
my ($raw_input,$context) = @_;
$self->SUPER::unpackage();
# Parse the raw input into a DIME::Message structure.
# - fail if the raw_input is not DIME formatted
print STDERR "raw_data: $raw_input\n";
$self->initialize_parser() if !defined($self->parser);
my $message = eval { $self->parser->parse_data(\$raw_input) }
or die "Something wrong with DIME message: @{[$@]}\n";
# The first payload is always the SOAP Message
# TODO - Error check
my @payloads = @{$message->{'_PAYLOADS'}};
my $env = shift(@payloads);
my $env_str = $env->print_content_data;
print STDERR "Received this envelope: ".$env_str."\n";
while (my $p = shift(@payloads)) {
print STDERR "Adding part to Packager\n";
$self->push_part($p);
}
return $env_str;
}
1;
__END__
=pod
=head1 NAME
SOAP::Lite::Packager - this class is an abstract class which allows for multiple types of packaging agents such as MIME and DIME.
=head1 DESCRIPTION
The SOAP::Lite::Packager class is responsible for managing a set of "parts." Parts are
additional pieces of information, additional documents, or virtually anything that
needs to be associated with the SOAP Envelope/payload. The packager then will take
these parts and encode/decode or "package"/"unpackage" them as they come and go
over the wire.
=head1 METHODS
=over
=item new
Instantiates a new instance of a SOAP::Lite::Packager.
=item parts
Contains an array of parts. The contents of this array and their types are completely
dependent upon the Packager being used. For example, when using MIME, the content
of this array is MIME::Entity's.
=item push_part
Adds a part to set of parts managed by the current instance of SOAP::Lite::Packager.
=item parser
Returns the parser used to parse attachments out of a data stream.
=item headers_http
This is a hook into the HTTP layer. It provides a way for a packager to add and/or modify
HTTP headers in a request/response. For example, most packaging layers will need to
override the Content-Type (e.g. multipart/related, or application/dime).
=back
=head1 ABSTRACT METHODS
If you wish to implement your own SOAP::Lite::Packager, then the methods below must be
implemented by you according to the prescribed input and output requirements.
=over
=item package()
The C<package> subroutine takes as input the SOAP envelope in string/SCALAR form.
This will serve as the content of the root part. The packager then encapsulates the
envelope with the parts contained within C<parts> and returns the properly
encapsulated envelope in string/SCALAR form.
=item unpackage()
The C<unpackage> subroutines takes as input raw data that needs to be parsed into
a set of parts. It is responsible for extracting the envelope from the input, and
populating C<parts> with an ARRAY of parts extracted from the input. It then returns
the SOAP Envelope in string/SCALAR form so that SOAP::Lite can parse it.
=back
=head1 SUPPORTED PACKAGING FORMATS
=head2 SOAP::Lite::Packager::MIME
C<SOAP::Lite::Packager::MIME> utilizes L<MIME::Tools> to provides the ability to send
and receive Multipart/Related and Multipart/Form-Data formatted requests and
responses.
=head3 MIME METHODS
The following methods are used when composing a MIME formatted message.
=over
=item transfer_encoding
The value of the root part's Content-Transfer-Encoding MIME Header. Default is: 8bit.
=item env_id
The value of the root part's Content-Id MIME Header. Default is: <main_envelope>.
=item env_location
The value of the root part's Content-Location MIME Header. Default is: /main_envelope.
=item env_type
The value of the root part's Content-Type MIME Header. Default is: text/xml.
=back
=head3 OPTIMIZING THE MIME PARSER
The use of attachments can often result in a heavy drain on system resources depending
upon how your MIME parser is configured. For example, you can instruct the parser to
store attachments in memory, or to use temp files. Using one of the other can affect
performance, disk utilization, and/or reliability. Therefore you should consult the
following URL for optimization techniques and trade-offs:
http://search.cpan.org/dist/MIME-tools/lib/MIME/Parser.pm#OPTIMIZING_YOUR_PARSER
To modify the parser's configuration options consult the following code sample,
which incidentally shows how to minimize memory utilization:
my $packager = SOAP::Lite::Packager::MIME->new;
# $packager->parser->decode_headers(1); # no difference
# $packager->parser->extract_nested_messages(1); # no difference
$packager->parser->output_to_core(0); # much less memory
$packager->parser->tmp_to_core(0); # much less memory
$packager->parser->tmp_recycling(0); # promotes faster garbage collection
$packager->parser->use_inner_files(1); # no difference
my $client = SOAP::Lite->uri($NS)->proxy($URL)->packager($packager);
$client->someMethod();
=head3 CLIENT SIDE EXAMPLE
The following code sample shows how to use attachments within the context of a
SOAP::Lite client.
#!/usr/bin/perl
use SOAP::Lite;
use MIME::Entity;
my $ent = build MIME::Entity
Type => "text/plain",
Path => "attachment.txt",
Filename => "attachment.txt",
Disposition => "attachment";
$NS = "urn:Majordojo:TemperatureService";
$HOST = "http://localhost/cgi-bin/soaplite.cgi";
my $client = SOAP::Lite
->packager(SOAP::Lite::Packager::MIME->new)
->parts([ $ent ])
->uri($NS)
->proxy($HOST);
$response = $client->c2f(SOAP::Data->name("temperature" => '100'));
print $response->valueof('//c2fResponse/foo');
=head3 SERVER SIDE EXAMPLE
The following code shows how to use attachments within the context of a CGI
script. It shows how to read incoming attachments, and to return attachments to
the client.
#!/usr/bin/perl -w
use SOAP::Transport::HTTP;
use MIME::Entity;
SOAP::Transport::HTTP::CGI
->packager(SOAP::Lite::Packager::MIME->new)
->dispatch_with({'urn:Majordojo:TemperatureService' => 'TemperatureService'})
->handle;
BEGIN {
package TemperatureService;
use vars qw(@ISA);
@ISA = qw(Exporter SOAP::Server::Parameters);
use SOAP::Lite;
sub c2f {
my $self = shift;
my $envelope = pop;
my $temp = $envelope->dataof("//c2f/temperature");
use MIME::Entity;
my $ent = build MIME::Entity
Type => "text/plain",
Path => "printenv",
Filename => "printenv",
Disposition => "attachment";
# read attachments
foreach my $part (@{$envelope->parts}) {
print STDERR "soaplite.cgi: attachment found! (".ref($part).")\n";
print STDERR "soaplite.cgi: contents => ".$part->stringify."\n";
}
# send attachments
return SOAP::Data->name('convertedTemp' => (((9/5)*($temp->value)) + 32)),
$ent;
}
}
=head2 SOAP::Lite::Packager::DIME
TODO
=head1 SEE ALSO
L<MIME::Tools>, L<DIME::Tools>
=head1 COPYRIGHT
Copyright (C) 2000-2007 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
Byrne Reese
Martin Kutter E<lt>martin.kutter fen-net.deE<gt>
=cut

29
Perl OTRS/Kernel/cpan-lib/SOAP/Lite/Utils.pm Normal file
View File

@@ -0,0 +1,29 @@
package SOAP::Lite::Utils;
use strict;
sub import {
my $caller = caller();
no strict qw(refs);
*{ "$caller\::__mk_accessors" } = \&__mk_accessors;
}
sub __mk_accessors {
my ($class, @method_from) = @_;
no strict 'refs';
for my $method ( @method_from ) {
my $field = '_' . $method;
*{ "$class\::$method" } = sub {
my $self = ref $_[0] ? shift : shift->new();
if (@_) {
$self->{$field} = shift;
return $self
}
return $self->{$field};
}
}
}
1;
__END__

553
Perl OTRS/Kernel/cpan-lib/SOAP/Packager.pm Normal file
View File

@@ -0,0 +1,553 @@
# ======================================================================
#
# 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::Packager;
use strict;
use vars;
our $VERSION = 1.17;
our $SUPPORTED_TYPES = { };
sub BEGIN {
no strict 'refs';
for my $method ( qw(parser headers_http persist_parts) ) {
my $field = '_' . $method;
*$method = sub {
my $self = shift;
if (@_) { $self->{$field} = shift; return $self }
return $self->{$field};
}
}
}
sub new {
my($class) = shift;
my(%params) = @_;
bless {
"_parts" => [ ],
"_parser" => undef,
"_persist_parts" => 0,
}, $class;
}
sub is_supported_part {
my $self = shift;
return $SUPPORTED_TYPES->{ref $_[0]};
}
sub parts {
my $self = shift;
if (@_) {
$self->{'_parts'} = shift;
}
return $self->{'_parts'};
}
# This is a static method that helps find the right Packager
sub find_packager {
# TODO - Input:
# * the mimetype of the data to be decoded raw data that needs
# * the data to be decoded
# Returns:
# * the proper SOAP::Packager instance
}
sub push_part {
my $self = shift;
my ($part) = @_;
push @{$self->{'_parts'}}, $part;
}
sub package {
# do nothing
die "SOAP::Packager::package() must be implemented";
}
sub unpackage {
my $self = shift;
$self->{'_parts'} = [] if !$self->persist_parts; # experimental
}
# ======================================================================
package SOAP::Packager::MIME;
use strict;
use vars qw(@ISA);
@ISA = qw(SOAP::Packager);
sub BEGIN {
no strict 'refs';
for my $method ( qw(transfer_encoding env_id env_location) ) {
my $field = '_' . $method;
*$method = sub {
my $self = shift;
if (@_) { $self->{$field} = shift; return $self }
return $self->{$field};
}
}
}
sub new {
my ($classname) = @_;
my $self = SOAP::Packager::new(@_);
$self->{'_content_encoding'} = '8bit';
$self->{'_env_id'} = '<main_envelope>';
$self->{'_env_location'} = '/main_envelope';
bless $self, $classname;
$SOAP::Packager::SUPPORTED_TYPES->{"MIME::Entity"} = 1;
return $self;
}
sub initialize_parser {
my $self = shift;
eval "require MIME::Parser;";
die "Could not find MIME::Parser - is MIME::Tools installed? Aborting." if $@;
$self->{'_parser'} = MIME::Parser->new;
$self->{'_parser'}->output_to_core('ALL');
$self->{'_parser'}->tmp_to_core(1);
$self->{'_parser'}->ignore_errors(1);
$self->{'_parser'}->extract_nested_messages(0);
}
sub generate_random_string {
my ($self,$len) = @_;
my @chars=('a'..'z','A'..'Z','0'..'9','_');
my $random_string;
foreach (1..$len) {
$random_string .= $chars[rand @chars];
}
return $random_string;
}
sub get_multipart_id {
my ($id) = shift;
($id || '') =~ /^<?([^>]+)>?$/; $1 || '';
}
sub package {
my $self = shift;
my ($envelope,$context) = @_;
return $envelope if (!$self->parts); # if there are no parts,
# then there is nothing to do
require MIME::Entity;
local $MIME::Entity::BOUNDARY_DELIMITER = "\r\n";
my $top = MIME::Entity->build('Type' => "Multipart/Related");
my $soapversion = defined($context) ? $context->soapversion : '1.1';
$top->attach('Type' => $soapversion == 1.1 ? "text/xml" : "application/soap+xml",
'Content-Transfer-Encoding' => $self->transfer_encoding(),
'Content-Location' => $self->env_location(),
'Content-ID' => $self->env_id(),
'Data' => $envelope );
# consume the attachments that come in as input by 'shift'ing
no strict 'refs';
while (my $part = shift(@{$self->parts})) {
$top->add_part($part);
}
# determine MIME boundary
my $boundary = $top->head->multipart_boundary;
$self->headers_http({ 'Content-Type' => 'Multipart/Related; type="text/xml"; start="<main_envelope>"; boundary="'.$boundary.'"'});
return $top->stringify_body;
}
sub unpackage {
my $self = shift;
my ($raw_input,$context) = @_;
$self->SUPER::unpackage();
# Parse the raw input into a MIME::Entity structure.
# - fail if the raw_input is not MIME formatted
$self->initialize_parser() if !defined($self->parser);
my $entity = eval { $self->parser->parse_data($raw_input) }
or die "Something wrong with MIME message: @{[$@ || $self->parser->last_error]}\n";
my $env = undef;
# major memory bloat below! TODO - fix!
if (lc($entity->head->mime_type) eq 'multipart/form-data') {
$env = $self->process_form_data($entity);
} elsif (lc($entity->head->mime_type) eq 'multipart/related') {
$env = $self->process_related($entity);
} elsif (lc($entity->head->mime_type) eq 'text/xml') {
# I don't think this ever gets called.
# warn "I am somewhere in the SOAP::Packager::MIME code I didn't know I would be in!";
$env = $entity->bodyhandle->as_string;
} else {
die "Can't handle MIME messsage with specified type (@{[$entity->head->mime_type]})\n";
}
# return the envelope
if ($env) {
return $env;
} elsif ($entity->bodyhandle->as_string) {
return $entity->bodyhandle->as_string;
} else {
die "No content in MIME message\n";
}
}
sub process_form_data {
my ($self, $entity) = @_;
my $env = undef;
foreach my $part ($entity->parts) {
my $name = $part->head->mime_attr('content-disposition.name');
$name eq 'payload' ?
$env = $part->bodyhandle->as_string
: $self->push_part($part);
}
return $env;
}
sub process_related {
my $self = shift;
my ($entity) = @_;
die "Multipart MIME messages MUST declare Multipart/Related content-type"
if ($entity->head->mime_attr('content-type') !~ /^multipart\/related/i);
# As it turns out, the Content-ID and start parameters are optional
# according to the MIME and SOAP specs. In the event that the head cannot
# be found, the head/root entity is used as a starting point.
# [19 Mar 2008] Modified by Feng Li <feng.li@sybase.com>
# Check optional start parameter, then optional Content-ID, then create/add
# Content-ID (the same approach as in SOAP::Lite 0.66)
#my $start = get_multipart_id($entity->head->mime_attr('content-type.start'));
my $start = get_multipart_id($entity->head->mime_attr('content-type.start'))
|| get_multipart_id($entity->parts(0)->head->mime_attr('content-id'));
if (!defined($start) || $start eq "") {
$start = $self->generate_random_string(10);
$entity->parts(0)->head->add('content-id',$start);
}
my $location = $entity->head->mime_attr('content-location') ||
'thismessage:/';
my $env;
foreach my $part ($entity->parts) {
next if !UNIVERSAL::isa($part => "MIME::Entity");
# Weird, the following use of head->get(SCALAR[,INDEX]) doesn't work as
# expected. Work around is to eliminate the INDEX.
my $pid = get_multipart_id($part->head->mime_attr('content-id'));
# If Content-ID is not supplied, then generate a random one (HACK - because
# MIME::Entity does not do this as it should... content-id is required
# according to MIME specification)
$pid = $self->generate_random_string(10) if $pid eq '';
my $type = $part->head->mime_type;
# If a Content-Location header cannot be found, this will look for an
# alternative in the following MIME Header attributes
my $plocation = $part->head->get('content-location') ||
$part->head->mime_attr('Content-Disposition.filename') ||
$part->head->mime_attr('Content-Type.name');
if ($start && $pid eq $start) {
$env = $part->bodyhandle->as_string;
} else {
$self->push_part($part);
}
}
# die "Can't find 'start' parameter in multipart MIME message\n"
# if @{$self->parts} > 1 && !$start;
return $env;
}
# ======================================================================
package SOAP::Packager::DIME;
use strict;
use vars qw(@ISA);
@ISA = qw(SOAP::Packager);
sub BEGIN {
no strict 'refs';
for my $method ( qw(foo) ) {
my $field = '_' . $method;
*$method = sub {
my $self = shift;
if (@_) { $self->{$field} = shift; return $self }
return $self->{$field};
}
}
}
sub new {
my ($classname) = @_;
my $self = SOAP::Packager::new(@_);
bless $self, $classname;
$SOAP::Packager::SUPPORTED_TYPES->{"DIME::Payload"} = 1;
return $self;
}
sub initialize_parser {
my $self = shift;
print STDERR "Initializing parser\n";
eval "require DIME::Parser;";
die "Could not find DIME::Parser - is DIME::Tools installed? Aborting." if $@;
$self->{'_parser'} = DIME::Parser->new;
}
sub package {
my $self = shift;
my ($envelope,$context) = @_;
return $envelope if (!$self->parts); # if there are no parts,
# then there is nothing to do
require DIME::Message;
require DIME::Payload;
my $message = DIME::Message->new;
my $top = DIME::Payload->new;
my $soapversion = defined($context) ? $context->soapversion : '1.1';
$top->attach('MIMEType' => $soapversion == 1.1 ?
"http://schemas.xmlsoap.org/soap/envelope/" : "application/soap+xml",
'Data' => \$envelope );
$message->add_payload($top);
# consume the attachments that come in as input by 'shift'ing
no strict 'refs';
while (my $part = shift(@{$self->parts})) {
die "You are only allowed to add parts of type DIME::Payload to a DIME::Message"
if (!$part->isa('DIME::Payload'));
# print STDERR "Adding payload to DIME message: ".ref($part)."\n";
$message->add_payload($part);
# print STDERR "Payload's payload is: ".${$part->print_content_data}."\n";
}
$self->headers_http({ 'Content-Type' => 'application/dime' });
return $message->print_data;
}
sub unpackage {
my $self = shift;
my ($raw_input,$context) = @_;
$self->SUPER::unpackage();
# Parse the raw input into a DIME::Message structure.
# - fail if the raw_input is not DIME formatted
print STDERR "raw_data: $raw_input\n";
$self->initialize_parser() if !defined($self->parser);
my $message = eval { $self->parser->parse_data(\$raw_input) }
or die "Something wrong with DIME message: @{[$@]}\n";
# The first payload is always the SOAP Message
# TODO - Error check
my @payloads = @{$message->{'_PAYLOADS'}};
my $env = shift(@payloads);
my $env_str = $env->print_content_data;
print STDERR "Received this envelope: ".$env_str."\n";
while (my $p = shift(@payloads)) {
print STDERR "Adding part to Packager\n";
$self->push_part($p);
}
return $env_str;
}
1;
__END__
=pod
=head1 NAME
SOAP::Packager - this class is an abstract class which allows for multiple types of packaging agents such as MIME and DIME.
=head1 DESCRIPTION
The SOAP::Packager class is responsible for managing a set of "parts." Parts are
additional pieces of information, additional documents, or virtually anything that
needs to be associated with the SOAP Envelope/payload. The packager then will take
these parts and encode/decode or "package"/"unpackage" them as they come and go
over the wire.
=head1 METHODS
=over
=item new
Instantiates a new instance of a SOAP::Packager.
=item parts
Contains an array of parts. The contents of this array and their types are completely
dependent upon the Packager being used. For example, when using MIME, the content
of this array is MIME::Entity's.
=item push_part
Adds a part to set of parts managed by the current instance of SOAP::Packager.
=item parser
Returns the parser used to parse attachments out of a data stream.
=item headers_http
This is a hook into the HTTP layer. It provides a way for a packager to add and/or modify
HTTP headers in a request/response. For example, most packaging layers will need to
override the Content-Type (e.g. multipart/related, or application/dime).
=back
=head1 ABSTRACT METHODS
If you wish to implement your own SOAP::Packager, then the methods below must be
implemented by you according to the prescribed input and output requirements.
=over
=item package()
The C<package> subroutine takes as input the SOAP envelope in string/SCALAR form.
This will serve as the content of the root part. The packager then encapsulates the
envelope with the parts contained within C<parts> and returns the properly
encapsulated envelope in string/SCALAR form.
=item unpackage()
The C<unpackage> subroutines takes as input raw data that needs to be parsed into
a set of parts. It is responsible for extracting the envelope from the input, and
populating C<parts> with an ARRAY of parts extracted from the input. It then returns
the SOAP Envelope in string/SCALAR form so that SOAP::Lite can parse it.
=back
=head1 SUPPORTED PACKAGING FORMATS
=head2 SOAP::Packager::MIME
C<SOAP::Packager::MIME> utilizes L<MIME::Tools> to provides the ability to send
and receive Multipart/Related and Multipart/Form-Data formatted requests and
responses.
=head3 MIME METHODS
The following methods are used when composing a MIME formatted message.
=over
=item transfer_encoding
The value of the root part's Content-Transfer-Encoding MIME Header. Default is: 8bit.
=item env_id
The value of the root part's Content-Id MIME Header. Default is: <main_envelope>.
=item env_location
The value of the root part's Content-Location MIME Header. Default is: /main_envelope.
=item env_type
The value of the root part's Content-Type MIME Header. Default is: text/xml.
=back
=head3 OPTIMIZING THE MIME PARSER
The use of attachments can often result in a heavy drain on system resources depending
upon how your MIME parser is configured. For example, you can instruct the parser to
store attachments in memory, or to use temp files. Using one of the other can affect
performance, disk utilization, and/or reliability. Therefore you should consult the
following URL for optimization techniques and trade-offs:
http://search.cpan.org/dist/MIME-tools/lib/MIME/Parser.pm#OPTIMIZING_YOUR_PARSER
To modify the parser's configuration options consult the following code sample,
which incidentally shows how to minimize memory utilization:
my $packager = SOAP::Packager::MIME->new;
# $packager->parser->decode_headers(1); # no difference
# $packager->parser->extract_nested_messages(1); # no difference
$packager->parser->output_to_core(0); # much less memory
$packager->parser->tmp_to_core(0); # much less memory
$packager->parser->tmp_recycling(0); # promotes faster garbage collection
$packager->parser->use_inner_files(1); # no difference
my $client = SOAP::Lite->uri($NS)->proxy($URL)->packager($packager);
$client->someMethod();
=head3 CLIENT SIDE EXAMPLE
The following code sample shows how to use attachments within the context of a
SOAP::Lite client.
#!/usr/bin/perl
use SOAP::Lite;
use MIME::Entity;
my $ent = build MIME::Entity
Type => "text/plain",
Path => "attachment.txt",
Filename => "attachment.txt",
Disposition => "attachment";
$NS = "urn:Majordojo:TemperatureService";
$HOST = "http://localhost/cgi-bin/soaplite.cgi";
my $client = SOAP::Lite
->packager(SOAP::Packager::MIME->new)
->parts([ $ent ])
->uri($NS)
->proxy($HOST);
$response = $client->c2f(SOAP::Data->name("temperature" => '100'));
print $response->valueof('//c2fResponse/foo');
=head3 SERVER SIDE EXAMPLE
The following code shows how to use attachments within the context of a CGI
script. It shows how to read incoming attachments, and to return attachments to
the client.
#!/usr/bin/perl -w
use SOAP::Transport::HTTP;
use MIME::Entity;
SOAP::Transport::HTTP::CGI
->packager(SOAP::Packager::MIME->new)
->dispatch_with({'urn:Majordojo:TemperatureService' => 'TemperatureService'})
->handle;
BEGIN {
package TemperatureService;
use vars qw(@ISA);
@ISA = qw(Exporter SOAP::Server::Parameters);
use SOAP::Lite;
sub c2f {
my $self = shift;
my $envelope = pop;
my $temp = $envelope->dataof("//c2f/temperature");
use MIME::Entity;
my $ent = build MIME::Entity
Type => "text/plain",
Path => "printenv",
Filename => "printenv",
Disposition => "attachment";
# read attachments
foreach my $part (@{$envelope->parts}) {
print STDERR "soaplite.cgi: attachment found! (".ref($part).")\n";
print STDERR "soaplite.cgi: contents => ".$part->stringify."\n";
}
# send attachments
return SOAP::Data->name('convertedTemp' => (((9/5)*($temp->value)) + 32)),
$ent;
}
}
=head2 SOAP::Packager::DIME
TODO
=head1 SEE ALSO
L<MIME::Tools>, L<DIME::Tools>
=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
Byrne Reese (byrne@majordojo.com)
=cut

944
Perl OTRS/Kernel/cpan-lib/SOAP/Transport/HTTP.pm Normal file
View File

@@ -0,0 +1,944 @@
# ======================================================================
#
# 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;