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