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