File Coverage

blib/lib/SOAP/Lite.pm

Criterion	Covered	Total	%
statement	961	1855	51.8
branch	341	1052	32.4
condition	122	569	21.4
subroutine	228	334	68.2
pod	6	9	66.6
total	1658	3819	43.4

# ======================================================================
#
# Copyright (C) 2000-2005 Paul Kulchenko ([e-mail])
# SOAP::Lite is free software; you can redistribute it
# and/or modify it under the same terms as Perl itself.
#
# ======================================================================

# Formatting hint:
# Target is the source code format laid out in Perl Best Practices (4 spaces
# indent, opening brace on condition line, no cuddled else).
#
# October 2007, Martin Kutter

package SOAP::Lite;

use strict;
use warnings;

our $VERSION = '1.11';

package SOAP::XMLSchemaApacheSOAP::Deserializer;

sub as_map {
    my $self = shift;
    return {
        map {
            my $hash = ($self->decode_object($_))[1];
            ($hash->{key} => $hash->{value})
        } @{$_[3] || []}
    };
}
sub as_Map; *as_Map = \&as_map;

# Thank to Kenneth Draper for this contribution
sub as_vector {
    my $self = shift;
    return [ map { scalar(($self->decode_object($_))[1]) } @{$_[3] || []} ];
}
sub as_Vector; *as_Vector = \&as_vector;

# ----------------------------------------------------------------------

package SOAP::XMLSchema::Serializer;

use vars qw(@ISA);

sub xmlschemaclass {
    my $self = shift;
    return $ISA[0] unless @_;
    @ISA = (shift);
    return $self;
}

# ----------------------------------------------------------------------

package SOAP::XMLSchema1999::Serializer;

use vars qw(@EXPORT $AUTOLOAD);

sub AUTOLOAD {
    local($1,$2);
    my($package, $method) = $AUTOLOAD =~ m/(?:(.+)::)([^:]+)$/;
    return if $method eq 'DESTROY';
    no strict 'refs';

    my $export_var = $package . '::EXPORT';
    my @export = @$export_var;

# Removed in 0.69 - this is a total hack. For some reason this is failing
# despite not being a fatal error condition.
#  die "Type '$method' can't be found in a schema class '$package'\n"
#    unless $method =~ s/^as_// && grep {$_ eq $method} @{$export_var};

# This was added in its place - it is still a hack, but it performs the
# necessary substitution. It just does not die.
    if ($method =~ s/^as_// && grep {$_ eq $method} @{$export_var}) {
#      print STDERR "method is now '$method'\n";
    } else {
        return;
    }

    $method =~ s/_/-/; # fix ur-type

    *$AUTOLOAD = sub {
        my $self = shift;
        my($value, $name, $type, $attr) = @_;
        return [$name, {'xsi:type' => "xsd:$method", %$attr}, $value];
    };
    goto &$AUTOLOAD;
}

BEGIN {
    @EXPORT = qw(ur_type
        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
        base64 hex string boolean
    );
    # TODO: replace by symbol table operations...
    # predeclare subs, so ->can check will be positive
    foreach (@EXPORT) { eval "sub as_$_" }
}

sub nilValue { 'null' }

sub anyTypeValue { 'ur-type' }

sub as_base64 {
    my ($self, $value, $name, $type, $attr) = @_;

    # Fixes #30271 for 5.8 and above.
    # Won't fix for 5.6 and below - perl can't handle unicode before
    # 5.8, and applying pack() to everything is just a slowdown.
    if ($SOAP::Constants::HAS_ENCODE) {
        if (Encode::is_utf8($value)) {
            if (Encode->can('_utf8_off')) { # the quick way, but it may change in future Perl versions.
                Encode::_utf8_off($value);
            }
            else {
                $value = pack('C*',unpack('C*',$value)); # the slow but safe way,
                # but this fallback works always.
            }
        }
    }

    require MIME::Base64;
    return [
        $name,
        {
            'xsi:type' => SOAP::Utils::qualify($self->encprefix => 'base64'),
            %$attr
        },
        MIME::Base64::encode_base64($value,'')
    ];
}

sub as_hex {
    my ($self, $value, $name, $type, $attr) = @_;
    return [
        $name,
        {
            'xsi:type' => 'xsd:hex', %$attr
        },
        join '', map {
            uc sprintf "%02x", ord
        } split '', $value
    ];
}

sub as_long {
    my($self, $value, $name, $type, $attr) = @_;
    return [
        $name,
        {'xsi:type' => 'xsd:long', %$attr},
        $value
    ];
}

sub as_dateTime {
    my ($self, $value, $name, $type, $attr) = @_;
    return [$name, {'xsi:type' => 'xsd:dateTime', %$attr}, $value];
}

sub as_string {
    my ($self, $value, $name, $type, $attr) = @_;
    die "String value expected instead of @{[ref $value]} reference\n"
        if ref $value;
    return [
        $name,
        {'xsi:type' => 'xsd:string', %$attr},
        SOAP::Utils::encode_data($value)
    ];
}

sub as_anyURI {
    my($self, $value, $name, $type, $attr) = @_;
    die "String value expected instead of @{[ref $value]} reference\n" if ref $value;
    return [
        $name,
        {'xsi:type' => 'xsd:anyURI', %$attr},
        SOAP::Utils::encode_data($value)
    ];
}

sub as_undef { $_[1] ? '1' : '0' }

sub as_boolean {
    my $self = shift;
    my($value, $name, $type, $attr) = @_;
    # fix [ 1.05279 ] Boolean serialization error
    return [
        $name,
        {'xsi:type' => 'xsd:boolean', %$attr},
        ( $value && $value ne 'false' ) ? 'true' : 'false'
    ];
}

sub as_float {
    my($self, $value, $name, $type, $attr) = @_;
    return [
        $name,
        {'xsi:type' => 'xsd:float', %$attr},
        $value
    ];
}

# ----------------------------------------------------------------------

package SOAP::XMLSchema2001::Serializer;

use vars qw(@EXPORT);

# no more warnings about "used only once"
*AUTOLOAD if 0;

*AUTOLOAD = \&SOAP::XMLSchema1999::Serializer::AUTOLOAD;

BEGIN {
  @EXPORT = qw(anyType anySimpleType 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 string hex base64 boolean
               QName
  );
  # Add QName to @EXPORT
  # predeclare subs, so ->can check will be positive
  foreach (@EXPORT) { eval "sub as_$_" }
}

sub nilValue { 'nil' }

sub anyTypeValue { 'anyType' }

sub as_long;        *as_long = \&SOAP::XMLSchema1999::Serializer::as_long;
sub as_float;       *as_float = \&SOAP::XMLSchema1999::Serializer::as_float;
sub as_string;      *as_string = \&SOAP::XMLSchema1999::Serializer::as_string;
sub as_anyURI;      *as_anyURI = \&SOAP::XMLSchema1999::Serializer::as_anyURI;

# TODO - QNames still don't work for 2001 schema!
sub as_QName;       *as_QName = \&SOAP::XMLSchema1999::Serializer::as_string;
sub as_hex;         *as_hex = \&as_hexBinary;
sub as_base64;      *as_base64 = \&as_base64Binary;
sub as_timeInstant; *as_timeInstant = \&as_dateTime;

# only 0 and 1 allowed - that's easy...
sub as_undef {
    $_[1]
    ? 'true'
    : 'false'
}

sub as_hexBinary {
    my ($self, $value, $name, $type, $attr) = @_;
    return [
        $name,
        {'xsi:type' => 'xsd:hexBinary', %$attr},
        join '', map {
                uc sprintf "%02x", ord
            } split '', $value
    ];
}

sub as_base64Binary {
    my ($self, $value, $name, $type, $attr) = @_;

    # Fixes #30271 for 5.8 and above.
    # Won't fix for 5.6 and below - perl can't handle unicode before
    # 5.8, and applying pack() to everything is just a slowdown.
    if (eval "require Encode; 1") {
        if (Encode::is_utf8($value)) {
            if (Encode->can('_utf8_off')) { # the quick way, but it may change in future Perl versions.
                Encode::_utf8_off($value);
            }
            else {
                $value = pack('C*',unpack('C*',$value)); # the slow but safe way,
                # but this fallback works always.
            }
        }
    }

    require MIME::Base64;
    return [
        $name,
        {
            'xsi:type' => 'xsd:base64Binary', %$attr
        },
        MIME::Base64::encode_base64($value,'')
    ];
}

sub as_boolean {
    my ($self, $value, $name, $type, $attr) = @_;
    # fix [ 1.05279 ] Boolean serialization error
    return [
        $name,
        {
            'xsi:type' => 'xsd:boolean', %$attr
        },
        ( $value && ($value ne 'false') )
            ? 'true'
            : 'false'
    ];
}


# ======================================================================

package SOAP::Utils;

sub qualify {
    $_[1]
        ? $_[1] =~ /:/
            ? $_[1]
            : join(':', $_[0] || (), $_[1])
        : defined $_[1]
            ? $_[0]
            : ''
    }

sub overqualify (&$) {
    for ($_[1]) {
        &{$_[0]};
        s/^:|:$//g
    }
}

sub disqualify {
    (my $qname = shift) =~ s/^($SOAP::Constants::NSMASK?)://;
    return $qname;
}

sub splitqname {
    local($1,$2);
    $_[0] =~ /^(?:([^:]+):)?(.+)$/;
    return ($1,$2)
}

sub longname {
    defined $_[0]
        ? sprintf('{%s}%s', $_[0], $_[1])
        : $_[1]
}

sub splitlongname {
    local($1,$2);
    $_[0] =~ /^(?:\{(.*)\})?(.+)$/;
    return ($1,$2)
}

# Q: why only '&' and '<' are encoded, but not '>'?
# A: because it is not required according to XML spec.
#
# [http://www.w3.org/TR/REC-xml#syntax]
# The ampersand character (&) and the left angle bracket (<) may appear in
# their literal form only when used as markup delimiters, or within a comment,
# a processing instruction, or a CDATA section. If they are needed elsewhere,
# they must be escaped using either numeric character references or the
# strings "&" and "<" respectively. The right angle bracket (>) may be
# represented using the string ">", and must, for compatibility, be
# escaped using ">" or a character reference when it appears in the
# string "]]>" in content, when that string is not marking the end of a
# CDATA section.

my %encode_attribute = ('&' => '&', '>' => '>', '<' => '<', '"' => '"');
sub encode_attribute { (my $e = $_[0]) =~ s/([&<>\"])/$encode_attribute{$1}/g; $e }

my %encode_data = ('&' => '&', '>' => '>', '<' => '<', "\xd" => '
');
sub encode_data {
    my $e = $_[0];
    if ($e) {
        $e =~ s/([&<>\015])/$encode_data{$1}/g;
        $e =~ s/\]\]>/\]\]>/g;
    }
    $e
}

# methods for internal tree (SOAP::Deserializer, SOAP::SOM and SOAP::Serializer)

sub o_qname { $_[0]->[0] }
sub o_attr  { $_[0]->[1] }
sub o_child { ref $_[0]->[2] ? $_[0]->[2] : undef }
sub o_chars { ref $_[0]->[2] ? undef : $_[0]->[2] }
            # $_[0]->[3] is not used. Serializer stores object ID there
sub o_value { $_[0]->[4] }
sub o_lname { $_[0]->[5] }
sub o_lattr { $_[0]->[6] }

sub format_datetime {
    my ($s,$m,$h,$D,$M,$Y) = (@_)[0,1,2,3,4,5];
    my $time = sprintf("%04d-%02d-%02dT%02d:%02d:%02d",($Y+1900),($M+1),$D,$h,$m,$s);
    return $time;
}

# make bytelength that calculates length in bytes regardless of utf/byte settings
# either we can do 'use bytes' or length will count bytes already
BEGIN {
    sub bytelength;
    *bytelength = eval('use bytes; 1') # 5.6.0 and later?
        ? sub { use bytes; length(@_ ? $_[0] : $_) }
        : sub { length(@_ ? $_[0] : $_) };
}

# ======================================================================

package SOAP::Cloneable;

sub clone {
    my $self = shift;

    return unless ref $self && UNIVERSAL::isa($self => __PACKAGE__);

    my $clone = bless {} => ref($self) || $self;
    for (keys %$self) {
        my $value = $self->{$_};
        $clone->{$_} = ref $value && UNIVERSAL::isa($value => __PACKAGE__) ? $value->clone : $value;
    }
    return $clone;
}

# ======================================================================

package SOAP::Transport;

use vars qw($AUTOLOAD @ISA);
@ISA = qw(SOAP::Cloneable);

use Class::Inspector;


sub DESTROY { SOAP::Trace::objects('()') }

sub new {
    my $self = shift;
    return $self if ref $self;
    my $class = ref($self) || $self;

    SOAP::Trace::objects('()');
    return bless {} => $class;
}

sub proxy {
    my $self = shift;
    $self = $self->new() if not ref $self;

    my $class = ref $self;

    return $self->{_proxy} unless @_;

    $_[0] =~ /^(\w+):/ or die "proxy: transport protocol not specified\n";
    my $protocol = uc "$1"; # untainted now

    # HTTPS is handled by HTTP class
    $protocol =~s/^HTTPS$/HTTP/;

    (my $protocol_class = "${class}::$protocol") =~ s/-/_/g;

    no strict 'refs';
    unless (Class::Inspector->loaded("$protocol_class\::Client")
        && UNIVERSAL::can("$protocol_class\::Client" => 'new')
    ) {
        eval "require $protocol_class";
        die "Unsupported protocol '$protocol'\n"
            if $@ =~ m!^Can\'t locate SOAP/Transport/!;
        die if $@;
    }

    $protocol_class .= "::Client";
    return $self->{_proxy} = $protocol_class->new(endpoint => shift, @_);
}

sub AUTOLOAD {
    my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2);
    return if $method eq 'DESTROY';

    no strict 'refs';
    *$AUTOLOAD = sub { shift->proxy->$method(@_) };
    goto &$AUTOLOAD;
}

# ======================================================================

package SOAP::Fault;

use Carp ();

use overload fallback => 1, '""' => "stringify";

sub DESTROY { SOAP::Trace::objects('()') }

sub new {
    my $self = shift;

    unless (ref $self) {
        my $class = $self;
        $self = bless {} => $class;
        SOAP::Trace::objects('()');
    }

    Carp::carp "Odd (wrong?) number of parameters in new()"
        if $^W && (@_ & 1);

    no strict qw(refs);
    while (@_) {
        my $method = shift;
        $self->$method(shift)
            if $self->can($method)
    }

    return $self;
}

sub stringify {
    my $self = shift;
    return join ': ', $self->faultcode, $self->faultstring;
}

sub BEGIN {
    no strict 'refs';
    for my $method (qw(faultcode faultstring faultactor faultdetail)) {
        my $field = '_' . $method;
        *$method = sub {
            my $self = UNIVERSAL::isa($_[0] => __PACKAGE__)
                ? shift->new
                : __PACKAGE__->new;
            if (@_) {
                $self->{$field} = shift;
                return $self
            }
            return $self->{$field};
        }
    }
    *detail = \&faultdetail;
}

# ======================================================================

package SOAP::Data;

use vars qw(@ISA @EXPORT_OK);
use Exporter;
use Carp ();
use SOAP::Lite::Deserializer::XMLSchemaSOAP1_2;

@ISA = qw(Exporter);
@EXPORT_OK = qw(name type attr value uri);

sub DESTROY { SOAP::Trace::objects('()') }

sub new {
    my $self = shift;

    unless (ref $self) {
        my $class = $self;
        $self = bless {_attr => {}, _value => [], _signature => []} => $class;
        SOAP::Trace::objects('()');
    }
    no strict qw(refs);
    Carp::carp "Odd (wrong?) number of parameters in new()" if $^W && (@_ & 1);
    while (@_) {
        my $method = shift;
        $self->$method(shift) if $self->can($method)
    }

    return $self;
}

