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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.87 by root, Thu Jul 9 08:31:16 2009 UTC vs.
Revision 1.130 by root, Fri Jan 14 17:43:11 2011 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
55	format_ipv4 format_ipv6	53	format_ipv4 format_ipv6
56	format_ip format_address	54	format_ip format_address
57	address_family	55	address_family
58	inet_aton	56	inet_aton
59	tcp_server	57	tcp_server
60	tcp_connect	58	tcp_connect
61	);	59	);
62		60
63	our $VERSION = 4.81;	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	}
64		74
65	=item $ipn = parse_ipv4 $dotted_quad	75	=item $ipn = parse_ipv4 $dotted_quad
66		76
67	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
68	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
…		…
99	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
100	(and will not parse).	110	(and will not parse).
101		111
102	This function works similarly to C<inet_pton AF_INET6, ...>.	112	This function works similarly to C<inet_pton AF_INET6, ...>.
103		113
		114	Example:
		115
		116	print unpack "H*", parse_ipv6 "2002:5345::10.0.0.1";
		117	# => 2002534500000000000000000a000001
		118
104	=cut	119	=cut
105		120
106	sub parse_ipv6($) {	121	sub parse_ipv6($) {
107	# quick test to avoid longer processing	122	# quick test to avoid longer processing
108	my $n = $_[0] =~ y/://;	123	my $n = $_[0] =~ y/://;
…		…
158	socket".	173	socket".
159		174
160	If the C<$text> to parse is a mapped IPv4 in IPv6 address (:ffff::<ipv4>),	175	If the C<$text> to parse is a mapped IPv4 in IPv6 address (:ffff::<ipv4>),
161	then it will be treated as an IPv4 address. If you don't want that, you	176	then it will be treated as an IPv4 address. If you don't want that, you
162	have to call C<parse_ipv4> and/or C<parse_ipv6> manually.	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
163		183
164	=item $ipn = AnyEvent::Socket::aton $ip	184	=item $ipn = AnyEvent::Socket::aton $ip
165		185
166	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
167	I<without> name resolution).	187	I<without> name resolution).
…		…
179	}	199	}
180	}	200	}
181		201
182	*aton = \&parse_address;	202	*aton = \&parse_address;
183		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	}
		233
184	=item ($host, $service) = parse_hostport $string[, $default_service]	234	=item ($host, $service) = parse_hostport $string[, $default_service]
185		235
186	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
187	problem. Unfortunately, just splitting on the colon makes it hard to	237	problem. Unfortunately, just splitting on the colon makes it hard to
188	specify IPv6 addresses and doesn't support the less common but well	238	specify IPv6 addresses and doesn't support the less common but well
…		…
203	ipv4or6 port e.g. "::1 443", "10.0.0.1 smtp"	253	ipv4or6 port e.g. "::1 443", "10.0.0.1 smtp"
204		254
205	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
206	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
207	detected nor a default was specified, then this function returns the	257	detected nor a default was specified, then this function returns the
208	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
209	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).
210		260
211	Example:	261	Example:
212		262
213	print join ",", parse_hostport "localhost:443";	263	print join ",", parse_hostport "localhost:443";
…		…
256	return if $host =~ /:/ && !parse_ipv6 $host;	306	return if $host =~ /:/ && !parse_ipv6 $host;
257		307
258	($host, $port)	308	($host, $port)
259	}	309	}
260		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
261	=item $sa_family = address_family $ipn	327	=item $sa_family = address_family $ipn
262		328
263	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 :)
264	of the given host address in network format.	330	of the given host address in network format.
265		331
…		…
299		365
300	If the C<$ipn> is a mapped IPv4 in IPv6 address (:ffff::<ipv4>), then just	366	If the C<$ipn> is a mapped IPv4 in IPv6 address (:ffff::<ipv4>), then just
301	the contained IPv4 address will be returned. If you do not want that, you	367	the contained IPv4 address will be returned. If you do not want that, you
302	have to call C<format_ipv6> manually.	368	have to call C<format_ipv6> manually.
303		369
		370	Example:
		371
		372	print format_address "\x01\x02\x03\x05";
		373	=> 1.2.3.5
		374
