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