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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.15 by root, Sat May 24 01:15:19 2008 UTC vs.
Revision 1.36 by root, Wed May 28 21:29:03 2008 UTC

…		…
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
		9	tcp_connect "gameserver.deliantra.net", 13327, sub {
		10	my ($fh) = @_
		11	or die "gameserver.deliantra.net connect failed: $!";
		12
		13	# enjoy your filehandle
		14	};
		15
		16	# a simple tcp server
		17	tcp_server undef, 8888, sub {
		18	my ($fh, $host, $port) = @_;
		19
		20	syswrite $fh, "The internet is full, $host:$port. Go away!\015\012";
		21	};
8		22
9	=head1 DESCRIPTION	23	=head1 DESCRIPTION
10		24
11	This module implements various utility functions for handling internet	25	This module implements various utility functions for handling internet
12	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
…		…
24	no warnings;	38	no warnings;
25	use strict;	39	use strict;
26		40
27	use Carp ();	41	use Carp ();
28	use Errno ();	42	use Errno ();
29	use Socket ();	43	use Socket qw(AF_INET AF_UNIX SOCK_STREAM SOCK_DGRAM SOL_SOCKET SO_REUSEADDR);
30		44
31	use AnyEvent ();	45	use AnyEvent ();
32	use AnyEvent::Util qw(guard fh_nonblocking);	46	use AnyEvent::Util qw(guard fh_nonblocking AF_INET6);
		47	use AnyEvent::DNS ();
33		48
34	use base 'Exporter';	49	use base 'Exporter';
35		50
36	BEGIN {	51	our @EXPORT = qw(
37	*socket_inet_aton = \&Socket::inet_aton; # take a copy, in case Coro::LWP overrides it	52	parse_ipv4 parse_ipv6
38	}	53	parse_ip parse_address
39		54	format_ip format_address
40	BEGIN {	55	address_family
41	my $af_inet6 = eval { &Socket::AF_INET6 };	56	inet_aton
42	eval "sub AF_INET6() { $af_inet6 }"; die if $@;	57	tcp_server
43		58	tcp_connect
44	delete $AnyEvent::PROTOCOL{ipv6} unless $af_inet6;	59	);
45	}
46
47	our @EXPORT = qw(parse_ipv4 parse_ipv6 parse_ip format_ip inet_aton tcp_server tcp_connect);
48		60
49	our $VERSION = '1.0';	61	our $VERSION = '1.0';
50		62
51	=item $ipn = parse_ipv4 $dotted_quad	63	=item $ipn = parse_ipv4 $dotted_quad
52		64
…		…
80		92
81	Tries to parse the given IPv6 address and return it in	93	Tries to parse the given IPv6 address and return it in
82	octet form (or undef when it isn't in a parsable format).	94	octet form (or undef when it isn't in a parsable format).
83		95
84	Should support all forms specified by RFC 2373 (and additionally all IPv4	96	Should support all forms specified by RFC 2373 (and additionally all IPv4
85	forms supported by parse_ipv4).	97	forms supported by parse_ipv4). Note that scope-id's are not supported
		98	(and will not parse).
86		99
87	This function works similarly to C<inet_pton AF_INET6, ...>.	100	This function works similarly to C<inet_pton AF_INET6, ...>.
88		101
89	=cut	102	=cut
90		103
…		…
123		136
124	# and done	137	# and done
125	pack "n*", map hex, @h, @t	138	pack "n*", map hex, @h, @t
126	}	139	}
127		140
		141	sub parse_unix($) {
		142	$_[0] eq "unix/"
		143	? pack "S", AF_UNIX
		144	: undef
		145
		146	}
		147
128	=item $ipn = parse_ip $text	148	=item $ipn = parse_address $text
129		149
130	Combines C<parse_ipv4> and C<parse_ipv6> in one function.	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
		152	(binary).
131		153
132	=cut	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
		156	socket".
133		157
		158	=cut
		159
134	sub parse_ip($) {	160	sub parse_address($) {
135	&parse_ipv4 \|\| &parse_ipv6	161	&parse_ipv4 \|\| &parse_ipv6 \|\| &parse_unix
136	}	162	}
137		163
		164	*parse_ip =\&parse_address; #d#
		165
		166	=item $sa_family = address_family $ipn
		167
		168	Returns the address family/protocol-family (AF_xxx/PF_xxx, in one value :)
		169	of the given host address in network format.
		170
		171	=cut
		172
		173	sub address_family($) {
		174	4 == length $_[0]
		175	? AF_INET
		176	: 16 == length $_[0]
		177	? AF_INET6
		178	: unpack "S", $_[0]
		179	}
		180
