ext/IO/lib/IO/Socket.pm

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