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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.45 by root, Sat May 31 13:38:01 2008 UTC vs.
Revision 1.114 by root, Fri Aug 21 11:59:25 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(
		49	getprotobyname
		50	parse_hostport format_hostport
52	parse_ipv4 parse_ipv6	51	parse_ipv4 parse_ipv6
53	parse_ip parse_address	52	parse_ip parse_address
		53	format_ipv4 format_ipv6
54	format_ip format_address	54	format_ip format_address
55	address_family	55	address_family
56	inet_aton	56	inet_aton
57	tcp_server	57	tcp_server
58	tcp_connect	58	tcp_connect
59	);	59	);
60		60
61	our $VERSION = 4.1;	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	}
62		74
63	=item $ipn = parse_ipv4 $dotted_quad	75	=item $ipn = parse_ipv4 $dotted_quad
64		76
65	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
66	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
…		…
78		90
79	# check leading parts against range	91	# check leading parts against range
80	return undef if grep $_ >= 256, @_[0 .. @_ - 2];	92	return undef if grep $_ >= 256, @_[0 .. @_ - 2];
81		93
82	# check trailing part against range	94	# check trailing part against range
83	return undef if $_[-1] >= 1 << (8 * (4 - $#_));	95	return undef if $_[-1] >= 2 ** (8 * (4 - $#_));
84		96
85	pack "N", (pop)	97	pack "N", (pop)
86	+ ($_[0] << 24)	98	+ ($_[0] << 24)
87	+ ($_[1] << 16)	99	+ ($_[1] << 16)
88	+ ($_[2] << 8);	100	+ ($_[2] << 8);
…		…
143	? pack "S", AF_UNIX	155	? pack "S", AF_UNIX
144	: undef	156	: undef
145		157
146	}	158	}
147		159
148	=item $ipn = parse_address $text	160	=item $ipn = parse_address $ip
149		161
150	Combines C<parse_ipv4> and C<parse_ipv6> in one function. The address	162	Combines C<parse_ipv4> and C<parse_ipv6> in one function. The address
151	here refers to the host address (not socket address) in network form	163	here refers to the host address (not socket address) in network form
152	(binary).	164	(binary).
153		165
154	If the C<$text> is C<unix/>, then this function returns a special token	166	If the C<$text> is C<unix/>, then this function returns a special token
155	recognised by the other functions in this module to mean "UNIX domain	167	recognised by the other functions in this module to mean "UNIX domain
156	socket".	168	socket".
157		169
		170	If the C<$text> to parse is a mapped IPv4 in IPv6 address (:ffff::<ipv4>),
		171	then it will be treated as an IPv4 address. If you don't want that, you
		172	have to call C<parse_ipv4> and/or C<parse_ipv6> manually.
		173
		174	=item $ipn = AnyEvent::Socket::aton $ip
		175
		176	Same as C<parse_address>, but not exported (think C<Socket::inet_aton> but
		177	I<without> name resolution).
		178
