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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.102 by root, Thu Jul 30 16:39:19 2009 UTC vs.
Revision 1.125 by root, Mon Oct 11 03:41:39 2010 UTC

…		…
45		45
46	use base 'Exporter';	46	use base 'Exporter';
47		47
48	our @EXPORT = qw(	48	our @EXPORT = qw(
49	getprotobyname	49	getprotobyname
50	parse_hostport	50	parse_hostport format_hostport
51	parse_ipv4 parse_ipv6	51	parse_ipv4 parse_ipv6
52	parse_ip parse_address	52	parse_ip parse_address
53	format_ipv4 format_ipv6	53	format_ipv4 format_ipv6
54	format_ip format_address	54	format_ip format_address
55	address_family	55	address_family
56	inet_aton	56	inet_aton
57	tcp_server	57	tcp_server
58	tcp_connect	58	tcp_connect
59	);	59	);
60		60
61	our $VERSION = 4.881;	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	}
62		74
63	=item $ipn = parse_ipv4 $dotted_quad	75	=item $ipn = parse_ipv4 $dotted_quad
64		76
65	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
66	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
…		…
97	forms supported by parse_ipv4). Note that scope-id's are not supported	109	forms supported by parse_ipv4). Note that scope-id's are not supported
98	(and will not parse).	110	(and will not parse).
99		111
100	This function works similarly to C<inet_pton AF_INET6, ...>.	112	This function works similarly to C<inet_pton AF_INET6, ...>.
101		113
		114	Example:
		115
		116	print unpack "H*", parse_ipv6 "2002:5345::10.0.0.1";
		117	# => 2002534500000000000000000a000001
		118
102	=cut	119	=cut
103		120
104	sub parse_ipv6($) {	121	sub parse_ipv6($) {
105	# quick test to avoid longer processing	122	# quick test to avoid longer processing
106	my $n = $_[0] =~ y/://;	123	my $n = $_[0] =~ y/://;
…		…
156	socket".	173	socket".
157		174
158	If the C<$text> to parse is a mapped IPv4 in IPv6 address (:ffff::<ipv4>),	175	If the C<$text> to parse is a mapped IPv4 in IPv6 address (:ffff::<ipv4>),
159	then it will be treated as an IPv4 address. If you don't want that, you	176	then it will be treated as an IPv4 address. If you don't want that, you
160	have to call C<parse_ipv4> and/or C<parse_ipv6> manually.	177	have to call C<parse_ipv4> and/or C<parse_ipv6> manually.
		178
		179	Example:
		180
		181	print unpack "H*", parse_address "10.1.2.3";
		182	# => 0a010203
161		183
162	=item $ipn = AnyEvent::Socket::aton $ip	184	=item $ipn = AnyEvent::Socket::aton $ip
163		185
164	Same as C<parse_address>, but not exported (think C<Socket::inet_aton> but	186	Same as C<parse_address>, but not exported (think C<Socket::inet_aton> but
165	I<without> name resolution).	187	I<without> name resolution).
…		…
183		205
184	Works like the builtin function of the same name, except it tries hard to	206	Works like the builtin function of the same name, except it tries hard to
185	work even on broken platforms (well, that's windows), where getprotobyname	207	work even on broken platforms (well, that's windows), where getprotobyname
186	is traditionally very unreliable.	208	is traditionally very unreliable.
187		209
		210	Example: get the protocol number for TCP (usually 6)
		211
		212	my $proto = getprotobyname "tcp";
		213
188	=cut	214	=cut
189		215
190	# microsoft can't even get getprotobyname working (the etc/protocols file	216	# microsoft can't even get getprotobyname working (the etc/protocols file
191	# gets lost fairly often on windows), so we have to hardcode some common	217	# gets lost fairly often on windows), so we have to hardcode some common
192	# protocol numbers ourselves.	218	# protocol numbers ourselves.
…		…
280	return if $host =~ /:/ && !parse_ipv6 $host;	306	return if $host =~ /:/ && !parse_ipv6 $host;
281		307
282	($host, $port)	308	($host, $port)
283	}	309	}
284		310
		311	=item $string = format_hostport $host, $port
		312
		313	Takes a host (in textual form) and a port and formats in unambigiously in
		314	a way that C<parse_hostport> can parse it again. C<$port> can be C<undef>.
		315
		316	=cut
		317
		318	sub format_hostport($;$) {
		319	my ($host, $port) = @_;
		320
		321	$port = ":$port" if length $port;
		322	$host = "[$host]" if $host =~ /:/;
		323
		324	"$host$port"
		325	}
		326
