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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.13 by root, Fri May 23 22:52:31 2008 UTC vs.
Revision 1.57 by root, Sat Jul 19 22:10:47 2008 UTC

…		…
2		2
3	AnyEvent::Socket - useful IPv4 and IPv6 stuff.	3	AnyEvent::Socket - useful IPv4 and IPv6 stuff.
4		4
5	=head1 SYNOPSIS	5	=head1 SYNOPSIS
6		6
7	use AnyEvent::Socket;	7	use AnyEvent::Socket;
		8
		9	tcp_connect "gameserver.deliantra.net", 13327, sub {
		10	my ($fh) = @_
		11	or die "gameserver.deliantra.net connect failed: $!";
		12
		13	# enjoy your filehandle
		14	};
		15
		16	# a simple tcp server
		17	tcp_server undef, 8888, sub {
		18	my ($fh, $host, $port) = @_;
		19
		20	syswrite $fh, "The internet is full, $host:$port. Go away!\015\012";
		21	};
8		22
9	=head1 DESCRIPTION	23	=head1 DESCRIPTION
10		24
11	This module implements various utility functions for handling internet	25	This module implements various utility functions for handling internet
12	protocol addresses and sockets, in an as transparent and simple way as	26	protocol addresses and sockets, in an as transparent and simple way as
…		…
24	no warnings;	38	no warnings;
25	use strict;	39	use strict;
26		40
27	use Carp ();	41	use Carp ();
28	use Errno ();	42	use Errno ();
29	use Socket ();	43	use Socket qw(AF_INET AF_UNIX SOCK_STREAM SOCK_DGRAM SOL_SOCKET SO_REUSEADDR);
30		44
31	use AnyEvent ();	45	use AnyEvent ();
32	use AnyEvent::Util qw(guard fh_nonblocking);	46	use AnyEvent::Util qw(guard fh_nonblocking AF_INET6);
		47	use AnyEvent::DNS ();
33		48
34	use base 'Exporter';	49	use base 'Exporter';
35		50
36	BEGIN {	51	our @EXPORT = qw(
37	*socket_inet_aton = \&Socket::inet_aton; # take a copy, in case Coro::LWP overrides it	52	parse_hostport
38	}	53	parse_ipv4 parse_ipv6
		54	parse_ip parse_address
		55	format_ip format_address
		56	address_family
		57	inet_aton
		58	tcp_server
		59	tcp_connect
		60	);
39		61
40	our @EXPORT = qw(parse_ipv4 parse_ipv6 parse_ip format_ip inet_aton tcp_server tcp_connect);
41
42	our $VERSION = '1.0';	62	our $VERSION = 4.22;
43		63
44	=item $ipn = parse_ipv4 $dotted_quad	64	=item $ipn = parse_ipv4 $dotted_quad
45		65
46	Tries to parse the given dotted quad IPv4 address and return it in	66	Tries to parse the given dotted quad IPv4 address and return it in
47	octet form (or undef when it isn't in a parsable format). Supports all	67	octet form (or undef when it isn't in a parsable format). Supports all
…		…
59		79
60	# check leading parts against range	80	# check leading parts against range
61	return undef if grep $_ >= 256, @_[0 .. @_ - 2];	81	return undef if grep $_ >= 256, @_[0 .. @_ - 2];
62		82
63	# check trailing part against range	83	# check trailing part against range
64	return undef if $_[-1] >= 1 << (8 * (4 - $#_));	84	return undef if $_[-1] >= 2 ** (8 * (4 - $#_));
65		85
66	pack "N", (pop)	86	pack "N", (pop)
67	+ ($_[0] << 24)	87	+ ($_[0] << 24)
68	+ ($_[1] << 16)	88	+ ($_[1] << 16)
69	+ ($_[2] << 8);	89	+ ($_[2] << 8);
70	}	90	}
71		91
72	=item $ipn = parse_ipv4 $dotted_quad	92	=item $ipn = parse_ipv6 $textual_ipv6_address
73		93
74	Tries to parse the given IPv6 address and return it in	94	Tries to parse the given IPv6 address and return it in
75	octet form (or undef when it isn't in a parsable format).	95	octet form (or undef when it isn't in a parsable format).
76		96
77	Should support all forms specified by RFC 2373 (and additionally all IPv4	97	Should support all forms specified by RFC 2373 (and additionally all IPv4
78	forms supported by parse_ipv4).	98	forms supported by parse_ipv4). Note that scope-id's are not supported
		99	(and will not parse).
79		100
80	This function works similarly to C<inet_pton AF_INET6, ...>.	101	This function works similarly to C<inet_pton AF_INET6, ...>.
81		102
82	=cut	103	=cut
83		104
…		…
93	}	114	}
94		115
95	my @h = split /:/, $h;	116	my @h = split /:/, $h;
96	my @t = split /:/, $t;	117	my @t = split /:/, $t;
97		118
98	# check four ipv4 tail	119	# check for ipv4 tail
99	if (@t && $t[-1]=~ /\./) {	120	if (@t && $t[-1]=~ /\./) {
100	return undef if $n > 6;	121	return undef if $n > 6;
101		122
102	my $ipn = parse_ipv4 pop @t	123	my $ipn = parse_ipv4 pop @t
103	or return undef;	124	or return undef;
…		…
116		137
117	# and done	138	# and done
118	pack "n*", map hex, @h, @t	139	pack "n*", map hex, @h, @t
119	}	140	}
120		141
		142	sub parse_unix($) {
		143	$_[0] eq "unix/"
		144	? pack "S", AF_UNIX
		145	: undef
		146
		147	}
		148
