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