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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.42 by root, Thu May 29 23:18:37 2008 UTC vs.
Revision 1.107 by root, Thu Aug 6 13:31:01 2009 UTC

…		…
2		2
3	AnyEvent::Socket - useful IPv4 and IPv6 stuff.	3	AnyEvent::Socket - useful IPv4 and IPv6 stuff.
4		4
5	=head1 SYNOPSIS	5	=head1 SYNOPSIS
6		6
7	use AnyEvent::Socket;	7	use AnyEvent::Socket;
8		8
9	tcp_connect "gameserver.deliantra.net", 13327, sub {	9	tcp_connect "gameserver.deliantra.net", 13327, sub {
10	my ($fh) = @_	10	my ($fh) = @_
11	or die "gameserver.deliantra.net connect failed: $!";	11	or die "gameserver.deliantra.net connect failed: $!";
12		12
13	# enjoy your filehandle	13	# enjoy your filehandle
14	};	14	};
15		15
16	# a simple tcp server	16	# a simple tcp server
17	tcp_server undef, 8888, sub {	17	tcp_server undef, 8888, sub {
18	my ($fh, $host, $port) = @_;	18	my ($fh, $host, $port) = @_;
19		19
20	syswrite $fh, "The internet is full, $host:$port. Go away!\015\012";	20	syswrite $fh, "The internet is full, $host:$port. Go away!\015\012";
21	};	21	};
22		22
23	=head1 DESCRIPTION	23	=head1 DESCRIPTION
24		24
25	This module implements various utility functions for handling internet	25	This module implements various utility functions for handling internet
26	protocol addresses and sockets, in an as transparent and simple way as	26	protocol addresses and sockets, in an as transparent and simple way as
…		…
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 = '1.0';	61	our $VERSION = 4.901;
62		62
63	=item $ipn = parse_ipv4 $dotted_quad	63	=item $ipn = parse_ipv4 $dotted_quad
64		64
65	Tries to parse the given dotted quad IPv4 address and return it in	65	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	66	octet form (or undef when it isn't in a parsable format). Supports all
…		…
78		78
79	# check leading parts against range	79	# check leading parts against range
80	return undef if grep $_ >= 256, @_[0 .. @_ - 2];	80	return undef if grep $_ >= 256, @_[0 .. @_ - 2];
81		81
82	# check trailing part against range	82	# check trailing part against range
83	return undef if $_[-1] >= 1 << (8 * (4 - $#_));	83	return undef if $_[-1] >= 2 ** (8 * (4 - $#_));
84		84
85	pack "N", (pop)	85	pack "N", (pop)
86	+ ($_[0] << 24)	86	+ ($_[0] << 24)
87	+ ($_[1] << 16)	87	+ ($_[1] << 16)
88	+ ($_[2] << 8);	88	+ ($_[2] << 8);
…		…
143	? pack "S", AF_UNIX	143	? pack "S", AF_UNIX
144	: undef	144	: undef
145		145
146	}	146	}
147		147
148	=item $ipn = parse_address $text	148	=item $ipn = parse_address $ip
149		149
150	Combines C<parse_ipv4> and C<parse_ipv6> in one function. The address	150	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	151	here refers to the host address (not socket address) in network form
152	(binary).	152	(binary).
153		153
154	If the C<$text> is C<unix/>, then this function returns a special token	154	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	155	recognised by the other functions in this module to mean "UNIX domain
156	socket".	156	socket".
157		157
		158	If the C<$text> to parse is a mapped IPv4 in IPv6 address (:ffff::<ipv4>),
		159	then it will be treated as an IPv4 address. If you don't want that, you
		160	have to call C<parse_ipv4> and/or C<parse_ipv6> manually.
		161
		162	=item $ipn = AnyEvent::Socket::aton $ip
		163
		164	Same as C<parse_address>, but not exported (think C<Socket::inet_aton> but
		165	I<without> name resolution).
		166
158	=cut	167	=cut
159		168
160	sub parse_address($) {	169	sub parse_address($) {
161	&parse_ipv4 \|\| &parse_ipv6 \|\| &parse_unix	170	for (&parse_ipv6) {
		171	if ($_) {
		172	s/^\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff//;
		173	return $_;
		174	} else {
		175	return &parse_ipv4 \|\| &parse_unix
		176	}
		177	}
162	}	178	}
163		179
164	*parse_ip =\&parse_address; #d#	180	*aton = \&parse_address;
		181
		182	=item ($name, $aliases, $proto) = getprotobyname $name
		183
		184	Works like the builtin function of the same name, except it tries hard to
		185	work even on broken platforms (well, that's windows), where getprotobyname
		186	is traditionally very unreliable.
		187
		188	=cut
		189
		190	# microsoft can't even get getprotobyname working (the etc/protocols file
		191	# gets lost fairly often on windows), so we have to hardcode some common
		192	# protocol numbers ourselves.
		193	our %PROTO_BYNAME;
		194
		195	$PROTO_BYNAME{tcp} = Socket::IPPROTO_TCP () if defined &Socket::IPPROTO_TCP;
		196	$PROTO_BYNAME{udp} = Socket::IPPROTO_UDP () if defined &Socket::IPPROTO_UDP;
		197	$PROTO_BYNAME{icmp} = Socket::IPPROTO_ICMP() if defined &Socket::IPPROTO_ICMP;
		198
		199	sub getprotobyname($) {
		200	my $name = lc shift;
		201
		202	defined (my $proton = $PROTO_BYNAME{$name} \|\| (getprotobyname $name)[2])
		203	or return;
		204
		205	($name, uc $name, $proton)
		206	}
		207
		208	=item ($host, $service) = parse_hostport $string[, $default_service]
		209
		210	Splitting a string of the form C<hostname:port> is a common
		211	problem. Unfortunately, just splitting on the colon makes it hard to
		212	specify IPv6 addresses and doesn't support the less common but well
		213	standardised C<[ip literal]> syntax.
		214
		215	This function tries to do this job in a better way, it supports the
		216	following formats, where C<port> can be a numerical port number of a
		217	service name, or a C<name=port> string, and the C< port> and C<:port>
		218	parts are optional. Also, everywhere where an IP address is supported
		219	a hostname or unix domain socket address is also supported (see
		220	C<parse_unix>).
		221
		222	hostname:port e.g. "www.linux.org", "www.x.de:443", "www.x.de:https=443"
		223	ipv4:port e.g. "198.182.196.56", "127.1:22"
		224	ipv6 e.g. "::1", "affe::1"
		225	[ipv4or6]:port e.g. "[::1]", "[10.0.1]:80"
		226	[ipv4or6] port e.g. "[127.0.0.1]", "[www.x.org] 17"
		227	ipv4or6 port e.g. "::1 443", "10.0.0.1 smtp"
		228
		229	It also supports defaulting the service name in a simple way by using
		230	C<$default_service> if no service was detected. If neither a service was
		231	detected nor a default was specified, then this function returns the
		232	empty list. The same happens when a parse error was detected, such as a
		233	hostname with a colon in it (the function is rather conservative, though).
		234
		235	Example:
		236
		237	print join ",", parse_hostport "localhost:443";
		238	# => "localhost,443"
		239
		240	print join ",", parse_hostport "localhost", "https";
		241	# => "localhost,https"
		242
		243	print join ",", parse_hostport "[::1]";
		244	# => "," (empty list)
		245
		246	=cut
		247
		248	sub parse_hostport($;$) {
		249	my ($host, $port);
		250
		251	for ("$_[0]") { # work on a copy, just in case, and also reset pos
		252
		253	# parse host, special cases: "ipv6" or "ipv6 port"
		254	unless (
		255	($host) = /^\s* ([0-9a-fA-F:]:[0-9a-fA-F:]:[0-9a-fA-F\.:]*)/xgc
		256	and parse_ipv6 $host
		257	) {
		258	/^\s*/xgc;
		259
		260	if (/^ \[ ([^\[\]]+) \]/xgc) {
		261	$host = $1;
		262	} elsif (/^ ([^\[\]:\ ]+) /xgc) {
		263	$host = $1;
		264	} else {
		265	return;
		266	}
		267	}
		268
		269	# parse port
		270	if (/\G (?:\s+\|:) ([^:[:space:]]+) \s*$/xgc) {
		271	$port = $1;
		272	} elsif (/\G\s*$/gc && length $_[1]) {
		273	$port = $_[1];
		274	} else {
		275	return;
		276	}
		277	}
		278
		279	# hostnames must not contain :'s
		280	return if $host =~ /:/ && !parse_ipv6 $host;
		281
		282	($host, $port)
		283	}
		284
		285	=item $string = format_hostport $host, $port
		286
		287	Takes a host (in textual form) and a port and formats in unambigiously in
		288	a way that C<parse_hostport> can parse it again. C<$port> can be C<undef>.
		289
		290	=cut
		291
		292	sub format_hostport($;$) {
		293	my ($host, $port) = @_;
		294
		295	$port = ":$port" if length $port;
		296	$host = "[$host]" if $host =~ /:/;
		297
		298	"$host$port"
		299	}
165		300
166	=item $sa_family = address_family $ipn	301	=item $sa_family = address_family $ipn
167		302
168	Returns the address family/protocol-family (AF_xxx/PF_xxx, in one value :)	303	Returns the address family/protocol-family (AF_xxx/PF_xxx, in one value :)
169	of the given host address in network format.	304	of the given host address in network format.
…		…
176	: 16 == length $_[0]	311	: 16 == length $_[0]
177	? AF_INET6	312	? AF_INET6
178	: unpack "S", $_[0]	313	: unpack "S", $_[0]
179	}	314	}
180		315
		316	=item $text = format_ipv4 $ipn
		317
		318	Expects a four octet string representing a binary IPv4 address and returns
		319	its textual format. Rarely used, see C<format_address> for a nicer
		320	interface.
		321
		322	=item $text = format_ipv6 $ipn
		323
		324	Expects a sixteen octet string representing a binary IPv6 address and
		325	returns its textual format. Rarely used, see C<format_address> for a
		326	nicer interface.
		327
