ext/IO/lib/IO/Socket.pm

   1 # IO::Socket.pm
   2 #
   3 # Copyright (c) 1996 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights
   4 # reserved. 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 =head1 NAME
  10
  11 IO::Socket - Object interface to socket communications
  12
  13 =head1 SYNOPSIS
  14
  15     use IO::Socket;
  16
  17 =head1 DESCRIPTION
  18
  19 C<IO::Socket> provides an object interface to creating and using sockets. It
  20 is built upon the L<IO::Handle> interface and inherits all the methods defined
  21 by L<IO::Handle>.
  22
  23 C<IO::Socket> only defines methods for those operations which are common to all
  24 types of socket. Operations which are specified to a socket in a particular
  25 domain have methods defined in sub classes of C<IO::Socket>
  26
  27 C<IO::Socket> will export all functions (and constants) defined by L<Socket>.
  28
  29 =head1 CONSTRUCTOR
  30
  31 =over 4
  32
  33 =item new ( [ARGS] )
  34
  35 Creates an C<IO::Socket>, which is a reference to a
  36 newly created symbol (see the C<Symbol> package). C<new>
  37 optionally takes arguments, these arguments are in key-value pairs.
  38 C<new> only looks for one key C<Domain> which tells new which domain
  39 the socket will be in. All other arguments will be passed to the
  40 configuration method of the package for that domain, See below.
  41
  42 =back
  43
  44 =head1 METHODS
  45
  46 See L<perlfunc> for complete descriptions of each of the following
  47 supported C<IO::Socket> methods, which are just front ends for the
  48 corresponding built-in functions:
  49
  50     socket
  51     socketpair
  52     bind
  53     listen
  54     accept
  55     send
  56     recv
  57     peername (getpeername)
  58     sockname (getsockname)
  59
  60 Some methods take slightly different arguments to those defined in L<perlfunc>
  61 in attempt to make the interface more flexible. These are
  62
  63 =over 4
  64
  65 =item accept([PKG])
  66
  67 perform the system call C<accept> on the socket and return a new object. The
  68 new object will be created in the same class as the listen socket, unless
  69 C<PKG> is specified. This object can be used to communicate with the client
  70 that was trying to connect. In a scalar context the new socket is returned,
  71 or undef upon failure. In an array context a two-element array is returned
  72 containing the new socket and the peer address, the list will
  73 be empty upon failure.
  74
  75 Additional methods that are provided are
  76
  77 =item timeout([VAL])
  78
  79 Set or get the timeout value associated with this socket. If called without
  80 any arguments then the current setting is returned. If called with an argument
  81 the current setting is changed and the previous value returned.
  82
  83 =item sockopt(OPT [, VAL])
  84
  85 Unified method to both set and get options in the SOL_SOCKET level. If called
  86 with one argument then getsockopt is called, otherwise setsockopt is called.
  87
  88 =item sockdomain
  89
  90 Returns the numerical number for the socket domain type. For example, for
  91 a AF_INET socket the value of &AF_INET will be returned.
  92
  93 =item socktype
  94
  95 Returns the numerical number for the socket type. For example, for
  96 a SOCK_STREAM socket the value of &SOCK_STREAM will be returned.
  97
  98 =item protocol
  99
 100 Returns the numerical number for the protocol being used on the socket, if
 101 known. If the protocol is unknown, as with an AF_UNIX socket, zero
 102 is returned.
 103
 104 =back
 105
 106 =cut
 107
 108
 109 require 5.000;
 110
 111 use Config;
 112 use IO::Handle;
 113 use Socket 1.3;
 114 use Carp;
 115 use strict;
 116 use vars qw(@ISA $VERSION);
 117 use Exporter;
 118
 119 @ISA = qw(IO::Handle);
 120
 121 $VERSION = "1.1602";
 122
 123 sub import {
 124     my $pkg = shift;
 125     my $callpkg = caller;
 126     Exporter::export 'Socket', $callpkg, @_;
 127 }
 128
 129 sub new {
 130     my($class,%arg) = @_;
 131     my $fh = $class->SUPER::new();
 132
 133     ${*$fh}{'io_socket_timeout'} = delete $arg{Timeout};
 134
 135     return scalar(%arg) ? $fh->configure(\%arg)
 136                         : $fh;
 137 }
 138
 139 my @domain2pkg = ();
 140
 141 sub register_domain {
 142     my($p,$d) = @_;
 143     $domain2pkg[$d] = $p;
 144 }
 145
 146 sub configure {
 147     my($fh,$arg) = @_;
 148     my $domain = delete $arg->{Domain};
 149
 150     croak 'IO::Socket: Cannot configure a generic socket'
 151         unless defined $domain;
 152
 153     croak "IO::Socket: Unsupported socket domain"
 154         unless defined $domain2pkg[$domain];
 155
 156     croak "IO::Socket: Cannot configure socket in domain '$domain'"
 157         unless ref($fh) eq "IO::Socket";
 158
 159     bless($fh, $domain2pkg[$domain]);
 160     $fh->configure($arg);
 161 }
 162
 163 sub socket {
 164     @_ == 4 or croak 'usage: $fh->socket(DOMAIN, TYPE, PROTOCOL)';
 165     my($fh,$domain,$type,$protocol) = @_;
 166
 167     socket($fh,$domain,$type,$protocol) or
 168         return undef;
 169
 170     ${*$fh}{'io_socket_domain'} = $domain;
 171     ${*$fh}{'io_socket_type'}   = $type;
 172     ${*$fh}{'io_socket_proto'}  = $protocol;
 173
 174     $fh;
 175 }
 176
 177 sub socketpair {
 178     @_ == 4 || croak 'usage: IO::Socket->pair(DOMAIN, TYPE, PROTOCOL)';
 179     my($class,$domain,$type,$protocol) = @_;
 180     my $fh1 = $class->new();
 181     my $fh2 = $class->new();
 182
 183     socketpair($fh1,$fh1,$domain,$type,$protocol) or
 184         return ();
 185
 186     ${*$fh1}{'io_socket_type'}  = ${*$fh2}{'io_socket_type'}  = $type;
 187     ${*$fh1}{'io_socket_proto'} = ${*$fh2}{'io_socket_proto'} = $protocol;
 188
 189     ($fh1,$fh2);
 190 }
 191
 192 sub connect {
 193     @_ == 2 || @_ == 3 or croak 'usage: $fh->connect(NAME) or $fh->connect(PORT, ADDR)';
 194     my $fh = shift;
 195     my $addr = @_ == 1 ? shift : sockaddr_in(@_);
 196     my $timeout = ${*$fh}{'io_socket_timeout'};
 197     local($SIG{ALRM}) = $timeout ? sub { undef $fh; }
 198                                  : $SIG{ALRM} || 'DEFAULT';
 199
 200      eval {
 201         croak 'connect: Bad address'
 202             if(@_ == 2 && !defined $_[1]);
 203
 204         if($timeout) {
 205             defined $Config{d_alarm} && defined alarm($timeout) or
 206                 $timeout = 0;
 207         }
 208
 209         my $ok = connect($fh, $addr);
 210
 211         alarm(0)
 212             if($timeout);
 213
 214         croak "connect: timeout"
 215             unless defined $fh;
 216
 217         undef $fh unless $ok;
 218     };
 219
 220     $fh;
 221 }
 222
 223 sub bind {
 224     @_ == 2 || @_ == 3 or croak 'usage: $fh->bind(NAME) or $fh->bind(PORT, ADDR)';
 225     my $fh = shift;
 226     my $addr = @_ == 1 ? shift : sockaddr_in(@_);
 227
 228     return bind($fh, $addr) ? $fh
 229                             : undef;
 230 }
 231
 232 sub listen {
 233     @_ >= 1 && @_ <= 2 or croak 'usage: $fh->listen([QUEUE])';
 234     my($fh,$queue) = @_;
 235     $queue = 5
 236         unless $queue && $queue > 0;
 237
 238     return listen($fh, $queue) ? $fh
 239                                : undef;
 240 }
 241
 242 sub accept {
 243     @_ == 1 || @_ == 2 or croak 'usage $fh->accept([PKG])';
 244     my $fh = shift;
 245     my $pkg = shift || $fh;
 246     my $timeout = ${*$fh}{'io_socket_timeout'};
 247     my $new = $pkg->new(Timeout => $timeout);
 248     my $peer = undef;
 249
 250     eval {
 251         if($timeout) {
 252             my $fdset = "";
 253             vec($fdset, $fh->fileno,1) = 1;
 254             croak "accept: timeout"
 255                 unless select($fdset,undef,undef,$timeout);
 256         }
 257         $peer = accept($new,$fh);
 258     };
 259
 260     return wantarray ? defined $peer ? ($new, $peer)
 261                                      : ()
 262                      : defined $peer ? $new
 263                                      : undef;
 264 }
 265
 266 sub sockname {
 267     @_ == 1 or croak 'usage: $fh->sockname()';
 268     getsockname($_[0]);
 269 }
 270
 271 sub peername {
 272     @_ == 1 or croak 'usage: $fh->peername()';
 273     my($fh) = @_;
 274     getpeername($fh)
 275       || ${*$fh}{'io_socket_peername'}
 276       || undef;
 277 }
 278
 279 sub send {
 280     @_ >= 2 && @_ <= 4 or croak 'usage: $fh->send(BUF, [FLAGS, [TO]])';
 281     my $fh    = $_[0];
 282     my $flags = $_[2] || 0;
 283     my $peer  = $_[3] || $fh->peername;
 284
 285     croak 'send: Cannot determine peer address'
 286          unless($peer);
 287
 288     my $r = defined(getpeername($fh))
 289         ? send($fh, $_[1], $flags)
 290         : send($fh, $_[1], $flags, $peer);
 291
 292     # remember who we send to, if it was sucessful
 293     ${*$fh}{'io_socket_peername'} = $peer
 294         if(@_ == 4 && defined $r);
 295
 296     $r;
 297 }
 298
 299 sub recv {
 300     @_ == 3 || @_ == 4 or croak 'usage: $fh->recv(BUF, LEN [, FLAGS])';
 301     my $sock  = $_[0];
 302     my $len   = $_[2];
 303     my $flags = $_[3] || 0;
 304
 305     # remember who we recv'd from
 306     ${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags);
 307 }
 308
 309
 310 sub setsockopt {
 311     @_ == 4 or croak '$fh->setsockopt(LEVEL, OPTNAME)';
 312     setsockopt($_[0],$_[1],$_[2],$_[3]);
 313 }
 314
 315 my $intsize = length(pack("i",0));
 316
 317 sub getsockopt {
 318     @_ == 3 or croak '$fh->getsockopt(LEVEL, OPTNAME)';
 319     my $r = getsockopt($_[0],$_[1],$_[2]);
 320     # Just a guess
 321     $r = unpack("i", $r)
 322         if(defined $r && length($r) == $intsize);
 323     $r;
 324 }
 325
 326 sub sockopt {
 327     my $fh = shift;
 328     @_ == 1 ? $fh->getsockopt(SOL_SOCKET,@_)
 329             : $fh->setsockopt(SOL_SOCKET,@_);
 330 }
 331
 332 sub timeout {
 333     @_ == 1 || @_ == 2 or croak 'usage: $fh->timeout([VALUE])';
 334     my($fh,$val) = @_;
 335     my $r = ${*$fh}{'io_socket_timeout'} || undef;
 336
 337     ${*$fh}{'io_socket_timeout'} = 0 + $val
 338         if(@_ == 2);
 339
 340     $r;
 341 }
 342
 343 sub sockdomain {
 344     @_ == 1 or croak 'usage: $fh->sockdomain()';
 345     my $fh = shift;
 346     ${*$fh}{'io_socket_domain'};
 347 }
 348
 349 sub socktype {
 350     @_ == 1 or croak 'usage: $fh->socktype()';
 351     my $fh = shift;
 352     ${*$fh}{'io_socket_type'}
 353 }
 354
 355 sub protocol {
 356     @_ == 1 or croak 'usage: $fh->protocol()';
 357     my($fh) = @_;
 358     ${*$fh}{'io_socket_protocol'};
 359 }
 360
 361 =head1 SUB-CLASSES
 362
 363 =cut
 364
 365 ##
 366 ## AF_INET
 367 ##
 368
 369 package IO::Socket::INET;
 370
 371 use strict;
 372 use vars qw(@ISA);
 373 use Socket;
 374 use Carp;
 375 use Exporter;
 376
 377 @ISA = qw(IO::Socket);
 378
 379 IO::Socket::INET->register_domain( AF_INET );
 380
 381 my %socket_type = ( tcp => SOCK_STREAM,
 382                     udp => SOCK_DGRAM,
 383                   );
 384
 385 =head2 IO::Socket::INET
 386
 387 C<IO::Socket::INET> provides a constructor to create an AF_INET domain socket
 388 and some related methods. The constructor can take the following options
 389
 390     PeerAddr    Remote host address          <hostname>[:<port>]
 391     PeerPort    Remote port or service       <service>[(<no>)] | <no>
 392     LocalAddr   Local host bind address      hostname[:port]
 393     LocalPort   Local host bind port         <service>[(<no>)] | <no>
 394     Proto       Protocol name                "tcp" | "udp" | ...
 395     Type        Socket type                  SOCK_STREAM | SOCK_DGRAM | ...
 396     Listen      Queue size for listen
 397     Reuse       Set SO_REUSEADDR before binding
 398     Timeout     Timeout value for various operations
 399
 400
 401 If C<Listen> is defined then a listen socket is created, else if the
 402 socket type, which is derived from the protocol, is SOCK_STREAM then
 403 connect() is called.
 404
 405 The C<PeerAddr> can be a hostname or the IP-address on the
 406 "xx.xx.xx.xx" form.  The C<PeerPort> can be a number or a symbolic
 407 service name.  The service name might be followed by a number in
 408 parenthesis which is used if the service is not known by the system.
 409 The C<PeerPort> specification can also be embedded in the C<PeerAddr>
 410 by preceding it with a ":".
 411
 412 Only one of C<Type> or C<Proto> needs to be specified, one will be
 413 assumed from the other.  If you specify a symbolic C<PeerPort> port,
 414 then the constructor will try to derive C<Type> and C<Proto> from
 415 the service name.
 416
 417 Examples:
 418
 419    $sock = IO::Socket::INET->new(PeerAddr => 'www.perl.org',
 420                                  PeerPort => 'http(80)',
 421                                  Proto    => 'tcp');
 422
 423    $sock = IO::Socket::INET->new(PeerAddr => 'localhost:smtp(25)');
 424
 425    $sock = IO::Socket::INET->new(Listen    => 5,
 426                                  LocalAddr => 'localhost',
 427                                  LocalPort => 9000,
 428                                  Proto     => 'tcp');
 429
 430 =head2 METHODS
 431
 432 =over 4
 433
 434 =item sockaddr ()
 435
 436 Return the address part of the sockaddr structure for the socket
 437
 438 =item sockport ()
 439
 440 Return the port number that the socket is using on the local host
 441
 442 =item sockhost ()
 443
 444 Return the address part of the sockaddr structure for the socket in a
 445 text form xx.xx.xx.xx
 446
 447 =item peeraddr ()
 448
 449 Return the address part of the sockaddr structure for the socket on
 450 the peer host
 451
 452 =item peerport ()
 453
 454 Return the port number for the socket on the peer host.
 455
 456 =item peerhost ()
 457
 458 Return the address part of the sockaddr structure for the socket on the
 459 peer host in a text form xx.xx.xx.xx
 460
 461 =back
 462
 463 =cut
 464
 465 sub _sock_info {
 466   my($addr,$port,$proto) = @_;
 467   my @proto = ();
 468   my @serv = ();
 469
 470   $port = $1
 471         if(defined $addr && $addr =~ s,:([\w\(\)/]+)$,,);
 472
 473   if(defined $proto) {
 474     @proto = $proto =~ m,\D, ? getprotobyname($proto)
 475                              : getprotobynumber($proto);
 476
 477     $proto = $proto[2] || undef;
 478   }
 479
 480   if(defined $port) {
 481     $port =~ s,\((\d+)\)$,,;
 482
 483     my $defport = $1 || undef;
 484     my $pnum = ($port =~ m,^(\d+)$,)[0];
 485
 486     @serv= getservbyname($port, $proto[0] || "")
 487         if($port =~ m,\D,);
 488
 489     $port = $pnum || $serv[2] || $defport || undef;
 490
 491     $proto = (getprotobyname($serv[3]))[2] || undef
 492         if @serv && !$proto;
 493   }
 494
 495  return ($addr || undef,
 496          $port || undef,
 497          $proto || undef
 498         );
 499 }
 500
 501 sub _error {
 502     my $fh = shift;
 503     $@ = join("",ref($fh),": ",@_);
 504     carp $@ if $^W;
 505     close($fh)
 506         if(defined fileno($fh));
 507     return undef;
 508 }
 509
 510 sub configure {
 511     my($fh,$arg) = @_;
 512     my($lport,$rport,$laddr,$raddr,$proto,$type);
 513
 514
 515     ($laddr,$lport,$proto) = _sock_info($arg->{LocalAddr},
 516                                         $arg->{LocalPort},
 517                                         $arg->{Proto});
 518
 519     $laddr = defined $laddr ? inet_aton($laddr)
 520                             : INADDR_ANY;
 521
 522     return _error($fh,"Bad hostname '",$arg->{LocalAddr},"'")
 523         unless(defined $laddr);
 524
 525     unless(exists $arg->{Listen}) {
 526         ($raddr,$rport,$proto) = _sock_info($arg->{PeerAddr},
 527                                             $arg->{PeerPort},
 528                                             $proto);
 529     }
 530
 531     if(defined $raddr) {
 532         $raddr = inet_aton($raddr);
 533         return _error($fh,"Bad hostname '",$arg->{PeerAddr},"'")
 534                 unless(defined $raddr);
 535     }
 536
 537     return _error($fh,'Cannot determine protocol')
 538         unless($proto);
 539
 540     my $pname = (getprotobynumber($proto))[0];
 541     $type = $arg->{Type} || $socket_type{$pname};
 542
 543     $fh->socket(AF_INET, $type, $proto) or
 544         return _error($fh,"$!");
 545
 546     if ($arg->{Reuse}) {
 547         $fh->sockopt(SO_REUSEADDR,1) or
 548                 return _error($fh);
 549     }
 550
 551     $fh->bind($lport || 0, $laddr) or
 552         return _error($fh,"$!");
 553
 554     if(exists $arg->{Listen}) {
 555         $fh->listen($arg->{Listen} || 5) or
 556             return _error($fh,"$!");
 557     }
 558     else {
 559         return _error($fh,'Cannot determine remote port')
 560                 unless($rport || $type == SOCK_DGRAM);
 561
 562         if($type == SOCK_STREAM || defined $raddr) {
 563             return _error($fh,'Bad peer address')
 564                 unless(defined $raddr);
 565
 566             $fh->connect($rport,$raddr) or
 567                 return _error($fh,"$!");
 568         }
 569     }
 570
 571     $fh;
 572 }
 573
 574 sub sockaddr {
 575     @_ == 1 or croak 'usage: $fh->sockaddr()';
 576     my($fh) = @_;
 577     (sockaddr_in($fh->sockname))[1];
 578 }
 579
 580 sub sockport {
 581     @_ == 1 or croak 'usage: $fh->sockport()';
 582     my($fh) = @_;
 583     (sockaddr_in($fh->sockname))[0];
 584 }
 585
 586 sub sockhost {
 587     @_ == 1 or croak 'usage: $fh->sockhost()';
 588     my($fh) = @_;
 589     inet_ntoa($fh->sockaddr);
 590 }
 591
 592 sub peeraddr {
 593     @_ == 1 or croak 'usage: $fh->peeraddr()';
 594     my($fh) = @_;
 595     (sockaddr_in($fh->peername))[1];
 596 }
 597
 598 sub peerport {
 599     @_ == 1 or croak 'usage: $fh->peerport()';
 600     my($fh) = @_;
 601     (sockaddr_in($fh->peername))[0];
 602 }
 603
 604 sub peerhost {
 605     @_ == 1 or croak 'usage: $fh->peerhost()';
 606     my($fh) = @_;
 607     inet_ntoa($fh->peeraddr);
 608 }
 609
 610 ##
 611 ## AF_UNIX
 612 ##
 613
 614 package IO::Socket::UNIX;
 615
 616 use strict;
 617 use vars qw(@ISA $VERSION);
 618 use Socket;
 619 use Carp;
 620 use Exporter;
 621
 622 @ISA = qw(IO::Socket);
 623
 624 IO::Socket::UNIX->register_domain( AF_UNIX );
 625
 626 =head2 IO::Socket::UNIX
 627
 628 C<IO::Socket::UNIX> provides a constructor to create an AF_UNIX domain socket
 629 and some related methods. The constructor can take the following options
 630
 631     Type        Type of socket (eg SOCK_STREAM or SOCK_DGRAM)
 632     Local       Path to local fifo
 633     Peer        Path to peer fifo
 634     Listen      Create a listen socket
 635
 636 =head2 METHODS
 637
 638 =over 4
 639
 640 =item hostpath()
 641
 642 Returns the pathname to the fifo at the local end
 643
 644 =item peerpath()
 645
 646 Returns the pathanme to the fifo at the peer end
 647
 648 =back
 649
 650 =cut
 651
 652 sub configure {
 653     my($fh,$arg) = @_;
 654     my($bport,$cport);
 655
 656     my $type = $arg->{Type} || SOCK_STREAM;
 657
 658     $fh->socket(AF_UNIX, $type, 0) or
 659         return undef;
 660
 661     if(exists $arg->{Local}) {
 662         my $addr = sockaddr_un($arg->{Local});
 663         $fh->bind($addr) or
 664             return undef;
 665     }
 666     if(exists $arg->{Listen}) {
 667         $fh->listen($arg->{Listen} || 5) or
 668             return undef;
 669     }
 670     elsif(exists $arg->{Peer}) {
 671         my $addr = sockaddr_un($arg->{Peer});
 672         $fh->connect($addr) or
 673             return undef;
 674     }
 675
 676     $fh;
 677 }
 678
 679 sub hostpath {
 680     @_ == 1 or croak 'usage: $fh->hostpath()';
 681     my $n = $_[0]->sockname || return undef;
 682     (sockaddr_un($n))[0];
 683 }
 684
 685 sub peerpath {
 686     @_ == 1 or croak 'usage: $fh->peerpath()';
 687     my $n = $_[0]->peername || return undef;
 688     (sockaddr_un($n))[0];
 689 }
 690
 691 =head1 SEE ALSO
 692
 693 L<Socket>, L<IO::Handle>
 694
 695 =head1 AUTHOR
 696
 697 Graham Barr E<lt>F<Graham.Barr@tiuk.ti.com>E<gt>
 698
 699 =head1 COPYRIGHT
 700
 701 Copyright (c) 1996 Graham Barr. All rights reserved. This program is free
 702 software; you can redistribute it and/or modify it under the same terms
 703 as Perl itself.
 704
 705 =cut
 706
 707 1; # Keep require happy