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