285	=item $sa_family = address_family $ipn	327	=item $sa_family = address_family $ipn
286		328
287	Returns the address family/protocol-family (AF_xxx/PF_xxx, in one value :)	329	Returns the address family/protocol-family (AF_xxx/PF_xxx, in one value :)
288	of the given host address in network format.	330	of the given host address in network format.
289		331
…		…
323		365
324	If the C<$ipn> is a mapped IPv4 in IPv6 address (:ffff::<ipv4>), then just	366	If the C<$ipn> is a mapped IPv4 in IPv6 address (:ffff::<ipv4>), then just
325	the contained IPv4 address will be returned. If you do not want that, you	367	the contained IPv4 address will be returned. If you do not want that, you
326	have to call C<format_ipv6> manually.	368	have to call C<format_ipv6> manually.
327		369
		370	Example:
		371
		372	print format_address "\x01\x02\x03\x05";
		373	=> 1.2.3.5
		374
328	=item $text = AnyEvent::Socket::ntoa $ipn	375	=item $text = AnyEvent::Socket::ntoa $ipn
329		376
330	Same as format_address, but not exported (think C<inet_ntoa>).	377	Same as format_address, but not exported (think C<inet_ntoa>).
331		378
332	=cut	379	=cut
…		…
334	sub format_ipv4($) {	381	sub format_ipv4($) {
335	join ".", unpack "C4", $_[0]	382	join ".", unpack "C4", $_[0]
336	}	383	}
337		384
338	sub format_ipv6($) {	385	sub format_ipv6($) {
		386	if ($_[0] =~ /^\x00\x00\x00\x00\x00\x00\x00\x00/) {
339	if (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0 eq $_[0]) {	387	if (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0 eq $_[0]) {
340	return "::";	388	return "::";
341	} elsif (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.1 eq $_[0]) {	389	} elsif (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.1 eq $_[0]) {
342	return "::1";	390	return "::1";
343	} elsif (v0.0.0.0.0.0.0.0.0.0.0.0 eq substr $_[0], 0, 12) {	391	} elsif (v0.0.0.0.0.0.0.0.0.0.0.0 eq substr $_[0], 0, 12) {
344	# v4compatible	392	# v4compatible
345	return "::" . format_ipv4 substr $_[0], 12;	393	return "::" . format_ipv4 substr $_[0], 12;
346	} elsif (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12) {	394	} elsif (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12) {
347	# v4mapped	395	# v4mapped
348	return "::ffff:" . format_ipv4 substr $_[0], 12;	396	return "::ffff:" . format_ipv4 substr $_[0], 12;
349	} elsif (v0.0.0.0.0.0.0.0.255.255.0.0 eq substr $_[0], 0, 12) {	397	} elsif (v0.0.0.0.0.0.0.0.255.255.0.0 eq substr $_[0], 0, 12) {
350	# v4translated	398	# v4translated
351	return "::ffff:0:" . format_ipv4 substr $_[0], 12;	399	return "::ffff:0:" . format_ipv4 substr $_[0], 12;
352	} else {	400	}
		401	}
		402
353	my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0];	403	my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0];
354		404
355	# this is rather sucky, I admit	405	# this is admittedly rather sucky
356	$ip =~ s/^0:(?:0:)*(0$)?/::/	406	$ip =~ s/(?:^\|:) 0:0:0:0:0:0:0 (?:$\|:)/::/x
357	or $ip =~ s/(:0){7}$/::/ or $ip =~ s/(:0){7}/:/	407	or $ip =~ s/(?:^\|:) 0:0:0:0:0:0 (?:$\|:)/::/x
358	or $ip =~ s/(:0){6}$/::/ or $ip =~ s/(:0){6}/:/	408	or $ip =~ s/(?:^\|:) 0:0:0:0:0 (?:$\|:)/::/x
359	or $ip =~ s/(:0){5}$/::/ or $ip =~ s/(:0){5}/:/	409	or $ip =~ s/(?:^\|:) 0:0:0:0 (?:$\|:)/::/x
360	or $ip =~ s/(:0){4}$/::/ or $ip =~ s/(:0){4}/:/	410	or $ip =~ s/(?:^\|:) 0:0:0 (?:$\|:)/::/x
361	or $ip =~ s/(:0){3}$/::/ or $ip =~ s/(:0){3}/:/	411	or $ip =~ s/(?:^\|:) 0:0 (?:$\|:)/::/x
362	or $ip =~ s/(:0){2}$/::/ or $ip =~ s/(:0){2}/:/	412	or $ip =~ s/(?:^\|:) 0 (?:$\|:)/::/x;
363	or $ip =~ s/(:0){1}$/::/ or $ip =~ s/(:0){1}/:/;	413
364	return $ip	414	$ip
365	}
366	}	415	}
367		416
368	sub format_address($) {	417	sub format_address($) {
369	my $af = address_family $_[0];	418	if (4 == length $_[0]) {
370	if ($af == AF_INET) {
371	return &format_ipv4;	419	return &format_ipv4;
372	} elsif ($af == AF_INET6) {	420	} elsif (16 == length $_[0]) {
373	return (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12)	421	return $_[0] =~ /^\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff(....)$/s
374	? format_ipv4 substr $_[0], 12	422	? format_ipv4 $1
375	: &format_ipv6;	423	: &format_ipv6;
376	} elsif ($af == AF_UNIX) {	424	} elsif (AF_UNIX == address_family $_[0]) {
377	return "unix/"	425	return "unix/"
378	} else {	426	} else {
379	return undef	427	return undef
380	}	428	}
381	}	429	}
…		…
383	*ntoa = \&format_address;	431	*ntoa = \&format_address;
384		432
385	=item inet_aton $name_or_address, $cb->(@addresses)	433	=item inet_aton $name_or_address, $cb->(@addresses)
386		434
387	Works similarly to its Socket counterpart, except that it uses a	435	Works similarly to its Socket counterpart, except that it uses a
388	callback. Also, if a host has only an IPv6 address, this might be passed	436	callback. Use the length to distinguish between ipv4 and ipv6 (4 octets
389	to the callback instead (use the length to detect this - 4 for IPv4, 16	437	for IPv4, 16 for IPv6), or use C<format_address> to convert it to a more
390	for IPv6).	438	readable format.
391		439
392	Unlike the L<Socket> function of the same name, you can get multiple IPv4	440	Note that C<resolve_sockaddr>, while initially a more complex interface,
393	and IPv6 addresses as result (and maybe even other adrdess types).	441	resolves host addresses, IDNs, service names and SRV records and gives you
		442	an ordered list of socket addresses to try and should be preferred over
		443	C<inet_aton>.
		444
		445	Example.
		446
		447	inet_aton "www.google.com", my $cv = AE::cv;
		448	say unpack "H*", $_
		449	for $cv->recv;
		450	# => d155e363
		451	# => d155e367 etc.
		452
		453	inet_aton "ipv6.google.com", my $cv = AE::cv;
		454	say unpack "H*", $_
		455	for $cv->recv;
		456	# => 20014860a00300000000000000000068
