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