121	=item $ipn = parse_ip $text	149	=item $ipn = parse_address $text
122		150
123	Combines C<parse_ipv4> and C<parse_ipv6> in one function.	151	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
		153	(binary).
124		154
125	=cut	155	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
		157	socket".
126		158
		159	=cut
		160
127	sub parse_ip($) {	161	sub parse_address($) {
128	&parse_ipv4 \|\| &parse_ipv6	162	&parse_ipv4 \|\| &parse_ipv6 \|\| &parse_unix
129	}	163	}
130		164
		165	*parse_ip =\&parse_address; #d#
		166
		167	=item ($host, $service) = parse_hostport $string[, $default_service]
		168
		169	Splitting a string of the form C<hostname:port> is a common
		170	problem. Unfortunately, just splitting on the colon makes it hard to
		171	specify IPv6 addresses and doesn't support the less common but well
		172	standardised C<[ip literal]> syntax.
		173
		174	This function tries to do this job in a better way, it supports the
		175	following formats, where C<port> can be a numerical port number of a
		176	service name, or a C<name=port> string, and the C< port> and C<:port>
		177	parts are optional. Also, everywhere where an IP address is supported
		178	a hostname or unix domain socket address is also supported (see
		179	C<parse_unix>).
		180
		181	hostname:port e.g. "www.linux.org", "www.x.de:443", "www.x.de:https=443"
		182	ipv4:port e.g. "198.182.196.56", "127.1:22"
		183	ipv6 e.g. "::1", "affe::1"
		184	[ipv4or6]:port e.g. "[::1]", "[10.0.1]:80"
		185	[ipv4or6] port e.g. "[127.0.0.1]", "[www.x.org] 17"
		186	ipv4or6 port e.g. "::1 443", "10.0.0.1 smtp"
		187
		188	It also supports defaulting the service name in a simple way by using
		189	C<$default_service> if no service was detected. If neither a service was
		190	detected nor a default was specified, then this function returns the
		191	empty list. The same happens when a parse error weas detected, such as a
		192	hostname with a colon in it (the function is rather conservative, though).
		193
		194	Example:
		195
		196	print join ",", parse_hostport "localhost:443";
		197	# => "localhost,443"
		198
		199	print join ",", parse_hostport "localhost", "https";
		200	# => "localhost,https"
		201
		202	print join ",", parse_hostport "[::1]";
		203	# => "," (empty list)
		204
		205	=cut
		206
		207	sub parse_hostport($;$) {
		208	my ($host, $port);
		209
		210	for ("$_[0]") { # work on a copy, just in case, and also reset pos
		211
		212	# parse host, special cases: "ipv6" or "ipv6 port"
		213	unless (
		214	($host) = /^\s* ([0-9a-fA-F:]:[0-9a-fA-F:]:[0-9a-fA-F\.:]*)/xgc
		215	and parse_ipv6 $host
		216	) {
		217	/^\s*/xgc;
		218
		219	if (/^ \[ ([^\[\]]+) \]/xgc) {
		220	$host = $1;
		221	} elsif (/^ ([^\[\]:\ ]+) /xgc) {
		222	$host = $1;
		223	} else {
		224	return;
		225	}
		226	}
		227
		228	# parse port
		229	if (/\G (?:\s+\|:) ([^:[:space:]]+) \s*$/xgc) {
		230	$port = $1;
		231	} elsif (/\G\s*$/gc && length $_[1]) {
		232	$port = $_[1];
		233	} else {
		234	return;
		235	}
		236	}
		237
		238	# hostnames must not contain :'s
		239	return if $host =~ /:/ && !parse_ipv6 $host;
		240
		241	($host, $port)
		242	}
		243
		244	=item $sa_family = address_family $ipn
		245
		246	Returns the address family/protocol-family (AF_xxx/PF_xxx, in one value :)
		247	of the given host address in network format.
		248
		249	=cut
		250
		251	sub address_family($) {
		252	4 == length $_[0]
		253	? AF_INET
		254	: 16 == length $_[0]
		255	? AF_INET6
		256	: unpack "S", $_[0]
		257	}
		258
131	=item $text = format_ip $ipn	259	=item $text = format_address $ipn
132		260
133	Takes either an IPv4 address (4 octets) or and IPv6 address (16 octets)	261	Covnvert a host address in network format (e.g. 4 octets for IPv4 or 16
134	and converts it into textual form.	262	octets for IPv6) and convert it into textual form.
		263
		264	Returns C<unix/> for UNIX domain sockets.
135		265
136	This function works similarly to C<inet_ntop AF_INET \|\| AF_INET6, ...>,	266	This function works similarly to C<inet_ntop AF_INET \|\| AF_INET6, ...>,
137	except it automatically detects the address type.	267	except it automatically detects the address type.
138		268
139	=cut	269	Returns C<undef> if it cannot detect the type.
140		270
141	sub format_ip;	271	=cut
		272
		273	sub format_address;
