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