[ViewVC] Diff of: cvs/AnyEvent/lib/AnyEvent/Socket.pm

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.11 by root, Fri May 23 20:09:56 2008 UTC vs.
Revision 1.67 by root, Mon Nov 3 17:14:30 2008 UTC

…		…
2		2
3	AnyEvent::Socket - useful IPv4 and IPv6 stuff.	3	AnyEvent::Socket - useful IPv4 and IPv6 stuff.
4		4
5	=head1 SYNOPSIS	5	=head1 SYNOPSIS
6		6
7	use AnyEvent::Socket;	7	use AnyEvent::Socket;
		8
		9	tcp_connect "gameserver.deliantra.net", 13327, sub {
		10	my ($fh) = @_
		11	or die "gameserver.deliantra.net connect failed: $!";
		12
		13	# enjoy your filehandle
		14	};
		15
		16	# a simple tcp server
		17	tcp_server undef, 8888, sub {
		18	my ($fh, $host, $port) = @_;
		19
		20	syswrite $fh, "The internet is full, $host:$port. Go away!\015\012";
		21	};
8		22
9	=head1 DESCRIPTION	23	=head1 DESCRIPTION
10		24
11	This module implements various utility functions for handling internet	25	This module implements various utility functions for handling internet
12	protocol addresses and sockets, in an as transparent and simple way as	26	protocol addresses and sockets, in an as transparent and simple way as
…		…
24	no warnings;	38	no warnings;
25	use strict;	39	use strict;
26		40
27	use Carp ();	41	use Carp ();
28	use Errno ();	42	use Errno ();
29	use Socket ();	43	use Socket qw(AF_INET AF_UNIX SOCK_STREAM SOCK_DGRAM SOL_SOCKET SO_REUSEADDR);
30		44
31	use AnyEvent ();	45	use AnyEvent ();
32	use AnyEvent::Util qw(guard fh_nonblocking);	46	use AnyEvent::Util qw(guard fh_nonblocking AF_INET6);
		47	use AnyEvent::DNS ();
33		48
34	use base 'Exporter';	49	use base 'Exporter';
35		50
36	BEGIN {	51	our @EXPORT = qw(
37	*socket_inet_aton = \&Socket::inet_aton; # take a copy, in case Coro::LWP overrides it	52	parse_hostport
38	}	53	parse_ipv4 parse_ipv6
		54	parse_ip parse_address
		55	format_ip format_address
		56	address_family
		57	inet_aton
		58	tcp_server
		59	tcp_connect
		60	);
39		61
40	our @EXPORT = qw(inet_aton tcp_server tcp_connect);
41
42	our $VERSION = '1.0';	62	our $VERSION = 4.31;
43		63
44	=item $ipn = parse_ipv4 $dotted_quad	64	=item $ipn = parse_ipv4 $dotted_quad
45		65
46	Tries to parse the given dotted quad IPv4 address and return it in	66	Tries to parse the given dotted quad IPv4 address and return it in
47	octet form (or undef when it isn't in a parsable format). Supports all	67	octet form (or undef when it isn't in a parsable format). Supports all
…		…
59		79
60	# check leading parts against range	80	# check leading parts against range
61	return undef if grep $_ >= 256, @_[0 .. @_ - 2];	81	return undef if grep $_ >= 256, @_[0 .. @_ - 2];
62		82
63	# check trailing part against range	83	# check trailing part against range
64	return undef if $_[-1] >= 1 << (8 * (4 - $#_));	84	return undef if $_[-1] >= 2 ** (8 * (4 - $#_));
65		85
66	pack "N", (pop)	86	pack "N", (pop)
67	+ ($_[0] << 24)	87	+ ($_[0] << 24)
68	+ ($_[1] << 16)	88	+ ($_[1] << 16)
69	+ ($_[2] << 8);	89	+ ($_[2] << 8);
70	}	90	}
71		91
72	=item $ipn = parse_ipv4 $dotted_quad	92	=item $ipn = parse_ipv6 $textual_ipv6_address
73		93
74	Tries to parse the given IPv6 address and return it in	94	Tries to parse the given IPv6 address and return it in
75	octet form (or undef when it isn't in a parsable format).	95	octet form (or undef when it isn't in a parsable format).
76		96
77	Should support all forms specified by RFC 2373 (and additionally all IPv4	97	Should support all forms specified by RFC 2373 (and additionally all IPv4
78	formst supported by parse_ipv4).	98	forms supported by parse_ipv4). Note that scope-id's are not supported
		99	(and will not parse).
		100
		101	This function works similarly to C<inet_pton AF_INET6, ...>.
79		102
80	=cut	103	=cut
81		104
82	sub parse_ipv6($) {	105	sub parse_ipv6($) {
83	# quick test to avoid longer processing	106	# quick test to avoid longer processing
…		…
91	}	114	}
92		115
93	my @h = split /:/, $h;	116	my @h = split /:/, $h;
94	my @t = split /:/, $t;	117	my @t = split /:/, $t;
95		118
96	# check four ipv4 tail	119	# check for ipv4 tail
97	if (@t && $t[-1]=~ /\./) {	120	if (@t && $t[-1]=~ /\./) {
98	return undef if $n > 6;	121	return undef if $n > 6;
99		122
100	my $ipn = parse_ipv4 pop @t	123	my $ipn = parse_ipv4 pop @t
101	or return undef;	124	or return undef;
…		…
114		137
115	# and done	138	# and done
116	pack "n*", map hex, @h, @t	139	pack "n*", map hex, @h, @t
117	}	140	}
118		141
		142	sub parse_unix($) {
		143	$_[0] eq "unix/"
		144	? pack "S", AF_UNIX
		145	: undef
		146
		147	}
		148