394		457
395	=cut	458	=cut
396		459
397	sub inet_aton {	460	sub inet_aton {
398	my ($name, $cb) = @_;	461	my ($name, $cb) = @_;
…		…
404	} elsif ($name eq "localhost") { # rfc2606 et al.	467	} elsif ($name eq "localhost") { # rfc2606 et al.
405	$cb->(v127.0.0.1, v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.1);	468	$cb->(v127.0.0.1, v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.1);
406	} else {	469	} else {
407	require AnyEvent::DNS;	470	require AnyEvent::DNS;
408		471
409	# simple, bad suboptimal algorithm	472	my $ipv4 = $AnyEvent::PROTOCOL{ipv4};
		473	my $ipv6 = $AnyEvent::PROTOCOL{ipv6};
		474
		475	my @res;
		476
		477	my $cv = AE::cv {
		478	$cb->(map @$_, reverse @res);
		479	};
		480
		481	$cv->begin;
		482
		483	if ($ipv4) {
		484	$cv->begin;
410	AnyEvent::DNS::a ($name, sub {	485	AnyEvent::DNS::a ($name, sub {
411	if (@_) {	486	$res[$ipv4] = [map &parse_ipv4, @_];
412	$cb->(map +(parse_ipv4 $_), @_);
413	} else {
414	$cb->();	487	$cv->end;
415	#AnyEvent::DNS::aaaa ($name, $cb); need inet_pton
416	}	488	});
417	});	489	};
		490
		491	if ($ipv6) {
		492	$cv->begin;
		493	AnyEvent::DNS::aaaa ($name, sub {
		494	$res[$ipv6] = [map &parse_ipv6, @_];
		495	$cv->end;
		496	});
		497	};
		498
		499	$cv->end;
418	}	500	}
419	}	501	}
420		502
421	BEGIN {	503	BEGIN {
422	*sockaddr_family = $Socket::VERSION >= 1.75	504	*sockaddr_family = $Socket::VERSION >= 1.75
…		…
426	\| eval { Socket::pack_sockaddr_un "U" }) =~ /^\x00/	508	\| eval { Socket::pack_sockaddr_un "U" }) =~ /^\x00/
427	? sub { unpack "xC", $_[0] }	509	? sub { unpack "xC", $_[0] }
428	: sub { unpack "S" , $_[0] };	510	: sub { unpack "S" , $_[0] };
429	}	511	}
430		512
431	# check for broken platforms with extra field in sockaddr structure	513	# check for broken platforms with an extra field in sockaddr structure
432	# kind of a rfc vs. bsd issue, as usual (ok, normally it's a	514	# kind of a rfc vs. bsd issue, as usual (ok, normally it's a
433	# unix vs. bsd issue, a iso C vs. bsd issue or simply a	515	# unix vs. bsd issue, a iso C vs. bsd issue or simply a
434	# correctness vs. bsd issue.)	516	# correctness vs. bsd issue.)
435	my $pack_family = 0x55 == sockaddr_family ("\x55\x55")	517	my $pack_family = 0x55 == sockaddr_family ("\x55\x55")
436	? "xC" : "S";	518	? "xC" : "S";
…		…
439		521
440	Pack the given port/host combination into a binary sockaddr	522	Pack the given port/host combination into a binary sockaddr
441	structure. Handles both IPv4 and IPv6 host addresses, as well as UNIX	523	structure. Handles both IPv4 and IPv6 host addresses, as well as UNIX
442	domain sockets (C<$host> == C<unix/> and C<$service> == absolute	524	domain sockets (C<$host> == C<unix/> and C<$service> == absolute
443	pathname).	525	pathname).
		526
		527	Example:
		528
		529	my $bind = AnyEvent::Socket::pack_sockaddr 43, v195.234.53.120;
		530	bind $socket, $bind
		531	or die "bind: $!";
