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