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