File Coverage

blib/lib/SOAP/XML/Client.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

package SOAP::XML::Client;
$SOAP::XML::Client::VERSION = '2.8';
use strict;
use Carp;
use XML::LibXML 0.6;
use SOAP::Lite 0.67;
use SOAP::Data::Builder 0.8;
use File::Slurp;
use Encode qw( decode );

use vars qw($DEBUG);

use base qw(Class::Accessor::Fast);

my @methods = qw(results results_xml uri xmlns proxy soapversion timeout error
    strip_default_xmlns encoding header transport status);

# wsdk

__PACKAGE__->mk_accessors(@methods);

$DEBUG = 0;

# Get an XML Parser
my $parser = XML::LibXML->new();
$parser->validation(0);
$parser->expand_entities(0);

# which methods should be set on object constructor
my @config_methods
    = qw(uri xmlns proxy soapversion strip_default_xmlns encoding timeout);

sub new {
    my ( $proto, $conf ) = @_;
    my $class = ref($proto) || $proto;
    my $self = {};
    bless( $self, $class );

    # Set up default soapversion and timeout
    $conf->{soapversion} = '1.1' unless defined $conf->{soapversion};
    $conf->{timeout}     = '30'  unless defined $conf->{timeout};
    $conf->{strip_default_xmlns} = 1
        unless defined $conf->{strip_default_xmlns};
    $conf->{encoding} ||= 'utf-8';

    # There is a WDSL file - process it
    if ( defined $conf->{wsdl} ) {
        $self->wsdl( $conf->{wsdl} );
        $self->_process_wsdl();
    }

    if ( $conf->{disable_base64} ) {
        *SOAP::Serializer::as_base64Binary = sub {
            my $self = shift;
            my ( $value, $name, $type, $attr ) = @_;
            return [
                $name,
                { 'xsi:type' => 'xsd:string', %$attr },
                SOAP::Utils::encode_data($value)
            ];
        };
    }

    # Read in the required params
    foreach my $soap_conf (@config_methods) {
        unless ( defined $conf->{$soap_conf} ) {
            croak "$soap_conf is required";
        } else {
            $self->$soap_conf( $conf->{$soap_conf} );
        }
    }

    $self->header( $conf->{header} ) if $conf->{header};

    # Set up the SOAP object
    $self->{soap} = SOAP::Lite->new;

    # We want the raw XML back
    $self->{soap}->outputxml(1);

    return $self;

}

#sub _process_wsdl {
#	my $self = shift;
#	my $services = SOAP::Schema->schema_url($self->wsdl())->parse()->services();
#	use Data::Dumper; #print STDERR Dumper($services);
#
#	foreach my $class (values %$services) {
#		print "C: $class\n";
#		foreach my $method (keys %$class) {
#			print "M: $method\n";
#			print Dumper($class->{$method});
#			$self->{proxies}->{$method} = $class->{$method}->{endpoint}->value();
#			$self->{uris}->{$method} = $class->{$method}->{uri}->value();
#		}
#	}
#}