138	=item $text = format_ip $ipn	181	=item $text = format_address $ipn
139		182
140	Takes either an IPv4 address (4 octets) or and IPv6 address (16 octets)	183	Covnvert a host address in network format (e.g. 4 octets for IPv4 or 16
141	and converts it into textual form.	184	octets for IPv6) and convert it into textual form.
		185
		186	Returns C<unix/> for UNIX domain sockets.
142		187
143	This function works similarly to C<inet_ntop AF_INET \|\| AF_INET6, ...>,	188	This function works similarly to C<inet_ntop AF_INET \|\| AF_INET6, ...>,
144	except it automatically detects the address type.	189	except it automatically detects the address type.
145		190
146	=cut	191	Returns C<undef> if it cannot detect the type.
147		192
148	sub format_ip;	193	=cut
		194
		195	sub format_address;
149	sub format_ip($) {	196	sub format_address($) {
150	if (4 == length $_[0]) {	197	my $af = address_family $_[0];
		198	if ($af == AF_INET) {
151	return join ".", unpack "C4", $_[0]	199	return join ".", unpack "C4", $_[0]
152	} elsif (16 == length $_[0]) {	200	} elsif ($af == AF_INET6) {
		201	if (v0.0.0.0.0.0.0.0.0.0.0.0 eq substr $_[0], 0, 12) {
		202	# v4compatible
		203	return "::" . format_address substr $_[0], 12;
153	if (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12) {	204	} elsif (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12) {
154	# v4mapped	205	# v4mapped
155	return "::ffff:" . format_ip substr $_[0], 12;	206	return "::ffff:" . format_address substr $_[0], 12;
		207	} elsif (v0.0.0.0.0.0.0.0.255.255.0.0 eq substr $_[0], 0, 12) {
		208	# v4translated
		209	return "::ffff:0:" . format_address substr $_[0], 12;
156	} else {	210	} else {
157	my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0];	211	my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0];
158		212
159	$ip =~ s/^0:(?:0:)*/::/	213	$ip =~ s/^0:(?:0:)*(0$)?/::/
160	or $ip =~ s/(:0)+$/::/	214	or $ip =~ s/(:0)+$/::/
161	or $ip =~ s/(:0)+/:/;	215	or $ip =~ s/(:0)+/:/;
162	return $ip	216	return $ip
163	}	217	}
		218	} elsif ($af == AF_UNIX) {
		219	return "unix/"
164	} else {	220	} else {
165	return undef	221	return undef
166	}	222	}
167	}	223	}
		224
		225	*format_ip = \&format_address;
168		226
169	=item inet_aton $name_or_address, $cb->(@addresses)	227	=item inet_aton $name_or_address, $cb->(@addresses)
170		228
171	Works similarly to its Socket counterpart, except that it uses a	229	Works similarly to its Socket counterpart, except that it uses a
172	callback. Also, if a host has only an IPv6 address, this might be passed	230	callback. Also, if a host has only an IPv6 address, this might be passed
173	to the callback instead (use the length to detect this - 4 for IPv4, 16	231	to the callback instead (use the length to detect this - 4 for IPv4, 16
174	for IPv6).	232	for IPv6).
175		233
176	Unlike the L<Socket> function of the same name, you can get multiple IPv4	234	Unlike the L<Socket> function of the same name, you can get multiple IPv4
177	and IPv6 addresses as result.	235	and IPv6 addresses as result (and maybe even other adrdess types).
178		236
179	=cut	237	=cut
180		238
181	sub inet_aton {	239	sub inet_aton {
182	my ($name, $cb) = @_;	240	my ($name, $cb) = @_;
…		…
200	}	258	}
201	});	259	});
202	}	260	}
203	}	261	}
204		262
		263	# check for broken platforms with extra field in sockaddr structure
		264	# kind of a rfc vs. bsd issue, as usual (ok, normally it's a
		265	# unix vs. bsd issue, a iso C vs. bsd issue or simply a
		266	# correctness vs. bsd issue.
		267	my $pack_family = 0x55 == Socket::sockaddr_family "\x55\x55"
		268	? "xC" : "S";
		269
