File Coverage

blib/lib/SOAP/Transport/TCP.pm
Criterion Covered Total %
statement 30 129 23.2
branch 0 56 0.0
condition 0 36 0.0
subroutine 10 24 41.6
pod n/a
total 40 245 16.3


line stmt bran cond sub pod time code
1             # ======================================================================
2             #
3             # Copyright (C) 2000-2001 Paul Kulchenko (paulclinger@yahoo.com)
4             # SOAP::Lite is free software; you can redistribute it
5             # and/or modify it under the same terms as Perl itself.
6             #
7             # $Id: TCP.pm 384 2011-08-16 17:08:08Z kutterma $
8             #
9             # ======================================================================
10              
11             package SOAP::Transport::TCP;
12              
13 1     1   6536 use strict;
  1         3  
  1         70  
14              
15             our $VERSION = 1.11;
16              
17 1     1   7 use URI;
  1         2  
  1         25  
18 1     1   2480 use IO::Socket;
  1         32244  
  1         7  
19 1     1   1968 use IO::Select;
  1         1831  
  1         58  
20 1     1   918 use IO::SessionData;
  1         11573  
  1         97  
21              
22             # ======================================================================
23              
24             package URI::tcp; # ok, let's do 'tcp://' scheme
25              
26             our $VERSION = 0.715;
27              
28             require URI::_server;
29             @URI::tcp::ISA=qw(URI::_server);
30              
31             # ======================================================================
32              
33             package SOAP::Transport::TCP::Client;
34              
35             our $VERSION = 0.715;
36              
37 1     1   9 use vars qw(@ISA);
  1         1  
  1         990  
