SOAP::Lite - Perl's Web Services Toolkit

 Hello Martin Kutter!

 Method: sayHello(string, string)
 Parameters:
    name: string
    givenName: string

 <sayHello xmlns="urn:HelloWorld">
   <s-gensym01 xsi:type="xsd:string">Kutter</s-gensym01>
   <s-gensym02 xsi:type="xsd:string">Martin</s-gensym02>
 </sayHello>

 use SOAP::Lite;
 my $soap = SOAP::Lite->new( proxy => 'http://localhost:81/soap-wsdl-test/helloworld.pl');
 $soap->default_ns('urn:HelloWorld');
 my $som = $soap->call('sayHello', 'Kutter', 'Martin');
 die $som->faultstring if ($som->fault);
 print $som->result, "\n";

 <definitions xmlns:soap="http://schemas.xmlsoap.org/wsdl/soap/"
   xmlns:s="http://www.w3.org/2001/XMLSchema"
   xmlns:s0="urn:HelloWorld"
   targetNamespace="urn:HelloWorld"
   xmlns="http://schemas.xmlsoap.org/wsdl/">
   <types>
     <s:schema targetNamespace="urn:HelloWorld">
     </s:schema>
   </types>
   <message name="sayHello">
     <part name="name" type="s:string" />
     <part name="givenName" type="s:string" />
   </message>
   <message name="sayHelloResponse">
     <part name="sayHelloResult" type="s:string" />
   </message>

   <portType name="Service1Soap">
     <operation name="sayHello">
       <input message="s0:sayHello" />
       <output message="s0:sayHelloResponse" />
     </operation>
   </portType>

   <binding name="Service1Soap" type="s0:Service1Soap">
     <soap:binding transport="http://schemas.xmlsoap.org/soap/http"
         style="rpc" />
     <operation name="sayHello">
       <soap:operation soapAction="urn:HelloWorld#sayHello"/>
       <input>
         <soap:body use="encoded"
           encodingStyle="http://schemas.xmlsoap.org/soap/encoding/"/>
       </input>
       <output>
         <soap:body use="encoded"
           encodingStyle="http://schemas.xmlsoap.org/soap/encoding/"/>
       </output>
     </operation>
   </binding>
   <service name="HelloWorld">
     <port name="HelloWorldSoap" binding="s0:Service1Soap">
       <soap:address location="http://localhost:81/soap-wsdl-test/helloworld.pl" />
     </port>
   </service>
 </definitions>

 <sayHello xmlns="urn:HelloWorld">
   <name xsi:type="xsd:string">Kutter</name>
   <givenName xsi:type="xsd:string">Martin</givenName>
 </sayHello>

 use SOAP::Lite;
 my $soap = SOAP::Lite->service("file:say_hello_rpcenc.wsdl");
 eval { my $result = $soap->sayHello('Kutter', 'Martin'); };
 if ($@) {
     die $@;
 }
 print $som->result();

 perl -MSOAP::Lite -e 'print SOAP::Lite->service("file:say_hello_rpcenc.wsdl")\
   ->sayHello('Kutter', 'Martin'), "\n";'

 use SOAP::Lite;
 my $soap = SOAP::Lite->new( proxy => 'http://localhost:81/soap-wsdl-test/helloworld.pl');
 $soap->default_ns('urn:HelloWorld');
 my $som = $soap->call('sayHello',
    SOAP::Data->name('name')->value('Kutter'),
    SOAP::Data->name('givenName')->value('Martin')
 );
 die $som->faultstring if ($som->fault);
 print $som->result, "\n";

 <definitions xmlns:soap="http://schemas.xmlsoap.org/wsdl/soap/"
   xmlns:s="http://www.w3.org/2001/XMLSchema"
   xmlns:s0="urn:HelloWorld"
   targetNamespace="urn:HelloWorld"
   xmlns="http://schemas.xmlsoap.org/wsdl/">
   <types>
     <s:schema targetNamespace="urn:HelloWorld">
       <s:complexType name="sayHello">
         <s:sequence>
           <s:element minOccurs="0" maxOccurs="1" name="name"
              type="s:string" />
           <s:element minOccurs="0" maxOccurs="1" name="givenName"
              type="s:string" nillable="1" />
         </s:sequence>
       </s:complexType>

       <s:complexType name="sayHelloResponse">
         <s:sequence>
           <s:element minOccurs="0" maxOccurs="1" name="sayHelloResult"
              type="s:string" />
         </s:sequence>
       </s:complexType>
     </s:schema>
   </types>
   <message name="sayHello">
     <part name="parameters" type="s0:sayHello" />
   </message>
   <message name="sayHelloResponse">
     <part name="parameters" type="s0:sayHelloResponse" />
   </message>

   <portType name="Service1Soap">
     <operation name="sayHello">
       <input message="s0:sayHello" />
       <output message="s0:sayHelloResponse" />
     </operation>
   </portType>

   <binding name="Service1Soap" type="s0:Service1Soap">
     <soap:binding transport="http://schemas.xmlsoap.org/soap/http"
         style="rpc" />
     <operation name="sayHello">
       <soap:operation soapAction="urn:HelloWorld#sayHello"/>
       <input>
         <soap:body use="literal" namespace="urn:HelloWorld"/>
       </input>
       <output>
         <soap:body use="literal" namespace="urn:HelloWorld"/>
       </output>
     </operation>
   </binding>
   <service name="HelloWorld">
     <port name="HelloWorldSoap" binding="s0:Service1Soap">
       <soap:address location="http://localhost:80//helloworld.pl" />
     </port>
   </service>
  </definitions>

 <ns0:sayHello xmlns:ns0="urn:HelloWorld">
    <parameters>
      <name>Kutter</name>
      <givenName>Martin</givenName>
    </parameters>
 </ns0:sayHello>

 <sayHelloResponse xmlns:ns0="urn:HelloWorld">
    <parameters>
        <sayHelloResult>Hello Martin Kutter!</sayHelloResult>
    </parameters>
 </sayHelloResponse>

 use SOAP::Lite +trace;
 my $soap = SOAP::Lite->new( proxy => 'http://localhost:80/helloworld.pl');

 $soap->on_action( sub { "urn:HelloWorld#sayHello" });
 $soap->autotype(0)->readable(1);
 $soap->default_ns('urn:HelloWorld');

 my $som = $soap->call('sayHello', SOAP::Data->name('parameters')->value(
    \SOAP::Data->value([
        SOAP::Data->name('name')->value( 'Kutter' ),
        SOAP::Data->name('givenName')->value('Martin'),
    ]))
);

 die $som->fault->{ faultstring } if ($som->fault);
 print $som->result, "\n";

 <definitions xmlns:soap="http://schemas.xmlsoap.org/wsdl/soap/"
    xmlns:s="http://www.w3.org/2001/XMLSchema"
    xmlns:s0="urn:HelloWorld"
    targetNamespace="urn:HelloWorld"
    xmlns="http://schemas.xmlsoap.org/wsdl/">
   <types>
     <s:schema targetNamespace="urn:HelloWorld">
       <s:element name="sayHello">
         <s:complexType>
           <s:sequence>
              <s:element minOccurs="0" maxOccurs="1" name="name" type="s:string" />
               <s:element minOccurs="0" maxOccurs="1" name="givenName" type="s:string" nillable="1" />
           </s:sequence>
          </s:complexType>
        </s:element>

        <s:element name="sayHelloResponse">
          <s:complexType>
            <s:sequence>
              <s:element minOccurs="0" maxOccurs="1" name="sayHelloResult" type="s:string" />
            </s:sequence>
        </s:complexType>
      </s:element>
    </types>
    <message name="sayHelloSoapIn">
      <part name="parameters" element="s0:sayHello" />
    </message>
    <message name="sayHelloSoapOut">
      <part name="parameters" element="s0:sayHelloResponse" />
    </message>

    <portType name="Service1Soap">
      <operation name="sayHello">
        <input message="s0:sayHelloSoapIn" />
        <output message="s0:sayHelloSoapOut" />
      </operation>
    </portType>

    <binding name="Service1Soap" type="s0:Service1Soap">
      <soap:binding transport="http://schemas.xmlsoap.org/soap/http"
          style="document" />
      <operation name="sayHello">
        <soap:operation soapAction="urn:HelloWorld#sayHello"/>
        <input>
          <soap:body use="literal" />
        </input>
        <output>
          <soap:body use="literal" />
        </output>
      </operation>
    </binding>
    <service name="HelloWorld">
      <port name="HelloWorldSoap" binding="s0:Service1Soap">
        <soap:address location="http://localhost:80//helloworld.pl" />
      </port>
    </service>
 </definitions>

 <sayHello xmlns="urn:HelloWorld">
   <name>Kutter</name>
   <givenName>Martin</givenName>
 </sayHello>

 <sayHelloResponse>
   <sayHelloResult>Hello Martin Kutter!</sayHelloResult>
 </sayHelloResponse>

 use SOAP::Lite;
 my $soap = SOAP::Lite->new( proxy => 'http://localhost:80/helloworld.pl');

 $soap->on_action( sub { "urn:HelloWorld#sayHello" });
 $soap->autotype(0);
 $soap->default_ns('urn:HelloWorld');

 my $som = $soap->call("sayHello",
    SOAP::Data->name('name')->value( 'Kutter' ),
    SOAP::Data->name('givenName')->value('Martin'),
);

 die $som->fault->{ faultstring } if ($som->fault);
 print $som->result, "\n";

 my $som = $soap->call('sayHello', SOAP::Data->name('parameters')->value(
    \SOAP::Data->value([
        SOAP::Data->name('name')->value( 'Kutter' ),
        SOAP::Data->name('givenName')->value('Martin'),
    ]))
 );

  use SOAP::Lite;
  use MIME::Entity;
  my $ent = build MIME::Entity
    Type        => "image/gif",
    Encoding    => "base64",
    Path        => "somefile.gif",
    Filename    => "saveme.gif",
    Disposition => "attachment";
  my $som = SOAP::Lite
    ->uri($SOME_NAMESPACE)
    ->parts([ $ent ])
    ->proxy($SOME_HOST)
    ->some_method(SOAP::Data->name("foo" => "bar"));

  use SOAP::Lite;
  use MIME::Entity;
  my $soap = SOAP::Lite
    ->uri($NS)
    ->proxy($HOST);
  my $som = $soap->foo();
  foreach my $part (${$som->parts}) {
    print $part->stringify;
  }

  package Attachment;
  use SOAP::Lite;
  use MIME::Entity;
  use strict;
  use vars qw(@ISA);
  @ISA = qw(SOAP::Server::Parameters);
  sub someMethod {
    my $self = shift;
    my $envelope = pop;
    foreach my $part (@{$envelope->parts}) {
      print "AttachmentService: attachment found! (".ref($part).")\n";
    }
    # do something
  }

  package Attachment;
  use SOAP::Lite;
  use MIME::Entity;
  use strict;
  use vars qw(@ISA);
  @ISA = qw(SOAP::Server::Parameters);
  sub someMethod {
    my $self = shift;
    my $envelope = pop;
    my $ent = build MIME::Entity
    'Id'          => "<1234>",
    'Type'        => "text/xml",
    'Path'        => "some.xml",
    'Filename'    => "some.xml",
    'Disposition' => "attachment";
    return SOAP::Data->name("foo" => "blah blah blah"),$ent;
  }

  use SOAP::Lite
    proxy => 'http://localhost/cgi-bin/soap.cgi',
    uri => 'http://my.own.com/My/Examples';

  my $soap1 = new SOAP::Lite; # will get the same proxy()/uri() as above
  print $soap1->getStateName(1)->result;

  my $soap2 = SOAP::Lite->new; # same thing as above
  print $soap2->getStateName(2)->result;

  # or you may override any settings you want
  my $soap3 = SOAP::Lite->proxy('http://localhost/');
  print $soap3->getStateName(1)->result;

  SOAP::Lite->self(undef);

  use SOAP::Lite
    on_action => sub {sprintf '%s#%s', @_};

  use SOAP::Lite proxy => 'http://localhost/';
  print SOAP::Lite->getStateName(1)->result;

  use SOAP::Lite proxy => 'http://localhost/cgi-bin/soap.cgi';
  print SOAP::Lite->getStateName(1)->result;

  eval "use SOAP::Lite proxy => 'http://localhost/cgi-bin/soap.cgi'; 1" or die;

  SOAP::Lite->self->proxy('http://localhost/cgi-bin/soap.cgi');

  use SOAP::Transport::HTTP;
  use MIME::Entity;
  $SOAP::Constants::MAX_CONTENT_SIZE = 10000;
  SOAP::Transport::HTTP::CGI
    ->dispatch_to('TemperatureService')
    ->handle;

  <mehodResponse>
    <res1>name1</res1>
    <res2>name2</res2>
    <res3>name3</res3>
  </mehodResponse>

  $result = $r->result; # gives you 'name1'
  $paramout1 = $r->paramsout;      # gives you 'name2', because of scalar context
  $paramout1 = ($r->paramsout)[0]; # gives you 'name2' also
  $paramout2 = ($r->paramsout)[1]; # gives you 'name3'

  @paramsout = $r->paramsout; # gives you ARRAY of out parameters
  $paramout1 = $paramsout[0]; # gives you 'res2', same as ($r->paramsout)[0]
  $paramout2 = $paramsout[1]; # gives you 'res3', same as ($r->paramsout)[1]

  sub mymethod {
    shift; # object/class reference
    my $param1 = shift;
    my $param2 = SOAP::Data->name('myparam' => shift() * 2);
    return $param1, $param2;
  }

  $a = 10;
  $b = SOAP::Data->name('myparam' => 12);
  $result = $soap->mymethod($a, $b);

  package My::PingPong;

  sub new {
    my $self = shift;
    my $class = ref($self) || $self;
    bless {_num=>shift} => $class;
  }

  sub next {
    my $self = shift;
    $self->{_num}++;
  }

  use SOAP::Lite +autodispatch =>
    uri => 'urn:',
    proxy => 'http://localhost/';

  my $p = My::PingPong->new(10); # $p->{_num} is 10 now, real object returned
  print $p->next, "\n";          # $p->{_num} is 11 now!, object autobinded

  use SOAP::Transport::HTTP;
  use My::Examples;           # module is preloaded

  SOAP::Transport::HTTP::CGI
     # deployed module should be present here or client will get
     # 'access denied'
    -> dispatch_to('My::Examples')
    -> handle;

  use SOAP::Transport::HTTP;
  # name is unknown, module will be loaded on demand

  SOAP::Transport::HTTP::CGI
    # deployed module should be present here or client will get 'access denied'
    -> dispatch_to('/Your/Path/To/Deployed/Modules', 'My::Examples')
    -> handle;

  dispatch_to(
    # dynamic dispatch that allows access to ALL modules in specified directory
    PATH/TO/MODULES
    # 1. specifies directory
    # -- AND --
    # 2. gives access to ALL modules in this directory without limits

    # static dispatch that allows access to ALL methods in particular MODULE
    MODULE
    #  1. gives access to particular module (all available methods)
    #  PREREQUISITES:
    #    module should be loaded manually (for example with 'use ...')
    #    -- OR --
    #    you can still specify it in PATH/TO/MODULES

    # static dispatch that allows access to particular method ONLY
    MODULE::method
    # same as MODULE, but gives access to ONLY particular method,
    # so there is not much sense to use both MODULE and MODULE::method
    # for the same MODULE
  );

  dispatch_with({
    URI => MODULE,        # 'http://www.soaplite.com/' => 'My::Class',
    SOAPAction => MODULE, # 'http://www.soaplite.com/method' => 'Another::Class',
    URI => object,        # 'http://www.soaplite.com/obj' => My::Class->new,
  })

  print SOAP::Lite
    ->uri('http://localhost/My/Parameters')
    ->proxy('http://localhost/', options => {compress_threshold => 10000})
    ->echo(1 x 10000)
    ->result;

  my $server = SOAP::Transport::HTTP::CGI
    ->dispatch_to('My::Parameters')
    ->options({compress_threshold => 10000})
    ->handle;

  return SOAP::Data->name('myname')
                   ->type('string')
                   ->uri($MY_NAMESPACE)
                   ->value($output);

 * CPAN:                http://search.cpan.org/search?dist=SOAP-Lite
 * Sourceforge:         http://sourceforge.net/projects/soaplite/

 https://soaplite.svn.sourceforge.net/svnroot/soaplite/

