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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.80 by root, Fri Jun 26 06:33:17 2009 UTC vs.
Revision 1.119 by root, Tue Jan 5 10:45:25 2010 UTC

…		…
33		33
34	=cut	34	=cut
35		35
36	package AnyEvent::Socket;	36	package AnyEvent::Socket;
37		37
38	no warnings;
39	use strict;
40
41	use Carp ();	38	use Carp ();
42	use Errno ();	39	use Errno ();
43	use Socket qw(AF_INET AF_UNIX SOCK_STREAM SOCK_DGRAM SOL_SOCKET SO_REUSEADDR);	40	use Socket qw(AF_INET AF_UNIX SOCK_STREAM SOCK_DGRAM SOL_SOCKET SO_REUSEADDR);
44		41
45	use AnyEvent ();	42	use AnyEvent (); BEGIN { AnyEvent::common_sense }
46	use AnyEvent::Util qw(guard fh_nonblocking AF_INET6);	43	use AnyEvent::Util qw(guard fh_nonblocking AF_INET6);
47	use AnyEvent::DNS ();	44	use AnyEvent::DNS ();
48		45
49	use base 'Exporter';	46	use base 'Exporter';
50		47
51	our @EXPORT = qw(	48	our @EXPORT = qw(
52	parse_hostport	49	getprotobyname
		50	parse_hostport format_hostport
53	parse_ipv4 parse_ipv6	51	parse_ipv4 parse_ipv6
54	parse_ip parse_address	52	parse_ip parse_address
		53	format_ipv4 format_ipv6
55	format_ip format_address	54	format_ip format_address
56	address_family	55	address_family
57	inet_aton	56	inet_aton
58	tcp_server	57	tcp_server
59	tcp_connect	58	tcp_connect
60	);	59	);
61		60
62	our $VERSION = 4.42;	61	our $VERSION = $AnyEvent::VERSION;
		62
		63	# used in cases where we may return immediately but want the
		64	# caller to do stuff first
		65	sub _postpone {
		66	my ($cb, @args) = (@_, $!);
		67
		68	my $w; $w = AE::timer 0, 0, sub {
		69	undef $w;
		70	$! = pop @args;
		71	$cb->(@args);
		72	};
		73	}
63		74
64	=item $ipn = parse_ipv4 $dotted_quad	75	=item $ipn = parse_ipv4 $dotted_quad
65		76
66	Tries to parse the given dotted quad IPv4 address and return it in	77	Tries to parse the given dotted quad IPv4 address and return it in
67	octet form (or undef when it isn't in a parsable format). Supports all	78	octet form (or undef when it isn't in a parsable format). Supports all
…		…
98	forms supported by parse_ipv4). Note that scope-id's are not supported	109	forms supported by parse_ipv4). Note that scope-id's are not supported
99	(and will not parse).	110	(and will not parse).
100		111
101	This function works similarly to C<inet_pton AF_INET6, ...>.	112	This function works similarly to C<inet_pton AF_INET6, ...>.
102		113
		114	Example:
		115
		116	print unpack "H*", parse_ipv6 "2002:5345::10.0.0.1";
		117	# => 2002534500000000000000000a000001
		118
103	=cut	119	=cut
104		120
105	sub parse_ipv6($) {	121	sub parse_ipv6($) {
106	# quick test to avoid longer processing	122	# quick test to avoid longer processing
107	my $n = $_[0] =~ y/://;	123	my $n = $_[0] =~ y/://;
…		…
144	? pack "S", AF_UNIX	160	? pack "S", AF_UNIX
145	: undef	161	: undef
146		162
147	}	163	}
148		164
149	=item $ipn = parse_address $text	165	=item $ipn = parse_address $ip
150		166
151	Combines C<parse_ipv4> and C<parse_ipv6> in one function. The address	167	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	168	here refers to the host address (not socket address) in network form
153	(binary).	169	(binary).
154		170
155	If the C<$text> is C<unix/>, then this function returns a special token	171	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	172	recognised by the other functions in this module to mean "UNIX domain
157	socket".	173	socket".
158		174
		175	If the C<$text> to parse is a mapped IPv4 in IPv6 address (:ffff::<ipv4>),
		176	then it will be treated as an IPv4 address. If you don't want that, you
		177	have to call C<parse_ipv4> and/or C<parse_ipv6> manually.
		178
		179	Example:
		180
		181	print unpack "H*", parse_address "10.1.2.3";
		182	# => 0a010203
		183
