home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _fee332f30cc33fa3fc4d5896d5980c5c < prev    next >
Encoding:
Text File  |  2004-06-01  |  6.8 KB  |  256 lines
  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,v 1.4 2002/04/15 19:09:57 paulk Exp $
  8. #
  9. # ======================================================================
  10.  
  11. package SOAP::Transport::TCP;
  12.  
  13. use strict;
  14. use vars qw($VERSION);
  15. $VERSION = sprintf("%d.%s", map {s/_//g; $_} q$Name: release-0_55-public $ =~ /-(\d+)_([\d_]+)/);
  16.  
  17. use URI;
  18. use IO::Socket;
  19. use IO::Select;
  20. use IO::SessionData;
  21. use SOAP::Lite;
  22.  
  23. # ======================================================================
  24.  
  25. package URI::tcp; # ok, let's do 'tcp://' scheme
  26. require URI::_server; 
  27. @URI::tcp::ISA=qw(URI::_server);
  28.  
  29. # ======================================================================
  30.  
  31. package SOAP::Transport::TCP::Client;
  32.  
  33. use vars qw(@ISA);
  34. @ISA = qw(SOAP::Client);
  35.  
  36. sub DESTROY { SOAP::Trace::objects('()') }
  37.  
  38. sub new { 
  39.   my $self = shift;
  40.  
  41.   unless (ref $self) {
  42.     my $class = ref($self) || $self;
  43.     my(@params, @methods);
  44.     while (@_) { $class->can($_[0]) ? push(@methods, shift() => shift) : push(@params, shift) }
  45.     $self = bless {@params} => $class;
  46.     while (@methods) { my($method, $params) = splice(@methods,0,2);
  47.       $self->$method(ref $params eq 'ARRAY' ? @$params : $params) 
  48.     }
  49.     # use SSL if there is any parameter with SSL_* in the name
  50.     $self->SSL(1) if !$self->SSL && grep /^SSL_/, keys %$self;
  51.     SOAP::Trace::objects('()');
  52.   }
  53.   return $self;
  54. }
  55.  
  56. sub SSL {
  57.   my $self = shift->new;
  58.   @_ ? ($self->{_SSL} = shift, return $self) : return $self->{_SSL};
  59. }
  60.  
  61. sub io_socket_class { shift->SSL ? 'IO::Socket::SSL' : 'IO::Socket::INET' }
  62.  
  63. sub syswrite {
  64.   my($self, $sock, $data) = @_;
  65.  
  66.   my $timeout = $sock->timeout;
  67.  
  68.   my $select = IO::Select->new($sock);
  69.  
  70.   my $len = length $data;
  71.   while (length $data > 0) {
  72.     return unless $select->can_write($timeout);
  73.     local $SIG{PIPE} = 'IGNORE';
  74.     # added length() to make it work on Mac. Thanks to Robin Fuller <rfuller@broadjump.com>
  75.     my $wc = syswrite($sock, $data, length($data));
  76.     if (defined $wc) {
  77.       substr($data, 0, $wc) = '';
  78.     } elsif (!IO::SessionData::WOULDBLOCK($!)) {
  79.       return;
  80.     }
  81.   }
  82.   return $len;
  83. }
  84.  
  85. sub sysread {
  86.   my($self, $sock) = @_;
  87.  
  88.   my $timeout = $sock->timeout;
  89.   my $select = IO::Select->new($sock);
  90.  
  91.   my $result = '';
  92.   my $data;
  93.   while (1) {
  94.     return unless $select->can_read($timeout);
  95.     my $rc = sysread($sock, $data, 4096);
  96.     if ($rc) {
  97.       $result .= $data;
  98.     } elsif (defined $rc) {
  99.       return $result;
  100.     } elsif (!IO::SessionData::WOULDBLOCK($!)) {
  101.       return;
  102.     }
  103.   }
  104. }
  105.  
  106. sub send_receive {
  107.   my($self, %parameters) = @_;
  108.   my($envelope, $endpoint, $action) = 
  109.     @parameters{qw(envelope endpoint action)};
  110.  
  111.   $endpoint ||= $self->endpoint;
  112.   warn "URLs with 'tcp:' scheme are deprecated. Use 'tcp://'. Still continue\n"
  113.     if $endpoint =~ s!^tcp:(//)?!tcp://!i && !$1;
  114.   my $uri = URI->new($endpoint);
  115.  
  116.   local($^W, $@, $!);
  117.   my $socket = $self->io_socket_class; 
  118.   eval "require $socket" or Carp::croak $@ unless UNIVERSAL::can($socket => 'new');
  119.   my $sock = $socket->new (
  120.     PeerAddr => $uri->host, PeerPort => $uri->port, Proto => $uri->scheme, %$self
  121.   );
  122.  
  123.   SOAP::Trace::debug($envelope);
  124.  
  125.   # bytelength hack. See SOAP::Transport::HTTP.pm for details.
  126.   my $bytelength = SOAP::Utils::bytelength($envelope);
  127.   $envelope = pack('C0A*', $envelope) 
  128.     if !$SOAP::Constants::DO_NOT_USE_LWP_LENGTH_HACK && length($envelope) != $bytelength;
  129.  
  130.   my $result;
  131.   if ($sock) {
  132.     $sock->blocking(0);
  133.     $self->syswrite($sock, $envelope)  and 
  134.      $sock->shutdown(1)                and # stop writing
  135.      $result = $self->sysread($sock);
  136.   }
  137.  
  138.   SOAP::Trace::debug($result);
  139.  
  140.   my $code = $@ || $!;
  141.  
  142.   $self->code($code);
  143.   $self->message($code);
  144.   $self->is_success(!defined $code || $code eq '');
  145.   $self->status($code);
  146.  
  147.   return $result;
  148. }
  149.  
  150. # ======================================================================
  151.  
  152. package SOAP::Transport::TCP::Server;
  153.  
  154. use IO::SessionSet;
  155.  
  156. use Carp ();
  157. use vars qw($AUTOLOAD @ISA);
  158. @ISA = qw(SOAP::Server);
  159.  
  160. sub DESTROY { SOAP::Trace::objects('()') }
  161.  
  162. sub new { 
  163.   my $self = shift;
  164.  
  165.   unless (ref $self) {
  166.     my $class = ref($self) || $self;
  167.  
  168.     my(@params, @methods);
  169.     while (@_) { $class->can($_[0]) ? push(@methods, shift() => shift) : push(@params, shift) }
  170.     $self = $class->SUPER::new(@methods);
  171.  
  172.     # use SSL if there is any parameter with SSL_* in the name
  173.     $self->SSL(1) if !$self->SSL && grep /^SSL_/, @params;
  174.  
  175.     my $socket = $self->io_socket_class; 
  176.     eval "require $socket" or Carp::croak $@ unless UNIVERSAL::can($socket => 'new');
  177.     $self->{_socket} = $socket->new(Proto => 'tcp', @params) 
  178.       or Carp::croak "Can't open socket: $!";
  179.  
  180.     SOAP::Trace::objects('()');
  181.   }
  182.   return $self;
  183. }
  184.  
  185. sub SSL {
  186.   my $self = shift->new;
  187.   @_ ? ($self->{_SSL} = shift, return $self) : return $self->{_SSL};
  188. }
  189.  
  190. sub io_socket_class { shift->SSL ? 'IO::Socket::SSL' : 'IO::Socket::INET' }
  191.  
  192. sub AUTOLOAD {
  193.   my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2);
  194.   return if $method eq 'DESTROY';
  195.  
  196.   no strict 'refs';
  197.   *$AUTOLOAD = sub { shift->{_socket}->$method(@_) };
  198.   goto &$AUTOLOAD;
  199. }
  200.  
  201. sub handle {
  202.   my $self = shift->new;
  203.   my $sock = $self->{_socket};
  204.   my $session_set = IO::SessionSet->new($sock);
  205.   my %data;
  206.   while (1) {
  207.     my @ready = $session_set->wait($sock->timeout);
  208.     for my $session (@ready) {
  209.       my $data;
  210.       if (my $rc = $session->read($data, 4096)) {
  211.         $data{$session} .= $data if $rc > 0;
  212.       } else {
  213.         $session->write($self->SUPER::handle(delete $data{$session}));
  214.         $session->close;
  215.       }
  216.     }
  217.   }
  218. }
  219.  
  220. # ======================================================================
  221.  
  222. 1;
  223.  
  224. __END__
  225.  
  226. =head1 NAME
  227.  
  228. SOAP::Transport::TCP - Server/Client side TCP support for SOAP::Lite
  229.  
  230. =head1 SYNOPSIS
  231.  
  232.   use SOAP::Transport::TCP;
  233.  
  234.   my $daemon = SOAP::Transport::TCP::Server
  235.     -> new (LocalAddr => 'localhost', LocalPort => 82, Listen => 5, Reuse => 1)
  236.     -> objects_by_reference(qw(My::PersistentIterator My::SessionIterator My::Chat))
  237.     -> dispatch_to('/Your/Path/To/Deployed/Modules', 'Module::Name', 'Module::method') 
  238.   ;
  239.   print "Contact to SOAP server at ", join(':', $daemon->sockhost, $daemon->sockport), "\n";
  240.   $daemon->handle;
  241.  
  242. =head1 DESCRIPTION
  243.  
  244. =head1 COPYRIGHT
  245.  
  246. Copyright (C) 2000-2001 Paul Kulchenko. All rights reserved.
  247.  
  248. This library is free software; you can redistribute it and/or modify
  249. it under the same terms as Perl itself.
  250.  
  251. =head1 AUTHOR
  252.  
  253. Paul Kulchenko (paulclinger@yahoo.com)
  254.  
  255. =cut
  256.