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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.67 by root, Mon Nov 3 17:14:30 2008 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
		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.31;	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($) {
283	sub format_address($) {
284	my $af = address_family $_[0];
285	if ($af == AF_INET) {
286	return join ".", unpack "C4", $_[0]	382	join ".", unpack "C4", $_[0]
287	} elsif ($af == AF_INET6) {	383	}
		384
		385	sub format_ipv6($) {
		386	if ($_[0] =~ /^\x00\x00\x00\x00\x00\x00\x00\x00/) {
288	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]) {
289	return "::";	388	return "::";
290	} 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]) {
291	return "::1";	390	return "::1";
292	} 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) {
293	# v4compatible	392	# v4compatible
294	return "::" . format_address substr $_[0], 12;	393	return "::" . format_ipv4 substr $_[0], 12;
295	} 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) {
296	# v4mapped	395	# v4mapped
297	return "::ffff:" . format_address substr $_[0], 12;	396	return "::ffff:" . format_ipv4 substr $_[0], 12;
298	} 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) {
299	# v4translated	398	# v4translated
300	return "::ffff:0:" . format_address substr $_[0], 12;	399	return "::ffff:0:" . format_ipv4 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	}	400	}
315	} elsif ($af == AF_UNIX) {	401	}
		402
		403	my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0];
		404
		405	# this is admittedly rather sucky
		406	$ip =~ s/(?:^\|:) 0:0:0:0:0:0:0 (?:$\|:)/::/x
		407	or $ip =~ s/(?:^\|:) 0:0:0:0:0:0 (?:$\|:)/::/x
		408	or $ip =~ s/(?:^\|:) 0:0:0:0:0 (?:$\|:)/::/x
		409	or $ip =~ s/(?:^\|:) 0:0:0:0 (?:$\|:)/::/x
		410	or $ip =~ s/(?:^\|:) 0:0:0 (?:$\|:)/::/x
		411	or $ip =~ s/(?:^\|:) 0:0 (?:$\|:)/::/x
		412	or $ip =~ s/(?:^\|:) 0 (?:$\|:)/::/x;
		413
		414	$ip
		415	}
		416
		417	sub format_address($) {
		418	if (4 == length $_[0]) {
		419	return &format_ipv4;
		420	} elsif (16 == length $_[0]) {
		421	return $_[0] =~ /^\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff(....)$/s
		422	? format_ipv4 $1
		423	: &format_ipv6;
		424	} elsif (AF_UNIX == address_family $_[0]) {
316	return "unix/"	425	return "unix/"
317	} else {	426	} else {
318	return undef	427	return undef
319	}	428	}
320	}	429	}
…		…
322	*ntoa = \&format_address;	431	*ntoa = \&format_address;
323		432
324	=item inet_aton $name_or_address, $cb->(@addresses)	433	=item inet_aton $name_or_address, $cb->(@addresses)
325		434
326	Works similarly to its Socket counterpart, except that it uses a	435	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	436	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	437	for IPv4, 16 for IPv6), or use C<format_address> to convert it to a more
329	for IPv6).	438	readable format.
330		439
331	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,
332	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
333		457
334	=cut	458	=cut
335		459
336	sub inet_aton {	460	sub inet_aton {
337	my ($name, $cb) = @_;	461	my ($name, $cb) = @_;
…		…
343	} elsif ($name eq "localhost") { # rfc2606 et al.	467	} 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);	468	$cb->(v127.0.0.1, v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.1);
345	} else {	469	} else {
346	require AnyEvent::DNS;	470	require AnyEvent::DNS;
347		471
348	# 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;
349	AnyEvent::DNS::a ($name, sub {	485	AnyEvent::DNS::a ($name, sub {
350	if (@_) {	486	$res[$ipv4] = [map &parse_ipv4, @_];
351	$cb->(map +(parse_ipv4 $_), @_);
352	} else {
353	$cb->();	487	$cv->end;
354	#AnyEvent::DNS::aaaa ($name, $cb); need inet_pton
355	}	488	});
356	});	489	};
357	}
358	}
359		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
360	# check for broken platforms with extra field in sockaddr structure	513	# 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	514	# 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	515	# unix vs. bsd issue, a iso C vs. bsd issue or simply a
363	# correctness vs. bsd issue.	516	# correctness vs. bsd issue.)
364	my $pack_family = (0x55 == Socket::sockaddr_family "\x55\x55")	517	my $pack_family = 0x55 == sockaddr_family ("\x55\x55")
365	? "xC" : "S";	518	? "xC" : "S";
366		519
367	=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host	520	=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host
368		521
369	Pack the given port/host combination into a binary sockaddr	522	Pack the given port/host combination into a binary sockaddr
370	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
371	domain sockets (C<$host> == C<unix/> and C<$service> == absolute	524	domain sockets (C<$host> == C<unix/> and C<$service> == absolute
372	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: $!";
373		532
374	=cut	533	=cut
375		534
376	sub pack_sockaddr($$) {	535	sub pack_sockaddr($$) {
377	my $af = address_family $_[1];	536	my $af = address_family $_[1];
…		…
404	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
405	module (C<format_address> converts it to C<unix/>).	564	module (C<format_address> converts it to C<unix/>).
406		565
407	=cut	566	=cut
408		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
409	sub unpack_sockaddr($) {	574	sub unpack_sockaddr($) {
410	my $af = Socket::sockaddr_family $_[0];	575	my $af = sockaddr_family $_[0];
411		576
412	if ($af == AF_INET) {	577	if ($af == AF_INET) {
413	Socket::unpack_sockaddr_in $_[0]	578	Socket::unpack_sockaddr_in $_[0]
414	} elsif ($af == AF_INET6) {	579	} elsif ($af == AF_INET6) {
415	unpack "x2 n x4 a16", $_[0]	580	unpack "x2 n x4 a16", $_[0]
416	} elsif ($af == AF_UNIX) {	581	} elsif ($af == AF_UNIX) {
417	((Socket::unpack_sockaddr_un $_[0]), pack "S", AF_UNIX)	582	((Socket::unpack_sockaddr_un $_[0] ^ $sa_un_zero), pack "S", AF_UNIX)
418	} else {	583	} else {
419	Carp::croak "unpack_sockaddr: unsupported protocol family $af";	584	Carp::croak "unpack_sockaddr: unsupported protocol family $af";
420	}	585	}
421	}	586	}
422		587
…		…
425	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
426	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
427	protocol-independent way. It works remotely similar to the getaddrinfo	592	protocol-independent way. It works remotely similar to the getaddrinfo
428	posix function.	593	posix function.
429		594
430	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
431	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
432	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
433	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
434	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
435	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
436	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>).
437		603
438	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
439	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,
440	C<$proto> will be ignored.	606	C<$proto> will be ignored.
441		607
…		…
462		628
463	resolve_sockaddr "google.com", "http", 0, undef, undef, sub { ... };	629	resolve_sockaddr "google.com", "http", 0, undef, undef, sub { ... };
464		630
465	=cut	631	=cut
466		632
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($$$$$$) {	633	sub resolve_sockaddr($$$$$$) {
477	my ($node, $service, $proto, $family, $type, $cb) = @_;	634	my ($node, $service, $proto, $family, $type, $cb) = @_;
478		635
479	if ($node eq "unix/") {	636	if ($node eq "unix/") {
480	return $cb->() if $family \|\| $service !~ /^\//; # no can do	637	return $cb->() if $family \|\| $service !~ /^\//; # no can do
…		…
496	$family \|\|= 6 unless $AnyEvent::PROTOCOL{ipv4};	653	$family \|\|= 6 unless $AnyEvent::PROTOCOL{ipv4};
497		654
498	$proto \|\|= "tcp";	655	$proto \|\|= "tcp";
499	$type \|\|= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM;	656	$type \|\|= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM;
500		657
501	my $proton = $PROTO_BYNAME{lc $proto} \|\| (getprotobyname $proto)[2]	658	my $proton = AnyEvent::Socket::getprotobyname $proto
502	or Carp::croak "$proto: protocol unknown";	659	or Carp::croak "$proto: protocol unknown";
503		660
504	my $port;	661	my $port;
505		662
506	if ($service =~ /^(\S+)=(\d+)$/) {	663	if ($service =~ /^(\S+)=(\d+)$/) {
…		…
510	} else {	667	} else {
511	$port = (getservbyname $service, $proto)[2]	668	$port = (getservbyname $service, $proto)[2]
512	or Carp::croak "$service/$proto: service unknown";	669	or Carp::croak "$service/$proto: service unknown";
513	}	670	}
514		671
515	my @target = [$node, $port];
516
517	# resolve a records / provide sockaddr structures	672	# resolve a records / provide sockaddr structures
518	my $resolve = sub {	673	my $resolve = sub {
		674	my @target = @_;
		675
519	my @res;	676	my @res;
520	my $cv = AnyEvent->condvar (cb => sub {	677	my $cv = AE::cv {
521	$cb->(	678	$cb->(
522	map $_->[2],	679	map $_->[2],
523	sort {	680	sort {
524	$AnyEvent::PROTOCOL{$b->[1]} <=> $AnyEvent::PROTOCOL{$a->[1]}	681	$AnyEvent::PROTOCOL{$b->[1]} <=> $AnyEvent::PROTOCOL{$a->[1]}
525	or $a->[0] <=> $b->[0]	682	or $a->[0] <=> $b->[0]
526	}	683	}
527	@res	684	@res
528	)	685	)
529	});	686	};
530		687
531	$cv->begin;	688	$cv->begin;
532	for my $idx (0 .. $#target) {	689	for my $idx (0 .. $#target) {
533	my ($node, $port) = @{ $target[$idx] };	690	my ($node, $port) = @{ $target[$idx] };
534		691
…		…
569	}	726	}
570	}	727	}
571	$cv->end;	728	$cv->end;
572	};	729	};
573		730
		731	$node = AnyEvent::Util::idn_to_ascii $node
		732	if $node =~ /[^\x00-\x7f]/;
		733
574	# try srv records, if applicable	734	# try srv records, if applicable
575	if ($node eq "localhost") {	735	if ($node eq "localhost") {
576	@target = (["127.0.0.1", $port], ["::1", $port]);	736	$resolve->(["127.0.0.1", $port], ["::1", $port]);
577	&$resolve;
578	} elsif (defined $service && !parse_address $node) {	737	} elsif (defined $service && !parse_address $node) {
579	AnyEvent::DNS::srv $service, $proto, $node, sub {	738	AnyEvent::DNS::srv $service, $proto, $node, sub {
580	my (@srv) = @_;	739	my (@srv) = @_;
581		740
582	# no srv records, continue traditionally
583	@srv	741	if (@srv) {
584	or return &$resolve;
585
586	# the only srv record has "." ("" here) => abort	742	# the only srv record has "." ("" here) => abort
587	$srv[0][2] ne "" \|\| $#srv	743	$srv[0][2] ne "" \|\| $#srv
588	or return $cb->();	744	or return $cb->();
589		745
590	# use srv records then	746	# use srv records then
		747	$resolve->(
591	@target = map ["$_->[3].", $_->[2]],	748	map ["$_->[3].", $_->[2]],
592	grep $_->[3] ne ".",	749	grep $_->[3] ne ".",
593	@srv;	750	@srv
594		751	);
595	&$resolve;	752	} else {
		753	# no srv records, continue traditionally
		754	$resolve->([$node, $port]);
		755	}
596	};	756	};
597	} else {	757	} else {
598	&$resolve;	758	# most common case
		759	$resolve->([$node, $port]);
599	}	760	}
600	}	761	}
601		762
602	=item $guard = tcp_connect $host, $service, $connect_cb[, $prepare_cb]	763	=item $guard = tcp_connect $host, $service, $connect_cb[, $prepare_cb]
603		764
604	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
605	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
606	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
607	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
608	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
609	socket).	770	domain socket).
610		771
611	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
612	records to locate the real target(s).	773	records to locate the real target(s).
613		774
614	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
615	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
616	each in turn.	777	each in turn.
617		778
618	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
619	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
620	(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
621	respectively. The fourth argument is a code reference that you can call	782	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	783	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	784	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	785	any arguments if there are no more connections). In most cases, you can
625	ignore this argument.	786	simply ignore this argument.
626		787
627	$cb->($filehandle, $host, $port, $retry)	788	$cb->($filehandle, $host, $port, $retry)
628		789
629	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
630	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>
631	indicating a DNS resolution failure).	792	indicating a DNS resolution failure).
632		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
633	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
634	can be used as a normal perl file handle as well.	799	can be used as a normal perl file handle as well.
635		800
636	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
637	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
638	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.
639		806
640	Sometimes you need to "prepare" the socket before connecting, for example,	807	Sometimes you need to "prepare" the socket before connecting, for example,
641	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
642	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
643	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
…		…
675	or die "unable to connect: $!";	842	or die "unable to connect: $!";
676		843
677	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.
678	$handle = new AnyEvent::Handle	845	$handle = new AnyEvent::Handle
679	fh => $fh,	846	fh => $fh,
		847	on_error => sub {
		848	warn "error $_[2]\n";
		849	$_[0]->destroy;
		850	},
