This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
f59c810bb4657dc7cc67b93ef16f11d1c695b5ce
[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     $sock->blocking($arg->{Blocking}) if defined $arg->{Blocking};
133
134     $proto ||= (getprotobyname('tcp'))[2];
135
136     my $pname = (getprotobynumber($proto))[0];
137     $type = $arg->{Type} || $socket_type{$pname};
138
139     my @raddr = ();
140
141     if(defined $raddr) {
142         @raddr = $sock->_get_addr($raddr, $arg->{MultiHomed});
143         return _error($sock, $EINVAL, "Bad hostname '",$arg->{PeerAddr},"'")
144             unless @raddr;
145     }
146
147     while(1) {
148
149         $sock->socket(AF_INET, $type, $proto) or
150             return _error($sock, $!, "$!");
151
152         if ($arg->{Reuse} || $arg->{ReuseAddr}) {
153             $sock->sockopt(SO_REUSEADDR,1) or
154                     return _error($sock, $!, "$!");
155         }
156
157         if ($arg->{ReusePort}) {
158             $sock->sockopt(SO_REUSEPORT,1) or
159                     return _error($sock, $!, "$!");
160         }
161
162         if ($arg->{Broadcast}) {
163                 $sock->sockopt(SO_BROADCAST,1) or
164                     return _error($sock, $!, "$!");
165         }
166
167         if($lport || ($laddr ne INADDR_ANY) || exists $arg->{Listen}) {
168             $sock->bind($lport || 0, $laddr) or
169                     return _error($sock, $!, "$!");
170         }
171
172         if(exists $arg->{Listen}) {
173             $sock->listen($arg->{Listen} || 5) or
174                 return _error($sock, $!, "$!");
175             last;
176         }
177
178         # don't try to connect unless we're given a PeerAddr
179         last unless exists($arg->{PeerAddr});
180  
181         $raddr = shift @raddr;
182
183         return _error($sock, $EINVAL, 'Cannot determine remote port')
184                 unless($rport || $type == SOCK_DGRAM || $type == SOCK_RAW);
185
186         last
187             unless($type == SOCK_STREAM || defined $raddr);
188
189         return _error($sock, $EINVAL, "Bad hostname '",$arg->{PeerAddr},"'")
190             unless defined $raddr;
191
192 #        my $timeout = ${*$sock}{'io_socket_timeout'};
193 #        my $before = time() if $timeout;
194
195         undef $@;
196         if ($sock->connect(pack_sockaddr_in($rport, $raddr))) {
197 #            ${*$sock}{'io_socket_timeout'} = $timeout;
198             return $sock;
199         }
200
201         return _error($sock, $!, $@ || "Timeout")
202             unless @raddr;
203
204 #       if ($timeout) {
205 #           my $new_timeout = $timeout - (time() - $before);
206 #           return _error($sock,
207 #                         (exists(&Errno::ETIMEDOUT) ? Errno::ETIMEDOUT() : $EINVAL),
208 #                         "Timeout") if $new_timeout <= 0;
209 #           ${*$sock}{'io_socket_timeout'} = $new_timeout;
210 #        }
211
212     }
213
214     $sock;
215 }
216
217 sub connect {
218     @_ == 2 || @_ == 3 or
219        croak 'usage: $sock->connect(NAME) or $sock->connect(PORT, ADDR)';
220     my $sock = shift;
221     return $sock->SUPER::connect(@_ == 1 ? shift : pack_sockaddr_in(@_));
222 }
223
224 sub bind {
225     @_ == 2 || @_ == 3 or
226        croak 'usage: $sock->bind(NAME) or $sock->bind(PORT, ADDR)';
227     my $sock = shift;
228     return $sock->SUPER::bind(@_ == 1 ? shift : pack_sockaddr_in(@_))
229 }
230
231 sub sockaddr {
232     @_ == 1 or croak 'usage: $sock->sockaddr()';
233     my($sock) = @_;
234     my $name = $sock->sockname;
235     $name ? (sockaddr_in($name))[1] : undef;
236 }
237
238 sub sockport {
239     @_ == 1 or croak 'usage: $sock->sockport()';
240     my($sock) = @_;
241     my $name = $sock->sockname;
242     $name ? (sockaddr_in($name))[0] : undef;
243 }
244
245 sub sockhost {
246     @_ == 1 or croak 'usage: $sock->sockhost()';
247     my($sock) = @_;
248     my $addr = $sock->sockaddr;
249     $addr ? inet_ntoa($addr) : undef;
250 }
251
252 sub peeraddr {
253     @_ == 1 or croak 'usage: $sock->peeraddr()';
254     my($sock) = @_;
255     my $name = $sock->peername;
256     $name ? (sockaddr_in($name))[1] : undef;
257 }
258
259 sub peerport {
260     @_ == 1 or croak 'usage: $sock->peerport()';
261     my($sock) = @_;
262     my $name = $sock->peername;
263     $name ? (sockaddr_in($name))[0] : undef;
264 }
265
266 sub peerhost {
267     @_ == 1 or croak 'usage: $sock->peerhost()';
268     my($sock) = @_;
269     my $addr = $sock->peeraddr;
270     $addr ? inet_ntoa($addr) : undef;
271 }
272
273 1;
274
275 __END__
276
277 =head1 NAME
278
279 IO::Socket::INET - Object interface for AF_INET domain sockets
280
281 =head1 SYNOPSIS
282
283     use IO::Socket::INET;
284
285 =head1 DESCRIPTION
286
287 C<IO::Socket::INET> provides an object interface to creating and using sockets
288 in the AF_INET domain. It is built upon the L<IO::Socket> interface and
289 inherits all the methods defined by L<IO::Socket>.
290
291 =head1 CONSTRUCTOR
292
293 =over 4
294
295 =item new ( [ARGS] )
296
297 Creates an C<IO::Socket::INET> object, which is a reference to a
298 newly created symbol (see the C<Symbol> package). C<new>
299 optionally takes arguments, these arguments are in key-value pairs.
300
301 In addition to the key-value pairs accepted by L<IO::Socket>,
302 C<IO::Socket::INET> provides.
303
304
305     PeerAddr    Remote host address          <hostname>[:<port>]
306     PeerHost    Synonym for PeerAddr
307     PeerPort    Remote port or service       <service>[(<no>)] | <no>
308     LocalAddr   Local host bind address      hostname[:port]
309     LocalHost   Synonym for LocalAddr
310     LocalPort   Local host bind port         <service>[(<no>)] | <no>
311     Proto       Protocol name (or number)    "tcp" | "udp" | ...
312     Type        Socket type                  SOCK_STREAM | SOCK_DGRAM | ...
313     Listen      Queue size for listen
314     ReuseAddr   Set SO_REUSEADDR before binding
315     Reuse       Set SO_REUSEADDR before binding (deprecated, prefer ReuseAddr)
316     ReusePort   Set SO_REUSEPORT before binding
317     Broadcast   Set SO_BROADCAST before binding
318     Timeout     Timeout value for various operations
319     MultiHomed  Try all adresses for multi-homed hosts
320     Blocking    Determine if connection will be blocking mode
321
322 If C<Listen> is defined then a listen socket is created, else if the
323 socket type, which is derived from the protocol, is SOCK_STREAM then
324 connect() is called.
325
326 Although it is not illegal, the use of C<MultiHomed> on a socket
327 which is in non-blocking mode is of little use. This is because the
328 first connect will never fail with a timeout as the connect call
329 will not block.
330
331 The C<PeerAddr> can be a hostname or the IP-address on the
332 "xx.xx.xx.xx" form.  The C<PeerPort> can be a number or a symbolic
333 service name.  The service name might be followed by a number in
334 parenthesis which is used if the service is not known by the system.
335 The C<PeerPort> specification can also be embedded in the C<PeerAddr>
336 by preceding it with a ":".
337
338 If C<Proto> is not given and you specify a symbolic C<PeerPort> port,
339 then the constructor will try to derive C<Proto> from the service
340 name.  As a last resort C<Proto> "tcp" is assumed.  The C<Type>
341 parameter will be deduced from C<Proto> if not specified.
342
343 If the constructor is only passed a single argument, it is assumed to
344 be a C<PeerAddr> specification.
345
346 If C<Blocking> is set to 0, the connection will be in nonblocking mode.
347 If not specified it defaults to 1 (blocking mode).
348
349 Examples:
350
351    $sock = IO::Socket::INET->new(PeerAddr => 'www.perl.org',
352                                  PeerPort => 'http(80)',
353                                  Proto    => 'tcp');
354
355    $sock = IO::Socket::INET->new(PeerAddr => 'localhost:smtp(25)');
356
357    $sock = IO::Socket::INET->new(Listen    => 5,
358                                  LocalAddr => 'localhost',
359                                  LocalPort => 9000,
360                                  Proto     => 'tcp');
361
362    $sock = IO::Socket::INET->new('127.0.0.1:25');
363
364    $sock = IO::Socket::INET->new(PeerPort  => 9999,
365                                  PeerAddr  => inet_ntoa(INADDR_BROADCAST),
366                                  Proto     => udp,    
367                                  LocalAddr => 'localhost',
368                                  Broadcast => 1 ) 
369                              or die "Can't bind : $@\n";
370
371  NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
372
373 As of VERSION 1.18 all IO::Socket objects have autoflush turned on
374 by default. This was not the case with earlier releases.
375
376  NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
377
378 =back
379
380 =head2 METHODS
381
382 =over 4
383
384 =item sockaddr ()
385
386 Return the address part of the sockaddr structure for the socket
387
388 =item sockport ()
389
390 Return the port number that the socket is using on the local host
391
392 =item sockhost ()
393
394 Return the address part of the sockaddr structure for the socket in a
395 text form xx.xx.xx.xx
396
397 =item peeraddr ()
398
399 Return the address part of the sockaddr structure for the socket on
400 the peer host
401
402 =item peerport ()
403
404 Return the port number for the socket on the peer host.
405
406 =item peerhost ()
407
408 Return the address part of the sockaddr structure for the socket on the
409 peer host in a text form xx.xx.xx.xx
410
411 =back
412
413 =head1 SEE ALSO
414
415 L<Socket>, L<IO::Socket>
416
417 =head1 AUTHOR
418
419 Graham Barr. Currently maintained by the Perl Porters.  Please report all
420 bugs to <perl5-porters@perl.org>.
421
422 =head1 COPYRIGHT
423
424 Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
425 This program is free software; you can redistribute it and/or
426 modify it under the same terms as Perl itself.
427
428 =cut