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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.60 by root, Thu Aug 21 18:45:16 2008 UTC vs.
Revision 1.117 by root, Sat Dec 5 02:50:48 2009 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.232;	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, service names and SRV records and gives you an
		441	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
…		…
443	C<sctp>. The default is currently C<tcp>, but in the future, this function	607	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	608	might try to use other protocols such as C<sctp>, depending on the socket
445	type and any SRV records it might find.	609	type and any SRV records it might find.
446		610
447	C<$family> must be either C<0> (meaning any protocol is OK), C<4> (use	611	C<$family> must be either C<0> (meaning any protocol is OK), C<4> (use
448	only IPv4) or C<6> (use only IPv6). This setting might be influenced by	612	only IPv4) or C<6> (use only IPv6). The default is influenced by
449	C<$ENV{PERL_ANYEVENT_PROTOCOLS}>.	613	C<$ENV{PERL_ANYEVENT_PROTOCOLS}>.
450		614
451	C<$type> must be C<SOCK_STREAM>, C<SOCK_DGRAM> or C<SOCK_SEQPACKET> (or	615	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).	616	C<undef> in which case it gets automatically chosen to be C<SOCK_STREAM>
		617	unless C<$proto> is C<udp>).
453		618
454	The callback will receive zero or more array references that contain	619	The callback will receive zero or more array references that contain
455	C<$family, $type, $proto> for use in C<socket> and a binary	620	C<$family, $type, $proto> for use in C<socket> and a binary
456	C<$sockaddr> for use in C<connect> (or C<bind>).	621	C<$sockaddr> for use in C<connect> (or C<bind>).
457		622
…		…
461		626
462	resolve_sockaddr "google.com", "http", 0, undef, undef, sub { ... };	627	resolve_sockaddr "google.com", "http", 0, undef, undef, sub { ... };
463		628
464	=cut	629	=cut
465		630
466	# microsoft can't even get getprotobyname working (the etc/protocols file
467	# gets lost fairly often on windows), so we have to hardcode some common
468	# protocol numbers ourselves.
469	our %PROTO_BYNAME;
470
471	$PROTO_BYNAME{tcp} = &Socket::IPPROTO_TCP if defined &Socket::IPPROTO_TCP;
472	$PROTO_BYNAME{udp} = &Socket::IPPROTO_UDP if defined &Socket::IPPROTO_UDP;
473	$PROTO_BYNAME{icmp} = &Socket::IPPROTO_ICMP if defined &Socket::IPPROTO_ICMP;
474
475	sub resolve_sockaddr($$$$$$) {	631	sub resolve_sockaddr($$$$$$) {
476	my ($node, $service, $proto, $family, $type, $cb) = @_;	632	my ($node, $service, $proto, $family, $type, $cb) = @_;
477		633
478	if ($node eq "unix/") {	634	if ($node eq "unix/") {
479	return $cb->() if $family \|\| !/^\//; # no can do	635	return $cb->() if $family \|\| $service !~ /^\//; # no can do
480		636
481	return $cb->([AF_UNIX, $type, 0, Socket::pack_sockaddr_un $service]);	637	return $cb->([AF_UNIX, defined $type ? $type : SOCK_STREAM, 0, Socket::pack_sockaddr_un $service]);
482	}	638	}
483		639
484	unless (AF_INET6) {	640	unless (AF_INET6) {
485	$family != 6	641	$family != 6
486	or return $cb->();	642	or return $cb->();
…		…
495	$family \|\|= 6 unless $AnyEvent::PROTOCOL{ipv4};	651	$family \|\|= 6 unless $AnyEvent::PROTOCOL{ipv4};
496		652
497	$proto \|\|= "tcp";	653	$proto \|\|= "tcp";
498	$type \|\|= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM;	654	$type \|\|= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM;
499		655
500	my $proton = $PROTO_BYNAME{lc $proto} \|\| (getprotobyname $proto)[2]	656	my $proton = getprotobyname $proto
501	or Carp::croak "$proto: protocol unknown";	657	or Carp::croak "$proto: protocol unknown";
502		658
503	my $port;	659	my $port;
504		660
505	if ($service =~ /^(\S+)=(\d+)$/) {	661	if ($service =~ /^(\S+)=(\d+)$/) {
…		…
514	my @target = [$node, $port];	670	my @target = [$node, $port];
515		671
516	# resolve a records / provide sockaddr structures	672	# resolve a records / provide sockaddr structures
517	my $resolve = sub {	673	my $resolve = sub {
518	my @res;	674	my @res;
519	my $cv = AnyEvent->condvar (cb => sub {	675	my $cv = AE::cv {
520	$cb->(	676	$cb->(
521	map $_->[2],	677	map $_->[2],
522	sort {	678	sort {
523	$AnyEvent::PROTOCOL{$b->[1]} <=> $AnyEvent::PROTOCOL{$a->[1]}	679	$AnyEvent::PROTOCOL{$b->[1]} <=> $AnyEvent::PROTOCOL{$a->[1]}
524	or $a->[0] <=> $b->[0]	680	or $a->[0] <=> $b->[0]
525	}	681	}
526	@res	682	@res
527	)	683	)
528	});	684	};
529		685
530	$cv->begin;	686	$cv->begin;
531	for my $idx (0 .. $#target) {	687	for my $idx (0 .. $#target) {
532	my ($node, $port) = @{ $target[$idx] };	688	my ($node, $port) = @{ $target[$idx] };
533		689
…		…
612		768
613	In either case, it will create a list of target hosts (e.g. for multihomed	769	In either case, it will create a list of target hosts (e.g. for multihomed
614	hosts or hosts with both IPv4 and IPv6 addresses) and try to connect to	770	hosts or hosts with both IPv4 and IPv6 addresses) and try to connect to
615	each in turn.	771	each in turn.
616		772
617	If the connect is successful, then the C<$connect_cb> will be invoked with	773	After the connection is established, then the C<$connect_cb> will be
618	the socket file handle (in non-blocking mode) as first and the peer host	774	invoked with the socket file handle (in non-blocking mode) as first and
619	(as a textual IP address) and peer port as second and third arguments,	775	the peer host (as a textual IP address) and peer port as second and third
620	respectively. The fourth argument is a code reference that you can call	776	arguments, respectively. The fourth argument is a code reference that you
621	if, for some reason, you don't like this connection, which will cause	777	can call if, for some reason, you don't like this connection, which will
622	C<tcp_connect> to try the next one (or call your callback without any	778	cause C<tcp_connect> to try the next one (or call your callback without
623	arguments if there are no more connections). In most cases, you can simply	779	any arguments if there are no more connections). In most cases, you can
624	ignore this argument.	780	simply ignore this argument.
625		781
626	$cb->($filehandle, $host, $port, $retry)	782	$cb->($filehandle, $host, $port, $retry)
627		783
628	If the connect is unsuccessful, then the C<$connect_cb> will be invoked	784	If the connect is unsuccessful, then the C<$connect_cb> will be invoked
629	without any arguments and C<$!> will be set appropriately (with C<ENXIO>	785	without any arguments and C<$!> will be set appropriately (with C<ENXIO>
630	indicating a DNS resolution failure).	786	indicating a DNS resolution failure).
		787
		788	The callback will I<never> be invoked before C<tcp_connect> returns, even
		789	if C<tcp_connect> was able to connect immediately (e.g. on unix domain
		790	sockets).
631		791
632	The file handle is perfect for being plugged into L<AnyEvent::Handle>, but	792	The file handle is perfect for being plugged into L<AnyEvent::Handle>, but
633	can be used as a normal perl file handle as well.	793	can be used as a normal perl file handle as well.
634		794
635	Unless called in void context, C<tcp_connect> returns a guard object that	795	Unless called in void context, C<tcp_connect> returns a guard object that
…		…
674	or die "unable to connect: $!";	834	or die "unable to connect: $!";
675		835
676	my $handle; # avoid direct assignment so on_eof has it in scope.	836	my $handle; # avoid direct assignment so on_eof has it in scope.
677	$handle = new AnyEvent::Handle	837	$handle = new AnyEvent::Handle
678	fh => $fh,	838	fh => $fh,
		839	on_error => sub {
		840	warn "error $_[2]\n";
		841	$_[0]->destroy;
		842	},
679	on_eof => sub {	843	on_eof => sub {
680	undef $handle; # keep it alive till eof	844	$handle->destroy; # destroy handle
681	warn "done.\n";	845	warn "done.\n";
682	};	846	};
683		847
684	$handle->push_write ("GET / HTTP/1.0\015\012\015\012");	848	$handle->push_write ("GET / HTTP/1.0\015\012\015\012");
685		849
686	$handle->push_read_line ("\015\012\015\012", sub {	850	$handle->push_read (line => "\015\012\015\012", sub {
687	my ($handle, $line) = @_;	851	my ($handle, $line) = @_;
688		852
689	# print response header	853	# print response header
690	print "HEADER\n$line\n\nBODY\n";	854	print "HEADER\n$line\n\nBODY\n";
691		855
…		…
717	# also http://advogato.org/article/672.html	881	# also http://advogato.org/article/672.html
718		882
719	my %state = ( fh => undef );	883	my %state = ( fh => undef );
720		884
721	# name/service to type/sockaddr resolution	885	# name/service to type/sockaddr resolution
722	resolve_sockaddr $host, $port, 0, 0, 0, sub {	886	resolve_sockaddr $host, $port, 0, 0, undef, sub {
723	my @target = @_;	887	my @target = @_;
724		888
725	$state{next} = sub {	889	$state{next} = sub {
726	return unless exists $state{fh};	890	return unless exists $state{fh};
727		891
728	my $target = shift @target	892	my $target = shift @target
729	or do {	893	or return (%state = (), _postpone $connect);
730	%state = ();
731	return $connect->();
732	};
733		894
734	my ($domain, $type, $proto, $sockaddr) = @$target;	895	my ($domain, $type, $proto, $sockaddr) = @$target;
735		896
736	# socket creation	897	# socket creation
737	socket $state{fh}, $domain, $type, $proto	898	socket $state{fh}, $domain, $type, $proto
…		…
741		902
742	my $timeout = $prepare && $prepare->($state{fh});	903	my $timeout = $prepare && $prepare->($state{fh});
743		904
744	$timeout \|\|= 30 if AnyEvent::WIN32;	905	$timeout \|\|= 30 if AnyEvent::WIN32;
745		906
746	$state{to} = AnyEvent->timer (after => $timeout, cb => sub {	907	$state{to} = AE::timer $timeout, 0, sub {
747	$! = &Errno::ETIMEDOUT;	908	$! = Errno::ETIMEDOUT;
748	$state{next}();	909	$state{next}();
749	}) if $timeout;	910	} if $timeout;
750		911
751	# called when the connect was successful, which,	912	# now connect
752	# in theory, could be the case immediately (but never is in practise)	913	if (
753	my $connected = sub {	914	(connect $state{fh}, $sockaddr)
754	delete $state{ww};	915	\|\| ($! == Errno::EINPROGRESS # POSIX
755	delete $state{to};	916	\|\| $! == Errno::EWOULDBLOCK
756		917	# WSAEINPROGRESS intentionally not checked - it means something else entirely
		918	\|\| $! == AnyEvent::Util::WSAEINVAL # not convinced, but doesn't hurt
		919	\|\| $! == AnyEvent::Util::WSAEWOULDBLOCK)
		920	) {
		921	$state{ww} = AE::io $state{fh}, 1, sub {
757	# we are connected, or maybe there was an error	922	# we are connected, or maybe there was an error
758	if (my $sin = getpeername $state{fh}) {	923	if (my $sin = getpeername $state{fh}) {
759	my ($port, $host) = unpack_sockaddr $sin;	924	my ($port, $host) = unpack_sockaddr $sin;
760		925
		926	delete $state{ww}; delete $state{to};
		927
761	my $guard = guard {	928	my $guard = guard { %state = () };
762	%state = ();
763	};
764		929
765	$connect->($state{fh}, format_address $host, $port, sub {	930	$connect->(delete $state{fh}, format_address $host, $port, sub {
766	$guard->cancel;	931	$guard->cancel;
		932	$state{next}();
		933	});
		934	} else {
		935	# dummy read to fetch real error code
		936	sysread $state{fh}, my $buf, 1 if $! == Errno::ENOTCONN;
		937
		938	return if $! == Errno::EAGAIN; # skip spurious wake-ups
		939
		940	delete $state{ww}; delete $state{to};
		941
767	$state{next}();	942	$state{next}();
768	});	943	}
769	} else {
770	# dummy read to fetch real error code
771	sysread $state{fh}, my $buf, 1 if $! == &Errno::ENOTCONN;
772	$state{next}();
773	}	944	};
774	};
775
776	# now connect
777	if (connect $state{fh}, $sockaddr) {
778	$connected->();
779	} elsif ($! == &Errno::EINPROGRESS # POSIX
780	\|\| $! == &Errno::EWOULDBLOCK
781	# WSAEINPROGRESS intentionally not checked - it means something else entirely
782	\|\| $! == AnyEvent::Util::WSAEINVAL # not convinced, but doesn't hurt
783	\|\| $! == AnyEvent::Util::WSAEWOULDBLOCK) {
784	$state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $connected);
785	} else {	945	} else {
786	$state{next}();	946	$state{next}();
787	}	947	}
788	};	948	};
789		949
790	$! = &Errno::ENXIO;	950	$! = Errno::ENXIO;
791	$state{next}();	951	$state{next}();
792	};	952	};
793		953
794	defined wantarray && guard { %state = () }	954	defined wantarray && guard { %state = () }
795	}	955	}
…		…
854	}, sub {	1014	}, sub {
855	my ($fh, $thishost, $thisport) = @_;	1015	my ($fh, $thishost, $thisport) = @_;
856	warn "bound to $thishost, port $thisport\n";	1016	warn "bound to $thishost, port $thisport\n";
857	};	1017	};
858		1018
		1019	Example: bind a server on a unix domain socket.
		1020
		1021	tcp_server "unix/", "/tmp/mydir/mysocket", sub {
		1022	my ($fh) = @_;
		1023	};
		1024
859	=cut	1025	=cut
860		1026
861	sub tcp_server($$$;$) {	1027	sub tcp_server($$$;$) {
862	my ($host, $service, $accept, $prepare) = @_;	1028	my ($host, $service, $accept, $prepare) = @_;
863		1029
…		…
907	$len \|\|= 128;	1073	$len \|\|= 128;
908		1074
909	listen $state{fh}, $len	1075	listen $state{fh}, $len
910	or Carp::croak "listen: $!";	1076	or Carp::croak "listen: $!";
911		1077
912	$state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub {	1078	$state{aw} = AE::io $state{fh}, 0, sub {
913	# this closure keeps $state alive	1079	# this closure keeps $state alive
914	while (my $peer = accept my $fh, $state{fh}) {	1080	while ($state{fh} && (my $peer = accept my $fh, $state{fh})) {
915	fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not	1081	fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not
916		1082
917	my ($service, $host) = unpack_sockaddr $peer;	1083	my ($service, $host) = unpack_sockaddr $peer;
918	$accept->($fh, format_address $host, $service);	1084	$accept->($fh, format_address $host, $service);
919	}	1085	}
920	});	1086	};
921		1087
922	defined wantarray	1088	defined wantarray
923	? guard { %state = () } # clear fh and watcher, which breaks the circular dependency	1089	? guard { %state = () } # clear fh and watcher, which breaks the circular dependency
924	: ()	1090	: ()
925	}	1091	}

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents): Revision 1.60 by root, Thu Aug 21 18:45:16 2008 UTC vs. Revision 1.117 by root, Sat Dec 5 02:50:48 2009 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.60 by root, Thu Aug 21 18:45:16 2008 UTC vs.
Revision 1.117 by root, Sat Dec 5 02:50:48 2009 UTC