304	=item $text = AnyEvent::Socket::ntoa $ipn	375	=item $text = AnyEvent::Socket::ntoa $ipn
305		376
306	Same as format_address, but not exported (think C<inet_ntoa>).	377	Same as format_address, but not exported (think C<inet_ntoa>).
307		378
308	=cut	379	=cut
…		…
310	sub format_ipv4($) {	381	sub format_ipv4($) {
311	join ".", unpack "C4", $_[0]	382	join ".", unpack "C4", $_[0]
312	}	383	}
313		384
314	sub format_ipv6($) {	385	sub format_ipv6($) {
		386	if ($_[0] =~ /^\x00\x00\x00\x00\x00\x00\x00\x00/) {
315	if (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0 eq $_[0]) {	387	if (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0 eq $_[0]) {
316	return "::";	388	return "::";
317	} elsif (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.1 eq $_[0]) {	389	} elsif (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.1 eq $_[0]) {
318	return "::1";	390	return "::1";
319	} elsif (v0.0.0.0.0.0.0.0.0.0.0.0 eq substr $_[0], 0, 12) {	391	} elsif (v0.0.0.0.0.0.0.0.0.0.0.0 eq substr $_[0], 0, 12) {
320	# v4compatible	392	# v4compatible
321	return "::" . format_ipv4 substr $_[0], 12;	393	return "::" . format_ipv4 substr $_[0], 12;
322	} elsif (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12) {	394	} elsif (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12) {
323	# v4mapped	395	# v4mapped
324	return "::ffff:" . format_ipv4 substr $_[0], 12;	396	return "::ffff:" . format_ipv4 substr $_[0], 12;
325	} elsif (v0.0.0.0.0.0.0.0.255.255.0.0 eq substr $_[0], 0, 12) {	397	} elsif (v0.0.0.0.0.0.0.0.255.255.0.0 eq substr $_[0], 0, 12) {
326	# v4translated	398	# v4translated
327	return "::ffff:0:" . format_ipv4 substr $_[0], 12;	399	return "::ffff:0:" . format_ipv4 substr $_[0], 12;
328	} else {	400	}
		401	}
		402
329	my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0];	403	my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0];
330		404
331	# this is rather sucky, I admit	405	# this is admittedly rather sucky
332	$ip =~ s/^0:(?:0:)*(0$)?/::/	406	$ip =~ s/(?:^\|:) 0:0:0:0:0:0:0 (?:$\|:)/::/x
333	or $ip =~ s/(:0){7}$/::/ or $ip =~ s/(:0){7}/:/	407	or $ip =~ s/(?:^\|:) 0:0:0:0:0:0 (?:$\|:)/::/x
334	or $ip =~ s/(:0){6}$/::/ or $ip =~ s/(:0){6}/:/	408	or $ip =~ s/(?:^\|:) 0:0:0:0:0 (?:$\|:)/::/x
335	or $ip =~ s/(:0){5}$/::/ or $ip =~ s/(:0){5}/:/	409	or $ip =~ s/(?:^\|:) 0:0:0:0 (?:$\|:)/::/x
336	or $ip =~ s/(:0){4}$/::/ or $ip =~ s/(:0){4}/:/	410	or $ip =~ s/(?:^\|:) 0:0:0 (?:$\|:)/::/x
337	or $ip =~ s/(:0){3}$/::/ or $ip =~ s/(:0){3}/:/	411	or $ip =~ s/(?:^\|:) 0:0 (?:$\|:)/::/x
338	or $ip =~ s/(:0){2}$/::/ or $ip =~ s/(:0){2}/:/	412	or $ip =~ s/(?:^\|:) 0 (?:$\|:)/::/x;
339	or $ip =~ s/(:0){1}$/::/ or $ip =~ s/(:0){1}/:/;	413
340	return $ip	414	$ip
341	}
342	}	415	}
343		416
344	sub format_address($) {	417	sub format_address($) {
345	my $af = address_family $_[0];	418	if (4 == length $_[0]) {
346	if ($af == AF_INET) {
347	return &format_ipv4;	419	return &format_ipv4;
348	} elsif ($af == AF_INET6) {	420	} elsif (16 == length $_[0]) {
349	return (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12)	421	return $_[0] =~ /^\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff(....)$/s
350	? format_ipv4 substr $_[0], 12	422	? format_ipv4 $1
351	: &format_ipv6;	423	: &format_ipv6;
352	} elsif ($af == AF_UNIX) {	424	} elsif (AF_UNIX == address_family $_[0]) {
353	return "unix/"	425	return "unix/"
354	} else {	426	} else {
355	return undef	427	return undef
356	}	428	}
357	}	429	}
…		…
359	*ntoa = \&format_address;	431	*ntoa = \&format_address;
360		432
361	=item inet_aton $name_or_address, $cb->(@addresses)	433	=item inet_aton $name_or_address, $cb->(@addresses)
362		434
363	Works similarly to its Socket counterpart, except that it uses a	435	Works similarly to its Socket counterpart, except that it uses a
364	callback. Also, if a host has only an IPv6 address, this might be passed	436	callback. Use the length to distinguish between ipv4 and ipv6 (4 octets
365	to the callback instead (use the length to detect this - 4 for IPv4, 16	437	for IPv4, 16 for IPv6), or use C<format_address> to convert it to a more
366	for IPv6).	438	readable format.
367		439
368	Unlike the L<Socket> function of the same name, you can get multiple IPv4	440	Note that C<resolve_sockaddr>, while initially a more complex interface,
369	and IPv6 addresses as result (and maybe even other adrdess types).	441	resolves host addresses, IDNs, service names and SRV records and gives you
		442	an ordered list of socket addresses to try and should be preferred over
		443	C<inet_aton>.
		444
		445	Example.
		446
		447	inet_aton "www.google.com", my $cv = AE::cv;
		448	say unpack "H*", $_
		449	for $cv->recv;
		450	# => d155e363
		451	# => d155e367 etc.
		452
		453	inet_aton "ipv6.google.com", my $cv = AE::cv;
		454	say unpack "H*", $_
		455	for $cv->recv;
		456	# => 20014860a00300000000000000000068
