home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 May / Chip_2000-05_cd1.bin / zkuste / Perl / ActivePerl-5.6.0.613.msi / 䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥 / _f599a5415acc71ae748c11cbb4f870e4 < prev    next >
Text File  |  2000-03-15  |  11KB  |  429 lines
  1. # IO::Socket.pm
  2. #
  3. # Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
  4. # This program is free software; you can redistribute it and/or
  5. # modify it under the same terms as Perl itself.
  6.  
  7. package IO::Socket;
  8.  
  9. require 5.005_64;
  10.  
  11. use IO::Handle;
  12. use Socket 1.3;
  13. use Carp;
  14. use strict;
  15. our(@ISA, $VERSION);
  16. use Exporter;
  17. use Errno;
  18.  
  19. # legacy
  20.  
  21. require IO::Socket::INET;
  22. require IO::Socket::UNIX if ($^O ne 'epoc');
  23.  
  24. @ISA = qw(IO::Handle);
  25.  
  26. $VERSION = "1.26";
  27.  
  28. sub import {
  29.     my $pkg = shift;
  30.     my $callpkg = caller;
  31.     Exporter::export 'Socket', $callpkg, @_;
  32. }
  33.  
  34. sub new {
  35.     my($class,%arg) = @_;
  36.     my $sock = $class->SUPER::new();
  37.  
  38.     $sock->autoflush(1);
  39.  
  40.     ${*$sock}{'io_socket_timeout'} = delete $arg{Timeout};
  41.  
  42.     return scalar(%arg) ? $sock->configure(\%arg)
  43.             : $sock;
  44. }
  45.  
  46. my @domain2pkg;
  47.  
  48. sub register_domain {
  49.     my($p,$d) = @_;
  50.     $domain2pkg[$d] = $p;
  51. }
  52.  
  53. sub configure {
  54.     my($sock,$arg) = @_;
  55.     my $domain = delete $arg->{Domain};
  56.  
  57.     croak 'IO::Socket: Cannot configure a generic socket'
  58.     unless defined $domain;
  59.  
  60.     croak "IO::Socket: Unsupported socket domain"
  61.     unless defined $domain2pkg[$domain];
  62.  
  63.     croak "IO::Socket: Cannot configure socket in domain '$domain'"
  64.     unless ref($sock) eq "IO::Socket";
  65.  
  66.     bless($sock, $domain2pkg[$domain]);
  67.     $sock->configure($arg);
  68. }
  69.  
  70. sub socket {
  71.     @_ == 4 or croak 'usage: $sock->socket(DOMAIN, TYPE, PROTOCOL)';
  72.     my($sock,$domain,$type,$protocol) = @_;
  73.  
  74.     socket($sock,$domain,$type,$protocol) or
  75.         return undef;
  76.  
  77.     ${*$sock}{'io_socket_domain'} = $domain;
  78.     ${*$sock}{'io_socket_type'}   = $type;
  79.     ${*$sock}{'io_socket_proto'}  = $protocol;
  80.  
  81.     $sock;
  82. }
  83.  
  84. sub socketpair {
  85.     @_ == 4 || croak 'usage: IO::Socket->socketpair(DOMAIN, TYPE, PROTOCOL)';
  86.     my($class,$domain,$type,$protocol) = @_;
  87.     my $sock1 = $class->new();
  88.     my $sock2 = $class->new();
  89.  
  90.     socketpair($sock1,$sock2,$domain,$type,$protocol) or
  91.         return ();
  92.  
  93.     ${*$sock1}{'io_socket_type'}  = ${*$sock2}{'io_socket_type'}  = $type;
  94.     ${*$sock1}{'io_socket_proto'} = ${*$sock2}{'io_socket_proto'} = $protocol;
  95.  
  96.     ($sock1,$sock2);
  97. }
  98.  
  99. sub connect {
  100.     @_ == 2 or croak 'usage: $sock->connect(NAME)';
  101.     my $sock = shift;
  102.     my $addr = shift;
  103.     my $timeout = ${*$sock}{'io_socket_timeout'};
  104.     my $err;
  105.     my $blocking;
  106.     $blocking = $sock->blocking(0) if $timeout;
  107.  
  108.     if (!connect($sock, $addr)) {
  109.     if ($timeout && $!{EINPROGRESS}) {
  110.         require IO::Select;
  111.  
  112.         my $sel = new IO::Select $sock;
  113.  
  114.         if (!$sel->can_write($timeout)) {
  115.         $err = $! || (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1);
  116.         $@ = "connect: timeout";
  117.         }
  118.         elsif(!connect($sock,$addr) && not $!{EISCONN}) {
  119.         # Some systems refuse to re-connect() to
  120.         # an already open socket and set errno to EISCONN.
  121.         $err = $!;
  122.         $@ = "connect: $!";
  123.         }
  124.     }
  125.     else {
  126.         $err = $!;
  127.         $@ = "connect: $!";
  128.     }
  129.     }
  130.  
  131.     $sock->blocking(1) if $blocking;
  132.  
  133.     $! = $err if $err;
  134.  
  135.     $err ? undef : $sock;
  136. }
  137.  
  138. sub bind {
  139.     @_ == 2 or croak 'usage: $sock->bind(NAME)';
  140.     my $sock = shift;
  141.     my $addr = shift;
  142.  
  143.     return bind($sock, $addr) ? $sock
  144.                   : undef;
  145. }
  146.  
  147. sub listen {
  148.     @_ >= 1 && @_ <= 2 or croak 'usage: $sock->listen([QUEUE])';
  149.     my($sock,$queue) = @_;
  150.     $queue = 5
  151.     unless $queue && $queue > 0;
  152.  
  153.     return listen($sock, $queue) ? $sock
  154.                  : undef;
  155. }
  156.  
  157. sub accept {
  158.     @_ == 1 || @_ == 2 or croak 'usage $sock->accept([PKG])';
  159.     my $sock = shift;
  160.     my $pkg = shift || $sock;
  161.     my $timeout = ${*$sock}{'io_socket_timeout'};
  162.     my $new = $pkg->new(Timeout => $timeout);
  163.     my $peer = undef;
  164.  
  165.     if($timeout) {
  166.     require IO::Select;
  167.  
  168.     my $sel = new IO::Select $sock;
  169.  
  170.     unless ($sel->can_read($timeout)) {
  171.         $@ = 'accept: timeout';
  172.         $! = (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1);
  173.         return;
  174.     }
  175.     }
  176.  
  177.     $peer = accept($new,$sock)
  178.     or return;
  179.  
  180.     return wantarray ? ($new, $peer)
  181.                        : $new;
  182. }
  183.  
  184. sub sockname {
  185.     @_ == 1 or croak 'usage: $sock->sockname()';
  186.     getsockname($_[0]);
  187. }
  188.  
  189. sub peername {
  190.     @_ == 1 or croak 'usage: $sock->peername()';
  191.     my($sock) = @_;
  192.     getpeername($sock)
  193.       || ${*$sock}{'io_socket_peername'}
  194.       || undef;
  195. }
  196.  
  197. sub connected {
  198.     @_ == 1 or croak 'usage: $sock->connected()';
  199.     my($sock) = @_;
  200.     getpeername($sock);
  201. }
  202.  
  203. sub send {
  204.     @_ >= 2 && @_ <= 4 or croak 'usage: $sock->send(BUF, [FLAGS, [TO]])';
  205.     my $sock  = $_[0];
  206.     my $flags = $_[2] || 0;
  207.     my $peer  = $_[3] || $sock->peername;
  208.  
  209.     croak 'send: Cannot determine peer address'
  210.      unless($peer);
  211.  
  212.     my $r = defined(getpeername($sock))
  213.     ? send($sock, $_[1], $flags)
  214.     : send($sock, $_[1], $flags, $peer);
  215.  
  216.     # remember who we send to, if it was sucessful
  217.     ${*$sock}{'io_socket_peername'} = $peer
  218.     if(@_ == 4 && defined $r);
  219.  
  220.     $r;
  221. }
  222.  
  223. sub recv {
  224.     @_ == 3 || @_ == 4 or croak 'usage: $sock->recv(BUF, LEN [, FLAGS])';
  225.     my $sock  = $_[0];
  226.     my $len   = $_[2];
  227.     my $flags = $_[3] || 0;
  228.  
  229.     # remember who we recv'd from
  230.     ${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags);
  231. }
  232.  
  233. sub shutdown {
  234.     @_ == 2 or croak 'usage: $sock->shutdown(HOW)';
  235.     my($sock, $how) = @_;
  236.     shutdown($sock, $how);
  237. }
  238.  
  239. sub setsockopt {
  240.     @_ == 4 or croak '$sock->setsockopt(LEVEL, OPTNAME)';
  241.     setsockopt($_[0],$_[1],$_[2],$_[3]);
  242. }
  243.  
  244. my $intsize = length(pack("i",0));
  245.  
  246. sub getsockopt {
  247.     @_ == 3 or croak '$sock->getsockopt(LEVEL, OPTNAME)';
  248.     my $r = getsockopt($_[0],$_[1],$_[2]);
  249.     # Just a guess
  250.     $r = unpack("i", $r)
  251.     if(defined $r && length($r) == $intsize);
  252.     $r;
  253. }
  254.  
  255. sub sockopt {
  256.     my $sock = shift;
  257.     @_ == 1 ? $sock->getsockopt(SOL_SOCKET,@_)
  258.         : $sock->setsockopt(SOL_SOCKET,@_);
  259. }
  260.  
  261. sub timeout {
  262.     @_ == 1 || @_ == 2 or croak 'usage: $sock->timeout([VALUE])';
  263.     my($sock,$val) = @_;
  264.     my $r = ${*$sock}{'io_socket_timeout'} || undef;
  265.  
  266.     ${*$sock}{'io_socket_timeout'} = 0 + $val
  267.     if(@_ == 2);
  268.  
  269.     $r;
  270. }
  271.  
  272. sub sockdomain {
  273.     @_ == 1 or croak 'usage: $sock->sockdomain()';
  274.     my $sock = shift;
  275.     ${*$sock}{'io_socket_domain'};
  276. }
  277.  
  278. sub socktype {
  279.     @_ == 1 or croak 'usage: $sock->socktype()';
  280.     my $sock = shift;
  281.     ${*$sock}{'io_socket_type'}
  282. }
  283.  
  284. sub protocol {
  285.     @_ == 1 or croak 'usage: $sock->protocol()';
  286.     my($sock) = @_;
  287.     ${*$sock}{'io_socket_proto'};
  288. }
  289.  
  290. 1;
  291.  
  292. __END__
  293.  
  294. =head1 NAME
  295.  
  296. IO::Socket - Object interface to socket communications
  297.  
  298. =head1 SYNOPSIS
  299.  
  300.     use IO::Socket;
  301.  
  302. =head1 DESCRIPTION
  303.  
  304. C<IO::Socket> provides an object interface to creating and using sockets. It
  305. is built upon the L<IO::Handle> interface and inherits all the methods defined
  306. by L<IO::Handle>.
  307.  
  308. C<IO::Socket> only defines methods for those operations which are common to all
  309. types of socket. Operations which are specified to a socket in a particular 
  310. domain have methods defined in sub classes of C<IO::Socket>
  311.  
  312. C<IO::Socket> will export all functions (and constants) defined by L<Socket>.
  313.  
  314. =head1 CONSTRUCTOR
  315.  
  316. =over 4
  317.  
  318. =item new ( [ARGS] )
  319.  
  320. Creates an C<IO::Socket>, which is a reference to a
  321. newly created symbol (see the C<Symbol> package). C<new>
  322. optionally takes arguments, these arguments are in key-value pairs.
  323. C<new> only looks for one key C<Domain> which tells new which domain
  324. the socket will be in. All other arguments will be passed to the
  325. configuration method of the package for that domain, See below.
  326.  
  327.  NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
  328.  
  329. As of VERSION 1.18 all IO::Socket objects have autoflush turned on
  330. by default. This was not the case with earlier releases.
  331.  
  332.  NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
  333.  
  334. =back
  335.  
  336. =head1 METHODS
  337.  
  338. See L<perlfunc> for complete descriptions of each of the following
  339. supported C<IO::Socket> methods, which are just front ends for the
  340. corresponding built-in functions:
  341.  
  342.     socket
  343.     socketpair
  344.     bind
  345.     listen
  346.     accept
  347.     send
  348.     recv
  349.     peername (getpeername)
  350.     sockname (getsockname)
  351.     shutdown
  352.  
  353. Some methods take slightly different arguments to those defined in L<perlfunc>
  354. in attempt to make the interface more flexible. These are
  355.  
  356. =over 4
  357.  
  358. =item accept([PKG])
  359.  
  360. perform the system call C<accept> on the socket and return a new object. The
  361. new object will be created in the same class as the listen socket, unless
  362. C<PKG> is specified. This object can be used to communicate with the client
  363. that was trying to connect. In a scalar context the new socket is returned,
  364. or undef upon failure. In an array context a two-element array is returned
  365. containing the new socket and the peer address; the list will
  366. be empty upon failure.
  367.  
  368. =item socketpair(DOMAIN, TYPE, PROTOCOL)
  369.  
  370. Call C<socketpair> and return a list of two sockets created, or an
  371. empty list on failure.
  372.  
  373. =back
  374.  
  375. Additional methods that are provided are:
  376.  
  377. =over 4
  378.  
  379. =item timeout([VAL])
  380.  
  381. Set or get the timeout value associated with this socket. If called without
  382. any arguments then the current setting is returned. If called with an argument
  383. the current setting is changed and the previous value returned.
  384.  
  385. =item sockopt(OPT [, VAL])
  386.  
  387. Unified method to both set and get options in the SOL_SOCKET level. If called
  388. with one argument then getsockopt is called, otherwise setsockopt is called.
  389.  
  390. =item sockdomain
  391.  
  392. Returns the numerical number for the socket domain type. For example, for
  393. a AF_INET socket the value of &AF_INET will be returned.
  394.  
  395. =item socktype
  396.  
  397. Returns the numerical number for the socket type. For example, for
  398. a SOCK_STREAM socket the value of &SOCK_STREAM will be returned.
  399.  
  400. =item protocol
  401.  
  402. Returns the numerical number for the protocol being used on the socket, if
  403. known. If the protocol is unknown, as with an AF_UNIX socket, zero
  404. is returned.
  405.  
  406. =item connected
  407.  
  408. If the socket is in a connected state the the peer address is returned.
  409. If the socket is not in a connected state then undef will be returned.
  410.  
  411. =back
  412.  
  413. =head1 SEE ALSO
  414.  
  415. L<Socket>, L<IO::Handle>, L<IO::Socket::INET>, L<IO::Socket::UNIX>
  416.  
  417. =head1 AUTHOR
  418.  
  419. Graham Barr. Currently maintained by the Perl Porters.  Please report all
  420. bugs to <perl5-porters@perl.org>.
  421.  
  422. =head1 COPYRIGHT
  423.  
  424. Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
  425. This program is free software; you can redistribute it and/or
  426. modify it under the same terms as Perl itself.
  427.  
  428. =cut
  429.