158	=cut	179	=cut
159		180
160	sub parse_address($) {	181	sub parse_address($) {
161	&parse_ipv4 \|\| &parse_ipv6 \|\| &parse_unix	182	for (&parse_ipv6) {
		183	if ($_) {
		184	s/^\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff//;
		185	return $_;
		186	} else {
		187	return &parse_ipv4 \|\| &parse_unix
		188	}
		189	}
162	}	190	}
163		191
164	*parse_ip =\&parse_address; #d#	192	*aton = \&parse_address;
		193
		194	=item ($name, $aliases, $proto) = getprotobyname $name
		195
		196	Works like the builtin function of the same name, except it tries hard to
		197	work even on broken platforms (well, that's windows), where getprotobyname
		198	is traditionally very unreliable.
		199
		200	=cut
		201
		202	# microsoft can't even get getprotobyname working (the etc/protocols file
		203	# gets lost fairly often on windows), so we have to hardcode some common
		204	# protocol numbers ourselves.
		205	our %PROTO_BYNAME;
		206
		207	$PROTO_BYNAME{tcp} = Socket::IPPROTO_TCP () if defined &Socket::IPPROTO_TCP;
		208	$PROTO_BYNAME{udp} = Socket::IPPROTO_UDP () if defined &Socket::IPPROTO_UDP;
		209	$PROTO_BYNAME{icmp} = Socket::IPPROTO_ICMP() if defined &Socket::IPPROTO_ICMP;
		210
		211	sub getprotobyname($) {
		212	my $name = lc shift;
		213
		214	defined (my $proton = $PROTO_BYNAME{$name} \|\| (getprotobyname $name)[2])
		215	or return;
		216
		217	($name, uc $name, $proton)
		218	}
		219
		220	=item ($host, $service) = parse_hostport $string[, $default_service]
		221
		222	Splitting a string of the form C<hostname:port> is a common
		223	problem. Unfortunately, just splitting on the colon makes it hard to
		224	specify IPv6 addresses and doesn't support the less common but well
		225	standardised C<[ip literal]> syntax.
		226
		227	This function tries to do this job in a better way, it supports the
		228	following formats, where C<port> can be a numerical port number of a
		229	service name, or a C<name=port> string, and the C< port> and C<:port>
		230	parts are optional. Also, everywhere where an IP address is supported
		231	a hostname or unix domain socket address is also supported (see
		232	C<parse_unix>).
		233
		234	hostname:port e.g. "www.linux.org", "www.x.de:443", "www.x.de:https=443"
		235	ipv4:port e.g. "198.182.196.56", "127.1:22"
		236	ipv6 e.g. "::1", "affe::1"
		237	[ipv4or6]:port e.g. "[::1]", "[10.0.1]:80"
		238	[ipv4or6] port e.g. "[127.0.0.1]", "[www.x.org] 17"
		239	ipv4or6 port e.g. "::1 443", "10.0.0.1 smtp"
		240
		241	It also supports defaulting the service name in a simple way by using
		242	C<$default_service> if no service was detected. If neither a service was
		243	detected nor a default was specified, then this function returns the
		244	empty list. The same happens when a parse error was detected, such as a
		245	hostname with a colon in it (the function is rather conservative, though).
		246
		247	Example:
		248
		249	print join ",", parse_hostport "localhost:443";
		250	# => "localhost,443"
		251
		252	print join ",", parse_hostport "localhost", "https";
		253	# => "localhost,https"
		254
		255	print join ",", parse_hostport "[::1]";
		256	# => "," (empty list)
		257
		258	=cut
		259
		260	sub parse_hostport($;$) {
		261	my ($host, $port);
		262
		263	for ("$_[0]") { # work on a copy, just in case, and also reset pos
		264
		265	# parse host, special cases: "ipv6" or "ipv6 port"
		266	unless (
		267	($host) = /^\s* ([0-9a-fA-F:]:[0-9a-fA-F:]:[0-9a-fA-F\.:]*)/xgc
		268	and parse_ipv6 $host
		269	) {
		270	/^\s*/xgc;
		271
		272	if (/^ \[ ([^\[\]]+) \]/xgc) {
		273	$host = $1;
		274	} elsif (/^ ([^\[\]:\ ]+) /xgc) {
		275	$host = $1;
		276	} else {
		277	return;
		278	}
		279	}
		280
		281	# parse port
		282	if (/\G (?:\s+\|:) ([^:[:space:]]+) \s*$/xgc) {
		283	$port = $1;
		284	} elsif (/\G\s*$/gc && length $_[1]) {
		285	$port = $_[1];
		286	} else {
		287	return;
		288	}
		289	}
		290
		291	# hostnames must not contain :'s
		292	return if $host =~ /:/ && !parse_ipv6 $host;
		293
		294	($host, $port)
		295	}
		296
		297	=item $string = format_hostport $host, $port
		298
		299	Takes a host (in textual form) and a port and formats in unambigiously in
		300	a way that C<parse_hostport> can parse it again. C<$port> can be C<undef>.
		301
		302	=cut
		303
		304	sub format_hostport($;$) {
		305	my ($host, $port) = @_;
		306
		307	$port = ":$port" if length $port;
		308	$host = "[$host]" if $host =~ /:/;
		309
		310	"$host$port"
		311	}
165		312
166	=item $sa_family = address_family $ipn	313	=item $sa_family = address_family $ipn
167		314
168	Returns the address family/protocol-family (AF_xxx/PF_xxx, in one value :)	315	Returns the address family/protocol-family (AF_xxx/PF_xxx, in one value :)
169	of the given host address in network format.	316	of the given host address in network format.
…		…
176	: 16 == length $_[0]	323	: 16 == length $_[0]
177	? AF_INET6	324	? AF_INET6
178	: unpack "S", $_[0]	325	: unpack "S", $_[0]
179	}	326	}
180		327
		328	=item $text = format_ipv4 $ipn
		329
		330	Expects a four octet string representing a binary IPv4 address and returns
		331	its textual format. Rarely used, see C<format_address> for a nicer
		332	interface.
		333
		334	=item $text = format_ipv6 $ipn
		335
		336	Expects a sixteen octet string representing a binary IPv6 address and
		337	returns its textual format. Rarely used, see C<format_address> for a
		338	nicer interface.
		339
