This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[rt.cpan.org #61577] try to populate socket info when not cached
[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;
dafec47d
TC
354 if (!defined(${*$sock}{'io_socket_domain'})) {
355 my $addr = $sock->sockname();
356 ${*$sock}{'io_socket_domain'} = sockaddr_family($addr)
357 if (defined($addr));
358 }
cf7fe8a2 359 ${*$sock}{'io_socket_domain'};
27d4819a
JM
360}
361
8add82fc 362sub socktype {
cf7fe8a2
GS
363 @_ == 1 or croak 'usage: $sock->socktype()';
364 my $sock = shift;
dafec47d
TC
365 ${*$sock}{'io_socket_type'} = $sock->sockopt(Socket::SO_TYPE)
366 if (!defined(${*$sock}{'io_socket_type'}) && defined(eval{Socket::SO_TYPE}));
cf7fe8a2 367 ${*$sock}{'io_socket_type'}
8add82fc
PP
368}
369
27d4819a 370sub protocol {
cf7fe8a2
GS
371 @_ == 1 or croak 'usage: $sock->protocol()';
372 my($sock) = @_;
dafec47d
TC
373 ${*$sock}{'io_socket_proto'} = $sock->sockopt(Socket::SO_PROTOCOL)
374 if (!defined(${*$sock}{'io_socket_proto'}) && defined(eval{Socket::SO_PROTOCOL}));
8fd73a68 375 ${*$sock}{'io_socket_proto'};
27d4819a
JM
376}
377
cf7fe8a2 3781;
8add82fc 379
cf7fe8a2 380__END__
27d4819a 381
cf7fe8a2 382=head1 NAME
e713eafe 383
cf7fe8a2 384IO::Socket - Object interface to socket communications
8add82fc 385
cf7fe8a2 386=head1 SYNOPSIS
7a4c00b4 387
cf7fe8a2 388 use IO::Socket;
7a4c00b4 389
cf7fe8a2 390=head1 DESCRIPTION
7a4c00b4 391
cf7fe8a2
GS
392C<IO::Socket> provides an object interface to creating and using sockets. It
393is built upon the L<IO::Handle> interface and inherits all the methods defined
394by L<IO::Handle>.
8add82fc 395
cf7fe8a2
GS
396C<IO::Socket> only defines methods for those operations which are common to all
397types of socket. Operations which are specified to a socket in a particular
398domain have methods defined in sub classes of C<IO::Socket>
e713eafe 399
cf7fe8a2 400C<IO::Socket> will export all functions (and constants) defined by L<Socket>.
e713eafe 401
cf7fe8a2 402=head1 CONSTRUCTOR
8add82fc 403
27d4819a
JM
404=over 4
405
cf7fe8a2 406=item new ( [ARGS] )
27d4819a 407
cf7fe8a2
GS
408Creates an C<IO::Socket>, which is a reference to a
409newly created symbol (see the C<Symbol> package). C<new>
410optionally takes arguments, these arguments are in key-value pairs.
411C<new> only looks for one key C<Domain> which tells new which domain
412the socket will be in. All other arguments will be passed to the
413configuration method of the package for that domain, See below.
8add82fc 414
cf7fe8a2 415 NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
3cb6de81 416
cf7fe8a2
GS
417As of VERSION 1.18 all IO::Socket objects have autoflush turned on
418by default. This was not the case with earlier releases.
27d4819a 419
cf7fe8a2 420 NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
27d4819a
JM
421
422=back
8add82fc 423
cf7fe8a2 424=head1 METHODS
8add82fc 425
cf7fe8a2
GS
426See L<perlfunc> for complete descriptions of each of the following
427supported C<IO::Socket> methods, which are just front ends for the
428corresponding built-in functions:
8add82fc 429
cf7fe8a2
GS
430 socket
431 socketpair
432 bind
433 listen
434 accept
435 send
436 recv
437 peername (getpeername)
438 sockname (getsockname)
439 shutdown
8add82fc 440
cf7fe8a2
GS
441Some methods take slightly different arguments to those defined in L<perlfunc>
442in attempt to make the interface more flexible. These are
8add82fc 443
cf7fe8a2 444=over 4
8add82fc 445
cf7fe8a2 446=item accept([PKG])
8add82fc 447
7e92b095
JH
448perform the system call C<accept> on the socket and return a new
449object. The new object will be created in the same class as the listen
450socket, unless C<PKG> is specified. This object can be used to
451communicate with the client that was trying to connect.
452
453In a scalar context the new socket is returned, or undef upon
454failure. In a list context a two-element array is returned containing
455the new socket and the peer address; the list will be empty upon
456failure.
457
458The timeout in the [PKG] can be specified as zero to effect a "poll",
459but you shouldn't do that because a new IO::Select object will be
10eaad5c 460created behind the scenes just to do the single poll. This is
7e92b095
JH
461horrendously inefficient. Use rather true select() with a zero
462timeout on the handle, or non-blocking IO.
8add82fc 463
c4be5b27 464=item socketpair(DOMAIN, TYPE, PROTOCOL)
465
466Call C<socketpair> and return a list of two sockets created, or an
467empty list on failure.
468
469=back
470
471Additional methods that are provided are:
472
473=over 4
8add82fc 474
63a347c7 475=item atmark
8add82fc 476
63a347c7
JH
477True if the socket is currently positioned at the urgent data mark,
478false otherwise.
8add82fc 479
63a347c7 480 use IO::Socket;
27d4819a 481
63a347c7 482 my $sock = IO::Socket::INET->new('some_server');
322cad79 483 $sock->read($data, 1024) until $sock->atmark;
8add82fc 484
63a347c7
JH
485Note: this is a reasonably new addition to the family of socket
486functions, so all systems may not support this yet. If it is
487unsupported by the system, an attempt to use this method will
488abort the program.
8add82fc 489
63a347c7 490The atmark() functionality is also exportable as sockatmark() function:
8add82fc 491
63a347c7 492 use IO::Socket 'sockatmark';
8add82fc 493
63a347c7 494This allows for a more traditional use of sockatmark() as a procedural
737dd4b4
MJD
495socket function. If your system does not support sockatmark(), the
496C<use> declaration will fail at compile time.
63a347c7
JH
497
498=item connected
499
a6d05634 500If the socket is in a connected state the peer address is returned.
63a347c7 501If the socket is not in a connected state then undef will be returned.
27d4819a 502
cf7fe8a2 503=item protocol
8add82fc 504
cf7fe8a2
GS
505Returns the numerical number for the protocol being used on the socket, if
506known. If the protocol is unknown, as with an AF_UNIX socket, zero
507is returned.
8add82fc 508
63a347c7 509=item sockdomain
8add82fc 510
63a347c7 511Returns the numerical number for the socket domain type. For example, for
d1be9408 512an AF_INET socket the value of &AF_INET will be returned.
63a347c7
JH
513
514=item sockopt(OPT [, VAL])
515
516Unified method to both set and get options in the SOL_SOCKET level. If called
517with one argument then getsockopt is called, otherwise setsockopt is called.
518
321499b5
SR
519=item getsockopt(LEVEL, OPT)
520
521Get option associated with the socket. Other levels than SOL_SOCKET
522may be specified here.
523
524=item setsockopt(LEVEL, OPT, VAL)
525
526Set option associated with the socket. Other levels than SOL_SOCKET
527may be specified here.
528
63a347c7
JH
529=item socktype
530
531Returns the numerical number for the socket type. For example, for
532a SOCK_STREAM socket the value of &SOCK_STREAM will be returned.
533
534=item timeout([VAL])
535
00d2151d
A
536Set or get the timeout value (in seconds) associated with this socket.
537If called without any arguments then the current setting is returned. If
538called with an argument the current setting is changed and the previous
539value returned.
27d4819a
JM
540
541=back
8add82fc 542
7a4c00b4 543=head1 SEE ALSO
8add82fc 544
cf7fe8a2 545L<Socket>, L<IO::Handle>, L<IO::Socket::INET>, L<IO::Socket::UNIX>
8add82fc 546
7a4c00b4 547=head1 AUTHOR
8add82fc 548
63a347c7 549Graham Barr. atmark() by Lincoln Stein. Currently maintained by the
9f7d1e40 550Perl Porters. Please report all bugs to <perlbug@perl.org>.
760ac839 551
8add82fc
PP
552=head1 COPYRIGHT
553
cf7fe8a2
GS
554Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
555This program is free software; you can redistribute it and/or
556modify it under the same terms as Perl itself.
8add82fc 557
63a347c7
JH
558The atmark() implementation: Copyright 2001, Lincoln Stein <lstein@cshl.org>.
559This module is distributed under the same terms as Perl itself.
560Feel free to use, modify and redistribute it as long as you retain
561the correct attribution.
562
8add82fc 563=cut