sub fetch {
    my ( $self, $conf ) = @_;

    # Reset the error so that the object ca be reused
    $self->error(undef);

    # Got to have a method!
    if ( !defined $conf->{method} or $conf->{method} eq '' ) {
        $self->error('You must supply a method name');
        return undef;
    }

    # Got to get xml from somewhere!
    if ( !defined $conf->{xml} && !defined $conf->{filename} ) {
        $self->error(
            "You must supply either the 'xml' or the 'filename' to use");
        return undef;
    }

    # Check the filename if supplied
    if ( defined $conf->{filename} ) {

        # Got a filename, see if it is readable
        unless ( -r $conf->{filename} ) {
            $self->error( "Unable to read: " . $conf->{filename} );
            return undef;
        } else {

            # Ok, read it in
            my $file_xml = read_file( $conf->{filename} );
            $conf->{xml} = $file_xml;
        }
    }

    # create a builder
    $self->{sdb} = SOAP::Data::Builder->new();

    unless ( $conf->{xml} eq '' ) {

        # add some wrapping paper so XML::LibXML likes it with no top level
        my $xml_data
            = '' . $conf->{xml} . '';
        my $xml;
        eval { $xml = $parser->parse_string($xml_data) };
        if ($@) {
            $self->error( 'Error parsing your XML: ' . $@ );
            return undef;
        }

        # Create the SOAP data from the XML
        my $nodes = $xml->childNodes;
        my $top   = $nodes->get_node(1);    # our wrapper
        if ( my $nodes = $top->childNodes ) {
            foreach my $node ( @{$nodes} ) {
                $self->_process_node( { node => $node } );
            }
        }
    }

    ################
    ## Execute the call and get the result back
    ################

    carp "About to run _call()" if $DEBUG;

#use Data::Dumper;
#print Dumper($self->{sdb}->to_soap_data());
#my $serialized_xml = SOAP::Serializer->autotype(0)->serialize( $self->{sdb}->to_soap_data() );
#carp "IF WE GET HERE IT WORKED!!!!!!!";
#print Dumper($self->{sdb}->elems());

    # execute the call in the relevant style done by the child object
    my ( $res, $transport ) = $self->_call( $conf->{method} );

    $self->transport( $transport );
    $self->status( $transport->status );

# TODO: actually need to specify encoding expected in return (or parse from response?)
    $res = decode( $self->{encoding}, $res );

    carp "After run _call()" if $DEBUG;

    if ( !defined $res or $res =~ /^\d/ or !$transport->is_success ) {

        # Got a web error - if it was XML it wouldn't start with a digit!
        $self->error($res);
        return undef;
    } else {

        # Strip out default name space stuff as it makes it hard
        # to parse and there's no reason for it I can see!
        $res =~ s/xmlns=".*?"//g if $self->strip_default_xmlns();

        # Generate xml object from the responce
        my $res_xml;
        eval { $res_xml = $parser->parse_string($res) };
        if ($@) {

            # Not valid xml
            $self->error( 'Unable to parse returned data as XML: ' . $@ );
            return undef;
        } else {

            # Now look for faults
            if ( my $nodes = $res_xml->findnodes("//faultstring") ) {

                # loop through faultstrings - checking it's parent is 'Fault'
                # We do not care about namespaces
                foreach my $node ( $nodes->get_nodelist() ) {
                    my $parentnode = $node->parentNode();
                    if ( $parentnode->nodeName() =~ /Fault/ ) {

                        # There is a "(*:)Fault/faultstring"
                        # get the human readable string
                        $self->error(
                            $nodes->get_node(1)->findvalue( '.', $nodes ) );
                        last;
                    }
                }
            }

            # See if there was a fault
            return undef if $self->error();

            # All looking good
            $self->results_xml($res_xml);
            $self->results($res);

            # I tried just return; but it didn't like it!
            return 1;
        }
    }
}

### Private methods

# Convert the XML to SOAP::Data::Builder
sub _process_node {
    my ( $self, $conf ) = @_;

    # We never access text nodes directly, only via the parent node
    return if $conf->{node}->nodeType == 3;

    carp "PROCESSING: " . $conf->{node}->nodeName() if $DEBUG;

    # Set up the parent if there was one
    my $parent = undef;
    $parent = $conf->{parent} if defined $conf->{parent};

    if ( $DEBUG && defined $parent ) {
        carp "PARENT NAME:" . $parent->{fullname};
    }

    my $type = undef;

    # Extract the attributes from the node
    my %attribs;
    foreach my $att ( $conf->{node}->attributes() ) {

        # skip anything which isn't defined!
        next unless defined $att;

        # Check if it's our 'special' value
        if ( $att->name() eq '_value_type' ) {
            $type = $att->value();
        } else {
            $attribs{ $att->name() } = $att->value();
        }
    }

    my @t = $conf->{node}->childNodes();

    # If we have 1 child and that child is text then use the content
    # of the child as our value we must also be at the end of the tree
    if ( scalar(@t) == 1
        && $conf->{node}->childNodes()->get_node(1)->nodeType() == 3 )
    {

        #return;
        my $value = $conf->{node}->childNodes()->get_node(1)->textContent();
        carp "ADDING : " . $conf->{node}->nodeName . " Value: $value"
            if $DEBUG;
        $self->{sdb}->add_elem(
            name       => $conf->{node}->nodeName,
            attributes => \%attribs,
            parent     => $parent,
            value      => $value,
            type       => $type,
        );

        carp "END OF THE LINE BUDDY!" if $DEBUG;
    } else {
        carp "- FOUND CHILD NODES" if $DEBUG;

        # Add it - it's a node without a value, but has child nodes
        my $obj;
        if ( defined $parent ) {
            carp "ADDING ELEMENT WITH PARENT: " . $conf->{node}->nodeName
                if $DEBUG;

            # Add with the parent
            $obj = $self->{sdb}->add_elem(
                name       => $conf->{node}->nodeName,
                attributes => \%attribs,
                parent     => $parent,
            );
        } else {
            carp "ADDING ELEMENT WITH NO PARENT: " . $conf->{node}->nodeName
                if $DEBUG;

            # Add with the parent
            # Add without parent
            $obj = $self->{sdb}->add_elem(
                name       => $conf->{node}->nodeName,
                attributes => \%attribs,
            );
        }

        foreach my $node ( $conf->{node}->childNodes() ) {

            # process each child node as long as it's not
            # a text node (type 3)
            $self->_process_node(
                {   'node'   => $node,
                    'parent' => $obj,
                }
            );
        }
    }
}

1;

__END__