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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.63 by root, Wed Oct 1 07:40:39 2008 UTC vs.
Revision 1.111 by elmex, Mon Aug 10 13:36:00 2009 UTC

…		…
33		33
34	=cut	34	=cut
35		35
36	package AnyEvent::Socket;	36	package AnyEvent::Socket;
37		37
38	no warnings;
39	use strict;
40
41	use Carp ();	38	use Carp ();
42	use Errno ();	39	use Errno ();
43	use Socket qw(AF_INET AF_UNIX SOCK_STREAM SOCK_DGRAM SOL_SOCKET SO_REUSEADDR);	40	use Socket qw(AF_INET AF_UNIX SOCK_STREAM SOCK_DGRAM SOL_SOCKET SO_REUSEADDR);
44		41
45	use AnyEvent ();	42	use AnyEvent (); BEGIN { AnyEvent::common_sense }
46	use AnyEvent::Util qw(guard fh_nonblocking AF_INET6);	43	use AnyEvent::Util qw(guard fh_nonblocking AF_INET6);
47	use AnyEvent::DNS ();	44	use AnyEvent::DNS ();
48		45
49	use base 'Exporter';	46	use base 'Exporter';
50		47
51	our @EXPORT = qw(	48	our @EXPORT = qw(
52	parse_hostport	49	getprotobyname
		50	parse_hostport format_hostport
53	parse_ipv4 parse_ipv6	51	parse_ipv4 parse_ipv6
54	parse_ip parse_address	52	parse_ip parse_address
		53	format_ipv4 format_ipv6
55	format_ip format_address	54	format_ip format_address
56	address_family	55	address_family
57	inet_aton	56	inet_aton
58	tcp_server	57	tcp_server
59	tcp_connect	58	tcp_connect
60	);	59	);
61		60
62	our $VERSION = 4.3;	61	our $VERSION = $AnyEvent::VERSION;
		62
		63	# used in cases where we may return immediately but want the
		64	# caller to do stuff first
		65	sub _postpone {
		66	my ($cb, @args) = @_;
		67
		68	my $w; $w = AE::timer 0, 0, sub {
		69	undef $w;
		70	$cb->(@args);
		71	};
		72	}
63		73
64	=item $ipn = parse_ipv4 $dotted_quad	74	=item $ipn = parse_ipv4 $dotted_quad
65		75
66	Tries to parse the given dotted quad IPv4 address and return it in	76	Tries to parse the given dotted quad IPv4 address and return it in
67	octet form (or undef when it isn't in a parsable format). Supports all	77	octet form (or undef when it isn't in a parsable format). Supports all
…		…
144	? pack "S", AF_UNIX	154	? pack "S", AF_UNIX
145	: undef	155	: undef
146		156
147	}	157	}
148		158
149	=item $ipn = parse_address $text	159	=item $ipn = parse_address $ip
150		160
151	Combines C<parse_ipv4> and C<parse_ipv6> in one function. The address	161	Combines C<parse_ipv4> and C<parse_ipv6> in one function. The address
152	here refers to the host address (not socket address) in network form	162	here refers to the host address (not socket address) in network form
153	(binary).	163	(binary).
154		164
155	If the C<$text> is C<unix/>, then this function returns a special token	165	If the C<$text> is C<unix/>, then this function returns a special token
156	recognised by the other functions in this module to mean "UNIX domain	166	recognised by the other functions in this module to mean "UNIX domain
157	socket".	167	socket".
158		168
		169	If the C<$text> to parse is a mapped IPv4 in IPv6 address (:ffff::<ipv4>),
		170	then it will be treated as an IPv4 address. If you don't want that, you
		171	have to call C<parse_ipv4> and/or C<parse_ipv6> manually.
		172
