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