205	=item $sa = AnyEvent::Socket::pack_sockaddr $port, $host	270	=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host
206		271
207	Pack the given port/hst combination into a binary sockaddr structure. Handles	272	Pack the given port/host combination into a binary sockaddr
208	both IPv4 and IPv6 host addresses.	273	structure. Handles both IPv4 and IPv6 host addresses, as well as UNIX
		274	domain sockets (C<$host> == C<unix/> and C<$service> == absolute
		275	pathname).
209		276
210	=cut	277	=cut
211		278
212	sub pack_sockaddr($$) {	279	sub pack_sockaddr($$) {
213	if (4 == length $_[1]) {	280	my $af = address_family $_[1];
		281
		282	if ($af == AF_INET) {
214	Socket::pack_sockaddr_in $_[0], $_[1]	283	Socket::pack_sockaddr_in $_[0], $_[1]
215	} elsif (16 == length $_[1]) {	284	} elsif ($af == AF_INET6) {
216	pack "SSL a16 L",	285	pack "$pack_family nL a16 L",
217	Socket::AF_INET6,	286	AF_INET6,
218	$_[0], # port	287	$_[0], # port
219	0, # flowinfo	288	0, # flowinfo
220	$_[1], # addr	289	$_[1], # addr
221	0 # scope id	290	0 # scope id
		291	} elsif ($af == AF_UNIX) {
		292	Socket::pack_sockaddr_un $_[0]
222	} else {	293	} else {
223	Carp::croak "pack_sockaddr: invalid host";	294	Carp::croak "pack_sockaddr: invalid host";
224	}	295	}
225	}	296	}
226		297
227	=item ($port, $host) = AnyEvent::Socket::unpack_sockaddr $sa	298	=item ($service, $host) = AnyEvent::Socket::unpack_sockaddr $sa
228		299
229	Unpack the given binary sockaddr structure (as used by bind, getpeername	300	Unpack the given binary sockaddr structure (as used by bind, getpeername
230	etc.) into a C<$port, $host> combination.	301	etc.) into a C<$service, $host> combination.
231		302
232	Handles both IPv4 and IPv6 sockaddr structures.	303	For IPv4 and IPv6, C<$service> is the port number and C<$host> the host
		304	address in network format (binary).
		305
		306	For UNIX domain sockets, C<$service> is the absolute pathname and C<$host>
		307	is a special token that is understood by the other functions in this
		308	module (C<format_address> converts it to C<unix/>).
