Diff of /SOAP-Transport-TCP/trunk/lib/SOAP/Transport/TCP.pm [000000] .. [r389]  Maximize  Restore

Switch to unified view

a b/SOAP-Transport-TCP/trunk/lib/SOAP/Transport/TCP.pm
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
use strict;
14
15
our $VERSION = 0.715;
16
17
use URI;
18
use IO::Socket;
19
use IO::Select;
20
use IO::SessionData;
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
use vars qw(@ISA);
38
require SOAP::Lite;
39
@ISA = qw(SOAP::Client);
40
41
sub DESTROY { SOAP::Trace::objects('()') }
42
43
sub new {
44
  my $self = shift;
45
46
  unless (ref $self) {
47
    my $class = ref($self) || $self;
48
    my(@params, @methods);
49
    while (@_) { $class->can($_[0]) ? push(@methods, shift() => shift) : push(@params, shift) }
50
    $self = bless {@params} => $class;
51
    while (@methods) { my($method, $params) = splice(@methods,0,2);
52
      $self->$method(ref $params eq 'ARRAY' ? @$params : $params)
53
    }
54
    # use SSL if there is any parameter with SSL_* in the name
55
    $self->SSL(1) if !$self->SSL && grep /^SSL_/, keys %$self;
56
    SOAP::Trace::objects('()');
57
  }
58
  return $self;
59
}
60
61
sub SSL {
62
  my $self = shift->new;
63
  @_ ? ($self->{_SSL} = shift, return $self) : return $self->{_SSL};
64
}
65
66
sub io_socket_class { shift->SSL ? 'IO::Socket::SSL' : 'IO::Socket::INET' }
67
68
sub syswrite {
69
  my($self, $sock, $data) = @_;
70
71
  my $timeout = $sock->timeout;
72
73
  my $select = IO::Select->new($sock);
74
75
  my $len = length $data;
76
  while (length $data > 0) {
77
    return unless $select->can_write($timeout);
78
    local $SIG{PIPE} = 'IGNORE';
79
    # added length() to make it work on Mac. Thanks to Robin Fuller <rfuller@broadjump.com>
80
    my $wc = syswrite($sock, $data, length($data));
81
    if (defined $wc) {
82
      substr($data, 0, $wc) = '';
83
    } elsif (!IO::SessionData::WOULDBLOCK($!)) {
84
      return;
85
    }
86
  }
87
  return $len;
88
}
89
90
sub sysread {
91
  my($self, $sock) = @_;
92
93
  my $timeout = $sock->timeout;
94
  my $select = IO::Select->new($sock);
95
96
  my $result = '';
97
  my $data;
98
  while (1) {
99
    return unless $select->can_read($timeout);
100
    my $rc = sysread($sock, $data, 4096);
101
    if ($rc) {
102
      $result .= $data;
103
    } elsif (defined $rc) {
104
      return $result;
105
    } elsif (!IO::SessionData::WOULDBLOCK($!)) {
106
      return;
107
    }
108
  }
109
}
110
111
sub send_receive {
112
  my($self, %parameters) = @_;
113
  my($envelope, $endpoint, $action) =
114
    @parameters{qw(envelope endpoint action)};
115
116
  $endpoint ||= $self->endpoint;
117
  warn "URLs with 'tcp:' scheme are deprecated. Use 'tcp://'. Still continue\n"
118
    if $endpoint =~ s!^tcp:(//)?!tcp://!i && !$1;
119
  my $uri = URI->new($endpoint);
120
121
  local($^W, $@, $!);
122
  my $socket = $self->io_socket_class;
123
  eval "require $socket" or Carp::croak $@ unless UNIVERSAL::can($socket => 'new');
124
  my $sock = $socket->new (
125
    PeerAddr => $uri->host, PeerPort => $uri->port, Proto => $uri->scheme, %$self
126
  );
127
128
  SOAP::Trace::debug($envelope);
129
130
  # bytelength hack. See SOAP::Transport::HTTP.pm for details.
131
  my $bytelength = SOAP::Utils::bytelength($envelope);
132
  $envelope = pack('C0A*', $envelope)
133
    if !$SOAP::Constants::DO_NOT_USE_LWP_LENGTH_HACK && length($envelope) != $bytelength;
134
135
  my $result;
136
  if ($sock) {
137
    $sock->blocking(0);
138
    $self->syswrite($sock, $envelope)  and
139
     $sock->shutdown(1)                and # stop writing
140
     $result = $self->sysread($sock);
141
  }
142
143
  SOAP::Trace::debug($result);
144
145
  my $code = $@ || $!;
146
147
  $self->code($code);
148
  $self->message($code);
149
  $self->is_success(!defined $code || $code eq '');
150
  $self->status($code);
151
152
  return $result;
153
}
154
155
# ======================================================================
156
157
package SOAP::Transport::TCP::Server;
158
159
use IO::SessionSet;
160
161
use Carp ();
162
use vars qw($AUTOLOAD @ISA);
163
@ISA = qw(SOAP::Server);
164
165
our $VERSION = 0.715;
166
167
sub DESTROY { SOAP::Trace::objects('()') }
168
169
sub new {
170
  my $self = shift;
171
172
  unless (ref $self) {
173
    my $class = ref($self) || $self;
174
175
    my(@params, @methods);
176
    while (@_) { $class->can($_[0]) ? push(@methods, shift() => shift) : push(@params, shift) }
177
    $self = $class->SUPER::new(@methods);
178
179
    # use SSL if there is any parameter with SSL_* in the name
180
    $self->SSL(1) if !$self->SSL && grep /^SSL_/, @params;
181
182
    my $socket = $self->io_socket_class;
183
    eval "require $socket" or Carp::croak $@ unless UNIVERSAL::can($socket => 'new');
184
    $self->{_socket} = $socket->new(Proto => 'tcp', @params)
185
      or Carp::croak "Can't open socket: $!";
186
187
    SOAP::Trace::objects('()');
188
  }
189
  return $self;
190
}
191
192
sub SSL {
193
  my $self = shift->new;
194
  @_ ? ($self->{_SSL} = shift, return $self) : return $self->{_SSL};
195
}
196
197
sub io_socket_class { shift->SSL ? 'IO::Socket::SSL' : 'IO::Socket::INET' }
198
199
sub AUTOLOAD {
200
  my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2);
201
  return if $method eq 'DESTROY';
202
203
  no strict 'refs';
204
  *$AUTOLOAD = sub { shift->{_socket}->$method(@_) };
205
  goto &$AUTOLOAD;
206
}
207
208
sub handle {
209
  my $self = shift->new;
210
  my $sock = $self->{_socket};
211
  my $session_set = IO::SessionSet->new($sock);
212
  my %data;
213
  while (1) {
214
    my @ready = $session_set->wait($sock->timeout);
215
    for my $session (@ready) {
216
      my $data;
217
      if (my $rc = $session->read($data, 4096)) {
218
        $data{$session} .= $data if $rc > 0;
219
      } else {
220
        $session->write($self->SUPER::handle(delete $data{$session}));
221
        $session->close;
222
      }
223
    }
224
  }
225
}
226
227
# ======================================================================
228
229
1;
230
231
__END__
232
233
234
=head1 NAME
235
236
SOAP::Transport::TCP - TCP Transport Support for SOAP::Lite
237
238
=head2 SOAP::Transport::TCP
239
240
The classes provided by this module implement direct TCP/IP communications methods for both clients and servers.
241
242
The connections don't use HTTP or any other higher-level protocol. These classes are selected when the client or server object being created uses an endpoint URI that starts with tcp://. Both client and server classes support using Secure Socket Layer if it is available. If any of the parameters to a new method from either of the classes begins with SSL_ (such as SSL_server in place of Server), the class attempts to load the IO::Socket::SSL package and use it to create socket objects.
243
244
Both of the following classes catch methods that are intended for the socket objects and pass them along, allowing calls such as $client->accept( ) without including the socket class in the inheritance tree.
245
246
=head3 SOAP::Transport::TCP::Client
247
248
Inherits from: L<SOAP::Client>.
249
250
The TCP client class defines only two relevant methods beyond new and send_receive. These methods are:
251
252
=over
253
254
=item SSL(I<optional new boolean value>)
255
256
    if ($client->SSL) # Execute only if in SSL mode