159	=item $text = AnyEvent::Socket::aton $ipn	184	=item $ipn = AnyEvent::Socket::aton $ip
160		185
161	Same as C<parse_address>, but not exported (think C<Socket::inet_aton> but	186	Same as C<parse_address>, but not exported (think C<Socket::inet_aton> but
162	I<without> name resolution).	187	I<without> name resolution).
163		188
164	=cut	189	=cut
165		190
166	sub parse_address($) {	191	sub parse_address($) {
167	&parse_ipv4 \|\| &parse_ipv6 \|\| &parse_unix	192	for (&parse_ipv6) {
		193	if ($_) {
		194	s/^\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff//;
		195	return $_;
		196	} else {
		197	return &parse_ipv4 \|\| &parse_unix
		198	}
		199	}
168	}	200	}
169		201
170	*aton = \&parse_address;	202	*aton = \&parse_address;
		203
		204	=item ($name, $aliases, $proto) = getprotobyname $name
		205
		206	Works like the builtin function of the same name, except it tries hard to
		207	work even on broken platforms (well, that's windows), where getprotobyname
		208	is traditionally very unreliable.
		209
		210	Example: get the protocol number for TCP (usually 6)
		211
		212	my $proto = getprotobyname "tcp";
		213
		214	=cut
		215
		216	# microsoft can't even get getprotobyname working (the etc/protocols file
		217	# gets lost fairly often on windows), so we have to hardcode some common
		218	# protocol numbers ourselves.
		219	our %PROTO_BYNAME;
		220
		221	$PROTO_BYNAME{tcp} = Socket::IPPROTO_TCP () if defined &Socket::IPPROTO_TCP;
		222	$PROTO_BYNAME{udp} = Socket::IPPROTO_UDP () if defined &Socket::IPPROTO_UDP;
		223	$PROTO_BYNAME{icmp} = Socket::IPPROTO_ICMP() if defined &Socket::IPPROTO_ICMP;
		224
		225	sub getprotobyname($) {
		226	my $name = lc shift;
		227
		228	defined (my $proton = $PROTO_BYNAME{$name} \|\| (getprotobyname $name)[2])
		229	or return;
		230
		231	($name, uc $name, $proton)
		232	}
171		233
172	=item ($host, $service) = parse_hostport $string[, $default_service]	234	=item ($host, $service) = parse_hostport $string[, $default_service]
173		235
174	Splitting a string of the form C<hostname:port> is a common	236	Splitting a string of the form C<hostname:port> is a common
175	problem. Unfortunately, just splitting on the colon makes it hard to	237	problem. Unfortunately, just splitting on the colon makes it hard to
…		…
191	ipv4or6 port e.g. "::1 443", "10.0.0.1 smtp"	253	ipv4or6 port e.g. "::1 443", "10.0.0.1 smtp"
192		254
193	It also supports defaulting the service name in a simple way by using	255	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	256	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	257	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	258	empty list. The same happens when a parse error was detected, such as a
197	hostname with a colon in it (the function is rather conservative, though).	259	hostname with a colon in it (the function is rather conservative, though).
198		260
199	Example:	261	Example:
200		262
201	print join ",", parse_hostport "localhost:443";	263	print join ",", parse_hostport "localhost:443";
…		…
244	return if $host =~ /:/ && !parse_ipv6 $host;	306	return if $host =~ /:/ && !parse_ipv6 $host;
245		307
246	($host, $port)	308	($host, $port)
247	}	309	}
248		310
		311	=item $string = format_hostport $host, $port
		312
		313	Takes a host (in textual form) and a port and formats in unambigiously in
		314	a way that C<parse_hostport> can parse it again. C<$port> can be C<undef>.
		315
		316	=cut
		317
		318	sub format_hostport($;$) {
		319	my ($host, $port) = @_;
		320
		321	$port = ":$port" if length $port;
		322	$host = "[$host]" if $host =~ /:/;
		323
		324	"$host$port"
		325	}
		326
249	=item $sa_family = address_family $ipn	327	=item $sa_family = address_family $ipn
250		328
251	Returns the address family/protocol-family (AF_xxx/PF_xxx, in one value :)	329	Returns the address family/protocol-family (AF_xxx/PF_xxx, in one value :)
252	of the given host address in network format.	330	of the given host address in network format.
253		331
…		…
259	: 16 == length $_[0]	337	: 16 == length $_[0]
260	? AF_INET6	338	? AF_INET6
261	: unpack "S", $_[0]	339	: unpack "S", $_[0]
262	}	340	}
263		341
		342	=item $text = format_ipv4 $ipn
		343
		344	Expects a four octet string representing a binary IPv4 address and returns
		345	its textual format. Rarely used, see C<format_address> for a nicer
		346	interface.
		347
		348	=item $text = format_ipv6 $ipn
		349
		350	Expects a sixteen octet string representing a binary IPv6 address and
		351	returns its textual format. Rarely used, see C<format_address> for a
		352	nicer interface.
		353