142	sub format_ip($) {	274	sub format_address($) {
143	if (4 == length $_[0]) {	275	my $af = address_family $_[0];
		276	if ($af == AF_INET) {
144	return join ".", unpack "C4", $_[0]	277	return join ".", unpack "C4", $_[0]
145	} elsif (16 == length $_[0]) {	278	} elsif ($af == AF_INET6) {
		279	if (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0 eq $_[0]) {
		280	return "::";
		281	} elsif (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.1 eq $_[0]) {
		282	return "::1";
		283	} elsif (v0.0.0.0.0.0.0.0.0.0.0.0 eq substr $_[0], 0, 12) {
		284	# v4compatible
		285	return "::" . format_address substr $_[0], 12;
146	if (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12) {	286	} elsif (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12) {
147	# v4mapped	287	# v4mapped
148	return "::ffff:" . format_ip substr $_[0], 12;	288	return "::ffff:" . format_address substr $_[0], 12;
		289	} elsif (v0.0.0.0.0.0.0.0.255.255.0.0 eq substr $_[0], 0, 12) {
		290	# v4translated
		291	return "::ffff:0:" . format_address substr $_[0], 12;
149	} else {	292	} else {
150	my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0];	293	my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0];
151		294
		295	# this is rather sucky, I admit
152	$ip =~ s/^0:(?:0:)*/::/	296	$ip =~ s/^0:(?:0:)*(0$)?/::/
153	or $ip =~ s/(:0)+$/::/	297	or $ip =~ s/(:0){7}$/::/ or $ip =~ s/(:0){7}/:/
154	or $ip =~ s/(:0)+/:/;	298	or $ip =~ s/(:0){6}$/::/ or $ip =~ s/(:0){6}/:/
		299	or $ip =~ s/(:0){5}$/::/ or $ip =~ s/(:0){5}/:/
		300	or $ip =~ s/(:0){4}$/::/ or $ip =~ s/(:0){4}/:/
		301	or $ip =~ s/(:0){3}$/::/ or $ip =~ s/(:0){3}/:/
		302	or $ip =~ s/(:0){2}$/::/ or $ip =~ s/(:0){2}/:/
		303	or $ip =~ s/(:0){1}$/::/ or $ip =~ s/(:0){1}/:/;
155	return $ip	304	return $ip
156	}	305	}
		306	} elsif ($af == AF_UNIX) {
		307	return "unix/"
157	} else {	308	} else {
158	return undef	309	return undef
159	}	310	}
160	}	311	}
		312
		313	*format_ip = \&format_address;
