ext/IO/lib/IO/Socket.pm

   1 #
   2
   3 package IO::Socket;
   4
   5 =head1 NAME
   6
   7 IO::Socket - supply object methods for sockets
   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 See L<perlfunc> for complete descriptions of each of the following
  24 supported C<IO::Seekable> methods, which are just front ends for the
  25 corresponding built-in functions:
  26
  27     socket
  28     socketpair
  29     bind
  30     listen
  31     accept
  32     send
  33     recv
  34     peername (getpeername)
  35     sockname (getsockname)
  36
  37 Some methods take slightly different arguments to those defined in L<perlfunc>
  38 in attempt to make the interface more flexible. These are
  39
  40 =item accept([PKG])
  41
  42 perform the system call C<accept> on the socket and return a new object. The
  43 new object will be created in the same class as the listen socket, unless
  44 C<PKG> is specified. This object can be used to communicate with the client
  45 that was trying to connect. In a scalar context the new socket is returned,
  46 or undef upon failure. In an array context a two-element array is returned
  47 containing the new socket and the peer address, the list will
  48 be empty upon failure.
  49
  50 Additional methods that are provided are
  51
  52 =item timeout([VAL])
  53
  54 Set or get the timeout value associated with this socket. If called without
  55 any arguments then the current setting is returned. If called with an argument
  56 the current setting is changed and the previous value returned.
  57
  58 =item sockopt(OPT [, VAL])
  59
  60 Unified method to both set and get options in the SOL_SOCKET level. If called
  61 with one argument then getsockopt is called, otherwise setsockopt is called
  62
  63 =cut
  64
  65
  66 require 5.000;
  67
  68 use Config;
  69 use IO::Handle;
  70 use Socket 1.3;
  71 use Carp;
  72 use strict;
  73 use vars qw(@ISA @EXPORT_OK $VERSION);
  74 use Exporter;
  75
  76 @ISA = qw(IO::Handle);
  77
  78 # This one will turn 1.2 => 1.02 and 1.2.3 => 1.0203 and so on ...
  79
  80 $VERSION = do{my @r=(q$Revision: 1.9 $=~/(\d+)/g);sprintf "%d."."%02d"x$#r,@r};
  81
  82 sub import {
  83     my $pkg = shift;
  84     my $callpkg = caller;
  85     Exporter::export 'Socket', $callpkg, @_;
  86 }
  87
  88 sub new {
  89     my($class,%arg) = @_;
  90     my $fh = $class->SUPER::new();
  91
  92     ${*$fh}{'io_socket_timeout'} = delete $arg{Timeout};
  93
  94     return scalar(%arg) ? $fh->configure(\%arg)
  95                         : $fh;
  96 }
  97
  98 sub configure {
  99     croak 'IO::Socket: Cannot configure a generic socket';
 100 }
 101
 102 sub socket {
 103     @_ == 4 or croak 'usage: $fh->socket(DOMAIN, TYPE, PROTOCOL)';
 104     my($fh,$domain,$type,$protocol) = @_;
 105
 106     socket($fh,$domain,$type,$protocol) or
 107         return undef;
 108
 109     ${*$fh}{'io_socket_type'} = $type;
 110     $fh;
 111 }
 112
 113 sub socketpair {
 114     @_ == 4 || croak 'usage: IO::Socket->pair(DOMAIN, TYPE, PROTOCOL)';
 115     my($class,$domain,$type,$protocol) = @_;
 116     my $fh1 = $class->new();
 117     my $fh2 = $class->new();
 118
 119     socketpair($fh1,$fh1,$domain,$type,$protocol) or
 120         return ();
 121
 122     ${*$fh1}{'io_socket_type'} = ${*$fh2}{'io_socket_type'} = $type;
 123
 124     ($fh1,$fh2);
 125 }
 126
 127 sub connect {
 128     @_ == 2 || @_ == 3 or croak 'usage: $fh->connect(NAME) or $fh->connect(PORT, ADDR)';
 129     my $fh = shift;
 130     my $addr = @_ == 1 ? shift : sockaddr_in(@_);
 131     my $timeout = ${*$fh}{'io_socket_timeout'};
 132     local($SIG{ALRM}) = $timeout ? sub { undef $fh; }
 133                                  : $SIG{ALRM} || 'DEFAULT';
 134
 135      eval {
 136         croak 'connect: Bad address'
 137             if(@_ == 2 && !defined $_[1]);
 138
 139         if($timeout) {
 140             defined $Config{d_alarm} && defined alarm($timeout) or
 141                 $timeout = 0;
 142         }
 143
 144         my $ok = connect($fh, $addr);
 145
 146         alarm(0)
 147             if($timeout);
 148
 149         croak "connect: timeout"
 150             unless defined $fh;
 151
 152         undef $fh unless $ok;
 153     };
 154
 155     $fh;
 156 }
 157
 158 sub bind {
 159     @_ == 2 || @_ == 3 or croak 'usage: $fh->bind(NAME) or $fh->bind(PORT, ADDR)';
 160     my $fh = shift;
 161     my $addr = @_ == 1 ? shift : sockaddr_in(@_);
 162
 163     return bind($fh, $addr) ? $fh
 164                             : undef;
 165 }
 166
 167 sub listen {
 168     @_ >= 1 && @_ <= 2 or croak 'usage: $fh->listen([QUEUE])';
 169     my($fh,$queue) = @_;
 170     $queue = 5
 171         unless $queue && $queue > 0;
 172
 173     return listen($fh, $queue) ? $fh
 174                                : undef;
 175 }
 176
 177 sub accept {
 178     @_ == 1 || @_ == 2 or croak 'usage $fh->accept([PKG])';
 179     my $fh = shift;
 180     my $pkg = shift || $fh;
 181     my $timeout = ${*$fh}{'io_socket_timeout'};
 182     my $new = $pkg->new(Timeout => $timeout);
 183     my $peer = undef;
 184
 185     eval {
 186         if($timeout) {
 187             my $fdset = "";
 188             vec($fdset, $fh->fileno,1) = 1;
 189             croak "accept: timeout"
 190                 unless select($fdset,undef,undef,$timeout);
 191         }
 192         $peer = accept($new,$fh);
 193     };
 194
 195     return wantarray ? defined $peer ? ($new, $peer)
 196                                      : ()
 197                      : defined $peer ? $new
 198                                      : undef;
 199 }
 200
 201 sub sockname {
 202     @_ == 1 or croak 'usage: $fh->sockname()';
 203     getsockname($_[0]);
 204 }
 205
 206 sub peername {
 207     @_ == 1 or croak 'usage: $fh->peername()';
 208     my($fh) = @_;
 209     getpeername($fh)
 210       || ${*$fh}{'io_socket_peername'}
 211       || undef;
 212 }
 213
 214 sub send {
 215     @_ >= 2 && @_ <= 4 or croak 'usage: $fh->send(BUF, [FLAGS, [TO]])';
 216     my $fh    = $_[0];
 217     my $flags = $_[2] || 0;
 218     my $peer  = $_[3] || $fh->peername;
 219
 220     croak 'send: Cannot determine peer address'
 221          unless($peer);
 222
 223     my $r = send($fh, $_[1], $flags, $peer);
 224
 225     # remember who we send to, if it was sucessful
 226     ${*$fh}{'io_socket_peername'} = $peer
 227         if(@_ == 4 && defined $r);
 228
 229     $r;
 230 }
 231
 232 sub recv {
 233     @_ == 3 || @_ == 4 or croak 'usage: $fh->recv(BUF, LEN [, FLAGS])';
 234     my $sock  = $_[0];
 235     my $len   = $_[2];
 236     my $flags = $_[3] || 0;
 237
 238     # remember who we recv'd from
 239     ${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags);
 240 }
 241
 242
 243 sub setsockopt {
 244     @_ == 4 or croak '$fh->setsockopt(LEVEL, OPTNAME)';
 245     setsockopt($_[0],$_[1],$_[2],$_[3]);
 246 }
 247
 248 my $intsize = length(pack("i",0));
 249
 250 sub getsockopt {
 251     @_ == 3 or croak '$fh->getsockopt(LEVEL, OPTNAME)';
 252     my $r = getsockopt($_[0],$_[1],$_[2]);
 253     # Just a guess
 254     $r = unpack("i", $r)
 255         if(defined $r && length($r) == $intsize);
 256     $r;
 257 }
 258
 259 sub sockopt {
 260     my $fh = shift;
 261     @_ == 1 ? $fh->getsockopt(SOL_SOCKET,@_)
 262             : $fh->setsockopt(SOL_SOCKET,@_);
 263 }
 264
 265 sub timeout {
 266     @_ == 1 || @_ == 2 or croak 'usage: $fh->timeout([VALUE])';
 267     my($fh,$val) = @_;
 268     my $r = ${*$fh}{'io_socket_timeout'} || undef;
 269
 270     ${*$fh}{'io_socket_timeout'} = 0 + $val
 271         if(@_ == 2);
 272
 273     $r;
 274 }
 275
 276 sub socktype {
 277     @_ == 1 or croak '$fh->socktype()';
 278     ${*{$_[0]}}{'io_socket_type'} || undef;
 279 }
 280
 281 =head1 SUB-CLASSES
 282
 283 =cut
 284
 285 ##
 286 ## AF_INET
 287 ##
 288
 289 package IO::Socket::INET;
 290
 291 use strict;
 292 use vars qw(@ISA $VERSION);
 293 use Socket;
 294 use Carp;
 295 use Exporter;
 296
 297 @ISA = qw(IO::Socket);
 298
 299 my %socket_type = ( tcp => SOCK_STREAM,
 300                     udp => SOCK_DGRAM,
 301                   );
 302
 303 =head2 IO::Socket::INET
 304
 305 C<IO::Socket::INET> provides a constructor to create an AF_INET domain socket
 306 and some related methods. The constructor can take the following options
 307
 308     PeerAddr    Remote host address
 309     PeerPort    Remote port or service
 310     LocalPort   Local host bind port
 311     LocalAddr   Local host bind address
 312     Proto       Protocol name (eg tcp udp etc)
 313     Type        Socket type (SOCK_STREAM etc)
 314     Listen      Queue size for listen
 315     Timeout     Timeout value for various operations
 316
 317 If Listen is defined then a listen socket is created, else if the socket
 318 type,   which is derived from the protocol, is SOCK_STREAM then a connect
 319 is called
 320
 321 Only one of C<Type> or C<Proto> needs to be specified, one will be assumed
 322 from the other.
 323
 324 =head2 METHODS
 325
 326 =item sockaddr()
 327
 328 Return the address part of the sockaddr structure for the socket
 329
 330 =item sockport()
 331
 332 Return the port number that the socket is using on the local host
 333
 334 =item sockhost()
 335
 336 Return the address part of the sockaddr structure for the socket in a
 337 text form xx.xx.xx.xx
 338
 339 =item peeraddr(), peerport(), peerhost()
 340
 341 Same as for the sock* functions, but returns the data about the peer
 342 host instead of the local host.
 343
 344 =cut
 345
 346
 347 sub _sock_info {
 348   my($addr,$port,$proto) = @_;
 349   my @proto = ();
 350   my @serv = ();
 351
 352   $port = $1
 353         if(defined $addr && $addr =~ s,:([\w\(\)/]+)$,,);
 354
 355   if(defined $proto) {
 356     @proto = $proto =~ m,\D, ? getprotobyname($proto)
 357                              : getprotobynumber($proto);
 358
 359     $proto = $proto[2] || undef;
 360   }
 361
 362   if(defined $port) {
 363     $port =~ s,\((\d+)\)$,,;
 364
 365     my $defport = $1 || undef;
 366     my $pnum = ($port =~ m,^(\d+)$,)[0];
 367
 368     @serv= getservbyname($port, $proto[0] || "")
 369         if($port =~ m,\D,);
 370
 371     $port = $pnum || $serv[2] || $defport || undef;
 372
 373     $proto = (getprotobyname($serv[3]))[2] || undef
 374         if @serv && !$proto;
 375   }
 376
 377  return ($addr || undef,
 378          $port || undef,
 379          $proto || undef
 380         );
 381 }
 382
 383 sub configure {
 384     my($fh,$arg) = @_;
 385     my($lport,$rport,$laddr,$raddr,$proto,$type);
 386
 387
 388     ($laddr,$lport,$proto) = _sock_info($arg->{LocalAddr},
 389                                         $arg->{LocalPort},
 390                                         $arg->{Proto});
 391
 392     $laddr = defined $laddr ? inet_aton($laddr)
 393                             : INADDR_ANY;
 394
 395     unless(exists $arg->{Listen}) {
 396         ($raddr,$rport,$proto) = _sock_info($arg->{PeerAddr},
 397                                             $arg->{PeerPort},
 398                                             $proto);
 399     }
 400
 401     croak 'IO::Socket: Cannot determine protocol'
 402         unless($proto);
 403
 404     my $pname = (getprotobynumber($proto))[0];
 405     $type = $arg->{Type} || $socket_type{$pname};
 406
 407     $fh->socket(AF_INET, $type, $proto) or
 408         return undef;
 409
 410     $fh->bind($lport || 0, $laddr) or
 411         return undef;
 412
 413     if(exists $arg->{Listen}) {
 414         $fh->listen($arg->{Listen} || 5) or
 415             return undef;
 416     }
 417     else {
 418         croak "IO::Socket: Cannot determine remote port"
 419                 unless($rport || $type == SOCK_DGRAM);
 420
 421         if($type == SOCK_STREAM || defined $raddr) {
 422             croak "IO::Socket: Bad peer address"
 423                 unless defined $raddr;
 424
 425             $fh->connect($rport,inet_aton($raddr)) or
 426                 return undef;
 427         }
 428     }
 429
 430     $fh;
 431 }
 432
 433 sub sockaddr {
 434     @_ == 1 or croak 'usage: $fh->sockaddr()';
 435     my($fh) = @_;
 436     (sockaddr_in($fh->sockname))[1];
 437 }
 438
 439 sub sockport {
 440     @_ == 1 or croak 'usage: $fh->sockport()';
 441     my($fh) = @_;
 442     (sockaddr_in($fh->sockname))[0];
 443 }
 444
 445 sub sockhost {
 446     @_ == 1 or croak 'usage: $fh->sockhost()';
 447     my($fh) = @_;
 448     inet_ntoa($fh->sockaddr);
 449 }
 450
 451 sub peeraddr {
 452     @_ == 1 or croak 'usage: $fh->peeraddr()';
 453     my($fh) = @_;
 454     (sockaddr_in($fh->peername))[1];
 455 }
 456
 457 sub peerport {
 458     @_ == 1 or croak 'usage: $fh->peerport()';
 459     my($fh) = @_;
 460     (sockaddr_in($fh->peername))[0];
 461 }
 462
 463 sub peerhost {
 464     @_ == 1 or croak 'usage: $fh->peerhost()';
 465     my($fh) = @_;
 466     inet_ntoa($fh->peeraddr);
 467 }
 468
 469 ##
 470 ## AF_UNIX
 471 ##
 472
 473 package IO::Socket::UNIX;
 474
 475 use strict;
 476 use vars qw(@ISA $VERSION);
 477 use Socket;
 478 use Carp;
 479 use Exporter;
 480
 481 @ISA = qw(IO::Socket);
 482
 483 =head2 IO::Socket::UNIX
 484
 485 C<IO::Socket::UNIX> provides a constructor to create an AF_UNIX domain socket
 486 and some related methods. The constructor can take the following options
 487
 488     Type        Type of socket (eg SOCK_STREAM or SOCK_DGRAM)
 489     Local       Path to local fifo
 490     Peer        Path to peer fifo
 491     Listen      Create a listen socket
 492
 493 =head2 METHODS
 494
 495 =item hostpath()
 496
 497 Returns the pathname to the fifo at the local end
 498
 499 =item peerpath()
 500
 501 Returns the pathanme to the fifo at the peer end
 502
 503 =cut
 504
 505 sub configure {
 506     my($fh,$arg) = @_;
 507     my($bport,$cport);
 508
 509     my $type = $arg->{Type} || SOCK_STREAM;
 510
 511     $fh->socket(AF_UNIX, $type, 0) or
 512         return undef;
 513
 514     if(exists $arg->{Local}) {
 515         my $addr = sockaddr_un($arg->{Local});
 516         $fh->bind($addr) or
 517             return undef;
 518     }
 519     if(exists $arg->{Listen}) {
 520         $fh->listen($arg->{Listen} || 5) or
 521             return undef;
 522     }
 523     elsif(exists $arg->{Peer}) {
 524         my $addr = sockaddr_un($arg->{Peer});
 525         $fh->connect($addr) or
 526             return undef;
 527     }
 528
 529     $fh;
 530 }
 531
 532 sub hostpath {
 533     @_ == 1 or croak 'usage: $fh->hostpath()';
 534     (sockaddr_un($_[0]->hostname))[0];
 535 }
 536
 537 sub peerpath {
 538     @_ == 1 or croak 'usage: $fh->peerpath()';
 539     (sockaddr_un($_[0]->peername))[0];
 540 }
 541
 542 =head1 AUTHOR
 543
 544 Graham Barr <Graham.Barr@tiuk.ti.com>
 545
 546 =head1 REVISION
 547
 548 $Revision: 1.9 $
 549
 550 The VERSION is derived from the revision turning each number after the
 551 first dot into a 2 digit number so
 552
 553         Revision 1.8   => VERSION 1.08
 554         Revision 1.2.3 => VERSION 1.0203
 555
 556 =head1 COPYRIGHT
 557
 558 Copyright (c) 1995 Graham Barr. All rights reserved. This program is free
 559 software; you can redistribute it and/or modify it under the same terms
 560 as Perl itself.
 561
 562 =cut
 563
 564 1; # Keep require happy