sub name {
    my $self = ref $_[0] ? shift : UNIVERSAL::isa($_[0] => __PACKAGE__) ? shift->new : __PACKAGE__->new;
    if (@_) {
        my $name = shift;
        my ($uri, $prefix);    # predeclare, because can't declare in assign
        if ($name) {
            ($uri, $name) = SOAP::Utils::splitlongname($name);
            unless (defined $uri) {
                ($prefix, $name) = SOAP::Utils::splitqname($name);
                $self->prefix($prefix) if defined $prefix;
            } else {
                $self->uri($uri);
            }
        }
        $self->{_name} = $name;

        $self->value(@_) if @_;
        return $self;
    }
    return $self->{_name};
}

sub attr {
    my $self = ref $_[0]
        ? shift
        : UNIVERSAL::isa($_[0] => __PACKAGE__)
            ? shift->new()
            : __PACKAGE__->new();
    if (@_) {
        $self->{_attr} = shift;
        return $self->value(@_) if @_;
        return $self
    }
    return $self->{_attr};
}

sub type {
    my $self = ref $_[0]
        ? shift
        : UNIVERSAL::isa($_[0] => __PACKAGE__)
            ? shift->new()
            : __PACKAGE__->new();
    if (@_) {
        $self->{_type} = shift;
        $self->value(@_) if @_;
        return $self;
    }
    if (!defined $self->{_type} && (my @types = grep {/^\{$SOAP::Constants::NS_XSI_ALL}type$/o} keys %{$self->{_attr}})) {
        $self->{_type} = (SOAP::Utils::splitlongname(delete $self->{_attr}->{shift(@types)}))[1];
    }
    return $self->{_type};
}

BEGIN {
    no strict 'refs';
    for my $method (qw(root mustUnderstand)) {
        my $field = '_' . $method;
        *$method = sub {
        my $attr = $method eq 'root'
            ? "{$SOAP::Constants::NS_ENC}$method"
            : "{$SOAP::Constants::NS_ENV}$method";
            my $self = UNIVERSAL::isa($_[0] => __PACKAGE__)
                ? shift->new
                : __PACKAGE__->new;
            if (@_) {
                $self->{_attr}->{$attr} = $self->{$field} = shift() ? 1 : 0;
                $self->value(@_) if @_;
                return $self;
            }
            $self->{$field} = SOAP::Lite::Deserializer::XMLSchemaSOAP1_2->as_boolean($self->{_attr}->{$attr})
                if !defined $self->{$field} && defined $self->{_attr}->{$attr};
            return $self->{$field};
        }
    }

    for my $method (qw(actor encodingStyle)) {
        my $field = '_' . $method;
        *$method = sub {
            my $attr = "{$SOAP::Constants::NS_ENV}$method";
            my $self = UNIVERSAL::isa($_[0] => __PACKAGE__)
                ? shift->new()
                : __PACKAGE__->new();
            if (@_) {
                $self->{_attr}->{$attr} = $self->{$field} = shift;
                $self->value(@_) if @_;
                return $self;
            }
            $self->{$field} = $self->{_attr}->{$attr}
                if !defined $self->{$field} && defined $self->{_attr}->{$attr};
            return $self->{$field};
        }
    }
}

sub prefix {
    my $self = ref $_[0]
        ? shift
        : UNIVERSAL::isa($_[0] => __PACKAGE__)
            ? shift->new()
            : __PACKAGE__->new();
    return $self->{_prefix} unless @_;
    $self->{_prefix} = shift;
    if (scalar @_) {
        return $self->value(@_);
    }
    return $self;
}

sub uri {
    my $self = ref $_[0]
        ? shift
        : UNIVERSAL::isa($_[0] => __PACKAGE__)
            ? shift->new()
            : __PACKAGE__->new();
    return $self->{_uri} unless @_;
    my $uri = $self->{_uri} = shift;
    warn "Usage of '::' in URI ($uri) deprecated. Use '/' instead\n"
        if defined $uri && $^W && $uri =~ /::/;
    if (scalar @_) {
         return $self->value(@_);
    }
    return $self;
}

sub set_value {
    my $self = ref $_[0]
        ? shift
        : UNIVERSAL::isa($_[0] => __PACKAGE__)
            ? shift->new()
            : __PACKAGE__->new();
    $self->{_value} = [@_];
    return $self;
}

sub value {
    my $self = ref $_[0] ? shift
        : UNIVERSAL::isa($_[0] => __PACKAGE__)
            ? shift->new()
            : __PACKAGE__->new;
    if (@_) {
        return $self->set_value(@_);
    }
    else {
        return wantarray
            ? @{$self->{_value}}
            : $self->{_value}->[0];
    }
}

sub signature {
    my $self = UNIVERSAL::isa($_[0] => __PACKAGE__)
        ? shift->new()
        : __PACKAGE__->new();
    (@_)
        ? ($self->{_signature} = shift, return $self)
        : (return $self->{_signature});
}

# ======================================================================

package SOAP::Header;

use vars qw(@ISA);
@ISA = qw(SOAP::Data);

# ======================================================================

package SOAP::Serializer;
use SOAP::Lite::Utils;
use Carp ();
use vars qw(@ISA);

@ISA = qw(SOAP::Cloneable SOAP::XMLSchema::Serializer);

BEGIN {
    # namespaces and anonymous data structures
    my $ns   = 0;
    my $name = 0;
    my $prefix = 'c-';
    sub gen_ns { 'namesp' . ++$ns }
    sub gen_name { join '', $prefix, 'gensym', ++$name }
    sub prefix { $prefix =~ s/^[^\-]+-/$_[1]-/; $_[0]; }
}

sub BEGIN {
    no strict 'refs';

    __PACKAGE__->__mk_accessors(qw(readable level seen autotype attr maptype
        namespaces multirefinplace encoding signature on_nonserialized context
        ns_uri ns_prefix use_default_ns));

    for my $method (qw(method fault freeform)) { # aliases for envelope
        *$method = sub { shift->envelope($method => @_) }
    }

    # Is this necessary? Seems like work for nothing when a user could just use
    # SOAP::Utils directly.
    # for my $method (qw(qualify overqualify disqualify)) { # import from SOAP::Utils
    #   *$method = \&{'SOAP::Utils::'.$method};
    # }
}

sub DESTROY { SOAP::Trace::objects('()') }

