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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.18 by root, Sat May 24 18:50:40 2008 UTC vs.
Revision 1.39 by root, Thu May 29 00:27:06 2008 UTC

…		…
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
		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	};
		22
16	=head1 DESCRIPTION	23	=head1 DESCRIPTION
17		24
18	This module implements various utility functions for handling internet	25	This module implements various utility functions for handling internet
19	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
20	possible.	27	possible.
…		…
31	no warnings;	38	no warnings;
32	use strict;	39	use strict;
33		40
34	use Carp ();	41	use Carp ();
35	use Errno ();	42	use Errno ();
36	use Socket ();	43	use Socket qw(AF_INET AF_UNIX SOCK_STREAM SOCK_DGRAM SOL_SOCKET SO_REUSEADDR);
37		44
38	use AnyEvent ();	45	use AnyEvent ();
39	use AnyEvent::Util qw(guard fh_nonblocking);	46	use AnyEvent::Util qw(guard fh_nonblocking AF_INET6);
40	use AnyEvent::DNS ();	47	use AnyEvent::DNS ();
41		48
42	use base 'Exporter';	49	use base 'Exporter';
43		50
44	BEGIN {	51	our @EXPORT = qw(
45	*socket_inet_aton = \&Socket::inet_aton; # take a copy, in case Coro::LWP overrides it	52	parse_ipv4 parse_ipv6
46	}	53	parse_ip parse_address
47		54	format_ip format_address
48	BEGIN {	55	address_family
49	my $af_inet6 = eval { &Socket::AF_INET6 };	56	inet_aton
50	eval "sub AF_INET6() { $af_inet6 }"; die if $@;	57	tcp_server
51		58	tcp_connect
52	delete $AnyEvent::PROTOCOL{ipv6} unless $af_inet6;	59	);
53	}
54
55	our @EXPORT = qw(parse_ipv4 parse_ipv6 parse_ip format_ip inet_aton tcp_server tcp_connect);
56		60
57	our $VERSION = '1.0';	61	our $VERSION = '1.0';
58		62
59	=item $ipn = parse_ipv4 $dotted_quad	63	=item $ipn = parse_ipv4 $dotted_quad
60		64
…		…
88		92
89	Tries to parse the given IPv6 address and return it in	93	Tries to parse the given IPv6 address and return it in
90	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).
91		95
92	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
93	forms supported by parse_ipv4).	97	forms supported by parse_ipv4). Note that scope-id's are not supported
		98	(and will not parse).
94		99
95	This function works similarly to C<inet_pton AF_INET6, ...>.	100	This function works similarly to C<inet_pton AF_INET6, ...>.
96		101
97	=cut	102	=cut
98		103
…		…
131		136
132	# and done	137	# and done
133	pack "n*", map hex, @h, @t	138	pack "n*", map hex, @h, @t
134	}	139	}
135		140
		141	sub parse_unix($) {
		142	$_[0] eq "unix/"
		143	? pack "S", AF_UNIX
		144	: undef
		145
		146	}
		147
136	=item $ipn = parse_ip $text	148	=item $ipn = parse_address $text
137		149
138	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).
139		153
140	=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".
141		157
		158	=cut
		159
142	sub parse_ip($) {	160	sub parse_address($) {
143	&parse_ipv4 \|\| &parse_ipv6	161	&parse_ipv4 \|\| &parse_ipv6 \|\| &parse_unix
144	}	162	}
145		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
146	=item $text = format_ip $ipn	181	=item $text = format_address $ipn
147		182
148	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
149	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.
150		187
151	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, ...>,
152	except it automatically detects the address type.	189	except it automatically detects the address type.
153		190
154	=cut	191	Returns C<undef> if it cannot detect the type.
155		192
156	sub format_ip;	193	=cut
		194
		195	sub format_address;
