SOAP::WSDL::Expat::Message2Hash - Convert SOAP messages to perl hash refs

 my $parser = SOAP::WSDL::Expat::MessageParser->new({
    class_resolver => 'My::Resolver'
 });
 $parser->parse( $xml );
 my $obj = $parser->get_data();

 Martin Kutter E<lt>martin.kutter fen-net.deE<gt>

 $Id: $

 $LastChangedDate: 2007-09-10 18:19:23 +0200 (Mo, 10 Sep 2007) $
 $LastChangedRevision: 218 $
 $LastChangedBy: kutterma $

 $HeadURL: https://soap-wsdl.svn.sourceforge.net/svnroot/soap-wsdl/SOAP-WSDL/trunk/lib/SOAP/WSDL/Expat/MessageParser.pm $

#!/usr/bin/perl
package SOAP::WSDL::Expat::Message2Hash;
use strict;
use warnings;
use base qw(SOAP::WSDL::Expat::Base);

use version; our $VERSION = qv('2.00.10');

sub _initialize {
    my ($self, $parser) = @_;
    $self->{ parser } = $parser;
    delete $self->{ data };             # remove potential old results

    my $characters;
    my $current = {};
    my $list = [];                      # node list
    my $current_part = q{};             # are we in header or body ?
    $self->{ data } = $current;

    # use "globals" for speed
    my ($_element, $_method,
        $_class, $_parser, %_attrs) = ();

    # no strict qw(refs);
    $parser->setHandlers(
        Start => sub {
            push @$list, $current;
           #If our element exists and is a list ref, add to it
            if ( exists $current->{ $_[1] }
              && ( ref ($current->{ $_[1] }) eq 'ARRAY')
            )  {
                push @{ $current->{ $_[1] } }, {};
                $current = $current->{ $_[1] }->[-1];
            }
            elsif ( exists $current->{ $_[1] } )
            {
                $current->{ $_[1] } = [ $current->{ $_[1] }, {} ];
                $current = $current->{ $_[1] }->[-1];
            }
            else {
                $current->{ $_[1] } = {};
                $current = $current->{ $_[1] };
            }
            return;
        },

        Char => sub {
            $characters .= $_[1] if $_[1] !~m{ \A \s* \z}xms;
            return;
        },

        End => sub {
            $_element = $_[1];

            # This one easily handles ignores for us, too...
            # return if not ref $$list[-1];

            if (length $characters) {
                if (ref $list->[-1]->{ $_element } eq 'ARRAY') {
                    $list->[-1]->{ $_element }->[-1] = $characters ;
                }
                else {
                    $list->[-1]->{ $_element } = $characters;
                }
            }
            $characters = q{};
            $current = pop @$list;           # step up in object hierarchy...
            return;
        }
    );
    return $parser;
}

1;