This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Save the spot of regprev (see #9911) for binary compatibility;
[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
63a347c7 9require v5.6;
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;
3a2f06e9 22require IO::Socket::UNIX if ($^O ne 'epoc');
cf7fe8a2 23
8add82fc
PP
24@ISA = qw(IO::Handle);
25
63a347c7
JH
26$VERSION = "1.27";
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
BL
111 my $blocking;
112 $blocking = $sock->blocking(0) if $timeout;
cf7fe8a2 113
c9fcc6c4 114 if (!connect($sock, $addr)) {
af663859 115 if ($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 }
f9c1db8d 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 }
c9fcc6c4
GS
131 else {
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
c9fcc6c4
GS
171 if($timeout) {
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
PP
221
222 # remember who we send to, if it was sucessful
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) = @_;
276 my $r = ${*$sock}{'io_socket_timeout'} || undef;
8add82fc 277
cf7fe8a2 278 ${*$sock}{'io_socket_timeout'} = 0 + $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
cf7fe8a2
GS
372perform the system call C<accept> on the socket and return a new object. The
373new object will be created in the same class as the listen socket, unless
374C<PKG> is specified. This object can be used to communicate with the client
375that was trying to connect. In a scalar context the new socket is returned,
91e74348 376or undef upon failure. In a list context a two-element array is returned
c4be5b27 377containing the new socket and the peer address; the list will
cf7fe8a2 378be empty upon failure.
8add82fc 379
c4be5b27 380=item socketpair(DOMAIN, TYPE, PROTOCOL)
381
382Call C<socketpair> and return a list of two sockets created, or an
383empty list on failure.
384
385=back
386
387Additional methods that are provided are:
388
389=over 4
8add82fc 390
63a347c7 391=item atmark
8add82fc 392
63a347c7
JH
393True if the socket is currently positioned at the urgent data mark,
394false otherwise.
8add82fc 395
63a347c7 396 use IO::Socket;
27d4819a 397
63a347c7
JH
398 my $sock = IO::Socket::INET->new('some_server');
399 $sock->read(1024,$data) until $sock->atmark;
8add82fc 400
63a347c7
JH
401Note: this is a reasonably new addition to the family of socket
402functions, so all systems may not support this yet. If it is
403unsupported by the system, an attempt to use this method will
404abort the program.
8add82fc 405
63a347c7 406The atmark() functionality is also exportable as sockatmark() function:
8add82fc 407
63a347c7 408 use IO::Socket 'sockatmark';
8add82fc 409
63a347c7
JH
410This allows for a more traditional use of sockatmark() as a procedural
411socket function.
412
413=item connected
414
415If the socket is in a connected state the the peer address is returned.
416If the socket is not in a connected state then undef will be returned.
27d4819a 417
cf7fe8a2 418=item protocol
8add82fc 419
cf7fe8a2
GS
420Returns the numerical number for the protocol being used on the socket, if
421known. If the protocol is unknown, as with an AF_UNIX socket, zero
422is returned.
8add82fc 423
63a347c7 424=item sockdomain
8add82fc 425
63a347c7
JH
426Returns the numerical number for the socket domain type. For example, for
427a AF_INET socket the value of &AF_INET will be returned.
428
429=item sockopt(OPT [, VAL])
430
431Unified method to both set and get options in the SOL_SOCKET level. If called
432with one argument then getsockopt is called, otherwise setsockopt is called.
433
434=item socktype
435
436Returns the numerical number for the socket type. For example, for
437a SOCK_STREAM socket the value of &SOCK_STREAM will be returned.
438
439=item timeout([VAL])
440
441Set or get the timeout value associated with this socket. If called without
442any arguments then the current setting is returned. If called with an argument
443the current setting is changed and the previous value returned.
27d4819a
JM
444
445=back
8add82fc 446
7a4c00b4 447=head1 SEE ALSO
8add82fc 448
cf7fe8a2 449L<Socket>, L<IO::Handle>, L<IO::Socket::INET>, L<IO::Socket::UNIX>
8add82fc 450
7a4c00b4 451=head1 AUTHOR
8add82fc 452
63a347c7
JH
453Graham Barr. atmark() by Lincoln Stein. Currently maintained by the
454Perl Porters. Please report all bugs to <perl5-porters@perl.org>.
760ac839 455
8add82fc
PP
456=head1 COPYRIGHT
457
cf7fe8a2
GS
458Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
459This program is free software; you can redistribute it and/or
460modify it under the same terms as Perl itself.
8add82fc 461
63a347c7
JH
462The atmark() implementation: Copyright 2001, Lincoln Stein <lstein@cshl.org>.
463This module is distributed under the same terms as Perl itself.
464Feel free to use, modify and redistribute it as long as you retain
465the correct attribution.
466
8add82fc 467=cut