181	=item $text = format_address $ipn	340	=item $text = format_address $ipn
182		341
183	Covnvert a host address in network format (e.g. 4 octets for IPv4 or 16	342	Covnvert a host address in network format (e.g. 4 octets for IPv4 or 16
184	octets for IPv6) and convert it into textual form.	343	octets for IPv6) and convert it into textual form.
185		344
…		…
188	This function works similarly to C<inet_ntop AF_INET \|\| AF_INET6, ...>,	347	This function works similarly to C<inet_ntop AF_INET \|\| AF_INET6, ...>,
189	except it automatically detects the address type.	348	except it automatically detects the address type.
190		349
191	Returns C<undef> if it cannot detect the type.	350	Returns C<undef> if it cannot detect the type.
192		351
193	=cut	352	If the C<$ipn> is a mapped IPv4 in IPv6 address (:ffff::<ipv4>), then just
		353	the contained IPv4 address will be returned. If you do not want that, you
		354	have to call C<format_ipv6> manually.
194		355
195	sub format_address;	356	=item $text = AnyEvent::Socket::ntoa $ipn
		357
		358	Same as format_address, but not exported (think C<inet_ntoa>).
		359
		360	=cut
		361
		362	sub format_ipv4($) {
		363	join ".", unpack "C4", $_[0]
		364	}
		365
		366	sub format_ipv6($) {
		367	if (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0 eq $_[0]) {
		368	return "::";
		369	} elsif (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.1 eq $_[0]) {
		370	return "::1";
		371	} elsif (v0.0.0.0.0.0.0.0.0.0.0.0 eq substr $_[0], 0, 12) {
		372	# v4compatible
		373	return "::" . format_ipv4 substr $_[0], 12;
		374	} elsif (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12) {
		375	# v4mapped
		376	return "::ffff:" . format_ipv4 substr $_[0], 12;
		377	} elsif (v0.0.0.0.0.0.0.0.255.255.0.0 eq substr $_[0], 0, 12) {
		378	# v4translated
		379	return "::ffff:0:" . format_ipv4 substr $_[0], 12;
		380	} else {
		381	my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0];
		382
		383	# this is rather sucky, I admit
		384	$ip =~ s/^0:(?:0:)*(0$)?/::/
		385	or $ip =~ s/(:0){7}$/::/ or $ip =~ s/(:0){7}/:/
		386	or $ip =~ s/(:0){6}$/::/ or $ip =~ s/(:0){6}/:/
		387	or $ip =~ s/(:0){5}$/::/ or $ip =~ s/(:0){5}/:/
		388	or $ip =~ s/(:0){4}$/::/ or $ip =~ s/(:0){4}/:/
		389	or $ip =~ s/(:0){3}$/::/ or $ip =~ s/(:0){3}/:/
		390	or $ip =~ s/(:0){2}$/::/ or $ip =~ s/(:0){2}/:/
		391	or $ip =~ s/(:0){1}$/::/ or $ip =~ s/(:0){1}/:/;
		392	return $ip
		393	}
		394	}
		395