233		309
234	=cut	310	=cut
235		311
236	sub unpack_sockaddr($) {	312	sub unpack_sockaddr($) {
237	my $af = unpack "S", $_[0];	313	my $af = Socket::sockaddr_family $_[0];
238		314
239	if ($af == &Socket::AF_INET) {	315	if ($af == AF_INET) {
240	Socket::unpack_sockaddr_in $_[0]	316	Socket::unpack_sockaddr_in $_[0]
241	} elsif ($af == AF_INET6) {	317	} elsif ($af == AF_INET6) {
242	(unpack "SSL a16 L")[1, 3]	318	unpack "x2 n x4 a16", $_[0]
		319	} elsif ($af == AF_UNIX) {
		320	((Socket::unpack_sockaddr_un $_[0]), pack "S", AF_UNIX)
243	} else {	321	} else {
244	Carp::croak "unpack_sockaddr: unsupported protocol family $af";	322	Carp::croak "unpack_sockaddr: unsupported protocol family $af";
245	}	323	}
246	}	324	}
247		325
248	sub _tcp_port($) {	326	=item resolve_sockaddr $node, $service, $proto, $family, $type, $cb->([$family, $type, $proto, $sockaddr], ...)
249	$_[0] =~ /^(\d)$/ and return $11;
250		327
251	(getservbyname $_[0], "tcp")[2]	328	Tries to resolve the given nodename and service name into protocol families
		329	and sockaddr structures usable to connect to this node and service in a
		330	protocol-independent way. It works remotely similar to the getaddrinfo
		331	posix function.
		332
		333	For internet addresses, C<$node> is either an IPv4 or IPv6 address or an
		334	internet hostname, and C<$service> is either a service name (port name
		335	from F</etc/services>) or a numerical port number. If both C<$node> and
		336	C<$service> are names, then SRV records will be consulted to find the real
		337	service, otherwise they will be used as-is. If you know that the service
		338	name is not in your services database, then you can specify the service in
		339	the format C<name=port> (e.g. C<http=80>).
		340
		341	For UNIX domain sockets, C<$node> must be the string C<unix/> and
		342	C<$service> must be the absolute pathname of the socket. In this case,
		343	C<$proto> will be ignored.
		344
		345	C<$proto> must be a protocol name, currently C<tcp>, C<udp> or
		346	C<sctp>. The default is currently C<tcp>, but in the future, this function
		347	might try to use other protocols such as C<sctp>, depending on the socket
		348	type and any SRV records it might find.
		349
		350	C<$family> must be either C<0> (meaning any protocol is OK), C<4> (use
		351	only IPv4) or C<6> (use only IPv6). This setting might be influenced by
		352	C<$ENV{PERL_ANYEVENT_PROTOCOLS}>.
		353
		354	C<$type> must be C<SOCK_STREAM>, C<SOCK_DGRAM> or C<SOCK_SEQPACKET> (or
		355	C<undef> in which case it gets automatically chosen).
		356
		357	The callback will receive zero or more array references that contain
		358	C<$family, $type, $proto> for use in C<socket> and a binary
		359	C<$sockaddr> for use in C<connect> (or C<bind>).
		360
		361	The application should try these in the order given.
		362
		363	Example:
		364
		365	resolve_sockaddr "google.com", "http", 0, undef, undef, sub { ... };
		366
		367	=cut
		368
		369	sub resolve_sockaddr($$$$$$) {
		370	my ($node, $service, $proto, $family, $type, $cb) = @_;
		371
		372	if ($node eq "unix/") {
		373	return $cb->() if $family \|\| !/^\//; # no can do
		374
		375	return $cb->([AF_UNIX, $type, 0, Socket::pack_sockaddr_un $service]);
		376	}
		377
		378	unless (AF_INET6) {
		379	$family != 6
		380	or return $cb->();
		381
		382	$family = 4;
		383	}
		384
		385	$cb->() if $family == 4 && !$AnyEvent::PROTOCOL{ipv4};
		386	$cb->() if $family == 6 && !$AnyEvent::PROTOCOL{ipv6};
		387
		388	$family \|\|= 4 unless $AnyEvent::PROTOCOL{ipv6};
		389	$family \|\|= 6 unless $AnyEvent::PROTOCOL{ipv4};
		390
		391	$proto \|\|= "tcp";
		392	$type \|\|= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM;
		393
		394	my $proton = (getprotobyname $proto)[2]
252	or Carp::croak "$_[0]: service unknown"	395	or Carp::croak "$proto: protocol unknown";
		396
		397	my $port;
		398
		399	if ($service =~ /^(\S+)=(\d+)$/) {
		400	($service, $port) = ($1, $2);
		401	} elsif ($service =~ /^\d+$/) {
		402	($service, $port) = (undef, $service);
		403	} else {
		404	$port = (getservbyname $service, $proto)[2]
		405	or Carp::croak "$service/$proto: service unknown";
		406	}
		407
		408	my @target = [$node, $port];
		409
		410	# resolve a records / provide sockaddr structures
		411	my $resolve = sub {
		412	my @res;
		413	my $cv = AnyEvent->condvar (cb => sub {
		414	$cb->(
		415	map $_->[2],
		416	sort {
		417	$AnyEvent::PROTOCOL{$b->[1]} <=> $AnyEvent::PROTOCOL{$a->[1]}
		418	or $a->[0] <=> $b->[0]
		419	}
		420	@res
		421	)
		422	});
		423
		424	$cv->begin;
		425	for my $idx (0 .. $#target) {
		426	my ($node, $port) = @{ $target[$idx] };
		427
		428	if (my $noden = parse_address $node) {
		429	if (4 == length $noden && $family != 6) {
		430	push @res, [$idx, "ipv4", [AF_INET, $type, $proton,
		431	pack_sockaddr $port, $noden]]
		432	}
		433
		434	if (16 == length $noden && $family != 4) {
		435	push @res, [$idx, "ipv6", [AF_INET6, $type, $proton,
		436	pack_sockaddr $port, $noden]]
		437	}
		438	} else {
		439	# ipv4
		440	if ($family != 6) {
		441	$cv->begin;
		442	a $node, sub {
		443	push @res, [$idx, "ipv4", [AF_INET, $type, $proton,
		444	pack_sockaddr $port, parse_ipv4 $_]]
		445	for @_;
		446	$cv->end;
		447	};
		448	}
		449
		450	# ipv6
		451	if ($family != 4) {
		452	$cv->begin;
		453	aaaa $node, sub {
		454	push @res, [$idx, "ipv6", [AF_INET6, $type, $proton,
		455	pack_sockaddr $port, parse_ipv6 $_]]
		456	for @_;
		457	$cv->end;
		458	};
		459	}
		460	}
		461	}
		462	$cv->end;
		463	};
		464
		465	# try srv records, if applicable
		466	if ($node eq "localhost") {
		467	@target = (["127.0.0.1", $port], ["::1", $port]);
		468	&$resolve;
		469	} elsif (defined $service && !parse_address $node) {
		470	srv $service, $proto, $node, sub {
		471	my (@srv) = @_;
		472
		473	# no srv records, continue traditionally
		474	@srv
		475	or return &$resolve;
		476
		477	# only srv record has "." => abort
		478	$srv[0][2] ne "." \|\| $#srv
		479	or return $cb->();
		480
		481	# use srv records then
		482	@target = map ["$_->[3].", $_->[2]],
		483	grep $_->[3] ne ".",
		484	@srv;
		485
		486	&$resolve;
		487	};
		488	} else {
		489	&$resolve;
		490	}
253	}	491	}
254		492
255	=item $guard = tcp_connect $host, $service, $connect_cb[, $prepare_cb]	493	=item $guard = tcp_connect $host, $service, $connect_cb[, $prepare_cb]
256		494
257	This is a convenience function that creates a TCP socket and makes a 100%	495	This is a convenience function that creates a TCP socket and makes a 100%
258	non-blocking connect to the given C<$host> (which can be a hostname or a	496	non-blocking connect to the given C<$host> (which can be a hostname or
		497	a textual IP address, or the string C<unix/> for UNIX domain sockets)
259	textual IP address) and C<$service> (which can be a numeric port number or	498	and C<$service> (which can be a numeric port number or a service name,
260	a service name, or a C<servicename=portnumber> string).	499	or a C<servicename=portnumber> string, or the pathname to a UNIX domain
		500	socket).
