home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl_ste.zip / LWP / Socket.pm < prev    next >
Text File  |  1997-01-27  |  9KB  |  402 lines
  1. # $Id: Socket.pm,v 1.22 1997/01/27 14:18:43 aas Exp $
  2.  
  3. package LWP::Socket;
  4.  
  5. =head1 NAME
  6.  
  7. LWP::Socket - TCP/IP socket interface
  8.  
  9. =head1 SYNOPSIS
  10.  
  11.  $socket = new LWP::Socket;
  12.  $socket->connect('localhost', 7); # echo
  13.  $quote = 'I dunno, I dream in Perl sometimes...';
  14.  $socket->write("$quote\n");
  15.  $socket->read_until("\n", \$buffer);
  16.  $socket->read(\$buffer);
  17.  $socket = undef;  # close
  18.  
  19. =head1 DESCRIPTION
  20.  
  21. This class implements TCP/IP sockets.  It groups socket generation,
  22. TCP address manipulation and buffered reading. Errors are handled by
  23. dying (throws exceptions).
  24.  
  25. This class should really not be required, something like this should
  26. be part of the standard Perl5 library.
  27.  
  28. Running this module standalone executes a self test which requires
  29. localhost to serve chargen and echo protocols.
  30.  
  31. =head1 METHODS
  32.  
  33. =cut
  34.  
  35.  
  36. $VERSION = sprintf("%d.%02d", q$Revision: 1.22 $ =~ /(\d+)\.(\d+)/);
  37. sub Version { $VERSION; }
  38.  
  39. use Socket qw(pack_sockaddr_in unpack_sockaddr_in
  40.           PF_INET SOCK_STREAM INADDR_ANY
  41.           inet_ntoa inet_aton);
  42. Socket->require_version(1.5);
  43.  
  44. use Carp ();
  45. use Symbol qw(gensym);
  46.  
  47. use LWP::Debug ();
  48. use LWP::IO ();
  49.  
  50. my $tcp_proto = (getprotobyname('tcp'))[2];
  51.  
  52.  
  53. =head2 $sock = new LWP::Socket()
  54.  
  55. Constructs a new socket object.
  56.  
  57. =cut
  58.  
  59. sub new
  60. {
  61.     my($class, $socket, $host, $port) = @_;
  62.  
  63.     unless ($socket) {
  64.     $socket = gensym();
  65.     LWP::Debug::debug("Socket $socket");
  66.  
  67.     socket($socket, PF_INET, SOCK_STREAM, $tcp_proto) or
  68.       Carp::croak("socket: $!");
  69.     }
  70.  
  71.     my $self = bless {
  72.     'socket' => $socket,
  73.     'host'   => $host,
  74.     'port'   => $port,
  75.     'buffer' => '',
  76.     'size'   => 4096,
  77.     }, $class;
  78.  
  79.     $self;
  80. }
  81.  
  82. sub DESTROY
  83. {
  84.     my $socket = shift->{'socket'};
  85.     close($socket);
  86. }
  87.  
  88. sub host { shift->{'host'}; }
  89. sub port { shift->{'port'}; }
  90.  
  91.  
  92. =head2 $sock->connect($host, $port)
  93.  
  94. Connect the socket to given host and port.
  95.  
  96. =cut
  97.  
  98. sub connect
  99. {
  100.     my($self, $host, $port) = @_;
  101.     Carp::croak("no host") unless defined $host && length $host;
  102.     Carp::croak("no port") unless defined $port && $port > 0;
  103.  
  104.     LWP::Debug::trace("($host, $port)");
  105.  
  106.     $self->{'host'} = $host;
  107.     $self->{'port'} = $port;
  108.  
  109.     my @addr = $self->_getaddress($host, $port);
  110.     Carp::croak("Can't resolv address for $host")
  111.       unless @addr;
  112.  
  113.     LWP::Debug::debug("Connecting to host '$host' on port '$port'...");
  114.     for (@addr) {
  115.     connect($self->{'socket'}, $_) and return;
  116.     }
  117.     Carp::croak("Could not connect to $host:$port");
  118. }
  119.  
  120.  
  121. =head2 $sock->shutdown()
  122.  
  123. Shuts down the connection.
  124.  
  125. =cut
  126.  
  127. sub shutdown
  128. {
  129.     my($self, $how) = @_;
  130.     $how = 2 unless defined $how;
  131.     shutdown($self->{'socket'}, $how);
  132.     delete $self->{'host'};
  133.     delete $self->{'port'};
  134. }
  135.  
  136.  
  137. =head2 $sock->bind($host, $port)
  138.  
  139. Binds a name to the socket.
  140.  
  141. =cut
  142.  
  143. sub bind
  144. {
  145.     my($self, $host, $port) = @_;
  146.     my $name = $self->_getaddress($host, $port);
  147.     bind($self->{'socket'}, $name);
  148. }
  149.  
  150.  
  151. =head2 $sock->listen($queuesize)
  152.  
  153. Set up listen queue for socket.
  154.  
  155. =cut
  156.  
  157. sub listen
  158. {
  159.     listen(shift->{'socket'}, @_);
  160. }
  161.  
  162.  
  163. =head2 $sock->accept($timeout)
  164.  
  165. Accepts a new connection.  Returns a new LWP::Socket object if successful.
  166. Timeout not implemented yet.
  167.  
  168. =cut
  169.  
  170. sub accept
  171. {
  172.     my $self = shift;
  173.     my $timeout = shift;
  174.     my $ns = gensym();
  175.     my $addr = accept($ns, $self->{'socket'});
  176.     if ($addr) {
  177.     my($port, $addr) = unpack_sockaddr_in($addr);
  178.     return new LWP::Socket $ns, inet_ntoa($addr), $port;
  179.     } else {
  180.     Carp::croak("Can't accept: $!");
  181.     }
  182. }
  183.  
  184.  
  185. =head2 $sock->getsockname()
  186.  
  187. Returns a 2 element array ($host, $port)
  188.  
  189. =cut
  190.  
  191. sub getsockname
  192. {
  193.     my($port, $addr) = unpack_sockaddr_in(getsockname(shift->{'socket'}));
  194.     (inet_ntoa($addr), $port);
  195. }
  196.  
  197.  
  198. =head2 $sock->read_until($delim, $data_ref, $size, $timeout)
  199.  
  200. Reads data from the socket, up to a delimiter specified by a regular
  201. expression.  If $delim is undefined all data is read.  If $size is
  202. defined, data will be read internally in chunks of $size bytes.  This
  203. does not mean that we will return the data when size bytes are read.
  204.  
  205. Note that $delim is discarded from the data returned.
  206.  
  207. =cut
  208.  
  209. sub read_until
  210. {
  211.     my ($self, $delim, $data_ref, $size, $timeout) = @_;
  212.  
  213.     {
  214.     my $d = $delim;
  215.     $d =~ s/\r/\\r/g;
  216.     $d =~ s/\n/\\n/g;
  217.     LWP::Debug::trace("('$d',...)");
  218.     }
  219.  
  220.     my $socket = $self->{'socket'};
  221.     $delim = '' unless defined $delim;
  222.     $size ||= $self->{'size'};
  223.  
  224.     my $buf = \$self->{'buffer'};
  225.  
  226.     if (length $delim) {
  227.     while ($$buf !~ /$delim/) {
  228.         LWP::IO::read($socket, $$buf, $size, length($$buf), $timeout)
  229.         or die "Unexpected EOF";
  230.     }
  231.     ($$data_ref, $self->{'buffer'}) = split(/$delim/, $$buf, 2);
  232.     } else {
  233.     $data_ref = $buf;
  234.     $self->{'buffer'} = '';
  235.     }
  236.  
  237.     1;
  238. }
  239.  
  240.  
  241. =head2 $sock->read($bufref, [$size, $timeout])
  242.  
  243. Reads data of the socket.  Not more than $size bytes.  Might return
  244. less if the data is available.  Dies on timeout.
  245.  
  246. =cut
  247.  
  248. sub read
  249. {
  250.     my($self, $data_ref, $size, $timeout) = @_;
  251.     $size ||= $self->{'size'};
  252.  
  253.     LWP::Debug::trace('(...)');
  254.     if (length $self->{'buffer'}) {
  255.     # return data from buffer until it is empty
  256.     #print "Returning data from buffer...$self->{'buffer'}\n";
  257.     $$data_ref = substr($self->{'buffer'}, 0, $size);
  258.     substr($self->{'buffer'}, 0, $size) = '';
  259.     return length $$data_ref;
  260.     }
  261.     LWP::IO::read($self->{'socket'}, $$data_ref, $size, undef, $timeout);
  262. }
  263.  
  264.  
  265. =head2 $sock->pushback($data)
  266.  
  267. Put data back into the socket.  Data will returned next time you
  268. read().  Can be used if you find out that you have read too much.
  269.  
  270. =cut
  271.  
  272. sub pushback
  273. {
  274.     LWP::Debug::trace('(' . length($_[1]) . ' bytes)');
  275.     my $self = shift;
  276.     substr($self->{'buffer'}, 0, 0) = shift;
  277. }
  278.  
  279.  
  280. =head2 $sock->write($data, [$timeout])
  281.  
  282. Write data to socket.  The $data argument might be a scalar or code.
  283.  
  284. If data is a reference to a subroutine, then we will call this routine
  285. to obtain the data to be written.  The routine will be called until it
  286. returns undef or empty data.  Data might be returned from the callback
  287. as a scalar or as a reference to a scalar.
  288.  
  289. Write returns the number of bytes written to the socket.
  290.  
  291. =cut
  292.  
  293. sub write
  294. {
  295.     my $self = shift;
  296.     my $timeout = $_[1];  # we don't want to copy data in $_[0]
  297.     LWP::Debug::trace('()');
  298.     my $bytes_written = 0;
  299.     if (!ref $_[0]) {
  300.     $bytes_written = LWP::IO::write($self->{'socket'}, $_[0], $timeout);
  301.     } elsif (ref($_[0]) eq 'CODE') {
  302.     # write data until $callback returns empty data '';
  303.     my $callback = shift;
  304.     while (1) {
  305.         my $data = &$callback;
  306.         last unless defined $data;
  307.         my $dataRef = ref($data) ? $data : \$data;
  308.         my $len = length $$dataRef;
  309.         last unless $len;
  310.         my $n = $self->write($$dataRef, $timeout);
  311.         $bytes_written += $n;
  312.         last if $n != $len;
  313.     }
  314.     } else {
  315.     Carp::croak('Illegal LWP::Socket->write() argument');
  316.     }
  317.     $bytes_written;
  318. }
  319.  
  320.  
  321.  
  322. =head2 _getaddress($h, $p)
  323.  
  324. Given a host and a port, it will return the address (sockaddr_in)
  325. suitable as the C<name> argument for connect() or bind(). Might return
  326. several addresses in array context if the hostname is bound to several
  327. IP addresses.
  328.  
  329. =cut
  330.  
  331.  
  332. sub _getaddress
  333. {
  334.     my($self, $host, $port) = @_;
  335.  
  336.     my(@addr);
  337.     if (!defined $host) {
  338.     # INADDR_ANY
  339.     $addr[0] = pack_sockaddr_in($port, INADDR_ANY);
  340.     }
  341.     elsif ($host =~ /^(\d+\.\d+\.\d+\.\d+)$/) {
  342.     # numeric IP address
  343.     $addr[0] = pack_sockaddr_in($port, inet_aton($1));
  344.     } else {
  345.     # hostname
  346.     LWP::Debug::debug("resolving host '$host'...");
  347.     (undef,undef,undef,undef,@addr) = gethostbyname($host);
  348.     for (@addr) {
  349.         LWP::Debug::debug("   ..." . inet_ntoa($_));
  350.         $_ = pack_sockaddr_in($port, $_);
  351.     }
  352.     }
  353.     wantarray ? @addr : $addr[0];
  354. }
  355.  
  356.  
  357. #####################################################################
  358.  
  359. package main;
  360.  
  361. eval join('',<DATA>) || die $@ unless caller();
  362.  
  363. =head1 SELF TEST
  364.  
  365. This self test is only executed when this file is run standalone. It
  366. tests its functions against some standard TCP services implemented by
  367. inetd. If you do not have them around the tests will fail.
  368.  
  369. =cut
  370.  
  371. 1;
  372.  
  373. __END__
  374.  
  375. LWP::Debug::level('+');
  376.  
  377. &chargen;
  378. &echo;
  379. print "Socket.pm $LWP::Socket::VERSION ok\n";
  380.  
  381. sub chargen
  382. {
  383.     my $socket = new LWP::Socket;
  384.     $socket->connect('localhost', 19); # chargen
  385.     $socket->read_until('A', \$buffer, 8);
  386.  
  387.     die 'Read Error' unless $buffer eq ' !"#$%&\'()*+,-./0123456789:;<=>?@';
  388.     $socket->read_until('Z', \$buffer, 8);
  389.     die 'Read Error' unless $buffer eq 'BCDEFGHIJKLMNOPQRSTUVWXY';
  390. }
  391.  
  392. sub echo
  393. {
  394.     $socket = new LWP::Socket;
  395.     $socket->connect('localhost', 7); # echo
  396.     $quote = 'I dunno, I dream in Perl sometimes...';
  397.          # --Larry Wall in  <8538@jpl-devvax.JPL.NASA.GOV>
  398.     $socket->write("$quote\n");
  399.     $socket->read_until("\n", \$buffer);
  400.     die 'Read Error' unless $buffer eq $quote;
  401. }
  402.