680	on_eof => sub {	851	on_eof => sub {
681	undef $handle; # keep it alive till eof	852	$handle->destroy; # destroy handle
682	warn "done.\n";	853	warn "done.\n";
683	};	854	};
684		855
685	$handle->push_write ("GET / HTTP/1.0\015\012\015\012");	856	$handle->push_write ("GET / HTTP/1.0\015\012\015\012");
686		857
687	$handle->push_read_line ("\015\012\015\012", sub {	858	$handle->push_read (line => "\015\012\015\012", sub {
688	my ($handle, $line) = @_;	859	my ($handle, $line) = @_;
689		860
690	# print response header	861	# print response header
691	print "HEADER\n$line\n\nBODY\n";	862	print "HEADER\n$line\n\nBODY\n";
692		863
…		…
712	=cut	883	=cut
713		884
714	sub tcp_connect($$$;$) {	885	sub tcp_connect($$$;$) {
715	my ($host, $port, $connect, $prepare) = @_;	886	my ($host, $port, $connect, $prepare) = @_;
716		887
717	# see http://cr.yp.to/docs/connect.html for some background	888	# see http://cr.yp.to/docs/connect.html for some tricky aspects
718	# also http://advogato.org/article/672.html	889	# also http://advogato.org/article/672.html
719		890
720	my %state = ( fh => undef );	891	my %state = ( fh => undef );
721		892
722	# name/service to type/sockaddr resolution	893	# name/service to type/sockaddr resolution
…		…
725		896
726	$state{next} = sub {	897	$state{next} = sub {
727	return unless exists $state{fh};	898	return unless exists $state{fh};
728		899
729	my $target = shift @target	900	my $target = shift @target
730	or do {	901	or return _postpone sub {
		902	return unless exists $state{fh};
731	%state = ();	903	%state = ();
732	return $connect->();	904	$connect->();
733	};	905	};
734		906
735	my ($domain, $type, $proto, $sockaddr) = @$target;	907	my ($domain, $type, $proto, $sockaddr) = @$target;
736		908
737	# socket creation	909	# socket creation
…		…
742		914
743	my $timeout = $prepare && $prepare->($state{fh});	915	my $timeout = $prepare && $prepare->($state{fh});
744		916
745	$timeout \|\|= 30 if AnyEvent::WIN32;	917	$timeout \|\|= 30 if AnyEvent::WIN32;
746		918
747	$state{to} = AnyEvent->timer (after => $timeout, cb => sub {	919	$state{to} = AE::timer $timeout, 0, sub {
748	$! = &Errno::ETIMEDOUT;	920	$! = Errno::ETIMEDOUT;
749	$state{next}();	921	$state{next}();
750	}) if $timeout;	922	} if $timeout;
751		923
752	# called when the connect was successful, which,	924	# now connect
753	# in theory, could be the case immediately (but never is in practise)	925	if (
754	$state{connected} = sub {	926	(connect $state{fh}, $sockaddr)
755	delete $state{ww};	927	\|\| ($! == Errno::EINPROGRESS # POSIX
756	delete $state{to};	928	\|\| $! == Errno::EWOULDBLOCK
757		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 {
758	# we are connected, or maybe there was an error	934	# we are connected, or maybe there was an error
759	if (my $sin = getpeername $state{fh}) {	935	if (my $sin = getpeername $state{fh}) {
760	my ($port, $host) = unpack_sockaddr $sin;	936	my ($port, $host) = unpack_sockaddr $sin;
761		937
		938	delete $state{ww}; delete $state{to};
		939
762	my $guard = guard { %state = () };	940	my $guard = guard { %state = () };
763		941
764	$connect->(delete $state{fh}, format_address $host, $port, sub {	942	$connect->(delete $state{fh}, format_address $host, $port, sub {
765	$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
766	$state{next}();	964	$state{next}();
767	});	965	}
768	} else {
769	# dummy read to fetch real error code
770	sysread $state{fh}, my $buf, 1 if $! == &Errno::ENOTCONN;
771	$state{next}();
772	}	966	};
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 {	967	} else {
785	$state{next}();	968	$state{next}();
786	}	969	}
787	};	970	};
788		971
789	$! = &Errno::ENXIO;	972	$! = Errno::ENXIO;
790	$state{next}();	973	$state{next}();
791	};	974	};
792		975
793	defined wantarray && guard { %state = () }	976	defined wantarray && guard { %state = () }
794	}	977	}
…		…
816	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,
817	below.	1000	below.
818		1001
819	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<<
820	$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
821	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
822	(see C<tcp_connect> for details).	1005	(see C<tcp_connect> for details).
823		1006
824	Croaks on any errors it can detect before the listen.	1007	Croaks on any errors it can detect before the listen.
825		1008
826	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
827	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,
828	the server will be stopped (but existing accepted connections will	1011	the server will be stopped (but existing accepted connections will
829	continue).	1012	not be affected).
830		1013
831	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
832	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
833	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
834	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
…		…
912	$len \|\|= 128;	1095	$len \|\|= 128;
913		1096
914	listen $state{fh}, $len	1097	listen $state{fh}, $len
915	or Carp::croak "listen: $!";	1098	or Carp::croak "listen: $!";
916		1099
917	$state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub {	1100	$state{aw} = AE::io $state{fh}, 0, sub {
918	# this closure keeps $state alive	1101	# this closure keeps $state alive
919	while (my $peer = accept my $fh, $state{fh}) {	1102	while ($state{fh} && (my $peer = accept my $fh, $state{fh})) {
920	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
921		1104
922	my ($service, $host) = unpack_sockaddr $peer;	1105	my ($service, $host) = unpack_sockaddr $peer;
923	$accept->($fh, format_address $host, $service);	1106	$accept->($fh, format_address $host, $service);
924	}	1107	}
925	});	1108	};
926		1109
927	defined wantarray	1110	defined wantarray
928	? guard { %state = () } # clear fh and watcher, which breaks the circular dependency	1111	? guard { %state = () } # clear fh and watcher, which breaks the circular dependency
929	: ()	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
930	}	1142	}
931		1143
932	1;	1144	1;
933		1145
934	=back	1146	=back

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents): Revision 1.67 by root, Mon Nov 3 17:14:30 2008 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.67 by root, Mon Nov 3 17:14:30 2008 UTC vs.
Revision 1.130 by root, Fri Jan 14 17:43:11 2011 UTC