261		501
262	If both C<$host> and C<$port> are names, then this function will use SRV	502	If both C<$host> and C<$port> are names, then this function will use SRV
263	records to locate the real target(s).	503	records to locate the real target(s).
264		504
265	In either case, it will create a list of target hosts (e.g. for multihomed	505	In either case, it will create a list of target hosts (e.g. for multihomed
266	hosts or hosts with both IPv4 and IPV6 addrsesses) and try to connetc to	506	hosts or hosts with both IPv4 and IPv6 addresses) and try to connect to
267	each in turn.	507	each in turn.
268		508
269	If the connect is successful, then the C<$connect_cb> will be invoked with	509	If the connect is successful, then the C<$connect_cb> will be invoked with
270	the socket filehandle (in non-blocking mode) as first and the peer host	510	the socket file handle (in non-blocking mode) as first and the peer host
271	(as a textual IP address) and peer port as second and third arguments,	511	(as a textual IP address) and peer port as second and third arguments,
272	respectively. The fourth argument is a code reference that you can call	512	respectively. The fourth argument is a code reference that you can call
273	if, for some reason, you don't like this connection, which will cause	513	if, for some reason, you don't like this connection, which will cause
274	C<tcp_connect> to try the next one (or call your callback without any	514	C<tcp_connect> to try the next one (or call your callback without any
275	arguments if there are no more connections). In most cases, you can simply	515	arguments if there are no more connections). In most cases, you can simply
…		…
277		517
278	$cb->($filehandle, $host, $port, $retry)	518	$cb->($filehandle, $host, $port, $retry)
279		519
280	If the connect is unsuccessful, then the C<$connect_cb> will be invoked	520	If the connect is unsuccessful, then the C<$connect_cb> will be invoked
281	without any arguments and C<$!> will be set appropriately (with C<ENXIO>	521	without any arguments and C<$!> will be set appropriately (with C<ENXIO>
282	indicating a dns resolution failure).	522	indicating a DNS resolution failure).
283		523
284	The filehandle is suitable to be plugged into L<AnyEvent::Handle>, but can	524	The file handle is perfect for being plugged into L<AnyEvent::Handle>, but
285	be used as a normal perl file handle as well.	525	can be used as a normal perl file handle as well.
286		526
287	Unless called in void context, C<tcp_connect> returns a guard object that	527	Unless called in void context, C<tcp_connect> returns a guard object that
288	will automatically abort connecting when it gets destroyed (it does not do	528	will automatically abort connecting when it gets destroyed (it does not do
289	anything to the socket after the connect was successful).	529	anything to the socket after the connect was successful).
290		530
…		…
294	a second callback, C<$prepare_cb>. It will be called with the file handle	534	a second callback, C<$prepare_cb>. It will be called with the file handle
295	in not-yet-connected state as only argument and must return the connection	535	in not-yet-connected state as only argument and must return the connection
296	timeout value (or C<0>, C<undef> or the empty list to indicate the default	536	timeout value (or C<0>, C<undef> or the empty list to indicate the default
297	timeout is to be used).	537	timeout is to be used).
298		538
299	Note that the socket could be either a IPv4 TCP socket or an IPv6 tcp	539	Note that the socket could be either a IPv4 TCP socket or an IPv6 TCP
300	socket (although only IPv4 is currently supported by this module).	540	socket (although only IPv4 is currently supported by this module).
		541
		542	Note to the poor Microsoft Windows users: Windows (of course) doesn't
		543	correctly signal connection errors, so unless your event library works
		544	around this, failed connections will simply hang. The only event libraries
		545	that handle this condition correctly are L<EV> and L<Glib>. Additionally,
		546	AnyEvent works around this bug with L<Event> and in its pure-perl
		547	backend. All other libraries cannot correctly handle this condition. To
		548	lessen the impact of this windows bug, a default timeout of 30 seconds
		549	will be imposed on windows. Cygwin is not affected.
