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