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