161		314
162	=item inet_aton $name_or_address, $cb->(@addresses)	315	=item inet_aton $name_or_address, $cb->(@addresses)
163		316
164	Works similarly to its Socket counterpart, except that it uses a	317	Works similarly to its Socket counterpart, except that it uses a
165	callback. Also, if a host has only an IPv6 address, this might be passed	318	callback. Also, if a host has only an IPv6 address, this might be passed
166	to the callback instead (use the length to detect this - 4 for IPv4, 16	319	to the callback instead (use the length to detect this - 4 for IPv4, 16
167	for IPv6).	320	for IPv6).
168		321
169	Unlike the L<Socket> function of the same name, you can get multiple IPv4	322	Unlike the L<Socket> function of the same name, you can get multiple IPv4
170	and IPv6 addresses as result.	323	and IPv6 addresses as result (and maybe even other adrdess types).
171		324
172	=cut	325	=cut
173		326
174	sub inet_aton {	327	sub inet_aton {
175	my ($name, $cb) = @_;	328	my ($name, $cb) = @_;
…		…
193	}	346	}
194	});	347	});
195	}	348	}
196	}	349	}
197		350
198	sub _tcp_port($) {	351	# check for broken platforms with extra field in sockaddr structure
199	$_[0] =~ /^(\d)$/ and return $11;	352	# kind of a rfc vs. bsd issue, as usual (ok, normally it's a
		353	# unix vs. bsd issue, a iso C vs. bsd issue or simply a
		354	# correctness vs. bsd issue.
		355	my $pack_family = (0x55 == Socket::sockaddr_family "\x55\x55")
		356	? "xC" : "S";
200		357
201	(getservbyname $_[0], "tcp")[2]	358	=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host
		359
		360	Pack the given port/host combination into a binary sockaddr
		361	structure. Handles both IPv4 and IPv6 host addresses, as well as UNIX
		362	domain sockets (C<$host> == C<unix/> and C<$service> == absolute
		363	pathname).
		364
		365	=cut
		366
		367	sub pack_sockaddr($$) {
		368	my $af = address_family $_[1];
		369
		370	if ($af == AF_INET) {
		371	Socket::pack_sockaddr_in $_[0], $_[1]
		372	} elsif ($af == AF_INET6) {
		373	pack "$pack_family nL a16 L",
		374	AF_INET6,
		375	$_[0], # port
		376	0, # flowinfo
		377	$_[1], # addr
		378	0 # scope id
		379	} elsif ($af == AF_UNIX) {
		380	Socket::pack_sockaddr_un $_[0]
		381	} else {
		382	Carp::croak "pack_sockaddr: invalid host";
		383	}
		384	}
		385
		386	=item ($service, $host) = AnyEvent::Socket::unpack_sockaddr $sa
		387
		388	Unpack the given binary sockaddr structure (as used by bind, getpeername
		389	etc.) into a C<$service, $host> combination.
		390
		391	For IPv4 and IPv6, C<$service> is the port number and C<$host> the host
		392	address in network format (binary).
		393
		394	For UNIX domain sockets, C<$service> is the absolute pathname and C<$host>
		395	is a special token that is understood by the other functions in this
		396	module (C<format_address> converts it to C<unix/>).
		397
		398	=cut
		399
		400	sub unpack_sockaddr($) {
		401	my $af = Socket::sockaddr_family $_[0];
		402
		403	if ($af == AF_INET) {
		404	Socket::unpack_sockaddr_in $_[0]
		405	} elsif ($af == AF_INET6) {
		406	unpack "x2 n x4 a16", $_[0]
		407	} elsif ($af == AF_UNIX) {
		408	((Socket::unpack_sockaddr_un $_[0]), pack "S", AF_UNIX)
		409	} else {
		410	Carp::croak "unpack_sockaddr: unsupported protocol family $af";
		411	}
		412	}
		413
		414	=item resolve_sockaddr $node, $service, $proto, $family, $type, $cb->([$family, $type, $proto, $sockaddr], ...)
		415
		416	Tries to resolve the given nodename and service name into protocol families
		417	and sockaddr structures usable to connect to this node and service in a
		418	protocol-independent way. It works remotely similar to the getaddrinfo
		419	posix function.
		420
		421	For internet addresses, C<$node> is either an IPv4 or IPv6 address or an
		422	internet hostname, and C<$service> is either a service name (port name
		423	from F</etc/services>) or a numerical port number. If both C<$node> and
		424	C<$service> are names, then SRV records will be consulted to find the real
		425	service, otherwise they will be used as-is. If you know that the service
		426	name is not in your services database, then you can specify the service in
		427	the format C<name=port> (e.g. C<http=80>).
		428
		429	For UNIX domain sockets, C<$node> must be the string C<unix/> and
		430	C<$service> must be the absolute pathname of the socket. In this case,
		431	C<$proto> will be ignored.
		432
		433	C<$proto> must be a protocol name, currently C<tcp>, C<udp> or
		434	C<sctp>. The default is currently C<tcp>, but in the future, this function
		435	might try to use other protocols such as C<sctp>, depending on the socket
		436	type and any SRV records it might find.
		437
		438	C<$family> must be either C<0> (meaning any protocol is OK), C<4> (use
		439	only IPv4) or C<6> (use only IPv6). This setting might be influenced by
		440	C<$ENV{PERL_ANYEVENT_PROTOCOLS}>.
		441
		442	C<$type> must be C<SOCK_STREAM>, C<SOCK_DGRAM> or C<SOCK_SEQPACKET> (or
		443	C<undef> in which case it gets automatically chosen).
		444
		445	The callback will receive zero or more array references that contain
		446	C<$family, $type, $proto> for use in C<socket> and a binary
		447	C<$sockaddr> for use in C<connect> (or C<bind>).
		448
		449	The application should try these in the order given.
		450
		451	Example:
		452
		453	resolve_sockaddr "google.com", "http", 0, undef, undef, sub { ... };
		454
		455	=cut
		456
		457	# microsoft can't even get getprotobyname working (the etc/protocols file
		458	# gets lost fairly often on windows), so we have to hardcode some common
		459	# protocol numbers ourselves.
		460	our %PROTO_BYNAME;
		461
		462	$PROTO_BYNAME{tcp} = &Socket::IPPROTO_TCP if defined &Socket::IPPROTO_TCP;
		463	$PROTO_BYNAME{udp} = &Socket::IPPROTO_UDP if defined &Socket::IPPROTO_UDP;
		464	$PROTO_BYNAME{icmp} = &Socket::IPPROTO_ICMP if defined &Socket::IPPROTO_ICMP;
		465
		466	sub resolve_sockaddr($$$$$$) {
		467	my ($node, $service, $proto, $family, $type, $cb) = @_;
		468
		469	if ($node eq "unix/") {
		470	return $cb->() if $family \|\| !/^\//; # no can do
		471
		472	return $cb->([AF_UNIX, $type, 0, Socket::pack_sockaddr_un $service]);
		473	}
		474
		475	unless (AF_INET6) {
		476	$family != 6
		477	or return $cb->();
		478
		479	$family = 4;
		480	}
		481
		482	$cb->() if $family == 4 && !$AnyEvent::PROTOCOL{ipv4};
		483	$cb->() if $family == 6 && !$AnyEvent::PROTOCOL{ipv6};
		484
		485	$family \|\|= 4 unless $AnyEvent::PROTOCOL{ipv6};
		486	$family \|\|= 6 unless $AnyEvent::PROTOCOL{ipv4};
		487
		488	$proto \|\|= "tcp";
		489	$type \|\|= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM;
		490
		491	my $proton = $PROTO_BYNAME{lc $proto} \|\| (getprotobyname $proto)[2]
202	or Carp::croak "$_[0]: service unknown"	492	or Carp::croak "$proto: protocol unknown";
203	}
204		493
		494	my $port;
		495
		496	if ($service =~ /^(\S+)=(\d+)$/) {
		497	($service, $port) = ($1, $2);
		498	} elsif ($service =~ /^\d+$/) {
		499	($service, $port) = (undef, $service);
		500	} else {
		501	$port = (getservbyname $service, $proto)[2]
		502	or Carp::croak "$service/$proto: service unknown";
		503	}
		504
		505	my @target = [$node, $port];
		506
		507	# resolve a records / provide sockaddr structures
		508	my $resolve = sub {
		509	my @res;
		510	my $cv = AnyEvent->condvar (cb => sub {
		511	$cb->(
		512	map $_->[2],
		513	sort {
		514	$AnyEvent::PROTOCOL{$b->[1]} <=> $AnyEvent::PROTOCOL{$a->[1]}
		515	or $a->[0] <=> $b->[0]
		516	}
		517	@res
		518	)
		519	});
		520
		521	$cv->begin;
		522	for my $idx (0 .. $#target) {
		523	my ($node, $port) = @{ $target[$idx] };
		524
		525	if (my $noden = parse_address $node) {
		526	my $af = address_family $noden;
		527
		528	if ($af == AF_INET && $family != 6) {
		529	push @res, [$idx, "ipv4", [AF_INET, $type, $proton,
		530	pack_sockaddr $port, $noden]]
		531	}
		532
		533	if ($af == AF_INET6 && $family != 4) {
		534	push @res, [$idx, "ipv6", [AF_INET6, $type, $proton,
		535	pack_sockaddr $port, $noden]]
		536	}
		537	} else {
		538	# ipv4
		539	if ($family != 6) {
		540	$cv->begin;
		541	AnyEvent::DNS::a $node, sub {
		542	push @res, [$idx, "ipv4", [AF_INET, $type, $proton,
		543	pack_sockaddr $port, parse_ipv4 $_]]
		544	for @_;
		545	$cv->end;
		546	};
		547	}
		548
		549	# ipv6
		550	if ($family != 4) {
		551	$cv->begin;
		552	AnyEvent::DNS::aaaa $node, sub {
		553	push @res, [$idx, "ipv6", [AF_INET6, $type, $proton,
		554	pack_sockaddr $port, parse_ipv6 $_]]
		555	for @_;
		556	$cv->end;
		557	};
		558	}
		559	}
		560	}
		561	$cv->end;
		562	};
		563
		564	# try srv records, if applicable
		565	if ($node eq "localhost") {
		566	@target = (["127.0.0.1", $port], ["::1", $port]);
		567	&$resolve;
		568	} elsif (defined $service && !parse_address $node) {
		569	AnyEvent::DNS::srv $service, $proto, $node, sub {
		570	my (@srv) = @_;
		571
		572	# no srv records, continue traditionally
		573	@srv
		574	or return &$resolve;
		575
		576	# the only srv record has "." ("" here) => abort
		577	$srv[0][2] ne "" \|\| $#srv
		578	or return $cb->();
		579
		580	# use srv records then
		581	@target = map ["$_->[3].", $_->[2]],
		582	grep $_->[3] ne ".",
		583	@srv;
		584
		585	&$resolve;
		586	};
		587	} else {
		588	&$resolve;
		589	}
		590	}
		591
