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