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