119	=item $ipn = parse_ip $text	149	=item $ipn = parse_address $text
120		150
121	Combines C<parse_ipv4> and C<parse_ipv6> in one function.	151	Combines C<parse_ipv4> and C<parse_ipv6> in one function. The address
		152	here refers to the host address (not socket address) in network form
		153	(binary).
122		154
123	=cut	155	If the C<$text> is C<unix/>, then this function returns a special token
		156	recognised by the other functions in this module to mean "UNIX domain
		157	socket".
124		158
		159	=item $text = AnyEvent::Socket::aton $ipn
		160
		161	Same as C<parse_address>, but not exported (think C<Socket::inet_aton> but
		162	I<without> name resolution).
		163
		164	=cut
		165
125	sub parse_ip($) {	166	sub parse_address($) {
126	&parse_ipv4 \|\| &parse_ipv6	167	&parse_ipv4 \|\| &parse_ipv6 \|\| &parse_unix
127	}	168	}
128		169
		170	*aton = \&parse_address;
		171
		172	=item ($host, $service) = parse_hostport $string[, $default_service]
		173
		174	Splitting a string of the form C<hostname:port> is a common
		175	problem. Unfortunately, just splitting on the colon makes it hard to
		176	specify IPv6 addresses and doesn't support the less common but well
		177	standardised C<[ip literal]> syntax.
		178
		179	This function tries to do this job in a better way, it supports the
		180	following formats, where C<port> can be a numerical port number of a
		181	service name, or a C<name=port> string, and the C< port> and C<:port>
		182	parts are optional. Also, everywhere where an IP address is supported
		183	a hostname or unix domain socket address is also supported (see
		184	C<parse_unix>).
		185
		186	hostname:port e.g. "www.linux.org", "www.x.de:443", "www.x.de:https=443"
		187	ipv4:port e.g. "198.182.196.56", "127.1:22"
		188	ipv6 e.g. "::1", "affe::1"
		189	[ipv4or6]:port e.g. "[::1]", "[10.0.1]:80"
		190	[ipv4or6] port e.g. "[127.0.0.1]", "[www.x.org] 17"
		191	ipv4or6 port e.g. "::1 443", "10.0.0.1 smtp"
		192
		193	It also supports defaulting the service name in a simple way by using
		194	C<$default_service> if no service was detected. If neither a service was
		195	detected nor a default was specified, then this function returns the
		196	empty list. The same happens when a parse error weas detected, such as a
		197	hostname with a colon in it (the function is rather conservative, though).
		198
		199	Example:
		200
		201	print join ",", parse_hostport "localhost:443";
		202	# => "localhost,443"
		203
		204	print join ",", parse_hostport "localhost", "https";
		205	# => "localhost,https"
		206
		207	print join ",", parse_hostport "[::1]";
		208	# => "," (empty list)
		209
		210	=cut
		211
		212	sub parse_hostport($;$) {
		213	my ($host, $port);
		214
		215	for ("$_[0]") { # work on a copy, just in case, and also reset pos
		216
		217	# parse host, special cases: "ipv6" or "ipv6 port"
		218	unless (
		219	($host) = /^\s* ([0-9a-fA-F:]:[0-9a-fA-F:]:[0-9a-fA-F\.:]*)/xgc
		220	and parse_ipv6 $host
		221	) {
		222	/^\s*/xgc;
		223
		224	if (/^ \[ ([^\[\]]+) \]/xgc) {
		225	$host = $1;
		226	} elsif (/^ ([^\[\]:\ ]+) /xgc) {
		227	$host = $1;
		228	} else {
		229	return;
		230	}
		231	}
		232
		233	# parse port
		234	if (/\G (?:\s+\|:) ([^:[:space:]]+) \s*$/xgc) {
		235	$port = $1;
		236	} elsif (/\G\s*$/gc && length $_[1]) {
		237	$port = $_[1];
		238	} else {
		239	return;
		240	}
		241	}
		242
		243	# hostnames must not contain :'s
		244	return if $host =~ /:/ && !parse_ipv6 $host;
		245
		246	($host, $port)
		247	}
		248
		249	=item $sa_family = address_family $ipn
		250
		251	Returns the address family/protocol-family (AF_xxx/PF_xxx, in one value :)
		252	of the given host address in network format.
		253
		254	=cut
		255
		256	sub address_family($) {
		257	4 == length $_[0]
		258	? AF_INET
		259	: 16 == length $_[0]
		260	? AF_INET6
		261	: unpack "S", $_[0]
		262	}
		263
129	=item $text = format_ip $ipn	264	=item $text = format_address $ipn
130		265
131	Takes either an IPv4 address (4 octets) or and IPv6 address (16 octets)	266	Covnvert a host address in network format (e.g. 4 octets for IPv4 or 16
132	and converts it into textual form.	267	octets for IPv6) and convert it into textual form.
133		268
134	=cut	269	Returns C<unix/> for UNIX domain sockets.
135		270
136	sub format_ip;	271	This function works similarly to C<inet_ntop AF_INET \|\| AF_INET6, ...>,
		272	except it automatically detects the address type.
		273
		274	Returns C<undef> if it cannot detect the type.
		275
		276	=item $text = AnyEvent::Socket::ntoa $ipn
		277
		278	Same as format_address, but not exported (think C<inet_ntoa>).
		279
		280	=cut
		281
		282	sub format_address;
