This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Blocking option ignored
[perl5.git] / ext / IO / lib / IO / Socket / INET.pm
1 # IO::Socket::INET.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::INET;
8
9 use strict;
10 our(@ISA, $VERSION);
11 use IO::Socket;
12 use Socket;
13 use Carp;
14 use Exporter;
15 use Errno;
16
17 @ISA = qw(IO::Socket);
18 $VERSION = "1.26";
19
20 my $EINVAL = exists(&Errno::EINVAL) ? Errno::EINVAL() : 1;
21
22 IO::Socket::INET->register_domain( AF_INET );
23
24 my %socket_type = ( tcp  => SOCK_STREAM,
25                     udp  => SOCK_DGRAM,
26                     icmp => SOCK_RAW
27                   );
28
29 sub new {
30     my $class = shift;
31     unshift(@_, "PeerAddr") if @_ == 1;
32     return $class->SUPER::new(@_);
33 }
34
35 sub _sock_info {
36   my($addr,$port,$proto) = @_;
37   my $origport = $port;
38   my @proto = ();
39   my @serv = ();
40
41   $port = $1
42         if(defined $addr && $addr =~ s,:([\w\(\)/]+)$,,);
43
44   if(defined $proto  && $proto =~ /\D/) {
45     if(@proto = getprotobyname($proto)) {
46       $proto = $proto[2] || undef;
47     }
48     else {
49       $@ = "Bad protocol '$proto'";
50       return;
51     }
52   }
53
54   if(defined $port) {
55     my $defport = ($port =~ s,\((\d+)\)$,,) ? $1 : undef;
56     my $pnum = ($port =~ m,^(\d+)$,)[0];
57
58     @serv = getservbyname($port, $proto[0] || "")
59         if ($port =~ m,\D,);
60
61     $port = $serv[2] || $defport || $pnum;
62     unless (defined $port) {
63         $@ = "Bad service '$origport'";
64         return;
65     }
66
67     $proto = (getprotobyname($serv[3]))[2] || undef
68         if @serv && !$proto;
69   }
70
71  return ($addr || undef,
72          $port || undef,
73          $proto || undef
74         );
75 }
76
77 sub _error {
78     my $sock = shift;
79     my $err = shift;
80     {
81       local($!);
82       my $title = ref($sock).": ";
83       $@ = join("", $_[0] =~ /^$title/ ? "" : $title, @_);
84       close($sock)
85         if(defined fileno($sock));
86     }
87     $! = $err;
88     return undef;
89 }
90
91 sub _get_addr {
92     my($sock,$addr_str, $multi) = @_;
93     my @addr;
94     if ($multi && $addr_str !~ /^\d+(?:\.\d+){3}$/) {
95         (undef, undef, undef, undef, @addr) = gethostbyname($addr_str);
96     } else {
97         my $h = inet_aton($addr_str);
98         push(@addr, $h) if defined $h;
99     }
100     @addr;
101 }
102
103 sub configure {
104     my($sock,$arg) = @_;
105     my($lport,$rport,$laddr,$raddr,$proto,$type);
106
107
108     $arg->{LocalAddr} = $arg->{LocalHost}
109         if exists $arg->{LocalHost} && !exists $arg->{LocalAddr};
110
111     ($laddr,$lport,$proto) = _sock_info($arg->{LocalAddr},
112                                         $arg->{LocalPort},
113                                         $arg->{Proto})
114                         or return _error($sock, $!, $@);
115
116     $laddr = defined $laddr ? inet_aton($laddr)
117                             : INADDR_ANY;
118
119     return _error($sock, $EINVAL, "Bad hostname '",$arg->{LocalAddr},"'")
120         unless(defined $laddr);
121
122     $arg->{PeerAddr} = $arg->{PeerHost}
123         if exists $arg->{PeerHost} && !exists $arg->{PeerAddr};
124
125     unless(exists $arg->{Listen}) {
126         ($raddr,$rport,$proto) = _sock_info($arg->{PeerAddr},
127                                             $arg->{PeerPort},
128                                             $proto)
129                         or return _error($sock, $!, $@);
130     }
131
132     $proto ||= (getprotobyname('tcp'))[2];
133
134     my $pname = (getprotobynumber($proto))[0];
135     $type = $arg->{Type} || $socket_type{$pname};
136
137     my @raddr = ();
138
139     if(defined $raddr) {
140         @raddr = $sock->_get_addr($raddr, $arg->{MultiHomed});
141         return _error($sock, $EINVAL, "Bad hostname '",$arg->{PeerAddr},"'")
142             unless @raddr;
143     }
144
145     while(1) {
146
147         $sock->socket(AF_INET, $type, $proto) or
148             return _error($sock, $!, "$!");
149
150         if (defined $arg->{Blocking}) {
151             defined $sock->blocking($arg->{Blocking})
152                 or return _error($sock, $!, "$!");
153         }
154
155         if ($arg->{Reuse} || $arg->{ReuseAddr}) {
156             $sock->sockopt(SO_REUSEADDR,1) or
157                     return _error($sock, $!, "$!");
158         }
159
160         if ($arg->{ReusePort}) {
161             $sock->sockopt(SO_REUSEPORT,1) or
162                     return _error($sock, $!, "$!");
163         }
164
165         if ($arg->{Broadcast}) {
166                 $sock->sockopt(SO_BROADCAST,1) or
167                     return _error($sock, $!, "$!");
168         }
169
170         if($lport || ($laddr ne INADDR_ANY) || exists $arg->{Listen}) {
171             $sock->bind($lport || 0, $laddr) or
172                     return _error($sock, $!, "$!");
173         }
174
175         if(exists $arg->{Listen}) {
176             $sock->listen($arg->{Listen} || 5) or
177                 return _error($sock, $!, "$!");
178             last;
179         }
180
181         # don't try to connect unless we're given a PeerAddr
182         last unless exists($arg->{PeerAddr});
183  
184         $raddr = shift @raddr;
185
186         return _error($sock, $EINVAL, 'Cannot determine remote port')
187                 unless($rport || $type == SOCK_DGRAM || $type == SOCK_RAW);
188
189         last
190             unless($type == SOCK_STREAM || defined $raddr);
191
192         return _error($sock, $EINVAL, "Bad hostname '",$arg->{PeerAddr},"'")
193             unless defined $raddr;
194
195 #        my $timeout = ${*$sock}{'io_socket_timeout'};
196 #        my $before = time() if $timeout;
197
198         undef $@;
199         if ($sock->connect(pack_sockaddr_in($rport, $raddr))) {
200 #            ${*$sock}{'io_socket_timeout'} = $timeout;
201             return $sock;
202         }
203
204         return _error($sock, $!, $@ || "Timeout")
205             unless @raddr;
206
207 #       if ($timeout) {
208 #           my $new_timeout = $timeout - (time() - $before);
209 #           return _error($sock,
210 #                         (exists(&Errno::ETIMEDOUT) ? Errno::ETIMEDOUT() : $EINVAL),
211 #                         "Timeout") if $new_timeout <= 0;
212 #           ${*$sock}{'io_socket_timeout'} = $new_timeout;
213 #        }
214
215     }
216
217     $sock;
218 }
219
220 sub connect {
221     @_ == 2 || @_ == 3 or
222        croak 'usage: $sock->connect(NAME) or $sock->connect(PORT, ADDR)';
223     my $sock = shift;
224     return $sock->SUPER::connect(@_ == 1 ? shift : pack_sockaddr_in(@_));
225 }
226
227 sub bind {
228     @_ == 2 || @_ == 3 or
229        croak 'usage: $sock->bind(NAME) or $sock->bind(PORT, ADDR)';
230     my $sock = shift;
231     return $sock->SUPER::bind(@_ == 1 ? shift : pack_sockaddr_in(@_))
232 }
233
234 sub sockaddr {
235     @_ == 1 or croak 'usage: $sock->sockaddr()';
236     my($sock) = @_;
237     my $name = $sock->sockname;
238     $name ? (sockaddr_in($name))[1] : undef;
239 }
240
241 sub sockport {
242     @_ == 1 or croak 'usage: $sock->sockport()';
243     my($sock) = @_;
244     my $name = $sock->sockname;
245     $name ? (sockaddr_in($name))[0] : undef;
246 }
247
248 sub sockhost {
249     @_ == 1 or croak 'usage: $sock->sockhost()';
250     my($sock) = @_;
251     my $addr = $sock->sockaddr;
252     $addr ? inet_ntoa($addr) : undef;
253 }
254
255 sub peeraddr {
256     @_ == 1 or croak 'usage: $sock->peeraddr()';
257     my($sock) = @_;
258     my $name = $sock->peername;
259     $name ? (sockaddr_in($name))[1] : undef;
260 }
261
262 sub peerport {
263     @_ == 1 or croak 'usage: $sock->peerport()';
264     my($sock) = @_;
265     my $name = $sock->peername;
266     $name ? (sockaddr_in($name))[0] : undef;
267 }
268
269 sub peerhost {
270     @_ == 1 or croak 'usage: $sock->peerhost()';
271     my($sock) = @_;
272     my $addr = $sock->peeraddr;
273     $addr ? inet_ntoa($addr) : undef;
274 }
275
276 1;
277
278 __END__
279
280 =head1 NAME
281
282 IO::Socket::INET - Object interface for AF_INET domain sockets
283
284 =head1 SYNOPSIS
285
286     use IO::Socket::INET;
287
288 =head1 DESCRIPTION
289
290 C<IO::Socket::INET> provides an object interface to creating and using sockets
291 in the AF_INET domain. It is built upon the L<IO::Socket> interface and
292 inherits all the methods defined by L<IO::Socket>.
293
294 =head1 CONSTRUCTOR
295
296 =over 4
297
298 =item new ( [ARGS] )
299
300 Creates an C<IO::Socket::INET> object, which is a reference to a
301 newly created symbol (see the C<Symbol> package). C<new>
302 optionally takes arguments, these arguments are in key-value pairs.
303
304 In addition to the key-value pairs accepted by L<IO::Socket>,
305 C<IO::Socket::INET> provides.
306
307
308     PeerAddr    Remote host address          <hostname>[:<port>]
309     PeerHost    Synonym for PeerAddr
310     PeerPort    Remote port or service       <service>[(<no>)] | <no>
311     LocalAddr   Local host bind address      hostname[:port]
312     LocalHost   Synonym for LocalAddr
313     LocalPort   Local host bind port         <service>[(<no>)] | <no>
314     Proto       Protocol name (or number)    "tcp" | "udp" | ...
315     Type        Socket type                  SOCK_STREAM | SOCK_DGRAM | ...
316     Listen      Queue size for listen
317     ReuseAddr   Set SO_REUSEADDR before binding
318     Reuse       Set SO_REUSEADDR before binding (deprecated, prefer ReuseAddr)
319     ReusePort   Set SO_REUSEPORT before binding
320     Broadcast   Set SO_BROADCAST before binding
321     Timeout     Timeout value for various operations
322     MultiHomed  Try all adresses for multi-homed hosts
323     Blocking    Determine if connection will be blocking mode
324
325 If C<Listen> is defined then a listen socket is created, else if the
326 socket type, which is derived from the protocol, is SOCK_STREAM then
327 connect() is called.
328
329 Although it is not illegal, the use of C<MultiHomed> on a socket
330 which is in non-blocking mode is of little use. This is because the
331 first connect will never fail with a timeout as the connect call
332 will not block.
333
334 The C<PeerAddr> can be a hostname or the IP-address on the
335 "xx.xx.xx.xx" form.  The C<PeerPort> can be a number or a symbolic
336 service name.  The service name might be followed by a number in
337 parenthesis which is used if the service is not known by the system.
338 The C<PeerPort> specification can also be embedded in the C<PeerAddr>
339 by preceding it with a ":".
340
341 If C<Proto> is not given and you specify a symbolic C<PeerPort> port,
342 then the constructor will try to derive C<Proto> from the service
343 name.  As a last resort C<Proto> "tcp" is assumed.  The C<Type>
344 parameter will be deduced from C<Proto> if not specified.
345
346 If the constructor is only passed a single argument, it is assumed to
347 be a C<PeerAddr> specification.
348
349 If C<Blocking> is set to 0, the connection will be in nonblocking mode.
350 If not specified it defaults to 1 (blocking mode).
351
352 Examples:
353
354    $sock = IO::Socket::INET->new(PeerAddr => 'www.perl.org',
355                                  PeerPort => 'http(80)',
356                                  Proto    => 'tcp');
357
358    $sock = IO::Socket::INET->new(PeerAddr => 'localhost:smtp(25)');
359
360    $sock = IO::Socket::INET->new(Listen    => 5,
361                                  LocalAddr => 'localhost',
362                                  LocalPort => 9000,
363                                  Proto     => 'tcp');
364
365    $sock = IO::Socket::INET->new('127.0.0.1:25');
366
367    $sock = IO::Socket::INET->new(PeerPort  => 9999,
368                                  PeerAddr  => inet_ntoa(INADDR_BROADCAST),
369                                  Proto     => udp,    
370                                  LocalAddr => 'localhost',
371                                  Broadcast => 1 ) 
372                              or die "Can't bind : $@\n";
373
374  NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
375
376 As of VERSION 1.18 all IO::Socket objects have autoflush turned on
377 by default. This was not the case with earlier releases.
378
379  NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
380
381 =back
382
383 =head2 METHODS
384
385 =over 4
386
387 =item sockaddr ()
388
389 Return the address part of the sockaddr structure for the socket
390
391 =item sockport ()
392
393 Return the port number that the socket is using on the local host
394
395 =item sockhost ()
396
397 Return the address part of the sockaddr structure for the socket in a
398 text form xx.xx.xx.xx
399
400 =item peeraddr ()
401
402 Return the address part of the sockaddr structure for the socket on
403 the peer host
404
405 =item peerport ()
406
407 Return the port number for the socket on the peer host.
408
409 =item peerhost ()
410
411 Return the address part of the sockaddr structure for the socket on the
412 peer host in a text form xx.xx.xx.xx
413
414 =back
415
416 =head1 SEE ALSO
417
418 L<Socket>, L<IO::Socket>
419
420 =head1 AUTHOR
421
422 Graham Barr. Currently maintained by the Perl Porters.  Please report all
423 bugs to <perl5-porters@perl.org>.
424
425 =head1 COPYRIGHT
426
427 Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
428 This program is free software; you can redistribute it and/or
429 modify it under the same terms as Perl itself.
430
431 =cut