264	=item $text = format_address $ipn	354	=item $text = format_address $ipn
265		355
266	Covnvert a host address in network format (e.g. 4 octets for IPv4 or 16	356	Covnvert a host address in network format (e.g. 4 octets for IPv4 or 16
267	octets for IPv6) and convert it into textual form.	357	octets for IPv6) and convert it into textual form.
268		358
…		…
271	This function works similarly to C<inet_ntop AF_INET \|\| AF_INET6, ...>,	361	This function works similarly to C<inet_ntop AF_INET \|\| AF_INET6, ...>,
272	except it automatically detects the address type.	362	except it automatically detects the address type.
273		363
274	Returns C<undef> if it cannot detect the type.	364	Returns C<undef> if it cannot detect the type.
275		365
		366	If the C<$ipn> is a mapped IPv4 in IPv6 address (:ffff::<ipv4>), then just
		367	the contained IPv4 address will be returned. If you do not want that, you
		368	have to call C<format_ipv6> manually.
		369
		370	Example:
		371
		372	print format_address "\x01\x02\x03\x05";
		373	=> 1.2.3.5
		374
276	=item $text = AnyEvent::Socket::ntoa $ipn	375	=item $text = AnyEvent::Socket::ntoa $ipn
277		376
278	Same as format_address, but not exported (think C<inet_ntoa>).	377	Same as format_address, but not exported (think C<inet_ntoa>).
279		378
280	=cut	379	=cut
281		380
282	sub format_address;	381	sub format_ipv4($) {
		382	join ".", unpack "C4", $_[0]
		383	}
		384
		385	sub format_ipv6($) {
		386	if (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0 eq $_[0]) {
		387	return "::";
		388	} elsif (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.1 eq $_[0]) {
		389	return "::1";
		390	} elsif (v0.0.0.0.0.0.0.0.0.0.0.0 eq substr $_[0], 0, 12) {
		391	# v4compatible
		392	return "::" . format_ipv4 substr $_[0], 12;
		393	} elsif (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12) {
		394	# v4mapped
		395	return "::ffff:" . format_ipv4 substr $_[0], 12;
		396	} elsif (v0.0.0.0.0.0.0.0.255.255.0.0 eq substr $_[0], 0, 12) {
		397	# v4translated
		398	return "::ffff:0:" . format_ipv4 substr $_[0], 12;
		399	} else {
		400	my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0];
		401
		402	# this is rather sucky, I admit
		403	$ip =~ s/^0:(?:0:)*(0$)?/::/
		404	or $ip =~ s/(:0){7}$/::/ or $ip =~ s/(:0){7}/:/
		405	or $ip =~ s/(:0){6}$/::/ or $ip =~ s/(:0){6}/:/
		406	or $ip =~ s/(:0){5}$/::/ or $ip =~ s/(:0){5}/:/
		407	or $ip =~ s/(:0){4}$/::/ or $ip =~ s/(:0){4}/:/
		408	or $ip =~ s/(:0){3}$/::/ or $ip =~ s/(:0){3}/:/
		409	or $ip =~ s/(:0){2}$/::/ or $ip =~ s/(:0){2}/:/
		410	or $ip =~ s/(:0){1}$/::/ or $ip =~ s/(:0){1}/:/;
		411	return $ip
		412	}
		413	}
		414
283	sub format_address($) {	415	sub format_address($) {
284	my $af = address_family $_[0];	416	my $af = address_family $_[0];
285	if ($af == AF_INET) {	417	if ($af == AF_INET) {
286	return join ".", unpack "C4", $_[0]	418	return &format_ipv4;
287	} elsif ($af == AF_INET6) {	419	} 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;
295	} elsif (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12) {	420	return (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12)
296	# v4mapped	421	? format_ipv4 substr $_[0], 12
297	return "::ffff:" . format_address substr $_[0], 12;	422	: &format_ipv6;
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;
301	} else {
302	my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0];
303
304	# this is rather sucky, I admit
305	$ip =~ s/^0:(?:0:)*(0$)?/::/
306	or $ip =~ s/(:0){7}$/::/ or $ip =~ s/(:0){7}/:/
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}/:/;
313	return $ip
314	}
315	} elsif ($af == AF_UNIX) {	423	} elsif ($af == AF_UNIX) {
316	return "unix/"	424	return "unix/"
317	} else {	425	} else {
318	return undef	426	return undef
319	}	427	}
…		…
322	*ntoa = \&format_address;	430	*ntoa = \&format_address;
323		431
324	=item inet_aton $name_or_address, $cb->(@addresses)	432	=item inet_aton $name_or_address, $cb->(@addresses)
325		433
326	Works similarly to its Socket counterpart, except that it uses a	434	Works similarly to its Socket counterpart, except that it uses a
327	callback. Also, if a host has only an IPv6 address, this might be passed	435	callback. Use the length to distinguish between ipv4 and ipv6 (4 octets
328	to the callback instead (use the length to detect this - 4 for IPv4, 16	436	for IPv4, 16 for IPv6), or use C<format_address> to convert it to a more
329	for IPv6).	437	readable format.
330		438
331	Unlike the L<Socket> function of the same name, you can get multiple IPv4	439	Note that C<resolve_sockaddr>, while initially a more complex interface,
332	and IPv6 addresses as result (and maybe even other adrdess types).	440	resolves host addresses, IDNs, service names and SRV records and gives you
		441	an ordered list of socket addresses to try and should be preferred over
		442	C<inet_aton>.
		443
		444	Example.
		445
		446	inet_aton "www.google.com", my $cv = AE::cv;
		447	say unpack "H*", $_
		448	for $cv->recv;
		449	# => d155e363
		450	# => d155e367 etc.
		451
		452	inet_aton "ipv6.google.com", my $cv = AE::cv;
		453	say unpack "H*", $_
		454	for $cv->recv;
		455	# => 20014860a00300000000000000000068