370		457
371	=cut	458	=cut
372		459
373	sub inet_aton {	460	sub inet_aton {
374	my ($name, $cb) = @_;	461	my ($name, $cb) = @_;
…		…
380	} elsif ($name eq "localhost") { # rfc2606 et al.	467	} elsif ($name eq "localhost") { # rfc2606 et al.
381	$cb->(v127.0.0.1, v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.1);	468	$cb->(v127.0.0.1, v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.1);
382	} else {	469	} else {
383	require AnyEvent::DNS;	470	require AnyEvent::DNS;
384		471
385	# simple, bad suboptimal algorithm	472	my $ipv4 = $AnyEvent::PROTOCOL{ipv4};
		473	my $ipv6 = $AnyEvent::PROTOCOL{ipv6};
		474
		475	my @res;
		476
		477	my $cv = AE::cv {
		478	$cb->(map @$_, reverse @res);
		479	};
		480
		481	$cv->begin;
		482
		483	if ($ipv4) {
		484	$cv->begin;
386	AnyEvent::DNS::a ($name, sub {	485	AnyEvent::DNS::a ($name, sub {
387	if (@_) {	486	$res[$ipv4] = [map &parse_ipv4, @_];
388	$cb->(map +(parse_ipv4 $_), @_);
389	} else {
390	$cb->();	487	$cv->end;
391	#AnyEvent::DNS::aaaa ($name, $cb); need inet_pton
392	}	488	});
393	});	489	};
394	}
395	}
396		490
		491	if ($ipv6) {
		492	$cv->begin;
		493	AnyEvent::DNS::aaaa ($name, sub {
		494	$res[$ipv6] = [map &parse_ipv6, @_];
		495	$cv->end;
		496	});
		497	};
		498
		499	$cv->end;
		500	}
		501	}
		502
		503	BEGIN {
		504	*sockaddr_family = $Socket::VERSION >= 1.75
		505	? \&Socket::sockaddr_family
		506	: # for 5.6.x, we need to do something much more horrible
		507	(Socket::pack_sockaddr_in 0x5555, "\x55\x55\x55\x55"
		508	\| eval { Socket::pack_sockaddr_un "U" }) =~ /^\x00/
		509	? sub { unpack "xC", $_[0] }
		510	: sub { unpack "S" , $_[0] };
		511	}
		512
397	# check for broken platforms with extra field in sockaddr structure	513	# check for broken platforms with an extra field in sockaddr structure
398	# kind of a rfc vs. bsd issue, as usual (ok, normally it's a	514	# kind of a rfc vs. bsd issue, as usual (ok, normally it's a
399	# unix vs. bsd issue, a iso C vs. bsd issue or simply a	515	# unix vs. bsd issue, a iso C vs. bsd issue or simply a
400	# correctness vs. bsd issue.	516	# correctness vs. bsd issue.)
401	my $pack_family = (0x55 == Socket::sockaddr_family "\x55\x55")	517	my $pack_family = 0x55 == sockaddr_family ("\x55\x55")
402	? "xC" : "S";	518	? "xC" : "S";
403		519
404	=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host	520	=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host
405		521
406	Pack the given port/host combination into a binary sockaddr	522	Pack the given port/host combination into a binary sockaddr
407	structure. Handles both IPv4 and IPv6 host addresses, as well as UNIX	523	structure. Handles both IPv4 and IPv6 host addresses, as well as UNIX
408	domain sockets (C<$host> == C<unix/> and C<$service> == absolute	524	domain sockets (C<$host> == C<unix/> and C<$service> == absolute
409	pathname).	525	pathname).
		526
		527	Example:
		528
		529	my $bind = AnyEvent::Socket::pack_sockaddr 43, v195.234.53.120;
		530	bind $socket, $bind
		531	or die "bind: $!";
