This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[rt.cpan.org #61577] propagate socket details on accept
[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
a5bed837 27$VERSION = "1.34";
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
YO
137 elsif (!connect($sock,$addr) &&
138 not ($!{EISCONN} || ($! == 10022 && $^O eq 'MSWin32'))
139 ) {
af663859
JH
140 # Some systems refuse to re-connect() to
141 # an already open socket and set errno to EISCONN.
2f78ce11 142 # Windows sets errno to WSAEINVAL (10022)
f9c1db8d
JH
143 $err = $!;
144 $@ = "connect: $!";
cf7fe8a2
GS
145 }
146 }
2f78ce11 147 elsif ($blocking || !($!{EINPROGRESS} || $!{EWOULDBLOCK})) {
c9fcc6c4
GS
148 $err = $!;
149 $@ = "connect: $!";
150 }
151 }
760ac839 152
c9fcc6c4 153 $sock->blocking(1) if $blocking;
00fdd80d 154
c9fcc6c4 155 $! = $err if $err;
00fdd80d 156
c9fcc6c4 157 $err ? undef : $sock;
8add82fc
PP
158}
159
757754a6
YO
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.
2f78ce11
YO
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 #
757754a6
YO
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
2f78ce11
YO
176 #
177 # 0x8004667e is FIONBIO
757754a6
YO
178 #
179 # which is used to set blocking behaviour.
2f78ce11 180
757754a6
YO
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.
2f78ce11 186
757754a6
YO
187 my $orig= !${*$sock}{io_sock_nonblocking};
188
189 return $orig unless @_;
2f78ce11 190
757754a6
YO
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;
2f78ce11
YO
200}
201
202
2d169392
PD
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
8add82fc 210sub bind {
cf7fe8a2
GS
211 @_ == 2 or croak 'usage: $sock->bind(NAME)';
212 my $sock = shift;
213 my $addr = shift;
8add82fc 214
cf7fe8a2
GS
215 return bind($sock, $addr) ? $sock
216 : undef;
8add82fc
PP
217}
218
219sub listen {
cf7fe8a2
GS
220 @_ >= 1 && @_ <= 2 or croak 'usage: $sock->listen([QUEUE])';
221 my($sock,$queue) = @_;
8add82fc
PP
222 $queue = 5
223 unless $queue && $queue > 0;
224
cf7fe8a2
GS
225 return listen($sock, $queue) ? $sock
226 : undef;
8add82fc
PP
227}
228
229sub accept {
cf7fe8a2
GS
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'};
8add82fc
PP
234 my $new = $pkg->new(Timeout => $timeout);
235 my $peer = undef;
236
7e92b095 237 if(defined $timeout) {
c9fcc6c4 238 require IO::Select;
cf7fe8a2 239
c9fcc6c4
GS
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;
cf7fe8a2 251
76d04ca3
TC
252 ${*$new}{$_} = ${*$sock}{$_} for qw( io_socket_domain io_socket_type io_socket_proto );
253
c9fcc6c4
GS
254 return wantarray ? ($new, $peer)
255 : $new;
8add82fc
PP
256}
257
258sub sockname {
cf7fe8a2 259 @_ == 1 or croak 'usage: $sock->sockname()';
8add82fc
PP
260 getsockname($_[0]);
261}
262
263sub peername {
cf7fe8a2
GS
264 @_ == 1 or croak 'usage: $sock->peername()';
265 my($sock) = @_;
2d169392 266 ${*$sock}{'io_socket_peername'} ||= getpeername($sock);
8add82fc
PP
267}
268
cf7fe8a2
GS
269sub connected {
270 @_ == 1 or croak 'usage: $sock->connected()';
271 my($sock) = @_;
272 getpeername($sock);
273}
274
8add82fc 275sub send {
cf7fe8a2
GS
276 @_ >= 2 && @_ <= 4 or croak 'usage: $sock->send(BUF, [FLAGS, [TO]])';
277 my $sock = $_[0];
8add82fc 278 my $flags = $_[2] || 0;
cf7fe8a2 279 my $peer = $_[3] || $sock->peername;
8add82fc
PP
280
281 croak 'send: Cannot determine peer address'
77536336 282 unless(defined $peer);
8add82fc 283
cf7fe8a2
GS
284 my $r = defined(getpeername($sock))
285 ? send($sock, $_[1], $flags)
286 : send($sock, $_[1], $flags, $peer);
8add82fc 287
a6d05634 288 # remember who we send to, if it was successful
cf7fe8a2 289 ${*$sock}{'io_socket_peername'} = $peer
8add82fc
PP
290 if(@_ == 4 && defined $r);
291
292 $r;
293}
294
295sub recv {
cf7fe8a2 296 @_ == 3 || @_ == 4 or croak 'usage: $sock->recv(BUF, LEN [, FLAGS])';
8add82fc
PP
297 my $sock = $_[0];
298 my $len = $_[2];
299 my $flags = $_[3] || 0;
300
301 # remember who we recv'd from
302 ${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags);
303}
304
cf7fe8a2
GS
305sub shutdown {
306 @_ == 2 or croak 'usage: $sock->shutdown(HOW)';
307 my($sock, $how) = @_;
2d169392 308 ${*$sock}{'io_socket_peername'} = undef;
cf7fe8a2
GS
309 shutdown($sock, $how);
310}
8add82fc
PP
311
312sub setsockopt {
f0bc0462 313 @_ == 4 or croak '$sock->setsockopt(LEVEL, OPTNAME, OPTVAL)';
8add82fc
PP
314 setsockopt($_[0],$_[1],$_[2],$_[3]);
315}
316
317my $intsize = length(pack("i",0));
318
319sub getsockopt {
cf7fe8a2 320 @_ == 3 or croak '$sock->getsockopt(LEVEL, OPTNAME)';
8add82fc
PP
321 my $r = getsockopt($_[0],$_[1],$_[2]);
322 # Just a guess
323 $r = unpack("i", $r)
324 if(defined $r && length($r) == $intsize);
325 $r;
326}
327
328sub sockopt {
cf7fe8a2
GS
329 my $sock = shift;
330 @_ == 1 ? $sock->getsockopt(SOL_SOCKET,@_)
331 : $sock->setsockopt(SOL_SOCKET,@_);
8add82fc
PP
332}
333
63a347c7
JH
334sub atmark {
335 @_ == 1 or croak 'usage: $sock->atmark()';
336 my($sock) = @_;
337 sockatmark($sock);
338}
339
8add82fc 340sub timeout {
cf7fe8a2
GS
341 @_ == 1 || @_ == 2 or croak 'usage: $sock->timeout([VALUE])';
342 my($sock,$val) = @_;
96e47f5b 343 my $r = ${*$sock}{'io_socket_timeout'};
8add82fc 344
96e47f5b 345 ${*$sock}{'io_socket_timeout'} = defined $val ? 0 + $val : $val
8add82fc
PP
346 if(@_ == 2);
347
348 $r;
349}
350
27d4819a 351sub sockdomain {
cf7fe8a2
GS
352 @_ == 1 or croak 'usage: $sock->sockdomain()';
353 my $sock = shift;
354 ${*$sock}{'io_socket_domain'};
27d4819a
JM
355}
356
8add82fc 357sub socktype {
cf7fe8a2
GS
358 @_ == 1 or croak 'usage: $sock->socktype()';
359 my $sock = shift;
360 ${*$sock}{'io_socket_type'}
8add82fc
PP
361}
362
27d4819a 363sub protocol {
cf7fe8a2
GS
364 @_ == 1 or croak 'usage: $sock->protocol()';
365 my($sock) = @_;
8fd73a68 366 ${*$sock}{'io_socket_proto'};
27d4819a
JM
367}
368
cf7fe8a2 3691;
8add82fc 370
cf7fe8a2 371__END__
27d4819a 372
cf7fe8a2 373=head1 NAME
e713eafe 374
cf7fe8a2 375IO::Socket - Object interface to socket communications
8add82fc 376
cf7fe8a2 377=head1 SYNOPSIS
7a4c00b4 378
cf7fe8a2 379 use IO::Socket;
7a4c00b4 380
cf7fe8a2 381=head1 DESCRIPTION
7a4c00b4 382
cf7fe8a2
GS
383C<IO::Socket> provides an object interface to creating and using sockets. It
384is built upon the L<IO::Handle> interface and inherits all the methods defined
385by L<IO::Handle>.
8add82fc 386
cf7fe8a2
GS
387C<IO::Socket> only defines methods for those operations which are common to all
388types of socket. Operations which are specified to a socket in a particular
389domain have methods defined in sub classes of C<IO::Socket>
e713eafe 390
cf7fe8a2 391C<IO::Socket> will export all functions (and constants) defined by L<Socket>.
e713eafe 392
cf7fe8a2 393=head1 CONSTRUCTOR
8add82fc 394
27d4819a
JM
395=over 4
396
cf7fe8a2 397=item new ( [ARGS] )
27d4819a 398
cf7fe8a2
GS
399Creates an C<IO::Socket>, which is a reference to a
400newly created symbol (see the C<Symbol> package). C<new>
401optionally takes arguments, these arguments are in key-value pairs.
402C<new> only looks for one key C<Domain> which tells new which domain
403the socket will be in. All other arguments will be passed to the
404configuration method of the package for that domain, See below.
8add82fc 405
cf7fe8a2 406 NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
3cb6de81 407
cf7fe8a2
GS
408As of VERSION 1.18 all IO::Socket objects have autoflush turned on
409by default. This was not the case with earlier releases.
27d4819a 410
cf7fe8a2 411 NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
27d4819a
JM
412
413=back
8add82fc 414
cf7fe8a2 415=head1 METHODS
8add82fc 416
cf7fe8a2
GS
417See L<perlfunc> for complete descriptions of each of the following
418supported C<IO::Socket> methods, which are just front ends for the
419corresponding built-in functions:
8add82fc 420
cf7fe8a2
GS
421 socket
422 socketpair
423 bind
424 listen
425 accept
426 send
427 recv
428 peername (getpeername)
429 sockname (getsockname)
430 shutdown
8add82fc 431
cf7fe8a2
GS
432Some methods take slightly different arguments to those defined in L<perlfunc>
433in attempt to make the interface more flexible. These are
8add82fc 434
cf7fe8a2 435=over 4
8add82fc 436
cf7fe8a2 437=item accept([PKG])
8add82fc 438
7e92b095
JH
439perform the system call C<accept> on the socket and return a new
440object. The new object will be created in the same class as the listen
441socket, unless C<PKG> is specified. This object can be used to
442communicate with the client that was trying to connect.
443
444In a scalar context the new socket is returned, or undef upon
445failure. In a list context a two-element array is returned containing
446the new socket and the peer address; the list will be empty upon
447failure.
448
449The timeout in the [PKG] can be specified as zero to effect a "poll",
450but you shouldn't do that because a new IO::Select object will be
10eaad5c 451created behind the scenes just to do the single poll. This is
7e92b095
JH
452horrendously inefficient. Use rather true select() with a zero
453timeout on the handle, or non-blocking IO.
8add82fc 454
c4be5b27 455=item socketpair(DOMAIN, TYPE, PROTOCOL)
456
457Call C<socketpair> and return a list of two sockets created, or an
458empty list on failure.
459
460=back
461
462Additional methods that are provided are:
463
464=over 4
8add82fc 465
63a347c7 466=item atmark
8add82fc 467
63a347c7
JH
468True if the socket is currently positioned at the urgent data mark,
469false otherwise.
8add82fc 470
63a347c7 471 use IO::Socket;
27d4819a 472
63a347c7 473 my $sock = IO::Socket::INET->new('some_server');
322cad79 474 $sock->read($data, 1024) until $sock->atmark;
8add82fc 475
63a347c7
JH
476Note: this is a reasonably new addition to the family of socket
477functions, so all systems may not support this yet. If it is
478unsupported by the system, an attempt to use this method will
479abort the program.
8add82fc 480
63a347c7 481The atmark() functionality is also exportable as sockatmark() function:
8add82fc 482
63a347c7 483 use IO::Socket 'sockatmark';
8add82fc 484
63a347c7 485This allows for a more traditional use of sockatmark() as a procedural
737dd4b4
MJD
486socket function. If your system does not support sockatmark(), the
487C<use> declaration will fail at compile time.
63a347c7
JH
488
489=item connected
490
a6d05634 491If the socket is in a connected state the peer address is returned.
63a347c7 492If the socket is not in a connected state then undef will be returned.
27d4819a 493
cf7fe8a2 494=item protocol
8add82fc 495
cf7fe8a2
GS
496Returns the numerical number for the protocol being used on the socket, if
497known. If the protocol is unknown, as with an AF_UNIX socket, zero
498is returned.
8add82fc 499
63a347c7 500=item sockdomain
8add82fc 501
63a347c7 502Returns the numerical number for the socket domain type. For example, for
d1be9408 503an AF_INET socket the value of &AF_INET will be returned.
63a347c7
JH
504
505=item sockopt(OPT [, VAL])
506
507Unified method to both set and get options in the SOL_SOCKET level. If called
508with one argument then getsockopt is called, otherwise setsockopt is called.
509
321499b5
SR
510=item getsockopt(LEVEL, OPT)
511
512Get option associated with the socket. Other levels than SOL_SOCKET
513may be specified here.
514
515=item setsockopt(LEVEL, OPT, VAL)
516
517Set option associated with the socket. Other levels than SOL_SOCKET
518may be specified here.
519
63a347c7
JH
520=item socktype
521
522Returns the numerical number for the socket type. For example, for
523a SOCK_STREAM socket the value of &SOCK_STREAM will be returned.
524
525=item timeout([VAL])
526
00d2151d
A
527Set or get the timeout value (in seconds) associated with this socket.
528If called without any arguments then the current setting is returned. If
529called with an argument the current setting is changed and the previous
530value returned.
27d4819a
JM
531
532=back
8add82fc 533
7a4c00b4 534=head1 SEE ALSO
8add82fc 535
cf7fe8a2 536L<Socket>, L<IO::Handle>, L<IO::Socket::INET>, L<IO::Socket::UNIX>
8add82fc 537
7a4c00b4 538=head1 AUTHOR
8add82fc 539
63a347c7 540Graham Barr. atmark() by Lincoln Stein. Currently maintained by the
9f7d1e40 541Perl Porters. Please report all bugs to <perlbug@perl.org>.
760ac839 542
8add82fc
PP
543=head1 COPYRIGHT
544
cf7fe8a2
GS
545Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
546This program is free software; you can redistribute it and/or
547modify it under the same terms as Perl itself.
8add82fc 548
63a347c7
JH
549The atmark() implementation: Copyright 2001, Lincoln Stein <lstein@cshl.org>.
550This module is distributed under the same terms as Perl itself.
551Feel free to use, modify and redistribute it as long as you retain
552the correct attribution.
553
8add82fc 554=cut