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 "$@"
 173         if ($@ and $fh);
 174
 175     return wantarray ? defined $peer ? ($new, $peer)
 176                                      : ()
 177                      : defined $peer ? $new
 178                                      : undef;
 179 }
 180
 181 sub sockname {
 182     @_ == 1 or croak 'usage: $sock->sockname()';
 183     getsockname($_[0]);
 184 }
 185
 186 sub peername {
 187     @_ == 1 or croak 'usage: $sock->peername()';
 188     my($sock) = @_;
 189     getpeername($sock)
 190       || ${*$sock}{'io_socket_peername'}
 191       || undef;
 192 }
 193
 194 sub connected {
 195     @_ == 1 or croak 'usage: $sock->connected()';
 196     my($sock) = @_;
 197     getpeername($sock);
 198 }
 199
 200 sub send {
 201     @_ >= 2 && @_ <= 4 or croak 'usage: $sock->send(BUF, [FLAGS, [TO]])';
 202     my $sock  = $_[0];
 203     my $flags = $_[2] || 0;
 204     my $peer  = $_[3] || $sock->peername;
 205
 206     croak 'send: Cannot determine peer address'
 207          unless($peer);
 208
 209     my $r = defined(getpeername($sock))
 210         ? send($sock, $_[1], $flags)
 211         : send($sock, $_[1], $flags, $peer);
 212
 213     # remember who we send to, if it was sucessful
 214     ${*$sock}{'io_socket_peername'} = $peer
 215         if(@_ == 4 && defined $r);
 216
 217     $r;
 218 }
 219
 220 sub recv {
 221     @_ == 3 || @_ == 4 or croak 'usage: $sock->recv(BUF, LEN [, FLAGS])';
 222     my $sock  = $_[0];
 223     my $len   = $_[2];
 224     my $flags = $_[3] || 0;
 225
 226     # remember who we recv'd from
 227     ${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags);
 228 }
 229
 230 sub shutdown {
 231     @_ == 2 or croak 'usage: $sock->shutdown(HOW)';
 232     my($sock, $how) = @_;
 233     shutdown($sock, $how);
 234 }
 235
 236 sub setsockopt {
 237     @_ == 4 or croak '$sock->setsockopt(LEVEL, OPTNAME)';
 238     setsockopt($_[0],$_[1],$_[2],$_[3]);
 239 }
 240
 241 my $intsize = length(pack("i",0));
 242
 243 sub getsockopt {
 244     @_ == 3 or croak '$sock->getsockopt(LEVEL, OPTNAME)';
 245     my $r = getsockopt($_[0],$_[1],$_[2]);
 246     # Just a guess
 247     $r = unpack("i", $r)
 248         if(defined $r && length($r) == $intsize);
 249     $r;
 250 }
 251
 252 sub sockopt {
 253     my $sock = shift;
 254     @_ == 1 ? $sock->getsockopt(SOL_SOCKET,@_)
 255             : $sock->setsockopt(SOL_SOCKET,@_);
 256 }
 257
 258 sub timeout {
 259     @_ == 1 || @_ == 2 or croak 'usage: $sock->timeout([VALUE])';
 260     my($sock,$val) = @_;
 261     my $r = ${*$sock}{'io_socket_timeout'} || undef;
 262
 263     ${*$sock}{'io_socket_timeout'} = 0 + $val
 264         if(@_ == 2);
 265
 266     $r;
 267 }
 268
 269 sub sockdomain {
 270     @_ == 1 or croak 'usage: $sock->sockdomain()';
 271     my $sock = shift;
 272     ${*$sock}{'io_socket_domain'};
 273 }
 274
 275 sub socktype {
 276     @_ == 1 or croak 'usage: $sock->socktype()';
 277     my $sock = shift;
 278     ${*$sock}{'io_socket_type'}
 279 }
 280
 281 sub protocol {
 282     @_ == 1 or croak 'usage: $sock->protocol()';
 283     my($sock) = @_;
 284     ${*$sock}{'io_socket_proto'};
 285 }
 286
 287 1;
 288
 289 __END__
 290
 291 =head1 NAME
 292
 293 IO::Socket - Object interface to socket communications
 294
 295 =head1 SYNOPSIS
 296
 297     use IO::Socket;
 298
 299 =head1 DESCRIPTION
 300
 301 C<IO::Socket> provides an object interface to creating and using sockets. It
 302 is built upon the L<IO::Handle> interface and inherits all the methods defined
 303 by L<IO::Handle>.
 304
 305 C<IO::Socket> only defines methods for those operations which are common to all
 306 types of socket. Operations which are specified to a socket in a particular
 307 domain have methods defined in sub classes of C<IO::Socket>
 308
 309 C<IO::Socket> will export all functions (and constants) defined by L<Socket>.
 310
 311 =head1 CONSTRUCTOR
 312
 313 =over 4
 314
 315 =item new ( [ARGS] )
 316
 317 Creates an C<IO::Socket>, which is a reference to a
 318 newly created symbol (see the C<Symbol> package). C<new>
 319 optionally takes arguments, these arguments are in key-value pairs.
 320 C<new> only looks for one key C<Domain> which tells new which domain
 321 the socket will be in. All other arguments will be passed to the
 322 configuration method of the package for that domain, See below.
 323
 324  NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
 325
 326 As of VERSION 1.18 all IO::Socket objects have autoflush turned on
 327 by default. This was not the case with earlier releases.
 328
 329  NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
 330
 331 =back
 332
 333 =head1 METHODS
 334
 335 See L<perlfunc> for complete descriptions of each of the following
 336 supported C<IO::Socket> methods, which are just front ends for the
 337 corresponding built-in functions:
 338
 339     socket
 340     socketpair
 341     bind
 342     listen
 343     accept
 344     send
 345     recv
 346     peername (getpeername)
 347     sockname (getsockname)
 348     shutdown
 349
 350 Some methods take slightly different arguments to those defined in L<perlfunc>
 351 in attempt to make the interface more flexible. These are
 352
 353 =over 4
 354
 355 =item accept([PKG])
 356
 357 perform the system call C<accept> on the socket and return a new object. The
 358 new object will be created in the same class as the listen socket, unless
 359 C<PKG> is specified. This object can be used to communicate with the client
 360 that was trying to connect. In a scalar context the new socket is returned,
 361 or undef upon failure. In an array context a two-element array is returned
 362 containing the new socket and the peer address; the list will
 363 be empty upon failure.
 364
 365 =item socketpair(DOMAIN, TYPE, PROTOCOL)
 366
 367 Call C<socketpair> and return a list of two sockets created, or an
 368 empty list on failure.
 369
 370 =back
 371
 372 Additional methods that are provided are:
 373
 374 =over 4
 375
 376 =item timeout([VAL])
 377
 378 Set or get the timeout value associated with this socket. If called without
 379 any arguments then the current setting is returned. If called with an argument
 380 the current setting is changed and the previous value returned.
 381
 382 =item sockopt(OPT [, VAL])
 383
 384 Unified method to both set and get options in the SOL_SOCKET level. If called
 385 with one argument then getsockopt is called, otherwise setsockopt is called.
 386
 387 =item sockdomain
 388
 389 Returns the numerical number for the socket domain type. For example, for
 390 a AF_INET socket the value of &AF_INET will be returned.
 391
 392 =item socktype
 393
 394 Returns the numerical number for the socket type. For example, for
 395 a SOCK_STREAM socket the value of &SOCK_STREAM will be returned.
 396
 397 =item protocol
 398
 399 Returns the numerical number for the protocol being used on the socket, if
 400 known. If the protocol is unknown, as with an AF_UNIX socket, zero
 401 is returned.
 402
 403 =item connected
 404
 405 If the socket is in a connected state the the peer address is returned.
 406 If the socket is not in a connected state then undef will be returned.
 407
 408 =back
 409
 410 =head1 SEE ALSO
 411
 412 L<Socket>, L<IO::Handle>, L<IO::Socket::INET>, L<IO::Socket::UNIX>
 413
 414 =head1 AUTHOR
 415
 416 Graham Barr. Currently maintained by the Perl Porters.  Please report all
 417 bugs to <perl5-porters@perl.org>.
 418
 419 =head1 COPYRIGHT
 420
 421 Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
 422 This program is free software; you can redistribute it and/or
 423 modify it under the same terms as Perl itself.
 424
 425 =cut