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 v5.6;
  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     $blocking = $sock->blocking(0) if $timeout;
 113
 114     if (!connect($sock, $addr)) {
 115         if ($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         else {
 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($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 sucessful
 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 object. The
 373 new object will be created in the same class as the listen socket, unless
 374 C<PKG> is specified. This object can be used to communicate with the client
 375 that was trying to connect. In a scalar context the new socket is returned,
 376 or undef upon failure. In a list context a two-element array is returned
 377 containing the new socket and the peer address; the list will
 378 be empty upon failure.
 379
 380 =item socketpair(DOMAIN, TYPE, PROTOCOL)
 381
 382 Call C<socketpair> and return a list of two sockets created, or an
 383 empty list on failure.
 384
 385 =back
 386
 387 Additional methods that are provided are:
 388
 389 =over 4
 390
 391 =item atmark
 392
 393 True if the socket is currently positioned at the urgent data mark,
 394 false otherwise.
 395
 396     use IO::Socket;
 397
 398     my $sock = IO::Socket::INET->new('some_server');
 399     $sock->read(1024,$data) until $sock->atmark;
 400
 401 Note: this is a reasonably new addition to the family of socket
 402 functions, so all systems may not support this yet.  If it is
 403 unsupported by the system, an attempt to use this method will
 404 abort the program.
 405
 406 The atmark() functionality is also exportable as sockatmark() function:
 407
 408         use IO::Socket 'sockatmark';
 409
 410 This allows for a more traditional use of sockatmark() as a procedural
 411 socket function.
 412
 413 =item connected
 414
 415 If the socket is in a connected state the the peer address is returned.
 416 If the socket is not in a connected state then undef will be returned.
 417
 418 =item protocol
 419
 420 Returns the numerical number for the protocol being used on the socket, if
 421 known. If the protocol is unknown, as with an AF_UNIX socket, zero
 422 is returned.
 423
 424 =item sockdomain
 425
 426 Returns the numerical number for the socket domain type. For example, for
 427 a AF_INET socket the value of &AF_INET will be returned.
 428
 429 =item sockopt(OPT [, VAL])
 430
 431 Unified method to both set and get options in the SOL_SOCKET level. If called
 432 with one argument then getsockopt is called, otherwise setsockopt is called.
 433
 434 =item socktype
 435
 436 Returns the numerical number for the socket type. For example, for
 437 a SOCK_STREAM socket the value of &SOCK_STREAM will be returned.
 438
 439 =item timeout([VAL])
 440
 441 Set or get the timeout value associated with this socket. If called without
 442 any arguments then the current setting is returned. If called with an argument
 443 the current setting is changed and the previous value returned.
 444
 445 =back
 446
 447 =head1 SEE ALSO
 448
 449 L<Socket>, L<IO::Handle>, L<IO::Socket::INET>, L<IO::Socket::UNIX>
 450
 451 =head1 AUTHOR
 452
 453 Graham Barr.  atmark() by Lincoln Stein.  Currently maintained by the
 454 Perl Porters.  Please report all bugs to <perl5-porters@perl.org>.
 455
 456 =head1 COPYRIGHT
 457
 458 Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
 459 This program is free software; you can redistribute it and/or
 460 modify it under the same terms as Perl itself.
 461
 462 The atmark() implementation: Copyright 2001, Lincoln Stein <lstein@cshl.org>.
 463 This module is distributed under the same terms as Perl itself.
 464 Feel free to use, modify and redistribute it as long as you retain
 465 the correct attribution.
 466
 467 =cut