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                     icmp => SOCK_RAW,
 384                   );
 385
 386 =head2 IO::Socket::INET
 387
 388 C<IO::Socket::INET> provides a constructor to create an AF_INET domain socket
 389 and some related methods. The constructor can take the following options
 390
 391     PeerAddr    Remote host address          <hostname>[:<port>]
 392     PeerPort    Remote port or service       <service>[(<no>)] | <no>
 393     LocalAddr   Local host bind address      hostname[:port]
 394     LocalPort   Local host bind port         <service>[(<no>)] | <no>
 395     Proto       Protocol name                "tcp" | "udp" | ...
 396     Type        Socket type                  SOCK_STREAM | SOCK_DGRAM | ...
 397     Listen      Queue size for listen
 398     Reuse       Set SO_REUSEADDR before binding
 399     Timeout     Timeout value for various operations
 400
 401
 402 If C<Listen> is defined then a listen socket is created, else if the
 403 socket type, which is derived from the protocol, is SOCK_STREAM then
 404 connect() is called.
 405
 406 The C<PeerAddr> can be a hostname or the IP-address on the
 407 "xx.xx.xx.xx" form.  The C<PeerPort> can be a number or a symbolic
 408 service name.  The service name might be followed by a number in
 409 parenthesis which is used if the service is not known by the system.
 410 The C<PeerPort> specification can also be embedded in the C<PeerAddr>
 411 by preceding it with a ":".
 412
 413 Only one of C<Type> or C<Proto> needs to be specified, one will be
 414 assumed from the other.  If you specify a symbolic C<PeerPort> port,
 415 then the constructor will try to derive C<Type> and C<Proto> from
 416 the service name.
 417
 418 Examples:
 419
 420    $sock = IO::Socket::INET->new(PeerAddr => 'www.perl.org',
 421                                  PeerPort => 'http(80)',
 422                                  Proto    => 'tcp');
 423
 424    $sock = IO::Socket::INET->new(PeerAddr => 'localhost:smtp(25)');
 425
 426    $sock = IO::Socket::INET->new(Listen    => 5,
 427                                  LocalAddr => 'localhost',
 428                                  LocalPort => 9000,
 429                                  Proto     => 'tcp');
 430
 431 =head2 METHODS
 432
 433 =over 4
 434
 435 =item sockaddr ()
 436
 437 Return the address part of the sockaddr structure for the socket
 438
 439 =item sockport ()
 440
 441 Return the port number that the socket is using on the local host
 442
 443 =item sockhost ()
 444
 445 Return the address part of the sockaddr structure for the socket in a
 446 text form xx.xx.xx.xx
 447
 448 =item peeraddr ()
 449
 450 Return the address part of the sockaddr structure for the socket on
 451 the peer host
 452
 453 =item peerport ()
 454
 455 Return the port number for the socket on the peer host.
 456
 457 =item peerhost ()
 458
 459 Return the address part of the sockaddr structure for the socket on the
 460 peer host in a text form xx.xx.xx.xx
 461
 462 =back
 463
 464 =cut
 465
 466 sub _sock_info {
 467   my($addr,$port,$proto) = @_;
 468   my @proto = ();
 469   my @serv = ();
 470
 471   $port = $1
 472         if(defined $addr && $addr =~ s,:([\w\(\)/]+)$,,);
 473
 474   if(defined $proto) {
 475     @proto = $proto =~ m,\D, ? getprotobyname($proto)
 476                              : getprotobynumber($proto);
 477
 478     $proto = $proto[2] || undef;
 479   }
 480
 481   if(defined $port) {
 482     $port =~ s,\((\d+)\)$,,;
 483
 484     my $defport = $1 || undef;
 485     my $pnum = ($port =~ m,^(\d+)$,)[0];
 486
 487     @serv= getservbyname($port, $proto[0] || "")
 488         if($port =~ m,\D,);
 489
 490     $port = $pnum || $serv[2] || $defport || undef;
 491
 492     $proto = (getprotobyname($serv[3]))[2] || undef
 493         if @serv && !$proto;
 494   }
 495
 496  return ($addr || undef,
 497          $port || undef,
 498          $proto || undef
 499         );
 500 }
 501
 502 sub _error {
 503     my $fh = shift;
 504     $@ = join("",ref($fh),": ",@_);
 505     carp $@ if $^W;
 506     close($fh)
 507         if(defined fileno($fh));
 508     return undef;
 509 }
 510
 511 sub configure {
 512     my($fh,$arg) = @_;
 513     my($lport,$rport,$laddr,$raddr,$proto,$type);
 514
 515
 516     ($laddr,$lport,$proto) = _sock_info($arg->{LocalAddr},
 517                                         $arg->{LocalPort},
 518                                         $arg->{Proto});
 519
 520     $laddr = defined $laddr ? inet_aton($laddr)
 521                             : INADDR_ANY;
 522
 523     return _error($fh,"Bad hostname '",$arg->{LocalAddr},"'")
 524         unless(defined $laddr);
 525
 526     unless(exists $arg->{Listen}) {
 527         ($raddr,$rport,$proto) = _sock_info($arg->{PeerAddr},
 528                                             $arg->{PeerPort},
 529                                             $proto);
 530     }
 531
 532     if(defined $raddr) {
 533         $raddr = inet_aton($raddr);
 534         return _error($fh,"Bad hostname '",$arg->{PeerAddr},"'")
 535                 unless(defined $raddr);
 536     }
 537
 538     return _error($fh,'Cannot determine protocol')
 539         unless($proto);
 540
 541     my $pname = (getprotobynumber($proto))[0];
 542     $type = $arg->{Type} || $socket_type{$pname};
 543
 544     $fh->socket(AF_INET, $type, $proto) or
 545         return _error($fh,"$!");
 546
 547     if ($arg->{Reuse}) {
 548         $fh->sockopt(SO_REUSEADDR,1) or
 549                 return _error($fh);
 550     }
 551
 552     $fh->bind($lport || 0, $laddr) or
 553         return _error($fh,"$!");
 554
 555     if(exists $arg->{Listen}) {
 556         $fh->listen($arg->{Listen} || 5) or
 557             return _error($fh,"$!");
 558     }
 559     else {
 560         return _error($fh,'Cannot determine remote port')
 561                 unless($rport || $type == SOCK_DGRAM || $type == SOCK_RAW);
 562
 563         if($type == SOCK_STREAM || defined $raddr) {
 564             return _error($fh,'Bad peer address')
 565                 unless(defined $raddr);
 566
 567             $fh->connect($rport,$raddr) or
 568                 return _error($fh,"$!");
 569         }
 570     }
 571
 572     $fh;
 573 }
 574
 575 sub sockaddr {
 576     @_ == 1 or croak 'usage: $fh->sockaddr()';
 577     my($fh) = @_;
 578     (sockaddr_in($fh->sockname))[1];
 579 }
 580
 581 sub sockport {
 582     @_ == 1 or croak 'usage: $fh->sockport()';
 583     my($fh) = @_;
 584     (sockaddr_in($fh->sockname))[0];
 585 }
 586
 587 sub sockhost {
 588     @_ == 1 or croak 'usage: $fh->sockhost()';
 589     my($fh) = @_;
 590     inet_ntoa($fh->sockaddr);
 591 }
 592
 593 sub peeraddr {
 594     @_ == 1 or croak 'usage: $fh->peeraddr()';
 595     my($fh) = @_;
 596     (sockaddr_in($fh->peername))[1];
 597 }
 598
 599 sub peerport {
 600     @_ == 1 or croak 'usage: $fh->peerport()';
 601     my($fh) = @_;
 602     (sockaddr_in($fh->peername))[0];
 603 }
 604
 605 sub peerhost {
 606     @_ == 1 or croak 'usage: $fh->peerhost()';
 607     my($fh) = @_;
 608     inet_ntoa($fh->peeraddr);
 609 }
 610
 611 ##
 612 ## AF_UNIX
 613 ##
 614
 615 package IO::Socket::UNIX;
 616
 617 use strict;
 618 use vars qw(@ISA $VERSION);
 619 use Socket;
 620 use Carp;
 621 use Exporter;
 622
 623 @ISA = qw(IO::Socket);
 624
 625 IO::Socket::UNIX->register_domain( AF_UNIX );
 626
 627 =head2 IO::Socket::UNIX
 628
 629 C<IO::Socket::UNIX> provides a constructor to create an AF_UNIX domain socket
 630 and some related methods. The constructor can take the following options
 631
 632     Type        Type of socket (eg SOCK_STREAM or SOCK_DGRAM)
 633     Local       Path to local fifo
 634     Peer        Path to peer fifo
 635     Listen      Create a listen socket
 636
 637 =head2 METHODS
 638
 639 =over 4
 640
 641 =item hostpath()
 642
 643 Returns the pathname to the fifo at the local end
 644
 645 =item peerpath()
 646
 647 Returns the pathanme to the fifo at the peer end
 648
 649 =back
 650
 651 =cut
 652
 653 sub configure {
 654     my($fh,$arg) = @_;
 655     my($bport,$cport);
 656
 657     my $type = $arg->{Type} || SOCK_STREAM;
 658
 659     $fh->socket(AF_UNIX, $type, 0) or
 660         return undef;
 661
 662     if(exists $arg->{Local}) {
 663         my $addr = sockaddr_un($arg->{Local});
 664         $fh->bind($addr) or
 665             return undef;
 666     }
 667     if(exists $arg->{Listen}) {
 668         $fh->listen($arg->{Listen} || 5) or
 669             return undef;
 670     }
 671     elsif(exists $arg->{Peer}) {
 672         my $addr = sockaddr_un($arg->{Peer});
 673         $fh->connect($addr) or
 674             return undef;
 675     }
 676
 677     $fh;
 678 }
 679
 680 sub hostpath {
 681     @_ == 1 or croak 'usage: $fh->hostpath()';
 682     my $n = $_[0]->sockname || return undef;
 683     (sockaddr_un($n))[0];
 684 }
 685
 686 sub peerpath {
 687     @_ == 1 or croak 'usage: $fh->peerpath()';
 688     my $n = $_[0]->peername || return undef;
 689     (sockaddr_un($n))[0];
 690 }
 691
 692 =head1 SEE ALSO
 693
 694 L<Socket>, L<IO::Handle>
 695
 696 =head1 AUTHOR
 697
 698 Graham Barr E<lt>F<Graham.Barr@tiuk.ti.com>E<gt>
 699
 700 =head1 COPYRIGHT
 701
 702 Copyright (c) 1996 Graham Barr. All rights reserved. This program is free
 703 software; you can redistribute it and/or modify it under the same terms
 704 as Perl itself.
 705
 706 =cut
 707
 708 1; # Keep require happy