196	sub format_address($) {	396	sub format_address($) {
197	my $af = address_family $_[0];	397	my $af = address_family $_[0];
198	if ($af == AF_INET) {	398	if ($af == AF_INET) {
199	return join ".", unpack "C4", $_[0]	399	return &format_ipv4;
200	} elsif ($af == AF_INET6) {	400	} elsif ($af == AF_INET6) {
201	if (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0 eq $_[0]) {
202	return "::";
203	} elsif (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.1 eq $_[0]) {
204	return "::1";
205	} elsif (v0.0.0.0.0.0.0.0.0.0.0.0 eq substr $_[0], 0, 12) {
206	# v4compatible
207	return "::" . format_address substr $_[0], 12;
208	} elsif (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12) {	401	return (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12)
209	# v4mapped	402	? format_ipv4 substr $_[0], 12
210	return "::ffff:" . format_address substr $_[0], 12;	403	: &format_ipv6;
211	} elsif (v0.0.0.0.0.0.0.0.255.255.0.0 eq substr $_[0], 0, 12) {
212	# v4translated
213	return "::ffff:0:" . format_address substr $_[0], 12;
214	} else {
215	my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0];
216
217	# this is rather sucky, I admit
218	$ip =~ s/^0:(?:0:)*(0$)?/::/
219	or $ip =~ s/(:0){7}$/::/ or $ip =~ s/(:0){7}/:/
220	or $ip =~ s/(:0){6}$/::/ or $ip =~ s/(:0){6}/:/
221	or $ip =~ s/(:0){5}$/::/ or $ip =~ s/(:0){5}/:/
222	or $ip =~ s/(:0){4}$/::/ or $ip =~ s/(:0){4}/:/
223	or $ip =~ s/(:0){3}$/::/ or $ip =~ s/(:0){3}/:/
224	or $ip =~ s/(:0){2}$/::/ or $ip =~ s/(:0){2}/:/
225	or $ip =~ s/(:0){1}$/::/ or $ip =~ s/(:0){1}/:/;
226	return $ip
227	}
228	} elsif ($af == AF_UNIX) {	404	} elsif ($af == AF_UNIX) {
229	return "unix/"	405	return "unix/"
230	} else {	406	} else {
231	return undef	407	return undef
232	}	408	}
233	}	409	}
234		410
235	*format_ip = \&format_address;	411	*ntoa = \&format_address;
236		412
237	=item inet_aton $name_or_address, $cb->(@addresses)	413	=item inet_aton $name_or_address, $cb->(@addresses)
238		414
239	Works similarly to its Socket counterpart, except that it uses a	415	Works similarly to its Socket counterpart, except that it uses a
240	callback. Also, if a host has only an IPv6 address, this might be passed	416	callback. Also, if a host has only an IPv6 address, this might be passed
…		…
268	}	444	}
269	});	445	});
270	}	446	}
271	}	447	}
272		448
		449	BEGIN {
		450	*sockaddr_family = $Socket::VERSION >= 1.75
		451	? \&Socket::sockaddr_family
		452	: # for 5.6.x, we need to do something much more horrible
		453	(Socket::pack_sockaddr_in 0x5555, "\x55\x55\x55\x55"
		454	\| eval { Socket::pack_sockaddr_un "U" }) =~ /^\x00/
		455	? sub { unpack "xC", $_[0] }
		456	: sub { unpack "S" , $_[0] };
		457	}
		458
273	# check for broken platforms with extra field in sockaddr structure	459	# check for broken platforms with extra field in sockaddr structure
274	# kind of a rfc vs. bsd issue, as usual (ok, normally it's a	460	# kind of a rfc vs. bsd issue, as usual (ok, normally it's a
275	# unix vs. bsd issue, a iso C vs. bsd issue or simply a	461	# unix vs. bsd issue, a iso C vs. bsd issue or simply a
276	# correctness vs. bsd issue.	462	# correctness vs. bsd issue.)
277	my $pack_family = (0x55 == Socket::sockaddr_family "\x55\x55")	463	my $pack_family = 0x55 == sockaddr_family ("\x55\x55")
278	? "xC" : "S";	464	? "xC" : "S";
279		465
280	=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host	466	=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host
281		467
282	Pack the given port/host combination into a binary sockaddr	468	Pack the given port/host combination into a binary sockaddr
…		…
317	is a special token that is understood by the other functions in this	503	is a special token that is understood by the other functions in this
318	module (C<format_address> converts it to C<unix/>).	504	module (C<format_address> converts it to C<unix/>).
319		505
320	=cut	506	=cut
321		507
		508	# perl contains a bug (imho) where it requires that the kernel always returns
		509	# sockaddr_un structures of maximum length (which is not, AFAICS, required
		510	# by any standard). try to 0-pad structures for the benefit of those platforms.
		511
		512	my $sa_un_zero = eval { Socket::pack_sockaddr_un "" }; $sa_un_zero ^= $sa_un_zero;
		513