333		456
334	=cut	457	=cut
335		458
336	sub inet_aton {	459	sub inet_aton {
337	my ($name, $cb) = @_;	460	my ($name, $cb) = @_;
…		…
343	} elsif ($name eq "localhost") { # rfc2606 et al.	466	} elsif ($name eq "localhost") { # rfc2606 et al.
344	$cb->(v127.0.0.1, v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.1);	467	$cb->(v127.0.0.1, v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.1);
345	} else {	468	} else {
346	require AnyEvent::DNS;	469	require AnyEvent::DNS;
347		470
348	# simple, bad suboptimal algorithm	471	my $ipv4 = $AnyEvent::PROTOCOL{ipv4};
		472	my $ipv6 = $AnyEvent::PROTOCOL{ipv6};
		473
		474	my @res;
		475
		476	my $cv = AE::cv {
		477	$cb->(map @$_, reverse @res);
		478	};
		479
		480	$cv->begin;
		481
		482	if ($ipv4) {
		483	$cv->begin;
349	AnyEvent::DNS::a ($name, sub {	484	AnyEvent::DNS::a ($name, sub {
350	if (@_) {	485	$res[$ipv4] = [map &parse_ipv4, @_];
351	$cb->(map +(parse_ipv4 $_), @_);
352	} else {
353	$cb->();	486	$cv->end;
354	#AnyEvent::DNS::aaaa ($name, $cb); need inet_pton
355	}	487	});
356	});	488	};
357	}
358	}
359		489
		490	if ($ipv6) {
		491	$cv->begin;
		492	AnyEvent::DNS::aaaa ($name, sub {
		493	$res[$ipv6] = [map &parse_ipv6, @_];
		494	$cv->end;
		495	});
		496	};
		497
		498	$cv->end;
		499	}
		500	}
		501
		502	BEGIN {
		503	*sockaddr_family = $Socket::VERSION >= 1.75
		504	? \&Socket::sockaddr_family
		505	: # for 5.6.x, we need to do something much more horrible
		506	(Socket::pack_sockaddr_in 0x5555, "\x55\x55\x55\x55"
		507	\| eval { Socket::pack_sockaddr_un "U" }) =~ /^\x00/
		508	? sub { unpack "xC", $_[0] }
		509	: sub { unpack "S" , $_[0] };
		510	}
		511
360	# check for broken platforms with extra field in sockaddr structure	512	# check for broken platforms with an extra field in sockaddr structure
361	# kind of a rfc vs. bsd issue, as usual (ok, normally it's a	513	# 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	514	# unix vs. bsd issue, a iso C vs. bsd issue or simply a
363	# correctness vs. bsd issue.	515	# correctness vs. bsd issue.)
364	my $pack_family = (0x55 == Socket::sockaddr_family "\x55\x55")	516	my $pack_family = 0x55 == sockaddr_family ("\x55\x55")
365	? "xC" : "S";	517	? "xC" : "S";
366		518
367	=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host	519	=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host
368		520
369	Pack the given port/host combination into a binary sockaddr	521	Pack the given port/host combination into a binary sockaddr
370	structure. Handles both IPv4 and IPv6 host addresses, as well as UNIX	522	structure. Handles both IPv4 and IPv6 host addresses, as well as UNIX
371	domain sockets (C<$host> == C<unix/> and C<$service> == absolute	523	domain sockets (C<$host> == C<unix/> and C<$service> == absolute
372	pathname).	524	pathname).
		525
		526	Example:
		527
		528	my $bind = AnyEvent::Socket::pack_sockaddr 43, v195.234.53.120;
		529	bind $socket, $bind
		530	or die "bind: $!";