137	sub format_ip($) {	283	sub format_address($) {
138	if (4 == length $_[0]) {	284	my $af = address_family $_[0];
		285	if ($af == AF_INET) {
139	return join ".", unpack "C4", $_[0]	286	return join ".", unpack "C4", $_[0]
140	} elsif (16 == length $_[0]) {	287	} elsif ($af == AF_INET6) {
		288	if (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0 eq $_[0]) {
		289	return "::";
		290	} elsif (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.1 eq $_[0]) {
		291	return "::1";
		292	} elsif (v0.0.0.0.0.0.0.0.0.0.0.0 eq substr $_[0], 0, 12) {
		293	# v4compatible
		294	return "::" . format_address substr $_[0], 12;
141	if (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12) {	295	} elsif (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12) {
142	# v4mapped	296	# v4mapped
143	return "::ffff:" . format_ip substr $_[0], 12;	297	return "::ffff:" . format_address substr $_[0], 12;
		298	} elsif (v0.0.0.0.0.0.0.0.255.255.0.0 eq substr $_[0], 0, 12) {
		299	# v4translated
		300	return "::ffff:0:" . format_address substr $_[0], 12;
144	} else {	301	} else {
145	my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0];	302	my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0];
146		303
		304	# this is rather sucky, I admit
147	$ip =~ s/^0:(?:0:)*/::/	305	$ip =~ s/^0:(?:0:)*(0$)?/::/
148	or $ip =~ s/(:0)+$/::/	306	or $ip =~ s/(:0){7}$/::/ or $ip =~ s/(:0){7}/:/
149	or $ip =~ s/(:0)+/:/;	307	or $ip =~ s/(:0){6}$/::/ or $ip =~ s/(:0){6}/:/
		308	or $ip =~ s/(:0){5}$/::/ or $ip =~ s/(:0){5}/:/
		309	or $ip =~ s/(:0){4}$/::/ or $ip =~ s/(:0){4}/:/
		310	or $ip =~ s/(:0){3}$/::/ or $ip =~ s/(:0){3}/:/
		311	or $ip =~ s/(:0){2}$/::/ or $ip =~ s/(:0){2}/:/
		312	or $ip =~ s/(:0){1}$/::/ or $ip =~ s/(:0){1}/:/;
150	return $ip	313	return $ip
151	}	314	}
		315	} elsif ($af == AF_UNIX) {
		316	return "unix/"
152	} else {	317	} else {
153	return undef	318	return undef
154	}	319	}
155	}	320	}
		321
		322	*ntoa = \&format_address;