157	sub format_ip($) {	196	sub format_address($) {
158	if (4 == length $_[0]) {	197	my $af = address_family $_[0];
		198	if ($af == AF_INET) {
159	return join ".", unpack "C4", $_[0]	199	return join ".", unpack "C4", $_[0]
160	} 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;
161	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) {
162	# v4mapped	205	# v4mapped
163	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;
164	} else {	210	} else {
165	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];
166		212
167	$ip =~ s/^0:(?:0:)*/::/	213	$ip =~ s/^0:(?:0:)*(0$)?/::/
168	or $ip =~ s/(:0)+$/::/	214	or $ip =~ s/(:0)+$/::/
169	or $ip =~ s/(:0)+/:/;	215	or $ip =~ s/(:0)+/:/;
170	return $ip	216	return $ip
171	}	217	}
		218	} elsif ($af == AF_UNIX) {
		219	return "unix/"
172	} else {	220	} else {
173	return undef	221	return undef
174	}	222	}
175	}	223	}
		224
		225	*format_ip = \&format_address;
176		226
177	=item inet_aton $name_or_address, $cb->(@addresses)	227	=item inet_aton $name_or_address, $cb->(@addresses)
178		228
179	Works similarly to its Socket counterpart, except that it uses a	229	Works similarly to its Socket counterpart, except that it uses a
180	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
181	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
182	for IPv6).	232	for IPv6).
183		233
184	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
185	and IPv6 addresses as result.	235	and IPv6 addresses as result (and maybe even other adrdess types).
186		236
187	=cut	237	=cut
188		238
189	sub inet_aton {	239	sub inet_aton {
190	my ($name, $cb) = @_;	240	my ($name, $cb) = @_;
…		…
208	}	258	}
209	});	259	});
210	}	260	}
211	}	261	}
212		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
213	=item $sa = AnyEvent::Socket::pack_sockaddr $port, $host	270	=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host
214		271
215	Pack the given port/host combination into a binary sockaddr structure. Handles	272	Pack the given port/host combination into a binary sockaddr
216	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).
217		276
218	=cut	277	=cut
219		278
220	sub pack_sockaddr($$) {	279	sub pack_sockaddr($$) {
221	if (4 == length $_[1]) {	280	my $af = address_family $_[1];
		281
		282	if ($af == AF_INET) {
222	Socket::pack_sockaddr_in $_[0], $_[1]	283	Socket::pack_sockaddr_in $_[0], $_[1]
223	} elsif (16 == length $_[1]) {	284	} elsif ($af == AF_INET6) {
224	pack "SnL a16 L",	285	pack "$pack_family nL a16 L",
225	Socket::AF_INET6,	286	AF_INET6,
226	$_[0], # port	287	$_[0], # port
227	0, # flowinfo	288	0, # flowinfo
228	$_[1], # addr	289	$_[1], # addr
229	0 # scope id	290	0 # scope id
		291	} elsif ($af == AF_UNIX) {
		292	Socket::pack_sockaddr_un $_[0]
230	} else {	293	} else {
231	Carp::croak "pack_sockaddr: invalid host";	294	Carp::croak "pack_sockaddr: invalid host";
232	}	295	}
233	}	296	}
234		297
235	=item ($port, $host) = AnyEvent::Socket::unpack_sockaddr $sa	298	=item ($service, $host) = AnyEvent::Socket::unpack_sockaddr $sa
236		299
237	Unpack the given binary sockaddr structure (as used by bind, getpeername	300	Unpack the given binary sockaddr structure (as used by bind, getpeername
238	etc.) into a C<$port, $host> combination.	301	etc.) into a C<$service, $host> combination.
239		302
240	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/>).
241		309
242	=cut	310	=cut
243		311
244	sub unpack_sockaddr($) {	312	sub unpack_sockaddr($) {
245	my $af = unpack "S", $_[0];	313	my $af = Socket::sockaddr_family $_[0];
246		314
247	if ($af == &Socket::AF_INET) {	315	if ($af == AF_INET) {
248	Socket::unpack_sockaddr_in $_[0]	316	Socket::unpack_sockaddr_in $_[0]
249	} elsif ($af == AF_INET6) {	317	} elsif ($af == AF_INET6) {
250	(unpack "SnL 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)
251	} else {	321	} else {
252	Carp::croak "unpack_sockaddr: unsupported protocol family $af";	322	Carp::croak "unpack_sockaddr: unsupported protocol family $af";
253	}	323	}
254	}	324	}
255		325
256	sub _tcp_port($) {	326	=item resolve_sockaddr $node, $service, $proto, $family, $type, $cb->([$family, $type, $proto, $sockaddr], ...)
257	$_[0] =~ /^(\d)$/ and return $11;
258		327
259	(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]
260	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	AnyEvent::DNS::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	AnyEvent::DNS::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	AnyEvent::DNS::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	}
261	}	491	}
262		492
263	=item $guard = tcp_connect $host, $service, $connect_cb[, $prepare_cb]	493	=item $guard = tcp_connect $host, $service, $connect_cb[, $prepare_cb]
264		494
265	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%
266	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)
267	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,
268	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).
269		501
270	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
271	records to locate the real target(s).	503	records to locate the real target(s).
272		504
273	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
…		…
304	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
305	timeout is to be used).	537	timeout is to be used).
306		538
307	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
308	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.
309		550
310	Simple Example: connect to localhost on port 22.	551	Simple Example: connect to localhost on port 22.
311		552
312	tcp_connect localhost => 22, sub {	553	tcp_connect localhost => 22, sub {
313	my $fh = shift	554	my $fh = shift
…		…
351	# could call $fh->bind etc. here	592	# could call $fh->bind etc. here
352		593
353	15	594	15
354	};	595	};
355		596
		597	Example: connect to a UNIX domain socket.
		598
		599	tcp_connect "unix/", "/tmp/.X11-unix/X0", sub {
		600	...
		601	}
		602