373		531
374	=cut	532	=cut
375		533
376	sub pack_sockaddr($$) {	534	sub pack_sockaddr($$) {
377	my $af = address_family $_[1];	535	my $af = address_family $_[1];
…		…
404	is a special token that is understood by the other functions in this	562	is a special token that is understood by the other functions in this
405	module (C<format_address> converts it to C<unix/>).	563	module (C<format_address> converts it to C<unix/>).
406		564
407	=cut	565	=cut
408		566
		567	# perl contains a bug (imho) where it requires that the kernel always returns
		568	# sockaddr_un structures of maximum length (which is not, AFAICS, required
		569	# by any standard). try to 0-pad structures for the benefit of those platforms.
		570
		571	my $sa_un_zero = eval { Socket::pack_sockaddr_un "" }; $sa_un_zero ^= $sa_un_zero;
		572
409	sub unpack_sockaddr($) {	573	sub unpack_sockaddr($) {
410	my $af = Socket::sockaddr_family $_[0];	574	my $af = sockaddr_family $_[0];
411		575
412	if ($af == AF_INET) {	576	if ($af == AF_INET) {
413	Socket::unpack_sockaddr_in $_[0]	577	Socket::unpack_sockaddr_in $_[0]
414	} elsif ($af == AF_INET6) {	578	} elsif ($af == AF_INET6) {
415	unpack "x2 n x4 a16", $_[0]	579	unpack "x2 n x4 a16", $_[0]
416	} elsif ($af == AF_UNIX) {	580	} elsif ($af == AF_UNIX) {
417	((Socket::unpack_sockaddr_un $_[0]), pack "S", AF_UNIX)	581	((Socket::unpack_sockaddr_un $_[0] ^ $sa_un_zero), pack "S", AF_UNIX)
418	} else {	582	} else {
419	Carp::croak "unpack_sockaddr: unsupported protocol family $af";	583	Carp::croak "unpack_sockaddr: unsupported protocol family $af";
420	}	584	}
421	}	585	}
422		586
…		…
425	Tries to resolve the given nodename and service name into protocol families	589	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	590	and sockaddr structures usable to connect to this node and service in a
427	protocol-independent way. It works remotely similar to the getaddrinfo	591	protocol-independent way. It works remotely similar to the getaddrinfo
428	posix function.	592	posix function.
429		593
430	For internet addresses, C<$node> is either an IPv4 or IPv6 address or an	594	For internet addresses, C<$node> is either an IPv4 or IPv6 address, an
431	internet hostname, and C<$service> is either a service name (port name	595	internet hostname (DNS domain name or IDN), and C<$service> is either
432	from F</etc/services>) or a numerical port number. If both C<$node> and	596	a service name (port name from F</etc/services>) or a numerical port
433	C<$service> are names, then SRV records will be consulted to find the real	597	number. If both C<$node> and C<$service> are names, then SRV records
434	service, otherwise they will be used as-is. If you know that the service	598	will be consulted to find the real service, otherwise they will be
435	name is not in your services database, then you can specify the service in	599	used as-is. If you know that the service name is not in your services
436	the format C<name=port> (e.g. C<http=80>).	600	database, then you can specify the service in the format C<name=port>
		601	(e.g. C<http=80>).
437		602
438	For UNIX domain sockets, C<$node> must be the string C<unix/> and	603	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,	604	C<$service> must be the absolute pathname of the socket. In this case,
440	C<$proto> will be ignored.	605	C<$proto> will be ignored.
441		606
…		…
462		627
463	resolve_sockaddr "google.com", "http", 0, undef, undef, sub { ... };	628	resolve_sockaddr "google.com", "http", 0, undef, undef, sub { ... };
464		629
465	=cut	630	=cut
466		631
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($$$$$$) {	632	sub resolve_sockaddr($$$$$$) {
477	my ($node, $service, $proto, $family, $type, $cb) = @_;	633	my ($node, $service, $proto, $family, $type, $cb) = @_;
478		634
479	if ($node eq "unix/") {	635	if ($node eq "unix/") {
480	return $cb->() if $family \|\| $service !~ /^\//; # no can do	636	return $cb->() if $family \|\| $service !~ /^\//; # no can do
…		…
496	$family \|\|= 6 unless $AnyEvent::PROTOCOL{ipv4};	652	$family \|\|= 6 unless $AnyEvent::PROTOCOL{ipv4};
497		653
498	$proto \|\|= "tcp";	654	$proto \|\|= "tcp";
499	$type \|\|= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM;	655	$type \|\|= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM;
500		656
501	my $proton = $PROTO_BYNAME{lc $proto} \|\| (getprotobyname $proto)[2]	657	my $proton = getprotobyname $proto
502	or Carp::croak "$proto: protocol unknown";	658	or Carp::croak "$proto: protocol unknown";
503		659
504	my $port;	660	my $port;
505		661
506	if ($service =~ /^(\S+)=(\d+)$/) {	662	if ($service =~ /^(\S+)=(\d+)$/) {
…		…
510	} else {	666	} else {
511	$port = (getservbyname $service, $proto)[2]	667	$port = (getservbyname $service, $proto)[2]
512	or Carp::croak "$service/$proto: service unknown";	668	or Carp::croak "$service/$proto: service unknown";
513	}	669	}
514		670
515	my @target = [$node, $port];
516
517	# resolve a records / provide sockaddr structures	671	# resolve a records / provide sockaddr structures
518	my $resolve = sub {	672	my $resolve = sub {
		673	my @target = @_;
		674
519	my @res;	675	my @res;
520	my $cv = AnyEvent->condvar (cb => sub {	676	my $cv = AE::cv {
521	$cb->(	677	$cb->(
522	map $_->[2],	678	map $_->[2],
523	sort {	679	sort {
524	$AnyEvent::PROTOCOL{$b->[1]} <=> $AnyEvent::PROTOCOL{$a->[1]}	680	$AnyEvent::PROTOCOL{$b->[1]} <=> $AnyEvent::PROTOCOL{$a->[1]}
525	or $a->[0] <=> $b->[0]	681	or $a->[0] <=> $b->[0]
526	}	682	}
527	@res	683	@res
528	)	684	)
529	});	685	};
530		686
531	$cv->begin;	687	$cv->begin;
532	for my $idx (0 .. $#target) {	688	for my $idx (0 .. $#target) {
533	my ($node, $port) = @{ $target[$idx] };	689	my ($node, $port) = @{ $target[$idx] };
534		690
…		…
569	}	725	}
570	}	726	}
571	$cv->end;	727	$cv->end;
572	};	728	};
573		729
		730	$node = AnyEvent::Util::idn_to_ascii $node
		731	if $node =~ /[^\x00-\x7f]/;
		732
574	# try srv records, if applicable	733	# try srv records, if applicable
575	if ($node eq "localhost") {	734	if ($node eq "localhost") {
576	@target = (["127.0.0.1", $port], ["::1", $port]);	735	$resolve->(["127.0.0.1", $port], ["::1", $port]);
577	&$resolve;
578	} elsif (defined $service && !parse_address $node) {	736	} elsif (defined $service && !parse_address $node) {
579	AnyEvent::DNS::srv $service, $proto, $node, sub {	737	AnyEvent::DNS::srv $service, $proto, $node, sub {
580	my (@srv) = @_;	738	my (@srv) = @_;
581		739
582	# no srv records, continue traditionally
583	@srv	740	if (@srv) {
584	or return &$resolve;
585
586	# the only srv record has "." ("" here) => abort	741	# the only srv record has "." ("" here) => abort
587	$srv[0][2] ne "" \|\| $#srv	742	$srv[0][2] ne "" \|\| $#srv
588	or return $cb->();	743	or return $cb->();
589		744
590	# use srv records then	745	# use srv records then
		746	$resolve->(
591	@target = map ["$_->[3].", $_->[2]],	747	map ["$_->[3].", $_->[2]],
592	grep $_->[3] ne ".",	748	grep $_->[3] ne ".",
593	@srv;	749	@srv
594		750	);
595	&$resolve;	751	} else {
		752	# no srv records, continue traditionally
		753	$resolve->([$node, $port]);
		754	}
596	};	755	};
597	} else {	756	} else {
598	&$resolve;	757	# most common case
		758	$resolve->([$node, $port]);
599	}	759	}
600	}	760	}
601		761
602	=item $guard = tcp_connect $host, $service, $connect_cb[, $prepare_cb]	762	=item $guard = tcp_connect $host, $service, $connect_cb[, $prepare_cb]
603		763
604	This is a convenience function that creates a TCP socket and makes a 100%	764	This is a convenience function that creates a TCP socket and makes a
605	non-blocking connect to the given C<$host> (which can be a hostname or	765	100% non-blocking connect to the given C<$host> (which can be a DNS/IDN
606	a textual IP address, or the string C<unix/> for UNIX domain sockets)	766	hostname or a textual IP address, or the string C<unix/> for UNIX domain
607	and C<$service> (which can be a numeric port number or a service name,	767	sockets) and C<$service> (which can be a numeric port number or a service
608	or a C<servicename=portnumber> string, or the pathname to a UNIX domain	768	name, or a C<servicename=portnumber> string, or the pathname to a UNIX
609	socket).	769	domain socket).
610		770
611	If both C<$host> and C<$port> are names, then this function will use SRV	771	If both C<$host> and C<$port> are names, then this function will use SRV
612	records to locate the real target(s).	772	records to locate the real target(s).
613		773
614	In either case, it will create a list of target hosts (e.g. for multihomed	774	In either case, it will create a list of target hosts (e.g. for multihomed
615	hosts or hosts with both IPv4 and IPv6 addresses) and try to connect to	775	hosts or hosts with both IPv4 and IPv6 addresses) and try to connect to
616	each in turn.	776	each in turn.
617		777
618	If the connect is successful, then the C<$connect_cb> will be invoked with	778	After the connection is established, then the C<$connect_cb> will be
619	the socket file handle (in non-blocking mode) as first and the peer host	779	invoked with the socket file handle (in non-blocking mode) as first and
620	(as a textual IP address) and peer port as second and third arguments,	780	the peer host (as a textual IP address) and peer port as second and third
621	respectively. The fourth argument is a code reference that you can call	781	arguments, respectively. The fourth argument is a code reference that you
622	if, for some reason, you don't like this connection, which will cause	782	can call if, for some reason, you don't like this connection, which will
623	C<tcp_connect> to try the next one (or call your callback without any	783	cause C<tcp_connect> to try the next one (or call your callback without
624	arguments if there are no more connections). In most cases, you can simply	784	any arguments if there are no more connections). In most cases, you can
625	ignore this argument.	785	simply ignore this argument.
626		786
627	$cb->($filehandle, $host, $port, $retry)	787	$cb->($filehandle, $host, $port, $retry)
628		788
629	If the connect is unsuccessful, then the C<$connect_cb> will be invoked	789	If the connect is unsuccessful, then the C<$connect_cb> will be invoked
630	without any arguments and C<$!> will be set appropriately (with C<ENXIO>	790	without any arguments and C<$!> will be set appropriately (with C<ENXIO>
631	indicating a DNS resolution failure).	791	indicating a DNS resolution failure).
		792
		793	The callback will I<never> be invoked before C<tcp_connect> returns, even
		794	if C<tcp_connect> was able to connect immediately (e.g. on unix domain
		795	sockets).
632		796
633	The file handle is perfect for being plugged into L<AnyEvent::Handle>, but	797	The file handle is perfect for being plugged into L<AnyEvent::Handle>, but
634	can be used as a normal perl file handle as well.	798	can be used as a normal perl file handle as well.
635		799
636	Unless called in void context, C<tcp_connect> returns a guard object that	800	Unless called in void context, C<tcp_connect> returns a guard object that
…		…
675	or die "unable to connect: $!";	839	or die "unable to connect: $!";
676		840
677	my $handle; # avoid direct assignment so on_eof has it in scope.	841	my $handle; # avoid direct assignment so on_eof has it in scope.
678	$handle = new AnyEvent::Handle	842	$handle = new AnyEvent::Handle
679	fh => $fh,	843	fh => $fh,
		844	on_error => sub {
		845	warn "error $_[2]\n";
		846	$_[0]->destroy;
		847	},
680	on_eof => sub {	848	on_eof => sub {
681	undef $handle; # keep it alive till eof	849	$handle->destroy; # destroy handle
682	warn "done.\n";	850	warn "done.\n";
683	};	851	};
684		852
685	$handle->push_write ("GET / HTTP/1.0\015\012\015\012");	853	$handle->push_write ("GET / HTTP/1.0\015\012\015\012");
686		854
687	$handle->push_read_line ("\015\012\015\012", sub {	855	$handle->push_read (line => "\015\012\015\012", sub {
688	my ($handle, $line) = @_;	856	my ($handle, $line) = @_;
689		857
690	# print response header	858	# print response header
691	print "HEADER\n$line\n\nBODY\n";	859	print "HEADER\n$line\n\nBODY\n";
692		860
…		…
712	=cut	880	=cut
713		881
714	sub tcp_connect($$$;$) {	882	sub tcp_connect($$$;$) {
715	my ($host, $port, $connect, $prepare) = @_;	883	my ($host, $port, $connect, $prepare) = @_;
716		884
717	# see http://cr.yp.to/docs/connect.html for some background	885	# see http://cr.yp.to/docs/connect.html for some tricky aspects
718	# also http://advogato.org/article/672.html	886	# also http://advogato.org/article/672.html
719		887
720	my %state = ( fh => undef );	888	my %state = ( fh => undef );
721		889
722	# name/service to type/sockaddr resolution	890	# name/service to type/sockaddr resolution
…		…
725		893
726	$state{next} = sub {	894	$state{next} = sub {
727	return unless exists $state{fh};	895	return unless exists $state{fh};
728		896
729	my $target = shift @target	897	my $target = shift @target
730	or do {	898	or return (%state = (), _postpone $connect);
731	%state = ();
732	return $connect->();
733	};
734		899
735	my ($domain, $type, $proto, $sockaddr) = @$target;	900	my ($domain, $type, $proto, $sockaddr) = @$target;
736		901
737	# socket creation	902	# socket creation
738	socket $state{fh}, $domain, $type, $proto	903	socket $state{fh}, $domain, $type, $proto
…		…
742		907
743	my $timeout = $prepare && $prepare->($state{fh});	908	my $timeout = $prepare && $prepare->($state{fh});
744		909
745	$timeout \|\|= 30 if AnyEvent::WIN32;	910	$timeout \|\|= 30 if AnyEvent::WIN32;
746		911
747	$state{to} = AnyEvent->timer (after => $timeout, cb => sub {	912	$state{to} = AE::timer $timeout, 0, sub {
748	$! = &Errno::ETIMEDOUT;	913	$! = Errno::ETIMEDOUT;
749	$state{next}();	914	$state{next}();
750	}) if $timeout;	915	} if $timeout;
751		916
752	# called when the connect was successful, which,	917	# now connect
753	# in theory, could be the case immediately (but never is in practise)	918	if (
754	$state{connected} = sub {	919	(connect $state{fh}, $sockaddr)
755	delete $state{ww};	920	\|\| ($! == Errno::EINPROGRESS # POSIX
756	delete $state{to};	921	\|\| $! == Errno::EWOULDBLOCK
757		922	# WSAEINPROGRESS intentionally not checked - it means something else entirely
		923	\|\| $! == AnyEvent::Util::WSAEINVAL # not convinced, but doesn't hurt
		924	\|\| $! == AnyEvent::Util::WSAEWOULDBLOCK)
		925	) {
		926	$state{ww} = AE::io $state{fh}, 1, sub {
758	# we are connected, or maybe there was an error	927	# we are connected, or maybe there was an error
759	if (my $sin = getpeername $state{fh}) {	928	if (my $sin = getpeername $state{fh}) {
760	my ($port, $host) = unpack_sockaddr $sin;	929	my ($port, $host) = unpack_sockaddr $sin;
761		930
		931	delete $state{ww}; delete $state{to};
		932
762	my $guard = guard { %state = () };	933	my $guard = guard { %state = () };
763		934
764	$connect->(delete $state{fh}, format_address $host, $port, sub {	935	$connect->(delete $state{fh}, format_address $host, $port, sub {
765	$guard->cancel;	936	$guard->cancel;
		937	$state{next}();
		938	});
		939	} else {
		940	if ($! == Errno::ENOTCONN) {
		941	# dummy read to fetch real error code if !cygwin
		942	sysread $state{fh}, my $buf, 1;
		943
		944	# cygwin 1.5 continously reports "ready' but never delivers
		945	# an error with getpeername or sysread.
		946	# cygwin 1.7 only reports readyness once, but is otherwise
		947	# the same, which is atcually more broken.
		948	# Work around both by using unportable SO_ERROR for cygwin.
		949	$! = (unpack "l", getsockopt $state{fh}, Socket::SOL_SOCKET(), Socket::SO_ERROR()) \|\| Errno::EAGAIN
		950	if AnyEvent::CYGWIN && $! == Errno::EAGAIN;
		951	}
		952
		953	return if $! == Errno::EAGAIN; # skip spurious wake-ups
		954
		955	delete $state{ww}; delete $state{to};
		956
766	$state{next}();	957	$state{next}();
767	});	958	}
768	} else {
769	# dummy read to fetch real error code
770	sysread $state{fh}, my $buf, 1 if $! == &Errno::ENOTCONN;
771	$state{next}();
772	}	959	};
773	};
774
775	# now connect
776	if (connect $state{fh}, $sockaddr) {
777	$state{connected}->();
778	} elsif ($! == &Errno::EINPROGRESS # POSIX
779	\|\| $! == &Errno::EWOULDBLOCK
780	# WSAEINPROGRESS intentionally not checked - it means something else entirely
781	\|\| $! == AnyEvent::Util::WSAEINVAL # not convinced, but doesn't hurt
782	\|\| $! == AnyEvent::Util::WSAEWOULDBLOCK) {
783	$state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $state{connected});
784	} else {	960	} else {
785	$state{next}();	961	$state{next}();
786	}	962	}
787	};	963	};
788		964
789	$! = &Errno::ENXIO;	965	$! = Errno::ENXIO;
790	$state{next}();	966	$state{next}();
791	};	967	};
792		968
793	defined wantarray && guard { %state = () }	969	defined wantarray && guard { %state = () }
794	}	970	}
…		…
912	$len \|\|= 128;	1088	$len \|\|= 128;
913		1089
914	listen $state{fh}, $len	1090	listen $state{fh}, $len
915	or Carp::croak "listen: $!";	1091	or Carp::croak "listen: $!";
916		1092
917	$state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub {	1093	$state{aw} = AE::io $state{fh}, 0, sub {
918	# this closure keeps $state alive	1094	# this closure keeps $state alive
919	while (my $peer = accept my $fh, $state{fh}) {	1095	while ($state{fh} && (my $peer = accept my $fh, $state{fh})) {
920	fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not	1096	fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not
921		1097
922	my ($service, $host) = unpack_sockaddr $peer;	1098	my ($service, $host) = unpack_sockaddr $peer;
923	$accept->($fh, format_address $host, $service);	1099	$accept->($fh, format_address $host, $service);
924	}	1100	}
925	});	1101	};
926		1102
927	defined wantarray	1103	defined wantarray
928	? guard { %state = () } # clear fh and watcher, which breaks the circular dependency	1104	? guard { %state = () } # clear fh and watcher, which breaks the circular dependency
929	: ()	1105	: ()
930	}	1106	}

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents): Revision 1.80 by root, Fri Jun 26 06:33:17 2009 UTC vs. Revision 1.119 by root, Tue Jan 5 10:45:25 2010 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.80 by root, Fri Jun 26 06:33:17 2009 UTC vs.
Revision 1.119 by root, Tue Jan 5 10:45:25 2010 UTC