301		550
302	Simple Example: connect to localhost on port 22.	551	Simple Example: connect to localhost on port 22.
303		552
304	tcp_connect localhost => 22, sub {	553	tcp_connect localhost => 22, sub {
305	my $fh = shift	554	my $fh = shift
…		…
343	# could call $fh->bind etc. here	592	# could call $fh->bind etc. here
344		593
345	15	594	15
346	};	595	};
347		596
		597	Example: connect to a UNIX domain socket.
		598
		599	tcp_connect "unix/", "/tmp/.X11-unix/X0", sub {
		600	...
		601	}
		602
348	=cut	603	=cut
349		604
350	sub tcp_connect($$$;$) {	605	sub tcp_connect($$$;$) {
351	my ($host, $port, $connect, $prepare) = @_;	606	my ($host, $port, $connect, $prepare) = @_;
352		607
353	# see http://cr.yp.to/docs/connect.html for some background	608	# see http://cr.yp.to/docs/connect.html for some background
		609	# also http://advogato.org/article/672.html
354		610
355	my %state = ( fh => undef );	611	my %state = ( fh => undef );
356		612
357	# name resolution	613	# name/service to type/sockaddr resolution
358	AnyEvent::DNS::addr $host, $port, 0, 0, 0, sub {	614	resolve_sockaddr $host, $port, 0, 0, 0, sub {
359	my @target = @_;	615	my @target = @_;
360		616
361	$state{next} = sub {	617	$state{next} = sub {
362	return unless exists $state{fh};	618	return unless exists $state{fh};
363		619
…		…
373	socket $state{fh}, $domain, $type, $proto	629	socket $state{fh}, $domain, $type, $proto
374	or return $state{next}();	630	or return $state{next}();
375		631
376	fh_nonblocking $state{fh}, 1;	632	fh_nonblocking $state{fh}, 1;
377		633
378	# prepare and optional timeout
379	if ($prepare) {
380	my $timeout = $prepare->($state{fh});	634	my $timeout = $prepare && $prepare->($state{fh});
381		635
		636	$timeout \|\|= 30 if AnyEvent::WIN32;
		637
382	$state{to} = AnyEvent->timer (after => $timeout, cb => sub {	638	$state{to} = AnyEvent->timer (after => $timeout, cb => sub {
383	$! = &Errno::ETIMEDOUT;	639	$! = &Errno::ETIMEDOUT;
384	$state{next}();	640	$state{next}();
385	}) if $timeout;	641	}) if $timeout;
386	}
387		642
388	# called when the connect was successful, which,	643	# called when the connect was successful, which,
389	# in theory, could be the case immediately (but never is in practise)	644	# in theory, could be the case immediately (but never is in practise)
390	my $connected = sub {	645	my $connected = sub {
391	delete $state{ww};	646	delete $state{ww};
…		…
397		652
398	my $guard = guard {	653	my $guard = guard {
399	%state = ();	654	%state = ();
400	};	655	};
401		656
402	$connect->($state{fh}, format_ip $host, $port, sub {	657	$connect->($state{fh}, format_address $host, $port, sub {
403	$guard->cancel;	658	$guard->cancel;
404	$state{next}();	659	$state{next}();
405	});	660	});
406	} else {	661	} else {
407	# dummy read to fetch real error code	662	# dummy read to fetch real error code
…		…
411	};	666	};
412		667
413	# now connect	668	# now connect
414	if (connect $state{fh}, $sockaddr) {	669	if (connect $state{fh}, $sockaddr) {
415	$connected->();	670	$connected->();
416	} elsif ($! == &Errno::EINPROGRESS \|\| $! == &Errno::EWOULDBLOCK) { # EINPROGRESS is POSIX	671	} elsif ($! == &Errno::EINPROGRESS # POSIX
		672	\|\| $! == &Errno::EWOULDBLOCK
		673	# WSAEINPROGRESS intentionally not checked - it means something else entirely
		674	\|\| $! == AnyEvent::Util::WSAEINVAL # not convinced, but doesn't hurt
		675	\|\| $! == AnyEvent::Util::WSAEWOULDBLOCK) {
417	$state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $connected);	676	$state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $connected);
418	} else {	677	} else {
419	%state = ();	678	$state{next}();
420	$connect->();
421	}	679	}
422	};	680	};
423		681
424	$! = &Errno::ENXIO;	682	$! = &Errno::ENXIO;
425	$state{next}();	683	$state{next}();
426	};	684	};
427		685
428	defined wantarray && guard { %state = () }	686	defined wantarray && guard { %state = () }
429	}	687	}
430		688
431	=item $guard = tcp_server $host, $port, $accept_cb[, $prepare_cb]	689	=item $guard = tcp_server $host, $service, $accept_cb[, $prepare_cb]
432		690
433	Create and bind a tcp socket to the given host (any IPv4 host if undef,	691	Create and bind a stream socket to the given host, and port, set the
434	otherwise it must be an IPv4 or IPv6 address) and port (service name or	692	SO_REUSEADDR flag (if applicable) and call C<listen>. Unlike the name
435	numeric port number, or an ephemeral port if given as zero or undef), set	693	implies, this function can also bind on UNIX domain sockets.
436	the SO_REUSEADDR flag and call C<listen>.
437		694
		695	For internet sockets, C<$host> must be an IPv4 or IPv6 address (or
		696	C<undef>, in which case it binds either to C<0> or to C<::>, depending on
		697	whether IPv4 or IPv6 is the preferred protocol).
		698
		699	To bind to the IPv4 wildcard address, use C<0>, to bind to the IPv6
		700	wildcard address, use C<::>.
		701
		702	The port is specified by C<$service>, which must be either a service name or
		703	a numeric port number (or C<0> or C<undef>, in which case an ephemeral
		704	port will be used).
		705
		706	For UNIX domain sockets, C<$host> must be C<unix/> and C<$service> must be
		707	the absolute pathname of the socket. This function will try to C<unlink>
		708	the socket before it tries to bind to it. See SECURITY CONSIDERATIONS,
		709	below.
		710