159	=item $text = AnyEvent::Socket::aton $ipn	173	=item $ipn = AnyEvent::Socket::aton $ip
160		174
161	Same as C<parse_address>, but not exported (think C<Socket::inet_aton> but	175	Same as C<parse_address>, but not exported (think C<Socket::inet_aton> but
162	I<without> name resolution).	176	I<without> name resolution).
163		177
164	=cut	178	=cut
165		179
166	sub parse_address($) {	180	sub parse_address($) {
167	&parse_ipv4 \|\| &parse_ipv6 \|\| &parse_unix	181	for (&parse_ipv6) {
		182	if ($_) {
		183	s/^\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff//;
		184	return $_;
		185	} else {
		186	return &parse_ipv4 \|\| &parse_unix
		187	}
		188	}
168	}	189	}
169		190
170	*aton = \&parse_address;	191	*aton = \&parse_address;
		192
		193	=item ($name, $aliases, $proto) = getprotobyname $name
		194
		195	Works like the builtin function of the same name, except it tries hard to
		196	work even on broken platforms (well, that's windows), where getprotobyname
		197	is traditionally very unreliable.
		198
		199	=cut
		200
		201	# microsoft can't even get getprotobyname working (the etc/protocols file
		202	# gets lost fairly often on windows), so we have to hardcode some common
		203	# protocol numbers ourselves.
		204	our %PROTO_BYNAME;
		205
		206	$PROTO_BYNAME{tcp} = Socket::IPPROTO_TCP () if defined &Socket::IPPROTO_TCP;
		207	$PROTO_BYNAME{udp} = Socket::IPPROTO_UDP () if defined &Socket::IPPROTO_UDP;
		208	$PROTO_BYNAME{icmp} = Socket::IPPROTO_ICMP() if defined &Socket::IPPROTO_ICMP;
		209
		210	sub getprotobyname($) {
		211	my $name = lc shift;
		212
		213	defined (my $proton = $PROTO_BYNAME{$name} \|\| (getprotobyname $name)[2])
		214	or return;
		215
		216	($name, uc $name, $proton)
		217	}
171		218
172	=item ($host, $service) = parse_hostport $string[, $default_service]	219	=item ($host, $service) = parse_hostport $string[, $default_service]
173		220
174	Splitting a string of the form C<hostname:port> is a common	221	Splitting a string of the form C<hostname:port> is a common
175	problem. Unfortunately, just splitting on the colon makes it hard to	222	problem. Unfortunately, just splitting on the colon makes it hard to
…		…
191	ipv4or6 port e.g. "::1 443", "10.0.0.1 smtp"	238	ipv4or6 port e.g. "::1 443", "10.0.0.1 smtp"
192		239
193	It also supports defaulting the service name in a simple way by using	240	It also supports defaulting the service name in a simple way by using
194	C<$default_service> if no service was detected. If neither a service was	241	C<$default_service> if no service was detected. If neither a service was
195	detected nor a default was specified, then this function returns the	242	detected nor a default was specified, then this function returns the
196	empty list. The same happens when a parse error weas detected, such as a	243	empty list. The same happens when a parse error was detected, such as a
197	hostname with a colon in it (the function is rather conservative, though).	244	hostname with a colon in it (the function is rather conservative, though).
198		245
199	Example:	246	Example:
200		247
201	print join ",", parse_hostport "localhost:443";	248	print join ",", parse_hostport "localhost:443";
…		…
244	return if $host =~ /:/ && !parse_ipv6 $host;	291	return if $host =~ /:/ && !parse_ipv6 $host;
245		292
246	($host, $port)	293	($host, $port)
247	}	294	}
248		295
		296	=item $string = format_hostport $host, $port
		297
		298	Takes a host (in textual form) and a port and formats in unambigiously in
		299	a way that C<parse_hostport> can parse it again. C<$port> can be C<undef>.
		300
		301	=cut
		302
		303	sub format_hostport($;$) {
		304	my ($host, $port) = @_;
		305
		306	$port = ":$port" if length $port;
		307	$host = "[$host]" if $host =~ /:/;
		308
		309	"$host$port"
		310	}
		311
