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

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.113 by root, Sun Aug 16 16:54:51 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.113 by root, Sun Aug 16 16:54:51 2009 UTC