356	=cut	603	=cut
357		604
358	sub tcp_connect($$$;$) {	605	sub tcp_connect($$$;$) {
359	my ($host, $port, $connect, $prepare) = @_;	606	my ($host, $port, $connect, $prepare) = @_;
360		607
361	# 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
362		610
363	my %state = ( fh => undef );	611	my %state = ( fh => undef );
364		612
365	# name resolution	613	# name/service to type/sockaddr resolution
366	AnyEvent::DNS::addr $host, $port, 0, 0, 0, sub {	614	resolve_sockaddr $host, $port, 0, 0, 0, sub {
367	my @target = @_;	615	my @target = @_;
368		616
369	$state{next} = sub {	617	$state{next} = sub {
370	return unless exists $state{fh};	618	return unless exists $state{fh};
371		619
…		…
381	socket $state{fh}, $domain, $type, $proto	629	socket $state{fh}, $domain, $type, $proto
382	or return $state{next}();	630	or return $state{next}();
383		631
384	fh_nonblocking $state{fh}, 1;	632	fh_nonblocking $state{fh}, 1;
385		633
386	# prepare and optional timeout
387	if ($prepare) {
388	my $timeout = $prepare->($state{fh});	634	my $timeout = $prepare && $prepare->($state{fh});
389		635
		636	$timeout \|\|= 30 if AnyEvent::WIN32;
		637
390	$state{to} = AnyEvent->timer (after => $timeout, cb => sub {	638	$state{to} = AnyEvent->timer (after => $timeout, cb => sub {
391	$! = &Errno::ETIMEDOUT;	639	$! = &Errno::ETIMEDOUT;
392	$state{next}();	640	$state{next}();
393	}) if $timeout;	641	}) if $timeout;
394	}
395		642
396	# called when the connect was successful, which,	643	# called when the connect was successful, which,
397	# 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)
398	my $connected = sub {	645	my $connected = sub {
399	delete $state{ww};	646	delete $state{ww};
…		…
405		652
406	my $guard = guard {	653	my $guard = guard {
407	%state = ();	654	%state = ();
408	};	655	};
409		656
410	$connect->($state{fh}, format_ip $host, $port, sub {	657	$connect->($state{fh}, format_address $host, $port, sub {
411	$guard->cancel;	658	$guard->cancel;
412	$state{next}();	659	$state{next}();
413	});	660	});
414	} else {	661	} else {
415	# dummy read to fetch real error code	662	# dummy read to fetch real error code
…		…
419	};	666	};
420		667
421	# now connect	668	# now connect
422	if (connect $state{fh}, $sockaddr) {	669	if (connect $state{fh}, $sockaddr) {
423	$connected->();	670	$connected->();
424	} 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) {
425	$state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $connected);	676	$state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $connected);
426	} else {	677	} else {
427	%state = ();	678	$state{next}();
428	$connect->();
429	}	679	}
430	};	680	};
431		681
432	$! = &Errno::ENXIO;	682	$! = &Errno::ENXIO;
433	$state{next}();	683	$state{next}();
434	};	684	};
435		685
436	defined wantarray && guard { %state = () }	686	defined wantarray && guard { %state = () }
437	}	687	}
438		688
439	=item $guard = tcp_server $host, $port, $accept_cb[, $prepare_cb]	689	=item $guard = tcp_server $host, $service, $accept_cb[, $prepare_cb]
440		690
441	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
442	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
443	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.
444	the SO_REUSEADDR flag and call C<listen>.
445		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
		697	on whether IPv4 or IPv6 is the preferred protocol, and maybe to both in
		698	future versions, as applicable).
		699
		700	To bind to the IPv4 wildcard address, use C<0>, to bind to the IPv6
		701	wildcard address, use C<::>.
		702
		703	The port is specified by C<$service>, which must be either a service name or
		704	a numeric port number (or C<0> or C<undef>, in which case an ephemeral
		705	port will be used).
		706
		707	For UNIX domain sockets, C<$host> must be C<unix/> and C<$service> must be
		708	the absolute pathname of the socket. This function will try to C<unlink>
		709	the socket before it tries to bind to it. See SECURITY CONSIDERATIONS,
		710	below.
		711