156		323
157	=item inet_aton $name_or_address, $cb->(@addresses)	324	=item inet_aton $name_or_address, $cb->(@addresses)
158		325
159	Works similarly to its Socket counterpart, except that it uses a	326	Works similarly to its Socket counterpart, except that it uses a
160	callback. Also, if a host has only an IPv6 address, this might be passed	327	callback. Also, if a host has only an IPv6 address, this might be passed
161	to the callback instead (use the length to detect this - 4 for IPv4, 16	328	to the callback instead (use the length to detect this - 4 for IPv4, 16
162	for IPv6).	329	for IPv6).
163		330
164	Unlike the L<Socket> function of the same name, you can get multiple IPv4	331	Unlike the L<Socket> function of the same name, you can get multiple IPv4
165	and IPv6 addresses as result.	332	and IPv6 addresses as result (and maybe even other adrdess types).
166		333
167	=cut	334	=cut
168		335
169	sub inet_aton {	336	sub inet_aton {
170	my ($name, $cb) = @_;	337	my ($name, $cb) = @_;
…		…
188	}	355	}
189	});	356	});
190	}	357	}
191	}	358	}
192		359
193	sub _tcp_port($) {	360	# check for broken platforms with extra field in sockaddr structure
194	$_[0] =~ /^(\d)$/ and return $11;	361	# kind of a rfc vs. bsd issue, as usual (ok, normally it's a
		362	# unix vs. bsd issue, a iso C vs. bsd issue or simply a
		363	# correctness vs. bsd issue.
		364	my $pack_family = (0x55 == Socket::sockaddr_family "\x55\x55")
		365	? "xC" : "S";
195		366
196	(getservbyname $_[0], "tcp")[2]	367	=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host
		368
		369	Pack the given port/host combination into a binary sockaddr
		370	structure. Handles both IPv4 and IPv6 host addresses, as well as UNIX
		371	domain sockets (C<$host> == C<unix/> and C<$service> == absolute
		372	pathname).
		373
		374	=cut
		375
		376	sub pack_sockaddr($$) {
		377	my $af = address_family $_[1];
		378
		379	if ($af == AF_INET) {
		380	Socket::pack_sockaddr_in $_[0], $_[1]
		381	} elsif ($af == AF_INET6) {
		382	pack "$pack_family nL a16 L",
		383	AF_INET6,
		384	$_[0], # port
		385	0, # flowinfo
		386	$_[1], # addr
		387	0 # scope id
		388	} elsif ($af == AF_UNIX) {
		389	Socket::pack_sockaddr_un $_[0]
		390	} else {
		391	Carp::croak "pack_sockaddr: invalid host";
		392	}
		393	}
		394
		395	=item ($service, $host) = AnyEvent::Socket::unpack_sockaddr $sa
		396
		397	Unpack the given binary sockaddr structure (as used by bind, getpeername
		398	etc.) into a C<$service, $host> combination.
		399
		400	For IPv4 and IPv6, C<$service> is the port number and C<$host> the host
		401	address in network format (binary).
		402
		403	For UNIX domain sockets, C<$service> is the absolute pathname and C<$host>
		404	is a special token that is understood by the other functions in this
		405	module (C<format_address> converts it to C<unix/>).
		406
		407	=cut
		408
		409	sub unpack_sockaddr($) {
		410	my $af = Socket::sockaddr_family $_[0];
		411
		412	if ($af == AF_INET) {
		413	Socket::unpack_sockaddr_in $_[0]
		414	} elsif ($af == AF_INET6) {
		415	unpack "x2 n x4 a16", $_[0]
		416	} elsif ($af == AF_UNIX) {
		417	((Socket::unpack_sockaddr_un $_[0]), pack "S", AF_UNIX)
		418	} else {
		419	Carp::croak "unpack_sockaddr: unsupported protocol family $af";
		420	}
		421	}
		422
		423	=item resolve_sockaddr $node, $service, $proto, $family, $type, $cb->([$family, $type, $proto, $sockaddr], ...)
		424
		425	Tries to resolve the given nodename and service name into protocol families
		426	and sockaddr structures usable to connect to this node and service in a
		427	protocol-independent way. It works remotely similar to the getaddrinfo
		428	posix function.
		429
		430	For internet addresses, C<$node> is either an IPv4 or IPv6 address or an
		431	internet hostname, and C<$service> is either a service name (port name
		432	from F</etc/services>) or a numerical port number. If both C<$node> and
		433	C<$service> are names, then SRV records will be consulted to find the real
		434	service, otherwise they will be used as-is. If you know that the service
		435	name is not in your services database, then you can specify the service in
		436	the format C<name=port> (e.g. C<http=80>).
		437
		438	For UNIX domain sockets, C<$node> must be the string C<unix/> and
		439	C<$service> must be the absolute pathname of the socket. In this case,
		440	C<$proto> will be ignored.
		441
		442	C<$proto> must be a protocol name, currently C<tcp>, C<udp> or
		443	C<sctp>. The default is currently C<tcp>, but in the future, this function
		444	might try to use other protocols such as C<sctp>, depending on the socket
		445	type and any SRV records it might find.
		446
		447	C<$family> must be either C<0> (meaning any protocol is OK), C<4> (use
		448	only IPv4) or C<6> (use only IPv6). The default is influenced by
		449	C<$ENV{PERL_ANYEVENT_PROTOCOLS}>.
		450
		451	C<$type> must be C<SOCK_STREAM>, C<SOCK_DGRAM> or C<SOCK_SEQPACKET> (or
		452	C<undef> in which case it gets automatically chosen to be C<SOCK_STREAM>
		453	unless C<$proto> is C<udp>).
		454
		455	The callback will receive zero or more array references that contain
		456	C<$family, $type, $proto> for use in C<socket> and a binary
		457	C<$sockaddr> for use in C<connect> (or C<bind>).
		458
		459	The application should try these in the order given.
		460
		461	Example:
		462
		463	resolve_sockaddr "google.com", "http", 0, undef, undef, sub { ... };
		464
		465	=cut
		466
		467	# microsoft can't even get getprotobyname working (the etc/protocols file
		468	# gets lost fairly often on windows), so we have to hardcode some common
		469	# protocol numbers ourselves.
		470	our %PROTO_BYNAME;
		471
		472	$PROTO_BYNAME{tcp} = &Socket::IPPROTO_TCP if defined &Socket::IPPROTO_TCP;
		473	$PROTO_BYNAME{udp} = &Socket::IPPROTO_UDP if defined &Socket::IPPROTO_UDP;
		474	$PROTO_BYNAME{icmp} = &Socket::IPPROTO_ICMP if defined &Socket::IPPROTO_ICMP;
		475
		476	sub resolve_sockaddr($$$$$$) {
		477	my ($node, $service, $proto, $family, $type, $cb) = @_;
		478
		479	if ($node eq "unix/") {
		480	return $cb->() if $family \|\| $service !~ /^\//; # no can do
		481
		482	return $cb->([AF_UNIX, defined $type ? $type : SOCK_STREAM, 0, Socket::pack_sockaddr_un $service]);
		483	}
		484
		485	unless (AF_INET6) {
		486	$family != 6
		487	or return $cb->();
		488
		489	$family = 4;
		490	}
		491
		492	$cb->() if $family == 4 && !$AnyEvent::PROTOCOL{ipv4};
		493	$cb->() if $family == 6 && !$AnyEvent::PROTOCOL{ipv6};
		494
		495	$family \|\|= 4 unless $AnyEvent::PROTOCOL{ipv6};
		496	$family \|\|= 6 unless $AnyEvent::PROTOCOL{ipv4};
		497
		498	$proto \|\|= "tcp";
		499	$type \|\|= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM;
		500
		501	my $proton = $PROTO_BYNAME{lc $proto} \|\| (getprotobyname $proto)[2]
197	or Carp::croak "$_[0]: service unknown"	502	or Carp::croak "$proto: protocol unknown";
198	}
199		503
		504	my $port;
		505
		506	if ($service =~ /^(\S+)=(\d+)$/) {
		507	($service, $port) = ($1, $2);
		508	} elsif ($service =~ /^\d+$/) {
		509	($service, $port) = (undef, $service);
		510	} else {
		511	$port = (getservbyname $service, $proto)[2]
		512	or Carp::croak "$service/$proto: service unknown";
		513	}
		514
		515	my @target = [$node, $port];
		516
		517	# resolve a records / provide sockaddr structures
		518	my $resolve = sub {
		519	my @res;
		520	my $cv = AnyEvent->condvar (cb => sub {
		521	$cb->(
		522	map $_->[2],
		523	sort {
		524	$AnyEvent::PROTOCOL{$b->[1]} <=> $AnyEvent::PROTOCOL{$a->[1]}
		525	or $a->[0] <=> $b->[0]
		526	}
		527	@res
		528	)
		529	});
		530
		531	$cv->begin;
		532	for my $idx (0 .. $#target) {
		533	my ($node, $port) = @{ $target[$idx] };
		534
		535	if (my $noden = parse_address $node) {
		536	my $af = address_family $noden;
		537
		538	if ($af == AF_INET && $family != 6) {
		539	push @res, [$idx, "ipv4", [AF_INET, $type, $proton,
		540	pack_sockaddr $port, $noden]]
		541	}
		542
		543	if ($af == AF_INET6 && $family != 4) {
		544	push @res, [$idx, "ipv6", [AF_INET6, $type, $proton,
		545	pack_sockaddr $port, $noden]]
		546	}
		547	} else {
		548	# ipv4
		549	if ($family != 6) {
		550	$cv->begin;
		551	AnyEvent::DNS::a $node, sub {
		552	push @res, [$idx, "ipv4", [AF_INET, $type, $proton,
		553	pack_sockaddr $port, parse_ipv4 $_]]
		554	for @_;
		555	$cv->end;
		556	};
		557	}
		558
		559	# ipv6
		560	if ($family != 4) {
		561	$cv->begin;
		562	AnyEvent::DNS::aaaa $node, sub {
		563	push @res, [$idx, "ipv6", [AF_INET6, $type, $proton,
		564	pack_sockaddr $port, parse_ipv6 $_]]
		565	for @_;
		566	$cv->end;
		567	};
		568	}
		569	}
		570	}
		571	$cv->end;
		572	};
		573
		574	# try srv records, if applicable
		575	if ($node eq "localhost") {
		576	@target = (["127.0.0.1", $port], ["::1", $port]);
		577	&$resolve;
		578	} elsif (defined $service && !parse_address $node) {
		579	AnyEvent::DNS::srv $service, $proto, $node, sub {
		580	my (@srv) = @_;
		581
		582	# no srv records, continue traditionally
		583	@srv
		584	or return &$resolve;
		585
		586	# the only srv record has "." ("" here) => abort
		587	$srv[0][2] ne "" \|\| $#srv
		588	or return $cb->();
		589
		590	# use srv records then
		591	@target = map ["$_->[3].", $_->[2]],
		592	grep $_->[3] ne ".",
		593	@srv;
		594
		595	&$resolve;
		596	};
		597	} else {
		598	&$resolve;
		599	}
		600	}
		601