181	=item $text = format_address $ipn	328	=item $text = format_address $ipn
182		329
183	Covnvert a host address in network format (e.g. 4 octets for IPv4 or 16	330	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.	331	octets for IPv6) and convert it into textual form.
185		332
…		…
188	This function works similarly to C<inet_ntop AF_INET \|\| AF_INET6, ...>,	335	This function works similarly to C<inet_ntop AF_INET \|\| AF_INET6, ...>,
189	except it automatically detects the address type.	336	except it automatically detects the address type.
190		337
191	Returns C<undef> if it cannot detect the type.	338	Returns C<undef> if it cannot detect the type.
192		339
193	=cut	340	If the C<$ipn> is a mapped IPv4 in IPv6 address (:ffff::<ipv4>), then just
		341	the contained IPv4 address will be returned. If you do not want that, you
		342	have to call C<format_ipv6> manually.
194		343
195	sub format_address;	344	=item $text = AnyEvent::Socket::ntoa $ipn
		345
		346	Same as format_address, but not exported (think C<inet_ntoa>).
		347
		348	=cut
		349
		350	sub format_ipv4($) {
		351	join ".", unpack "C4", $_[0]
		352	}
		353
		354	sub format_ipv6($) {
		355	if (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0 eq $_[0]) {
		356	return "::";
		357	} elsif (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.1 eq $_[0]) {
		358	return "::1";
		359	} elsif (v0.0.0.0.0.0.0.0.0.0.0.0 eq substr $_[0], 0, 12) {
		360	# v4compatible
		361	return "::" . format_ipv4 substr $_[0], 12;
		362	} elsif (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12) {
		363	# v4mapped
		364	return "::ffff:" . format_ipv4 substr $_[0], 12;
		365	} elsif (v0.0.0.0.0.0.0.0.255.255.0.0 eq substr $_[0], 0, 12) {
		366	# v4translated
		367	return "::ffff:0:" . format_ipv4 substr $_[0], 12;
		368	} else {
		369	my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0];
		370
		371	# this is rather sucky, I admit
		372	$ip =~ s/^0:(?:0:)*(0$)?/::/
		373	or $ip =~ s/(:0){7}$/::/ or $ip =~ s/(:0){7}/:/
		374	or $ip =~ s/(:0){6}$/::/ or $ip =~ s/(:0){6}/:/
		375	or $ip =~ s/(:0){5}$/::/ or $ip =~ s/(:0){5}/:/
		376	or $ip =~ s/(:0){4}$/::/ or $ip =~ s/(:0){4}/:/
		377	or $ip =~ s/(:0){3}$/::/ or $ip =~ s/(:0){3}/:/
		378	or $ip =~ s/(:0){2}$/::/ or $ip =~ s/(:0){2}/:/
		379	or $ip =~ s/(:0){1}$/::/ or $ip =~ s/(:0){1}/:/;
		380	return $ip
		381	}
		382	}
		383
