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