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