257
258
Reflects the attribute that denotes whether the client object is using SSL sockets for communications.
259
260
=item io_socket_class
261
262
    ($client->io_socket_class)->new(%options);
263
264
Returns the name of the class to use when creating socket objects for internal use in communications. As implemented, it returns one of IO::Socket::INET or IO::Socket::SSL, depending on the return value of the previous SSL method.
265
266
=back
267
268
If an application creates a subclass that inherits from this client class, either method is a likely target for overloading.
269
270
The new method behaves identically to most other classes, except that it detects the presence of SSL-targeted values in the parameter list and sets the SSL method appropriately if they are present.
271
272
The send_receive method creates a socket of the appropriate class and connects to the configured endpoint. It then sets the socket to nonblocking I/O, sends the message, shuts down the client end of the connection (preventing further writing), and reads the response back from the server. The socket object is discarded after the response and
273
appropriate status codes are set on the client object.
274
275
=head3 SOAP::Transport::TCP::Server
276
277
Inherits from: L<SOAP::Server>.
278
279
The server class also defines the same two additional methods as in the client class:
280
281
=over
282
283
=item SSL(I<optional new boolean value>)
284
285
    if ($client->SSL) # Execute only if in SSL mode
286
287
Reflects the attribute that denotes whether the client object is using SSL sockets for communications.
288
289
=item io_socket_class
290
291
    ($client->io_socket_class)->new(%options);
292
293
Returns the name of the class to use when creating socket objects for internal use in communications. As implemented, it returns one of IO::Socket::INET or IO::Socket::SSL, depending on the return value of the previous SSL method. The new method also manages the automatic selection of SSL in the same fashion as the client class does.
294
295
The handle method in this server implementation isn't designed to be called once with each new request. Rather, it is called with no arguments, at which time it enters into an infinite loop of waiting for a connection, reading the request, routing the request and sending back the serialized response. This continues until the process itself is interrupted by an untrapped signal or similar means.
296
297
=back
298
299
=head1 COPYRIGHT
300
301
Copyright (C) 2000-2004 Paul Kulchenko. All rights reserved.
302
303
This library is free software; you can redistribute it and/or modify
304
it under the same terms as Perl itself.
305
306
=head1 AUTHORS
307
308
Written by Paul Kulchenko.
309
310
Split from SOAP::Lite and SOAP-Transport-TCP packaging by Martin Kutter
311
312
=cut