dist/IO/lib/IO/Socket/INET.pm

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