205	=item $guard = tcp_connect $host, $port, $connect_cb[, $prepare_cb]	592	=item $guard = tcp_connect $host, $service, $connect_cb[, $prepare_cb]
206		593
207	This is a convenience function that creates a tcp socket and makes a 100%	594	This is a convenience function that creates a TCP socket and makes a 100%
208	non-blocking connect to the given C<$host> (which can be a hostname or a	595	non-blocking connect to the given C<$host> (which can be a hostname or
209	textual IP address) and C<$port> (which can be a numeric port number or a	596	a textual IP address, or the string C<unix/> for UNIX domain sockets)
210	service name).	597	and C<$service> (which can be a numeric port number or a service name,
		598	or a C<servicename=portnumber> string, or the pathname to a UNIX domain
		599	socket).
211		600
212	If both C<$host> and C<$port> are names, then this function will use SRV	601	If both C<$host> and C<$port> are names, then this function will use SRV
213	records to locate the real target in a future version.	602	records to locate the real target(s).
214		603
215	Unless called in void context, it returns a guard object that will	604	In either case, it will create a list of target hosts (e.g. for multihomed
216	automatically abort connecting when it gets destroyed (it does not do	605	hosts or hosts with both IPv4 and IPv6 addresses) and try to connect to
217	anything to the socket after the connect was successful).	606	each in turn.
218		607
219	If the connect is successful, then the C<$connect_cb> will be invoked with	608	If the connect is successful, then the C<$connect_cb> will be invoked with
220	the socket filehandle (in non-blocking mode) as first and the peer host	609	the socket file handle (in non-blocking mode) as first and the peer host
221	(as a textual IP address) and peer port as second and third arguments,	610	(as a textual IP address) and peer port as second and third arguments,
222	respectively.	611	respectively. The fourth argument is a code reference that you can call
		612	if, for some reason, you don't like this connection, which will cause
		613	C<tcp_connect> to try the next one (or call your callback without any
		614	arguments if there are no more connections). In most cases, you can simply
		615	ignore this argument.
		616
		617	$cb->($filehandle, $host, $port, $retry)
223		618
224	If the connect is unsuccessful, then the C<$connect_cb> will be invoked	619	If the connect is unsuccessful, then the C<$connect_cb> will be invoked
225	without any arguments and C<$!> will be set appropriately (with C<ENXIO>	620	without any arguments and C<$!> will be set appropriately (with C<ENXIO>
226	indicating a dns resolution failure).	621	indicating a DNS resolution failure).
227		622
228	The filehandle is suitable to be plugged into L<AnyEvent::Handle>, but can	623	The file handle is perfect for being plugged into L<AnyEvent::Handle>, but
229	be used as a normal perl file handle as well.	624	can be used as a normal perl file handle as well.
		625
		626	Unless called in void context, C<tcp_connect> returns a guard object that
		627	will automatically abort connecting when it gets destroyed (it does not do
		628	anything to the socket after the connect was successful).
