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