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