ext/IO/lib/IO/Socket.pm

   1 # IO::Socket.pm
   2 #
   3 # Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
   4 # 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 require 5.000;
  10
  11 use IO::Handle;
  12 use Socket 1.3;
  13 use Carp;
  14 use strict;
  15 use vars qw(@ISA $VERSION);
  16 use Exporter;
  17
  18 # legacy
  19
  20 require IO::Socket::INET;
  21 require IO::Socket::UNIX;
  22
  23 @ISA = qw(IO::Handle);
  24
  25 $VERSION = "1.252";
  26
  27 sub import {
  28     my $pkg = shift;
  29     my $callpkg = caller;
  30     Exporter::export 'Socket', $callpkg, @_;
  31 }
  32
  33 sub new {
  34     my($class,%arg) = @_;
  35     my $sock = $class->SUPER::new();
  36
  37     $sock->autoflush(1);
  38
  39     ${*$sock}{'io_socket_timeout'} = delete $arg{Timeout};
  40
  41     return scalar(%arg) ? $sock->configure(\%arg)
  42                         : $sock;
  43 }
  44
  45 my @domain2pkg;
  46
  47 sub register_domain {
  48     my($p,$d) = @_;
  49     $domain2pkg[$d] = $p;
  50 }
  51
  52 sub configure {
  53     my($sock,$arg) = @_;
  54     my $domain = delete $arg->{Domain};
  55
  56     croak 'IO::Socket: Cannot configure a generic socket'
  57         unless defined $domain;
  58
  59     croak "IO::Socket: Unsupported socket domain"
  60         unless defined $domain2pkg[$domain];
  61
  62     croak "IO::Socket: Cannot configure socket in domain '$domain'"
  63         unless ref($sock) eq "IO::Socket";
  64
  65     bless($sock, $domain2pkg[$domain]);
  66     $sock->configure($arg);
  67 }
  68
  69 sub socket {
  70     @_ == 4 or croak 'usage: $sock->socket(DOMAIN, TYPE, PROTOCOL)';
  71     my($sock,$domain,$type,$protocol) = @_;
  72
  73     socket($sock,$domain,$type,$protocol) or
  74         return undef;
  75
  76     ${*$sock}{'io_socket_domain'} = $domain;
  77     ${*$sock}{'io_socket_type'}   = $type;
  78     ${*$sock}{'io_socket_proto'}  = $protocol;
  79
  80     $sock;
  81 }
  82
  83 sub socketpair {
  84     @_ == 4 || croak 'usage: IO::Socket->socketpair(DOMAIN, TYPE, PROTOCOL)';
  85     my($class,$domain,$type,$protocol) = @_;
  86     my $sock1 = $class->new();
  87     my $sock2 = $class->new();
  88
  89     socketpair($sock1,$sock2,$domain,$type,$protocol) or
  90         return ();
  91
  92     ${*$sock1}{'io_socket_type'}  = ${*$sock2}{'io_socket_type'}  = $type;
  93     ${*$sock1}{'io_socket_proto'} = ${*$sock2}{'io_socket_proto'} = $protocol;
  94
  95     ($sock1,$sock2);
  96 }
  97
  98 sub connect {
  99     @_ == 2 or croak 'usage: $sock->connect(NAME)';
 100     my $sock = shift;
 101     my $addr = shift;
 102     my $timeout = ${*$sock}{'io_socket_timeout'};
 103
 104     my $blocking;
 105     $blocking = $sock->blocking(0) if $timeout;
 106
 107     eval {
 108         croak 'connect: Bad address'
 109             if(@_ == 2 && !defined $_[1]);
 110
 111         unless(connect($sock, $addr)) {
 112             if($timeout && ($! == &IO::EINPROGRESS)) {
 113                 require IO::Select;
 114
 115                 my $sel = new IO::Select $sock;
 116
 117                 unless($sel->can_write($timeout) && defined($sock->peername)) {
 118                     croak "connect: timeout";
 119                 }
 120             }
 121             else {
 122                 croak "connect: $!";
 123             }
 124         }
 125     };
 126
 127     my $ret = $@ ? undef : $sock;
 128
 129     $sock->blocking($blocking) if $timeout;
 130
 131     $ret;
 132 }
 133
 134 sub bind {
 135     @_ == 2 or croak 'usage: $sock->bind(NAME)';
 136     my $sock = shift;
 137     my $addr = shift;
 138
 139     return bind($sock, $addr) ? $sock
 140                               : undef;
 141 }
 142
 143 sub listen {
 144     @_ >= 1 && @_ <= 2 or croak 'usage: $sock->listen([QUEUE])';
 145     my($sock,$queue) = @_;
 146     $queue = 5
 147         unless $queue && $queue > 0;
 148
 149     return listen($sock, $queue) ? $sock
 150                                  : undef;
 151 }
 152
 153 sub accept {
 154     @_ == 1 || @_ == 2 or croak 'usage $sock->accept([PKG])';
 155     my $sock = shift;
 156     my $pkg = shift || $sock;
 157     my $timeout = ${*$sock}{'io_socket_timeout'};
 158     my $new = $pkg->new(Timeout => $timeout);
 159     my $peer = undef;
 160
 161     eval {
 162         if($timeout) {
 163             require IO::Select;
 164
 165             my $sel = new IO::Select $sock;
 166
 167             croak "accept: timeout"
 168                 unless $sel->can_read($timeout);
 169         }
 170         $peer = accept($new,$sock) || undef;
 171     };
 172     croak "$@" if $@ and $sock;
 173
 174     return wantarray ? defined $peer ? ($new, $peer)
 175                                      : ()
 176                      : defined $peer ? $new
 177                                      : undef;
 178 }
 179
 180 sub sockname {
 181     @_ == 1 or croak 'usage: $sock->sockname()';
 182     getsockname($_[0]);
 183 }
 184
 185 sub peername {
 186     @_ == 1 or croak 'usage: $sock->peername()';
 187     my($sock) = @_;
 188     getpeername($sock)
 189       || ${*$sock}{'io_socket_peername'}
 190       || undef;
 191 }
 192
 193 sub connected {
 194     @_ == 1 or croak 'usage: $sock->connected()';
 195     my($sock) = @_;
 196     getpeername($sock);
 197 }
 198
 199 sub send {
 200     @_ >= 2 && @_ <= 4 or croak 'usage: $sock->send(BUF, [FLAGS, [TO]])';
 201     my $sock  = $_[0];
 202     my $flags = $_[2] || 0;
 203     my $peer  = $_[3] || $sock->peername;
 204
 205     croak 'send: Cannot determine peer address'
 206          unless($peer);
 207
 208     my $r = defined(getpeername($sock))
 209         ? send($sock, $_[1], $flags)
 210         : send($sock, $_[1], $flags, $peer);
 211
 212     # remember who we send to, if it was sucessful
 213     ${*$sock}{'io_socket_peername'} = $peer
 214         if(@_ == 4 && defined $r);
 215
 216     $r;
 217 }
 218
 219 sub recv {
 220     @_ == 3 || @_ == 4 or croak 'usage: $sock->recv(BUF, LEN [, FLAGS])';
 221     my $sock  = $_[0];
 222     my $len   = $_[2];
 223     my $flags = $_[3] || 0;
 224
 225     # remember who we recv'd from
 226     ${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags);
 227 }
 228
 229 sub shutdown {
 230     @_ == 2 or croak 'usage: $sock->shutdown(HOW)';
 231     my($sock, $how) = @_;
 232     shutdown($sock, $how);
 233 }
 234
 235 sub setsockopt {
 236     @_ == 4 or croak '$sock->setsockopt(LEVEL, OPTNAME)';
 237     setsockopt($_[0],$_[1],$_[2],$_[3]);
 238 }
 239
 240 my $intsize = length(pack("i",0));
 241
 242 sub getsockopt {
 243     @_ == 3 or croak '$sock->getsockopt(LEVEL, OPTNAME)';
 244     my $r = getsockopt($_[0],$_[1],$_[2]);
 245     # Just a guess
 246     $r = unpack("i", $r)
 247         if(defined $r && length($r) == $intsize);
 248     $r;
 249 }
 250
 251 sub sockopt {
 252     my $sock = shift;
 253     @_ == 1 ? $sock->getsockopt(SOL_SOCKET,@_)
 254             : $sock->setsockopt(SOL_SOCKET,@_);
 255 }
 256
 257 sub timeout {
 258     @_ == 1 || @_ == 2 or croak 'usage: $sock->timeout([VALUE])';
 259     my($sock,$val) = @_;
 260     my $r = ${*$sock}{'io_socket_timeout'} || undef;
 261
 262     ${*$sock}{'io_socket_timeout'} = 0 + $val
 263         if(@_ == 2);
 264
 265     $r;
 266 }
 267
 268 sub sockdomain {
 269     @_ == 1 or croak 'usage: $sock->sockdomain()';
 270     my $sock = shift;
 271     ${*$sock}{'io_socket_domain'};
 272 }
 273
 274 sub socktype {
 275     @_ == 1 or croak 'usage: $sock->socktype()';
 276     my $sock = shift;
 277     ${*$sock}{'io_socket_type'}
 278 }
 279
 280 sub protocol {
 281     @_ == 1 or croak 'usage: $sock->protocol()';
 282     my($sock) = @_;
 283     ${*$sock}{'io_socket_proto'};
 284 }
 285
 286 1;
 287
 288 __END__
 289
 290 =head1 NAME
 291
 292 IO::Socket - Object interface to socket communications
 293
 294 =head1 SYNOPSIS
 295
 296     use IO::Socket;
 297
 298 =head1 DESCRIPTION
 299
 300 C<IO::Socket> provides an object interface to creating and using sockets. It
 301 is built upon the L<IO::Handle> interface and inherits all the methods defined
 302 by L<IO::Handle>.
 303
 304 C<IO::Socket> only defines methods for those operations which are common to all
 305 types of socket. Operations which are specified to a socket in a particular
 306 domain have methods defined in sub classes of C<IO::Socket>
 307
 308 C<IO::Socket> will export all functions (and constants) defined by L<Socket>.
 309
 310 =head1 CONSTRUCTOR
 311
 312 =over 4
 313
 314 =item new ( [ARGS] )
 315
 316 Creates an C<IO::Socket>, which is a reference to a
 317 newly created symbol (see the C<Symbol> package). C<new>
 318 optionally takes arguments, these arguments are in key-value pairs.
 319 C<new> only looks for one key C<Domain> which tells new which domain
 320 the socket will be in. All other arguments will be passed to the
 321 configuration method of the package for that domain, See below.
 322
 323  NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
 324
 325 As of VERSION 1.18 all IO::Socket objects have autoflush turned on
 326 by default. This was not the case with earlier releases.
 327
 328  NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
 329
 330 =back
 331
 332 =head1 METHODS
 333
 334 See L<perlfunc> for complete descriptions of each of the following
 335 supported C<IO::Socket> methods, which are just front ends for the
 336 corresponding built-in functions:
 337
 338     socket
 339     socketpair
 340     bind
 341     listen
 342     accept
 343     send
 344     recv
 345     peername (getpeername)
 346     sockname (getsockname)
 347     shutdown
 348
 349 Some methods take slightly different arguments to those defined in L<perlfunc>
 350 in attempt to make the interface more flexible. These are
 351
 352 =over 4
 353
 354 =item accept([PKG])
 355
 356 perform the system call C<accept> on the socket and return a new object. The
 357 new object will be created in the same class as the listen socket, unless
 358 C<PKG> is specified. This object can be used to communicate with the client
 359 that was trying to connect. In a scalar context the new socket is returned,
 360 or undef upon failure. In an array context a two-element array is returned
 361 containing the new socket and the peer address; the list will
 362 be empty upon failure.
 363
 364 =item socketpair(DOMAIN, TYPE, PROTOCOL)
 365
 366 Call C<socketpair> and return a list of two sockets created, or an
 367 empty list on failure.
 368
 369 =back
 370
 371 Additional methods that are provided are:
 372
 373 =over 4
 374
 375 =item timeout([VAL])
 376
 377 Set or get the timeout value associated with this socket. If called without
 378 any arguments then the current setting is returned. If called with an argument
 379 the current setting is changed and the previous value returned.
 380
 381 =item sockopt(OPT [, VAL])
 382
 383 Unified method to both set and get options in the SOL_SOCKET level. If called
 384 with one argument then getsockopt is called, otherwise setsockopt is called.
 385
 386 =item sockdomain
 387
 388 Returns the numerical number for the socket domain type. For example, for
 389 a AF_INET socket the value of &AF_INET will be returned.
 390
 391 =item socktype
 392
 393 Returns the numerical number for the socket type. For example, for
 394 a SOCK_STREAM socket the value of &SOCK_STREAM will be returned.
 395
 396 =item protocol
 397
 398 Returns the numerical number for the protocol being used on the socket, if
 399 known. If the protocol is unknown, as with an AF_UNIX socket, zero
 400 is returned.
 401
 402 =item connected
 403
 404 If the socket is in a connected state the the peer address is returned.
 405 If the socket is not in a connected state then undef will be returned.
 406
 407 =back
 408
 409 =head1 SEE ALSO
 410
 411 L<Socket>, L<IO::Handle>, L<IO::Socket::INET>, L<IO::Socket::UNIX>
 412
 413 =head1 AUTHOR
 414
 415 Graham Barr. Currently maintained by the Perl Porters.  Please report all
 416 bugs to <perl5-porters@perl.org>.
 417
 418 =head1 COPYRIGHT
 419
 420 Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
 421 This program is free software; you can redistribute it and/or
 422 modify it under the same terms as Perl itself.
 423
 424 =cut