This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix precedence problem in IO::Socket::connect() from 80d2c56d79
[perl5.git] / dist / IO / lib / IO / Socket.pm
1
2 # IO::Socket.pm
3 #
4 # Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
5 # This program is free software; you can redistribute it and/or
6 # modify it under the same terms as Perl itself.
7
8 package IO::Socket;
9
10 require 5.006;
11
12 use IO::Handle;
13 use Socket 1.3;
14 use Carp;
15 use strict;
16 our(@ISA, $VERSION, @EXPORT_OK);
17 use Exporter;
18 use Errno;
19
20 # legacy
21
22 require IO::Socket::INET;
23 require IO::Socket::UNIX if ($^O ne 'epoc' && $^O ne 'symbian');
24
25 @ISA = qw(IO::Handle);
26
27 $VERSION = "1.37";
28
29 @EXPORT_OK = qw(sockatmark);
30
31 sub import {
32     my $pkg = shift;
33     if (@_ && $_[0] eq 'sockatmark') { # not very extensible but for now, fast
34         Exporter::export_to_level('IO::Socket', 1, $pkg, 'sockatmark');
35     } else {
36         my $callpkg = caller;
37         Exporter::export 'Socket', $callpkg, @_;
38     }
39 }
40
41 sub new {
42     my($class,%arg) = @_;
43     my $sock = $class->SUPER::new();
44
45     $sock->autoflush(1);
46
47     ${*$sock}{'io_socket_timeout'} = delete $arg{Timeout};
48
49     return scalar(%arg) ? $sock->configure(\%arg)
50                         : $sock;
51 }
52
53 my @domain2pkg;
54
55 sub register_domain {
56     my($p,$d) = @_;
57     $domain2pkg[$d] = $p;
58 }
59
60 sub configure {
61     my($sock,$arg) = @_;
62     my $domain = delete $arg->{Domain};
63
64     croak 'IO::Socket: Cannot configure a generic socket'
65         unless defined $domain;
66
67     croak "IO::Socket: Unsupported socket domain"
68         unless defined $domain2pkg[$domain];
69
70     croak "IO::Socket: Cannot configure socket in domain '$domain'"
71         unless ref($sock) eq "IO::Socket";
72
73     bless($sock, $domain2pkg[$domain]);
74     $sock->configure($arg);
75 }
76
77 sub socket {
78     @_ == 4 or croak 'usage: $sock->socket(DOMAIN, TYPE, PROTOCOL)';
79     my($sock,$domain,$type,$protocol) = @_;
80
81     socket($sock,$domain,$type,$protocol) or
82         return undef;
83
84     ${*$sock}{'io_socket_domain'} = $domain;
85     ${*$sock}{'io_socket_type'}   = $type;
86     ${*$sock}{'io_socket_proto'}  = $protocol;
87
88     $sock;
89 }
90
91 sub socketpair {
92     @_ == 4 || croak 'usage: IO::Socket->socketpair(DOMAIN, TYPE, PROTOCOL)';
93     my($class,$domain,$type,$protocol) = @_;
94     my $sock1 = $class->new();
95     my $sock2 = $class->new();
96
97     socketpair($sock1,$sock2,$domain,$type,$protocol) or
98         return ();
99
100     ${*$sock1}{'io_socket_type'}  = ${*$sock2}{'io_socket_type'}  = $type;
101     ${*$sock1}{'io_socket_proto'} = ${*$sock2}{'io_socket_proto'} = $protocol;
102
103     ($sock1,$sock2);
104 }
105
106 sub connect {
107     @_ == 2 or croak 'usage: $sock->connect(NAME)';
108     my $sock = shift;
109     my $addr = shift;
110     my $timeout = ${*$sock}{'io_socket_timeout'};
111     my $err;
112     my $blocking;
113
114     $blocking = $sock->blocking(0) if $timeout;
115     if (!connect($sock, $addr)) {
116         if (defined $timeout && ($!{EINPROGRESS} || $!{EWOULDBLOCK})) {
117             require IO::Select;
118
119             my $sel = new IO::Select $sock;
120
121             undef $!;
122             my($r,$w,$e) = IO::Select::select(undef,$sel,$sel,$timeout);
123             if(@$e[0]) {
124                 # Windows return from select after the timeout in case of
125                 # WSAECONNREFUSED(10061) if exception set is not used.
126                 # This behavior is different from Linux.
127                 # Using the exception
128                 # set we now emulate the behavior in Linux
129                 #    - Karthik Rajagopalan
130                 $err = $sock->getsockopt(SOL_SOCKET,SO_ERROR);
131                 $@ = "connect: $err";
132             }
133             elsif(!@$w[0]) {
134                 $err = $! || (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1);
135                 $@ = "connect: timeout";
136             }
137             elsif (!connect($sock,$addr) &&
138                 not ($!{EISCONN} || ($^O eq 'MSWin32' &&
139                 ($! == ($] < 5.019004) ? 10022 : Errno::EINVAL)))
140             ) {
141                 # Some systems refuse to re-connect() to
142                 # an already open socket and set errno to EISCONN.
143                 # Windows sets errno to WSAEINVAL (10022) (pre-5.19.4) or
144                 # EINVAL (22) (5.19.4 onwards).
145                 $err = $!;
146                 $@ = "connect: $!";
147             }
148         }
149         elsif ($blocking || !($!{EINPROGRESS} || $!{EWOULDBLOCK}))  {
150             $err = $!;
151             $@ = "connect: $!";
152         }
153     }
154
155     $sock->blocking(1) if $blocking;
156
157     $! = $err if $err;
158
159     $err ? undef : $sock;
160 }
161
162 # Enable/disable blocking IO on sockets.
163 # Without args return the current status of blocking,
164 # with args change the mode as appropriate, returning the
165 # old setting, or in case of error during the mode change
166 # undef.
167
168 sub blocking {
169     my $sock = shift;
170
171     return $sock->SUPER::blocking(@_)
172         if $^O ne 'MSWin32' && $^O ne 'VMS';
173
174     # Windows handles blocking differently
175     #
176     # http://groups.google.co.uk/group/perl.perl5.porters/browse_thread/thread/b4e2b1d88280ddff/630b667a66e3509f?#630b667a66e3509f
177     # http://msdn.microsoft.com/library/default.asp?url=/library/en-us/winsock/winsock/ioctlsocket_2.asp
178     #
179     # 0x8004667e is FIONBIO
180     #
181     # which is used to set blocking behaviour.
182
183     # NOTE: 
184     # This is a little confusing, the perl keyword for this is
185     # 'blocking' but the OS level behaviour is 'non-blocking', probably
186     # because sockets are blocking by default.
187     # Therefore internally we have to reverse the semantics.
188
189     my $orig= !${*$sock}{io_sock_nonblocking};
190         
191     return $orig unless @_;
192
193     my $block = shift;
194     
195     if ( !$block != !$orig ) {
196         ${*$sock}{io_sock_nonblocking} = $block ? 0 : 1;
197         ioctl($sock, 0x8004667e, pack("L!",${*$sock}{io_sock_nonblocking}))
198             or return undef;
199     }
200     
201     return $orig;        
202 }
203
204
205 sub close {
206     @_ == 1 or croak 'usage: $sock->close()';
207     my $sock = shift;
208     ${*$sock}{'io_socket_peername'} = undef;
209     $sock->SUPER::close();
210 }
211
212 sub bind {
213     @_ == 2 or croak 'usage: $sock->bind(NAME)';
214     my $sock = shift;
215     my $addr = shift;
216
217     return bind($sock, $addr) ? $sock
218                               : undef;
219 }
220
221 sub listen {
222     @_ >= 1 && @_ <= 2 or croak 'usage: $sock->listen([QUEUE])';
223     my($sock,$queue) = @_;
224     $queue = 5
225         unless $queue && $queue > 0;
226
227     return listen($sock, $queue) ? $sock
228                                  : undef;
229 }
230
231 sub accept {
232     @_ == 1 || @_ == 2 or croak 'usage $sock->accept([PKG])';
233     my $sock = shift;
234     my $pkg = shift || $sock;
235     my $timeout = ${*$sock}{'io_socket_timeout'};
236     my $new = $pkg->new(Timeout => $timeout);
237     my $peer = undef;
238
239     if(defined $timeout) {
240         require IO::Select;
241
242         my $sel = new IO::Select $sock;
243
244         unless ($sel->can_read($timeout)) {
245             $@ = 'accept: timeout';
246             $! = (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1);
247             return;
248         }
249     }
250
251     $peer = accept($new,$sock)
252         or return;
253
254     ${*$new}{$_} = ${*$sock}{$_} for qw( io_socket_domain io_socket_type io_socket_proto );
255
256     return wantarray ? ($new, $peer)
257                      : $new;
258 }
259
260 sub sockname {
261     @_ == 1 or croak 'usage: $sock->sockname()';
262     getsockname($_[0]);
263 }
264
265 sub peername {
266     @_ == 1 or croak 'usage: $sock->peername()';
267     my($sock) = @_;
268     ${*$sock}{'io_socket_peername'} ||= getpeername($sock);
269 }
270
271 sub connected {
272     @_ == 1 or croak 'usage: $sock->connected()';
273     my($sock) = @_;
274     getpeername($sock);
275 }
276
277 sub send {
278     @_ >= 2 && @_ <= 4 or croak 'usage: $sock->send(BUF, [FLAGS, [TO]])';
279     my $sock  = $_[0];
280     my $flags = $_[2] || 0;
281     my $peer  = $_[3] || $sock->peername;
282
283     croak 'send: Cannot determine peer address'
284          unless(defined $peer);
285
286     my $r = defined(getpeername($sock))
287         ? send($sock, $_[1], $flags)
288         : send($sock, $_[1], $flags, $peer);
289
290     # remember who we send to, if it was successful
291     ${*$sock}{'io_socket_peername'} = $peer
292         if(@_ == 4 && defined $r);
293
294     $r;
295 }
296
297 sub recv {
298     @_ == 3 || @_ == 4 or croak 'usage: $sock->recv(BUF, LEN [, FLAGS])';
299     my $sock  = $_[0];
300     my $len   = $_[2];
301     my $flags = $_[3] || 0;
302
303     # remember who we recv'd from
304     ${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags);
305 }
306
307 sub shutdown {
308     @_ == 2 or croak 'usage: $sock->shutdown(HOW)';
309     my($sock, $how) = @_;
310     ${*$sock}{'io_socket_peername'} = undef;
311     shutdown($sock, $how);
312 }
313
314 sub setsockopt {
315     @_ == 4 or croak '$sock->setsockopt(LEVEL, OPTNAME, OPTVAL)';
316     setsockopt($_[0],$_[1],$_[2],$_[3]);
317 }
318
319 my $intsize = length(pack("i",0));
320
321 sub getsockopt {
322     @_ == 3 or croak '$sock->getsockopt(LEVEL, OPTNAME)';
323     my $r = getsockopt($_[0],$_[1],$_[2]);
324     # Just a guess
325     $r = unpack("i", $r)
326         if(defined $r && length($r) == $intsize);
327     $r;
328 }
329
330 sub sockopt {
331     my $sock = shift;
332     @_ == 1 ? $sock->getsockopt(SOL_SOCKET,@_)
333             : $sock->setsockopt(SOL_SOCKET,@_);
334 }
335
336 sub atmark {
337     @_ == 1 or croak 'usage: $sock->atmark()';
338     my($sock) = @_;
339     sockatmark($sock);
340 }
341
342 sub timeout {
343     @_ == 1 || @_ == 2 or croak 'usage: $sock->timeout([VALUE])';
344     my($sock,$val) = @_;
345     my $r = ${*$sock}{'io_socket_timeout'};
346
347     ${*$sock}{'io_socket_timeout'} = defined $val ? 0 + $val : $val
348         if(@_ == 2);
349
350     $r;
351 }
352
353 sub sockdomain {
354     @_ == 1 or croak 'usage: $sock->sockdomain()';
355     my $sock = shift;
356     if (!defined(${*$sock}{'io_socket_domain'})) {
357         my $addr = $sock->sockname();
358         ${*$sock}{'io_socket_domain'} = sockaddr_family($addr)
359             if (defined($addr));
360     }
361     ${*$sock}{'io_socket_domain'};
362 }
363
364 sub socktype {
365     @_ == 1 or croak 'usage: $sock->socktype()';
366     my $sock = shift;
367     ${*$sock}{'io_socket_type'} = $sock->sockopt(Socket::SO_TYPE)
368         if (!defined(${*$sock}{'io_socket_type'}) && defined(eval{Socket::SO_TYPE}));
369     ${*$sock}{'io_socket_type'}
370 }
371
372 sub protocol {
373     @_ == 1 or croak 'usage: $sock->protocol()';
374     my($sock) = @_;
375     ${*$sock}{'io_socket_proto'} = $sock->sockopt(Socket::SO_PROTOCOL)
376         if (!defined(${*$sock}{'io_socket_proto'}) && defined(eval{Socket::SO_PROTOCOL}));
377     ${*$sock}{'io_socket_proto'};
378 }
379
380 1;
381
382 __END__
383
384 =head1 NAME
385
386 IO::Socket - Object interface to socket communications
387
388 =head1 SYNOPSIS
389
390     use IO::Socket;
391
392 =head1 DESCRIPTION
393
394 C<IO::Socket> provides an object interface to creating and using sockets. It
395 is built upon the L<IO::Handle> interface and inherits all the methods defined
396 by L<IO::Handle>.
397
398 C<IO::Socket> only defines methods for those operations which are common to all
399 types of socket. Operations which are specified to a socket in a particular 
400 domain have methods defined in sub classes of C<IO::Socket>
401
402 C<IO::Socket> will export all functions (and constants) defined by L<Socket>.
403
404 =head1 CONSTRUCTOR
405
406 =over 4
407
408 =item new ( [ARGS] )
409
410 Creates an C<IO::Socket>, which is a reference to a
411 newly created symbol (see the C<Symbol> package). C<new>
412 optionally takes arguments, these arguments are in key-value pairs.
413 C<new> only looks for one key C<Domain> which tells new which domain
414 the socket will be in. All other arguments will be passed to the
415 configuration method of the package for that domain, See below.
416
417  NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
418
419 As of VERSION 1.18 all IO::Socket objects have autoflush turned on
420 by default. This was not the case with earlier releases.
421
422  NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
423
424 =back
425
426 =head1 METHODS
427
428 See L<perlfunc> for complete descriptions of each of the following
429 supported C<IO::Socket> methods, which are just front ends for the
430 corresponding built-in functions:
431
432     socket
433     socketpair
434     bind
435     listen
436     accept
437     send
438     recv
439     peername (getpeername)
440     sockname (getsockname)
441     shutdown
442
443 Some methods take slightly different arguments to those defined in L<perlfunc>
444 in attempt to make the interface more flexible. These are
445
446 =over 4
447
448 =item accept([PKG])
449
450 perform the system call C<accept> on the socket and return a new
451 object. The new object will be created in the same class as the listen
452 socket, unless C<PKG> is specified. This object can be used to
453 communicate with the client that was trying to connect.
454
455 In a scalar context the new socket is returned, or undef upon
456 failure. In a list context a two-element array is returned containing
457 the new socket and the peer address; the list will be empty upon
458 failure.
459
460 The timeout in the [PKG] can be specified as zero to effect a "poll",
461 but you shouldn't do that because a new IO::Select object will be
462 created behind the scenes just to do the single poll.  This is
463 horrendously inefficient.  Use rather true select() with a zero
464 timeout on the handle, or non-blocking IO.
465
466 =item socketpair(DOMAIN, TYPE, PROTOCOL)
467
468 Call C<socketpair> and return a list of two sockets created, or an
469 empty list on failure.
470
471 =back
472
473 Additional methods that are provided are:
474
475 =over 4
476
477 =item atmark
478
479 True if the socket is currently positioned at the urgent data mark,
480 false otherwise.
481
482     use IO::Socket;
483
484     my $sock = IO::Socket::INET->new('some_server');
485     $sock->read($data, 1024) until $sock->atmark;
486
487 Note: this is a reasonably new addition to the family of socket
488 functions, so all systems may not support this yet.  If it is
489 unsupported by the system, an attempt to use this method will
490 abort the program.
491
492 The atmark() functionality is also exportable as sockatmark() function:
493
494         use IO::Socket 'sockatmark';
495
496 This allows for a more traditional use of sockatmark() as a procedural
497 socket function.  If your system does not support sockatmark(), the
498 C<use> declaration will fail at compile time.
499
500 =item connected
501
502 If the socket is in a connected state the peer address is returned.
503 If the socket is not in a connected state then undef will be returned.
504
505 =item protocol
506
507 Returns the numerical number for the protocol being used on the socket, if
508 known. If the protocol is unknown, as with an AF_UNIX socket, zero
509 is returned.
510
511 =item sockdomain
512
513 Returns the numerical number for the socket domain type. For example, for
514 an AF_INET socket the value of &AF_INET will be returned.
515
516 =item sockopt(OPT [, VAL])
517
518 Unified method to both set and get options in the SOL_SOCKET level. If called
519 with one argument then getsockopt is called, otherwise setsockopt is called.
520
521 =item getsockopt(LEVEL, OPT)
522
523 Get option associated with the socket. Other levels than SOL_SOCKET
524 may be specified here.
525
526 =item setsockopt(LEVEL, OPT, VAL)
527
528 Set option associated with the socket. Other levels than SOL_SOCKET
529 may be specified here.
530
531 =item socktype
532
533 Returns the numerical number for the socket type. For example, for
534 a SOCK_STREAM socket the value of &SOCK_STREAM will be returned.
535
536 =item timeout([VAL])
537
538 Set or get the timeout value (in seconds) associated with this socket.
539 If called without any arguments then the current setting is returned. If
540 called with an argument the current setting is changed and the previous
541 value returned.
542
543 =back
544
545 =head1 LIMITATIONS
546
547 On some systems, for an IO::Socket object created with new_from_fd(),
548 or created with accept() from such an object, the protocol(),
549 sockdomain() and socktype() methods may return undef.
550
551 =head1 SEE ALSO
552
553 L<Socket>, L<IO::Handle>, L<IO::Socket::INET>, L<IO::Socket::UNIX>
554
555 =head1 AUTHOR
556
557 Graham Barr.  atmark() by Lincoln Stein.  Currently maintained by the
558 Perl Porters.  Please report all bugs to <perlbug@perl.org>.
559
560 =head1 COPYRIGHT
561
562 Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
563 This program is free software; you can redistribute it and/or
564 modify it under the same terms as Perl itself.
565
566 The atmark() implementation: Copyright 2001, Lincoln Stein <lstein@cshl.org>.
567 This module is distributed under the same terms as Perl itself.
568 Feel free to use, modify and redistribute it as long as you retain
569 the correct attribution.
570
571 =cut