38             require SOAP::Lite;
39             @ISA = qw(SOAP::Client);
40              
41 0     0     sub DESTROY { SOAP::Trace::objects('()') }
42              
43             sub new {
44 0     0     my $self = shift;
45              
46 0 0         unless (ref $self) {
47 0   0       my $class = ref($self) || $self;
48 0           my(@params, @methods);
49 0 0         while (@_) { $class->can($_[0]) ? push(@methods, shift() => shift) : push(@params, shift) }
  0            
50 0           $self = bless {@params} => $class;
51 0           while (@methods) { my($method, $params) = splice(@methods,0,2);
  0            
52 0 0         $self->$method(ref $params eq 'ARRAY' ? @$params : $params)
53             }
54             # use SSL if there is any parameter with SSL_* in the name
55 0 0 0       $self->SSL(1) if !$self->SSL && grep /^SSL_/, keys %$self;
56 0           SOAP::Trace::objects('()');
57             }
58 0           return $self;
59             }
60              
61             sub SSL {
62 0     0     my $self = shift->new;
63 0 0         @_ ? ($self->{_SSL} = shift, return $self) : return $self->{_SSL};
64             }
65              
66 0 0   0     sub io_socket_class { shift->SSL ? 'IO::Socket::SSL' : 'IO::Socket::INET' }
67              
68             sub syswrite {
69 0     0     my($self, $sock, $data) = @_;
70              
71 0           my $timeout = $sock->timeout;
72              
73 0           my $select = IO::Select->new($sock);
74              
75 0           my $len = length $data;
76 0           while (length $data > 0) {
77 0 0         return unless $select->can_write($timeout);
78 0           local $SIG{PIPE} = 'IGNORE';
79             # added length() to make it work on Mac. Thanks to Robin Fuller
80 0           my $wc = syswrite($sock, $data, length($data));
81 0 0         if (defined $wc) {
    0          
82 0           substr($data, 0, $wc) = '';
83             } elsif (!IO::SessionData::WOULDBLOCK($!)) {
84 0           return;
85             }
86             }
87 0           return $len;
88             }
89              
90             sub sysread {
91 0     0     my($self, $sock) = @_;
92              
93 0           my $timeout = $sock->timeout;
94 0           my $select = IO::Select->new($sock);
95              
96 0           my $result = '';
97 0           my $data;
98 0           while (1) {
99 0 0         return unless $select->can_read($timeout);
100 0           my $rc = sysread($sock, $data, 4096);
101 0 0         if ($rc) {
    0          
    0          
102 0           $result .= $data;
103             } elsif (defined $rc) {
104 0           return $result;
105             } elsif (!IO::SessionData::WOULDBLOCK($!)) {
106 0           return;
107             }
108             }
109             }
110              
111             sub send_receive {
112 0     0     my($self, %parameters) = @_;
113 0           my($envelope, $endpoint, $action) =
114             @parameters{qw(envelope endpoint action)};
115              
116 0   0       $endpoint ||= $self->endpoint;
117 0 0 0       warn "URLs with 'tcp:' scheme are deprecated. Use 'tcp://'. Still continue\n"
118             if $endpoint =~ s!^tcp:(//)?!tcp://!i && !$1;
119 0           my $uri = URI->new($endpoint);
120              
121 0           local($^W, $@, $!);
122 0           my $socket = $self->io_socket_class;
123 0 0 0       eval "require $socket" or Carp::croak $@ unless UNIVERSAL::can($socket => 'new');
124 0           my $sock = $socket->new (
125             PeerAddr => $uri->host, PeerPort => $uri->port, Proto => $uri->scheme, %$self
126             );
127              
128 0           SOAP::Trace::debug($envelope);
129              
130             # bytelength hack. See SOAP::Transport::HTTP.pm for details.
131 0           my $bytelength = SOAP::Utils::bytelength($envelope);
132 0 0 0       $envelope = pack('C0A*', $envelope)
133             if !$SOAP::Constants::DO_NOT_USE_LWP_LENGTH_HACK && length($envelope) != $bytelength;
134              
135 0           my $result;
136 0 0         if ($sock) {
137 0           $sock->blocking(0);
138 0 0 0       $self->syswrite($sock, $envelope) and
139             $sock->shutdown(1) and # stop writing
140             $result = $self->sysread($sock);
141             }
142              
143 0           SOAP::Trace::debug($result);
144              
145 0   0       my $code = $@ || $!;
146              
147 0           $self->code($code);
148 0           $self->message($code);
149 0   0       $self->is_success(!defined $code || $code eq '');
150 0           $self->status($code);
151              
152 0           return $result;
153             }
154              
155             # ======================================================================
156              
157             package SOAP::Transport::TCP::Server;
158              
159 1     1   17 use IO::SessionSet;
  1         2  
  1         58  
160              
161 1     1   5 use Carp ();
  1         3  
  1         25  
162 1     1   5 use vars qw($AUTOLOAD @ISA);
  1         2  
  1         462  
163             @ISA = qw(SOAP::Server);
164              
165             our $VERSION = 0.715;
166              
167 0     0     sub DESTROY { SOAP::Trace::objects('()') }
168              
169             sub new {
170 0     0     my $self = shift;
171              
172 0 0         unless (ref $self) {
173 0   0       my $class = ref($self) || $self;
174              
175 0           my(@params, @methods);
176 0 0         while (@_) { $class->can($_[0]) ? push(@methods, shift() => shift) : push(@params, shift) }
  0            
177 0           $self = $class->SUPER::new(@methods);
178              
179             # use SSL if there is any parameter with SSL_* in the name
180 0 0 0       $self->SSL(1) if !$self->SSL && grep /^SSL_/, @params;
181              
182 0           my $socket = $self->io_socket_class;
183 0 0 0       eval "require $socket" or Carp::croak $@ unless UNIVERSAL::can($socket => 'new');
184 0 0         $self->{_socket} = $socket->new(Proto => 'tcp', @params)
185             or Carp::croak "Can't open socket: $!";
186              
187 0           SOAP::Trace::objects('()');
188             }
189 0           return $self;
190             }
191              
192             sub SSL {
193 0     0     my $self = shift->new;
194 0 0         @_ ? ($self->{_SSL} = shift, return $self) : return $self->{_SSL};
195             }
196              
197 0 0   0     sub io_socket_class { shift->SSL ? 'IO::Socket::SSL' : 'IO::Socket::INET' }
198              
199             sub AUTOLOAD {
200 0     0     my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2);
201 0 0         return if $method eq 'DESTROY';
202              
203 1     1   5 no strict 'refs';
  1         3  
  1         264  
204 0     0     *$AUTOLOAD = sub { shift->{_socket}->$method(@_) };
  0            
205 0           goto &$AUTOLOAD;
206             }
207              
208             sub handle {
209 0     0     my $self = shift->new;
210 0           my $sock = $self->{_socket};
211 0           my $session_set = IO::SessionSet->new($sock);
212 0           my %data;
213 0           while (1) {
214 0           my @ready = $session_set->wait($sock->timeout);
215 0           for my $session (grep { defined } @ready) {
  0            
216 0           my $data;
217 0 0         if (my $rc = $session->read($data, 4096)) {
218 0 0         $data{$session} .= $data if $rc > 0;
219             } else {
220 0           $session->write($self->SUPER::handle(delete $data{$session}));
221 0           $session->close;
222             }
223             }
224             }
225             }
226              
227             # ======================================================================
228              
229             1;
230              
231             __END__