[Summary view] [Print] [Text view]

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