196	sub format_address($) {	384	sub format_address($) {
197	my $af = address_family $_[0];	385	my $af = address_family $_[0];
198	if ($af == AF_INET) {	386	if ($af == AF_INET) {
199	return join ".", unpack "C4", $_[0]	387	return &format_ipv4;
200	} elsif ($af == AF_INET6) {	388	} 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) {	389	return (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12)
209	# v4mapped	390	? format_ipv4 substr $_[0], 12
210	return "::ffff:" . format_address substr $_[0], 12;	391	: &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) {	392	} elsif ($af == AF_UNIX) {
229	return "unix/"	393	return "unix/"
230	} else {	394	} else {
231	return undef	395	return undef
232	}	396	}
233	}	397	}
234		398
235	*format_ip = \&format_address;	399	*ntoa = \&format_address;
236		400
237	=item inet_aton $name_or_address, $cb->(@addresses)	401	=item inet_aton $name_or_address, $cb->(@addresses)
238		402
239	Works similarly to its Socket counterpart, except that it uses a	403	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	404	callback. Also, if a host has only an IPv6 address, this might be passed
…		…
268	}	432	}
269	});	433	});
270	}	434	}
271	}	435	}
272		436
		437	BEGIN {
		438	*sockaddr_family = $Socket::VERSION >= 1.75
		439	? \&Socket::sockaddr_family
		440	: # for 5.6.x, we need to do something much more horrible
		441	(Socket::pack_sockaddr_in 0x5555, "\x55\x55\x55\x55"
		442	\| eval { Socket::pack_sockaddr_un "U" }) =~ /^\x00/
		443	? sub { unpack "xC", $_[0] }
		444	: sub { unpack "S" , $_[0] };
		445	}
		446
