File Coverage

lib/XML/Compile/Transport.pm

Criterion	Covered	Total	%
statement	65	82	79.2
branch	10	24	41.6
condition	5	13	38.4
subroutine	14	18	77.7
pod	5	8	62.5
total	99	145	68.2

# Copyrights 2007-2019 by [Mark Overmeer ].
#  For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 2.02.
# This code is part of distribution XML-Compile-SOAP.  Meta-POD processed
# with OODoc into POD and HTML manual-pages.  See README.md
# Copyright Mark Overmeer.  Licensed under the same terms as Perl itself.

package XML::Compile::Transport;
use vars '$VERSION';
$VERSION = '3.26';

use base 'XML::Compile::SOAP::Extension';

use warnings;
use strict;

use Log::Report     'xml-compile-soap';

use Log::Report::Exception ();

use XML::LibXML     ();
use Time::HiRes     qw/time/;


sub init($)
{   my ($self, $args) = @_;
    $self->SUPER::init($args);
    $self->{charset} = $args->{charset} || 'UTF-8';

    my $addr  = $args->{address} || 'http://localhost';
    my @addrs = ref $addr eq 'ARRAY' ? @$addr : $addr;

    $self->{addrs} = \@addrs;
    $self;
}

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


sub charset() {shift->{charset}}


sub addresses() { @{shift->{addrs}} }


sub address()
{   my $addrs = shift->{addrs};
    @$addrs==1 ? $addrs->[0] : $addrs->[rand @$addrs];
}

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


sub compileClient(@)
{   my ($self, %args) = @_;
    my $call   = $self->_prepare_call(\%args);
    my $kind   = $args{kind} || 'request-response';
    my $format = $args{xml_format} || 0;

    sub
    {   my ($xmlout, $trace, $mtom) = @_;
        my $start     = time;
        my $textout   = ref $xmlout ? $xmlout->toString($format) : $xmlout;
#warn $xmlout->toString(1);   # show message sent

        my $stringify = time;
        $trace->{stringify_elapse} = $stringify - $start;
        $trace->{transport_start}  = $start;

        my ($textin, $xops) = try { $call->(\$textout, $trace, $mtom) };
        my $connected = time;
        $trace->{connect_elapse}   = $connected - $stringify;
        if($@)
        {   $trace->{errors} = [$@->wasFatal];
            return;
        }

        my $xmlin;
        if($textin)
        {   $xmlin = try {XML::LibXML->load_xml(string => $$textin)};
            if($@) { $trace->{errors} = [$@->wasFatal] }
            else   { $trace->{response_dom} = $xmlin }
        }

        my $answer = $xmlin;
        if($kind eq 'one-way')
        {   my $response = $trace->{http_response};
            my $code = defined $response ? $response->code : -1;
            if($code==202) { $answer ||= {} }
            else
            {   push @{$trace->{errors}}, Log::Report::Exception->new
                 (reason => 'error', message => __"call failed with code $code")
            }
        }
        elsif(!$xmlin)
        {   push @{$trace->{errors}}, Log::Report::Exception->new
              (reason => 'error', message => __"no xml as answer");
        }

        my $end = $trace->{transport_end} = time;

        $trace->{parse_elapse}     = $end - $connected;
        $trace->{transport_elapse} = $end - $start;

        wantarray || ! keys %$xops
            or warning "loosing received XOPs";

        wantarray ? ($answer, $xops) : $answer;
    }
}

sub _prepare_call($) { panic "not implemented" }

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


{   my %registered;
    sub register($)   { my ($class, $uri) = @_; $registered{$uri} = $class }
    sub plugin($)     { my ($class, $uri) = @_; $registered{$uri} }
    sub registered($) { values %registered }
}

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


1;