ext/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.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