File: Transport.pm

package info (click to toggle)
libxml-compile-soap-perl 3.26%2Bds-1
  • links: PTS, VCS
  • area: non-free
  • in suites: bullseye
  • size: 616 kB
  • sloc: perl: 4,406; makefile: 7
file content (127 lines) | stat: -rw-r--r-- 3,482 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
# Copyrights 2007-2019 by [Mark Overmeer <markov@cpan.org>].
#  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;