446	For each new connection that could be C<accept>ed, call the C<$accept_cb>	712	For each new connection that could be C<accept>ed, call the C<<
447	with the file handle (in non-blocking mode) as first and the peer host and	713	$accept_cb->($fh, $host, $port) >> with the file handle (in non-blocking
448	port as second and third arguments (see C<tcp_connect> for details).	714	mode) as first and the peer host and port as second and third arguments
		715	(see C<tcp_connect> for details).
449		716
450	Croaks on any errors.	717	Croaks on any errors it can detect before the listen.
451		718
452	If called in non-void context, then this function returns a guard object	719	If called in non-void context, then this function returns a guard object
453	whose lifetime it tied to the TCP server: If the object gets destroyed,	720	whose lifetime it tied to the TCP server: If the object gets destroyed,
454	the server will be stopped (but existing accepted connections will	721	the server will be stopped (but existing accepted connections will
455	continue).	722	continue).
456		723
457	If you need more control over the listening socket, you can provide a	724	If you need more control over the listening socket, you can provide a
458	C<$prepare_cb>, which is called just before the C<listen ()> call, with	725	C<< $prepare_cb->($fh, $host, $port) >>, which is called just before the
459	the listen file handle as first argument.	726	C<listen ()> call, with the listen file handle as first argument, and IP
		727	address and port number of the local socket endpoint as second and third
		728	arguments.
460		729
461	It should return the length of the listen queue (or C<0> for the default).	730	It should return the length of the listen queue (or C<0> for the default).
462		731
		732	Note to IPv6 users: RFC-compliant behaviour for IPv6 sockets listening on
		733	C<::> is to bind to both IPv6 and IPv4 addresses by default on dual-stack
		734	hosts. Unfortunately, only GNU/Linux seems to implement this properly, so
		735	if you want both IPv4 and IPv6 listening sockets you should create the
		736	IPv6 socket first and then attempt to bind on the IPv4 socket, but ignore
		737	any C<EADDRINUSE> errors.
		738