200	=item $guard = tcp_connect $host, $port, $connect_cb[, $prepare_cb]	602	=item $guard = tcp_connect $host, $service, $connect_cb[, $prepare_cb]
201		603
202	This is a convenience function that creates a tcp socket and makes a 100%	604	This is a convenience function that creates a TCP socket and makes a 100%
203	non-blocking connect to the given C<$host> (which can be a hostname or a	605	non-blocking connect to the given C<$host> (which can be a hostname or
204	textual IP address) and C<$port> (which can be a numeric port number or a	606	a textual IP address, or the string C<unix/> for UNIX domain sockets)
205	service name).	607	and C<$service> (which can be a numeric port number or a service name,
		608	or a C<servicename=portnumber> string, or the pathname to a UNIX domain
		609	socket).
206		610
207	If both C<$host> and C<$port> are names, then this function will use SRV	611	If both C<$host> and C<$port> are names, then this function will use SRV
208	records to locate the real target in a future version.	612	records to locate the real target(s).
209		613
210	Unless called in void context, it returns a guard object that will	614	In either case, it will create a list of target hosts (e.g. for multihomed
211	automatically abort connecting when it gets destroyed (it does not do	615	hosts or hosts with both IPv4 and IPv6 addresses) and try to connect to
212	anything to the socket after the connect was successful).	616	each in turn.
213		617
214	If the connect is successful, then the C<$connect_cb> will be invoked with	618	If the connect is successful, then the C<$connect_cb> will be invoked with
215	the socket filehandle (in non-blocking mode) as first and the peer host	619	the socket file handle (in non-blocking mode) as first and the peer host
216	(as a textual IP address) and peer port as second and third arguments,	620	(as a textual IP address) and peer port as second and third arguments,
217	respectively.	621	respectively. The fourth argument is a code reference that you can call
		622	if, for some reason, you don't like this connection, which will cause
		623	C<tcp_connect> to try the next one (or call your callback without any
		624	arguments if there are no more connections). In most cases, you can simply
		625	ignore this argument.
		626
		627	$cb->($filehandle, $host, $port, $retry)
218		628
219	If the connect is unsuccessful, then the C<$connect_cb> will be invoked	629	If the connect is unsuccessful, then the C<$connect_cb> will be invoked
220	without any arguments and C<$!> will be set appropriately (with C<ENXIO>	630	without any arguments and C<$!> will be set appropriately (with C<ENXIO>
221	indicating a dns resolution failure).	631	indicating a DNS resolution failure).
222		632
223	The filehandle is suitable to be plugged into L<AnyEvent::Handle>, but can	633	The file handle is perfect for being plugged into L<AnyEvent::Handle>, but
224	be used as a normal perl file handle as well.	634	can be used as a normal perl file handle as well.
		635
		636	Unless called in void context, C<tcp_connect> returns a guard object that
		637	will automatically abort connecting when it gets destroyed (it does not do
		638	anything to the socket after the connect was successful).