# ======================================================================
#
# Copyright (C) 2000-2005 Paul Kulchenko (paulclinger@yahoo.com)
# SOAP::Lite is free software; you can redistribute it
# and/or modify it under the same terms as Perl itself.
#
# $Id: Lite.pm 374 2010-05-14 08:12:25Z kutterma $
#
# ======================================================================

# 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 5.006; #weak references require perl 5.6
use strict;
our $VERSION = 0.712;
# ======================================================================

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 (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' => 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 [ 1204279 ] Boolean serialization error
    return [
        $name,
        {'xsi:type' => 'xsd:boolean', %$attr},
        ( $value ne 'false' && $value ) ? '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 [ 1204279 ] Boolean serialization error
    return [
        $name,
        {
            'xsi:type' => 'xsd:boolean', %$attr
        },
        ( $value ne 'false' && $value )
            ? '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 "&amp;" and "&lt;" respectively. The right angle bracket (>) may be
# represented using the string "&gt;", and must, for compatibility, be
# escaped using "&gt;" 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 = ('&' => '&amp;', '>' => '&gt;', '<' => '&lt;', '"' => '&quot;');
sub encode_attribute { (my $e = $_[0]) =~ s/([&<>\"])/$encode_attribute{$1}/g; $e }

my %encode_data = ('&' => '&amp;', '>' => '&gt;', '<' => '&lt;', "\xd" => '&#xd;');
sub encode_data {
    my $e = $_[0];
    if ($e) {
        $e =~ s/([&<>\015])/$encode_data{$1}/g;
        $e =~ s/\]\]>/\]\]&gt;/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 = UNIVERSAL::isa($_[0] => __PACKAGE__) ? shift->new : __PACKAGE__->new;
    if (@_) {
        my ($name, $uri, $prefix) = shift;
        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 = UNIVERSAL::isa($_[0] => __PACKAGE__)
        ? shift->new()
        : __PACKAGE__->new();
    if (@_) {
        $self->{_attr} = shift;
        $self->value(@_) if @_;
        return $self
    }
    return $self->{_attr};
}

sub type {
    my $self = 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 = UNIVERSAL::isa($_[0] => __PACKAGE__)
        ? shift->new()
        : __PACKAGE__->new();
    return $self->{_prefix} unless @_;
    $self->{_prefix} = shift;
    $self->value(@_) if @_;
    return $self;
}

sub uri {
    my $self = 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 =~ /::/;
    $self->value(@_) if @_;
    return $self;
}

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

sub value {
    my $self = UNIVERSAL::isa($_[0] => __PACKAGE__)
        ? shift->new()
        : __PACKAGE__->new;
    (@_)
        ? ($self->set_value(@_), return $self)
        : wantarray
            ? return @{$self->{_value}}
            : return $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 typelookup 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 => {},
        _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'],
        },
        _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->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 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);
    my $seen = $self->seen;
    $seen->{$id}->{count}++;
    $seen->{$id}->{multiref} ||= $seen->{$id}->{count} > 1;
    $seen->{$id}->{value} = $object;
    $seen->{$id}->{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 $seen = shift->seen->{my $id = shift || return undef};
    return $seen->{multiref} ? "ref-$id" : 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
    $self->recursive_object($object) if ++$objectstack{$id} > 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 cought 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) {
            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 crete 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 <array>5</array><array>6</array>
        # 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 
        # <array><foo>1</foo><foo>2</foo></array>
        #
        
        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',
            ''
        )} 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 = shift;
    my $data = shift;
    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 $value = join '', @values;
    my $level = $self->level;
    my $indent = $self->readable ? ' ' x (($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 !~ /^(?![xX][mM][lL])$SOAP::Constants::NSMASK$/o;

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

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

sub xmlize {
    my $self = shift;
    my($name, $attrs, $values, $id) = @{+shift};
    $attrs ||= {};

    local $self->{_level} = $self->{_level} + 1;
    return $self->tag($name, $attrs)
        unless defined $values;
    return $self->tag($name, $attrs, $values)
        unless UNIVERSAL::isa($values => 'ARRAY');
    return $self->tag($name, {%$attrs, href => '#'.$self->multiref_anchor($id)})
        if $self->is_href($id, delete($attrs->{_id}));
    return $self->tag($name,
        {
            %$attrs, id => $self->multiref_anchor($id)
        },
        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 coment 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;
    @_
        ? do {
            $self->{'_parser'} = shift;
            return $self;
        }
        : 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 <iceman@mit.edu>
    # and Craig Johnston <craig.johnston@pressplay.com>
    # 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 <mrdamnfrenchy@yahoo.com>
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 = shift;
    my ($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;

    $op = '==' unless $op; $op .= '=' if $op eq '=' || $op eq '!';
    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 = shift;
    my($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;

@ISA = qw(SOAP::Cloneable);

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

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

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 <Chris.Davies@ManheimEurope.com>
    $_[1] =~ /^\s*</ || $_[1] !~ /^(?:[\w-]+:|From )/;
}

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
        $id =~ s/^<([^>]*)>$/$1/; # string any leading and trailing brackets
        $self->ids->{$id} = $part if $id;
        $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, $children, $value) = @$ref;

    $ref->[ _ATTRS ] = $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 $ref = shift;
    my($name, $attrs, $children, $value) = @$ref;

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

    # check encodingStyle
    # future versions may bind deserializer to encodingStyle
    my $encodingStyle = $attrs->{"{$SOAP::Constants::NS_ENV}encodingStyle"} || "";
    my (%union,%isect);
    # 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
    # Find intersection of declared and supported encoding styles
    foreach my $e (@SOAP::Constants::SUPPORTED_ENCODING_STYLES, split(/ +/,$encodingStyle)) {
        $union{$e}++ && $isect{$e}++;
    }
    die "Unrecognized/unsupported value of encodingStyle attribute '$encodingStyle'"
        if defined($encodingStyle) && length($encodingStyle) > 0 && !%isect &&
            !(SOAP::Lite->soapversion == 1.1 && $encodingStyle =~ /(?:^|\b)$SOAP::Constants::NS_ENC/);

    # removed to provide literal support in 0.65
    #$encodingStyle !~ /(?:^|\b)$SOAP::Constants::NS_ENC/;
    #                 # ^^^^^^^^ \b causing problems (!?) on some systems
    #                 # as reported by David Dyck <dcd@tc.fluke.com>
    #                 # so use (?:^|\b) instead

    use vars '$arraytype'; # type of Array element specified on Array itself
    # either specified with xsi:type, or <enc:name/> 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;

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

    # 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:)?//;
        # convert to absolute if not internal '#' or 'cid:'
        $id = $self->baselocation($id) unless $1;
        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 || ''}
            || ($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 namea
    $caller = (caller(2))[3] if $caller =~ /eval/;
    chomp(my $msg = join ' ', @_);
    printf STDERR "%s: %s\n", $caller, $msg;
}

sub import {
    no strict 'refs';
    local $^W;
    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 : $_);
        }
    }
    # TODO - I am getting a warning here about redefining a subroutine
    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 <types> element if there is no one
        $s->set_value($s->value, $self->deserializer->deserialize('<types></types>')->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 <service>, aka tModel-type descriptions
    my @services = $s->service;
    my $tns = $s->{'_attr'}->{'targetNamespace'};
    # if there is no <service> element we'll provide it
    @services = $self->deserializer->deserialize(<<"FAKE")->root->service unless @services;
<definitions>
  <service name="@{[$service || 'FakeService']}">
    <port name="@{[$port || 'FakePort']}" binding="@{[$s->binding->name]}"/>
  </service>
</definitions>
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)->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; # supress 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