410		532
411	=cut	533	=cut
412		534
413	sub pack_sockaddr($$) {	535	sub pack_sockaddr($$) {
414	my $af = address_family $_[1];	536	my $af = address_family $_[1];
…		…
441	is a special token that is understood by the other functions in this	563	is a special token that is understood by the other functions in this
442	module (C<format_address> converts it to C<unix/>).	564	module (C<format_address> converts it to C<unix/>).
443		565
444	=cut	566	=cut
445		567
		568	# perl contains a bug (imho) where it requires that the kernel always returns
		569	# sockaddr_un structures of maximum length (which is not, AFAICS, required
		570	# by any standard). try to 0-pad structures for the benefit of those platforms.
		571
		572	my $sa_un_zero = eval { Socket::pack_sockaddr_un "" }; $sa_un_zero ^= $sa_un_zero;
		573
446	sub unpack_sockaddr($) {	574	sub unpack_sockaddr($) {
447	my $af = Socket::sockaddr_family $_[0];	575	my $af = sockaddr_family $_[0];
448		576
449	if ($af == AF_INET) {	577	if ($af == AF_INET) {
450	Socket::unpack_sockaddr_in $_[0]	578	Socket::unpack_sockaddr_in $_[0]
451	} elsif ($af == AF_INET6) {	579	} elsif ($af == AF_INET6) {
452	unpack "x2 n x4 a16", $_[0]	580	unpack "x2 n x4 a16", $_[0]
453	} elsif ($af == AF_UNIX) {	581	} elsif ($af == AF_UNIX) {
454	((Socket::unpack_sockaddr_un $_[0]), pack "S", AF_UNIX)	582	((Socket::unpack_sockaddr_un $_[0] ^ $sa_un_zero), pack "S", AF_UNIX)
455	} else {	583	} else {
456	Carp::croak "unpack_sockaddr: unsupported protocol family $af";	584	Carp::croak "unpack_sockaddr: unsupported protocol family $af";
457	}	585	}
458	}	586	}
459		587
…		…
462	Tries to resolve the given nodename and service name into protocol families	590	Tries to resolve the given nodename and service name into protocol families
463	and sockaddr structures usable to connect to this node and service in a	591	and sockaddr structures usable to connect to this node and service in a
464	protocol-independent way. It works remotely similar to the getaddrinfo	592	protocol-independent way. It works remotely similar to the getaddrinfo
465	posix function.	593	posix function.
466		594
467	For internet addresses, C<$node> is either an IPv4 or IPv6 address or an	595	For internet addresses, C<$node> is either an IPv4 or IPv6 address, an
468	internet hostname, and C<$service> is either a service name (port name	596	internet hostname (DNS domain name or IDN), and C<$service> is either
469	from F</etc/services>) or a numerical port number. If both C<$node> and	597	a service name (port name from F</etc/services>) or a numerical port
470	C<$service> are names, then SRV records will be consulted to find the real	598	number. If both C<$node> and C<$service> are names, then SRV records
471	service, otherwise they will be used as-is. If you know that the service	599	will be consulted to find the real service, otherwise they will be
472	name is not in your services database, then you can specify the service in	600	used as-is. If you know that the service name is not in your services
473	the format C<name=port> (e.g. C<http=80>).	601	database, then you can specify the service in the format C<name=port>
		602	(e.g. C<http=80>).
474		603
475	For UNIX domain sockets, C<$node> must be the string C<unix/> and	604	For UNIX domain sockets, C<$node> must be the string C<unix/> and
476	C<$service> must be the absolute pathname of the socket. In this case,	605	C<$service> must be the absolute pathname of the socket. In this case,
477	C<$proto> will be ignored.	606	C<$proto> will be ignored.
478		607
…		…
499		628
500	resolve_sockaddr "google.com", "http", 0, undef, undef, sub { ... };	629	resolve_sockaddr "google.com", "http", 0, undef, undef, sub { ... };
501		630
502	=cut	631	=cut
503		632
504	# microsoft can't even get getprotobyname working (the etc/protocols file
505	# gets lost fairly often on windows), so we have to hardcode some common
506	# protocol numbers ourselves.
507	our %PROTO_BYNAME;
508
509	$PROTO_BYNAME{tcp} = &Socket::IPPROTO_TCP if defined &Socket::IPPROTO_TCP;
510	$PROTO_BYNAME{udp} = &Socket::IPPROTO_UDP if defined &Socket::IPPROTO_UDP;
511	$PROTO_BYNAME{icmp} = &Socket::IPPROTO_ICMP if defined &Socket::IPPROTO_ICMP;
512
513	sub resolve_sockaddr($$$$$$) {	633	sub resolve_sockaddr($$$$$$) {
514	my ($node, $service, $proto, $family, $type, $cb) = @_;	634	my ($node, $service, $proto, $family, $type, $cb) = @_;
515		635
516	if ($node eq "unix/") {	636	if ($node eq "unix/") {
517	return $cb->() if $family \|\| $service !~ /^\//; # no can do	637	return $cb->() if $family \|\| $service !~ /^\//; # no can do
…		…
533	$family \|\|= 6 unless $AnyEvent::PROTOCOL{ipv4};	653	$family \|\|= 6 unless $AnyEvent::PROTOCOL{ipv4};
534		654
535	$proto \|\|= "tcp";	655	$proto \|\|= "tcp";
536	$type \|\|= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM;	656	$type \|\|= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM;
537		657
538	my $proton = $PROTO_BYNAME{lc $proto} \|\| (getprotobyname $proto)[2]	658	my $proton = AnyEvent::Socket::getprotobyname $proto
539	or Carp::croak "$proto: protocol unknown";	659	or Carp::croak "$proto: protocol unknown";
540		660
541	my $port;	661	my $port;
542		662
543	if ($service =~ /^(\S+)=(\d+)$/) {	663	if ($service =~ /^(\S+)=(\d+)$/) {
…		…
547	} else {	667	} else {
548	$port = (getservbyname $service, $proto)[2]	668	$port = (getservbyname $service, $proto)[2]
549	or Carp::croak "$service/$proto: service unknown";	669	or Carp::croak "$service/$proto: service unknown";
550	}	670	}
551		671
552	my @target = [$node, $port];
553
554	# resolve a records / provide sockaddr structures	672	# resolve a records / provide sockaddr structures
555	my $resolve = sub {	673	my $resolve = sub {
		674	my @target = @_;
		675
556	my @res;	676	my @res;
557	my $cv = AnyEvent->condvar (cb => sub {	677	my $cv = AE::cv {
558	$cb->(	678	$cb->(
559	map $_->[2],	679	map $_->[2],
560	sort {	680	sort {
561	$AnyEvent::PROTOCOL{$b->[1]} <=> $AnyEvent::PROTOCOL{$a->[1]}	681	$AnyEvent::PROTOCOL{$b->[1]} <=> $AnyEvent::PROTOCOL{$a->[1]}
562	or $a->[0] <=> $b->[0]	682	or $a->[0] <=> $b->[0]
563	}	683	}
564	@res	684	@res
565	)	685	)
566	});	686	};
567		687
568	$cv->begin;	688	$cv->begin;
569	for my $idx (0 .. $#target) {	689	for my $idx (0 .. $#target) {
570	my ($node, $port) = @{ $target[$idx] };	690	my ($node, $port) = @{ $target[$idx] };
571		691
…		…
606	}	726	}
607	}	727	}
608	$cv->end;	728	$cv->end;
609	};	729	};
610		730
		731	$node = AnyEvent::Util::idn_to_ascii $node
		732	if $node =~ /[^\x00-\x7f]/;
		733
611	# try srv records, if applicable	734	# try srv records, if applicable
612	if ($node eq "localhost") {	735	if ($node eq "localhost") {
613	@target = (["127.0.0.1", $port], ["::1", $port]);	736	$resolve->(["127.0.0.1", $port], ["::1", $port]);
614	&$resolve;
615	} elsif (defined $service && !parse_address $node) {	737	} elsif (defined $service && !parse_address $node) {
616	AnyEvent::DNS::srv $service, $proto, $node, sub {	738	AnyEvent::DNS::srv $service, $proto, $node, sub {
617	my (@srv) = @_;	739	my (@srv) = @_;
618		740
619	# no srv records, continue traditionally
620	@srv	741	if (@srv) {
621	or return &$resolve;
622
623	# the only srv record has "." ("" here) => abort	742	# the only srv record has "." ("" here) => abort
624	$srv[0][2] ne "" \|\| $#srv	743	$srv[0][2] ne "" \|\| $#srv
625	or return $cb->();	744	or return $cb->();
626		745
627	# use srv records then	746	# use srv records then
		747	$resolve->(
628	@target = map ["$_->[3].", $_->[2]],	748	map ["$_->[3].", $_->[2]],
629	grep $_->[3] ne ".",	749	grep $_->[3] ne ".",
630	@srv;	750	@srv
631		751	);
632	&$resolve;	752	} else {
		753	# no srv records, continue traditionally
		754	$resolve->([$node, $port]);
		755	}
633	};	756	};
634	} else {	757	} else {
635	&$resolve;	758	# most common case
		759	$resolve->([$node, $port]);
636	}	760	}
637	}	761	}
638		762
639	=item $guard = tcp_connect $host, $service, $connect_cb[, $prepare_cb]	763	=item $guard = tcp_connect $host, $service, $connect_cb[, $prepare_cb]
640		764
641	This is a convenience function that creates a TCP socket and makes a 100%	765	This is a convenience function that creates a TCP socket and makes a
642	non-blocking connect to the given C<$host> (which can be a hostname or	766	100% non-blocking connect to the given C<$host> (which can be a DNS/IDN
643	a textual IP address, or the string C<unix/> for UNIX domain sockets)	767	hostname or a textual IP address, or the string C<unix/> for UNIX domain
644	and C<$service> (which can be a numeric port number or a service name,	768	sockets) and C<$service> (which can be a numeric port number or a service
645	or a C<servicename=portnumber> string, or the pathname to a UNIX domain	769	name, or a C<servicename=portnumber> string, or the pathname to a UNIX
646	socket).	770	domain socket).
647		771
648	If both C<$host> and C<$port> are names, then this function will use SRV	772	If both C<$host> and C<$port> are names, then this function will use SRV
649	records to locate the real target(s).	773	records to locate the real target(s).
650		774
651	In either case, it will create a list of target hosts (e.g. for multihomed	775	In either case, it will create a list of target hosts (e.g. for multihomed
652	hosts or hosts with both IPv4 and IPv6 addresses) and try to connect to	776	hosts or hosts with both IPv4 and IPv6 addresses) and try to connect to
653	each in turn.	777	each in turn.
654		778
655	If the connect is successful, then the C<$connect_cb> will be invoked with	779	After the connection is established, then the C<$connect_cb> will be
656	the socket file handle (in non-blocking mode) as first and the peer host	780	invoked with the socket file handle (in non-blocking mode) as first, and
657	(as a textual IP address) and peer port as second and third arguments,	781	the peer host (as a textual IP address) and peer port as second and third
658	respectively. The fourth argument is a code reference that you can call	782	arguments, respectively. The fourth argument is a code reference that you
659	if, for some reason, you don't like this connection, which will cause	783	can call if, for some reason, you don't like this connection, which will
660	C<tcp_connect> to try the next one (or call your callback without any	784	cause C<tcp_connect> to try the next one (or call your callback without
661	arguments if there are no more connections). In most cases, you can simply	785	any arguments if there are no more connections). In most cases, you can
662	ignore this argument.	786	simply ignore this argument.
663		787
664	$cb->($filehandle, $host, $port, $retry)	788	$cb->($filehandle, $host, $port, $retry)
665		789
666	If the connect is unsuccessful, then the C<$connect_cb> will be invoked	790	If the connect is unsuccessful, then the C<$connect_cb> will be invoked
667	without any arguments and C<$!> will be set appropriately (with C<ENXIO>	791	without any arguments and C<$!> will be set appropriately (with C<ENXIO>
668	indicating a DNS resolution failure).	792	indicating a DNS resolution failure).
669		793
		794	The callback will I<never> be invoked before C<tcp_connect> returns, even
		795	if C<tcp_connect> was able to connect immediately (e.g. on unix domain
		796	sockets).
		797
670	The file handle is perfect for being plugged into L<AnyEvent::Handle>, but	798	The file handle is perfect for being plugged into L<AnyEvent::Handle>, but
671	can be used as a normal perl file handle as well.	799	can be used as a normal perl file handle as well.
672		800
673	Unless called in void context, C<tcp_connect> returns a guard object that	801	Unless called in void context, C<tcp_connect> returns a guard object that
674	will automatically abort connecting when it gets destroyed (it does not do	802	will automatically cancel the connection attempt when it gets destroyed
		803	- in which case the callback will not be invoked. Destroying it does not
675	anything to the socket after the connect was successful).	804	do anything to the socket after the connect was successful - you cannot
		805	"uncall" a callback that has been invoked already.
676		806
677	Sometimes you need to "prepare" the socket before connecting, for example,	807	Sometimes you need to "prepare" the socket before connecting, for example,
678	to C<bind> it to some port, or you want a specific connect timeout that	808	to C<bind> it to some port, or you want a specific connect timeout that
679	is lower than your kernel's default timeout. In this case you can specify	809	is lower than your kernel's default timeout. In this case you can specify
680	a second callback, C<$prepare_cb>. It will be called with the file handle	810	a second callback, C<$prepare_cb>. It will be called with the file handle
…		…
712	or die "unable to connect: $!";	842	or die "unable to connect: $!";
713		843
714	my $handle; # avoid direct assignment so on_eof has it in scope.	844	my $handle; # avoid direct assignment so on_eof has it in scope.
715	$handle = new AnyEvent::Handle	845	$handle = new AnyEvent::Handle
716	fh => $fh,	846	fh => $fh,
		847	on_error => sub {
		848	warn "error $_[2]\n";
		849	$_[0]->destroy;
		850	},
717	on_eof => sub {	851	on_eof => sub {
718	undef $handle; # keep it alive till eof	852	$handle->destroy; # destroy handle
719	warn "done.\n";	853	warn "done.\n";
720	};	854	};
721		855
722	$handle->push_write ("GET / HTTP/1.0\015\012\015\012");	856	$handle->push_write ("GET / HTTP/1.0\015\012\015\012");
723		857
724	$handle->push_read_line ("\015\012\015\012", sub {	858	$handle->push_read (line => "\015\012\015\012", sub {
725	my ($handle, $line) = @_;	859	my ($handle, $line) = @_;
726		860
727	# print response header	861	# print response header
728	print "HEADER\n$line\n\nBODY\n";	862	print "HEADER\n$line\n\nBODY\n";
729		863
…		…
749	=cut	883	=cut
750		884
751	sub tcp_connect($$$;$) {	885	sub tcp_connect($$$;$) {
752	my ($host, $port, $connect, $prepare) = @_;	886	my ($host, $port, $connect, $prepare) = @_;
753		887
754	# see http://cr.yp.to/docs/connect.html for some background	888	# see http://cr.yp.to/docs/connect.html for some tricky aspects
755	# also http://advogato.org/article/672.html	889	# also http://advogato.org/article/672.html
756		890
757	my %state = ( fh => undef );	891	my %state = ( fh => undef );
758		892
759	# name/service to type/sockaddr resolution	893	# name/service to type/sockaddr resolution
…		…
762		896
763	$state{next} = sub {	897	$state{next} = sub {
764	return unless exists $state{fh};	898	return unless exists $state{fh};
765		899
766	my $target = shift @target	900	my $target = shift @target
767	or do {	901	or return _postpone sub {
		902	return unless exists $state{fh};
768	%state = ();	903	%state = ();
769	return $connect->();	904	$connect->();
770	};	905	};
771		906
772	my ($domain, $type, $proto, $sockaddr) = @$target;	907	my ($domain, $type, $proto, $sockaddr) = @$target;
773		908
774	# socket creation	909	# socket creation
…		…
779		914
780	my $timeout = $prepare && $prepare->($state{fh});	915	my $timeout = $prepare && $prepare->($state{fh});
781		916
782	$timeout \|\|= 30 if AnyEvent::WIN32;	917	$timeout \|\|= 30 if AnyEvent::WIN32;
783		918
784	$state{to} = AnyEvent->timer (after => $timeout, cb => sub {	919	$state{to} = AE::timer $timeout, 0, sub {
785	$! = &Errno::ETIMEDOUT;	920	$! = Errno::ETIMEDOUT;
786	$state{next}();	921	$state{next}();
787	}) if $timeout;	922	} if $timeout;
788		923
789	# called when the connect was successful, which,	924	# now connect
790	# in theory, could be the case immediately (but never is in practise)	925	if (
791	$state{connected} = sub {	926	(connect $state{fh}, $sockaddr)
792	delete $state{ww};	927	\|\| ($! == Errno::EINPROGRESS # POSIX
793	delete $state{to};	928	\|\| $! == Errno::EWOULDBLOCK
794		929	# WSAEINPROGRESS intentionally not checked - it means something else entirely
		930	\|\| $! == AnyEvent::Util::WSAEINVAL # not convinced, but doesn't hurt
		931	\|\| $! == AnyEvent::Util::WSAEWOULDBLOCK)
		932	) {
		933	$state{ww} = AE::io $state{fh}, 1, sub {
795	# we are connected, or maybe there was an error	934	# we are connected, or maybe there was an error
796	if (my $sin = getpeername $state{fh}) {	935	if (my $sin = getpeername $state{fh}) {
797	my ($port, $host) = unpack_sockaddr $sin;	936	my ($port, $host) = unpack_sockaddr $sin;
798		937
		938	delete $state{ww}; delete $state{to};
		939
799	my $guard = guard { %state = () };	940	my $guard = guard { %state = () };
800		941
801	$connect->(delete $state{fh}, format_address $host, $port, sub {	942	$connect->(delete $state{fh}, format_address $host, $port, sub {
802	$guard->cancel;	943	$guard->cancel;
		944	$state{next}();
		945	});
		946	} else {
		947	if ($! == Errno::ENOTCONN) {
		948	# dummy read to fetch real error code if !cygwin
		949	sysread $state{fh}, my $buf, 1;
		950
		951	# cygwin 1.5 continously reports "ready' but never delivers
		952	# an error with getpeername or sysread.
		953	# cygwin 1.7 only reports readyness once, but is otherwise
		954	# the same, which is actually more broken.
		955	# Work around both by using unportable SO_ERROR for cygwin.
		956	$! = (unpack "l", getsockopt $state{fh}, Socket::SOL_SOCKET(), Socket::SO_ERROR()) \|\| Errno::EAGAIN
		957	if AnyEvent::CYGWIN && $! == Errno::EAGAIN;
		958	}
		959
		960	return if $! == Errno::EAGAIN; # skip spurious wake-ups
		961
		962	delete $state{ww}; delete $state{to};
		963
803	$state{next}();	964	$state{next}();
804	});	965	}
805	} else {
806	# dummy read to fetch real error code
807	sysread $state{fh}, my $buf, 1 if $! == &Errno::ENOTCONN;
808	$state{next}();
809	}	966	};
810	};
811
812	# now connect
813	if (connect $state{fh}, $sockaddr) {
814	$state{connected}->();
815	} elsif ($! == &Errno::EINPROGRESS # POSIX
816	\|\| $! == &Errno::EWOULDBLOCK
817	# WSAEINPROGRESS intentionally not checked - it means something else entirely
818	\|\| $! == AnyEvent::Util::WSAEINVAL # not convinced, but doesn't hurt
819	\|\| $! == AnyEvent::Util::WSAEWOULDBLOCK) {
820	$state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $state{connected});
821	} else {	967	} else {
822	$state{next}();	968	$state{next}();
823	}	969	}
824	};	970	};
825		971
826	$! = &Errno::ENXIO;	972	$! = Errno::ENXIO;
827	$state{next}();	973	$state{next}();
828	};	974	};
829		975
830	defined wantarray && guard { %state = () }	976	defined wantarray && guard { %state = () }
831	}	977	}
…		…
853	the socket before it tries to bind to it. See SECURITY CONSIDERATIONS,	999	the socket before it tries to bind to it. See SECURITY CONSIDERATIONS,
854	below.	1000	below.
855		1001
856	For each new connection that could be C<accept>ed, call the C<<	1002	For each new connection that could be C<accept>ed, call the C<<
857	$accept_cb->($fh, $host, $port) >> with the file handle (in non-blocking	1003	$accept_cb->($fh, $host, $port) >> with the file handle (in non-blocking
858	mode) as first and the peer host and port as second and third arguments	1004	mode) as first, and the peer host and port as second and third arguments
859	(see C<tcp_connect> for details).	1005	(see C<tcp_connect> for details).
860		1006
861	Croaks on any errors it can detect before the listen.	1007	Croaks on any errors it can detect before the listen.
862		1008
863	If called in non-void context, then this function returns a guard object	1009	If called in non-void context, then this function returns a guard object
864	whose lifetime it tied to the TCP server: If the object gets destroyed,	1010	whose lifetime it tied to the TCP server: If the object gets destroyed,
865	the server will be stopped (but existing accepted connections will	1011	the server will be stopped (but existing accepted connections will
866	continue).	1012	not be affected).
867		1013
868	If you need more control over the listening socket, you can provide a	1014	If you need more control over the listening socket, you can provide a
869	C<< $prepare_cb->($fh, $host, $port) >>, which is called just before the	1015	C<< $prepare_cb->($fh, $host, $port) >>, which is called just before the
870	C<listen ()> call, with the listen file handle as first argument, and IP	1016	C<listen ()> call, with the listen file handle as first argument, and IP
871	address and port number of the local socket endpoint as second and third	1017	address and port number of the local socket endpoint as second and third
…		…
949	$len \|\|= 128;	1095	$len \|\|= 128;
950		1096
951	listen $state{fh}, $len	1097	listen $state{fh}, $len
952	or Carp::croak "listen: $!";	1098	or Carp::croak "listen: $!";
953		1099
954	$state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub {	1100	$state{aw} = AE::io $state{fh}, 0, sub {
955	# this closure keeps $state alive	1101	# this closure keeps $state alive
956	while (my $peer = accept my $fh, $state{fh}) {	1102	while ($state{fh} && (my $peer = accept my $fh, $state{fh})) {
957	fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not	1103	fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not
958		1104
959	my ($service, $host) = unpack_sockaddr $peer;	1105	my ($service, $host) = unpack_sockaddr $peer;
960	$accept->($fh, format_address $host, $service);	1106	$accept->($fh, format_address $host, $service);
961	}	1107	}
962	});	1108	};
963		1109
964	defined wantarray	1110	defined wantarray
965	? guard { %state = () } # clear fh and watcher, which breaks the circular dependency	1111	? guard { %state = () } # clear fh and watcher, which breaks the circular dependency
966	: ()	1112	: ()
		1113	}
		1114
		1115	=item tcp_nodelay $fh, $enable
		1116
		1117	Enables (or disables) the C<TCP_NODELAY> socket option (also known as
		1118	Nagle's algorithm). Returns false on error, true otherwise.
		1119
		1120	=cut
		1121
		1122	sub tcp_nodelay($$) {
		1123	my $onoff = int ! ! $_[1];
		1124
		1125	setsockopt $_[0], Socket::IPPROTO_TCP (), Socket::TCP_NODELAY (), $onoff
		1126	}
		1127
		1128	=item tcp_congestion $fh, $algorithm
		1129
		1130	Sets the tcp congestion avoidance algorithm (via the C<TCP_CONGESTION>
		1131	socket option). The default is OS-specific, but is usually
		1132	C<reno>. Typical other available choices include C<cubic>, C<lp>, C<bic>,
		1133	C<highspeed>, C<htcp>, C<hybla>, C<illinois>, C<scalable>, C<vegas>,
		1134	C<veno>, C<westwood> and C<yeah>.
		1135
		1136	=cut
		1137
		1138	sub tcp_congestion($$) {
		1139	defined TCP_CONGESTION
		1140	? setsockopt $_[0], Socket::IPPROTO_TCP (), TCP_CONGESTION, "$_[1]"
		1141	: undef
967	}	1142	}
968		1143
969	1;	1144	1;
970		1145
971	=back	1146	=back

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents): Revision 1.87 by root, Thu Jul 9 08:31:16 2009 UTC vs. Revision 1.130 by root, Fri Jan 14 17:43:11 2011 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.87 by root, Thu Jul 9 08:31:16 2009 UTC vs.
Revision 1.130 by root, Fri Jan 14 17:43:11 2011 UTC