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