463	Example: bind on TCP port 8888 on the local machine and tell each client	739	Example: bind on some TCP port on the local machine and tell each client
464	to go away.	740	to go away.
465		741
466	tcp_server undef, 8888, sub {	742	tcp_server undef, undef, sub {
467	my ($fh, $host, $port) = @_;	743	my ($fh, $host, $port) = @_;
468		744
469	syswrite $fh, "The internet is full, $host:$port. Go away!\015\012";	745	syswrite $fh, "The internet is full, $host:$port. Go away!\015\012";
		746	}, sub {
		747	my ($fh, $thishost, $thisport) = @_;
		748	warn "bound to $thishost, port $thisport\n";
470	};	749	};
471		750
472	=cut	751	=cut
473		752
474	sub tcp_server($$$;$) {	753	sub tcp_server($$$;$) {
475	my ($host, $port, $accept, $prepare) = @_;	754	my ($host, $service, $accept, $prepare) = @_;
		755
		756	$host = $AnyEvent::PROTOCOL{ipv4} < $AnyEvent::PROTOCOL{ipv6} && AF_INET6
		757	? "::" : "0"
		758	unless defined $host;
		759
		760	my $ipn = parse_address $host
		761	or Carp::croak "AnyEvent::Socket::tcp_server: cannot parse '$host' as host address";
		762
		763	my $af = address_family $ipn;
476		764
477	my %state;	765	my %state;
478		766
479	socket $state{fh}, &Socket::AF_INET, &Socket::SOCK_STREAM, 0	767	# win32 perl is too stupid to get this right :/
		768	Carp::croak "tcp_server/socket: address family not supported"
		769	if AnyEvent::WIN32 && $af == AF_UNIX;
		770
		771	socket $state{fh}, $af, SOCK_STREAM, 0
480	or Carp::croak "socket: $!";	772	or Carp::croak "tcp_server/socket: $!";
481		773
		774	if ($af == AF_INET \|\| $af == AF_INET6) {
482	setsockopt $state{fh}, &Socket::SOL_SOCKET, &Socket::SO_REUSEADDR, 1	775	setsockopt $state{fh}, SOL_SOCKET, SO_REUSEADDR, 1
483	or Carp::croak "so_reuseaddr: $!";	776	or Carp::croak "tcp_server/so_reuseaddr: $!"
		777	unless AnyEvent::WIN32; # work around windows bug
484		778
485	bind $state{fh}, Socket::pack_sockaddr_in _tcp_port $port, socket_inet_aton ($host \|\| "0.0.0.0")	779	unless ($service =~ /^\d*$/) {
		780	$service = (getservbyname $service, "tcp")[2]
		781	or Carp::croak "$service: service unknown"
		782	}
		783	} elsif ($af == AF_UNIX) {
		784	unlink $service;
		785	}
		786
		787	bind $state{fh}, pack_sockaddr $service, $ipn
486	or Carp::croak "bind: $!";	788	or Carp::croak "bind: $!";
487		789
488	fh_nonblocking $state{fh}, 1;	790	fh_nonblocking $state{fh}, 1;
489		791
490	my $len = ($prepare && $prepare->($state{fh})) \|\| 128;	792	my $len;
		793
		794	if ($prepare) {
		795	my ($service, $host) = unpack_sockaddr getsockname $state{fh};
		796	$len = $prepare && $prepare->($state{fh}, format_address $host, $service);
		797	}
		798
		799	$len \|\|= 128;
491		800
492	listen $state{fh}, $len	801	listen $state{fh}, $len
493	or Carp::croak "listen: $!";	802	or Carp::croak "listen: $!";
494		803
495	$state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub {	804	$state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub {
496	# this closure keeps $state alive	805	# this closure keeps $state alive
497	while (my $peer = accept my $fh, $state{fh}) {	806	while (my $peer = accept my $fh, $state{fh}) {
498	fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not	807	fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not
		808
499	my ($port, $host) = Socket::unpack_sockaddr_in $peer;	809	my ($service, $host) = unpack_sockaddr $peer;
500	$accept->($fh, (Socket::inet_ntoa $host), $port);	810	$accept->($fh, format_address $host, $service);
501	}	811	}
502	});	812	});
503		813
504	defined wantarray	814	defined wantarray
505	? guard { %state = () } # clear fh and watcher, which breaks the circular dependency	815	? guard { %state = () } # clear fh and watcher, which breaks the circular dependency
…		…
508		818
509	1;	819	1;
510		820
511	=back	821	=back
512		822
		823	=head1 SECURITY CONSIDERATIONS
		824
		825	This module is quite powerful, with with power comes the ability to abuse
		826	as well: If you accept "hostnames" and ports from untrusted sources,
		827	then note that this can be abused to delete files (host=C<unix/>). This
		828	is not really a problem with this module, however, as blindly accepting
		829	any address and protocol and trying to bind a server or connect to it is
		830	harmful in general.
		831
513	=head1 AUTHOR	832	=head1 AUTHOR
514		833
515	Marc Lehmann <schmorp@schmorp.de>	834	Marc Lehmann <schmorp@schmorp.de>
516	http://home.schmorp.de/	835	http://home.schmorp.de/
517		836

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents): Revision 1.18 by root, Sat May 24 18:50:40 2008 UTC vs. Revision 1.39 by root, Thu May 29 00:27:06 2008 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.18 by root, Sat May 24 18:50:40 2008 UTC vs.
Revision 1.39 by root, Thu May 29 00:27:06 2008 UTC