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