438	For each new connection that could be C<accept>ed, call the C<$accept_cb>	711	For each new connection that could be C<accept>ed, call the C<<
439	with the filehandle (in non-blocking mode) as first and the peer host and	712	$accept_cb->($fh, $host, $port) >> with the file handle (in non-blocking
440	port as second and third arguments (see C<tcp_connect> for details).	713	mode) as first and the peer host and port as second and third arguments
		714	(see C<tcp_connect> for details).
441		715
442	Croaks on any errors.	716	Croaks on any errors it can detect before the listen.
443		717
444	If called in non-void context, then this function returns a guard object	718	If called in non-void context, then this function returns a guard object
445	whose lifetime it tied to the tcp server: If the object gets destroyed,	719	whose lifetime it tied to the TCP server: If the object gets destroyed,
446	the server will be stopped (but existing accepted connections will	720	the server will be stopped (but existing accepted connections will
447	continue).	721	continue).
448		722
449	If you need more control over the listening socket, you can provide a	723	If you need more control over the listening socket, you can provide a
450	C<$prepare_cb>, which is called just before the C<listen ()> call, with	724	C<< $prepare_cb->($fh, $host, $port) >>, which is called just before the
451	the listen file handle as first argument.	725	C<listen ()> call, with the listen file handle as first argument, and IP
		726	address and port number of the local socket endpoint as second and third
		727	arguments.