249	=item $sa_family = address_family $ipn	312	=item $sa_family = address_family $ipn
250		313
251	Returns the address family/protocol-family (AF_xxx/PF_xxx, in one value :)	314	Returns the address family/protocol-family (AF_xxx/PF_xxx, in one value :)
252	of the given host address in network format.	315	of the given host address in network format.
253		316
…		…
259	: 16 == length $_[0]	322	: 16 == length $_[0]
260	? AF_INET6	323	? AF_INET6
261	: unpack "S", $_[0]	324	: unpack "S", $_[0]
262	}	325	}
263		326
		327	=item $text = format_ipv4 $ipn
		328
		329	Expects a four octet string representing a binary IPv4 address and returns
		330	its textual format. Rarely used, see C<format_address> for a nicer
		331	interface.
		332
		333	=item $text = format_ipv6 $ipn
		334
		335	Expects a sixteen octet string representing a binary IPv6 address and
		336	returns its textual format. Rarely used, see C<format_address> for a
		337	nicer interface.
		338
264	=item $text = format_address $ipn	339	=item $text = format_address $ipn
265		340
266	Covnvert a host address in network format (e.g. 4 octets for IPv4 or 16	341	Covnvert a host address in network format (e.g. 4 octets for IPv4 or 16
267	octets for IPv6) and convert it into textual form.	342	octets for IPv6) and convert it into textual form.
268		343
…		…
271	This function works similarly to C<inet_ntop AF_INET \|\| AF_INET6, ...>,	346	This function works similarly to C<inet_ntop AF_INET \|\| AF_INET6, ...>,
272	except it automatically detects the address type.	347	except it automatically detects the address type.
273		348
274	Returns C<undef> if it cannot detect the type.	349	Returns C<undef> if it cannot detect the type.
275		350
		351	If the C<$ipn> is a mapped IPv4 in IPv6 address (:ffff::<ipv4>), then just
		352	the contained IPv4 address will be returned. If you do not want that, you
		353	have to call C<format_ipv6> manually.
		354
276	=item $text = AnyEvent::Socket::ntoa $ipn	355	=item $text = AnyEvent::Socket::ntoa $ipn
277		356
278	Same as format_address, but not exported (think C<inet_ntoa>).	357	Same as format_address, but not exported (think C<inet_ntoa>).
279		358
280	=cut	359	=cut
281		360
282	sub format_address;	361	sub format_ipv4($) {
		362	join ".", unpack "C4", $_[0]
		363	}
		364
		365	sub format_ipv6($) {
		366	if (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0 eq $_[0]) {
		367	return "::";
		368	} elsif (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.1 eq $_[0]) {
		369	return "::1";
		370	} elsif (v0.0.0.0.0.0.0.0.0.0.0.0 eq substr $_[0], 0, 12) {
		371	# v4compatible
		372	return "::" . format_ipv4 substr $_[0], 12;
		373	} elsif (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12) {
		374	# v4mapped
		375	return "::ffff:" . format_ipv4 substr $_[0], 12;
		376	} elsif (v0.0.0.0.0.0.0.0.255.255.0.0 eq substr $_[0], 0, 12) {
		377	# v4translated
		378	return "::ffff:0:" . format_ipv4 substr $_[0], 12;
		379	} else {
		380	my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0];
		381
		382	# this is rather sucky, I admit
		383	$ip =~ s/^0:(?:0:)*(0$)?/::/
		384	or $ip =~ s/(:0){7}$/::/ or $ip =~ s/(:0){7}/:/
		385	or $ip =~ s/(:0){6}$/::/ or $ip =~ s/(:0){6}/:/
		386	or $ip =~ s/(:0){5}$/::/ or $ip =~ s/(:0){5}/:/
		387	or $ip =~ s/(:0){4}$/::/ or $ip =~ s/(:0){4}/:/
		388	or $ip =~ s/(:0){3}$/::/ or $ip =~ s/(:0){3}/:/
		389	or $ip =~ s/(:0){2}$/::/ or $ip =~ s/(:0){2}/:/
		390	or $ip =~ s/(:0){1}$/::/ or $ip =~ s/(:0){1}/:/;
		391	return $ip
		392	}
		393	}
		394