sub new {
    my $self = shift;
    return $self if ref $self;

    my $class = $self;
    $self = bless {
        _level => 0,
        _autotype => 1,
        _readable => 0,
        _ns_uri => '',
        _ns_prefix => '',
        _use_default_ns => 1,
        _multirefinplace => 0,
        _seen => {},
        _encoding => 'UTF-8',
        _objectstack => {},
        _signature => [],
        _maptype => {},
        _on_nonserialized => sub {Carp::carp "Cannot marshall @{[ref shift]} reference" if $^W; return},
        _encodingStyle => $SOAP::Constants::NS_ENC,
        _attr => {
            "{$SOAP::Constants::NS_ENV}encodingStyle" => $SOAP::Constants::NS_ENC,
        },
        _namespaces => {},
        _soapversion => SOAP::Lite->soapversion,
    } => $class;
    $self->typelookup({
           'base64Binary' =>
              [10, sub {$_[0] =~ /[^\x09\x0a\x0d\x20-\x7f]/ }, 'as_base64Binary'],
           'zerostring' =>
               [12, sub { $_[0] =~ /^0\d+$/ }, 'as_string'],
            # int (and actually long too) are subtle: the negative range is one greater...
            'int'  =>
               [20, sub {$_[0] =~ /^([+-]?\d+)$/ && ($1 <= 2147483647) && ($1 >= -2147483648); }, 'as_int'],
            'long' =>
               [25, sub {$_[0] =~ /^([+-]?\d+)$/ && $1 <= 9223372036854775807;}, 'as_long'],
            'float'  =>
               [30, sub {$_[0] =~ /^(-?(?:\d+(?:\.\d*)?|\.\d+|NaN|INF)|([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?)$/}, 'as_float'],
            'gMonth' =>
               [35, sub { $_[0] =~ /^--\d\d--(-\d\d:\d\d)?$/; }, 'as_gMonth'],
            'gDay' =>
               [40, sub { $_[0] =~ /^---\d\d(-\d\d:\d\d)?$/; }, 'as_gDay'],
            'gYear' =>
               [45, sub { $_[0] =~ /^-?\d\d\d\d(-\d\d:\d\d)?$/; }, 'as_gYear'],
            'gMonthDay' =>
               [50, sub { $_[0] =~ /^-\d\d-\d\d(-\d\d:\d\d)?$/; }, 'as_gMonthDay'],
            'gYearMonth' =>
               [55, sub { $_[0] =~ /^-?\d\d\d\d-\d\d(Z|([+-]\d\d:\d\d))?$/; }, 'as_gYearMonth'],
            'date' =>
               [60, sub { $_[0] =~ /^-?\d\d\d\d-\d\d-\d\d(Z|([+-]\d\d:\d\d))?$/; }, 'as_date'],
            'time' =>
               [70, sub { $_[0] =~ /^\d\d:\d\d:\d\d(\.\d\d\d)?(Z|([+-]\d\d:\d\d))?$/; }, 'as_time'],
            'dateTime' =>
               [75, sub { $_[0] =~ /^\d\d\d\d-\d\d-\d\dT\d\d:\d\d:\d\d(\.\d\d\d)?(Z|([+-]\d\d:\d\d))?$/; }, 'as_dateTime'],
            'duration' =>
               [80, sub { $_[0] !~m{^-?PT?$} && $_[0] =~ m{^
                        -?   # a optional - sign
                        P
                        (:? \d+Y )?
                        (:? \d+M )?
                        (:? \d+D )?
                        (:?
                            T(:?\d+H)?
                            (:?\d+M)?
                            (:?\d+S)?
                        )?
                        $
                    }x;
               }, 'as_duration'],
            'boolean' =>
               [90, sub { $_[0] =~ /^(true|false)$/i; }, 'as_boolean'],
            'anyURI' =>
               [95, sub { $_[0] =~ /^(urn:|http:\/\/)/i; }, 'as_anyURI'],
            'string' =>
               [100, sub {1}, 'as_string'],
        });
    $self->register_ns($SOAP::Constants::NS_ENC,$SOAP::Constants::PREFIX_ENC);
    $self->register_ns($SOAP::Constants::NS_ENV,$SOAP::Constants::PREFIX_ENV)
        if $SOAP::Constants::PREFIX_ENV;
    $self->xmlschema($SOAP::Constants::DEFAULT_XML_SCHEMA);
    SOAP::Trace::objects('()');

    no strict qw(refs);
    Carp::carp "Odd (wrong?) number of parameters in new()" if $^W && (@_ & 1);
    while (@_) { my $method = shift; $self->$method(shift) if $self->can($method) }

    return $self;
}

sub typelookup {
    my ($self, $lookup) = @_;
    if (defined $lookup) {
        $self->{ _typelookup } = $lookup;
        $self->{ _typelookup_order } = [ sort { $lookup->{$a}->[0] <=> $lookup->{$b}->[0] } keys %{ $lookup } ];
        return $self;
    }
    return $self->{ _typelookup };
}

sub ns {
    my $self = shift;
    $self = $self->new() if not ref $self;
    if (@_) {
        my ($u,$p) = @_;
        my $prefix;

        if ($p) {
            $prefix = $p;
        }
        elsif (!$p && !($prefix = $self->find_prefix($u))) {
            $prefix = gen_ns;
        }

        $self->{'_ns_uri'}         = $u;
        $self->{'_ns_prefix'}      = $prefix;
        $self->{'_use_default_ns'} = 0;
        # $self->register_ns($u,$prefix);
        $self->{'_namespaces'}->{$u} = $prefix;
        return $self;
    }
    return $self->{'_ns_uri'};
}

sub default_ns {
    my $self = shift;
    $self = $self->new() if not ref $self;
    if (@_) {
        my ($u) = @_;
        $self->{'_ns_uri'}         = $u;
        $self->{'_ns_prefix'}      = '';
        $self->{'_use_default_ns'} = 1;
        return $self;
    }
    return $self->{'_ns_uri'};
}

sub use_prefix {
    my $self = shift;
    $self = $self->new() if not ref $self;
    warn 'use_prefix has been deprecated. if you wish to turn off or on the '
        . 'use of a default namespace, then please use either ns(uri) or default_ns(uri)';
    if (@_) {
        my $use = shift;
        $self->{'_use_default_ns'} = !$use || 0;
        return $self;
    } else {
        return $self->{'_use_default_ns'};
    }
}
sub uri {
    my $self = shift;
    $self = $self->new() if not ref $self;
#    warn 'uri has been deprecated. if you wish to set the namespace for the request, then please use either ns(uri) or default_ns(uri)';
    if (@_) {
        my $ns = shift;
        if ($self->{_use_default_ns}) {
           $self->default_ns($ns);
        }
        else {
           $self->ns($ns);
        }
#       $self->{'_ns_uri'} = $ns;
#       $self->register_ns($self->{'_ns_uri'}) if (!$self->{_use_default_ns});
        return $self;
    }
    return $self->{'_ns_uri'};
}

sub encodingStyle {
    my $self = shift;
    $self = $self->new() if not ref $self;
    return $self->{'_encodingStyle'} unless @_;

    my $cur_style = $self->{'_encodingStyle'};
    delete($self->{'_namespaces'}->{$cur_style});

    my $new_style = shift;
    if ($new_style eq "") {
        delete($self->{'_attr'}->{"{$SOAP::Constants::NS_ENV}encodingStyle"});
    }
    else {
        $self->{'_attr'}->{"{$SOAP::Constants::NS_ENV}encodingStyle"} = $new_style;
        $self->{'_namespaces'}->{$new_style} = $SOAP::Constants::PREFIX_ENC;
    }
}

# TODO - changing SOAP version can affect previously set encodingStyle
sub soapversion {
    my $self = shift;
    return $self->{_soapversion} unless @_;
    return $self if $self->{_soapversion} eq SOAP::Lite->soapversion;
    $self->{_soapversion} = shift;

    $self->attr({
        "{$SOAP::Constants::NS_ENV}encodingStyle" => $SOAP::Constants::NS_ENC,
    });
    $self->namespaces({
        $SOAP::Constants::NS_ENC => $SOAP::Constants::PREFIX_ENC,
        $SOAP::Constants::PREFIX_ENV ? ($SOAP::Constants::NS_ENV => $SOAP::Constants::PREFIX_ENV) : (),
    });
    $self->xmlschema($SOAP::Constants::DEFAULT_XML_SCHEMA);

    return $self;
}

sub xmlschema {
    my $self = shift->new;
    return $self->{_xmlschema} unless @_;

    my @schema;
    if ($_[0]) {
        @schema = grep {/XMLSchema/ && /$_[0]/} keys %SOAP::Constants::XML_SCHEMAS;
        Carp::croak "More than one schema match parameter '$_[0]': @{[join ', ', @schema]}" if @schema > 1;
        Carp::croak "No schema match parameter '$_[0]'" if @schema != 1;
    }

    # do nothing if current schema is the same as new
    # return $self if $self->{_xmlschema} && $self->{_xmlschema} eq $schema[0];

    my $ns = $self->namespaces;
    # delete current schema from namespaces
    if (my $schema = $self->{_xmlschema}) {
        delete $ns->{$schema};
        delete $ns->{"$schema-instance"};
    }

    # add new schema into namespaces
    if (my $schema = $self->{_xmlschema} = shift @schema) {
        $ns->{$schema} = 'xsd';
        $ns->{"$schema-instance"} = 'xsi';
    }

    # and here is the class serializer should work with
    my $class = exists $SOAP::Constants::XML_SCHEMAS{$self->{_xmlschema}}
        ? $SOAP::Constants::XML_SCHEMAS{$self->{_xmlschema}} . '::Serializer'
        : $self;

    $self->xmlschemaclass($class);

    return $self;
}

sub envprefix {
    my $self = shift->new();
    return $self->namespaces->{$SOAP::Constants::NS_ENV} unless @_;
    $self->namespaces->{$SOAP::Constants::NS_ENV} = shift;
    return $self;
}

sub encprefix {
    my $self = shift->new();
    return $self->namespaces->{$SOAP::Constants::NS_ENC} unless @_;
    $self->namespaces->{$SOAP::Constants::NS_ENC} = shift;
    return $self;
}

sub gen_id { sprintf "%U", $_[1] }

sub multiref_object {
    my ($self, $object) = @_;
    my $id = $self->gen_id($object);
    if (! exists $self->{ _seen }->{ $id }) {
        $self->{ _seen }->{ $id } = {
            count => 1,
            multiref => 0,
            value => $object,
            recursive => 0
        };
    }
    else {
        my $id_seen = $self->{ _seen }->{ $id };
        $id_seen->{count}++;
        $id_seen->{multiref} = 1;
        $id_seen->{value} = $object;
        $id_seen->{recursive} ||= 0;
    }
    return $id;
}

sub recursive_object {
    my $self = shift;
    $self->seen->{$self->gen_id(shift)}->{recursive} = 1;
}

sub is_href {
    my $self = shift;
    my $seen = $self->seen->{shift || return} or return;
    return 1 if $seen->{id};
    return $seen->{multiref}
        && !($seen->{id} = (shift
            || $seen->{recursive}
            || $seen->{multiref} && $self->multirefinplace));
}

sub multiref_anchor {
    my ($self, $id) = @_;
    no warnings qw(uninitialized);
    if ($self->{ _seen }->{ $id }->{multiref}) {
        return "ref-$id"
    }
    else {
        return undef;
    }
}

sub encode_multirefs {
    my $self = shift;
    return if $self->multirefinplace();

    my $seen = $self->{ _seen };
    map { $_->[1]->{_id} = 1; $_ }
        map { $self->encode_object($seen->{$_}->{value}) }
            grep { $seen->{$_}->{multiref} && !$seen->{$_}->{recursive} }
                keys %$seen;
}

sub maptypetouri {
    my($self, $type, $simple) = @_;

    return $type unless defined $type;
    my($prefix, $name) = SOAP::Utils::splitqname($type);

    unless (defined $prefix) {
        $name =~ s/__|\./::/g;
        $self->maptype->{$name} = $simple
            ? die "Schema/namespace for type '$type' is not specified\n"
            : $SOAP::Constants::NS_SL_PERLTYPE
                unless exists $self->maptype->{$name};
        $type = $self->maptype->{$name}
            ? SOAP::Utils::qualify($self->namespaces->{$self->maptype->{$name}} ||= gen_ns, $type)
            : undef;
    }
    return $type;
}

sub encode_object {
    my($self, $object, $name, $type, $attr) = @_;

    $attr ||= {};
    return $self->encode_scalar($object, $name, $type, $attr)
        unless ref $object;

    my $id = $self->multiref_object($object);

    use vars '%objectstack';           # we'll play with symbol table
    local %objectstack = %objectstack; # want to see objects ONLY in the current tree

    # did we see this object in current tree? Seems to be recursive refs
    # same as call to $self->recursive_object($object) - but
    # recursive_object($object) has to re-compute the object's id
    if (++$objectstack{ $id } > 1) {
        $self->{ _seen }->{ $id }->{recursive} = 1
    }

    # return if we already saw it twice. It should be already properly serialized
    return if $objectstack{$id} > 2;

    if (UNIVERSAL::isa($object => 'SOAP::Data')) {
        # use $object->SOAP::Data:: to enable overriding name() and others in inherited classes
        $object->SOAP::Data::name($name)
            unless defined $object->SOAP::Data::name;

        # apply ->uri() and ->prefix() which can modify name and attributes of
        # element, but do not modify SOAP::Data itself
        my($name, $attr) = $self->fixattrs($object);
        $attr = $self->attrstoqname($attr);

        my @realvalues = $object->SOAP::Data::value;
        return [$name || gen_name, $attr] unless @realvalues;

        my $method = "as_" . ($object->SOAP::Data::type || '-'); # dummy type if not defined
        # try to call method specified for this type
        no strict qw(refs);
        my @values = map {
            # store null/nil attribute if value is undef
            local $attr->{SOAP::Utils::qualify(xsi => $self->xmlschemaclass->nilValue)} = $self->xmlschemaclass->as_undef(1)
                unless defined;
            $self->can($method) && $self->$method($_, $name || gen_name, $object->SOAP::Data::type, $attr)
                || $self->typecast($_, $name || gen_name, $object->SOAP::Data::type, $attr)
                || $self->encode_object($_, $name, $object->SOAP::Data::type, $attr)
        } @realvalues;
        $object->SOAP::Data::signature([map {join $;, $_->[0], SOAP::Utils::disqualify($_->[1]->{'xsi:type'} || '')} @values]) if @values;
        return wantarray ? @values : $values[0];
    }

    my $class = ref $object;

    if ($class !~ /^(?:SCALAR|ARRAY|HASH|REF)$/o) {
        # we could also check for CODE|GLOB|LVALUE, but we cannot serialize
        # them anyway, so they'll be caught by check below
        $class =~ s/::/__/g;

        $name = $class if !defined $name;
        $type = $class if !defined $type && $self->autotype;

        my $method = 'as_' . $class;
        if ($self->can($method)) {
            no strict qw(refs);
            my $encoded = $self->$method($object, $name, $type, $attr);
            return $encoded if ref $encoded;
            # return only if handled, otherwise handle with default handlers
        }
    }

    if (UNIVERSAL::isa($object => 'REF') || UNIVERSAL::isa($object => 'SCALAR')) {
        return $self->encode_scalar($object, $name, $type, $attr);
    }
    elsif (UNIVERSAL::isa($object => 'ARRAY')) {
        # Added in SOAP::Lite 0.65_6 to fix an XMLRPC bug
        return $self->encodingStyle eq ""
            || $self->isa('XMLRPC::Serializer')
                ? $self->encode_array($object, $name, $type, $attr)
                : $self->encode_literal_array($object, $name, $type, $attr);
    }
    elsif (UNIVERSAL::isa($object => 'HASH')) {
        return $self->encode_hash($object, $name, $type, $attr);
    }
    else {
        return $self->on_nonserialized->($object);
    }
}

sub encode_scalar {
    my($self, $value, $name, $type, $attr) = @_;
    $name ||= gen_name;

    my $schemaclass = $self->xmlschemaclass;

    # null reference
    return [$name, {%$attr, SOAP::Utils::qualify(xsi => $schemaclass->nilValue) => $schemaclass->as_undef(1)}] unless defined $value;

    # object reference
    return [$name, {'xsi:type' => $self->maptypetouri($type), %$attr}, [$self->encode_object($$value)], $self->gen_id($value)] if ref $value;

    # autodefined type
    if ($self->{ _autotype}) {
        my $lookup = $self->{_typelookup};
        no strict qw(refs);
        #for (sort {$lookup->{$a}->[0] <=> $lookup->{$b}->[0]} keys %$lookup) {
        for (@{ $self->{ _typelookup_order } }) {
            my $method = $lookup->{$_}->[2];
            return $self->can($method) && $self->$method($value, $name, $type, $attr)
                || $method->($value, $name, $type, $attr)
                    if $lookup->{$_}->[1]->($value);
        }
    }

    # invariant
    return [$name, $attr, $value];
}

sub encode_array {
    my ($self, $array, $name, $type, $attr) = @_;
    my $items = 'item';

    # If typing is disabled, just serialize each of the array items
    # with no type information, each using the specified name,
    # and do not create a wrapper array tag.
    if (!$self->autotype) {
        $name ||= gen_name;
        return map {$self->encode_object($_, $name)} @$array;
    }

    # TODO: add support for multidimensional, partially transmitted and sparse arrays
    my @items = map {$self->encode_object($_, $items)} @$array;
    my $num = @items;
    my($arraytype, %types) = '-';
    for (@items) { $arraytype = $_->[1]->{'xsi:type'} || '-'; $types{$arraytype}++ }
    $arraytype = sprintf "%s\[$num]", keys %types > 1 || $arraytype eq '-' ? SOAP::Utils::qualify(xsd => $self->xmlschemaclass->anyTypeValue) : $arraytype;

    # $type = SOAP::Utils::qualify($self->encprefix => 'Array') if $self->autotype && !defined $type;
    $type = qualify($self->encprefix => 'Array') if !defined $type;
    return [$name || SOAP::Utils::qualify($self->encprefix => 'Array'),
          {
              SOAP::Utils::qualify($self->encprefix => 'arrayType') => $arraytype,
              'xsi:type' => $self->maptypetouri($type), %$attr
          },
          [@items],
          $self->gen_id($array)
    ];
}

# Will encode arrays using doc-literal style
sub encode_literal_array {
    my($self, $array, $name, $type, $attr) = @_;

    if ($self->autotype) {
        my $items = 'item';

        # TODO: add support for multidimensional, partially transmitted and sparse arrays
        my @items = map {$self->encode_object($_, $items)} @$array;


        my $num = @items;
        my($arraytype, %types) = '-';
        for (@items) {
           $arraytype = $_->[1]->{'xsi:type'} || '-';
           $types{$arraytype}++
        }
        $arraytype = sprintf "%s\[$num]", keys %types > 1 || $arraytype eq '-'
            ? SOAP::Utils::qualify(xsd => $self->xmlschemaclass->anyTypeValue)
            : $arraytype;

        $type = SOAP::Utils::qualify($self->encprefix => 'Array')
            if !defined $type;

        return [$name || SOAP::Utils::qualify($self->encprefix => 'Array'),
            {
                SOAP::Utils::qualify($self->encprefix => 'arrayType') => $arraytype,
                'xsi:type' => $self->maptypetouri($type), %$attr
            },
            [ @items ],
            $self->gen_id($array)
        ];
    }
    else {
        #
        # literal arrays are different - { array => [ 5,6 ] }
        # results in 56
        # This means that if there's a literal inside the array (not a
        # reference), we have to encode it this way. If there's only
        # nested tags, encode as
        # 12
        #

        my $literal = undef;
        my @items = map {
            ref $_
                ? $self->encode_object($_)
                : do {
                    $literal++;
                    $_
                }

        } @$array;

        if ($literal) {
            return map { [ $name , $attr , $_, $self->gen_id($array) ] } @items;
        }
        else {
            return [$name || SOAP::Utils::qualify($self->encprefix => 'Array'),
                $attr,
                [ @items ],
                $self->gen_id($array)
            ];
        }
    }
}

sub encode_hash {
    my($self, $hash, $name, $type, $attr) = @_;

    if ($self->autotype && grep {!/$SOAP::Constants::ELMASK/o} keys %$hash) {
        warn qq!Cannot encode @{[$name ? "'$name'" : 'unnamed']} element as 'hash'. Will be encoded as 'map' instead\n! if $^W;
        return $self->as_map($hash, $name || gen_name, $type, $attr);
    }

    $type = 'SOAPStruct'
        if $self->autotype && !defined($type) && exists $self->maptype->{SOAPStruct};
    return [$name || gen_name,
          $self->autotype ? {'xsi:type' => $self->maptypetouri($type), %$attr} : { %$attr },
          [map {$self->encode_object($hash->{$_}, $_)} keys %$hash],
          $self->gen_id($hash)
    ];
}

sub as_ordered_hash {
    my ($self, $value, $name, $type, $attr) = @_;
    die "Not an ARRAY reference for 'ordered_hash' type" unless UNIVERSAL::isa($value => 'ARRAY');
    return [ $name, $attr,
        [map{$self->encode_object(@{$value}[2*$_+1,2*$_])} 0..$#$value/2 ],
        $self->gen_id($value)
    ];
}

sub as_map {
    my ($self, $value, $name, $type, $attr) = @_;
    die "Not a HASH reference for 'map' type" unless UNIVERSAL::isa($value => 'HASH');
    my $prefix = ($self->namespaces->{$SOAP::Constants::NS_APS} ||= 'apachens');
    my @items = map {
        $self->encode_object(
            SOAP::Data->type(
                ordered_hash => [
                    key => $_,
                    value => $value->{$_}
                ]
            ),
            'item',
            ''
        )} sort keys %$value;
    return [
        $name,
        {'xsi:type' => "$prefix:Map", %$attr},
        [@items],
        $self->gen_id($value)
    ];
}

sub as_xml {
    my $self = shift;
    my($value, $name, $type, $attr) = @_;
    return [$name, {'_xml' => 1}, $value];
}

sub typecast {
    my $self = shift;
    my($value, $name, $type, $attr) = @_;
    return if ref $value; # skip complex object, caller knows how to deal with it
    return if $self->autotype && !defined $type; # we don't know, autotype knows
    return [$name,
          {(defined $type && $type gt '' ? ('xsi:type' => $self->maptypetouri($type, 'simple type')) : ()), %$attr},
          $value
    ];
}

sub register_ns {
    my $self = shift->new();
    my ($ns,$prefix) = @_;
    $prefix = gen_ns if !$prefix;
    $self->{'_namespaces'}->{$ns} = $prefix if $ns;
}

sub find_prefix {
    my ($self, $ns) = @_;
    return (exists $self->{'_namespaces'}->{$ns})
        ? $self->{'_namespaces'}->{$ns}
        : ();
}

sub fixattrs {
    my ($self, $data) = @_;
    my ($name, $attr) = ($data->SOAP::Data::name, {%{$data->SOAP::Data::attr}});
    my ($xmlns, $prefix) = ($data->uri, $data->prefix);
    unless (defined($xmlns) || defined($prefix)) {
        $self->register_ns($xmlns,$prefix) unless ($self->use_default_ns);
        return ($name, $attr);
    }
    $name ||= gen_name(); # local name
    $prefix = gen_ns() if !defined $prefix && $xmlns gt '';
    $prefix = ''
        if defined $xmlns && $xmlns eq ''
            || defined $prefix && $prefix eq '';

    $attr->{join ':', xmlns => $prefix || ()} = $xmlns if defined $xmlns;
    $name = join ':', $prefix, $name if $prefix;

    $self->register_ns($xmlns,$prefix) unless ($self->use_default_ns);

    return ($name, $attr);

}

sub toqname {
    my $self = shift;
    my $long = shift;

    return $long unless $long =~ /^\{(.*)\}(.+)$/;
    return SOAP::Utils::qualify $self->namespaces->{$1} ||= gen_ns, $2;
}

sub attrstoqname {
    my $self = shift;
    my $attrs = shift;

    return {
        map { /^\{(.*)\}(.+)$/
            ? ($self->toqname($_) => $2 eq 'type'
                || $2 eq 'arrayType'
                    ? $self->toqname($attrs->{$_})
                    : $attrs->{$_})
            : ($_ => $attrs->{$_})
        } keys %$attrs
    };
}

sub tag {
    my ($self, $tag, $attrs, @values) = @_;

    my $readable = $self->{ _readable };

    my $value = join '', @values;
    my $indent = $readable ? ' ' x (($self->{ _level }-1)*2) : '';

    # check for special attribute
    return "$indent$value" if exists $attrs->{_xml} && delete $attrs->{_xml};

    die "Element '$tag' can't be allowed in valid XML message. Died."
        if $tag !~ /^$SOAP::Constants::NSMASK$/o;

	warn "Element '$tag' uses the reserved prefix 'XML' (in any case)"
		if $tag !~ /^(?![Xx][Mm][Ll])/;

    my $prolog = $readable ? "\n" : "";
    my $epilog = $readable ? "\n" : "";
    my $tagjoiner = " ";
    if ($self->{ _level } == 1) {
        my $namespaces = $self->namespaces;
        foreach (keys %$namespaces) {
            $attrs->{SOAP::Utils::qualify(xmlns => $namespaces->{$_})} = $_
        }
        $prolog = qq!encoding]}"?>!
            if defined $self->encoding;
        $prolog .= "\n" if $readable;
        $tagjoiner = " \n".(' ' x 4 ) if $readable;
    }
    my $tagattrs = join($tagjoiner, '',
        map { sprintf '%s="%s"', $_, SOAP::Utils::encode_attribute($attrs->{$_}) }
            grep { $_ && defined $attrs->{$_} && ($_ ne 'xsi:type' || $attrs->{$_} ne '') }
                sort keys %$attrs);

    if ($value gt '') {
        return sprintf("$prolog$indent<%s%s>%s%s$epilog",$tag,$tagattrs,$value,($value =~ /^\s*
    }
    else {
        return sprintf("$prolog$indent<%s%s />$epilog$indent",$tag,$tagattrs);
    }
}

sub xmlize {
    my $self = shift;
    my($name, $attrs, $values, $id) = @{$_[0]};
    $attrs ||= {};

    local $self->{_level} = $self->{_level} + 1;

    return $self->tag($name, $attrs)
        unless defined $values;

    return $self->tag($name, $attrs, $values)
        unless ref $values eq "ARRAY";

    return $self->tag($name, {%$attrs, href => '#'.$self->multiref_anchor($id)})
        if $self->is_href($id, delete($attrs->{_id}));

    # we have seen this element as a reference
    if (defined $id && $self->{ _seen }->{ $id }->{ multiref}) {
        return $self->tag($name,
            {
                %$attrs, id => $self->multiref_anchor($id)
            },
            map {$self->xmlize($_)} @$values
        );
    }
    else {
        return $self->tag($name, $attrs, map {$self->xmlize($_)} @$values);
    }
}

sub uriformethod {
    my $self = shift;

    my $method_is_data = ref $_[0] && UNIVERSAL::isa($_[0] => 'SOAP::Data');

    # drop prefix from method that could be string or SOAP::Data object
    my($prefix, $method) = $method_is_data
        ? ($_[0]->prefix, $_[0]->name)
        : SOAP::Utils::splitqname($_[0]);

    my $attr = {reverse %{$self->namespaces}};
    # try to define namespace that could be stored as
    #   a) method is SOAP::Data
    #        ? attribute in method's element as xmlns= or xmlns:${prefix}=
    #        : uri
    #   b) attribute in Envelope element as xmlns= or xmlns:${prefix}=
    #   c) no prefix or prefix equal serializer->envprefix
    #        ? '', but see comment below
    #        : die with error message
    my $uri = $method_is_data
        ? ref $_[0]->attr && ($_[0]->attr->{$prefix ? "xmlns:$prefix" : 'xmlns'} || $_[0]->uri)
        : $self->uri;

    defined $uri or $uri = $attr->{$prefix || ''};

    defined $uri or $uri = !$prefix || $prefix eq $self->envprefix
    # still in doubts what should namespace be in this case
    # but will keep it like this for now and be compatible with our server
        ? ( $method_is_data
            && $^W
            && warn("URI is not provided as an attribute for method ($method)\n"),
            ''
            )
        : die "Can't find namespace for method ($prefix:$method)\n";

    return ($uri, $method);
}

sub serialize { SOAP::Trace::trace('()');
    my $self = shift->new;
    @_ == 1 or Carp::croak "serialize() method accepts one parameter";

    $self->seen({}); # reinitialize multiref table
    my($encoded) = $self->encode_object($_[0]);

    # now encode multirefs if any
    #                 v -------------- subelements of Envelope
    push(@{$encoded->[2]}, $self->encode_multirefs) if ref $encoded->[2];
    return $self->xmlize($encoded);
}

sub envelope {
    SOAP::Trace::trace('()');
    my $self = shift->new;
    my $type = shift;
    my(@parameters, @header);
    for (@_) {
        # Find all the SOAP Headers
        if (defined($_) && ref($_) && UNIVERSAL::isa($_ => 'SOAP::Header')) {
            push(@header, $_);
        }
        # Find all the SOAP Message Parts (attachments)
        elsif (defined($_) && ref($_) && $self->context
            && $self->context->packager->is_supported_part($_)
        ) {
            $self->context->packager->push_part($_);
        }
        # Find all the SOAP Body elements
        else {
            # proposed resolution for [ 1700326 ] encode_data called incorrectly in envelope
            push(@parameters, $_);
            # push (@parameters, SOAP::Utils::encode_data($_));
        }
    }
    my $header = @header ? SOAP::Data->set_value(@header) : undef;
    my($body,$parameters);
    if ($type eq 'method' || $type eq 'response') {
        SOAP::Trace::method(@parameters);

        my $method = shift(@parameters);
        #  or die "Unspecified method for SOAP call\n";

        $parameters = @parameters ? SOAP::Data->set_value(@parameters) : undef;
        if (!defined($method)) {}
        elsif (UNIVERSAL::isa($method => 'SOAP::Data')) {
            $body = $method;
        }
        elsif ($self->use_default_ns) {
            if ($self->{'_ns_uri'}) {
                $body = SOAP::Data->name($method)
                    ->attr({'xmlns' => $self->{'_ns_uri'} } );
            }
            else {
                $body = SOAP::Data->name($method);
            }
        }
        else {
            # Commented out by Byrne on 1/4/2006 - to address default namespace problems
            #      $body = SOAP::Data->name($method)->uri($self->{'_ns_uri'});
            #      $body = $body->prefix($self->{'_ns_prefix'}) if ($self->{'_ns_prefix'});

            # Added by Byrne on 1/4/2006 - to avoid the unnecessary creation of a new
            # namespace
            # Begin New Code (replaces code commented out above)
            $body = SOAP::Data->name($method);
            my $pre = $self->find_prefix($self->{'_ns_uri'});
            $body = $body->prefix($pre) if ($self->{'_ns_prefix'});
            # End new code
        }

        # This is breaking a unit test right now...
        # proposed resolution for [ 1700326 ] encode_data called incorrectly in envelope
        #    $body->set_value(SOAP::Utils::encode_data($parameters ? \$parameters : ()))
        #      if $body;
        # must call encode_data on nothing to enforce xsi:nil="true" to be set.
        $body->set_value($parameters ? \$parameters : SOAP::Utils::encode_data()) if $body;
    }
    elsif ($type eq 'fault') {
        SOAP::Trace::fault(@parameters);
        # -> attr({'xmlns' => ''})
        # Parameter order fixed thanks to Tom Fischer
        $body = SOAP::Data-> name(SOAP::Utils::qualify($self->envprefix => 'Fault'))
          -> value(\SOAP::Data->set_value(
                SOAP::Data->name(faultcode => SOAP::Utils::qualify($self->envprefix => $parameters[0]))->type(""),
                SOAP::Data->name(faultstring => SOAP::Utils::encode_data($parameters[1]))->type(""),
                defined($parameters[3])
                    ? SOAP::Data->name(faultactor => $parameters[3])->type("")
                    : (),
                defined($parameters[2])
                    ? SOAP::Data->name(detail => do{
                        my $detail = $parameters[2];
                        ref $detail
                            ? \$detail
                            : SOAP::Utils::encode_data($detail)
                    })
                    : (),
        ));
    }
    elsif ($type eq 'freeform') {
        SOAP::Trace::freeform(@parameters);
        $body = SOAP::Data->set_value(@parameters);
    }
    elsif (!defined($type)) {
        # This occurs when the Body is intended to be null. When no method has been
        # passed in of any kind.
    }
    else {
        die "Wrong type of envelope ($type) for SOAP call\n";
    }

    $self->{ _seen } = {}; # reinitialize multiref table

    # Build the envelope
    # Right now it is possible for $body to be a SOAP::Data element that has not
    # XML escaped any values. How do you remedy this?
    my($encoded) = $self->encode_object(
        SOAP::Data->name(
            SOAP::Utils::qualify($self->envprefix => 'Envelope') => \SOAP::Data->value(
                ($header
                    ? SOAP::Data->name( SOAP::Utils::qualify($self->envprefix => 'Header') => \$header)
                    : ()
                ),
                ($body
                    ? SOAP::Data->name(SOAP::Utils::qualify($self->envprefix => 'Body') => \$body)
                    : SOAP::Data->name(SOAP::Utils::qualify($self->envprefix => 'Body')) ),
            )
        )->attr($self->attr)
    );

    $self->signature($parameters->signature) if ref $parameters;

    # IMHO multirefs should be encoded after Body, but only some
    # toolkits understand this encoding, so we'll keep them for now (04/15/2001)
    # as the last element inside the Body
    #                 v -------------- subelements of Envelope
    #                      vv -------- last of them (Body)
    #                            v --- subelements
    push(@{$encoded->[2]->[-1]->[2]}, $self->encode_multirefs) if ref $encoded->[2]->[-1]->[2];

    # Sometimes SOAP::Serializer is invoked statically when there is no context.
    # So first check to see if a context exists.
    # TODO - a context needs to be initialized by a constructor?
    if ($self->context && $self->context->packager->parts) {
        # TODO - this needs to be called! Calling it though wraps the payload twice!
        #  return $self->context->packager->package($self->xmlize($encoded));
    }

    return $self->xmlize($encoded);
}

# ======================================================================

package SOAP::Parser;

sub DESTROY { SOAP::Trace::objects('()') }

sub xmlparser {
    my $self = shift;
    return eval {
        $SOAP::Constants::DO_NOT_USE_XML_PARSER
            ? undef
            : do {
                require XML::Parser;
                XML::Parser->new() }
            }
            || eval { require XML::Parser::Lite; XML::Parser::Lite->new }
            || die "XML::Parser is not @{[$SOAP::Constants::DO_NOT_USE_XML_PARSER ? 'used' : 'available']} and ", $@;
}

sub parser {
    my $self = shift->new;

    # set the parser if passed
    if (my $parser = shift) {
        $self->{'_parser'} = shift;
        return $self;
    }

    # else return the parser or use XML::Parser::Lite
    return ($self->{'_parser'} ||= $self->xmlparser);
}

sub new {
    my $self = shift;
    return $self if ref $self;
    my $class = $self;
    SOAP::Trace::objects('()');
    return bless {_parser => shift}, $class;
}

sub decode { SOAP::Trace::trace('()');
    my $self = shift;

    $self->parser->setHandlers(
        Final => sub { shift; $self->final(@_) },
        Start => sub { shift; $self->start(@_) },
        End   => sub { shift; $self->end(@_)   },
        Char  => sub { shift; $self->char(@_)  },
        ExternEnt => sub { shift; die "External entity (pointing to '$_[1]') is not allowed" },
    );
    # my $parsed = $self->parser->parse($_[0]);
    # return $parsed;
    #
    my $ret = undef;
    eval {
        $ret = $self->parser->parse($_[0]);
    };
    if ($@) {
        $self->final; # Clean up in the event of an error
        die $@; # Pass back the error
    }
    return $ret;
}

sub final {
    my $self = shift;

    # clean handlers, otherwise SOAP::Parser won't be deleted:
    # it refers to XML::Parser which refers to subs from SOAP::Parser
    # Thanks to Ryan Adams
    # and Craig Johnston
    # checked by number of tests in t/02-payload.t

    undef $self->{_values};
    $self->parser->setHandlers(
        Final => undef,
        Start => undef,
        End => undef,
        Char => undef,
        ExternEnt => undef,
    );
    $self->{_done};
}

sub start { push @{shift->{_values}}, [shift, {@_}] }

# string concatenation changed to arrays which should improve performance
# for strings with many entity-encoded elements.
# Thanks to Mathieu Longtin
sub char { push @{shift->{_values}->[-1]->[3]}, shift }

sub end {
    my $self = shift;
    my $done = pop @{$self->{_values}};
    $done->[2] = defined $done->[3]
        ? join('',@{$done->[3]})
        : '' unless ref $done->[2];
    undef $done->[3];
    @{$self->{_values}}
        ? (push @{$self->{_values}->[-1]->[2]}, $done)
        : ($self->{_done} = $done);
}

# ======================================================================

package SOAP::SOM;

use Carp ();
use SOAP::Lite::Utils;

sub BEGIN {
    no strict 'refs';
    my %path = (
        root        => '/',
        envelope    => '/Envelope',
        body        => '/Envelope/Body',
        header      => '/Envelope/Header',
        headers     => '/Envelope/Header/[>0]',
        fault       => '/Envelope/Body/Fault',
        faultcode   => '/Envelope/Body/Fault/faultcode',
        faultstring => '/Envelope/Body/Fault/faultstring',
        faultactor  => '/Envelope/Body/Fault/faultactor',
        faultdetail => '/Envelope/Body/Fault/detail',
    );
    for my $method (keys %path) {
        *$method = sub {
            my $self = shift;
            ref $self or return $path{$method};
            Carp::croak "Method '$method' is readonly and doesn't accept any parameters" if @_;
            return $self->valueof($path{$method});
        };
    }
    my %results = (
        method    => '/Envelope/Body/[1]',
        result    => '/Envelope/Body/[1]/[1]',
        freeform  => '/Envelope/Body/[>0]',
        paramsin  => '/Envelope/Body/[1]/[>0]',
        paramsall => '/Envelope/Body/[1]/[>0]',
        paramsout => '/Envelope/Body/[1]/[>1]'
    );
    for my $method (keys %results) {
        *$method = sub {
            my $self = shift;
            ref $self or return $results{$method};
            Carp::croak "Method '$method' is readonly and doesn't accept any parameters" if @_;
            defined $self->fault ? return : return $self->valueof($results{$method});
        };
    }

    for my $method (qw(o_child o_value o_lname o_lattr o_qname)) { # import from SOAP::Utils
        *$method = \&{'SOAP::Utils::'.$method};
    }

    __PACKAGE__->__mk_accessors('context');

}

# use object in boolean context return true/false on last match
# Ex.: $som->match('//Fault') ? 'SOAP call failed' : 'success';
use overload fallback => 1, 'bool'  => sub { @{shift->{_current}} > 0 };

sub DESTROY { SOAP::Trace::objects('()') }

sub new {
    my $self = shift;
    my $class = ref($self) || $self;
    my $content = shift;
    SOAP::Trace::objects('()');
    return bless { _content => $content, _current => [$content] } => $class;
}

sub parts {
    my $self = shift;
    if (@_) {
        $self->context->packager->parts(@_);
        return $self;
    }
    else {
        return $self->context->packager->parts;
    }
}

sub is_multipart {
    my $self = shift;
    return defined($self->parts);
}

sub current {
    my $self = shift;
    $self->{_current} = [@_], return $self if @_;
    return wantarray ? @{$self->{_current}} : $self->{_current}->[0];
}

sub valueof {
    my $self = shift;
    local $self->{_current} = $self->{_current};
    $self->match(shift) if @_;
    return wantarray
        ? map {o_value($_)} @{$self->{_current}}
        : @{$self->{_current}} ? o_value($self->{_current}->[0]) : undef;
}

sub headerof { # SOAP::Header is the same as SOAP::Data, so just rebless it
    wantarray
        ? map { bless $_ => 'SOAP::Header' } shift->dataof(@_)
        : do { # header returned by ->dataof can be undef in scalar context
            my $header = shift->dataof(@_);
            ref $header ? bless($header => 'SOAP::Header') : undef;
        };
}

sub dataof {
    my $self = shift;
    local $self->{_current} = $self->{_current};
    $self->match(shift) if @_;
    return wantarray
        ? map {$self->_as_data($_)} @{$self->{_current}}
        : @{$self->{_current}}
            ? $self->_as_data($self->{_current}->[0])
            : undef;
}

sub namespaceuriof {
    my $self = shift;
    local $self->{_current} = $self->{_current};
    $self->match(shift) if @_;
    return wantarray
        ? map {(SOAP::Utils::splitlongname(o_lname($_)))[0]} @{$self->{_current}}
        : @{$self->{_current}} ? (SOAP::Utils::splitlongname(o_lname($self->{_current}->[0])))[0] : undef;
}

#sub _as_data {
#    my $self = shift;
#    my $pointer = shift;
#
#    SOAP::Data
#        -> new(prefix => '', name => o_qname($pointer), name => o_lname($pointer), attr => o_lattr($pointer))
#        -> set_value(o_value($pointer));
#}

sub _as_data {
    my $self = shift;
    my $node = shift;

    my $data = SOAP::Data->new( prefix => '',
        # name => o_qname has side effect: sets namespace !
        name => o_qname($node),
        name => o_lname($node),
        attr => o_lattr($node) );

    if ( defined o_child($node) ) {
        my @children;
        foreach my $child ( @{ o_child($node) } ) {
            push( @children, $self->_as_data($child) );
        }
        $data->set_value( \SOAP::Data->value(@children) );
    }
    else {
        $data->set_value( o_value($node) );
    }

    return $data;
}


sub match {
    my $self = shift;
    my $path = shift;
    $self->{_current} = [
        $path =~ s!^/!! || !@{$self->{_current}}
        ? $self->_traverse($self->{_content}, 1 => split '/' => $path)
        : map {$self->_traverse_tree(o_child($_), split '/' => $path)} @{$self->{_current}}
    ];
    return $self;
}

sub _traverse {
    my ($self, $pointer, $itself, $path, @path) = @_;

    die "Incorrect parameter" unless $itself =~/^\d+$/;

    if ($path && substr($path, 0, 1) eq '{') {
        $path = join '/', $path, shift @path while @path && $path !~ /}/;
    }

    my($op, $num) = $path =~ /^\[(<=|<|>=|>|=|!=?)?(\d+)\]$/ if defined $path;

    return $pointer unless defined $path;

    if (! $op) {
        $op = '==';
    }
    elsif ($op eq '=' || $op eq '!') {
        $op .= '=';
    }
    my $numok = defined $num && eval "$itself $op $num";
    my $nameok = (o_lname($pointer) || '') =~ /(?:^|\})$path$/ if defined $path; # name can be with namespace

    my $anynode = $path eq '';
    unless ($anynode) {
        if (@path) {
            return if defined $num && !$numok || !defined $num && !$nameok;
        }
        else {
            return $pointer if defined $num && $numok || !defined $num && $nameok;
            return;
        }
    }

    my @walk;
    push @walk, $self->_traverse_tree([$pointer], @path) if $anynode;
    push @walk, $self->_traverse_tree(o_child($pointer), $anynode ? ($path, @path) : @path);
    return @walk;
}

sub _traverse_tree {
    my ($self, $pointer, @path) = @_;

    # can be list of children or value itself. Traverse only children
    return unless ref $pointer eq 'ARRAY';

    my $itself = 1;

    grep {defined}
        map {$self->_traverse($_, $itself++, @path)}
        grep {!ref o_lattr($_) ||
            !exists o_lattr($_)->{"{$SOAP::Constants::NS_ENC}root"} ||
            o_lattr($_)->{"{$SOAP::Constants::NS_ENC}root"} ne '0'}
        @$pointer;
}

# ======================================================================

package SOAP::Deserializer;

use vars qw(@ISA);
use SOAP::Lite::Utils;
use Class::Inspector;
use URI::Escape qw{uri_unescape};

@ISA = qw(SOAP::Cloneable);

sub DESTROY { SOAP::Trace::objects('()') }

sub BEGIN {
    __PACKAGE__->__mk_accessors( qw(ids hrefs parts parser
        base xmlschemas xmlschema context) );
}

# Cache (slow) Class::Inspector results
my %_class_loaded=();

sub new {
    my $self = shift;
    return $self if ref $self;
    my $class = $self;
    SOAP::Trace::objects('()');
    return bless {
        '_ids'        => {},
        '_hrefs'      => {},
        '_parser'     => SOAP::Parser->new,
        '_xmlschemas' => {
            $SOAP::Constants::NS_APS => 'SOAP::XMLSchemaApacheSOAP::Deserializer',
#            map {
#                $_ => $SOAP::Constants::XML_SCHEMAS{$_} . '::Deserializer'
#              } keys %SOAP::Constants::XML_SCHEMAS
            map {
                $_ => 'SOAP::Lite::Deserializer::' . $SOAP::Constants::XML_SCHEMA_OF{$_}
              } keys %SOAP::Constants::XML_SCHEMA_OF

        },
    }, $class;
}

sub is_xml {
    # Added check for envelope delivery. Fairly standard with MMDF and sendmail
    # Thanks to Chris Davies
    $_[1] =~ /^\s*
}

sub baselocation {
    my $self = shift;
    my $location = shift;
    if ($location) {
        my $uri = URI->new($location);
        # make absolute location if relative
        $location = $uri->abs($self->base || 'thismessage:/')->as_string unless $uri->scheme;
    }
    return $location;
}

# Returns the envelope and populates SOAP::Packager with parts
sub decode_parts {
    my $self = shift;
    my $env = $self->context->packager->unpackage($_[0],$self->context);
    my $body = $self->parser->decode($env);
    # TODO - This shouldn't be here! This is packager specific!
    #        However this does need to pull out all the cid's
    #        to populate ids hash with.
    foreach (@{$self->context->packager->parts}) {
        my $data     = $_->bodyhandle->as_string;
        my $type     = $_->head->mime_attr('Content-Type');
        my $location = $_->head->mime_attr('Content-Location');
        my $id       = $_->head->mime_attr('Content-Id');
        $location = $self->baselocation($location);
        my $part = lc($type) eq 'text/xml' && !$SOAP::Constants::DO_NOT_PROCESS_XML_IN_MIME
            ? $self->parser->decode($data)
            : ['mimepart', {}, $data];
        # This below looks like unnecessary bloat!!!
        # I should probably dereference the mimepart, provide a callback to get the string data
        $self->ids->{$1} = $part if ($id && $id =~ m/^<([^>]+)>$/); # strip any leading and trailing brackets
        $self->ids->{$location} = $part if $location;
    }
    return $body;
}

# decode returns a parsed body in the form of an ARRAY
# each element of the ARRAY is a HASH, ARRAY or SCALAR
sub decode {
    my $self = shift->new; # this actually is important
    return $self->is_xml($_[0])
        ? $self->parser->decode($_[0])
        : $self->decode_parts($_[0]);
}

# deserialize returns a SOAP::SOM object and parses straight
# text as input
sub deserialize {
    SOAP::Trace::trace('()');
    my $self = shift->new;

    # initialize
    $self->hrefs({});
    $self->ids({});

    # If the document is XML, then ids will be empty
    # If the document is MIME, then ids will hold a list of cids
    my $parsed = $self->decode($_[0]);

    # Having this code here makes multirefs in the Body work, but multirefs
    # that reference XML fragments in a MIME part do not work.
    if (keys %{$self->ids()}) {
        $self->traverse_ids($parsed);
    }
    else {
        # delay - set ids to be traversed later in decode_object, they only get
        # traversed if an href is found that is referencing an id.
        $self->ids($parsed);
    }
    $self->decode_object($parsed);
    my $som = SOAP::SOM->new($parsed);
    $som->context($self->context); # TODO - try removing this and see if it works!
    return $som;
}

sub traverse_ids {
    my $self = shift;
    my $ref = shift;
    my($undef, $attrs, $children) = @$ref;
    #  ^^^^^^ to fix nasty error on Mac platform (Carl K. Cunningham)
    $self->ids->{$attrs->{'id'}} = $ref if exists $attrs->{'id'};
    return unless ref $children;
    for (@$children) {
        $self->traverse_ids($_)
    };
}

use constant _ATTRS => 6;
use constant _NAME => 5;

sub decode_object {
    my $self = shift;
    my $ref = shift;
    my($name, $attrs_ref, $children, $value) = @$ref;

    my %attrs = %{ $attrs_ref };

    $ref->[ _ATTRS ] = \%attrs;        # make a copy for long attributes

    use vars qw(%uris);
    local %uris = (%uris, map {
        do { (my $ns = $_) =~ s/^xmlns:?//; $ns } => delete $attrs{$_}
    } grep {/^xmlns(:|$)/} keys %attrs);

    foreach (keys %attrs) {
        next unless m/^($SOAP::Constants::NSMASK?):($SOAP::Constants::NSMASK)$/;

    $1 =~ /^[xX][mM][lL]/ ||
        $uris{$1} &&
            do {
                $attrs{SOAP::Utils::longname($uris{$1}, $2)} = do {
                    my $value = $attrs{$_};
                    $2 ne 'type' && $2 ne 'arrayType'
                        ? $value
                        : SOAP::Utils::longname($value =~ m/^($SOAP::Constants::NSMASK?):(${SOAP::Constants::NSMASK}(?:\[[\d,]*\])*)/
                            ? ($uris{$1} || die("Unresolved prefix '$1' for attribute value '$value'\n"), $2)
                            : ($uris{''} || die("Unspecified namespace for type '$value'\n"), $value)
                    );
                };
                1;
            }
            || die "Unresolved prefix '$1' for attribute '$_'\n";
  }

    # and now check the element
    my $ns = ($name =~ s/^($SOAP::Constants::NSMASK?):// ? $1 : '');
    $ref->[ _NAME ] = SOAP::Utils::longname(
        $ns
            ? ($uris{$ns} || die "Unresolved prefix '$ns' for element '$name'\n")
            : (defined $uris{''} ? $uris{''} : undef),
        $name
    );

    ($children, $value) = (undef, $children) unless ref $children;

    return $name => ($ref->[4] = $self->decode_value(
        [$ref->[ _NAME ], \%attrs, $children, $value]
    ));
}

sub decode_value {
    my $self = shift;
    my($name, $attrs, $children, $value) = @{ $_[0] };

    # check SOAP version if applicable
    use vars '$level'; local $level = $level || 0;
    if (++$level == 1) {
        my($namespace, $envelope) = SOAP::Utils::splitlongname($name);
        SOAP::Lite->soapversion($namespace) if $envelope eq 'Envelope' && $namespace;
    }

    if (exists $attrs->{"{$SOAP::Constants::NS_ENV}encodingStyle"}) {
        # check encodingStyle
        # future versions may bind deserializer to encodingStyle
        my $encodingStyle = $attrs->{"{$SOAP::Constants::NS_ENV}encodingStyle"};
        # TODO - SOAP 1.2 and 1.1 have different rules about valid encodingStyle values
        #        For example, in 1.1 - any http://schemas.xmlsoap.org/soap/encoding/*
        #        value is valid
        if (defined $encodingStyle && length($encodingStyle)) {
            my %styles = map { $_ => undef } @SOAP::Constants::SUPPORTED_ENCODING_STYLES;
            my $found = 0;
            foreach my $e (split(/ +/,$encodingStyle)) {
                if (exists $styles{$e}) {
                    $found ++;
            }
        }
        die "Unrecognized/unsupported value of encodingStyle attribute '$encodingStyle'"
            if (! $found) && !(SOAP::Lite->soapversion == 1.1 && $encodingStyle =~ /(?:^|\b)$SOAP::Constants::NS_ENC/);
    }
    }
    use vars '$arraytype'; # type of Array element specified on Array itself
    # either specified with xsi:type, or  or array element
    my ($type) = grep { defined }
        map($attrs->{$_}, sort grep {/^\{$SOAP::Constants::NS_XSI_ALL\}type$/o} keys %$attrs),
           $name =~ /^\{$SOAP::Constants::NS_ENC\}/ ? $name : $arraytype;
    local $arraytype; # it's used only for one level, we don't need it anymore

    # $name is not used here since type should be encoded as type, not as name
    my ($schema, $class) = SOAP::Utils::splitlongname($type) if $type;
    my $schemaclass = defined($schema) && $self->{ _xmlschemas }->{$schema}
        || $self;

    if (! exists $_class_loaded{$schemaclass}) {
        no strict qw(refs);
        if (! Class::Inspector->loaded($schemaclass) ) {
            eval "require $schemaclass" or die $@ if not ref $schemaclass;
        }
        $_class_loaded{$schemaclass} = undef;
    }

    # store schema that is used in parsed message
    $self->{ _xmlschema } = $schema if ($schema) && $schema =~ /XMLSchema/;

   # don't use class/type if anyType/ur-type is specified on wire
    undef $class
        if $schemaclass->can('anyTypeValue')
            && $schemaclass->anyTypeValue eq $class;

    my $method = 'as_' . ($class || '-'); # dummy type if not defined
    $class =~ s/__|\./::/g if $class;

    my $id = $attrs->{id};
    if (defined $id && exists $self->hrefs->{$id}) {
        return $self->hrefs->{$id};
    }
    elsif (exists $attrs->{href}) {
        (my $id = delete $attrs->{href}) =~ s/^(#|cid:|uuid:)?//;
        my $type=$1;
        $id=uri_unescape($id) if (defined($type) and $type eq 'cid:');
        # convert to absolute if not internal '#' or 'cid:'
        $id = $self->baselocation($id) unless $type;
        return $self->hrefs->{$id} if exists $self->hrefs->{$id};
        # First time optimization. we don't traverse IDs unless asked for it.
        # This is where traversing id's is delayed from before
        #   - the first time through - ids should contain a copy of the parsed XML
        #     structure! seems silly to make so many copies
        my $ids = $self->ids;
        if (ref($ids) ne 'HASH') {
            $self->ids({});            # reset list of ids first time through
            $self->traverse_ids($ids);
        }
        if (exists($self->ids->{$id})) {
            my $obj = ($self->decode_object(delete($self->ids->{$id})))[1];
            return $self->hrefs->{$id} = $obj;
        }
        else {
            die "Unresolved (wrong?) href ($id) in element '$name'\n";
        }
    }

    return undef if grep {
        /^$SOAP::Constants::NS_XSI_NILS$/ && do {
             my $class = $self->xmlschemas->{ $1 || $2 };
             eval "require $class" or die @$;;
             $class->as_undef($attrs->{$_})
        }
    } keys %$attrs;

    # try to handle with typecasting
    my $res = $self->typecast($value, $name, $attrs, $children, $type);
    return $res if defined $res;

    # ok, continue with others
    if (exists $attrs->{"{$SOAP::Constants::NS_ENC}arrayType"}) {
        my $res = [];
        $self->hrefs->{$id} = $res if defined $id;

        # check for arrayType which could be [1], [,2][5] or []
        # [,][1] will NOT be allowed right now (multidimensional sparse array)
        my($type, $multisize) = $attrs->{"{$SOAP::Constants::NS_ENC}arrayType"}
            =~ /^(.+)\[(\d*(?:,\d+)*)\](?:\[(?:\d+(?:,\d+)*)\])*$/
                or die qq!Unrecognized/unsupported format of arrayType attribute '@{[$attrs->{"{$SOAP::Constants::NS_ENC}arrayType"}]}'\n!;

        my @dimensions = map { $_ || undef } split /,/, $multisize;
        my $size = 1;
        foreach (@dimensions) { $size *= $_ || 0 }

        # TODO ähm, shouldn't this local be my?
        local $arraytype = $type;

        # multidimensional
        if ($multisize =~ /,/) {
            @$res = splitarray(
                [@dimensions],
                [map { scalar(($self->decode_object($_))[1]) } @{$children || []}]
            );
        }
        # normal
        else {
            @$res = map { scalar(($self->decode_object($_))[1]) } @{$children || []};
        }

        # sparse (position)
        if (ref $children && exists SOAP::Utils::o_lattr($children->[0])->{"{$SOAP::Constants::NS_ENC}position"}) {
            my @new;
            for (my $pos = 0; $pos < @$children; $pos++) {
                # TBD implement position in multidimensional array
                my($position) = SOAP::Utils::o_lattr($children->[$pos])->{"{$SOAP::Constants::NS_ENC}position"} =~ /^\[(\d+)\]$/
                    or die "Position must be specified for all elements of sparse array\n";
                $new[$position] = $res->[$pos];
            }
            @$res = @new;
        }

        # partially transmitted (offset)
        # TBD implement offset in multidimensional array
        my($offset) = $attrs->{"{$SOAP::Constants::NS_ENC}offset"} =~ /^\[(\d+)\]$/
            if exists $attrs->{"{$SOAP::Constants::NS_ENC}offset"};
        unshift(@$res, (undef) x $offset) if $offset;

        die "Too many elements in array. @{[scalar@$res]} instead of claimed $multisize ($size)\n"
            if $multisize && $size < @$res;

        # extend the array if number of elements is specified
        $#$res = $dimensions[0]-1 if defined $dimensions[0] && @$res < $dimensions[0];

        return defined $class && $class ne 'Array' ? bless($res => $class) : $res;

    }
    elsif ($name =~ /^\{$SOAP::Constants::NS_ENC\}Struct$/
        || !$schemaclass->can($method)
           && (ref $children || defined $class && $value =~ /^\s*$/)) {
        my $res = {};
        $self->hrefs->{$id} = $res if defined $id;

        # Patch code introduced in 0.65 - deserializes array properly
        # Decode each element of the struct.
        my %child_count_of = ();
        foreach my $child (@{$children || []}) {
            my ($child_name, $child_value) = $self->decode_object($child);
            # Store the decoded element in the struct.  If the element name is
            # repeated, replace the previous scalar value with a new array
            # containing both values.
            if (not $child_count_of{$child_name}) {
                # first time to see this value: use scalar
                $res->{$child_name} = $child_value;
            }
            elsif ($child_count_of{$child_name} == 1) {
                # second time to see this value: convert scalar to array
                $res->{$child_name} = [ $res->{$child_name}, $child_value ];
            }
            else {
                # already have an array: append to it
                push @{$res->{$child_name}}, $child_value;
            }
            $child_count_of{$child_name}++;
        }
        # End patch code

        return defined $class && $class ne 'SOAPStruct' ? bless($res => $class) : $res;
    }
    else {
        my $res;
        if (my $method_ref = $schemaclass->can($method)) {
            $res = $method_ref->($self, $value, $name, $attrs, $children, $type);
        }
        else {
            $res = $self->typecast($value, $name, $attrs, $children, $type);
            $res = $class ? die "Unrecognized type '$type'\n" : $value
                unless defined $res;
        }
        $self->hrefs->{$id} = $res if defined $id;
        return $res;
    }
}

sub splitarray {
    my @sizes = @{+shift};
    my $size = shift @sizes;
    my $array = shift;

    return splice(@$array, 0, $size) unless @sizes;
    my @array = ();
    push @array, [
        splitarray([@sizes], $array)
    ] while @$array && (!defined $size || $size--);
    return @array;
}

sub typecast { } # typecast is called for both objects AND scalar types
                 # check ref of the second parameter (first is the object)
                 # return undef if you don't want to handle it

# ======================================================================

package SOAP::Client;


use SOAP::Lite::Utils;

$VERSION = $SOAP::Lite::VERSION;
sub BEGIN {
    __PACKAGE__->__mk_accessors(qw(endpoint code message
        is_success status options));
}

# ======================================================================

package SOAP::Server::Object;

sub gen_id; *gen_id = \&SOAP::Serializer::gen_id;

my %alive;
my %objects;

sub objects_by_reference {
    shift;
    while (@_) {
        @alive{shift()} = ref $_[0]
            ? shift
            : sub {
                $_[1]-$_[$_[5] ? 5 : 4] > $SOAP::Constants::OBJS_BY_REF_KEEPALIVE
            }
    }
    keys %alive;
}

sub reference {
    my $self = shift;
    my $stamp = time;
    my $object = shift;
    my $id = $stamp . $self->gen_id($object);

    # this is code for garbage collection
    my $time = time;
    my $type = ref $object;
    my @objects = grep { $objects{$_}->[1] eq $type } keys %objects;
    for (grep { $alive{$type}->(scalar @objects, $time, @{$objects{$_}}) } @objects) {
        delete $objects{$_};
    }

    $objects{$id} = [$object, $type, $stamp];
    bless { id => $id } => ref $object;
}

sub references {
    my $self = shift;
    return @_ unless %alive; # small optimization
    return map {
        ref($_) && exists $alive{ref $_}
            ? $self->reference($_)
            : $_
    } @_;
}

sub object {
    my $self = shift;
    my $class = ref($self) || $self;
    my $object = shift;
    return $object unless ref($object) && $alive{ref $object} && exists $object->{id};

    my $reference = $objects{$object->{id}};
    die "Object with specified id couldn't be found\n" unless ref $reference->[0];

    $reference->[3] = time; # last access time
    return $reference->[0]; # reference to actual object
}

sub objects {
    my $self = shift;
    return @_ unless %alive; # small optimization
    return map {
        ref($_) && exists $alive{ref $_} && exists $_->{id}
            ? $self->object($_)
            : $_
    } @_;
}

# ======================================================================

package SOAP::Server::Parameters;

sub byNameOrOrder {
    unless (UNIVERSAL::isa($_[-1] => 'SOAP::SOM')) {
        warn "Last parameter is expected to be envelope\n" if $^W;
        pop;
        return @_;
    }
    my $params = pop->method;
    my @mandatory = ref $_[0] eq 'ARRAY'
        ? @{shift()}
        : die "list of parameters expected as the first parameter for byName";
    my $byname = 0;
    my @res = map { $byname += exists $params->{$_}; $params->{$_} } @mandatory;
    return $byname
        ? @res
        : @_;
}

sub byName {
  unless (UNIVERSAL::isa($_[-1] => 'SOAP::SOM')) {
    warn "Last parameter is expected to be envelope\n" if $^W;
    pop;
    return @_;
  }
  return @{pop->method}{ref $_[0] eq 'ARRAY' ? @{shift()} : die "list of parameters expected as the first parameter for byName"};
}

# ======================================================================

package SOAP::Server;

use Carp ();
use Scalar::Util qw(weaken);
sub DESTROY { SOAP::Trace::objects('()') }

sub initialize {
    return (
        packager => SOAP::Packager::MIME->new,
        transport => SOAP::Transport->new,
        serializer => SOAP::Serializer->new,
        deserializer => SOAP::Deserializer->new,
        on_action => sub { ; },
        on_dispatch => sub {
            return;
        },
    );
}

sub new {
    my $self = shift;
    return $self if ref $self;

    unless (ref $self) {
        my $class = $self;
        my(@params, @methods);

        while (@_) {
            my($method, $params) = splice(@_,0,2);
            $class->can($method)
                ? push(@methods, $method, $params)
                : $^W && Carp::carp "Unrecognized parameter '$method' in new()";
        }

        $self = bless {
            _dispatch_to   => [],
            _dispatch_with => {},
            _dispatched    => [],
            _action        => '',
            _options       => {},
        } => $class;
        unshift(@methods, $self->initialize);
        no strict qw(refs);
        while (@methods) {
            my($method, $params) = splice(@methods,0,2);
            $self->$method(ref $params eq 'ARRAY' ? @$params : $params)
        }
        SOAP::Trace::objects('()');
    }

    Carp::carp "Odd (wrong?) number of parameters in new()"
        if $^W && (@_ & 1);

    no strict qw(refs);
    while (@_) {
        my($method, $params) = splice(@_,0,2);
        $self->can($method)
            ? $self->$method(ref $params eq 'ARRAY' ? @$params : $params)
            : $^W && Carp::carp "Unrecognized parameter '$method' in new()"
    }

    return $self;
}

sub init_context {
    my $self = shift;
    $self->{'_deserializer'}->{'_context'} = $self;
    # weaken circular reference to avoid a memory hole
    weaken($self->{'_deserializer'}->{'_context'});

    $self->{'_serializer'}->{'_context'} = $self;
    # weaken circular reference to avoid a memory hole
    weaken($self->{'_serializer'}->{'_context'});
}

sub BEGIN {
    no strict 'refs';
    for my $method (qw(serializer deserializer transport)) {
        my $field = '_' . $method;
        *$method = sub {
            my $self = shift->new();
            if (@_) {
                my $context = $self->{$field}->{'_context'}; # save the old context
                $self->{$field} = shift;
                $self->{$field}->{'_context'} = $context;    # restore the old context
                return $self;
            }
            else {
                return $self->{$field};
            }
        }
    }

    for my $method (qw(action myuri options dispatch_with packager)) {
    my $field = '_' . $method;
        *$method = sub {
            my $self = shift->new();
            (@_)
                ? do {
                    $self->{$field} = shift;
                    return $self;
                }
                : return $self->{$field};
        }
    }
    for my $method (qw(on_action on_dispatch)) {
        my $field = '_' . $method;
        *$method = sub {
            my $self = shift->new;
            # my $self = shift;
            return $self->{$field} unless @_;
            local $@;
            # commented out because that 'eval' was unsecure
            # > ref $_[0] eq 'CODE' ? shift : eval shift;
            # Am I paranoid enough?
            $self->{$field} = shift;
            Carp::croak $@ if $@;
            Carp::croak "$method() expects subroutine (CODE) or string that evaluates into subroutine (CODE)"
                unless ref $self->{$field} eq 'CODE';
            return $self;
        }
    }

    #    __PACKAGE__->__mk_accessors( qw(dispatch_to) );
    for my $method (qw(dispatch_to)) {
        my $field = '_' . $method;
        *$method = sub {
            my $self = shift->new;
            # my $self = shift;
            (@_)
                ? do {
                    $self->{$field} = [@_];
                    return $self;
                }
                : return @{ $self->{$field} };
        }
    }
}

sub objects_by_reference {
    my $self = shift;
    $self = $self->new() if not ref $self;
    @_
        ? (SOAP::Server::Object->objects_by_reference(@_), return $self)
        : SOAP::Server::Object->objects_by_reference;
}

sub dispatched {
    my $self = shift;
    $self = $self->new() if not ref $self;
    @_
        ? (push(@{$self->{_dispatched}}, @_), return $self)
        : return @{$self->{_dispatched}};
}

sub find_target {
    my $self = shift;
    my $request = shift;

    # try to find URI/method from on_dispatch call first
    my($method_uri, $method_name) = $self->on_dispatch->($request);

    # if nothing there, then get it from envelope itself
    $request->match((ref $request)->method);
    ($method_uri, $method_name) = ($request->namespaceuriof || '', $request->dataof->name)
        unless $method_name;

    $self->on_action->(my $action = $self->action, $method_uri, $method_name);

    # check to avoid security vulnerability: Protected->Unprotected::method(@parameters)
    # see for more details: http://www.phrack.org/phrack/58/p58-0x09
    die "Denied access to method ($method_name)\n" unless $method_name =~ /^\w+$/;

    my ($class, $static);
    # try to bind directly
    if (defined($class = $self->dispatch_with->{$method_uri}
            || $self->dispatch_with->{$action || ''}
            || (defined($action) && $action =~ /^"(.+)"$/
                ? $self->dispatch_with->{$1}
                : undef))) {
        # return object, nothing else to do here
        return ($class, $method_uri, $method_name) if ref $class;
        $static = 1;
    }
    else {
        die "URI path shall map to class" unless defined ($class = URI->new($method_uri)->path);

        for ($class) { s!^/|/$!!g; s!/!::!g; s/^$/main/; }
        die "Failed to access class ($class)" unless $class =~ /^(\w[\w:]*)$/;

        my $fullname = "$class\::$method_name";
        foreach ($self->dispatch_to) {
            return ($_, $method_uri, $method_name) if ref eq $class; # $OBJECT
            next if ref;                                   # skip other objects
            # will ignore errors, because it may complain on
            # d:\foo\bar, which is PATH and not regexp
            eval {
                $static ||= $class =~ /^$_$/           # MODULE
                    || $fullname =~ /^$_$/             # MODULE::method
                    || $method_name =~ /^$_$/ && ($class eq 'main'); # method ('main' assumed)
            };
        }
    }

    no strict 'refs';

# TODO - sort this mess out:
# The task is to test whether the class in question has already been loaded.
#
# SOAP::Lite 0.60:
#  unless (defined %{"${class}::"}) {
# Patch to SOAP::Lite 0.60:
# The following patch does not work for packages defined within a BEGIN block
#  unless (exists($INC{join '/', split /::/, $class.'.pm'})) {
# Combination of 0.60 and patch did not work reliably, either.
#
# Now we do the following: Check whether the class is main (always loaded)
# or the class implements the method in question
# or the package exists as file in %INC.
#
# This is still sort of a hack - but I don't know anything better
# If you have some idea, please help me out...
#
    unless (($class eq 'main') || $class->can($method_name)
        || exists($INC{join '/', split /::/, $class . '.pm'})) {

        # allow all for static and only specified path for dynamic bindings
        local @INC = (($static ? @INC : ()), grep {!ref && m![/\\.]!} $self->dispatch_to());
        eval 'local $^W; ' . "require $class";
        die "Failed to access class ($class): $@" if $@;
        $self->dispatched($class) unless $static;
    }

    die "Denied access to method ($method_name) in class ($class)"
        unless $static || grep {/^$class$/} $self->dispatched;

    return ($class, $method_uri, $method_name);
}

sub handle {
    SOAP::Trace::trace('()');
    my $self = shift;
    $self = $self->new if !ref $self; # inits the server when called in a static context
    $self->init_context();
    # we want to restore it when we are done
    local $SOAP::Constants::DEFAULT_XML_SCHEMA
        = $SOAP::Constants::DEFAULT_XML_SCHEMA;

    # SOAP version WILL NOT be restored when we are done.
    # is it problem?

    my $result = eval {
        local $SIG{__DIE__};
        # why is this here:
        $self->serializer->soapversion(1.1);
        my $request = eval { $self->deserializer->deserialize($_[0]) };

        die SOAP::Fault
            ->faultcode($SOAP::Constants::FAULT_VERSION_MISMATCH)
            ->faultstring($@)
                if $@ && $@ =~ /^$SOAP::Constants::WRONG_VERSION/;

        die "Application failed during request deserialization: $@" if $@;
        my $som = ref $request;
        die "Can't find root element in the message"
            unless $request->match($som->envelope);
        $self->serializer->soapversion(SOAP::Lite->soapversion);
        $self->serializer->xmlschema($SOAP::Constants::DEFAULT_XML_SCHEMA
            = $self->deserializer->xmlschema)
                if $self->deserializer->xmlschema;

        die SOAP::Fault
            ->faultcode($SOAP::Constants::FAULT_MUST_UNDERSTAND)
            ->faultstring("Unrecognized header has mustUnderstand attribute set to 'true'")
            if !$SOAP::Constants::DO_NOT_CHECK_MUSTUNDERSTAND &&
                grep {
                    $_->mustUnderstand
                    && (!$_->actor || $_->actor eq $SOAP::Constants::NEXT_ACTOR)
                } $request->dataof($som->headers);

        die "Can't find method element in the message"
            unless $request->match($som->method);
        # TODO - SOAP::Dispatcher plugs in here
        # my $handler = $self->dispatcher->find_handler($request);
        my($class, $method_uri, $method_name) = $self->find_target($request);
        my @results = eval {
            local $^W;
            my @parameters = $request->paramsin;

            # SOAP::Trace::dispatch($fullname);
            SOAP::Trace::parameters(@parameters);

            push @parameters, $request
                if UNIVERSAL::isa($class => 'SOAP::Server::Parameters');

            no strict qw(refs);
            SOAP::Server::Object->references(
                defined $parameters[0]
                && ref $parameters[0]
                && UNIVERSAL::isa($parameters[0] => $class)
                    ? do {
                        my $object = shift @parameters;
                        SOAP::Server::Object->object(ref $class
                            ? $class
                            : $object
                        )->$method_name(SOAP::Server::Object->objects(@parameters)),

                        # send object back as a header
                        # preserve name, specify URI
                        SOAP::Header
                            ->uri($SOAP::Constants::NS_SL_HEADER => $object)
                            ->name($request->dataof($som->method.'/[1]')->name)
                    } # end do block

                    # SOAP::Dispatcher will plug-in here as well
                    # $handler->dispatch(SOAP::Server::Object->objects(@parameters)
                    : $class->$method_name(SOAP::Server::Object->objects(@parameters)) );
        }; # end eval block
        SOAP::Trace::result(@results);

        # let application errors pass through with 'Server' code
        die ref $@
            ? $@
            : $@ =~ /^Can\'t locate object method "$method_name"/
                ? "Failed to locate method ($method_name) in class ($class)"
                : SOAP::Fault->faultcode($SOAP::Constants::FAULT_SERVER)->faultstring($@)
                    if $@;

        my $result = $self->serializer
            ->prefix('s') # distinguish generated element names between client and server
            ->uri($method_uri)
            ->envelope(response => $method_name . 'Response', @results);
        return $result;
    };

    # void context
    return unless defined wantarray;

    # normal result
    return $result unless $@;

    # check fails, something wrong with message
    return $self->make_fault($SOAP::Constants::FAULT_CLIENT, $@) unless ref $@;

    # died with SOAP::Fault
    return $self->make_fault($@->faultcode   || $SOAP::Constants::FAULT_SERVER,
        $@->faultstring || 'Application error',
        $@->faultdetail, $@->faultactor)
    if UNIVERSAL::isa($@ => 'SOAP::Fault');

    # died with complex detail
    return $self->make_fault($SOAP::Constants::FAULT_SERVER, 'Application error' => $@);

} # end of handle()

sub make_fault {
    my $self = shift;
    my($code, $string, $detail, $actor) = @_;
    $self->serializer->fault($code, $string, $detail, $actor || $self->myuri);
}

# ======================================================================

package SOAP::Trace;

use Carp ();

my @list = qw(
    transport   dispatch    result
    parameters  headers     objects
    method      fault       freeform
    trace       debug);
{
    no strict 'refs';
    for (@list) {
        *$_ = sub {}
    }
}

sub defaultlog {
    my $caller = (caller(1))[3]; # the 4th element returned by caller is the subroutine name
    $caller = (caller(2))[3] if $caller =~ /eval/;
    chomp(my $msg = join ' ', @_);
    printf STDERR "%s: %s\n", $caller, $msg;
}

sub import {
    no strict 'refs';
    no warnings qw{ redefine }; # suppress warnings about redefining
    my $pack = shift;
    my(@notrace, @symbols);
    for (@_) {
        if (ref eq 'CODE') {
            my $call = $_;
            foreach (@symbols) { *$_ = sub { $call->(@_) } }
            @symbols = ();
        }
        else {
            local $_ = $_;
            my $minus = s/^-//;
            my $all = $_ eq 'all';
            Carp::carp "Illegal symbol for tracing ($_)" unless $all || $pack->can($_);
            $minus ? push(@notrace, $all ? @list : $_) : push(@symbols, $all ? @list : $_);
        }
    }
    foreach (@symbols) { *$_ = \&defaultlog }
    foreach (@notrace) { *$_ = sub {} }
}

# ======================================================================

package SOAP::Custom::XML::Data;

use vars qw(@ISA $AUTOLOAD);
@ISA = qw(SOAP::Data);

use overload fallback => 1, '""' => sub { shift->value };

sub _compileit {
    no strict 'refs';
    my $method = shift;
    *$method = sub {
        return __PACKAGE__->SUPER::name($method => $_[0]->attr->{$method})
            if exists $_[0]->attr->{$method};
        my @elems = grep {
            ref $_ && UNIVERSAL::isa($_ => __PACKAGE__)
            && $_->SUPER::name =~ /(^|:)$method$/
        } $_[0]->value;
        return wantarray? @elems : $elems[0];
    };
}

sub BEGIN { foreach (qw(name type import use)) { _compileit($_) } }

sub AUTOLOAD {
    my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2);
    return if $method eq 'DESTROY';

    _compileit($method);
    goto &$AUTOLOAD;
}

# ======================================================================

package SOAP::Custom::XML::Deserializer;

use vars qw(@ISA);
@ISA = qw(SOAP::Deserializer);

sub decode_value {
    my $self = shift;
    my $ref = shift;
    my($name, $attrs, $children, $value) = @$ref;
    # base class knows what to do with it
    return $self->SUPER::decode_value($ref) if exists $attrs->{href};

    SOAP::Custom::XML::Data
        -> SOAP::Data::name($name)
        -> attr($attrs)
        -> set_value(ref $children && @$children
            ? map(scalar(($self->decode_object($_))[1]), @$children)
            : $value);
}

# ======================================================================

package SOAP::Schema::Deserializer;

use vars qw(@ISA);
@ISA = qw(SOAP::Custom::XML::Deserializer);

# ======================================================================

package SOAP::Schema::WSDL;

use vars qw(%imported @ISA);
@ISA = qw(SOAP::Schema);

sub new {
    my $self = shift;

    unless (ref $self) {
        my $class = $self;
        $self = $class->SUPER::new(@_);
    }
    return $self;
}

sub base {
    my $self = shift->new;
    @_
        ? ($self->{_base} = shift, return $self)
        : return $self->{_base};
}

sub import {
    my $self = shift->new;
    my $s = shift;
    my $base = shift || $self->base || die "Missing base argument for ", __PACKAGE__, "\n";

    my @a = $s->import;
    local %imported = %imported;
    foreach (@a) {
        next unless $_->location;
        my $location = URI->new_abs($_->location->value, $base)->as_string;
        if ($imported{$location}++) {
            warn "Recursion loop detected in service description from '$location'. Ignored\n" if $^W;
            return $s;
        }
        my $root = $self->import(
            $self->deserializer->deserialize(
                $self->access($location)
            )->root, $location);

        $root->SOAP::Data::name eq 'definitions' ? $s->set_value($s->value, $root->value) :
        $root->SOAP::Data::name eq 'schema' ? do { # add  element if there is no one
        $s->set_value($s->value, $self->deserializer->deserialize('')->root) unless $s->types;
        $s->types->set_value($s->types->value, $root) } :
        die "Don't know what to do with '@{[$root->SOAP::Data::name]}' in schema imported from '$location'\n";
    }

    # return the parsed WSDL file
    $s;
}

# TODO - This is woefully incomplete!
sub parse_schema_element {
    my $element = shift;
    # Current element is a complex type
    if (defined($element->complexType)) {
        my @elements = ();
        if (defined($element->complexType->sequence)) {

            foreach my $e ($element->complexType->sequence->element) {
                push @elements,parse_schema_element($e);
            }
        }
        return @elements;
    }
    elsif ($element->simpleType) {
    }
    else {
        return $element;
    }
}

sub parse {
    my $self = shift->new;
    my($s, $service, $port) = @_;
    my @result;

    # handle imports
    $self->import($s);

    # handle descriptions without , aka tModel-type descriptions
    my @services = $s->service;
    my $tns = $s->{'_attr'}->{'targetNamespace'};
    # if there is no  element we'll provide it
    @services = $self->deserializer->deserialize(<<"FAKE")->root->service unless @services;





FAKE

    my $has_warned = 0;
    foreach (@services) {
        my $name = $_->name;
        next if $service && $service ne $name;
        my %services;
        foreach ($_->port) {
            next if $port && $port ne $_->name;
            my $binding = SOAP::Utils::disqualify($_->binding);
            my $endpoint = ref $_->address ? $_->address->location : undef;
            foreach ($s->binding) {
                # is this a SOAP binding?
                next unless grep { $_->uri eq 'http://schemas.xmlsoap.org/wsdl/soap/' } $_->binding;
                next unless $_->name eq $binding;
                my $default_style = $_->binding->style;
                my $porttype = SOAP::Utils::disqualify($_->type);
                foreach ($_->operation) {
                    my $opername = $_->name;
                    $services{$opername} = {}; # should be initialized in 5.7 and after
                    my $soapaction = $_->operation->soapAction;
                    my $invocationStyle = $_->operation->style || $default_style || "rpc";
                    my $encodingStyle = $_->input->body->use || "encoded";
                    my $namespace = $_->input->body->namespace || $tns;
                    my @parts;
                    foreach ($s->portType) {
                        next unless $_->name eq $porttype;
                        foreach ($_->operation) {
                            next unless $_->name eq $opername;
                            my $inputmessage = SOAP::Utils::disqualify($_->input->message);
                            foreach my $msg ($s->message) {
                                next unless $msg->name eq $inputmessage;
                                if ($invocationStyle eq "document" && $encodingStyle eq "literal") {
#                  warn "document/literal support is EXPERIMENTAL in SOAP::Lite"
#                  if !$has_warned && ($has_warned = 1);
                                    my ($input_ns,$input_name) = SOAP::Utils::splitqname($msg->part->element);
                                    foreach my $schema ($s->types->schema) {
                                        foreach my $element ($schema->element) {
                                            next unless $element->name eq $input_name;
                                            push @parts,parse_schema_element($element);
                                        }
                                        $services{$opername}->{parameters} = [ @parts ];
                                    }
                                }
                                else {
                                    # TODO - support all combinations of doc|rpc/lit|enc.
                                    #warn "$invocationStyle/$encodingStyle is not supported in this version of SOAP::Lite";
                                    @parts = $msg->part;
                                    $services{$opername}->{parameters} = [ @parts ];
                                }
                            }
                        }

                    for ($services{$opername}) {
                        $_->{endpoint}   = $endpoint;
                        $_->{soapaction} = $soapaction;
                        $_->{namespace}  = $namespace;
                        # $_->{parameters} = [@parts];
                    }
                }
            }
        }
    }
    # fix nonallowed characters in package name, and add 's' if started with digit
    for ($name) { s/\W+/_/g; s/^(\d)/s$1/ }
    push @result, $name => \%services;
    }
    return @result;
}

# ======================================================================

# Naming? SOAP::Service::Schema?
package SOAP::Schema;

use Carp ();

sub DESTROY { SOAP::Trace::objects('()') }

sub new {
    my $self = shift;
    return $self if ref $self;
    unless (ref $self) {
        my $class = $self;
        require LWP::UserAgent;
        $self = bless {
            '_deserializer' => SOAP::Schema::Deserializer->new,
            '_useragent'    => LWP::UserAgent->new,
        }, $class;

        SOAP::Trace::objects('()');
    }

    Carp::carp "Odd (wrong?) number of parameters in new()" if $^W && (@_ & 1);
    no strict qw(refs);
    while (@_) {
        my $method = shift;
        $self->$method(shift) if $self->can($method)
    }

    return $self;
}

sub schema {
    warn "SOAP::Schema->schema has been deprecated. "
        . "Please use SOAP::Schema->schema_url instead.";
    return shift->schema_url(@_);
}

sub BEGIN {
    no strict 'refs';
    for my $method (qw(deserializer schema_url services useragent stub cache_dir cache_ttl)) {
        my $field = '_' . $method;
        *$method = sub {
            my $self = shift->new;
            @_ ? ($self->{$field} = shift, return $self) : return $self->{$field};
        }
    }
}

sub parse {
    my $self = shift;
    my $s = $self->deserializer->deserialize($self->access)->root;
    # here should be something that defines what schema description we want to use
    $self->services({SOAP::Schema::WSDL->base($self->schema_url)->useragent($self->useragent)->parse($s, @_)});

}

sub refresh_cache {
    my $self = shift;
    my ($filename,$contents) = @_;
    open CACHE,">$filename" or Carp::croak "Could not open cache file for writing: $!";
    print CACHE $contents;
    close CACHE;
}

sub load {
    my $self = shift->new;
    local $^W; # suppress warnings about redefining
    foreach (keys %{$self->services || Carp::croak 'Nothing to load. Schema is not specified'}) {
        # TODO - check age of cached file, and delete if older than configured amount
        if ($self->cache_dir) {
            my $cached_file = File::Spec->catfile($self->cache_dir,$_.".pm");
            my $ttl = $self->cache_ttl || $SOAP::Constants::DEFAULT_CACHE_TTL;
            open (CACHE, "<$cached_file");
            my @stat = stat($cached_file) unless eof(CACHE);
            close CACHE;
            if (@stat) {
                # Cache exists
                my $cache_lived = time() - $stat[9];
                if ($ttl > 0 && $cache_lived > $ttl) {
                    $self->refresh_cache($cached_file,$self->generate_stub($_));
                }
            }
            else {
                # Cache doesn't exist
                $self->refresh_cache($cached_file,$self->generate_stub($_));
            }
            push @INC,$self->cache_dir;
            eval "require $_" or Carp::croak "Could not load cached file: $@";
        }
        else {
            eval $self->generate_stub($_) or Carp::croak "Bad stub: $@";
        }
    }
    $self;
}

sub access {
    my $self = shift->new;
    my $url = shift || $self->schema_url || Carp::croak 'Nothing to access. URL is not specified';
    $self->useragent->env_proxy if $ENV{'HTTP_proxy'};

    my $req = HTTP::Request->new(GET => $url);
    $req->proxy_authorization_basic($ENV{'HTTP_proxy_user'}, $ENV{'HTTP_proxy_pass'})
        if ($ENV{'HTTP_proxy_user'} && $ENV{'HTTP_proxy_pass'});

    my $resp = $self->useragent->request($req);
    $resp->is_success ? $resp->content : die "Service description '$url' can't be loaded: ",  $resp->status_line, "\n";
}

sub generate_stub {
    my $self = shift->new;
    my $package = shift;
    my $services = $self->services->{$package};
    my $schema_url = $self->schema_url;

    $self->{'_stub'} = <<"EOP";
package $package;
# Generated by SOAP::Lite (v$SOAP::Lite::VERSION) for Perl -- soaplite.com
# Copyright (C) 2000-2006 Paul Kulchenko, Byrne Reese
# -- generated at [@{[scalar localtime]}]
EOP
    $self->{'_stub'} .= "# -- generated from $schema_url\n" if $schema_url;
    $self->{'_stub'} .= 'my %methods = ('."\n";
    foreach my $service (keys %$services) {
        $self->{'_stub'} .= "'$service' => {\n";
        foreach (qw(endpoint soapaction namespace)) {
            $self->{'_stub'} .= "    $_ => '".$services->{$service}{$_}."',\n";
        }
        $self->{'_stub'} .= "    parameters => [\n";
        foreach (@{$services->{$service}{parameters}}) {
            # This is a workaround for https://sourceforge.net/tracker/index.php?func=detail&aid=2001592&group_id=66000&atid=513017
            next unless ref $_;
            $self->{'_stub'} .= "      SOAP::Data->new(name => '".$_->name."', type => '".$_->type."', attr => {";
            $self->{'_stub'} .= do {
                my %attr = %{$_->attr};
                join(', ', map {"'$_' => '$attr{$_}'"}
                    grep {/^xmlns:(?!-)/}
                        keys %attr);
            };
            $self->{'_stub'} .= "}),\n";
        }
        $self->{'_stub'} .= "    ], # end parameters\n";
        $self->{'_stub'} .= "  }, # end $service\n";
    }
    $self->{'_stub'} .= "); # end my %methods\n";
    $self->{'_stub'} .= <<'EOP';

use SOAP::Lite;
use Exporter;
use Carp ();

use vars qw(@ISA $AUTOLOAD @EXPORT_OK %EXPORT_TAGS);
@ISA = qw(Exporter SOAP::Lite);
@EXPORT_OK = (keys %methods);
%EXPORT_TAGS = ('all' => [@EXPORT_OK]);

sub _call {
    my ($self, $method) = (shift, shift);
    my $name = UNIVERSAL::isa($method => 'SOAP::Data') ? $method->name : $method;
    my %method = %{$methods{$name}};
    $self->proxy($method{endpoint} || Carp::croak "No server address (proxy) specified")
        unless $self->proxy;
    my @templates = @{$method{parameters}};
    my @parameters = ();
    foreach my $param (@_) {
        if (@templates) {
            my $template = shift @templates;
            my ($prefix,$typename) = SOAP::Utils::splitqname($template->type);
            my $method = 'as_'.$typename;
            # TODO - if can('as_'.$typename) {...}
            my $result = $self->serializer->$method($param, $template->name, $template->type, $template->attr);
            push(@parameters, $template->value($result->[2]));
        }
        else {
            push(@parameters, $param);
        }
    }
    $self->endpoint($method{endpoint})
       ->ns($method{namespace})
       ->on_action(sub{qq!"$method{soapaction}"!});
EOP
    my $namespaces = $self->deserializer->ids->[1];
    foreach my $key (keys %{$namespaces}) {
        my ($ns,$prefix) = SOAP::Utils::splitqname($key);
        $self->{'_stub'} .= '  $self->serializer->register_ns("'.$namespaces->{$key}.'","'.$prefix.'");'."\n"
            if (defined $ns && ($ns eq "xmlns"));
    }
    $self->{'_stub'} .= <<'EOP';
    my $som = $self->SUPER::call($method => @parameters);
    if ($self->want_som) {
        return $som;
    }
    UNIVERSAL::isa($som => 'SOAP::SOM') ? wantarray ? $som->paramsall : $som->result : $som;
}

sub BEGIN {
    no strict 'refs';
    for my $method (qw(want_som)) {
        my $field = '_' . $method;
        *$method = sub {
            my $self = shift->new;
            @_ ? ($self->{$field} = shift, return $self) : return $self->{$field};
        }
    }
}
no strict 'refs';
for my $method (@EXPORT_OK) {
    my %method = %{$methods{$method}};
    *$method = sub {
        my $self = UNIVERSAL::isa($_[0] => __PACKAGE__)
            ? ref $_[0]
                ? shift # OBJECT
                # CLASS, either get self or create new and assign to self
                : (shift->self || __PACKAGE__->self(__PACKAGE__->new))
            # function call, either get self or create new and assign to self
            : (__PACKAGE__->self || __PACKAGE__->self(__PACKAGE__->new));
        $self->_call($method, @_);
    }
}

sub AUTOLOAD {
    my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2);
    return if $method eq 'DESTROY' || $method eq 'want_som';
    die "Unrecognized method '$method'. List of available method(s): @EXPORT_OK\n";
}

1;
EOP
    return $self->stub;
}

# ======================================================================

package SOAP;

use vars qw($AUTOLOAD);
require URI;

my $soap; # shared between SOAP and SOAP::Lite packages

{
    no strict 'refs';
    *AUTOLOAD = sub {
        local($1,$2);
        my($package, $method) = $AUTOLOAD =~ m/(?:(.+)::)([^:]+)$/;
        return if $method eq 'DESTROY';

        my $soap = ref $_[0] && UNIVERSAL::isa($_[0] => 'SOAP::Lite')
            ? $_[0]
            : $soap
                || die "SOAP:: prefix shall only be used in combination with +autodispatch option\n";

        my $uri = URI->new($soap->uri);
        my $currenturi = $uri->path;
        $package = ref $_[0] && UNIVERSAL::isa($_[0] => 'SOAP::Lite')
            ? $currenturi
            : $package eq 'SOAP'
                ? ref $_[0] || ($_[0] eq 'SOAP'
                    ? $currenturi || Carp::croak "URI is not specified for method call"
                    : $_[0])
                : $package eq 'main'
                    ? $currenturi || $package
                    : $package;

        # drop first parameter if it's a class name
        {
            my $pack = $package;
            for ($pack) { s!^/!!; s!/!::!g; }
            shift @_ if @_ && !ref $_[0] && ($_[0] eq $pack || $_[0] eq 'SOAP')
                || ref $_[0] && UNIVERSAL::isa($_[0] => 'SOAP::Lite');
        }

        for ($package) { s!::!/!g; s!^/?!/!; }
        $uri->path($package);

        my $som = $soap->uri($uri->as_string)->call($method => @_);
        UNIVERSAL::isa($som => 'SOAP::SOM')
            ? wantarray
                ? $som->paramsall
                : $som->result
            : $som;
    };
}

# ======================================================================

package SOAP::Lite;

use vars qw($AUTOLOAD @ISA);
use Carp ();

use SOAP::Lite::Utils;
use SOAP::Constants;
use SOAP::Packager;

use Scalar::Util qw(weaken blessed);

@ISA = qw(SOAP::Cloneable);

# provide access to global/autodispatched object
sub self {
    @_ > 1
        ? $soap = $_[1]
        : $soap
}

# no more warnings about "used only once"
*UNIVERSAL::AUTOLOAD if 0;

sub autodispatched { \&{*UNIVERSAL::AUTOLOAD} eq \&{*SOAP::AUTOLOAD} };

sub soapversion {
    my $self = shift;
    my $version = shift or return $SOAP::Constants::SOAP_VERSION;

    ($version) = grep {
        $SOAP::Constants::SOAP_VERSIONS{$_}->{NS_ENV} eq $version
        } keys %SOAP::Constants::SOAP_VERSIONS
            unless exists $SOAP::Constants::SOAP_VERSIONS{$version};

    die qq!$SOAP::Constants::WRONG_VERSION Supported versions:\n@{[
        join "\n", map {"  $_ ($SOAP::Constants::SOAP_VERSIONS{$_}->{NS_ENV})"} keys %SOAP::Constants::SOAP_VERSIONS
        ]}\n!
        unless defined($version) && defined(my $def = $SOAP::Constants::SOAP_VERSIONS{$version});

    foreach (keys %$def) {
        eval "\$SOAP::Constants::$_ = '$SOAP::Constants::SOAP_VERSIONS{$version}->{$_}'";
    }

    $SOAP::Constants::SOAP_VERSION = $version;

    return $self;
}

BEGIN { SOAP::Lite->soapversion(1.1) }

sub import {
    my $pkg = shift;
    my $caller = caller;
    no strict 'refs';
    # emulate 'use SOAP::Lite 0.99' behavior
    $pkg->require_version(shift) if defined $_[0] && $_[0] =~ /^\d/;

    while (@_) {
        my $command = shift;

        my @parameters = UNIVERSAL::isa($_[0] => 'ARRAY')
            ? @{shift()}
            : shift
                if @_ && $command ne 'autodispatch';

        if ($command eq 'autodispatch' || $command eq 'dispatch_from') {
            $soap = ($soap||$pkg)->new;
            no strict 'refs';
            foreach ($command eq 'autodispatch'
                ? 'UNIVERSAL'
                : @parameters
            ) {
                my $sub = "${_}::AUTOLOAD";
                defined &{*$sub}
                    ? (\&{*$sub} eq \&{*SOAP::AUTOLOAD}
                        ? ()
                        : Carp::croak "$sub already assigned and won't work with DISPATCH. Died")
                    : (*$sub = *SOAP::AUTOLOAD);
            }
        }
        elsif ($command eq 'service') {
            foreach (keys %{SOAP::Schema->schema_url(shift(@parameters))->parse(@parameters)->load->services}) {
                $_->export_to_level(1, undef, ':all');
            }
        }
        elsif ($command eq 'debug' || $command eq 'trace') {
            SOAP::Trace->import(@parameters ? @parameters : 'all');
        }
        elsif ($command eq 'import') {
            local $^W; # suppress warnings about redefining
            my $package = shift(@parameters);
            $package->export_to_level(1, undef, @parameters ? @parameters : ':all') if $package;
        }
        else {
            Carp::carp "Odd (wrong?) number of parameters in import(), still continue" if $^W && !(@parameters & 1);
            $soap = ($soap||$pkg)->$command(@parameters);
        }
    }
}

sub DESTROY { SOAP::Trace::objects('()') }

sub new {
    my $self = shift;
    return $self if ref $self;
    unless (ref $self) {
        my $class = $self;
        # Check whether we can clone. Only the SAME class allowed, no inheritance
        $self = ref($soap) eq $class ? $soap->clone : {
            _transport    => SOAP::Transport->new,
            _serializer   => SOAP::Serializer->new,
            _deserializer => SOAP::Deserializer->new,
            _packager     => SOAP::Packager::MIME->new,
            _schema       => undef,
            _autoresult   => 0,
            _on_action    => sub { sprintf '"%s#%s"', shift || '', shift },
            _on_fault     => sub {ref $_[1] ? return $_[1] : Carp::croak $_[0]->transport->is_success ? $_[1] : $_[0]->transport->status},
        };
        bless $self => $class;
        $self->on_nonserialized($self->on_nonserialized || $self->serializer->on_nonserialized);
        SOAP::Trace::objects('()');
    }

    Carp::carp "Odd (wrong?) number of parameters in new()" if $^W && (@_ & 1);
    no strict qw(refs);
    while (@_) {
        my($method, $params) = splice(@_,0,2);
        $self->can($method)
            ? $self->$method(ref $params eq 'ARRAY' ? @$params : $params)
            : $^W && Carp::carp "Unrecognized parameter '$method' in new()"
    }

    return $self;
}

sub init_context {
    my $self = shift->new;
    $self->{'_deserializer'}->{'_context'} = $self;
    # weaken circular reference to avoid a memory hole
    weaken $self->{'_deserializer'}->{'_context'};

    $self->{'_serializer'}->{'_context'} = $self;
    # weaken circular reference to avoid a memory hole
    weaken $self->{'_serializer'}->{'_context'};
}

# Naming? wsdl_parser
sub schema {
    my $self = shift;
    if (@_) {
        $self->{'_schema'} = shift;
        return $self;
    }
    else {
        if (!defined $self->{'_schema'}) {
            $self->{'_schema'} = SOAP::Schema->new;
        }
        return $self->{'_schema'};
    }
}

sub BEGIN {
    no strict 'refs';
    for my $method (qw(serializer deserializer)) {
        my $field = '_' . $method;
        *$method = sub {
            my $self = shift->new;
            if (@_) {
                my $context = $self->{$field}->{'_context'}; # save the old context
                $self->{$field} = shift;
                $self->{$field}->{'_context'} = $context;    # restore the old context
                return $self;
            }
            else {
                return $self->{$field};
            }
        }
    }

    __PACKAGE__->__mk_accessors(
        qw(endpoint transport outputxml autoresult packager)
    );
    #  for my $method () {
    #    my $field = '_' . $method;
    #    *$method = sub {
    #      my $self = shift->new;
    #      @_ ? ($self->{$field} = shift, return $self) : return $self->{$field};
    #    }
    #  }
    for my $method (qw(on_action on_fault on_nonserialized)) {
        my $field = '_' . $method;
        *$method = sub {
            my $self = shift->new;
            return $self->{$field} unless @_;
            local $@;
            # commented out because that 'eval' was unsecure
            # > ref $_[0] eq 'CODE' ? shift : eval shift;
            # Am I paranoid enough?
            $self->{$field} = shift;
            Carp::croak $@ if $@;
            Carp::croak "$method() expects subroutine (CODE) or string that evaluates into subroutine (CODE)"
                unless ref $self->{$field} eq 'CODE';
            return $self;
        }
    }
    # SOAP::Transport Shortcuts
    # TODO - deprecate proxy() in favor of new language endpoint_url()
    no strict qw(refs);
    for my $method (qw(proxy)) {
        *$method = sub {
            my $self = shift->new;
            @_ ? ($self->transport->$method(@_), return $self) : return $self->transport->$method();
        }
    }

    # SOAP::Seriailizer Shortcuts
    for my $method (qw(autotype readable envprefix encodingStyle
                    encprefix multirefinplace encoding
                    typelookup header maptype xmlschema
                    uri ns_prefix ns_uri use_prefix use_default_ns
                    ns default_ns)) {
        *$method = sub {
            my $self = shift->new;
            @_ ? ($self->serializer->$method(@_), return $self) : return $self->serializer->$method();
        }
    }

    # SOAP::Schema Shortcuts
    for my $method (qw(cache_dir cache_ttl)) {
        *$method = sub {
            my $self = shift->new;
            @_ ? ($self->schema->$method(@_), return $self) : return $self->schema->$method();
        }
    }
}

sub parts {
    my $self = shift;
    $self->packager->parts(@_);
    return $self;
}

# Naming? wsdl
sub service {
    my $self = shift->new;
    return $self->{'_service'} unless @_;
    $self->schema->schema_url($self->{'_service'} = shift);
    my %services = %{$self->schema->parse(@_)->load->services};

    Carp::croak "More than one service in service description. Service and port names have to be specified\n"
        if keys %services > 1;
    my $service = (keys %services)[0]->new;
    return $service;
}

sub AUTOLOAD {
    my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2);
    return if $method eq 'DESTROY';

    ref $_[0] or Carp::croak qq!Can\'t locate class method "$method" via package \"! . __PACKAGE__ .'\"';

    no strict 'refs';
    *$AUTOLOAD = sub {
        my $self = shift;
        my $som = $self->call($method => @_);
        return $self->autoresult && UNIVERSAL::isa($som => 'SOAP::SOM')
            ? wantarray ? $som->paramsall : $som->result
            : $som;
    };
    goto &$AUTOLOAD;
}

sub call {
    SOAP::Trace::trace('()');
    my $self = shift;

    die "A service address has not been specified either by using SOAP::Lite->proxy() or a service description)\n"
        unless defined $self->proxy && UNIVERSAL::isa($self->proxy => 'SOAP::Client');

    $self->init_context();

    my $serializer = $self->serializer;
    $serializer->on_nonserialized($self->on_nonserialized);

    my $response = $self->transport->send_receive(
        context  => $self, # this is provided for context
        endpoint => $self->endpoint,
        action   => scalar($self->on_action->($serializer->uriformethod($_[0]))),
                # leave only parameters so we can later update them if required
        envelope => $serializer->envelope(method => shift, @_),
        encoding => $serializer->encoding,
        parts    => @{$self->packager->parts} ? $self->packager->parts : undef,
    );

    return $response if $self->outputxml;

    my $result = eval { $self->deserializer->deserialize($response) }
        if $response;

    if (!$self->transport->is_success || # transport fault
        $@ ||                            # not deserializible
        # fault message even if transport OK
        # or no transport error (for example, fo TCP, POP3, IO implementations)
        UNIVERSAL::isa($result => 'SOAP::SOM') && $result->fault) {
        return ($self->on_fault->($self, $@
            ? $@ . ($response || '')
            : $result)
                || $result
        );
        # ? # trick editors
    }
    # this might be trouble for connection close...
    return unless $response; # nothing to do for one-ways

    # little bit tricky part that binds in/out parameters
    if (UNIVERSAL::isa($result => 'SOAP::SOM')
        && ($result->paramsout || $result->headers)
        && $serializer->signature) {
        my $num = 0;
        my %signatures = map {$_ => $num++} @{$serializer->signature};
        for ($result->dataof(SOAP::SOM::paramsout), $result->dataof(SOAP::SOM::headers)) {
            my $signature = join $;, $_->name, $_->type || '';
            if (exists $signatures{$signature}) {
                my $param = $signatures{$signature};
                my($value) = $_->value; # take first value

                # fillup parameters
                UNIVERSAL::isa($_[$param] => 'SOAP::Data')
                    ? $_[$param]->SOAP::Data::value($value)
                    : UNIVERSAL::isa($_[$param] => 'ARRAY')
                        ? (@{$_[$param]} = @$value)
                        : UNIVERSAL::isa($_[$param] => 'HASH')
                            ? (%{$_[$param]} = %$value)
                            : UNIVERSAL::isa($_[$param] => 'SCALAR')
                                ? (${$_[$param]} = $$value)
                                : ($_[$param] = $value)
            }
        }
    }
    return $result;
} # end of call()

# ======================================================================

package SOAP::Lite::COM;

require SOAP::Lite;

sub required {
  foreach (qw(
    URI::_foreign URI::http URI::https
    LWP::Protocol::http LWP::Protocol::https LWP::Authen::Basic LWP::Authen::Digest
    HTTP::Daemon Compress::Zlib SOAP::Transport::HTTP
    XMLRPC::Lite XMLRPC::Transport::HTTP
  )) {
    eval join ';', 'local $SIG{__DIE__}', "require $_";
  }
}

sub new    { required; SOAP::Lite->new(@_) }

sub create; *create = \&new; # make alias. Somewhere 'new' is registered keyword

sub soap; *soap = \&new;     # also alias. Just to be consistent with .xmlrpc call

sub xmlrpc { required; XMLRPC::Lite->new(@_) }

sub server { required; shift->new(@_) }

sub data   { SOAP::Data->new(@_) }

sub header { SOAP::Header->new(@_) }

sub hash   { +{@_} }

sub instanceof {
  my $class = shift;
  die "Incorrect class name" unless $class =~ /^(\w[\w:]*)$/;
  eval "require $class";
  $class->new(@_);
}

# ======================================================================

1;

__END__