home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 May / Chip_2000-05_cd1.bin / zkuste / Perl / ActivePerl-5.6.0.613.msi / 䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥 / _3051e53bf6f3f5fd0c86f52523b4c21b < prev    next >
Text File  |  2000-03-15  |  11KB  |  407 lines
  1. # IO::Socket::INET.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::INET;
  8.  
  9. use strict;
  10. our(@ISA, $VERSION);
  11. use IO::Socket;
  12. use Socket;
  13. use Carp;
  14. use Exporter;
  15. use Errno;
  16.  
  17. @ISA = qw(IO::Socket);
  18. $VERSION = "1.25";
  19.  
  20. my $EINVAL = exists(&Errno::EINVAL) ? Errno::EINVAL() : 1;
  21.  
  22. IO::Socket::INET->register_domain( AF_INET );
  23.  
  24. my %socket_type = ( tcp  => SOCK_STREAM,
  25.             udp  => SOCK_DGRAM,
  26.             icmp => SOCK_RAW
  27.           );
  28.  
  29. sub new {
  30.     my $class = shift;
  31.     unshift(@_, "PeerAddr") if @_ == 1;
  32.     return $class->SUPER::new(@_);
  33. }
  34.  
  35. sub _sock_info {
  36.   my($addr,$port,$proto) = @_;
  37.   my @proto = ();
  38.   my @serv = ();
  39.  
  40.   $port = $1
  41.     if(defined $addr && $addr =~ s,:([\w\(\)/]+)$,,);
  42.  
  43.   if(defined $proto) {
  44.     if (@proto = ( $proto =~ m,\D,
  45.         ? getprotobyname($proto)
  46.         : getprotobynumber($proto))
  47.     ) {
  48.       $proto = $proto[2] || undef;
  49.     }
  50.     else {
  51.       $@ = "Bad protocol '$proto'";
  52.       return;
  53.     }
  54.   }
  55.  
  56.   if(defined $port) {
  57.     $port =~ s,\((\d+)\)$,,;
  58.  
  59.     my $defport = $1 || undef;
  60.     my $pnum = ($port =~ m,^(\d+)$,)[0];
  61.  
  62.     if ($port =~ m,\D,) {
  63.       unless (@serv = getservbyname($port, $proto[0] || "")) {
  64.     $@ = "Bad service '$port'";
  65.     return;
  66.       }
  67.     }
  68.  
  69.     $port = $pnum || $serv[2] || $defport || undef;
  70.  
  71.     $proto = (getprotobyname($serv[3]))[2] || undef
  72.     if @serv && !$proto;
  73.   }
  74.  
  75.  return ($addr || undef,
  76.      $port || undef,
  77.      $proto || undef
  78.     );
  79. }
  80.  
  81. sub _error {
  82.     my $sock = shift;
  83.     my $err = shift;
  84.     {
  85.       local($!);
  86.       $@ = join("",ref($sock),": ",@_);
  87.       close($sock)
  88.     if(defined fileno($sock));
  89.     }
  90.     $! = $err;
  91.     return undef;
  92. }
  93.  
  94. sub _get_addr {
  95.     my($sock,$addr_str, $multi) = @_;
  96.     my @addr;
  97.     if ($multi && $addr_str !~ /^\d+(?:\.\d+){3}$/) {
  98.     (undef, undef, undef, undef, @addr) = gethostbyname($addr_str);
  99.     } else {
  100.     my $h = inet_aton($addr_str);
  101.     push(@addr, $h) if defined $h;
  102.     }
  103.     @addr;
  104. }
  105.  
  106. sub configure {
  107.     my($sock,$arg) = @_;
  108.     my($lport,$rport,$laddr,$raddr,$proto,$type);
  109.  
  110.  
  111.     $arg->{LocalAddr} = $arg->{LocalHost}
  112.     if exists $arg->{LocalHost} && !exists $arg->{LocalAddr};
  113.  
  114.     ($laddr,$lport,$proto) = _sock_info($arg->{LocalAddr},
  115.                     $arg->{LocalPort},
  116.                     $arg->{Proto})
  117.             or return _error($sock, $!, $@);
  118.  
  119.     $laddr = defined $laddr ? inet_aton($laddr)
  120.                 : INADDR_ANY;
  121.  
  122.     return _error($sock, $EINVAL, "Bad hostname '",$arg->{LocalAddr},"'")
  123.     unless(defined $laddr);
  124.  
  125.     $arg->{PeerAddr} = $arg->{PeerHost}
  126.     if exists $arg->{PeerHost} && !exists $arg->{PeerAddr};
  127.  
  128.     unless(exists $arg->{Listen}) {
  129.     ($raddr,$rport,$proto) = _sock_info($arg->{PeerAddr},
  130.                         $arg->{PeerPort},
  131.                         $proto)
  132.             or return _error($sock, $!, $@);
  133.     }
  134.  
  135.     $proto ||= (getprotobyname('tcp'))[2];
  136.  
  137.     my $pname = (getprotobynumber($proto))[0];
  138.     $type = $arg->{Type} || $socket_type{$pname};
  139.  
  140.     my @raddr = ();
  141.  
  142.     if(defined $raddr) {
  143.     @raddr = $sock->_get_addr($raddr, $arg->{MultiHomed});
  144.     return _error($sock, $EINVAL, "Bad hostname '",$arg->{PeerAddr},"'")
  145.         unless @raddr;
  146.     }
  147.  
  148.     while(1) {
  149.  
  150.     $sock->socket(AF_INET, $type, $proto) or
  151.         return _error($sock, $!, "$!");
  152.  
  153.     if ($arg->{Reuse}) {
  154.         $sock->sockopt(SO_REUSEADDR,1) or
  155.             return _error($sock, $!, "$!");
  156.     }
  157.  
  158.     if($lport || ($laddr ne INADDR_ANY) || exists $arg->{Listen}) {
  159.         $sock->bind($lport || 0, $laddr) or
  160.             return _error($sock, $!, "$!");
  161.     }
  162.  
  163.     if(exists $arg->{Listen}) {
  164.         $sock->listen($arg->{Listen} || 5) or
  165.         return _error($sock, $!, "$!");
  166.         last;
  167.     }
  168.  
  169.      # don't try to connect unless we're given a PeerAddr
  170.      last unless exists($arg->{PeerAddr});
  171.  
  172.         $raddr = shift @raddr;
  173.  
  174.     return _error($sock, $EINVAL, 'Cannot determine remote port')
  175.         unless($rport || $type == SOCK_DGRAM || $type == SOCK_RAW);
  176.  
  177.     last
  178.         unless($type == SOCK_STREAM || defined $raddr);
  179.  
  180.     return _error($sock, $EINVAL, "Bad hostname '",$arg->{PeerAddr},"'")
  181.         unless defined $raddr;
  182.  
  183. #        my $timeout = ${*$sock}{'io_socket_timeout'};
  184. #        my $before = time() if $timeout;
  185.  
  186.         if ($sock->connect(pack_sockaddr_in($rport, $raddr))) {
  187. #            ${*$sock}{'io_socket_timeout'} = $timeout;
  188.             return $sock;
  189.         }
  190.  
  191.     return _error($sock, $!, "Timeout")
  192.         unless @raddr;
  193.  
  194. #    if ($timeout) {
  195. #        my $new_timeout = $timeout - (time() - $before);
  196. #        return _error($sock,
  197. #                         (exists(&Errno::ETIMEDOUT) ? Errno::ETIMEDOUT() : $EINVAL),
  198. #                         "Timeout") if $new_timeout <= 0;
  199. #        ${*$sock}{'io_socket_timeout'} = $new_timeout;
  200. #        }
  201.  
  202.     }
  203.  
  204.     $sock;
  205. }
  206.  
  207. sub connect {
  208.     @_ == 2 || @_ == 3 or
  209.        croak 'usage: $sock->connect(NAME) or $sock->connect(PORT, ADDR)';
  210.     my $sock = shift;
  211.     return $sock->SUPER::connect(@_ == 1 ? shift : pack_sockaddr_in(@_));
  212. }
  213.  
  214. sub bind {
  215.     @_ == 2 || @_ == 3 or
  216.        croak 'usage: $sock->bind(NAME) or $sock->bind(PORT, ADDR)';
  217.     my $sock = shift;
  218.     return $sock->SUPER::bind(@_ == 1 ? shift : pack_sockaddr_in(@_))
  219. }
  220.  
  221. sub sockaddr {
  222.     @_ == 1 or croak 'usage: $sock->sockaddr()';
  223.     my($sock) = @_;
  224.     my $name = $sock->sockname;
  225.     $name ? (sockaddr_in($name))[1] : undef;
  226. }
  227.  
  228. sub sockport {
  229.     @_ == 1 or croak 'usage: $sock->sockport()';
  230.     my($sock) = @_;
  231.     my $name = $sock->sockname;
  232.     $name ? (sockaddr_in($name))[0] : undef;
  233. }
  234.  
  235. sub sockhost {
  236.     @_ == 1 or croak 'usage: $sock->sockhost()';
  237.     my($sock) = @_;
  238.     my $addr = $sock->sockaddr;
  239.     $addr ? inet_ntoa($addr) : undef;
  240. }
  241.  
  242. sub peeraddr {
  243.     @_ == 1 or croak 'usage: $sock->peeraddr()';
  244.     my($sock) = @_;
  245.     my $name = $sock->peername;
  246.     $name ? (sockaddr_in($name))[1] : undef;
  247. }
  248.  
  249. sub peerport {
  250.     @_ == 1 or croak 'usage: $sock->peerport()';
  251.     my($sock) = @_;
  252.     my $name = $sock->peername;
  253.     $name ? (sockaddr_in($name))[0] : undef;
  254. }
  255.  
  256. sub peerhost {
  257.     @_ == 1 or croak 'usage: $sock->peerhost()';
  258.     my($sock) = @_;
  259.     my $addr = $sock->peeraddr;
  260.     $addr ? inet_ntoa($addr) : undef;
  261. }
  262.  
  263. 1;
  264.  
  265. __END__
  266.  
  267. =head1 NAME
  268.  
  269. IO::Socket::INET - Object interface for AF_INET domain sockets
  270.  
  271. =head1 SYNOPSIS
  272.  
  273.     use IO::Socket::INET;
  274.  
  275. =head1 DESCRIPTION
  276.  
  277. C<IO::Socket::INET> provides an object interface to creating and using sockets
  278. in the AF_INET domain. It is built upon the L<IO::Socket> interface and
  279. inherits all the methods defined by L<IO::Socket>.
  280.  
  281. =head1 CONSTRUCTOR
  282.  
  283. =over 4
  284.  
  285. =item new ( [ARGS] )
  286.  
  287. Creates an C<IO::Socket::INET> object, which is a reference to a
  288. newly created symbol (see the C<Symbol> package). C<new>
  289. optionally takes arguments, these arguments are in key-value pairs.
  290.  
  291. In addition to the key-value pairs accepted by L<IO::Socket>,
  292. C<IO::Socket::INET> provides.
  293.  
  294.  
  295.     PeerAddr    Remote host address          <hostname>[:<port>]
  296.     PeerHost    Synonym for PeerAddr
  297.     PeerPort    Remote port or service       <service>[(<no>)] | <no>
  298.     LocalAddr    Local host bind    address      hostname[:port]
  299.     LocalHost    Synonym for LocalAddr
  300.     LocalPort    Local host bind    port         <service>[(<no>)] | <no>
  301.     Proto    Protocol name (or number)    "tcp" | "udp" | ...
  302.     Type    Socket type                  SOCK_STREAM | SOCK_DGRAM | ...
  303.     Listen    Queue size for listen
  304.     Reuse    Set SO_REUSEADDR before binding
  305.     Timeout    Timeout    value for various operations
  306.     MultiHomed  Try all adresses for multi-homed hosts
  307.  
  308.  
  309. If C<Listen> is defined then a listen socket is created, else if the
  310. socket type, which is derived from the protocol, is SOCK_STREAM then
  311. connect() is called.
  312.  
  313. Although it is not illegal, the use of C<MultiHomed> on a socket
  314. which is in non-blocking mode is of little use. This is because the
  315. first connect will never fail with a timeout as the connaect call
  316. will not block.
  317.  
  318. The C<PeerAddr> can be a hostname or the IP-address on the
  319. "xx.xx.xx.xx" form.  The C<PeerPort> can be a number or a symbolic
  320. service name.  The service name might be followed by a number in
  321. parenthesis which is used if the service is not known by the system.
  322. The C<PeerPort> specification can also be embedded in the C<PeerAddr>
  323. by preceding it with a ":".
  324.  
  325. If C<Proto> is not given and you specify a symbolic C<PeerPort> port,
  326. then the constructor will try to derive C<Proto> from the service
  327. name.  As a last resort C<Proto> "tcp" is assumed.  The C<Type>
  328. parameter will be deduced from C<Proto> if not specified.
  329.  
  330. If the constructor is only passed a single argument, it is assumed to
  331. be a C<PeerAddr> specification.
  332.  
  333. Examples:
  334.  
  335.    $sock = IO::Socket::INET->new(PeerAddr => 'www.perl.org',
  336.                                  PeerPort => 'http(80)',
  337.                                  Proto    => 'tcp');
  338.  
  339.    $sock = IO::Socket::INET->new(PeerAddr => 'localhost:smtp(25)');
  340.  
  341.    $sock = IO::Socket::INET->new(Listen    => 5,
  342.                                  LocalAddr => 'localhost',
  343.                                  LocalPort => 9000,
  344.                                  Proto     => 'tcp');
  345.  
  346.    $sock = IO::Socket::INET->new('127.0.0.1:25');
  347.  
  348.  
  349.  NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
  350.  
  351. As of VERSION 1.18 all IO::Socket objects have autoflush turned on
  352. by default. This was not the case with earlier releases.
  353.  
  354.  NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
  355.  
  356. =back
  357.  
  358. =head2 METHODS
  359.  
  360. =over 4
  361.  
  362. =item sockaddr ()
  363.  
  364. Return the address part of the sockaddr structure for the socket
  365.  
  366. =item sockport ()
  367.  
  368. Return the port number that the socket is using on the local host
  369.  
  370. =item sockhost ()
  371.  
  372. Return the address part of the sockaddr structure for the socket in a
  373. text form xx.xx.xx.xx
  374.  
  375. =item peeraddr ()
  376.  
  377. Return the address part of the sockaddr structure for the socket on
  378. the peer host
  379.  
  380. =item peerport ()
  381.  
  382. Return the port number for the socket on the peer host.
  383.  
  384. =item peerhost ()
  385.  
  386. Return the address part of the sockaddr structure for the socket on the
  387. peer host in a text form xx.xx.xx.xx
  388.  
  389. =back
  390.  
  391. =head1 SEE ALSO
  392.  
  393. L<Socket>, L<IO::Socket>
  394.  
  395. =head1 AUTHOR
  396.  
  397. Graham Barr. Currently maintained by the Perl Porters.  Please report all
  398. bugs to <perl5-porters@perl.org>.
  399.  
  400. =head1 COPYRIGHT
  401.  
  402. Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
  403. This program is free software; you can redistribute it and/or
  404. modify it under the same terms as Perl itself.
  405.  
  406. =cut
  407.