283	sub format_address($) {	395	sub format_address($) {
284	my $af = address_family $_[0];	396	my $af = address_family $_[0];
285	if ($af == AF_INET) {	397	if ($af == AF_INET) {
286	return join ".", unpack "C4", $_[0]	398	return &format_ipv4;
287	} elsif ($af == AF_INET6) {	399	} elsif ($af == AF_INET6) {
288	if (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0 eq $_[0]) {
289	return "::";
290	} elsif (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.1 eq $_[0]) {
291	return "::1";
292	} elsif (v0.0.0.0.0.0.0.0.0.0.0.0 eq substr $_[0], 0, 12) {
293	# v4compatible
294	return "::" . format_address substr $_[0], 12;
295	} elsif (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12) {	400	return (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12)
296	# v4mapped	401	? format_ipv4 substr $_[0], 12
297	return "::ffff:" . format_address substr $_[0], 12;	402	: &format_ipv6;
298	} elsif (v0.0.0.0.0.0.0.0.255.255.0.0 eq substr $_[0], 0, 12) {
299	# v4translated
300	return "::ffff:0:" . format_address substr $_[0], 12;
301	} else {
302	my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0];
303
304	# this is rather sucky, I admit
305	$ip =~ s/^0:(?:0:)*(0$)?/::/
306	or $ip =~ s/(:0){7}$/::/ or $ip =~ s/(:0){7}/:/
307	or $ip =~ s/(:0){6}$/::/ or $ip =~ s/(:0){6}/:/
308	or $ip =~ s/(:0){5}$/::/ or $ip =~ s/(:0){5}/:/
309	or $ip =~ s/(:0){4}$/::/ or $ip =~ s/(:0){4}/:/
310	or $ip =~ s/(:0){3}$/::/ or $ip =~ s/(:0){3}/:/
311	or $ip =~ s/(:0){2}$/::/ or $ip =~ s/(:0){2}/:/
312	or $ip =~ s/(:0){1}$/::/ or $ip =~ s/(:0){1}/:/;
313	return $ip
314	}
315	} elsif ($af == AF_UNIX) {	403	} elsif ($af == AF_UNIX) {
316	return "unix/"	404	return "unix/"
317	} else {	405	} else {
318	return undef	406	return undef
319	}	407	}
…		…
355	}	443	}
356	});	444	});
357	}	445	}
358	}	446	}
359		447
		448	BEGIN {
		449	*sockaddr_family = $Socket::VERSION >= 1.75
		450	? \&Socket::sockaddr_family
		451	: # for 5.6.x, we need to do something much more horrible
		452	(Socket::pack_sockaddr_in 0x5555, "\x55\x55\x55\x55"
		453	\| eval { Socket::pack_sockaddr_un "U" }) =~ /^\x00/
		454	? sub { unpack "xC", $_[0] }
		455	: sub { unpack "S" , $_[0] };
		456	}
		457