230		629
231	Sometimes you need to "prepare" the socket before connecting, for example,	630	Sometimes you need to "prepare" the socket before connecting, for example,
232	to C<bind> it to some port, or you want a specific connect timeout that	631	to C<bind> it to some port, or you want a specific connect timeout that
233	is lower than your kernel's default timeout. In this case you can specify	632	is lower than your kernel's default timeout. In this case you can specify
234	a second callback, C<$prepare_cb>. It will be called with the file handle	633	a second callback, C<$prepare_cb>. It will be called with the file handle
235	in not-yet-connected state as only argument and must return the connection	634	in not-yet-connected state as only argument and must return the connection
236	timeout value (or C<0>, C<undef> or the empty list to indicate the default	635	timeout value (or C<0>, C<undef> or the empty list to indicate the default
237	timeout is to be used).	636	timeout is to be used).
238		637
239	Note that the socket could be either a IPv4 TCP socket or an IPv6 tcp	638	Note that the socket could be either a IPv4 TCP socket or an IPv6 TCP
240	socket (although only IPv4 is currently supported by this module).	639	socket (although only IPv4 is currently supported by this module).
241		640
		641	Note to the poor Microsoft Windows users: Windows (of course) doesn't
		642	correctly signal connection errors, so unless your event library works
		643	around this, failed connections will simply hang. The only event libraries
		644	that handle this condition correctly are L<EV> and L<Glib>. Additionally,
		645	AnyEvent works around this bug with L<Event> and in its pure-perl
		646	backend. All other libraries cannot correctly handle this condition. To
		647	lessen the impact of this windows bug, a default timeout of 30 seconds
		648	will be imposed on windows. Cygwin is not affected.
		649
242	Simple Example: connect to localhost on port 22.	650	Simple Example: connect to localhost on port 22.
243		651
244	tcp_connect localhost => 22, sub {	652	tcp_connect localhost => 22, sub {
245	my $fh = shift	653	my $fh = shift
246	or die "unable to connect: $!";	654	or die "unable to connect: $!";
247	# do something	655	# do something
248	};	656	};
249		657
250	Complex Example: connect to www.google.com on port 80 and make a simple	658	Complex Example: connect to www.google.com on port 80 and make a simple
251	GET request without much error handling. Also limit the connection timeout	659	GET request without much error handling. Also limit the connection timeout
252	to 15 seconds.	660	to 15 seconds.
253		661
…		…
283	# could call $fh->bind etc. here	691	# could call $fh->bind etc. here
284		692
285	15	693	15
286	};	694	};
287		695
		696	Example: connect to a UNIX domain socket.
		697
		698	tcp_connect "unix/", "/tmp/.X11-unix/X0", sub {
		699	...
		700	}
		701