444		532
445	=cut	533	=cut
446		534
447	sub pack_sockaddr($$) {	535	sub pack_sockaddr($$) {
448	my $af = address_family $_[1];	536	my $af = address_family $_[1];
…		…
475	is a special token that is understood by the other functions in this	563	is a special token that is understood by the other functions in this
476	module (C<format_address> converts it to C<unix/>).	564	module (C<format_address> converts it to C<unix/>).
477		565
478	=cut	566	=cut
479		567
		568	# perl contains a bug (imho) where it requires that the kernel always returns
		569	# sockaddr_un structures of maximum length (which is not, AFAICS, required
		570	# by any standard). try to 0-pad structures for the benefit of those platforms.
		571
		572	my $sa_un_zero = eval { Socket::pack_sockaddr_un "" }; $sa_un_zero ^= $sa_un_zero;
		573
480	sub unpack_sockaddr($) {	574	sub unpack_sockaddr($) {
481	my $af = sockaddr_family $_[0];	575	my $af = sockaddr_family $_[0];
482		576
483	if ($af == AF_INET) {	577	if ($af == AF_INET) {
484	Socket::unpack_sockaddr_in $_[0]	578	Socket::unpack_sockaddr_in $_[0]
485	} elsif ($af == AF_INET6) {	579	} elsif ($af == AF_INET6) {
486	unpack "x2 n x4 a16", $_[0]	580	unpack "x2 n x4 a16", $_[0]
487	} elsif ($af == AF_UNIX) {	581	} elsif ($af == AF_UNIX) {
488	((Socket::unpack_sockaddr_un $_[0]), pack "S", AF_UNIX)	582	((Socket::unpack_sockaddr_un $_[0] ^ $sa_un_zero), pack "S", AF_UNIX)
489	} else {	583	} else {
490	Carp::croak "unpack_sockaddr: unsupported protocol family $af";	584	Carp::croak "unpack_sockaddr: unsupported protocol family $af";
491	}	585	}
492	}	586	}
493		587
…		…
496	Tries to resolve the given nodename and service name into protocol families	590	Tries to resolve the given nodename and service name into protocol families
497	and sockaddr structures usable to connect to this node and service in a	591	and sockaddr structures usable to connect to this node and service in a
498	protocol-independent way. It works remotely similar to the getaddrinfo	592	protocol-independent way. It works remotely similar to the getaddrinfo
499	posix function.	593	posix function.
500		594
501	For internet addresses, C<$node> is either an IPv4 or IPv6 address or an	595	For internet addresses, C<$node> is either an IPv4 or IPv6 address, an
502	internet hostname, and C<$service> is either a service name (port name	596	internet hostname (DNS domain name or IDN), and C<$service> is either
503	from F</etc/services>) or a numerical port number. If both C<$node> and	597	a service name (port name from F</etc/services>) or a numerical port
504	C<$service> are names, then SRV records will be consulted to find the real	598	number. If both C<$node> and C<$service> are names, then SRV records
505	service, otherwise they will be used as-is. If you know that the service	599	will be consulted to find the real service, otherwise they will be
506	name is not in your services database, then you can specify the service in	600	used as-is. If you know that the service name is not in your services
507	the format C<name=port> (e.g. C<http=80>).	601	database, then you can specify the service in the format C<name=port>
		602	(e.g. C<http=80>).
508		603
509	For UNIX domain sockets, C<$node> must be the string C<unix/> and	604	For UNIX domain sockets, C<$node> must be the string C<unix/> and
510	C<$service> must be the absolute pathname of the socket. In this case,	605	C<$service> must be the absolute pathname of the socket. In this case,
511	C<$proto> will be ignored.	606	C<$proto> will be ignored.
512		607
…		…
558	$family \|\|= 6 unless $AnyEvent::PROTOCOL{ipv4};	653	$family \|\|= 6 unless $AnyEvent::PROTOCOL{ipv4};
559		654
560	$proto \|\|= "tcp";	655	$proto \|\|= "tcp";
561	$type \|\|= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM;	656	$type \|\|= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM;
562		657
563	my $proton = getprotobyname $proto	658	my $proton = AnyEvent::Socket::getprotobyname $proto
564	or Carp::croak "$proto: protocol unknown";	659	or Carp::croak "$proto: protocol unknown";
565		660
566	my $port;	661	my $port;
567		662
568	if ($service =~ /^(\S+)=(\d+)$/) {	663	if ($service =~ /^(\S+)=(\d+)$/) {
…		…
572	} else {	667	} else {
573	$port = (getservbyname $service, $proto)[2]	668	$port = (getservbyname $service, $proto)[2]
574	or Carp::croak "$service/$proto: service unknown";	669	or Carp::croak "$service/$proto: service unknown";
575	}	670	}
576		671
577	my @target = [$node, $port];
578
579	# resolve a records / provide sockaddr structures	672	# resolve a records / provide sockaddr structures
580	my $resolve = sub {	673	my $resolve = sub {
		674	my @target = @_;
		675
581	my @res;	676	my @res;
582	my $cv = AnyEvent->condvar (cb => sub {	677	my $cv = AE::cv {
583	$cb->(	678	$cb->(
584	map $_->[2],	679	map $_->[2],
585	sort {	680	sort {
586	$AnyEvent::PROTOCOL{$b->[1]} <=> $AnyEvent::PROTOCOL{$a->[1]}	681	$AnyEvent::PROTOCOL{$b->[1]} <=> $AnyEvent::PROTOCOL{$a->[1]}
587	or $a->[0] <=> $b->[0]	682	or $a->[0] <=> $b->[0]
588	}	683	}
589	@res	684	@res
590	)	685	)
591	});	686	};
592		687
593	$cv->begin;	688	$cv->begin;
594	for my $idx (0 .. $#target) {	689	for my $idx (0 .. $#target) {
595	my ($node, $port) = @{ $target[$idx] };	690	my ($node, $port) = @{ $target[$idx] };
596		691
…		…
631	}	726	}
632	}	727	}
633	$cv->end;	728	$cv->end;
634	};	729	};
635		730
		731	$node = AnyEvent::Util::idn_to_ascii $node
		732	if $node =~ /[^\x00-\x7f]/;
		733
