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