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