636	# try srv records, if applicable	734	# try srv records, if applicable
637	if ($node eq "localhost") {	735	if ($node eq "localhost") {
638	@target = (["127.0.0.1", $port], ["::1", $port]);	736	$resolve->(["127.0.0.1", $port], ["::1", $port]);
639	&$resolve;
640	} elsif (defined $service && !parse_address $node) {	737	} elsif (defined $service && !parse_address $node) {
641	AnyEvent::DNS::srv $service, $proto, $node, sub {	738	AnyEvent::DNS::srv $service, $proto, $node, sub {
642	my (@srv) = @_;	739	my (@srv) = @_;
643		740
644	# no srv records, continue traditionally
645	@srv	741	if (@srv) {
646	or return &$resolve;
647
648	# the only srv record has "." ("" here) => abort	742	# the only srv record has "." ("" here) => abort
649	$srv[0][2] ne "" \|\| $#srv	743	$srv[0][2] ne "" \|\| $#srv
650	or return $cb->();	744	or return $cb->();
651		745
652	# use srv records then	746	# use srv records then
		747	$resolve->(
653	@target = map ["$_->[3].", $_->[2]],	748	map ["$_->[3].", $_->[2]],
654	grep $_->[3] ne ".",	749	grep $_->[3] ne ".",
655	@srv;	750	@srv
656		751	);
657	&$resolve;	752	} else {
		753	# no srv records, continue traditionally
		754	$resolve->([$node, $port]);
		755	}
658	};	756	};
659	} else {	757	} else {
660	&$resolve;	758	# most common case
		759	$resolve->([$node, $port]);
661	}	760	}
662	}	761	}
663		762
664	=item $guard = tcp_connect $host, $service, $connect_cb[, $prepare_cb]	763	=item $guard = tcp_connect $host, $service, $connect_cb[, $prepare_cb]
665		764
666	This is a convenience function that creates a TCP socket and makes a 100%	765	This is a convenience function that creates a TCP socket and makes a
667	non-blocking connect to the given C<$host> (which can be a hostname or	766	100% non-blocking connect to the given C<$host> (which can be a DNS/IDN
668	a textual IP address, or the string C<unix/> for UNIX domain sockets)	767	hostname or a textual IP address, or the string C<unix/> for UNIX domain
669	and C<$service> (which can be a numeric port number or a service name,	768	sockets) and C<$service> (which can be a numeric port number or a service
670	or a C<servicename=portnumber> string, or the pathname to a UNIX domain	769	name, or a C<servicename=portnumber> string, or the pathname to a UNIX
671	socket).	770	domain socket).
672		771
673	If both C<$host> and C<$port> are names, then this function will use SRV	772	If both C<$host> and C<$port> are names, then this function will use SRV
674	records to locate the real target(s).	773	records to locate the real target(s).
675		774
676	In either case, it will create a list of target hosts (e.g. for multihomed	775	In either case, it will create a list of target hosts (e.g. for multihomed
677	hosts or hosts with both IPv4 and IPv6 addresses) and try to connect to	776	hosts or hosts with both IPv4 and IPv6 addresses) and try to connect to
678	each in turn.	777	each in turn.
679		778
680	If the connect is successful, then the C<$connect_cb> will be invoked with	779	After the connection is established, then the C<$connect_cb> will be
681	the socket file handle (in non-blocking mode) as first and the peer host	780	invoked with the socket file handle (in non-blocking mode) as first and
682	(as a textual IP address) and peer port as second and third arguments,	781	the peer host (as a textual IP address) and peer port as second and third
683	respectively. The fourth argument is a code reference that you can call	782	arguments, respectively. The fourth argument is a code reference that you
684	if, for some reason, you don't like this connection, which will cause	783	can call if, for some reason, you don't like this connection, which will
685	C<tcp_connect> to try the next one (or call your callback without any	784	cause C<tcp_connect> to try the next one (or call your callback without
686	arguments if there are no more connections). In most cases, you can simply	785	any arguments if there are no more connections). In most cases, you can
687	ignore this argument.	786	simply ignore this argument.
688		787
689	$cb->($filehandle, $host, $port, $retry)	788	$cb->($filehandle, $host, $port, $retry)
690		789
691	If the connect is unsuccessful, then the C<$connect_cb> will be invoked	790	If the connect is unsuccessful, then the C<$connect_cb> will be invoked
692	without any arguments and C<$!> will be set appropriately (with C<ENXIO>	791	without any arguments and C<$!> will be set appropriately (with C<ENXIO>
693	indicating a DNS resolution failure).	792	indicating a DNS resolution failure).
694		793
		794	The callback will I<never> be invoked before C<tcp_connect> returns, even
		795	if C<tcp_connect> was able to connect immediately (e.g. on unix domain
		796	sockets).
		797