288	=cut	702	=cut
289		703
290	sub tcp_connect($$$;$) {	704	sub tcp_connect($$$;$) {
291	my ($host, $port, $connect, $prepare) = @_;	705	my ($host, $port, $connect, $prepare) = @_;
292		706
293	# see http://cr.yp.to/docs/connect.html for some background	707	# see http://cr.yp.to/docs/connect.html for some background
		708	# also http://advogato.org/article/672.html
294		709
295	my %state = ( fh => undef );	710	my %state = ( fh => undef );
296		711
297	# name resolution	712	# name/service to type/sockaddr resolution
298	inet_aton $host, sub {	713	resolve_sockaddr $host, $port, 0, 0, 0, sub {
		714	my @target = @_;
		715
		716	$state{next} = sub {
299	return unless exists $state{fh};	717	return unless exists $state{fh};
300		718
301	my $ipn = shift;	719	my $target = shift @target
302
303	4 == length $ipn
304	or do {	720	or do {
305	%state = ();	721	%state = ();
306	$! = &Errno::ENXIO;
307	return $connect->();	722	return $connect->();
		723	};
		724
		725	my ($domain, $type, $proto, $sockaddr) = @$target;
		726
		727	# socket creation
		728	socket $state{fh}, $domain, $type, $proto
		729	or return $state{next}();
		730
		731	fh_nonblocking $state{fh}, 1;
		732
		733	my $timeout = $prepare && $prepare->($state{fh});
		734
		735	$timeout \|\|= 30 if AnyEvent::WIN32;
		736
		737	$state{to} = AnyEvent->timer (after => $timeout, cb => sub {
		738	$! = &Errno::ETIMEDOUT;
		739	$state{next}();
		740	}) if $timeout;
		741
		742	# called when the connect was successful, which,
		743	# in theory, could be the case immediately (but never is in practise)
		744	my $connected = sub {
		745	delete $state{ww};
		746	delete $state{to};
		747
		748	# we are connected, or maybe there was an error
		749	if (my $sin = getpeername $state{fh}) {
		750	my ($port, $host) = unpack_sockaddr $sin;
		751
		752	my $guard = guard {
		753	%state = ();
		754	};
		755
		756	$connect->($state{fh}, format_address $host, $port, sub {
		757	$guard->cancel;
		758	$state{next}();
		759	});
		760	} else {
		761	# dummy read to fetch real error code
		762	sysread $state{fh}, my $buf, 1 if $! == &Errno::ENOTCONN;
		763	$state{next}();
		764	}
308	};	765	};
309		766
310	# socket creation	767	# now connect
311	socket $state{fh}, &Socket::AF_INET, &Socket::SOCK_STREAM, 0	768	if (connect $state{fh}, $sockaddr) {
312	or do {
313	%state = ();
314	return $connect->();
315	};
316
317	fh_nonblocking $state{fh}, 1;
318
319	# prepare and optional timeout
320	if ($prepare) {
321	my $timeout = $prepare->($state{fh});
322
323	$state{to} = AnyEvent->timer (after => $timeout, cb => sub {
324	%state = ();
325	$! = &Errno::ETIMEDOUT;
326	$connect->();	769	$connected->();
327	}) if $timeout;	770	} elsif ($! == &Errno::EINPROGRESS # POSIX
328	}	771	\|\| $! == &Errno::EWOULDBLOCK
329		772	# WSAEINPROGRESS intentionally not checked - it means something else entirely
330	# called when the connect was successful, which,	773	\|\| $! == AnyEvent::Util::WSAEINVAL # not convinced, but doesn't hurt
331	# in theory, could be the case immediately (but never is in practise)	774	\|\| $! == AnyEvent::Util::WSAEWOULDBLOCK) {
332	my $connected = sub {	775	$state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $connected);
333	my $fh = delete $state{fh};
334	%state = ();
335
336	# we are connected, or maybe there was an error
337	if (my $sin = getpeername $fh) {
338	my ($port, $host) = Socket::unpack_sockaddr_in $sin;
339	$connect->($fh, (Socket::inet_ntoa $host), $port);
340	} else {	776	} else {
341	# dummy read to fetch real error code	777	$state{next}();
342	sysread $fh, my $buf, 1 if $! == &Errno::ENOTCONN;
343	$connect->();
344	}	778	}
345	};	779	};
346		780
347	# now connect	781	$! = &Errno::ENXIO;
348	if (connect $state{fh}, Socket::pack_sockaddr_in _tcp_port $port, $ipn) {	782	$state{next}();
349	$connected->();
350	} elsif ($! == &Errno::EINPROGRESS \|\| $! == &Errno::EWOULDBLOCK) { # EINPROGRESS is POSIX
351	$state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $connected);
352	} else {
353	%state = ();
354	$connect->();
355	}
356	};	783	};
357		784
358	defined wantarray	785	defined wantarray && guard { %state = () }
359	? guard { %state = () } # break any circular dependencies and unregister watchers
360	: ()
361	}	786	}
362		787
363	=item $guard = tcp_server $host, $port, $accept_cb[, $prepare_cb]	788	=item $guard = tcp_server $host, $service, $accept_cb[, $prepare_cb]
364		789
365	Create and bind a tcp socket to the given host (any IPv4 host if undef,	790	Create and bind a stream socket to the given host, and port, set the
366	otherwise it must be an IPv4 or IPv6 address) and port (service name or	791	SO_REUSEADDR flag (if applicable) and call C<listen>. Unlike the name
367	numeric port number, or an ephemeral port if given as zero or undef), set	792	implies, this function can also bind on UNIX domain sockets.
368	the SO_REUSEADDR flag and call C<listen>.
369		793
		794	For internet sockets, C<$host> must be an IPv4 or IPv6 address (or
		795	C<undef>, in which case it binds either to C<0> or to C<::>, depending
		796	on whether IPv4 or IPv6 is the preferred protocol, and maybe to both in
		797	future versions, as applicable).
		798
		799	To bind to the IPv4 wildcard address, use C<0>, to bind to the IPv6
		800	wildcard address, use C<::>.
		801
		802	The port is specified by C<$service>, which must be either a service name or
		803	a numeric port number (or C<0> or C<undef>, in which case an ephemeral
		804	port will be used).
		805
		806	For UNIX domain sockets, C<$host> must be C<unix/> and C<$service> must be
		807	the absolute pathname of the socket. This function will try to C<unlink>
		808	the socket before it tries to bind to it. See SECURITY CONSIDERATIONS,
		809	below.
		810
370	For each new connection that could be C<accept>ed, call the C<$accept_cb>	811	For each new connection that could be C<accept>ed, call the C<<
371	with the filehandle (in non-blocking mode) as first and the peer host and	812	$accept_cb->($fh, $host, $port) >> with the file handle (in non-blocking
372	port as second and third arguments (see C<tcp_connect> for details).	813	mode) as first and the peer host and port as second and third arguments
		814	(see C<tcp_connect> for details).
373		815
374	Croaks on any errors.	816	Croaks on any errors it can detect before the listen.
375		817
376	If called in non-void context, then this function returns a guard object	818	If called in non-void context, then this function returns a guard object
377	whose lifetime it tied to the tcp server: If the object gets destroyed,	819	whose lifetime it tied to the TCP server: If the object gets destroyed,
378	the server will be stopped (but existing accepted connections will	820	the server will be stopped (but existing accepted connections will
379	continue).	821	continue).
380		822
381	If you need more control over the listening socket, you can provide a	823	If you need more control over the listening socket, you can provide a
382	C<$prepare_cb>, which is called just before the C<listen ()> call, with	824	C<< $prepare_cb->($fh, $host, $port) >>, which is called just before the
383	the listen file handle as first argument.	825	C<listen ()> call, with the listen file handle as first argument, and IP
		826	address and port number of the local socket endpoint as second and third
		827	arguments.
384		828
385	It should return the length of the listen queue (or C<0> for the default).	829	It should return the length of the listen queue (or C<0> for the default).
386		830
		831	Note to IPv6 users: RFC-compliant behaviour for IPv6 sockets listening on
		832	C<::> is to bind to both IPv6 and IPv4 addresses by default on dual-stack
		833	hosts. Unfortunately, only GNU/Linux seems to implement this properly, so
		834	if you want both IPv4 and IPv6 listening sockets you should create the
		835	IPv6 socket first and then attempt to bind on the IPv4 socket, but ignore
		836	any C<EADDRINUSE> errors.
		837
