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