695	The file handle is perfect for being plugged into L<AnyEvent::Handle>, but	798	The file handle is perfect for being plugged into L<AnyEvent::Handle>, but
696	can be used as a normal perl file handle as well.	799	can be used as a normal perl file handle as well.
697		800
698	Unless called in void context, C<tcp_connect> returns a guard object that	801	Unless called in void context, C<tcp_connect> returns a guard object that
699	will automatically abort connecting when it gets destroyed (it does not do	802	will automatically cancel the connection attempt when it gets destroyed
		803	- in which case the callback will not be invoked. Destroying it does not
700	anything to the socket after the connect was successful).	804	do anything to the socket after the connect was successful - you cannot
		805	"uncall" a callback that has been invoked already.
701		806
702	Sometimes you need to "prepare" the socket before connecting, for example,	807	Sometimes you need to "prepare" the socket before connecting, for example,
703	to C<bind> it to some port, or you want a specific connect timeout that	808	to C<bind> it to some port, or you want a specific connect timeout that
704	is lower than your kernel's default timeout. In this case you can specify	809	is lower than your kernel's default timeout. In this case you can specify
705	a second callback, C<$prepare_cb>. It will be called with the file handle	810	a second callback, C<$prepare_cb>. It will be called with the file handle
…		…
748	warn "done.\n";	853	warn "done.\n";
749	};	854	};
750		855
751	$handle->push_write ("GET / HTTP/1.0\015\012\015\012");	856	$handle->push_write ("GET / HTTP/1.0\015\012\015\012");
752		857
753	$handle->push_read_line ("\015\012\015\012", sub {	858	$handle->push_read (line => "\015\012\015\012", sub {
754	my ($handle, $line) = @_;	859	my ($handle, $line) = @_;
755		860
756	# print response header	861	# print response header
757	print "HEADER\n$line\n\nBODY\n";	862	print "HEADER\n$line\n\nBODY\n";
758		863
…		…
778	=cut	883	=cut
779		884
780	sub tcp_connect($$$;$) {	885	sub tcp_connect($$$;$) {
781	my ($host, $port, $connect, $prepare) = @_;	886	my ($host, $port, $connect, $prepare) = @_;
782		887
783	# see http://cr.yp.to/docs/connect.html for some background	888	# see http://cr.yp.to/docs/connect.html for some tricky aspects
784	# also http://advogato.org/article/672.html	889	# also http://advogato.org/article/672.html
785		890
786	my %state = ( fh => undef );	891	my %state = ( fh => undef );
787		892
788	# name/service to type/sockaddr resolution	893	# name/service to type/sockaddr resolution
…		…
791		896
792	$state{next} = sub {	897	$state{next} = sub {
793	return unless exists $state{fh};	898	return unless exists $state{fh};
794		899
795	my $target = shift @target	900	my $target = shift @target
796	or return (%state = (), $connect->());	901	or return _postpone sub {
		902	return unless exists $state{fh};
		903	%state = ();
		904	$connect->();
		905	};
797		906
798	my ($domain, $type, $proto, $sockaddr) = @$target;	907	my ($domain, $type, $proto, $sockaddr) = @$target;
799		908
800	# socket creation	909	# socket creation
801	socket $state{fh}, $domain, $type, $proto	910	socket $state{fh}, $domain, $type, $proto
…		…
805		914
806	my $timeout = $prepare && $prepare->($state{fh});	915	my $timeout = $prepare && $prepare->($state{fh});
807		916
808	$timeout \|\|= 30 if AnyEvent::WIN32;	917	$timeout \|\|= 30 if AnyEvent::WIN32;
809		918
810	$state{to} = AnyEvent->timer (after => $timeout, cb => sub {	919	$state{to} = AE::timer $timeout, 0, sub {
811	$! = Errno::ETIMEDOUT;	920	$! = Errno::ETIMEDOUT;
812	$state{next}();	921	$state{next}();
813	}) if $timeout;	922	} if $timeout;
814		923
815	# called when the connect was successful, which,	924	# now connect
816	# in theory, could be the case immediately (but never is in practise)	925	if (
817	$state{connected} = sub {	926	(connect $state{fh}, $sockaddr)
		927	\|\| ($! == Errno::EINPROGRESS # POSIX
		928	\|\| $! == Errno::EWOULDBLOCK
		929	# WSAEINPROGRESS intentionally not checked - it means something else entirely
		930	\|\| $! == AnyEvent::Util::WSAEINVAL # not convinced, but doesn't hurt
		931	\|\| $! == AnyEvent::Util::WSAEWOULDBLOCK)
		932	) {
		933	$state{ww} = AE::io $state{fh}, 1, sub {
818	# we are connected, or maybe there was an error	934	# we are connected, or maybe there was an error
819	if (my $sin = getpeername $state{fh}) {	935	if (my $sin = getpeername $state{fh}) {
820	my ($port, $host) = unpack_sockaddr $sin;	936	my ($port, $host) = unpack_sockaddr $sin;
821		937
822	delete $state{ww}; delete $state{to};	938	delete $state{ww}; delete $state{to};
823		939
824	my $guard = guard { %state = () };	940	my $guard = guard { %state = () };
825		941
826	$connect->(delete $state{fh}, format_address $host, $port, sub {	942	$connect->(delete $state{fh}, format_address $host, $port, sub {
827	$guard->cancel;	943	$guard->cancel;
		944	$state{next}();
		945	});
		946	} else {
		947	if ($! == Errno::ENOTCONN) {
		948	# dummy read to fetch real error code if !cygwin
		949	sysread $state{fh}, my $buf, 1;
		950
		951	# cygwin 1.5 continously reports "ready' but never delivers
		952	# an error with getpeername or sysread.
		953	# cygwin 1.7 only reports readyness once, but is otherwise
		954	# the same, which is atcually more broken.
		955	# Work around both by using unportable SO_ERROR for cygwin.
		956	$! = (unpack "l", getsockopt $state{fh}, Socket::SOL_SOCKET(), Socket::SO_ERROR()) \|\| Errno::EAGAIN
		957	if AnyEvent::CYGWIN && $! == Errno::EAGAIN;
		958	}
		959
		960	return if $! == Errno::EAGAIN; # skip spurious wake-ups
		961
		962	delete $state{ww}; delete $state{to};
		963
828	$state{next}();	964	$state{next}();
829	});	965	}
830	} else {
831	# dummy read to fetch real error code
832	sysread $state{fh}, my $buf, 1 if $! == Errno::ENOTCONN;
833
834	return if $! == Errno::EAGAIN; # skip spurious wake-ups
835
836	delete $state{ww}; delete $state{to};
837
838	$state{next}();
839	}	966	};
840	};
841
842	# now connect
843	if (connect $state{fh}, $sockaddr) {
844	$state{connected}->();
845	} elsif ($! == Errno::EINPROGRESS # POSIX
846	\|\| $! == Errno::EWOULDBLOCK
847	# WSAEINPROGRESS intentionally not checked - it means something else entirely
848	\|\| $! == AnyEvent::Util::WSAEINVAL # not convinced, but doesn't hurt
849	\|\| $! == AnyEvent::Util::WSAEWOULDBLOCK) {
850	$state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $state{connected});
851	} else {	967	} else {
852	$state{next}();	968	$state{next}();
853	}	969	}
854	};	970	};
855		971
…		…
979	$len \|\|= 128;	1095	$len \|\|= 128;
980		1096
981	listen $state{fh}, $len	1097	listen $state{fh}, $len
982	or Carp::croak "listen: $!";	1098	or Carp::croak "listen: $!";
983		1099
984	$state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub {	1100	$state{aw} = AE::io $state{fh}, 0, sub {
985	# this closure keeps $state alive	1101	# this closure keeps $state alive
986	while (my $peer = accept my $fh, $state{fh}) {	1102	while ($state{fh} && (my $peer = accept my $fh, $state{fh})) {
987	fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not	1103	fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not
988		1104
989	my ($service, $host) = unpack_sockaddr $peer;	1105	my ($service, $host) = unpack_sockaddr $peer;
990	$accept->($fh, format_address $host, $service);	1106	$accept->($fh, format_address $host, $service);
991	}	1107	}
992	});	1108	};
993		1109
994	defined wantarray	1110	defined wantarray
995	? guard { %state = () } # clear fh and watcher, which breaks the circular dependency	1111	? guard { %state = () } # clear fh and watcher, which breaks the circular dependency
996	: ()	1112	: ()
		1113	}
		1114
		1115	=item tcp_nodelay $fh, $enable
		1116
		1117	Enables (or disables) the C<TCP_NODELAY> socket option (also known as
		1118	Nagle's algorithm). Returns false on error, true otherwise.
		1119
		1120	=cut
		1121
		1122	sub tcp_nodelay($$) {
		1123	my $onoff = int ! ! $_[1];
		1124
		1125	setsockopt $_[0], Socket::IPPROTO_TCP (), Socket::TCP_NODELAY (), $onoff
		1126	}
		1127
		1128	=item tcp_congestion $fh, $algorithm
		1129
		1130	Sets the tcp congestion algorithm (via the C<TCP_CONGESTION>. The default is OS-specific, but usually
		1131	C<reno>. Typical other available choices include C<cubic>, C<reno>,
		1132	C<lp>, C<bic>, C<highspeed>, C<htcp>, C<hybla>, C<illinois>, C<scalable>,
		1133	C<vegas>, C<veno>, C<westwood> and C<yeah>.
		1134
		1135	=cut
		1136
		1137	sub tcp_congestion($$) {
		1138	defined AnyEvent::Util::TCP_CONGESTION
		1139	? setsockopt $_[0], Socket::IPPROTO_TCP (), AnyEvent::Util::TCP_CONGESTION, "$_[1]"
		1140	: undef
997	}	1141	}
998		1142
999	1;	1143	1;
1000		1144
1001	=back	1145	=back

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents): Revision 1.102 by root, Thu Jul 30 16:39:19 2009 UTC vs. Revision 1.125 by root, Mon Oct 11 03:41:39 2010 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.102 by root, Thu Jul 30 16:39:19 2009 UTC vs.
Revision 1.125 by root, Mon Oct 11 03:41:39 2010 UTC