273	# check for broken platforms with extra field in sockaddr structure	447	# 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	448	# 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	449	# unix vs. bsd issue, a iso C vs. bsd issue or simply a
276	# correctness vs. bsd issue.	450	# correctness vs. bsd issue.)
277	my $pack_family = (0x55 == Socket::sockaddr_family "\x55\x55")	451	my $pack_family = 0x55 == sockaddr_family ("\x55\x55")
278	? "xC" : "S";	452	? "xC" : "S";
279		453
280	=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host	454	=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host
281		455
282	Pack the given port/host combination into a binary sockaddr	456	Pack the given port/host combination into a binary sockaddr
…		…
318	module (C<format_address> converts it to C<unix/>).	492	module (C<format_address> converts it to C<unix/>).
319		493
320	=cut	494	=cut
321		495
322	sub unpack_sockaddr($) {	496	sub unpack_sockaddr($) {
323	my $af = Socket::sockaddr_family $_[0];	497	my $af = sockaddr_family $_[0];
324		498
325	if ($af == AF_INET) {	499	if ($af == AF_INET) {
326	Socket::unpack_sockaddr_in $_[0]	500	Socket::unpack_sockaddr_in $_[0]
327	} elsif ($af == AF_INET6) {	501	} elsif ($af == AF_INET6) {
328	unpack "x2 n x4 a16", $_[0]	502	unpack "x2 n x4 a16", $_[0]
…		…
356	C<sctp>. The default is currently C<tcp>, but in the future, this function	530	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	531	might try to use other protocols such as C<sctp>, depending on the socket
358	type and any SRV records it might find.	532	type and any SRV records it might find.
359		533
360	C<$family> must be either C<0> (meaning any protocol is OK), C<4> (use	534	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	535	only IPv4) or C<6> (use only IPv6). The default is influenced by
362	C<$ENV{PERL_ANYEVENT_PROTOCOLS}>.	536	C<$ENV{PERL_ANYEVENT_PROTOCOLS}>.
363		537
364	C<$type> must be C<SOCK_STREAM>, C<SOCK_DGRAM> or C<SOCK_SEQPACKET> (or	538	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).	539	C<undef> in which case it gets automatically chosen to be C<SOCK_STREAM>
		540	unless C<$proto> is C<udp>).
366		541
367	The callback will receive zero or more array references that contain	542	The callback will receive zero or more array references that contain
368	C<$family, $type, $proto> for use in C<socket> and a binary	543	C<$family, $type, $proto> for use in C<socket> and a binary
369	C<$sockaddr> for use in C<connect> (or C<bind>).	544	C<$sockaddr> for use in C<connect> (or C<bind>).
370		545
…		…
378		553
379	sub resolve_sockaddr($$$$$$) {	554	sub resolve_sockaddr($$$$$$) {
380	my ($node, $service, $proto, $family, $type, $cb) = @_;	555	my ($node, $service, $proto, $family, $type, $cb) = @_;
381		556
382	if ($node eq "unix/") {	557	if ($node eq "unix/") {
383	return $cb->() if $family \|\| !/^\//; # no can do	558	return $cb->() if $family \|\| $service !~ /^\//; # no can do
384		559
385	return $cb->([AF_UNIX, $type, 0, Socket::pack_sockaddr_un $service]);	560	return $cb->([AF_UNIX, defined $type ? $type : SOCK_STREAM, 0, Socket::pack_sockaddr_un $service]);
386	}	561	}
387		562
388	unless (AF_INET6) {	563	unless (AF_INET6) {
389	$family != 6	564	$family != 6
390	or return $cb->();	565	or return $cb->();
…		…
399	$family \|\|= 6 unless $AnyEvent::PROTOCOL{ipv4};	574	$family \|\|= 6 unless $AnyEvent::PROTOCOL{ipv4};
400		575
401	$proto \|\|= "tcp";	576	$proto \|\|= "tcp";
402	$type \|\|= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM;	577	$type \|\|= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM;
403		578
404	my $proton = (getprotobyname $proto)[2]	579	my $proton = getprotobyname $proto
405	or Carp::croak "$proto: protocol unknown";	580	or Carp::croak "$proto: protocol unknown";
406		581
407	my $port;	582	my $port;
408		583
409	if ($service =~ /^(\S+)=(\d+)$/) {	584	if ($service =~ /^(\S+)=(\d+)$/) {
…		…
418	my @target = [$node, $port];	593	my @target = [$node, $port];
419		594
420	# resolve a records / provide sockaddr structures	595	# resolve a records / provide sockaddr structures
421	my $resolve = sub {	596	my $resolve = sub {
422	my @res;	597	my @res;
423	my $cv = AnyEvent->condvar (cb => sub {	598	my $cv = AE::cv {
424	$cb->(	599	$cb->(
425	map $_->[2],	600	map $_->[2],
426	sort {	601	sort {
427	$AnyEvent::PROTOCOL{$b->[1]} <=> $AnyEvent::PROTOCOL{$a->[1]}	602	$AnyEvent::PROTOCOL{$b->[1]} <=> $AnyEvent::PROTOCOL{$a->[1]}
428	or $a->[0] <=> $b->[0]	603	or $a->[0] <=> $b->[0]
429	}	604	}
430	@res	605	@res
431	)	606	)
432	});	607	};
433		608
434	$cv->begin;	609	$cv->begin;
435	for my $idx (0 .. $#target) {	610	for my $idx (0 .. $#target) {
436	my ($node, $port) = @{ $target[$idx] };	611	my ($node, $port) = @{ $target[$idx] };
437		612
…		…
484		659
485	# no srv records, continue traditionally	660	# no srv records, continue traditionally
486	@srv	661	@srv
487	or return &$resolve;	662	or return &$resolve;
488		663
489	# only srv record has "." ("" here) => abort	664	# the only srv record has "." ("" here) => abort
490	$srv[0][2] ne "" \|\| $#srv	665	$srv[0][2] ne "" \|\| $#srv
491	or return $cb->();	666	or return $cb->();
492		667
493	# use srv records then	668	# use srv records then
494	@target = map ["$_->[3].", $_->[2]],	669	@target = map ["$_->[3].", $_->[2]],
…		…
516		691
517	In either case, it will create a list of target hosts (e.g. for multihomed	692	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	693	hosts or hosts with both IPv4 and IPv6 addresses) and try to connect to
519	each in turn.	694	each in turn.
520		695
521	If the connect is successful, then the C<$connect_cb> will be invoked with	696	After the connection is established (but never before the C<tcp_connect>
		697	fucntion itself returns), then the C<$connect_cb> will be invoked with
522	the socket file handle (in non-blocking mode) as first and the peer host	698	the socket file handle (in non-blocking mode) as first and the peer host
523	(as a textual IP address) and peer port as second and third arguments,	699	(as a textual IP address) and peer port as second and third arguments,
524	respectively. The fourth argument is a code reference that you can call	700	respectively. The fourth argument is a code reference that you can call
525	if, for some reason, you don't like this connection, which will cause	701	if, for some reason, you don't like this connection, which will cause
526	C<tcp_connect> to try the next one (or call your callback without any	702	C<tcp_connect> to try the next one (or call your callback without any
…		…
560	lessen the impact of this windows bug, a default timeout of 30 seconds	736	lessen the impact of this windows bug, a default timeout of 30 seconds
561	will be imposed on windows. Cygwin is not affected.	737	will be imposed on windows. Cygwin is not affected.
562		738
563	Simple Example: connect to localhost on port 22.	739	Simple Example: connect to localhost on port 22.
564		740
565	tcp_connect localhost => 22, sub {	741	tcp_connect localhost => 22, sub {
566	my $fh = shift	742	my $fh = shift
567	or die "unable to connect: $!";	743	or die "unable to connect: $!";
568	# do something	744	# do something
569	};	745	};
570		746
571	Complex Example: connect to www.google.com on port 80 and make a simple	747	Complex Example: connect to www.google.com on port 80 and make a simple
572	GET request without much error handling. Also limit the connection timeout	748	GET request without much error handling. Also limit the connection timeout
573	to 15 seconds.	749	to 15 seconds.
574		750
…		…
578	or die "unable to connect: $!";	754	or die "unable to connect: $!";
579		755
580	my $handle; # avoid direct assignment so on_eof has it in scope.	756	my $handle; # avoid direct assignment so on_eof has it in scope.
581	$handle = new AnyEvent::Handle	757	$handle = new AnyEvent::Handle
582	fh => $fh,	758	fh => $fh,
		759	on_error => sub {
		760	warn "error $_[2]\n";
		761	$_[0]->destroy;
		762	},
583	on_eof => sub {	763	on_eof => sub {
584	undef $handle; # keep it alive till eof	764	$handle->destroy; # destroy handle
585	warn "done.\n";	765	warn "done.\n";
586	};	766	};
587		767
588	$handle->push_write ("GET / HTTP/1.0\015\012\015\012");	768	$handle->push_write ("GET / HTTP/1.0\015\012\015\012");
589		769
…		…
612	...	792	...
613	}	793	}
614		794
615	=cut	795	=cut
616		796
		797	# used in cases where we may return immediately but want the
		798	# caller to do stuff first
		799	sub _delayed_call {
		800	my ($cb, @args) = @_;
		801
		802	my $w; $w = AE::timer 0, 0, sub {
		803	undef $w;
		804	$cb->(@args);
		805	};
		806	}
		807
617	sub tcp_connect($$$;$) {	808	sub tcp_connect($$$;$) {
618	my ($host, $port, $connect, $prepare) = @_;	809	my ($host, $port, $connect, $prepare) = @_;
619		810
620	# see http://cr.yp.to/docs/connect.html for some background	811	# see http://cr.yp.to/docs/connect.html for some background
621	# also http://advogato.org/article/672.html	812	# also http://advogato.org/article/672.html
622		813
623	my %state = ( fh => undef );	814	my %state = ( fh => undef );
624		815
625	# name/service to type/sockaddr resolution	816	# name/service to type/sockaddr resolution
626	resolve_sockaddr $host, $port, 0, 0, 0, sub {	817	resolve_sockaddr $host, $port, 0, 0, undef, sub {
627	my @target = @_;	818	my @target = @_;
628		819
629	$state{next} = sub {	820	$state{next} = sub {
630	return unless exists $state{fh};	821	return unless exists $state{fh};
631		822
632	my $target = shift @target	823	my $target = shift @target
633	or do {	824	or return (%state = (), _delayed_call $connect);
634	%state = ();
635	return $connect->();
636	};
637		825
638	my ($domain, $type, $proto, $sockaddr) = @$target;	826	my ($domain, $type, $proto, $sockaddr) = @$target;
639		827
640	# socket creation	828	# socket creation
641	socket $state{fh}, $domain, $type, $proto	829	socket $state{fh}, $domain, $type, $proto
…		…
645		833
646	my $timeout = $prepare && $prepare->($state{fh});	834	my $timeout = $prepare && $prepare->($state{fh});
647		835
648	$timeout \|\|= 30 if AnyEvent::WIN32;	836	$timeout \|\|= 30 if AnyEvent::WIN32;
649		837
650	$state{to} = AnyEvent->timer (after => $timeout, cb => sub {	838	$state{to} = AE::timer $timeout, 0, sub {
651	$! = &Errno::ETIMEDOUT;	839	$! = Errno::ETIMEDOUT;
652	$state{next}();	840	$state{next}();
653	}) if $timeout;	841	} if $timeout;
654		842
655	# called when the connect was successful, which,	843	# now connect
656	# in theory, could be the case immediately (but never is in practise)	844	if (
657	my $connected = sub {	845	(connect $state{fh}, $sockaddr)
658	delete $state{ww};	846	\|\| ($! == Errno::EINPROGRESS # POSIX
659	delete $state{to};	847	\|\| $! == Errno::EWOULDBLOCK
660		848	# WSAEINPROGRESS intentionally not checked - it means something else entirely
		849	\|\| $! == AnyEvent::Util::WSAEINVAL # not convinced, but doesn't hurt
		850	\|\| $! == AnyEvent::Util::WSAEWOULDBLOCK)
		851	) {
		852	$state{ww} = AE::io $state{fh}, 1, sub {
661	# we are connected, or maybe there was an error	853	# we are connected, or maybe there was an error
662	if (my $sin = getpeername $state{fh}) {	854	if (my $sin = getpeername $state{fh}) {
663	my ($port, $host) = unpack_sockaddr $sin;	855	my ($port, $host) = unpack_sockaddr $sin;
664		856
		857	delete $state{ww}; delete $state{to};
		858
665	my $guard = guard {	859	my $guard = guard { %state = () };
666	%state = ();
667	};
668		860
669	$connect->($state{fh}, format_address $host, $port, sub {	861	$connect->(delete $state{fh}, format_address $host, $port, sub {
670	$guard->cancel;	862	$guard->cancel;
		863	$state{next}();
		864	});
		865	} else {
		866	# dummy read to fetch real error code
		867	sysread $state{fh}, my $buf, 1 if $! == Errno::ENOTCONN;
		868
		869	return if $! == Errno::EAGAIN; # skip spurious wake-ups
		870
		871	delete $state{ww}; delete $state{to};
		872
671	$state{next}();	873	$state{next}();
672	});	874	}
673	} else {
674	# dummy read to fetch real error code
675	sysread $state{fh}, my $buf, 1 if $! == &Errno::ENOTCONN;
676	$state{next}();
677	}	875	};
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 {	876	} else {
690	$state{next}();	877	$state{next}();
691	}	878	}
692	};	879	};
693		880
694	$! = &Errno::ENXIO;	881	$! = Errno::ENXIO;
695	$state{next}();	882	$state{next}();
696	};	883	};
697		884
698	defined wantarray && guard { %state = () }	885	defined wantarray && guard { %state = () }
699	}	886	}
…		…
758	}, sub {	945	}, sub {
759	my ($fh, $thishost, $thisport) = @_;	946	my ($fh, $thishost, $thisport) = @_;
760	warn "bound to $thishost, port $thisport\n";	947	warn "bound to $thishost, port $thisport\n";
761	};	948	};
762		949
		950	Example: bind a server on a unix domain socket.
		951
		952	tcp_server "unix/", "/tmp/mydir/mysocket", sub {
		953	my ($fh) = @_;
		954	};
		955
763	=cut	956	=cut
764		957
765	sub tcp_server($$$;$) {	958	sub tcp_server($$$;$) {
766	my ($host, $service, $accept, $prepare) = @_;	959	my ($host, $service, $accept, $prepare) = @_;
767		960
…		…
811	$len \|\|= 128;	1004	$len \|\|= 128;
812		1005
813	listen $state{fh}, $len	1006	listen $state{fh}, $len
814	or Carp::croak "listen: $!";	1007	or Carp::croak "listen: $!";
815		1008
816	$state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub {	1009	$state{aw} = AE::io $state{fh}, 0, sub {
817	# this closure keeps $state alive	1010	# this closure keeps $state alive
818	while (my $peer = accept my $fh, $state{fh}) {	1011	while (my $peer = accept my $fh, $state{fh}) {
819	fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not	1012	fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not
820		1013
821	my ($service, $host) = unpack_sockaddr $peer;	1014	my ($service, $host) = unpack_sockaddr $peer;
822	$accept->($fh, format_address $host, $service);	1015	$accept->($fh, format_address $host, $service);
823	}	1016	}
824	});	1017	};
825		1018
826	defined wantarray	1019	defined wantarray
827	? guard { %state = () } # clear fh and watcher, which breaks the circular dependency	1020	? guard { %state = () } # clear fh and watcher, which breaks the circular dependency
828	: ()	1021	: ()
829	}	1022	}

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents): Revision 1.42 by root, Thu May 29 23:18:37 2008 UTC vs. Revision 1.107 by root, Thu Aug 6 13:31:01 2009 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.42 by root, Thu May 29 23:18:37 2008 UTC vs.
Revision 1.107 by root, Thu Aug 6 13:31:01 2009 UTC