322	sub unpack_sockaddr($) {	514	sub unpack_sockaddr($) {
323	my $af = Socket::sockaddr_family $_[0];	515	my $af = sockaddr_family $_[0];
324		516
325	if ($af == AF_INET) {	517	if ($af == AF_INET) {
326	Socket::unpack_sockaddr_in $_[0]	518	Socket::unpack_sockaddr_in $_[0]
327	} elsif ($af == AF_INET6) {	519	} elsif ($af == AF_INET6) {
328	unpack "x2 n x4 a16", $_[0]	520	unpack "x2 n x4 a16", $_[0]
329	} elsif ($af == AF_UNIX) {	521	} elsif ($af == AF_UNIX) {
330	((Socket::unpack_sockaddr_un $_[0]), pack "S", AF_UNIX)	522	((Socket::unpack_sockaddr_un $_[0] ^ $sa_un_zero), pack "S", AF_UNIX)
331	} else {	523	} else {
332	Carp::croak "unpack_sockaddr: unsupported protocol family $af";	524	Carp::croak "unpack_sockaddr: unsupported protocol family $af";
333	}	525	}
334	}	526	}
335		527
…		…
356	C<sctp>. The default is currently C<tcp>, but in the future, this function	548	C<sctp>. The default is currently C<tcp>, but in the future, this function
357	might try to use other protocols such as C<sctp>, depending on the socket	549	might try to use other protocols such as C<sctp>, depending on the socket
358	type and any SRV records it might find.	550	type and any SRV records it might find.
359		551
360	C<$family> must be either C<0> (meaning any protocol is OK), C<4> (use	552	C<$family> must be either C<0> (meaning any protocol is OK), C<4> (use
361	only IPv4) or C<6> (use only IPv6). This setting might be influenced by	553	only IPv4) or C<6> (use only IPv6). The default is influenced by
362	C<$ENV{PERL_ANYEVENT_PROTOCOLS}>.	554	C<$ENV{PERL_ANYEVENT_PROTOCOLS}>.
363		555
364	C<$type> must be C<SOCK_STREAM>, C<SOCK_DGRAM> or C<SOCK_SEQPACKET> (or	556	C<$type> must be C<SOCK_STREAM>, C<SOCK_DGRAM> or C<SOCK_SEQPACKET> (or
365	C<undef> in which case it gets automatically chosen).	557	C<undef> in which case it gets automatically chosen to be C<SOCK_STREAM>
		558	unless C<$proto> is C<udp>).