360	# check for broken platforms with extra field in sockaddr structure	458	# check for broken platforms with extra field in sockaddr structure
361	# kind of a rfc vs. bsd issue, as usual (ok, normally it's a	459	# kind of a rfc vs. bsd issue, as usual (ok, normally it's a
362	# unix vs. bsd issue, a iso C vs. bsd issue or simply a	460	# unix vs. bsd issue, a iso C vs. bsd issue or simply a
363	# correctness vs. bsd issue.	461	# correctness vs. bsd issue.)
364	my $pack_family = (0x55 == Socket::sockaddr_family "\x55\x55")	462	my $pack_family = 0x55 == sockaddr_family ("\x55\x55")
365	? "xC" : "S";	463	? "xC" : "S";
366		464
367	=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host	465	=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host
368		466
369	Pack the given port/host combination into a binary sockaddr	467	Pack the given port/host combination into a binary sockaddr
…		…
405	module (C<format_address> converts it to C<unix/>).	503	module (C<format_address> converts it to C<unix/>).
406		504
407	=cut	505	=cut
408		506
409	sub unpack_sockaddr($) {	507	sub unpack_sockaddr($) {
410	my $af = Socket::sockaddr_family $_[0];	508	my $af = sockaddr_family $_[0];
411		509
412	if ($af == AF_INET) {	510	if ($af == AF_INET) {
413	Socket::unpack_sockaddr_in $_[0]	511	Socket::unpack_sockaddr_in $_[0]
414	} elsif ($af == AF_INET6) {	512	} elsif ($af == AF_INET6) {
415	unpack "x2 n x4 a16", $_[0]	513	unpack "x2 n x4 a16", $_[0]
…		…
443	C<sctp>. The default is currently C<tcp>, but in the future, this function	541	C<sctp>. The default is currently C<tcp>, but in the future, this function
444	might try to use other protocols such as C<sctp>, depending on the socket	542	might try to use other protocols such as C<sctp>, depending on the socket
445	type and any SRV records it might find.	543	type and any SRV records it might find.
446		544
447	C<$family> must be either C<0> (meaning any protocol is OK), C<4> (use	545	C<$family> must be either C<0> (meaning any protocol is OK), C<4> (use
448	only IPv4) or C<6> (use only IPv6). This setting might be influenced by	546	only IPv4) or C<6> (use only IPv6). The default is influenced by
449	C<$ENV{PERL_ANYEVENT_PROTOCOLS}>.	547	C<$ENV{PERL_ANYEVENT_PROTOCOLS}>.
450		548
451	C<$type> must be C<SOCK_STREAM>, C<SOCK_DGRAM> or C<SOCK_SEQPACKET> (or	549	C<$type> must be C<SOCK_STREAM>, C<SOCK_DGRAM> or C<SOCK_SEQPACKET> (or
452	C<undef> in which case it gets automatically chosen).	550	C<undef> in which case it gets automatically chosen to be C<SOCK_STREAM>
		551	unless C<$proto> is C<udp>).
453		552
454	The callback will receive zero or more array references that contain	553	The callback will receive zero or more array references that contain
455	C<$family, $type, $proto> for use in C<socket> and a binary	554	C<$family, $type, $proto> for use in C<socket> and a binary
456	C<$sockaddr> for use in C<connect> (or C<bind>).	555	C<$sockaddr> for use in C<connect> (or C<bind>).
457		556
…		…
461		560
462	resolve_sockaddr "google.com", "http", 0, undef, undef, sub { ... };	561	resolve_sockaddr "google.com", "http", 0, undef, undef, sub { ... };
463		562
464	=cut	563	=cut
465		564
466	# microsoft can't even get getprotobyname working (the etc/protocols file
467	# gets lost fairly often on windows), so we have to hardcode some common
468	# protocol numbers ourselves.
469	our %PROTO_BYNAME;
470
471	$PROTO_BYNAME{tcp} = &Socket::IPPROTO_TCP if defined &Socket::IPPROTO_TCP;
472	$PROTO_BYNAME{udp} = &Socket::IPPROTO_UDP if defined &Socket::IPPROTO_UDP;
473	$PROTO_BYNAME{icmp} = &Socket::IPPROTO_ICMP if defined &Socket::IPPROTO_ICMP;
474
475	sub resolve_sockaddr($$$$$$) {	565	sub resolve_sockaddr($$$$$$) {
476	my ($node, $service, $proto, $family, $type, $cb) = @_;	566	my ($node, $service, $proto, $family, $type, $cb) = @_;
477		567
478	if ($node eq "unix/") {	568	if ($node eq "unix/") {
479	return $cb->() if $family \|\| !/^\//; # no can do	569	return $cb->() if $family \|\| $service !~ /^\//; # no can do
480		570
481	return $cb->([AF_UNIX, $type, 0, Socket::pack_sockaddr_un $service]);	571	return $cb->([AF_UNIX, defined $type ? $type : SOCK_STREAM, 0, Socket::pack_sockaddr_un $service]);
482	}	572	}
483		573
484	unless (AF_INET6) {	574	unless (AF_INET6) {
485	$family != 6	575	$family != 6
486	or return $cb->();	576	or return $cb->();
…		…
495	$family \|\|= 6 unless $AnyEvent::PROTOCOL{ipv4};	585	$family \|\|= 6 unless $AnyEvent::PROTOCOL{ipv4};
496		586
497	$proto \|\|= "tcp";	587	$proto \|\|= "tcp";
498	$type \|\|= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM;	588	$type \|\|= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM;
499		589
500	my $proton = $PROTO_BYNAME{lc $proto} \|\| (getprotobyname $proto)[2]	590	my $proton = getprotobyname $proto
501	or Carp::croak "$proto: protocol unknown";	591	or Carp::croak "$proto: protocol unknown";
502		592
503	my $port;	593	my $port;
504		594
505	if ($service =~ /^(\S+)=(\d+)$/) {	595	if ($service =~ /^(\S+)=(\d+)$/) {
…		…
514	my @target = [$node, $port];	604	my @target = [$node, $port];
515		605
516	# resolve a records / provide sockaddr structures	606	# resolve a records / provide sockaddr structures
517	my $resolve = sub {	607	my $resolve = sub {
518	my @res;	608	my @res;
519	my $cv = AnyEvent->condvar (cb => sub {	609	my $cv = AE::cv {
520	$cb->(	610	$cb->(
521	map $_->[2],	611	map $_->[2],
522	sort {	612	sort {
523	$AnyEvent::PROTOCOL{$b->[1]} <=> $AnyEvent::PROTOCOL{$a->[1]}	613	$AnyEvent::PROTOCOL{$b->[1]} <=> $AnyEvent::PROTOCOL{$a->[1]}
524	or $a->[0] <=> $b->[0]	614	or $a->[0] <=> $b->[0]
525	}	615	}
526	@res	616	@res
527	)	617	)
528	});	618	};
529		619
530	$cv->begin;	620	$cv->begin;
531	for my $idx (0 .. $#target) {	621	for my $idx (0 .. $#target) {
532	my ($node, $port) = @{ $target[$idx] };	622	my ($node, $port) = @{ $target[$idx] };
533		623
…		…
612		702
613	In either case, it will create a list of target hosts (e.g. for multihomed	703	In either case, it will create a list of target hosts (e.g. for multihomed
614	hosts or hosts with both IPv4 and IPv6 addresses) and try to connect to	704	hosts or hosts with both IPv4 and IPv6 addresses) and try to connect to
615	each in turn.	705	each in turn.
616		706
617	If the connect is successful, then the C<$connect_cb> will be invoked with	707	After the connection is established, then the C<$connect_cb> will be
618	the socket file handle (in non-blocking mode) as first and the peer host	708	invoked with the socket file handle (in non-blocking mode) as first and
619	(as a textual IP address) and peer port as second and third arguments,	709	the peer host (as a textual IP address) and peer port as second and third
620	respectively. The fourth argument is a code reference that you can call	710	arguments, respectively. The fourth argument is a code reference that you
621	if, for some reason, you don't like this connection, which will cause	711	can call if, for some reason, you don't like this connection, which will
622	C<tcp_connect> to try the next one (or call your callback without any	712	cause C<tcp_connect> to try the next one (or call your callback without
623	arguments if there are no more connections). In most cases, you can simply	713	any arguments if there are no more connections). In most cases, you can
624	ignore this argument.	714	simply ignore this argument.
625		715
626	$cb->($filehandle, $host, $port, $retry)	716	$cb->($filehandle, $host, $port, $retry)
627		717
628	If the connect is unsuccessful, then the C<$connect_cb> will be invoked	718	If the connect is unsuccessful, then the C<$connect_cb> will be invoked
629	without any arguments and C<$!> will be set appropriately (with C<ENXIO>	719	without any arguments and C<$!> will be set appropriately (with C<ENXIO>
630	indicating a DNS resolution failure).	720	indicating a DNS resolution failure).
		721
		722	The callback will I<never> be invoked before C<tcp_connect> returns, even
		723	if C<tcp_connect> was able to connect immediately (e.g. on unix domain
		724	sockets).
631		725
632	The file handle is perfect for being plugged into L<AnyEvent::Handle>, but	726	The file handle is perfect for being plugged into L<AnyEvent::Handle>, but
633	can be used as a normal perl file handle as well.	727	can be used as a normal perl file handle as well.
634		728
635	Unless called in void context, C<tcp_connect> returns a guard object that	729	Unless called in void context, C<tcp_connect> returns a guard object that
…		…
674	or die "unable to connect: $!";	768	or die "unable to connect: $!";
675		769
676	my $handle; # avoid direct assignment so on_eof has it in scope.	770	my $handle; # avoid direct assignment so on_eof has it in scope.
677	$handle = new AnyEvent::Handle	771	$handle = new AnyEvent::Handle
678	fh => $fh,	772	fh => $fh,
		773	on_error => sub {
		774	warn "error $_[2]\n";
		775	$_[0]->destroy;
		776	},
679	on_eof => sub {	777	on_eof => sub {
680	undef $handle; # keep it alive till eof	778	$handle->destroy; # destroy handle
681	warn "done.\n";	779	warn "done.\n";
682	};	780	};
683		781
684	$handle->push_write ("GET / HTTP/1.0\015\012\015\012");	782	$handle->push_write ("GET / HTTP/1.0\015\012\015\012");
685		783
686	$handle->push_read_line ("\015\012\015\012", sub {	784	$handle->push_read (line => "\015\012\015\012", sub {
687	my ($handle, $line) = @_;	785	my ($handle, $line) = @_;
688		786
689	# print response header	787	# print response header
690	print "HEADER\n$line\n\nBODY\n";	788	print "HEADER\n$line\n\nBODY\n";
691		789
…		…
717	# also http://advogato.org/article/672.html	815	# also http://advogato.org/article/672.html
718		816
719	my %state = ( fh => undef );	817	my %state = ( fh => undef );
720		818
721	# name/service to type/sockaddr resolution	819	# name/service to type/sockaddr resolution
722	resolve_sockaddr $host, $port, 0, 0, 0, sub {	820	resolve_sockaddr $host, $port, 0, 0, undef, sub {
723	my @target = @_;	821	my @target = @_;
724		822
725	$state{next} = sub {	823	$state{next} = sub {
726	return unless exists $state{fh};	824	return unless exists $state{fh};
727		825
728	my $target = shift @target	826	my $target = shift @target
729	or do {	827	or return (%state = (), _postpone $connect);
730	%state = ();
731	return $connect->();
732	};
733		828
734	my ($domain, $type, $proto, $sockaddr) = @$target;	829	my ($domain, $type, $proto, $sockaddr) = @$target;
735		830
736	# socket creation	831	# socket creation
737	socket $state{fh}, $domain, $type, $proto	832	socket $state{fh}, $domain, $type, $proto
…		…
741		836
742	my $timeout = $prepare && $prepare->($state{fh});	837	my $timeout = $prepare && $prepare->($state{fh});
743		838
744	$timeout \|\|= 30 if AnyEvent::WIN32;	839	$timeout \|\|= 30 if AnyEvent::WIN32;
745		840
746	$state{to} = AnyEvent->timer (after => $timeout, cb => sub {	841	$state{to} = AE::timer $timeout, 0, sub {
747	$! = &Errno::ETIMEDOUT;	842	$! = Errno::ETIMEDOUT;
748	$state{next}();	843	$state{next}();
749	}) if $timeout;	844	} if $timeout;
750		845
751	# called when the connect was successful, which,	846	# now connect
752	# in theory, could be the case immediately (but never is in practise)	847	if (
753	my $connected = sub {	848	(connect $state{fh}, $sockaddr)
754	delete $state{ww};	849	\|\| ($! == Errno::EINPROGRESS # POSIX
755	delete $state{to};	850	\|\| $! == Errno::EWOULDBLOCK
756		851	# WSAEINPROGRESS intentionally not checked - it means something else entirely
		852	\|\| $! == AnyEvent::Util::WSAEINVAL # not convinced, but doesn't hurt
		853	\|\| $! == AnyEvent::Util::WSAEWOULDBLOCK)
		854	) {
		855	$state{ww} = AE::io $state{fh}, 1, sub {
757	# we are connected, or maybe there was an error	856	# we are connected, or maybe there was an error
758	if (my $sin = getpeername $state{fh}) {	857	if (my $sin = getpeername $state{fh}) {
759	my ($port, $host) = unpack_sockaddr $sin;	858	my ($port, $host) = unpack_sockaddr $sin;
760		859
		860	delete $state{ww}; delete $state{to};
		861
761	my $guard = guard {	862	my $guard = guard { %state = () };
762	%state = ();
763	};
764		863
765	$connect->($state{fh}, format_address $host, $port, sub {	864	$connect->(delete $state{fh}, format_address $host, $port, sub {
766	$guard->cancel;	865	$guard->cancel;
		866	$state{next}();
		867	});
		868	} else {
		869	# dummy read to fetch real error code
		870	sysread $state{fh}, my $buf, 1 if $! == Errno::ENOTCONN;
		871
		872	return if $! == Errno::EAGAIN; # skip spurious wake-ups
		873
		874	delete $state{ww}; delete $state{to};
		875
767	$state{next}();	876	$state{next}();
768	});	877	}
769	} else {
770	# dummy read to fetch real error code
771	sysread $state{fh}, my $buf, 1 if $! == &Errno::ENOTCONN;
772	$state{next}();
773	}	878	};
774	};
775
776	# now connect
777	if (connect $state{fh}, $sockaddr) {
778	$connected->();
779	} elsif ($! == &Errno::EINPROGRESS # POSIX
780	\|\| $! == &Errno::EWOULDBLOCK
781	# WSAEINPROGRESS intentionally not checked - it means something else entirely
782	\|\| $! == AnyEvent::Util::WSAEINVAL # not convinced, but doesn't hurt
783	\|\| $! == AnyEvent::Util::WSAEWOULDBLOCK) {
784	$state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $connected);
785	} else {	879	} else {
786	$state{next}();	880	$state{next}();
787	}	881	}
788	};	882	};
789		883
790	$! = &Errno::ENXIO;	884	$! = Errno::ENXIO;
791	$state{next}();	885	$state{next}();
792	};	886	};
793		887
794	defined wantarray && guard { %state = () }	888	defined wantarray && guard { %state = () }
795	}	889	}
…		…
854	}, sub {	948	}, sub {
855	my ($fh, $thishost, $thisport) = @_;	949	my ($fh, $thishost, $thisport) = @_;
856	warn "bound to $thishost, port $thisport\n";	950	warn "bound to $thishost, port $thisport\n";
857	};	951	};
858		952
		953	Example: bind a server on a unix domain socket.
		954
		955	tcp_server "unix/", "/tmp/mydir/mysocket", sub {
		956	my ($fh) = @_;
		957	};
		958
859	=cut	959	=cut
860		960
861	sub tcp_server($$$;$) {	961	sub tcp_server($$$;$) {
862	my ($host, $service, $accept, $prepare) = @_;	962	my ($host, $service, $accept, $prepare) = @_;
863		963
…		…
907	$len \|\|= 128;	1007	$len \|\|= 128;
908		1008
909	listen $state{fh}, $len	1009	listen $state{fh}, $len
910	or Carp::croak "listen: $!";	1010	or Carp::croak "listen: $!";
911		1011
912	$state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub {	1012	$state{aw} = AE::io $state{fh}, 0, sub {
913	# this closure keeps $state alive	1013	# this closure keeps $state alive
914	while (my $peer = accept my $fh, $state{fh}) {	1014	while (my $peer = accept my $fh, $state{fh}) {
915	fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not	1015	fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not
916		1016
917	my ($service, $host) = unpack_sockaddr $peer;	1017	my ($service, $host) = unpack_sockaddr $peer;
918	$accept->($fh, format_address $host, $service);	1018	$accept->($fh, format_address $host, $service);
919	}	1019	}
920	});	1020	};
921		1021
922	defined wantarray	1022	defined wantarray
923	? guard { %state = () } # clear fh and watcher, which breaks the circular dependency	1023	? guard { %state = () } # clear fh and watcher, which breaks the circular dependency
924	: ()	1024	: ()
925	}	1025	}

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents): Revision 1.63 by root, Wed Oct 1 07:40:39 2008 UTC vs. Revision 1.111 by elmex, Mon Aug 10 13:36:00 2009 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.63 by root, Wed Oct 1 07:40:39 2008 UTC vs.
Revision 1.111 by elmex, Mon Aug 10 13:36:00 2009 UTC