225		639
226	Sometimes you need to "prepare" the socket before connecting, for example,	640	Sometimes you need to "prepare" the socket before connecting, for example,
227	to C<bind> it to some port, or you want a specific connect timeout that	641	to C<bind> it to some port, or you want a specific connect timeout that
228	is lower than your kernel's default timeout. In this case you can specify	642	is lower than your kernel's default timeout. In this case you can specify
229	a second callback, C<$prepare_cb>. It will be called with the file handle	643	a second callback, C<$prepare_cb>. It will be called with the file handle
230	in not-yet-connected state as only argument and must return the connection	644	in not-yet-connected state as only argument and must return the connection
231	timeout value (or C<0>, C<undef> or the empty list to indicate the default	645	timeout value (or C<0>, C<undef> or the empty list to indicate the default
232	timeout is to be used).	646	timeout is to be used).
233		647
234	Note that the socket could be either a IPv4 TCP socket or an IPv6 tcp	648	Note that the socket could be either a IPv4 TCP socket or an IPv6 TCP
235	socket (although only IPv4 is currently supported by this module).	649	socket (although only IPv4 is currently supported by this module).
236		650
		651	Note to the poor Microsoft Windows users: Windows (of course) doesn't
		652	correctly signal connection errors, so unless your event library works
		653	around this, failed connections will simply hang. The only event libraries
		654	that handle this condition correctly are L<EV> and L<Glib>. Additionally,
		655	AnyEvent works around this bug with L<Event> and in its pure-perl
		656	backend. All other libraries cannot correctly handle this condition. To
		657	lessen the impact of this windows bug, a default timeout of 30 seconds
		658	will be imposed on windows. Cygwin is not affected.
		659
237	Simple Example: connect to localhost on port 22.	660	Simple Example: connect to localhost on port 22.
238		661
239	tcp_connect localhost => 22, sub {	662	tcp_connect localhost => 22, sub {
240	my $fh = shift	663	my $fh = shift
241	or die "unable to connect: $!";	664	or die "unable to connect: $!";
242	# do something	665	# do something
243	};	666	};
244		667
245	Complex Example: connect to www.google.com on port 80 and make a simple	668	Complex Example: connect to www.google.com on port 80 and make a simple
246	GET request without much error handling. Also limit the connection timeout	669	GET request without much error handling. Also limit the connection timeout
247	to 15 seconds.	670	to 15 seconds.
248		671
…		…
278	# could call $fh->bind etc. here	701	# could call $fh->bind etc. here
279		702
280	15	703	15
281	};	704	};
282		705
		706	Example: connect to a UNIX domain socket.
		707
		708	tcp_connect "unix/", "/tmp/.X11-unix/X0", sub {
		709	...
		710	}
		711