387	Example: bind on tcp port 8888 on the local machine and tell each client	838	Example: bind on some TCP port on the local machine and tell each client
388	to go away.	839	to go away.
389		840
390	tcp_server undef, 8888, sub {	841	tcp_server undef, undef, sub {
391	my ($fh, $host, $port) = @_;	842	my ($fh, $host, $port) = @_;
392		843
393	syswrite $fh, "The internet is full, $host:$port. Go away!\015\012";	844	syswrite $fh, "The internet is full, $host:$port. Go away!\015\012";
		845	}, sub {
		846	my ($fh, $thishost, $thisport) = @_;
		847	warn "bound to $thishost, port $thisport\n";
394	};	848	};
395		849
396	=cut	850	=cut
397		851
398	sub tcp_server($$$;$) {	852	sub tcp_server($$$;$) {
399	my ($host, $port, $accept, $prepare) = @_;	853	my ($host, $service, $accept, $prepare) = @_;
		854
		855	$host = $AnyEvent::PROTOCOL{ipv4} < $AnyEvent::PROTOCOL{ipv6} && AF_INET6
		856	? "::" : "0"
		857	unless defined $host;
		858
		859	my $ipn = parse_address $host
		860	or Carp::croak "AnyEvent::Socket::tcp_server: cannot parse '$host' as host address";
		861
		862	my $af = address_family $ipn;
400		863
401	my %state;	864	my %state;
402		865
403	socket $state{fh}, &Socket::AF_INET, &Socket::SOCK_STREAM, 0	866	# win32 perl is too stupid to get this right :/
		867	Carp::croak "tcp_server/socket: address family not supported"
		868	if AnyEvent::WIN32 && $af == AF_UNIX;
		869
		870	socket $state{fh}, $af, SOCK_STREAM, 0
404	or Carp::croak "socket: $!";	871	or Carp::croak "tcp_server/socket: $!";
405		872
		873	if ($af == AF_INET \|\| $af == AF_INET6) {
406	setsockopt $state{fh}, &Socket::SOL_SOCKET, &Socket::SO_REUSEADDR, 1	874	setsockopt $state{fh}, SOL_SOCKET, SO_REUSEADDR, 1
407	or Carp::croak "so_reuseaddr: $!";	875	or Carp::croak "tcp_server/so_reuseaddr: $!"
		876	unless AnyEvent::WIN32; # work around windows bug
408		877
409	bind $state{fh}, Socket::pack_sockaddr_in _tcp_port $port, socket_inet_aton ($host \|\| "0.0.0.0")	878	unless ($service =~ /^\d*$/) {
		879	$service = (getservbyname $service, "tcp")[2]
		880	or Carp::croak "$service: service unknown"
		881	}
		882	} elsif ($af == AF_UNIX) {
		883	unlink $service;
		884	}
		885
		886	bind $state{fh}, pack_sockaddr $service, $ipn
410	or Carp::croak "bind: $!";	887	or Carp::croak "bind: $!";
411		888
412	fh_nonblocking $state{fh}, 1;	889	fh_nonblocking $state{fh}, 1;
413		890
414	my $len = ($prepare && $prepare->($state{fh})) \|\| 128;	891	my $len;
		892
		893	if ($prepare) {
		894	my ($service, $host) = unpack_sockaddr getsockname $state{fh};
		895	$len = $prepare && $prepare->($state{fh}, format_address $host, $service);
		896	}
		897
		898	$len \|\|= 128;
415		899
416	listen $state{fh}, $len	900	listen $state{fh}, $len
417	or Carp::croak "listen: $!";	901	or Carp::croak "listen: $!";
418		902
419	$state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub {	903	$state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub {
420	# this closure keeps $state alive	904	# this closure keeps $state alive
421	while (my $peer = accept my $fh, $state{fh}) {	905	while (my $peer = accept my $fh, $state{fh}) {
422	fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not	906	fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not
		907
423	my ($port, $host) = Socket::unpack_sockaddr_in $peer;	908	my ($service, $host) = unpack_sockaddr $peer;
424	$accept->($fh, (Socket::inet_ntoa $host), $port);	909	$accept->($fh, format_address $host, $service);
425	}	910	}
426	});	911	});
427		912
428	defined wantarray	913	defined wantarray
429	? guard { %state = () } # clear fh and watcher, which breaks the circular dependency	914	? guard { %state = () } # clear fh and watcher, which breaks the circular dependency
…		…
432		917
433	1;	918	1;
434		919
435	=back	920	=back
436		921
		922	=head1 SECURITY CONSIDERATIONS
		923
		924	This module is quite powerful, with with power comes the ability to abuse
		925	as well: If you accept "hostnames" and ports from untrusted sources,
		926	then note that this can be abused to delete files (host=C<unix/>). This
		927	is not really a problem with this module, however, as blindly accepting
		928	any address and protocol and trying to bind a server or connect to it is
		929	harmful in general.
		930
437	=head1 AUTHOR	931	=head1 AUTHOR
438		932
439	Marc Lehmann <schmorp@schmorp.de>	933	Marc Lehmann <schmorp@schmorp.de>
440	http://home.schmorp.de/	934	http://home.schmorp.de/
441		935

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents): Revision 1.13 by root, Fri May 23 22:52:31 2008 UTC vs. Revision 1.57 by root, Sat Jul 19 22:10:47 2008 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.13 by root, Fri May 23 22:52:31 2008 UTC vs.
Revision 1.57 by root, Sat Jul 19 22:10:47 2008 UTC