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' && $^O ne 'symbian');
  23
  24 @ISA = qw(IO::Handle);
  25
  26 $VERSION = "1.30_01";
  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} || $!{EWOULDBLOCK})) {
 116             require IO::Select;
 117
 118             my $sel = new IO::Select $sock;
 119
 120             undef $!;
 121             if (!$sel->can_write($timeout)) {
 122                 $err = $! || (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1);
 123                 $@ = "connect: timeout";
 124             }
 125             elsif (!connect($sock,$addr) &&
 126                 not ($!{EISCONN} || ($! == 10022 && $^O eq 'MSWin32'))
 127             ) {
 128                 # Some systems refuse to re-connect() to
 129                 # an already open socket and set errno to EISCONN.
 130                 # Windows sets errno to WSAEINVAL (10022)
 131                 $err = $!;
 132                 $@ = "connect: $!";
 133             }
 134         }
 135         elsif ($blocking || !($!{EINPROGRESS} || $!{EWOULDBLOCK}))  {
 136             $err = $!;
 137             $@ = "connect: $!";
 138         }
 139     }
 140
 141     $sock->blocking(1) if $blocking;
 142
 143     $! = $err if $err;
 144
 145     $err ? undef : $sock;
 146 }
 147
 148
 149 sub blocking {
 150     my $sock = shift;
 151
 152     return $sock->SUPER::blocking(@_)
 153         if $^O ne 'MSWin32';
 154
 155     # Windows handles blocking differently
 156     #
 157     # http://groups.google.co.uk/group/perl.perl5.porters/browse_thread/
 158     #   thread/b4e2b1d88280ddff/630b667a66e3509f?#630b667a66e3509f
 159     # http://msdn.microsoft.com/library/default.asp?url=/library/en-us/
 160     #   winsock/winsock/ioctlsocket_2.asp
 161     #
 162     # 0x8004667e is FIONBIO
 163     # By default all sockets are blocking
 164
 165     return !${*$sock}{io_sock_nonblocking}
 166         unless @_;
 167
 168     my $block = shift;
 169
 170     ${*$sock}{io_sock_nonblocking} = $block ? "0" : "1";
 171
 172     return ioctl($sock, 0x8004667e, \${*$sock}{io_sock_nonblocking});
 173 }
 174
 175
 176 sub close {
 177     @_ == 1 or croak 'usage: $sock->close()';
 178     my $sock = shift;
 179     ${*$sock}{'io_socket_peername'} = undef;
 180     $sock->SUPER::close();
 181 }
 182
 183 sub bind {
 184     @_ == 2 or croak 'usage: $sock->bind(NAME)';
 185     my $sock = shift;
 186     my $addr = shift;
 187
 188     return bind($sock, $addr) ? $sock
 189                               : undef;
 190 }
 191
 192 sub listen {
 193     @_ >= 1 && @_ <= 2 or croak 'usage: $sock->listen([QUEUE])';
 194     my($sock,$queue) = @_;
 195     $queue = 5
 196         unless $queue && $queue > 0;
 197
 198     return listen($sock, $queue) ? $sock
 199                                  : undef;
 200 }
 201
 202 sub accept {
 203     @_ == 1 || @_ == 2 or croak 'usage $sock->accept([PKG])';
 204     my $sock = shift;
 205     my $pkg = shift || $sock;
 206     my $timeout = ${*$sock}{'io_socket_timeout'};
 207     my $new = $pkg->new(Timeout => $timeout);
 208     my $peer = undef;
 209
 210     if(defined $timeout) {
 211         require IO::Select;
 212
 213         my $sel = new IO::Select $sock;
 214
 215         unless ($sel->can_read($timeout)) {
 216             $@ = 'accept: timeout';
 217             $! = (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1);
 218             return;
 219         }
 220     }
 221
 222     $peer = accept($new,$sock)
 223         or return;
 224
 225     return wantarray ? ($new, $peer)
 226                      : $new;
 227 }
 228
 229 sub sockname {
 230     @_ == 1 or croak 'usage: $sock->sockname()';
 231     getsockname($_[0]);
 232 }
 233
 234 sub peername {
 235     @_ == 1 or croak 'usage: $sock->peername()';
 236     my($sock) = @_;
 237     ${*$sock}{'io_socket_peername'} ||= getpeername($sock);
 238 }
 239
 240 sub connected {
 241     @_ == 1 or croak 'usage: $sock->connected()';
 242     my($sock) = @_;
 243     getpeername($sock);
 244 }
 245
 246 sub send {
 247     @_ >= 2 && @_ <= 4 or croak 'usage: $sock->send(BUF, [FLAGS, [TO]])';
 248     my $sock  = $_[0];
 249     my $flags = $_[2] || 0;
 250     my $peer  = $_[3] || $sock->peername;
 251
 252     croak 'send: Cannot determine peer address'
 253          unless($peer);
 254
 255     my $r = defined(getpeername($sock))
 256         ? send($sock, $_[1], $flags)
 257         : send($sock, $_[1], $flags, $peer);
 258
 259     # remember who we send to, if it was successful
 260     ${*$sock}{'io_socket_peername'} = $peer
 261         if(@_ == 4 && defined $r);
 262
 263     $r;
 264 }
 265
 266 sub recv {
 267     @_ == 3 || @_ == 4 or croak 'usage: $sock->recv(BUF, LEN [, FLAGS])';
 268     my $sock  = $_[0];
 269     my $len   = $_[2];
 270     my $flags = $_[3] || 0;
 271
 272     # remember who we recv'd from
 273     ${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags);
 274 }
 275
 276 sub shutdown {
 277     @_ == 2 or croak 'usage: $sock->shutdown(HOW)';
 278     my($sock, $how) = @_;
 279     ${*$sock}{'io_socket_peername'} = undef;
 280     shutdown($sock, $how);
 281 }
 282
 283 sub setsockopt {
 284     @_ == 4 or croak '$sock->setsockopt(LEVEL, OPTNAME, OPTVAL)';
 285     setsockopt($_[0],$_[1],$_[2],$_[3]);
 286 }
 287
 288 my $intsize = length(pack("i",0));
 289
 290 sub getsockopt {
 291     @_ == 3 or croak '$sock->getsockopt(LEVEL, OPTNAME)';
 292     my $r = getsockopt($_[0],$_[1],$_[2]);
 293     # Just a guess
 294     $r = unpack("i", $r)
 295         if(defined $r && length($r) == $intsize);
 296     $r;
 297 }
 298
 299 sub sockopt {
 300     my $sock = shift;
 301     @_ == 1 ? $sock->getsockopt(SOL_SOCKET,@_)
 302             : $sock->setsockopt(SOL_SOCKET,@_);
 303 }
 304
 305 sub atmark {
 306     @_ == 1 or croak 'usage: $sock->atmark()';
 307     my($sock) = @_;
 308     sockatmark($sock);
 309 }
 310
 311 sub timeout {
 312     @_ == 1 || @_ == 2 or croak 'usage: $sock->timeout([VALUE])';
 313     my($sock,$val) = @_;
 314     my $r = ${*$sock}{'io_socket_timeout'};
 315
 316     ${*$sock}{'io_socket_timeout'} = defined $val ? 0 + $val : $val
 317         if(@_ == 2);
 318
 319     $r;
 320 }
 321
 322 sub sockdomain {
 323     @_ == 1 or croak 'usage: $sock->sockdomain()';
 324     my $sock = shift;
 325     ${*$sock}{'io_socket_domain'};
 326 }
 327
 328 sub socktype {
 329     @_ == 1 or croak 'usage: $sock->socktype()';
 330     my $sock = shift;
 331     ${*$sock}{'io_socket_type'}
 332 }
 333
 334 sub protocol {
 335     @_ == 1 or croak 'usage: $sock->protocol()';
 336     my($sock) = @_;
 337     ${*$sock}{'io_socket_proto'};
 338 }
 339
 340 1;
 341
 342 __END__
 343
 344 =head1 NAME
 345
 346 IO::Socket - Object interface to socket communications
 347
 348 =head1 SYNOPSIS
 349
 350     use IO::Socket;
 351
 352 =head1 DESCRIPTION
 353
 354 C<IO::Socket> provides an object interface to creating and using sockets. It
 355 is built upon the L<IO::Handle> interface and inherits all the methods defined
 356 by L<IO::Handle>.
 357
 358 C<IO::Socket> only defines methods for those operations which are common to all
 359 types of socket. Operations which are specified to a socket in a particular
 360 domain have methods defined in sub classes of C<IO::Socket>
 361
 362 C<IO::Socket> will export all functions (and constants) defined by L<Socket>.
 363
 364 =head1 CONSTRUCTOR
 365
 366 =over 4
 367
 368 =item new ( [ARGS] )
 369
 370 Creates an C<IO::Socket>, which is a reference to a
 371 newly created symbol (see the C<Symbol> package). C<new>
 372 optionally takes arguments, these arguments are in key-value pairs.
 373 C<new> only looks for one key C<Domain> which tells new which domain
 374 the socket will be in. All other arguments will be passed to the
 375 configuration method of the package for that domain, See below.
 376
 377  NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
 378
 379 As of VERSION 1.18 all IO::Socket objects have autoflush turned on
 380 by default. This was not the case with earlier releases.
 381
 382  NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
 383
 384 =back
 385
 386 =head1 METHODS
 387
 388 See L<perlfunc> for complete descriptions of each of the following
 389 supported C<IO::Socket> methods, which are just front ends for the
 390 corresponding built-in functions:
 391
 392     socket
 393     socketpair
 394     bind
 395     listen
 396     accept
 397     send
 398     recv
 399     peername (getpeername)
 400     sockname (getsockname)
 401     shutdown
 402
 403 Some methods take slightly different arguments to those defined in L<perlfunc>
 404 in attempt to make the interface more flexible. These are
 405
 406 =over 4
 407
 408 =item accept([PKG])
 409
 410 perform the system call C<accept> on the socket and return a new
 411 object. The new object will be created in the same class as the listen
 412 socket, unless C<PKG> is specified. This object can be used to
 413 communicate with the client that was trying to connect.
 414
 415 In a scalar context the new socket is returned, or undef upon
 416 failure. In a list context a two-element array is returned containing
 417 the new socket and the peer address; the list will be empty upon
 418 failure.
 419
 420 The timeout in the [PKG] can be specified as zero to effect a "poll",
 421 but you shouldn't do that because a new IO::Select object will be
 422 created behind the scenes just to do the single poll.  This is
 423 horrendously inefficient.  Use rather true select() with a zero
 424 timeout on the handle, or non-blocking IO.
 425
 426 =item socketpair(DOMAIN, TYPE, PROTOCOL)
 427
 428 Call C<socketpair> and return a list of two sockets created, or an
 429 empty list on failure.
 430
 431 =back
 432
 433 Additional methods that are provided are:
 434
 435 =over 4
 436
 437 =item atmark
 438
 439 True if the socket is currently positioned at the urgent data mark,
 440 false otherwise.
 441
 442     use IO::Socket;
 443
 444     my $sock = IO::Socket::INET->new('some_server');
 445     $sock->read($data, 1024) until $sock->atmark;
 446
 447 Note: this is a reasonably new addition to the family of socket
 448 functions, so all systems may not support this yet.  If it is
 449 unsupported by the system, an attempt to use this method will
 450 abort the program.
 451
 452 The atmark() functionality is also exportable as sockatmark() function:
 453
 454         use IO::Socket 'sockatmark';
 455
 456 This allows for a more traditional use of sockatmark() as a procedural
 457 socket function.  If your system does not support sockatmark(), the
 458 C<use> declaration will fail at compile time.
 459
 460 =item connected
 461
 462 If the socket is in a connected state the peer address is returned.
 463 If the socket is not in a connected state then undef will be returned.
 464
 465 =item protocol
 466
 467 Returns the numerical number for the protocol being used on the socket, if
 468 known. If the protocol is unknown, as with an AF_UNIX socket, zero
 469 is returned.
 470
 471 =item sockdomain
 472
 473 Returns the numerical number for the socket domain type. For example, for
 474 an AF_INET socket the value of &AF_INET will be returned.
 475
 476 =item sockopt(OPT [, VAL])
 477
 478 Unified method to both set and get options in the SOL_SOCKET level. If called
 479 with one argument then getsockopt is called, otherwise setsockopt is called.
 480
 481 =item socktype
 482
 483 Returns the numerical number for the socket type. For example, for
 484 a SOCK_STREAM socket the value of &SOCK_STREAM will be returned.
 485
 486 =item timeout([VAL])
 487
 488 Set or get the timeout value associated with this socket. If called without
 489 any arguments then the current setting is returned. If called with an argument
 490 the current setting is changed and the previous value returned.
 491
 492 =back
 493
 494 =head1 SEE ALSO
 495
 496 L<Socket>, L<IO::Handle>, L<IO::Socket::INET>, L<IO::Socket::UNIX>
 497
 498 =head1 AUTHOR
 499
 500 Graham Barr.  atmark() by Lincoln Stein.  Currently maintained by the
 501 Perl Porters.  Please report all bugs to <perl5-porters@perl.org>.
 502
 503 =head1 COPYRIGHT
 504
 505 Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
 506 This program is free software; you can redistribute it and/or
 507 modify it under the same terms as Perl itself.
 508
 509 The atmark() implementation: Copyright 2001, Lincoln Stein <lstein@cshl.org>.
 510 This module is distributed under the same terms as Perl itself.
 511 Feel free to use, modify and redistribute it as long as you retain
 512 the correct attribution.
 513
 514 =cut