283	=cut	712	=cut
284		713
285	sub tcp_connect($$$;$) {	714	sub tcp_connect($$$;$) {
286	my ($host, $port, $connect, $prepare) = @_;	715	my ($host, $port, $connect, $prepare) = @_;
287		716
288	# see http://cr.yp.to/docs/connect.html for some background	717	# see http://cr.yp.to/docs/connect.html for some background
		718	# also http://advogato.org/article/672.html
289		719
290	my %state = ( fh => undef );	720	my %state = ( fh => undef );
291		721
292	# name resolution	722	# name/service to type/sockaddr resolution
293	inet_aton $host, sub {	723	resolve_sockaddr $host, $port, 0, 0, undef, sub {
		724	my @target = @_;
		725
		726	$state{next} = sub {
294	return unless exists $state{fh};	727	return unless exists $state{fh};
295		728
296	my $ipn = shift;	729	my $target = shift @target
297
298	4 == length $ipn
299	or do {	730	or do {
300	%state = ();	731	%state = ();
301	$! = &Errno::ENXIO;
302	return $connect->();	732	return $connect->();
		733	};
		734
		735	my ($domain, $type, $proto, $sockaddr) = @$target;
		736
		737	# socket creation
		738	socket $state{fh}, $domain, $type, $proto
		739	or return $state{next}();
		740
		741	fh_nonblocking $state{fh}, 1;
		742
		743	my $timeout = $prepare && $prepare->($state{fh});
		744
		745	$timeout \|\|= 30 if AnyEvent::WIN32;
		746
		747	$state{to} = AnyEvent->timer (after => $timeout, cb => sub {
		748	$! = &Errno::ETIMEDOUT;
		749	$state{next}();
		750	}) if $timeout;
		751
		752	# called when the connect was successful, which,
		753	# in theory, could be the case immediately (but never is in practise)
		754	$state{connected} = sub {
		755	delete $state{ww};
		756	delete $state{to};
		757
		758	# we are connected, or maybe there was an error
		759	if (my $sin = getpeername $state{fh}) {
		760	my ($port, $host) = unpack_sockaddr $sin;
		761
		762	my $guard = guard { %state = () };
		763
		764	$connect->(delete $state{fh}, format_address $host, $port, sub {
		765	$guard->cancel;
		766	$state{next}();
		767	});
		768	} else {
		769	# dummy read to fetch real error code
		770	sysread $state{fh}, my $buf, 1 if $! == &Errno::ENOTCONN;
		771	$state{next}();
		772	}
303	};	773	};
304		774
305	# socket creation	775	# now connect
306	socket $state{fh}, &Socket::AF_INET, &Socket::SOCK_STREAM, 0	776	if (connect $state{fh}, $sockaddr) {
307	or do {
308	%state = ();
309	return $connect->();
310	};
311
312	fh_nonblocking $state{fh}, 1;
313
314	# prepare and optional timeout
315	if ($prepare) {
316	my $timeout = $prepare->($state{fh});
317
318	$state{to} = AnyEvent->timer (after => $timeout, cb => sub {
319	%state = ();
320	$! = &Errno::ETIMEDOUT;
321	$connect->();	777	$state{connected}->();
322	}) if $timeout;	778	} elsif ($! == &Errno::EINPROGRESS # POSIX
323	}	779	\|\| $! == &Errno::EWOULDBLOCK
324		780	# WSAEINPROGRESS intentionally not checked - it means something else entirely
325	# called when the connect was successful, which,	781	\|\| $! == AnyEvent::Util::WSAEINVAL # not convinced, but doesn't hurt
326	# in theory, could be the case immediately (but never is in practise)	782	\|\| $! == AnyEvent::Util::WSAEWOULDBLOCK) {
327	my $connected = sub {	783	$state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $state{connected});
328	my $fh = delete $state{fh};
329	%state = ();
330
331	# we are connected, or maybe there was an error
332	if (my $sin = getpeername $fh) {
333	my ($port, $host) = Socket::unpack_sockaddr_in $sin;
334	$connect->($fh, (Socket::inet_ntoa $host), $port);
335	} else {	784	} else {
336	# dummy read to fetch real error code	785	$state{next}();
337	sysread $fh, my $buf, 1 if $! == &Errno::ENOTCONN;
338	$connect->();
339	}	786	}
340	};	787	};
341		788
342	# now connect	789	$! = &Errno::ENXIO;
343	if (connect $state{fh}, Socket::pack_sockaddr_in _tcp_port $port, $ipn) {	790	$state{next}();
344	$connected->();
345	} elsif ($! == &Errno::EINPROGRESS \|\| $! == &Errno::EWOULDBLOCK) { # EINPROGRESS is POSIX
346	$state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $connected);
347	} else {
348	%state = ();
349	$connect->();
350	}
351	};	791	};
352		792
353	defined wantarray	793	defined wantarray && guard { %state = () }
354	? guard { %state = () } # break any circular dependencies and unregister watchers
355	: ()
356	}	794	}
357		795
358	=item $guard = tcp_server $host, $port, $accept_cb[, $prepare_cb]	796	=item $guard = tcp_server $host, $service, $accept_cb[, $prepare_cb]
359		797
360	Create and bind a tcp socket to the given host (any IPv4 host if undef,	798	Create and bind a stream socket to the given host, and port, set the
361	otherwise it must be an IPv4 or IPv6 address) and port (service name or	799	SO_REUSEADDR flag (if applicable) and call C<listen>. Unlike the name
362	numeric port number, or an ephemeral port if given as zero or undef), set	800	implies, this function can also bind on UNIX domain sockets.
363	the SO_REUSEADDR flag and call C<listen>.
364		801
		802	For internet sockets, C<$host> must be an IPv4 or IPv6 address (or
		803	C<undef>, in which case it binds either to C<0> or to C<::>, depending
		804	on whether IPv4 or IPv6 is the preferred protocol, and maybe to both in
		805	future versions, as applicable).
		806
		807	To bind to the IPv4 wildcard address, use C<0>, to bind to the IPv6
		808	wildcard address, use C<::>.
		809
		810	The port is specified by C<$service>, which must be either a service name or
		811	a numeric port number (or C<0> or C<undef>, in which case an ephemeral
		812	port will be used).
		813
		814	For UNIX domain sockets, C<$host> must be C<unix/> and C<$service> must be
		815	the absolute pathname of the socket. This function will try to C<unlink>
		816	the socket before it tries to bind to it. See SECURITY CONSIDERATIONS,
		817	below.
		818
365	For each new connection that could be C<accept>ed, call the C<$accept_cb>	819	For each new connection that could be C<accept>ed, call the C<<
366	with the filehandle (in non-blocking mode) as first and the peer host and	820	$accept_cb->($fh, $host, $port) >> with the file handle (in non-blocking
367	port as second and third arguments (see C<tcp_connect> for details).	821	mode) as first and the peer host and port as second and third arguments
		822	(see C<tcp_connect> for details).
368		823
369	Croaks on any errors.	824	Croaks on any errors it can detect before the listen.
370		825
371	If called in non-void context, then this function returns a guard object	826	If called in non-void context, then this function returns a guard object
372	whose lifetime it tied to the tcp server: If the object gets destroyed,	827	whose lifetime it tied to the TCP server: If the object gets destroyed,
373	the server will be stopped (but existing accepted connections will	828	the server will be stopped (but existing accepted connections will
374	continue).	829	continue).
375		830
376	If you need more control over the listening socket, you can provide a	831	If you need more control over the listening socket, you can provide a
377	C<$prepare_cb>, which is called just before the C<listen ()> call, with	832	C<< $prepare_cb->($fh, $host, $port) >>, which is called just before the
378	the listen file handle as first argument.	833	C<listen ()> call, with the listen file handle as first argument, and IP
		834	address and port number of the local socket endpoint as second and third
		835	arguments.
379		836
380	It should return the length of the listen queue (or C<0> for the default).	837	It should return the length of the listen queue (or C<0> for the default).
381		838
		839	Note to IPv6 users: RFC-compliant behaviour for IPv6 sockets listening on
		840	C<::> is to bind to both IPv6 and IPv4 addresses by default on dual-stack
		841	hosts. Unfortunately, only GNU/Linux seems to implement this properly, so
		842	if you want both IPv4 and IPv6 listening sockets you should create the
		843	IPv6 socket first and then attempt to bind on the IPv4 socket, but ignore
		844	any C<EADDRINUSE> errors.
		845
