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.005_64;
  10
  11 use IO::Handle;
  12 use Socket 1.3;
  13 use Carp;
  14 use strict;
  15 our(@ISA, $VERSION);
  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.26";
  27
  28 sub import {
  29     my $pkg = shift;
  30     my $callpkg = caller;
  31     Exporter::export 'Socket', $callpkg, @_;
  32 }
  33
  34 sub new {
  35     my($class,%arg) = @_;
  36     my $sock = $class->SUPER::new();
  37
  38     $sock->autoflush(1);
  39
  40     ${*$sock}{'io_socket_timeout'} = delete $arg{Timeout};
  41
  42     return scalar(%arg) ? $sock->configure(\%arg)
  43                         : $sock;
  44 }
  45
  46 my @domain2pkg;
  47
  48 sub register_domain {
  49     my($p,$d) = @_;
  50     $domain2pkg[$d] = $p;
  51 }
  52
  53 sub configure {
  54     my($sock,$arg) = @_;
  55     my $domain = delete $arg->{Domain};
  56
  57     croak 'IO::Socket: Cannot configure a generic socket'
  58         unless defined $domain;
  59
  60     croak "IO::Socket: Unsupported socket domain"
  61         unless defined $domain2pkg[$domain];
  62
  63     croak "IO::Socket: Cannot configure socket in domain '$domain'"
  64         unless ref($sock) eq "IO::Socket";
  65
  66     bless($sock, $domain2pkg[$domain]);
  67     $sock->configure($arg);
  68 }
  69
  70 sub socket {
  71     @_ == 4 or croak 'usage: $sock->socket(DOMAIN, TYPE, PROTOCOL)';
  72     my($sock,$domain,$type,$protocol) = @_;
  73
  74     socket($sock,$domain,$type,$protocol) or
  75         return undef;
  76
  77     ${*$sock}{'io_socket_domain'} = $domain;
  78     ${*$sock}{'io_socket_type'}   = $type;
  79     ${*$sock}{'io_socket_proto'}  = $protocol;
  80
  81     $sock;
  82 }
  83
  84 sub socketpair {
  85     @_ == 4 || croak 'usage: IO::Socket->socketpair(DOMAIN, TYPE, PROTOCOL)';
  86     my($class,$domain,$type,$protocol) = @_;
  87     my $sock1 = $class->new();
  88     my $sock2 = $class->new();
  89
  90     socketpair($sock1,$sock2,$domain,$type,$protocol) or
  91         return ();
  92
  93     ${*$sock1}{'io_socket_type'}  = ${*$sock2}{'io_socket_type'}  = $type;
  94     ${*$sock1}{'io_socket_proto'} = ${*$sock2}{'io_socket_proto'} = $protocol;
  95
  96     ($sock1,$sock2);
  97 }
  98
  99 sub connect {
 100     @_ == 2 or croak 'usage: $sock->connect(NAME)';
 101     my $sock = shift;
 102     my $addr = shift;
 103     my $timeout = ${*$sock}{'io_socket_timeout'};
 104     my $err;
 105     my $blocking;
 106     $blocking = $sock->blocking(0) if $timeout;
 107
 108     if (!connect($sock, $addr)) {
 109         if ($timeout && exists(&IO::EINPROGRESS) && ($! == &IO::EINPROGRESS)) {
 110             require IO::Select;
 111
 112             my $sel = new IO::Select $sock;
 113
 114             if (!$sel->can_write($timeout)) {
 115                 $err = $! || (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1);
 116                 $@ = "connect: timeout";
 117             }
 118             elsif(!connect($sock,$addr)) {
 119                 $err = $!;
 120                 $@ = "connect: $!";
 121             }
 122         }
 123         else {
 124             $err = $!;
 125             $@ = "connect: $!";
 126         }
 127     }
 128
 129     $sock->blocking(1) if $blocking;
 130
 131     $! = $err if $err;
 132
 133     $err ? undef : $sock;
 134 }
 135
 136 sub bind {
 137     @_ == 2 or croak 'usage: $sock->bind(NAME)';
 138     my $sock = shift;
 139     my $addr = shift;
 140
 141     return bind($sock, $addr) ? $sock
 142                               : undef;
 143 }
 144
 145 sub listen {
 146     @_ >= 1 && @_ <= 2 or croak 'usage: $sock->listen([QUEUE])';
 147     my($sock,$queue) = @_;
 148     $queue = 5
 149         unless $queue && $queue > 0;
 150
 151     return listen($sock, $queue) ? $sock
 152                                  : undef;
 153 }
 154
 155 sub accept {
 156     @_ == 1 || @_ == 2 or croak 'usage $sock->accept([PKG])';
 157     my $sock = shift;
 158     my $pkg = shift || $sock;
 159     my $timeout = ${*$sock}{'io_socket_timeout'};
 160     my $new = $pkg->new(Timeout => $timeout);
 161     my $peer = undef;
 162
 163     if($timeout) {
 164         require IO::Select;
 165
 166         my $sel = new IO::Select $sock;
 167
 168         unless ($sel->can_read($timeout)) {
 169             $@ = 'accept: timeout';
 170             $! = (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1);
 171             return;
 172         }
 173     }
 174
 175     $peer = accept($new,$sock)
 176         or return;
 177
 178     return wantarray ? ($new, $peer)
 179                      : $new;
 180 }
 181
 182 sub sockname {
 183     @_ == 1 or croak 'usage: $sock->sockname()';
 184     getsockname($_[0]);
 185 }
 186
 187 sub peername {
 188     @_ == 1 or croak 'usage: $sock->peername()';
 189     my($sock) = @_;
 190     getpeername($sock)
 191       || ${*$sock}{'io_socket_peername'}
 192       || undef;
 193 }
 194
 195 sub connected {
 196     @_ == 1 or croak 'usage: $sock->connected()';
 197     my($sock) = @_;
 198     getpeername($sock);
 199 }
 200
 201 sub send {
 202     @_ >= 2 && @_ <= 4 or croak 'usage: $sock->send(BUF, [FLAGS, [TO]])';
 203     my $sock  = $_[0];
 204     my $flags = $_[2] || 0;
 205     my $peer  = $_[3] || $sock->peername;
 206
 207     croak 'send: Cannot determine peer address'
 208          unless($peer);
 209
 210     my $r = defined(getpeername($sock))
 211         ? send($sock, $_[1], $flags)
 212         : send($sock, $_[1], $flags, $peer);
 213
 214     # remember who we send to, if it was sucessful
 215     ${*$sock}{'io_socket_peername'} = $peer
 216         if(@_ == 4 && defined $r);
 217
 218     $r;
 219 }
 220
 221 sub recv {
 222     @_ == 3 || @_ == 4 or croak 'usage: $sock->recv(BUF, LEN [, FLAGS])';
 223     my $sock  = $_[0];
 224     my $len   = $_[2];
 225     my $flags = $_[3] || 0;
 226
 227     # remember who we recv'd from
 228     ${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags);
 229 }
 230
 231 sub shutdown {
 232     @_ == 2 or croak 'usage: $sock->shutdown(HOW)';
 233     my($sock, $how) = @_;
 234     shutdown($sock, $how);
 235 }
 236
 237 sub setsockopt {
 238     @_ == 4 or croak '$sock->setsockopt(LEVEL, OPTNAME)';
 239     setsockopt($_[0],$_[1],$_[2],$_[3]);
 240 }
 241
 242 my $intsize = length(pack("i",0));
 243
 244 sub getsockopt {
 245     @_ == 3 or croak '$sock->getsockopt(LEVEL, OPTNAME)';
 246     my $r = getsockopt($_[0],$_[1],$_[2]);
 247     # Just a guess
 248     $r = unpack("i", $r)
 249         if(defined $r && length($r) == $intsize);
 250     $r;
 251 }
 252
 253 sub sockopt {
 254     my $sock = shift;
 255     @_ == 1 ? $sock->getsockopt(SOL_SOCKET,@_)
 256             : $sock->setsockopt(SOL_SOCKET,@_);
 257 }
 258
 259 sub timeout {
 260     @_ == 1 || @_ == 2 or croak 'usage: $sock->timeout([VALUE])';
 261     my($sock,$val) = @_;
 262     my $r = ${*$sock}{'io_socket_timeout'} || undef;
 263
 264     ${*$sock}{'io_socket_timeout'} = 0 + $val
 265         if(@_ == 2);
 266
 267     $r;
 268 }
 269
 270 sub sockdomain {
 271     @_ == 1 or croak 'usage: $sock->sockdomain()';
 272     my $sock = shift;
 273     ${*$sock}{'io_socket_domain'};
 274 }
 275
 276 sub socktype {
 277     @_ == 1 or croak 'usage: $sock->socktype()';
 278     my $sock = shift;
 279     ${*$sock}{'io_socket_type'}
 280 }
 281
 282 sub protocol {
 283     @_ == 1 or croak 'usage: $sock->protocol()';
 284     my($sock) = @_;
 285     ${*$sock}{'io_socket_proto'};
 286 }
 287
 288 1;
 289
 290 __END__
 291
 292 =head1 NAME
 293
 294 IO::Socket - Object interface to socket communications
 295
 296 =head1 SYNOPSIS
 297
 298     use IO::Socket;
 299
 300 =head1 DESCRIPTION
 301
 302 C<IO::Socket> provides an object interface to creating and using sockets. It
 303 is built upon the L<IO::Handle> interface and inherits all the methods defined
 304 by L<IO::Handle>.
 305
 306 C<IO::Socket> only defines methods for those operations which are common to all
 307 types of socket. Operations which are specified to a socket in a particular
 308 domain have methods defined in sub classes of C<IO::Socket>
 309
 310 C<IO::Socket> will export all functions (and constants) defined by L<Socket>.
 311
 312 =head1 CONSTRUCTOR
 313
 314 =over 4
 315
 316 =item new ( [ARGS] )
 317
 318 Creates an C<IO::Socket>, which is a reference to a
 319 newly created symbol (see the C<Symbol> package). C<new>
 320 optionally takes arguments, these arguments are in key-value pairs.
 321 C<new> only looks for one key C<Domain> which tells new which domain
 322 the socket will be in. All other arguments will be passed to the
 323 configuration method of the package for that domain, See below.
 324
 325  NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
 326
 327 As of VERSION 1.18 all IO::Socket objects have autoflush turned on
 328 by default. This was not the case with earlier releases.
 329
 330  NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
 331
 332 =back
 333
 334 =head1 METHODS
 335
 336 See L<perlfunc> for complete descriptions of each of the following
 337 supported C<IO::Socket> methods, which are just front ends for the
 338 corresponding built-in functions:
 339
 340     socket
 341     socketpair
 342     bind
 343     listen
 344     accept
 345     send
 346     recv
 347     peername (getpeername)
 348     sockname (getsockname)
 349     shutdown
 350
 351 Some methods take slightly different arguments to those defined in L<perlfunc>
 352 in attempt to make the interface more flexible. These are
 353
 354 =over 4
 355
 356 =item accept([PKG])
 357
 358 perform the system call C<accept> on the socket and return a new object. The
 359 new object will be created in the same class as the listen socket, unless
 360 C<PKG> is specified. This object can be used to communicate with the client
 361 that was trying to connect. In a scalar context the new socket is returned,
 362 or undef upon failure. In an array context a two-element array is returned
 363 containing the new socket and the peer address; the list will
 364 be empty upon failure.
 365
 366 =item socketpair(DOMAIN, TYPE, PROTOCOL)
 367
 368 Call C<socketpair> and return a list of two sockets created, or an
 369 empty list on failure.
 370
 371 =back
 372
 373 Additional methods that are provided are:
 374
 375 =over 4
 376
 377 =item timeout([VAL])
 378
 379 Set or get the timeout value associated with this socket. If called without
 380 any arguments then the current setting is returned. If called with an argument
 381 the current setting is changed and the previous value returned.
 382
 383 =item sockopt(OPT [, VAL])
 384
 385 Unified method to both set and get options in the SOL_SOCKET level. If called
 386 with one argument then getsockopt is called, otherwise setsockopt is called.
 387
 388 =item sockdomain
 389
 390 Returns the numerical number for the socket domain type. For example, for
 391 a AF_INET socket the value of &AF_INET will be returned.
 392
 393 =item socktype
 394
 395 Returns the numerical number for the socket type. For example, for
 396 a SOCK_STREAM socket the value of &SOCK_STREAM will be returned.
 397
 398 =item protocol
 399
 400 Returns the numerical number for the protocol being used on the socket, if
 401 known. If the protocol is unknown, as with an AF_UNIX socket, zero
 402 is returned.
 403
 404 =item connected
 405
 406 If the socket is in a connected state the the peer address is returned.
 407 If the socket is not in a connected state then undef will be returned.
 408
 409 =back
 410
 411 =head1 SEE ALSO
 412
 413 L<Socket>, L<IO::Handle>, L<IO::Socket::INET>, L<IO::Socket::UNIX>
 414
 415 =head1 AUTHOR
 416
 417 Graham Barr. Currently maintained by the Perl Porters.  Please report all
 418 bugs to <perl5-porters@perl.org>.
 419
 420 =head1 COPYRIGHT
 421
 422 Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
 423 This program is free software; you can redistribute it and/or
 424 modify it under the same terms as Perl itself.
 425
 426 =cut