package SOAP::XML::Client;

use strict;
use Carp;
use XML::LibXML;
use SOAP::Lite;
use SOAP::Data::Builder;
use File::Slurp;

use vars qw($VERSION $DEBUG);

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

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

# wsdk

__PACKAGE__->mk_accessors(@methods);

$DEBUG = 0;

$VERSION = 2.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);

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 }, $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} );
        }
    }

    # 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 =
          '<soap_lite_wrapper>' . $conf->{xml} . '</soap_lite_wrapper>';
        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 = $self->_call( $conf->{method} );

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

    if ( !defined $res or $res =~ /^\d/ ) {

        # 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__

=head1 NAME

SOAP::XML::Client - Simple frame work for talking with web services

=head1 DESCRIPTION

This package is the base class for talking with web services,
there are specific modules to use depending on the type
of service you are calling, e.g. C<SOAP::XML::Client::DotNet> or
C<SOAP::XML::Client::Generic>

This package helps in talking with web services, it just needs
a bit of XML thrown at it and you get some XML back.
It's designed to be REALLY simple to use.

=head1 SYNOPSIS

  See SOAP::XML::Client::DotNet or SOAP::XML::Client::Generic for usage example.

  If you are creating a child class you just need to
  impliment the actual _call() - see pod below.

=head1 methods

=head2 new()

  my $soap_client = SOAP::XML::Client::DotNet->new({
    uri 	=> 'http://www.yourdomain.com/services',
    proxy 	=> 'http://www.yourproxy.com/services/services.asmx',
    xmlns 	=> 'http://www.yourdomain.com/services',
    soapversion => '1.1',     # defaults to 1.1
    timeout	=> '30',      # detauls to 30 seconds
    strip_default_xmlns => 1, # defaults to 1
  });

This constructor requires uri, proxy and xmlns to be
supplied, otherwise it will croak.

strip_default_xmlns is used to remove xmlns="http://.../"
from returned XML, it will NOT alter xmlns:FOO="http//.../"
set to '0' if you do not wish for this to happen.

If you pass an encoding option then the SOAP message will be flagged
as that encoding (this defaults to UTF8):

   ...
     encoding => 'iso-8859-1',
   ...

To stop SOAP::Lite being overly keen to encode values as Base64, pass
in disable_base64:

   ...
     disable_base64 => 1,
   ...

=head2 fetch()

  # Generate the required XML, this is the bit after the Method XML element
  # in the services.asmx descriptor for this method (see SOAP::XML::Client::DotNet SYNOPSIS).
  my $user_id = '900109';
  my $xml = "<userId _value_type='long'>$user_id</userId>";

  if($soap_client->fetch({ method => 'GetActivity', xml => $xml }) {
      # Get result as a string
      my $xml_string = $soap_client->result();

      # Get result as a XML::LibXML object
      my $xml_libxml_object = $soap_client->result_xml();

  } else {
      # There was some sort of error
      print $soap_client->error() . "\n";
  }

This method actually calls the web service, it takes a method name
and an xml string. If there is a problem with either the XML or
the SOAP transport (e.g. web server error/could not connect etc)
undef will be returned and the error() will be set.

Each node in the XML supplied (either by string or from a filename)
needs to have _value_type defined or the submitted format will
default to 'string'.

You can supply 'filename' rather than 'xml' and it will read in from
the file.

We check for Fault/faultstring in the returned XML,
anything else you'll need to check for yourself.

=head2 error()

  $soap_client->error();

If fetch returns undef then check this method, it will either be that the filename you
supplied couldn't be read, the XML you supplied was not correctly formatted (XML::LibXML 
could not parse it), there was a transport error with the web service or Fault/faultstring
was found in the XML returned.

=head2 results();

  my $results = $soap_client->results();

Can be called after fetch() to get the raw XML, if fetch was sucessful.

=head2 results_xml();

  my $results_as_xml = $soap_client->results_xml();

Can be called after fetch() to get the XML::LibXML Document element of the returned
xml, as long as fetch was sucessful.

=head1 HOW TO DEBUG

At the top of your script, before 'use SOAP::XML::Client::<TYPE>' add:

use SOAP::Lite (  +trace => 'all',
                  readable => 1,
                  outputxml => 1,
               );

It may or may not help, not all web services give you many helpful error messages!
At least you can see what's being submitted and returned. It can be the
smallest thing that causes a problem, mis-typed data (see _value_type in xml),
or typo in xmlns line.

If the type of module (e.g. SOAP::XML::Client::DotNet) doesn't work, switch
to one of the other ones and see if that helps. 

=head2 _call()

  This should be implimented by the child class

  package SOAP::XML::Client::<PACKAGE NAME>;

  use base qw(SOAP::XML::Client);

  sub _call {
	my ($self,$method) = @_;

	# Impliment it! - below is the code from SOAP::XML::Client::DotNet

	# This code is the .NET specific way of calling SOAP,
	# it might work for other stuff as well        
        my $soap_action = sub {return $self->uri() . '/' . $method};
        
        my $caller = $self->{soap}
                        ->uri($self->uri())
                        ->proxy($self->proxy(), timeout => $self->timeout())
                        ->on_action( $soap_action );
        
        $caller->soapversion($self->soapversion());

        # Create a SOAP::Data node for the method name
        my $method_name = SOAP::Data->name($method)->attr({'xmlns' => $self->xmlns()});
  
        # Execute the SOAP Request and get the resulting XML
        my $res = $caller->call( $method_name => $self->{sdb}->to_soap_data());

        return $res;
  }

  1;

=head1 SEE ALSO

<SOAP::XML::Client::DotNet> <SOAP::XML::Client::Generic>

=head1 AUTHOR

Leo Lapworth <LLAP@cuckoo.org>

=head1 COPYRIGHT

(c) 2005 Leo Lapworth

This library is free software, you can use it under the same 
terms as perl itself.

=head1 THANKS

Thanks to Foxtons for letting me develope this on their time and
to Aaron for his help with understanding SOAP a bit more and
the London.pm list for ideas.

=cut