382	Example: bind on tcp port 8888 on the local machine and tell each client	846	Example: bind on some TCP port on the local machine and tell each client
383	to go away.	847	to go away.
384		848
385	tcp_server undef, 8888, sub {	849	tcp_server undef, undef, sub {
386	my ($fh, $host, $port) = @_;	850	my ($fh, $host, $port) = @_;
387		851
388	syswrite $fh, "The internet is full, $host:$port. Go away!\015\012";	852	syswrite $fh, "The internet is full, $host:$port. Go away!\015\012";
		853	}, sub {
		854	my ($fh, $thishost, $thisport) = @_;
		855	warn "bound to $thishost, port $thisport\n";
389	};	856	};
390		857
		858	Example: bind a server on a unix domain socket.
		859
		860	tcp_server "unix/", "/tmp/mydir/mysocket", sub {
		861	my ($fh) = @_;
		862	};
		863
391	=cut	864	=cut
392		865
393	sub tcp_server($$$;$) {	866	sub tcp_server($$$;$) {
394	my ($host, $port, $accept, $prepare) = @_;	867	my ($host, $service, $accept, $prepare) = @_;
		868
		869	$host = $AnyEvent::PROTOCOL{ipv4} < $AnyEvent::PROTOCOL{ipv6} && AF_INET6
		870	? "::" : "0"
		871	unless defined $host;
		872
		873	my $ipn = parse_address $host
		874	or Carp::croak "AnyEvent::Socket::tcp_server: cannot parse '$host' as host address";
		875
		876	my $af = address_family $ipn;
395		877
396	my %state;	878	my %state;
397		879
398	socket $state{fh}, &Socket::AF_INET, &Socket::SOCK_STREAM, 0	880	# win32 perl is too stupid to get this right :/
		881	Carp::croak "tcp_server/socket: address family not supported"
		882	if AnyEvent::WIN32 && $af == AF_UNIX;
		883
		884	socket $state{fh}, $af, SOCK_STREAM, 0
399	or Carp::croak "socket: $!";	885	or Carp::croak "tcp_server/socket: $!";
400		886
		887	if ($af == AF_INET \|\| $af == AF_INET6) {
401	setsockopt $state{fh}, &Socket::SOL_SOCKET, &Socket::SO_REUSEADDR, 1	888	setsockopt $state{fh}, SOL_SOCKET, SO_REUSEADDR, 1
402	or Carp::croak "so_reuseaddr: $!";	889	or Carp::croak "tcp_server/so_reuseaddr: $!"
		890	unless AnyEvent::WIN32; # work around windows bug
403		891
404	bind $state{fh}, Socket::pack_sockaddr_in _tcp_port $port, socket_inet_aton ($host \|\| "0.0.0.0")	892	unless ($service =~ /^\d*$/) {
		893	$service = (getservbyname $service, "tcp")[2]
		894	or Carp::croak "$service: service unknown"
		895	}
		896	} elsif ($af == AF_UNIX) {
		897	unlink $service;
		898	}
		899
		900	bind $state{fh}, pack_sockaddr $service, $ipn
405	or Carp::croak "bind: $!";	901	or Carp::croak "bind: $!";
406		902
407	fh_nonblocking $state{fh}, 1;	903	fh_nonblocking $state{fh}, 1;
408		904
409	my $len = ($prepare && $prepare->($state{fh})) \|\| 128;	905	my $len;
		906
		907	if ($prepare) {
		908	my ($service, $host) = unpack_sockaddr getsockname $state{fh};
		909	$len = $prepare && $prepare->($state{fh}, format_address $host, $service);
		910	}
		911
		912	$len \|\|= 128;
410		913
411	listen $state{fh}, $len	914	listen $state{fh}, $len
412	or Carp::croak "listen: $!";	915	or Carp::croak "listen: $!";
413		916
414	$state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub {	917	$state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub {
415	# this closure keeps $state alive	918	# this closure keeps $state alive
416	while (my $peer = accept my $fh, $state{fh}) {	919	while (my $peer = accept my $fh, $state{fh}) {
417	fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not	920	fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not
		921
418	my ($port, $host) = Socket::unpack_sockaddr_in $peer;	922	my ($service, $host) = unpack_sockaddr $peer;
419	$accept->($fh, (Socket::inet_ntoa $host), $port);	923	$accept->($fh, format_address $host, $service);
420	}	924	}
421	});	925	});
422		926
423	defined wantarray	927	defined wantarray
424	? guard { %state = () } # clear fh and watcher, which breaks the circular dependency	928	? guard { %state = () } # clear fh and watcher, which breaks the circular dependency
…		…
427		931
428	1;	932	1;
429		933
430	=back	934	=back
431		935
		936	=head1 SECURITY CONSIDERATIONS
		937
		938	This module is quite powerful, with with power comes the ability to abuse
		939	as well: If you accept "hostnames" and ports from untrusted sources,
		940	then note that this can be abused to delete files (host=C<unix/>). This
		941	is not really a problem with this module, however, as blindly accepting
		942	any address and protocol and trying to bind a server or connect to it is
		943	harmful in general.
		944
432	=head1 AUTHOR	945	=head1 AUTHOR
433		946
434	Marc Lehmann <schmorp@schmorp.de>	947	Marc Lehmann <schmorp@schmorp.de>
435	http://home.schmorp.de/	948	http://home.schmorp.de/
436		949

Diff Legend

-–
+Removed lines
-+
+Added lines
-<
+Changed lines
->
+Changed lines

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents): Revision 1.11 by root, Fri May 23 20:09:56 2008 UTC vs. Revision 1.67 by root, Mon Nov 3 17:14:30 2008 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.11 by root, Fri May 23 20:09:56 2008 UTC vs.
Revision 1.67 by root, Mon Nov 3 17:14:30 2008 UTC