1 2# IO::Socket.pm 3# 4# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. 5# This program is free software; you can redistribute it and/or 6# modify it under the same terms as Perl itself. 7 8package IO::Socket; 9 10require 5.006; 11 12use IO::Handle; 13use Socket 1.3; 14use Carp; 15use strict; 16our(@ISA, $VERSION, @EXPORT_OK); 17use Exporter; 18use Errno; 19 20# legacy 21 22require IO::Socket::INET; 23require IO::Socket::UNIX if ($^O ne 'epoc' && $^O ne 'symbian'); 24 25@ISA = qw(IO::Handle); 26 27$VERSION = "1.34"; 28 29@EXPORT_OK = qw(sockatmark); 30 31sub import { 32 my $pkg = shift; 33 if (@_ && $_[0] eq 'sockatmark') { # not very extensible but for now, fast 34 Exporter::export_to_level('IO::Socket', 1, $pkg, 'sockatmark'); 35 } else { 36 my $callpkg = caller; 37 Exporter::export 'Socket', $callpkg, @_; 38 } 39} 40 41sub new { 42 my($class,%arg) = @_; 43 my $sock = $class->SUPER::new(); 44 45 $sock->autoflush(1); 46 47 ${*$sock}{'io_socket_timeout'} = delete $arg{Timeout}; 48 49 return scalar(%arg) ? $sock->configure(\%arg) 50 : $sock; 51} 52 53my @domain2pkg; 54 55sub register_domain { 56 my($p,$d) = @_; 57 $domain2pkg[$d] = $p; 58} 59 60sub configure { 61 my($sock,$arg) = @_; 62 my $domain = delete $arg->{Domain}; 63 64 croak 'IO::Socket: Cannot configure a generic socket' 65 unless defined $domain; 66 67 croak "IO::Socket: Unsupported socket domain" 68 unless defined $domain2pkg[$domain]; 69 70 croak "IO::Socket: Cannot configure socket in domain '$domain'" 71 unless ref($sock) eq "IO::Socket"; 72 73 bless($sock, $domain2pkg[$domain]); 74 $sock->configure($arg); 75} 76 77sub socket { 78 @_ == 4 or croak 'usage: $sock->socket(DOMAIN, TYPE, PROTOCOL)'; 79 my($sock,$domain,$type,$protocol) = @_; 80 81 socket($sock,$domain,$type,$protocol) or 82 return undef; 83 84 ${*$sock}{'io_socket_domain'} = $domain; 85 ${*$sock}{'io_socket_type'} = $type; 86 ${*$sock}{'io_socket_proto'} = $protocol; 87 88 $sock; 89} 90 91sub socketpair { 92 @_ == 4 || croak 'usage: IO::Socket->socketpair(DOMAIN, TYPE, PROTOCOL)'; 93 my($class,$domain,$type,$protocol) = @_; 94 my $sock1 = $class->new(); 95 my $sock2 = $class->new(); 96 97 socketpair($sock1,$sock2,$domain,$type,$protocol) or 98 return (); 99 100 ${*$sock1}{'io_socket_type'} = ${*$sock2}{'io_socket_type'} = $type; 101 ${*$sock1}{'io_socket_proto'} = ${*$sock2}{'io_socket_proto'} = $protocol; 102 103 ($sock1,$sock2); 104} 105 106sub connect { 107 @_ == 2 or croak 'usage: $sock->connect(NAME)'; 108 my $sock = shift; 109 my $addr = shift; 110 my $timeout = ${*$sock}{'io_socket_timeout'}; 111 my $err; 112 my $blocking; 113 114 $blocking = $sock->blocking(0) if $timeout; 115 if (!connect($sock, $addr)) { 116 if (defined $timeout && ($!{EINPROGRESS} || $!{EWOULDBLOCK})) { 117 require IO::Select; 118 119 my $sel = new IO::Select $sock; 120 121 undef $!; 122 my($r,$w,$e) = IO::Select::select(undef,$sel,$sel,$timeout); 123 if(@$e[0]) { 124 # Windows return from select after the timeout in case of 125 # WSAECONNREFUSED(10061) if exception set is not used. 126 # This behavior is different from Linux. 127 # Using the exception 128 # set we now emulate the behavior in Linux 129 # - Karthik Rajagopalan 130 $err = $sock->getsockopt(SOL_SOCKET,SO_ERROR); 131 $@ = "connect: $err"; 132 } 133 elsif(!@$w[0]) { 134 $err = $! || (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1); 135 $@ = "connect: timeout"; 136 } 137 elsif (!connect($sock,$addr) && 138 not ($!{EISCONN} || ($! == 10022 && $^O eq 'MSWin32')) 139 ) { 140 # Some systems refuse to re-connect() to 141 # an already open socket and set errno to EISCONN. 142 # Windows sets errno to WSAEINVAL (10022) 143 $err = $!; 144 $@ = "connect: $!"; 145 } 146 } 147 elsif ($blocking || !($!{EINPROGRESS} || $!{EWOULDBLOCK})) { 148 $err = $!; 149 $@ = "connect: $!"; 150 } 151 } 152 153 $sock->blocking(1) if $blocking; 154 155 $! = $err if $err; 156 157 $err ? undef : $sock; 158} 159 160# Enable/disable blocking IO on sockets. 161# Without args return the current status of blocking, 162# with args change the mode as appropriate, returning the 163# old setting, or in case of error during the mode change 164# undef. 165 166sub blocking { 167 my $sock = shift; 168 169 return $sock->SUPER::blocking(@_) 170 if $^O ne 'MSWin32'; 171 172 # Windows handles blocking differently 173 # 174 # http://groups.google.co.uk/group/perl.perl5.porters/browse_thread/thread/b4e2b1d88280ddff/630b667a66e3509f?#630b667a66e3509f 175 # http://msdn.microsoft.com/library/default.asp?url=/library/en-us/winsock/winsock/ioctlsocket_2.asp 176 # 177 # 0x8004667e is FIONBIO 178 # 179 # which is used to set blocking behaviour. 180 181 # NOTE: 182 # This is a little confusing, the perl keyword for this is 183 # 'blocking' but the OS level behaviour is 'non-blocking', probably 184 # because sockets are blocking by default. 185 # Therefore internally we have to reverse the semantics. 186 187 my $orig= !${*$sock}{io_sock_nonblocking}; 188 189 return $orig unless @_; 190 191 my $block = shift; 192 193 if ( !$block != !$orig ) { 194 ${*$sock}{io_sock_nonblocking} = $block ? 0 : 1; 195 ioctl($sock, 0x8004667e, pack("L!",${*$sock}{io_sock_nonblocking})) 196 or return undef; 197 } 198 199 return $orig; 200} 201 202 203sub close { 204 @_ == 1 or croak 'usage: $sock->close()'; 205 my $sock = shift; 206 ${*$sock}{'io_socket_peername'} = undef; 207 $sock->SUPER::close(); 208} 209 210sub bind { 211 @_ == 2 or croak 'usage: $sock->bind(NAME)'; 212 my $sock = shift; 213 my $addr = shift; 214 215 return bind($sock, $addr) ? $sock 216 : undef; 217} 218 219sub listen { 220 @_ >= 1 && @_ <= 2 or croak 'usage: $sock->listen([QUEUE])'; 221 my($sock,$queue) = @_; 222 $queue = 5 223 unless $queue && $queue > 0; 224 225 return listen($sock, $queue) ? $sock 226 : undef; 227} 228 229sub accept { 230 @_ == 1 || @_ == 2 or croak 'usage $sock->accept([PKG])'; 231 my $sock = shift; 232 my $pkg = shift || $sock; 233 my $timeout = ${*$sock}{'io_socket_timeout'}; 234 my $new = $pkg->new(Timeout => $timeout); 235 my $peer = undef; 236 237 if(defined $timeout) { 238 require IO::Select; 239 240 my $sel = new IO::Select $sock; 241 242 unless ($sel->can_read($timeout)) { 243 $@ = 'accept: timeout'; 244 $! = (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1); 245 return; 246 } 247 } 248 249 $peer = accept($new,$sock) 250 or return; 251 252 return wantarray ? ($new, $peer) 253 : $new; 254} 255 256sub sockname { 257 @_ == 1 or croak 'usage: $sock->sockname()'; 258 getsockname($_[0]); 259} 260 261sub peername { 262 @_ == 1 or croak 'usage: $sock->peername()'; 263 my($sock) = @_; 264 ${*$sock}{'io_socket_peername'} ||= getpeername($sock); 265} 266 267sub connected { 268 @_ == 1 or croak 'usage: $sock->connected()'; 269 my($sock) = @_; 270 getpeername($sock); 271} 272 273sub send { 274 @_ >= 2 && @_ <= 4 or croak 'usage: $sock->send(BUF, [FLAGS, [TO]])'; 275 my $sock = $_[0]; 276 my $flags = $_[2] || 0; 277 my $peer = $_[3] || $sock->peername; 278 279 croak 'send: Cannot determine peer address' 280 unless(defined $peer); 281 282 my $r = defined(getpeername($sock)) 283 ? send($sock, $_[1], $flags) 284 : send($sock, $_[1], $flags, $peer); 285 286 # remember who we send to, if it was successful 287 ${*$sock}{'io_socket_peername'} = $peer 288 if(@_ == 4 && defined $r); 289 290 $r; 291} 292 293sub recv { 294 @_ == 3 || @_ == 4 or croak 'usage: $sock->recv(BUF, LEN [, FLAGS])'; 295 my $sock = $_[0]; 296 my $len = $_[2]; 297 my $flags = $_[3] || 0; 298 299 # remember who we recv'd from 300 ${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags); 301} 302 303sub shutdown { 304 @_ == 2 or croak 'usage: $sock->shutdown(HOW)'; 305 my($sock, $how) = @_; 306 ${*$sock}{'io_socket_peername'} = undef; 307 shutdown($sock, $how); 308} 309 310sub setsockopt { 311 @_ == 4 or croak '$sock->setsockopt(LEVEL, OPTNAME, OPTVAL)'; 312 setsockopt($_[0],$_[1],$_[2],$_[3]); 313} 314 315my $intsize = length(pack("i",0)); 316 317sub getsockopt { 318 @_ == 3 or croak '$sock->getsockopt(LEVEL, OPTNAME)'; 319 my $r = getsockopt($_[0],$_[1],$_[2]); 320 # Just a guess 321 $r = unpack("i", $r) 322 if(defined $r && length($r) == $intsize); 323 $r; 324} 325 326sub sockopt { 327 my $sock = shift; 328 @_ == 1 ? $sock->getsockopt(SOL_SOCKET,@_) 329 : $sock->setsockopt(SOL_SOCKET,@_); 330} 331 332sub atmark { 333 @_ == 1 or croak 'usage: $sock->atmark()'; 334 my($sock) = @_; 335 sockatmark($sock); 336} 337 338sub timeout { 339 @_ == 1 || @_ == 2 or croak 'usage: $sock->timeout([VALUE])'; 340 my($sock,$val) = @_; 341 my $r = ${*$sock}{'io_socket_timeout'}; 342 343 ${*$sock}{'io_socket_timeout'} = defined $val ? 0 + $val : $val 344 if(@_ == 2); 345 346 $r; 347} 348 349sub sockdomain { 350 @_ == 1 or croak 'usage: $sock->sockdomain()'; 351 my $sock = shift; 352 ${*$sock}{'io_socket_domain'}; 353} 354 355sub socktype { 356 @_ == 1 or croak 'usage: $sock->socktype()'; 357 my $sock = shift; 358 ${*$sock}{'io_socket_type'} 359} 360 361sub protocol { 362 @_ == 1 or croak 'usage: $sock->protocol()'; 363 my($sock) = @_; 364 ${*$sock}{'io_socket_proto'}; 365} 366 3671; 368 369__END__ 370 371=head1 NAME 372 373IO::Socket - Object interface to socket communications 374 375=head1 SYNOPSIS 376 377 use IO::Socket; 378 379=head1 DESCRIPTION 380 381C<IO::Socket> provides an object interface to creating and using sockets. It 382is built upon the L<IO::Handle> interface and inherits all the methods defined 383by L<IO::Handle>. 384 385C<IO::Socket> only defines methods for those operations which are common to all 386types of socket. Operations which are specified to a socket in a particular 387domain have methods defined in sub classes of C<IO::Socket> 388 389C<IO::Socket> will export all functions (and constants) defined by L<Socket>. 390 391=head1 CONSTRUCTOR 392 393=over 4 394 395=item new ( [ARGS] ) 396 397Creates an C<IO::Socket>, which is a reference to a 398newly created symbol (see the C<Symbol> package). C<new> 399optionally takes arguments, these arguments are in key-value pairs. 400C<new> only looks for one key C<Domain> which tells new which domain 401the socket will be in. All other arguments will be passed to the 402configuration method of the package for that domain, See below. 403 404 NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE 405 406As of VERSION 1.18 all IO::Socket objects have autoflush turned on 407by default. This was not the case with earlier releases. 408 409 NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE 410 411=back 412 413=head1 METHODS 414 415See L<perlfunc> for complete descriptions of each of the following 416supported C<IO::Socket> methods, which are just front ends for the 417corresponding built-in functions: 418 419 socket 420 socketpair 421 bind 422 listen 423 accept 424 send 425 recv 426 peername (getpeername) 427 sockname (getsockname) 428 shutdown 429 430Some methods take slightly different arguments to those defined in L<perlfunc> 431in attempt to make the interface more flexible. These are 432 433=over 4 434 435=item accept([PKG]) 436 437perform the system call C<accept> on the socket and return a new 438object. The new object will be created in the same class as the listen 439socket, unless C<PKG> is specified. This object can be used to 440communicate with the client that was trying to connect. 441 442In a scalar context the new socket is returned, or undef upon 443failure. In a list context a two-element array is returned containing 444the new socket and the peer address; the list will be empty upon 445failure. 446 447The timeout in the [PKG] can be specified as zero to effect a "poll", 448but you shouldn't do that because a new IO::Select object will be 449created behind the scenes just to do the single poll. This is 450horrendously inefficient. Use rather true select() with a zero 451timeout on the handle, or non-blocking IO. 452 453=item socketpair(DOMAIN, TYPE, PROTOCOL) 454 455Call C<socketpair> and return a list of two sockets created, or an 456empty list on failure. 457 458=back 459 460Additional methods that are provided are: 461 462=over 4 463 464=item atmark 465 466True if the socket is currently positioned at the urgent data mark, 467false otherwise. 468 469 use IO::Socket; 470 471 my $sock = IO::Socket::INET->new('some_server'); 472 $sock->read($data, 1024) until $sock->atmark; 473 474Note: this is a reasonably new addition to the family of socket 475functions, so all systems may not support this yet. If it is 476unsupported by the system, an attempt to use this method will 477abort the program. 478 479The atmark() functionality is also exportable as sockatmark() function: 480 481 use IO::Socket 'sockatmark'; 482 483This allows for a more traditional use of sockatmark() as a procedural 484socket function. If your system does not support sockatmark(), the 485C<use> declaration will fail at compile time. 486 487=item connected 488 489If the socket is in a connected state the peer address is returned. 490If the socket is not in a connected state then undef will be returned. 491 492=item protocol 493 494Returns the numerical number for the protocol being used on the socket, if 495known. If the protocol is unknown, as with an AF_UNIX socket, zero 496is returned. 497 498=item sockdomain 499 500Returns the numerical number for the socket domain type. For example, for 501an AF_INET socket the value of &AF_INET will be returned. 502 503=item sockopt(OPT [, VAL]) 504 505Unified method to both set and get options in the SOL_SOCKET level. If called 506with one argument then getsockopt is called, otherwise setsockopt is called. 507 508=item getsockopt(LEVEL, OPT) 509 510Get option associated with the socket. Other levels than SOL_SOCKET 511may be specified here. 512 513=item setsockopt(LEVEL, OPT, VAL) 514 515Set option associated with the socket. Other levels than SOL_SOCKET 516may be specified here. 517 518=item socktype 519 520Returns the numerical number for the socket type. For example, for 521a SOCK_STREAM socket the value of &SOCK_STREAM will be returned. 522 523=item timeout([VAL]) 524 525Set or get the timeout value (in seconds) associated with this socket. 526If called without any arguments then the current setting is returned. If 527called with an argument the current setting is changed and the previous 528value returned. 529 530=back 531 532=head1 SEE ALSO 533 534L<Socket>, L<IO::Handle>, L<IO::Socket::INET>, L<IO::Socket::UNIX> 535 536=head1 AUTHOR 537 538Graham Barr. atmark() by Lincoln Stein. Currently maintained by the 539Perl Porters. Please report all bugs to <perlbug@perl.org>. 540 541=head1 COPYRIGHT 542 543Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. 544This program is free software; you can redistribute it and/or 545modify it under the same terms as Perl itself. 546 547The atmark() implementation: Copyright 2001, Lincoln Stein <lstein@cshl.org>. 548This module is distributed under the same terms as Perl itself. 549Feel free to use, modify and redistribute it as long as you retain 550the correct attribution. 551 552=cut 553