366		559
367	The callback will receive zero or more array references that contain	560	The callback will receive zero or more array references that contain
368	C<$family, $type, $proto> for use in C<socket> and a binary	561	C<$family, $type, $proto> for use in C<socket> and a binary
369	C<$sockaddr> for use in C<connect> (or C<bind>).	562	C<$sockaddr> for use in C<connect> (or C<bind>).
370		563
…		…
378		571
379	sub resolve_sockaddr($$$$$$) {	572	sub resolve_sockaddr($$$$$$) {
380	my ($node, $service, $proto, $family, $type, $cb) = @_;	573	my ($node, $service, $proto, $family, $type, $cb) = @_;
381		574
382	if ($node eq "unix/") {	575	if ($node eq "unix/") {
383	return $cb->() if $family \|\| !/^\//; # no can do	576	return $cb->() if $family \|\| $service !~ /^\//; # no can do
384		577
385	return $cb->([AF_UNIX, $type, 0, Socket::pack_sockaddr_un $service]);	578	return $cb->([AF_UNIX, defined $type ? $type : SOCK_STREAM, 0, Socket::pack_sockaddr_un $service]);
386	}	579	}
387		580
388	unless (AF_INET6) {	581	unless (AF_INET6) {
389	$family != 6	582	$family != 6
390	or return $cb->();	583	or return $cb->();
…		…
399	$family \|\|= 6 unless $AnyEvent::PROTOCOL{ipv4};	592	$family \|\|= 6 unless $AnyEvent::PROTOCOL{ipv4};
400		593
401	$proto \|\|= "tcp";	594	$proto \|\|= "tcp";
402	$type \|\|= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM;	595	$type \|\|= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM;
403		596
404	my $proton = (getprotobyname $proto)[2]	597	my $proton = getprotobyname $proto
405	or Carp::croak "$proto: protocol unknown";	598	or Carp::croak "$proto: protocol unknown";
406		599
407	my $port;	600	my $port;
408		601
409	if ($service =~ /^(\S+)=(\d+)$/) {	602	if ($service =~ /^(\S+)=(\d+)$/) {
…		…
418	my @target = [$node, $port];	611	my @target = [$node, $port];
419		612
420	# resolve a records / provide sockaddr structures	613	# resolve a records / provide sockaddr structures
421	my $resolve = sub {	614	my $resolve = sub {
422	my @res;	615	my @res;
423	my $cv = AnyEvent->condvar (cb => sub {	616	my $cv = AE::cv {
424	$cb->(	617	$cb->(
425	map $_->[2],	618	map $_->[2],
426	sort {	619	sort {
427	$AnyEvent::PROTOCOL{$b->[1]} <=> $AnyEvent::PROTOCOL{$a->[1]}	620	$AnyEvent::PROTOCOL{$b->[1]} <=> $AnyEvent::PROTOCOL{$a->[1]}
428	or $a->[0] <=> $b->[0]	621	or $a->[0] <=> $b->[0]
429	}	622	}
430	@res	623	@res
431	)	624	)
432	});	625	};
433		626
434	$cv->begin;	627	$cv->begin;
435	for my $idx (0 .. $#target) {	628	for my $idx (0 .. $#target) {
436	my ($node, $port) = @{ $target[$idx] };	629	my ($node, $port) = @{ $target[$idx] };
437		630
…		…
516		709
517	In either case, it will create a list of target hosts (e.g. for multihomed	710	In either case, it will create a list of target hosts (e.g. for multihomed
518	hosts or hosts with both IPv4 and IPv6 addresses) and try to connect to	711	hosts or hosts with both IPv4 and IPv6 addresses) and try to connect to
519	each in turn.	712	each in turn.
520		713
521	If the connect is successful, then the C<$connect_cb> will be invoked with	714	After the connection is established, then the C<$connect_cb> will be
522	the socket file handle (in non-blocking mode) as first and the peer host	715	invoked with the socket file handle (in non-blocking mode) as first and
523	(as a textual IP address) and peer port as second and third arguments,	716	the peer host (as a textual IP address) and peer port as second and third
524	respectively. The fourth argument is a code reference that you can call	717	arguments, respectively. The fourth argument is a code reference that you
525	if, for some reason, you don't like this connection, which will cause	718	can call if, for some reason, you don't like this connection, which will
526	C<tcp_connect> to try the next one (or call your callback without any	719	cause C<tcp_connect> to try the next one (or call your callback without
527	arguments if there are no more connections). In most cases, you can simply	720	any arguments if there are no more connections). In most cases, you can
528	ignore this argument.	721	simply ignore this argument.
529		722
530	$cb->($filehandle, $host, $port, $retry)	723	$cb->($filehandle, $host, $port, $retry)
531		724
532	If the connect is unsuccessful, then the C<$connect_cb> will be invoked	725	If the connect is unsuccessful, then the C<$connect_cb> will be invoked
533	without any arguments and C<$!> will be set appropriately (with C<ENXIO>	726	without any arguments and C<$!> will be set appropriately (with C<ENXIO>
534	indicating a DNS resolution failure).	727	indicating a DNS resolution failure).
		728
		729	The callback will I<never> be invoked before C<tcp_connect> returns, even
		730	if C<tcp_connect> was able to connect immediately (e.g. on unix domain
		731	sockets).
535		732
536	The file handle is perfect for being plugged into L<AnyEvent::Handle>, but	733	The file handle is perfect for being plugged into L<AnyEvent::Handle>, but
537	can be used as a normal perl file handle as well.	734	can be used as a normal perl file handle as well.
538		735
539	Unless called in void context, C<tcp_connect> returns a guard object that	736	Unless called in void context, C<tcp_connect> returns a guard object that
…		…
578	or die "unable to connect: $!";	775	or die "unable to connect: $!";
579		776
580	my $handle; # avoid direct assignment so on_eof has it in scope.	777	my $handle; # avoid direct assignment so on_eof has it in scope.
581	$handle = new AnyEvent::Handle	778	$handle = new AnyEvent::Handle
582	fh => $fh,	779	fh => $fh,
		780	on_error => sub {
		781	warn "error $_[2]\n";
		782	$_[0]->destroy;
		783	},
583	on_eof => sub {	784	on_eof => sub {
584	undef $handle; # keep it alive till eof	785	$handle->destroy; # destroy handle
585	warn "done.\n";	786	warn "done.\n";
586	};	787	};
587		788
588	$handle->push_write ("GET / HTTP/1.0\015\012\015\012");	789	$handle->push_write ("GET / HTTP/1.0\015\012\015\012");
589		790
590	$handle->push_read_line ("\015\012\015\012", sub {	791	$handle->push_read (line => "\015\012\015\012", sub {
591	my ($handle, $line) = @_;	792	my ($handle, $line) = @_;
592		793
593	# print response header	794	# print response header
594	print "HEADER\n$line\n\nBODY\n";	795	print "HEADER\n$line\n\nBODY\n";
595		796
…		…
621	# also http://advogato.org/article/672.html	822	# also http://advogato.org/article/672.html
622		823
623	my %state = ( fh => undef );	824	my %state = ( fh => undef );
624		825
625	# name/service to type/sockaddr resolution	826	# name/service to type/sockaddr resolution
626	resolve_sockaddr $host, $port, 0, 0, 0, sub {	827	resolve_sockaddr $host, $port, 0, 0, undef, sub {
627	my @target = @_;	828	my @target = @_;
628		829
629	$state{next} = sub {	830	$state{next} = sub {
630	return unless exists $state{fh};	831	return unless exists $state{fh};
631		832
632	my $target = shift @target	833	my $target = shift @target
633	or do {	834	or return (%state = (), _postpone $connect);
634	%state = ();
635	return $connect->();
636	};
637		835
638	my ($domain, $type, $proto, $sockaddr) = @$target;	836	my ($domain, $type, $proto, $sockaddr) = @$target;
639		837
640	# socket creation	838	# socket creation
641	socket $state{fh}, $domain, $type, $proto	839	socket $state{fh}, $domain, $type, $proto
…		…
645		843
646	my $timeout = $prepare && $prepare->($state{fh});	844	my $timeout = $prepare && $prepare->($state{fh});
647		845
648	$timeout \|\|= 30 if AnyEvent::WIN32;	846	$timeout \|\|= 30 if AnyEvent::WIN32;
649		847
650	$state{to} = AnyEvent->timer (after => $timeout, cb => sub {	848	$state{to} = AE::timer $timeout, 0, sub {
651	$! = &Errno::ETIMEDOUT;	849	$! = Errno::ETIMEDOUT;
652	$state{next}();	850	$state{next}();
653	}) if $timeout;	851	} if $timeout;
654		852
655	# called when the connect was successful, which,	853	# now connect
656	# in theory, could be the case immediately (but never is in practise)	854	if (
657	my $connected = sub {	855	(connect $state{fh}, $sockaddr)
658	delete $state{ww};	856	\|\| ($! == Errno::EINPROGRESS # POSIX
659	delete $state{to};	857	\|\| $! == Errno::EWOULDBLOCK
660		858	# WSAEINPROGRESS intentionally not checked - it means something else entirely
		859	\|\| $! == AnyEvent::Util::WSAEINVAL # not convinced, but doesn't hurt
		860	\|\| $! == AnyEvent::Util::WSAEWOULDBLOCK)
		861	) {
		862	$state{ww} = AE::io $state{fh}, 1, sub {
661	# we are connected, or maybe there was an error	863	# we are connected, or maybe there was an error
662	if (my $sin = getpeername $state{fh}) {	864	if (my $sin = getpeername $state{fh}) {
663	my ($port, $host) = unpack_sockaddr $sin;	865	my ($port, $host) = unpack_sockaddr $sin;
664		866
		867	delete $state{ww}; delete $state{to};
		868
665	my $guard = guard {	869	my $guard = guard { %state = () };
666	%state = ();
667	};
668		870
669	$connect->($state{fh}, format_address $host, $port, sub {	871	$connect->(delete $state{fh}, format_address $host, $port, sub {
670	$guard->cancel;	872	$guard->cancel;
		873	$state{next}();
		874	});
		875	} else {
		876	# dummy read to fetch real error code
		877	sysread $state{fh}, my $buf, 1 if $! == Errno::ENOTCONN;
		878
		879	return if $! == Errno::EAGAIN; # skip spurious wake-ups
		880
		881	delete $state{ww}; delete $state{to};
		882
671	$state{next}();	883	$state{next}();
672	});	884	}
673	} else {
674	# dummy read to fetch real error code
675	sysread $state{fh}, my $buf, 1 if $! == &Errno::ENOTCONN;
676	$state{next}();
677	}	885	};
678	};
679
680	# now connect
681	if (connect $state{fh}, $sockaddr) {
682	$connected->();
683	} elsif ($! == &Errno::EINPROGRESS # POSIX
684	\|\| $! == &Errno::EWOULDBLOCK
685	# WSAEINPROGRESS intentionally not checked - it means something else entirely
686	\|\| $! == AnyEvent::Util::WSAEINVAL # not convinced, but doesn't hurt
687	\|\| $! == AnyEvent::Util::WSAEWOULDBLOCK) {
688	$state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $connected);
689	} else {	886	} else {
690	$state{next}();	887	$state{next}();
691	}	888	}
692	};	889	};
693		890
694	$! = &Errno::ENXIO;	891	$! = Errno::ENXIO;
695	$state{next}();	892	$state{next}();
696	};	893	};
697		894
698	defined wantarray && guard { %state = () }	895	defined wantarray && guard { %state = () }
699	}	896	}
…		…
758	}, sub {	955	}, sub {
759	my ($fh, $thishost, $thisport) = @_;	956	my ($fh, $thishost, $thisport) = @_;
760	warn "bound to $thishost, port $thisport\n";	957	warn "bound to $thishost, port $thisport\n";
761	};	958	};
762		959
		960	Example: bind a server on a unix domain socket.
		961
		962	tcp_server "unix/", "/tmp/mydir/mysocket", sub {
		963	my ($fh) = @_;
		964	};
		965
763	=cut	966	=cut
764		967
765	sub tcp_server($$$;$) {	968	sub tcp_server($$$;$) {
766	my ($host, $service, $accept, $prepare) = @_;	969	my ($host, $service, $accept, $prepare) = @_;
767		970
…		…
811	$len \|\|= 128;	1014	$len \|\|= 128;
812		1015
813	listen $state{fh}, $len	1016	listen $state{fh}, $len
814	or Carp::croak "listen: $!";	1017	or Carp::croak "listen: $!";
815		1018
816	$state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub {	1019	$state{aw} = AE::io $state{fh}, 0, sub {
817	# this closure keeps $state alive	1020	# this closure keeps $state alive
818	while (my $peer = accept my $fh, $state{fh}) {	1021	while (my $peer = accept my $fh, $state{fh}) {
819	fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not	1022	fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not
820		1023
821	my ($service, $host) = unpack_sockaddr $peer;	1024	my ($service, $host) = unpack_sockaddr $peer;
822	$accept->($fh, format_address $host, $service);	1025	$accept->($fh, format_address $host, $service);
823	}	1026	}
824	});	1027	};
825		1028
826	defined wantarray	1029	defined wantarray
827	? guard { %state = () } # clear fh and watcher, which breaks the circular dependency	1030	? guard { %state = () } # clear fh and watcher, which breaks the circular dependency
828	: ()	1031	: ()
829	}	1032	}

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents): Revision 1.45 by root, Sat May 31 13:38:01 2008 UTC vs. Revision 1.114 by root, Fri Aug 21 11:59:25 2009 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.45 by root, Sat May 31 13:38:01 2008 UTC vs.
Revision 1.114 by root, Fri Aug 21 11:59:25 2009 UTC