452		728
453	It should return the length of the listen queue (or C<0> for the default).	729	It should return the length of the listen queue (or C<0> for the default).
454		730
455	Example: bind on tcp port 8888 on the local machine and tell each client	731	Example: bind on some TCP port on the local machine and tell each client
456	to go away.	732	to go away.
457		733
458	tcp_server undef, 8888, sub {	734	tcp_server undef, undef, sub {
459	my ($fh, $host, $port) = @_;	735	my ($fh, $host, $port) = @_;
460		736
461	syswrite $fh, "The internet is full, $host:$port. Go away!\015\012";	737	syswrite $fh, "The internet is full, $host:$port. Go away!\015\012";
		738	}, sub {
		739	my ($fh, $thishost, $thisport) = @_;
		740	warn "bound to $thishost, port $thisport\n";
462	};	741	};
463		742
464	=cut	743	=cut
465		744
466	sub tcp_server($$$;$) {	745	sub tcp_server($$$;$) {
467	my ($host, $port, $accept, $prepare) = @_;	746	my ($host, $service, $accept, $prepare) = @_;
		747
		748	$host = $AnyEvent::PROTOCOL{ipv4} < $AnyEvent::PROTOCOL{ipv6} && AF_INET6
		749	? "::" : "0"
		750	unless defined $host;
		751
		752	my $ipn = parse_address $host
		753	or Carp::croak "AnyEvent::Socket::tcp_server: cannot parse '$host' as host address";
		754
		755	my $af = address_family $ipn;
468		756
469	my %state;	757	my %state;
470		758
471	socket $state{fh}, &Socket::AF_INET, &Socket::SOCK_STREAM, 0	759	# win32 perl is too stupid to get this right :/
		760	Carp::croak "tcp_server/socket: address family not supported"
		761	if AnyEvent::WIN32 && $af == AF_UNIX;
		762
		763	socket $state{fh}, $af, SOCK_STREAM, 0
472	or Carp::croak "socket: $!";	764	or Carp::croak "tcp_server/socket: $!";
473		765
		766	if ($af == AF_INET \|\| $af == AF_INET6) {
474	setsockopt $state{fh}, &Socket::SOL_SOCKET, &Socket::SO_REUSEADDR, 1	767	setsockopt $state{fh}, SOL_SOCKET, SO_REUSEADDR, 1
475	or Carp::croak "so_reuseaddr: $!";	768	or Carp::croak "tcp_server/so_reuseaddr: $!"
		769	unless !AnyEvent::WIN32; # work around windows bug
476		770
477	bind $state{fh}, Socket::pack_sockaddr_in _tcp_port $port, socket_inet_aton ($host \|\| "0.0.0.0")	771	unless ($service =~ /^\d*$/) {
		772	$service = (getservbyname $service, "tcp")[2]
		773	or Carp::croak "$service: service unknown"
		774	}
		775	} elsif ($af == AF_UNIX) {
		776	unlink $service;
		777	}
		778
		779	bind $state{fh}, pack_sockaddr $service, $ipn
478	or Carp::croak "bind: $!";	780	or Carp::croak "bind: $!";
479		781
480	fh_nonblocking $state{fh}, 1;	782	fh_nonblocking $state{fh}, 1;
481		783
482	my $len = ($prepare && $prepare->($state{fh})) \|\| 128;	784	my $len;
		785
		786	if ($prepare) {
		787	my ($service, $host) = unpack_sockaddr getsockname $state{fh};
		788	$len = $prepare && $prepare->($state{fh}, format_address $host, $service);
		789	}
		790
		791	$len \|\|= 128;
483		792
484	listen $state{fh}, $len	793	listen $state{fh}, $len
485	or Carp::croak "listen: $!";	794	or Carp::croak "listen: $!";
486		795
487	$state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub {	796	$state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub {
488	# this closure keeps $state alive	797	# this closure keeps $state alive
489	while (my $peer = accept my $fh, $state{fh}) {	798	while (my $peer = accept my $fh, $state{fh}) {
490	fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not	799	fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not
491	my ($port, $host) = Socket::unpack_sockaddr_in $peer;	800	my ($service, $host) = unpack_sockaddr $peer;
492	$accept->($fh, (Socket::inet_ntoa $host), $port);	801	$accept->($fh, format_address $host, $service);
493	}	802	}
494	});	803	});
495		804
496	defined wantarray	805	defined wantarray
497	? guard { %state = () } # clear fh and watcher, which breaks the circular dependency	806	? guard { %state = () } # clear fh and watcher, which breaks the circular dependency

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents): Revision 1.15 by root, Sat May 24 01:15:19 2008 UTC vs. Revision 1.36 by root, Wed May 28 21:29:03 2008 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.15 by root, Sat May 24 01:15:19 2008 UTC vs.
Revision 1.36 by root, Wed May 28 21:29:03 2008 UTC