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