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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.18 by root, Sat May 24 18:50:40 2008 UTC vs.
Revision 1.130 by root, Fri Jan 14 17:43:11 2011 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		8
9	tcp_connect "gameserver.deliantra.net", 13327, sub {	9	tcp_connect "gameserver.deliantra.net", 13327, sub {
10	my ($fh) = @_	10	my ($fh) = @_
11	or die "gameserver.deliantra.net connect failed: $!";	11	or die "gameserver.deliantra.net connect failed: $!";
12		12
13	# enjoy your filehandle	13	# enjoy your filehandle
14	};	14	};
		15
		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	};
15		22
16	=head1 DESCRIPTION	23	=head1 DESCRIPTION
17		24
18	This module implements various utility functions for handling internet	25	This module implements various utility functions for handling internet
19	protocol addresses and sockets, in an as transparent and simple way as	26	protocol addresses and sockets, in an as transparent and simple way as
…		…
26		33
27	=cut	34	=cut
28		35
29	package AnyEvent::Socket;	36	package AnyEvent::Socket;
30		37
31	no warnings;
32	use strict;
33
34	use Carp ();	38	use Carp ();
35	use Errno ();	39	use Errno ();
36	use Socket ();	40	use Socket qw(AF_INET AF_UNIX SOCK_STREAM SOCK_DGRAM SOL_SOCKET SO_REUSEADDR);
37		41
38	use AnyEvent ();	42	use AnyEvent (); BEGIN { AnyEvent::common_sense }
39	use AnyEvent::Util qw(guard fh_nonblocking);	43	use AnyEvent::Util qw(guard fh_nonblocking AF_INET6);
40	use AnyEvent::DNS ();	44	use AnyEvent::DNS ();
41		45
42	use base 'Exporter';	46	use base 'Exporter';
43		47
44	BEGIN {	48	our @EXPORT = qw(
45	*socket_inet_aton = \&Socket::inet_aton; # take a copy, in case Coro::LWP overrides it	49	getprotobyname
46	}	50	parse_hostport format_hostport
		51	parse_ipv4 parse_ipv6
		52	parse_ip parse_address
		53	format_ipv4 format_ipv6
		54	format_ip format_address
		55	address_family
		56	inet_aton
		57	tcp_server
		58	tcp_connect
		59	);
47		60
48	BEGIN {	61	our $VERSION = $AnyEvent::VERSION;
49	my $af_inet6 = eval { &Socket::AF_INET6 };
50	eval "sub AF_INET6() { $af_inet6 }"; die if $@;
51		62
52	delete $AnyEvent::PROTOCOL{ipv6} unless $af_inet6;	63	# used in cases where we may return immediately but want the
53	}	64	# caller to do stuff first
		65	sub _postpone {
		66	my ($cb, @args) = (@_, $!);
54		67
55	our @EXPORT = qw(parse_ipv4 parse_ipv6 parse_ip format_ip inet_aton tcp_server tcp_connect);	68	my $w; $w = AE::timer 0, 0, sub {
56		69	undef $w;
57	our $VERSION = '1.0';	70	$! = pop @args;
		71	$cb->(@args);
		72	};
		73	}
58		74
59	=item $ipn = parse_ipv4 $dotted_quad	75	=item $ipn = parse_ipv4 $dotted_quad
60		76
61	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
62	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
…		…
74		90
75	# check leading parts against range	91	# check leading parts against range
76	return undef if grep $_ >= 256, @_[0 .. @_ - 2];	92	return undef if grep $_ >= 256, @_[0 .. @_ - 2];
77		93
78	# check trailing part against range	94	# check trailing part against range
79	return undef if $_[-1] >= 1 << (8 * (4 - $#_));	95	return undef if $_[-1] >= 2 ** (8 * (4 - $#_));
80		96
81	pack "N", (pop)	97	pack "N", (pop)
82	+ ($_[0] << 24)	98	+ ($_[0] << 24)
83	+ ($_[1] << 16)	99	+ ($_[1] << 16)
84	+ ($_[2] << 8);	100	+ ($_[2] << 8);
…		…
88		104
89	Tries to parse the given IPv6 address and return it in	105	Tries to parse the given IPv6 address and return it in
90	octet form (or undef when it isn't in a parsable format).	106	octet form (or undef when it isn't in a parsable format).
91		107
92	Should support all forms specified by RFC 2373 (and additionally all IPv4	108	Should support all forms specified by RFC 2373 (and additionally all IPv4
93	forms supported by parse_ipv4).	109	forms supported by parse_ipv4). Note that scope-id's are not supported
		110	(and will not parse).
94		111
95	This function works similarly to C<inet_pton AF_INET6, ...>.	112	This function works similarly to C<inet_pton AF_INET6, ...>.
		113
		114	Example:
		115
		116	print unpack "H*", parse_ipv6 "2002:5345::10.0.0.1";
		117	# => 2002534500000000000000000a000001
96		118
97	=cut	119	=cut
98		120
99	sub parse_ipv6($) {	121	sub parse_ipv6($) {
100	# quick test to avoid longer processing	122	# quick test to avoid longer processing
…		…
131		153
132	# and done	154	# and done
133	pack "n*", map hex, @h, @t	155	pack "n*", map hex, @h, @t
134	}	156	}
135		157
136	=item $ipn = parse_ip $text	158	sub parse_unix($) {
		159	$_[0] eq "unix/"
		160	? pack "S", AF_UNIX
		161	: undef
137		162
		163	}
		164
		165	=item $ipn = parse_address $ip
		166
138	Combines C<parse_ipv4> and C<parse_ipv6> in one function.	167	Combines C<parse_ipv4> and C<parse_ipv6> in one function. The address
		168	here refers to the host address (not socket address) in network form
		169	(binary).
139		170
140	=cut	171	If the C<$text> is C<unix/>, then this function returns a special token
		172	recognised by the other functions in this module to mean "UNIX domain
		173	socket".
141		174
		175	If the C<$text> to parse is a mapped IPv4 in IPv6 address (:ffff::<ipv4>),
		176	then it will be treated as an IPv4 address. If you don't want that, you
		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
		183
		184	=item $ipn = AnyEvent::Socket::aton $ip
		185
		186	Same as C<parse_address>, but not exported (think C<Socket::inet_aton> but
		187	I<without> name resolution).
		188
		189	=cut
		190
142	sub parse_ip($) {	191	sub parse_address($) {
143	&parse_ipv4 \|\| &parse_ipv6	192	for (&parse_ipv6) {
		193	if ($_) {
		194	s/^\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff//;
		195	return $_;
		196	} else {
		197	return &parse_ipv4 \|\| &parse_unix
		198	}
		199	}
144	}	200	}
145		201
		202	*aton = \&parse_address;
		203
		204	=item ($name, $aliases, $proto) = getprotobyname $name
		205
		206	Works like the builtin function of the same name, except it tries hard to
		207	work even on broken platforms (well, that's windows), where getprotobyname
		208	is traditionally very unreliable.
		209
		210	Example: get the protocol number for TCP (usually 6)
		211
		212	my $proto = getprotobyname "tcp";
		213
		214	=cut
		215
		216	# microsoft can't even get getprotobyname working (the etc/protocols file
		217	# gets lost fairly often on windows), so we have to hardcode some common
		218	# protocol numbers ourselves.
		219	our %PROTO_BYNAME;
		220
		221	$PROTO_BYNAME{tcp} = Socket::IPPROTO_TCP () if defined &Socket::IPPROTO_TCP;
		222	$PROTO_BYNAME{udp} = Socket::IPPROTO_UDP () if defined &Socket::IPPROTO_UDP;
		223	$PROTO_BYNAME{icmp} = Socket::IPPROTO_ICMP() if defined &Socket::IPPROTO_ICMP;
		224
		225	sub getprotobyname($) {
		226	my $name = lc shift;
		227
		228	defined (my $proton = $PROTO_BYNAME{$name} \|\| (getprotobyname $name)[2])
		229	or return;
		230
		231	($name, uc $name, $proton)
		232	}
		233
		234	=item ($host, $service) = parse_hostport $string[, $default_service]
		235
		236	Splitting a string of the form C<hostname:port> is a common
		237	problem. Unfortunately, just splitting on the colon makes it hard to
		238	specify IPv6 addresses and doesn't support the less common but well
		239	standardised C<[ip literal]> syntax.
		240
		241	This function tries to do this job in a better way, it supports the
		242	following formats, where C<port> can be a numerical port number of a
		243	service name, or a C<name=port> string, and the C< port> and C<:port>
		244	parts are optional. Also, everywhere where an IP address is supported
		245	a hostname or unix domain socket address is also supported (see
		246	C<parse_unix>).
		247
		248	hostname:port e.g. "www.linux.org", "www.x.de:443", "www.x.de:https=443"
		249	ipv4:port e.g. "198.182.196.56", "127.1:22"
		250	ipv6 e.g. "::1", "affe::1"
		251	[ipv4or6]:port e.g. "[::1]", "[10.0.1]:80"
		252	[ipv4or6] port e.g. "[127.0.0.1]", "[www.x.org] 17"
		253	ipv4or6 port e.g. "::1 443", "10.0.0.1 smtp"
		254
		255	It also supports defaulting the service name in a simple way by using
		256	C<$default_service> if no service was detected. If neither a service was
		257	detected nor a default was specified, then this function returns the
		258	empty list. The same happens when a parse error was detected, such as a
		259	hostname with a colon in it (the function is rather conservative, though).
		260
		261	Example:
		262
		263	print join ",", parse_hostport "localhost:443";
		264	# => "localhost,443"
		265
		266	print join ",", parse_hostport "localhost", "https";
		267	# => "localhost,https"
		268
		269	print join ",", parse_hostport "[::1]";
		270	# => "," (empty list)
		271
		272	=cut
		273
		274	sub parse_hostport($;$) {
		275	my ($host, $port);
		276
		277	for ("$_[0]") { # work on a copy, just in case, and also reset pos
		278
		279	# parse host, special cases: "ipv6" or "ipv6 port"
		280	unless (
		281	($host) = /^\s* ([0-9a-fA-F:]:[0-9a-fA-F:]:[0-9a-fA-F\.:]*)/xgc
		282	and parse_ipv6 $host
		283	) {
		284	/^\s*/xgc;
		285
		286	if (/^ \[ ([^\[\]]+) \]/xgc) {
		287	$host = $1;
		288	} elsif (/^ ([^\[\]:\ ]+) /xgc) {
		289	$host = $1;
		290	} else {
		291	return;
		292	}
		293	}
		294
		295	# parse port
		296	if (/\G (?:\s+\|:) ([^:[:space:]]+) \s*$/xgc) {
		297	$port = $1;
		298	} elsif (/\G\s*$/gc && length $_[1]) {
		299	$port = $_[1];
		300	} else {
		301	return;
		302	}
		303	}
		304
		305	# hostnames must not contain :'s
		306	return if $host =~ /:/ && !parse_ipv6 $host;
		307
		308	($host, $port)
		309	}
		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
		327	=item $sa_family = address_family $ipn
		328
		329	Returns the address family/protocol-family (AF_xxx/PF_xxx, in one value :)
		330	of the given host address in network format.
		331
		332	=cut
		333
		334	sub address_family($) {
		335	4 == length $_[0]
		336	? AF_INET
		337	: 16 == length $_[0]
		338	? AF_INET6
		339	: unpack "S", $_[0]
		340	}
		341
146	=item $text = format_ip $ipn	342	=item $text = format_ipv4 $ipn
147		343
148	Takes either an IPv4 address (4 octets) or and IPv6 address (16 octets)	344	Expects a four octet string representing a binary IPv4 address and returns
		345	its textual format. Rarely used, see C<format_address> for a nicer
		346	interface.
		347
		348	=item $text = format_ipv6 $ipn
		349
		350	Expects a sixteen octet string representing a binary IPv6 address and
		351	returns its textual format. Rarely used, see C<format_address> for a
		352	nicer interface.
		353
		354	=item $text = format_address $ipn
		355
		356	Covnvert a host address in network format (e.g. 4 octets for IPv4 or 16
149	and converts it into textual form.	357	octets for IPv6) and convert it into textual form.
		358
		359	Returns C<unix/> for UNIX domain sockets.
150		360
151	This function works similarly to C<inet_ntop AF_INET \|\| AF_INET6, ...>,	361	This function works similarly to C<inet_ntop AF_INET \|\| AF_INET6, ...>,
152	except it automatically detects the address type.	362	except it automatically detects the address type.
153		363
154	=cut	364	Returns C<undef> if it cannot detect the type.
155		365
156	sub format_ip;	366	If the C<$ipn> is a mapped IPv4 in IPv6 address (:ffff::<ipv4>), then just
		367	the contained IPv4 address will be returned. If you do not want that, you
		368	have to call C<format_ipv6> manually.
		369
		370	Example:
		371
		372	print format_address "\x01\x02\x03\x05";
		373	=> 1.2.3.5
		374
		375	=item $text = AnyEvent::Socket::ntoa $ipn
		376
		377	Same as format_address, but not exported (think C<inet_ntoa>).
		378
		379	=cut
		380
157	sub format_ip($) {	381	sub format_ipv4($) {
		382	join ".", unpack "C4", $_[0]
		383	}
		384
		385	sub format_ipv6($) {
		386	if ($_[0] =~ /^\x00\x00\x00\x00\x00\x00\x00\x00/) {
		387	if (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0 eq $_[0]) {
		388	return "::";
		389	} elsif (v0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.1 eq $_[0]) {
		390	return "::1";
		391	} elsif (v0.0.0.0.0.0.0.0.0.0.0.0 eq substr $_[0], 0, 12) {
		392	# v4compatible
		393	return "::" . format_ipv4 substr $_[0], 12;
		394	} elsif (v0.0.0.0.0.0.0.0.0.0.255.255 eq substr $_[0], 0, 12) {
		395	# v4mapped
		396	return "::ffff:" . format_ipv4 substr $_[0], 12;
		397	} elsif (v0.0.0.0.0.0.0.0.255.255.0.0 eq substr $_[0], 0, 12) {
		398	# v4translated
		399	return "::ffff:0:" . format_ipv4 substr $_[0], 12;
		400	}
		401	}
		402
		403	my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0];
		404
		405	# this is admittedly rather sucky
		406	$ip =~ s/(?:^\|:) 0:0:0:0:0:0:0 (?:$\|:)/::/x
		407	or $ip =~ s/(?:^\|:) 0:0:0:0:0:0 (?:$\|:)/::/x
		408	or $ip =~ s/(?:^\|:) 0:0:0:0:0 (?:$\|:)/::/x
		409	or $ip =~ s/(?:^\|:) 0:0:0:0 (?:$\|:)/::/x
		410	or $ip =~ s/(?:^\|:) 0:0:0 (?:$\|:)/::/x
		411	or $ip =~ s/(?:^\|:) 0:0 (?:$\|:)/::/x
		412	or $ip =~ s/(?:^\|:) 0 (?:$\|:)/::/x;
		413
		414	$ip
		415	}
		416
		417	sub format_address($) {
158	if (4 == length $_[0]) {	418	if (4 == length $_[0]) {
159	return join ".", unpack "C4", $_[0]	419	return &format_ipv4;
160	} elsif (16 == length $_[0]) {	420	} elsif (16 == length $_[0]) {
161	if (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
162	# v4mapped	422	? format_ipv4 $1
163	return "::ffff:" . format_ip substr $_[0], 12;	423	: &format_ipv6;
164	} else {	424	} elsif (AF_UNIX == address_family $_[0]) {
165	my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0];	425	return "unix/"
166
167	$ip =~ s/^0:(?:0:)*/::/
168	or $ip =~ s/(:0)+$/::/
169	or $ip =~ s/(:0)+/:/;
170	return $ip
171	}
172	} else {	426	} else {
173	return undef	427	return undef
174	}	428	}
175	}	429	}
176		430
		431	*ntoa = \&format_address;
		432
177	=item inet_aton $name_or_address, $cb->(@addresses)	433	=item inet_aton $name_or_address, $cb->(@addresses)
178		434
179	Works similarly to its Socket counterpart, except that it uses a	435	Works similarly to its Socket counterpart, except that it uses a
180	callback. Also, if a host has only an IPv6 address, this might be passed	436	callback. Use the length to distinguish between ipv4 and ipv6 (4 octets
181	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
182	for IPv6).	438	readable format.
183		439
184	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,
185	and IPv6 addresses as result.	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
186		457
187	=cut	458	=cut
188		459
189	sub inet_aton {	460	sub inet_aton {
190	my ($name, $cb) = @_;	461	my ($name, $cb) = @_;
…		…
196	} elsif ($name eq "localhost") { # rfc2606 et al.	467	} elsif ($name eq "localhost") { # rfc2606 et al.
197	$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);
198	} else {	469	} else {
199	require AnyEvent::DNS;	470	require AnyEvent::DNS;
200		471
201	# 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;
202	AnyEvent::DNS::a ($name, sub {	485	AnyEvent::DNS::a ($name, sub {
203	if (@_) {	486	$res[$ipv4] = [map &parse_ipv4, @_];
204	$cb->(map +(parse_ipv4 $_), @_);
205	} else {
206	$cb->();	487	$cv->end;
207	#AnyEvent::DNS::aaaa ($name, $cb); need inet_pton
208	}	488	});
209	});	489	};
210	}
211	}
212		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;
		500	}
		501	}
		502
		503	BEGIN {
		504	*sockaddr_family = $Socket::VERSION >= 1.75
		505	? \&Socket::sockaddr_family
		506	: # for 5.6.x, we need to do something much more horrible
		507	(Socket::pack_sockaddr_in 0x5555, "\x55\x55\x55\x55"
		508	\| eval { Socket::pack_sockaddr_un "U" }) =~ /^\x00/
		509	? sub { unpack "xC", $_[0] }
		510	: sub { unpack "S" , $_[0] };
		511	}
		512
		513	# check for broken platforms with an extra field in sockaddr structure
		514	# kind of a rfc vs. bsd issue, as usual (ok, normally it's a
		515	# unix vs. bsd issue, a iso C vs. bsd issue or simply a
		516	# correctness vs. bsd issue.)
		517	my $pack_family = 0x55 == sockaddr_family ("\x55\x55")
		518	? "xC" : "S";
		519
213	=item $sa = AnyEvent::Socket::pack_sockaddr $port, $host	520	=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host
214		521
215	Pack the given port/host combination into a binary sockaddr structure. Handles	522	Pack the given port/host combination into a binary sockaddr
216	both IPv4 and IPv6 host addresses.	523	structure. Handles both IPv4 and IPv6 host addresses, as well as UNIX
		524	domain sockets (C<$host> == C<unix/> and C<$service> == absolute
		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: $!";
217		532
218	=cut	533	=cut
219		534
220	sub pack_sockaddr($$) {	535	sub pack_sockaddr($$) {
221	if (4 == length $_[1]) {	536	my $af = address_family $_[1];
		537
		538	if ($af == AF_INET) {
222	Socket::pack_sockaddr_in $_[0], $_[1]	539	Socket::pack_sockaddr_in $_[0], $_[1]
223	} elsif (16 == length $_[1]) {	540	} elsif ($af == AF_INET6) {
224	pack "SnL a16 L",	541	pack "$pack_family nL a16 L",
225	Socket::AF_INET6,	542	AF_INET6,
226	$_[0], # port	543	$_[0], # port
227	0, # flowinfo	544	0, # flowinfo
228	$_[1], # addr	545	$_[1], # addr
229	0 # scope id	546	0 # scope id
		547	} elsif ($af == AF_UNIX) {
		548	Socket::pack_sockaddr_un $_[0]
230	} else {	549	} else {
231	Carp::croak "pack_sockaddr: invalid host";	550	Carp::croak "pack_sockaddr: invalid host";
232	}	551	}
233	}	552	}
234		553
235	=item ($port, $host) = AnyEvent::Socket::unpack_sockaddr $sa	554	=item ($service, $host) = AnyEvent::Socket::unpack_sockaddr $sa
236		555
237	Unpack the given binary sockaddr structure (as used by bind, getpeername	556	Unpack the given binary sockaddr structure (as used by bind, getpeername
238	etc.) into a C<$port, $host> combination.	557	etc.) into a C<$service, $host> combination.
239		558
240	Handles both IPv4 and IPv6 sockaddr structures.	559	For IPv4 and IPv6, C<$service> is the port number and C<$host> the host
		560	address in network format (binary).
241		561
		562	For UNIX domain sockets, C<$service> is the absolute pathname and C<$host>
		563	is a special token that is understood by the other functions in this
		564	module (C<format_address> converts it to C<unix/>).
		565
242	=cut	566	=cut
		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;
243		573
244	sub unpack_sockaddr($) {	574	sub unpack_sockaddr($) {
245	my $af = unpack "S", $_[0];	575	my $af = sockaddr_family $_[0];
246		576
247	if ($af == &Socket::AF_INET) {	577	if ($af == AF_INET) {
248	Socket::unpack_sockaddr_in $_[0]	578	Socket::unpack_sockaddr_in $_[0]
249	} elsif ($af == AF_INET6) {	579	} elsif ($af == AF_INET6) {
250	(unpack "SnL a16 L")[1, 3]	580	unpack "x2 n x4 a16", $_[0]
		581	} elsif ($af == AF_UNIX) {
		582	((Socket::unpack_sockaddr_un $_[0] ^ $sa_un_zero), pack "S", AF_UNIX)
251	} else {	583	} else {
252	Carp::croak "unpack_sockaddr: unsupported protocol family $af";	584	Carp::croak "unpack_sockaddr: unsupported protocol family $af";
253	}	585	}
254	}	586	}
255		587
256	sub _tcp_port($) {	588	=item resolve_sockaddr $node, $service, $proto, $family, $type, $cb->([$family, $type, $proto, $sockaddr], ...)
257	$_[0] =~ /^(\d)$/ and return $11;
258		589
259	(getservbyname $_[0], "tcp")[2]	590	Tries to resolve the given nodename and service name into protocol families
		591	and sockaddr structures usable to connect to this node and service in a
		592	protocol-independent way. It works remotely similar to the getaddrinfo
		593	posix function.
		594
		595	For internet addresses, C<$node> is either an IPv4 or IPv6 address, an
		596	internet hostname (DNS domain name or IDN), and C<$service> is either
		597	a service name (port name from F</etc/services>) or a numerical port
		598	number. If both C<$node> and C<$service> are names, then SRV records
		599	will be consulted to find the real service, otherwise they will be
		600	used as-is. If you know that the service name is not in your services
		601	database, then you can specify the service in the format C<name=port>
		602	(e.g. C<http=80>).
		603
		604	For UNIX domain sockets, C<$node> must be the string C<unix/> and
		605	C<$service> must be the absolute pathname of the socket. In this case,
		606	C<$proto> will be ignored.
		607
		608	C<$proto> must be a protocol name, currently C<tcp>, C<udp> or
		609	C<sctp>. The default is currently C<tcp>, but in the future, this function
		610	might try to use other protocols such as C<sctp>, depending on the socket
		611	type and any SRV records it might find.
		612
		613	C<$family> must be either C<0> (meaning any protocol is OK), C<4> (use
		614	only IPv4) or C<6> (use only IPv6). The default is influenced by
		615	C<$ENV{PERL_ANYEVENT_PROTOCOLS}>.
		616
		617	C<$type> must be C<SOCK_STREAM>, C<SOCK_DGRAM> or C<SOCK_SEQPACKET> (or
		618	C<undef> in which case it gets automatically chosen to be C<SOCK_STREAM>
		619	unless C<$proto> is C<udp>).
		620
		621	The callback will receive zero or more array references that contain
		622	C<$family, $type, $proto> for use in C<socket> and a binary
		623	C<$sockaddr> for use in C<connect> (or C<bind>).
		624
		625	The application should try these in the order given.
		626
		627	Example:
		628
		629	resolve_sockaddr "google.com", "http", 0, undef, undef, sub { ... };
		630
		631	=cut
		632
		633	sub resolve_sockaddr($$$$$$) {
		634	my ($node, $service, $proto, $family, $type, $cb) = @_;
		635
		636	if ($node eq "unix/") {
		637	return $cb->() if $family \|\| $service !~ /^\//; # no can do
		638
		639	return $cb->([AF_UNIX, defined $type ? $type : SOCK_STREAM, 0, Socket::pack_sockaddr_un $service]);
		640	}
		641
		642	unless (AF_INET6) {
		643	$family != 6
		644	or return $cb->();
		645
		646	$family = 4;
		647	}
		648
		649	$cb->() if $family == 4 && !$AnyEvent::PROTOCOL{ipv4};
		650	$cb->() if $family == 6 && !$AnyEvent::PROTOCOL{ipv6};
		651
		652	$family \|\|= 4 unless $AnyEvent::PROTOCOL{ipv6};
		653	$family \|\|= 6 unless $AnyEvent::PROTOCOL{ipv4};
		654
		655	$proto \|\|= "tcp";
		656	$type \|\|= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM;
		657
		658	my $proton = AnyEvent::Socket::getprotobyname $proto
260	or Carp::croak "$_[0]: service unknown"	659	or Carp::croak "$proto: protocol unknown";
		660
		661	my $port;
		662
		663	if ($service =~ /^(\S+)=(\d+)$/) {
		664	($service, $port) = ($1, $2);
		665	} elsif ($service =~ /^\d+$/) {
		666	($service, $port) = (undef, $service);
		667	} else {
		668	$port = (getservbyname $service, $proto)[2]
		669	or Carp::croak "$service/$proto: service unknown";
		670	}
		671
		672	# resolve a records / provide sockaddr structures
		673	my $resolve = sub {
		674	my @target = @_;
		675
		676	my @res;
		677	my $cv = AE::cv {
		678	$cb->(
		679	map $_->[2],
		680	sort {
		681	$AnyEvent::PROTOCOL{$b->[1]} <=> $AnyEvent::PROTOCOL{$a->[1]}
		682	or $a->[0] <=> $b->[0]
		683	}
		684	@res
		685	)
		686	};
		687
		688	$cv->begin;
		689	for my $idx (0 .. $#target) {
		690	my ($node, $port) = @{ $target[$idx] };
		691
		692	if (my $noden = parse_address $node) {
		693	my $af = address_family $noden;
		694
		695	if ($af == AF_INET && $family != 6) {
		696	push @res, [$idx, "ipv4", [AF_INET, $type, $proton,
		697	pack_sockaddr $port, $noden]]
		698	}
		699
		700	if ($af == AF_INET6 && $family != 4) {
		701	push @res, [$idx, "ipv6", [AF_INET6, $type, $proton,
		702	pack_sockaddr $port, $noden]]
		703	}
		704	} else {
		705	# ipv4
		706	if ($family != 6) {
		707	$cv->begin;
		708	AnyEvent::DNS::a $node, sub {
		709	push @res, [$idx, "ipv4", [AF_INET, $type, $proton,
		710	pack_sockaddr $port, parse_ipv4 $_]]
		711	for @_;
		712	$cv->end;
		713	};
		714	}
		715
		716	# ipv6
		717	if ($family != 4) {
		718	$cv->begin;
		719	AnyEvent::DNS::aaaa $node, sub {
		720	push @res, [$idx, "ipv6", [AF_INET6, $type, $proton,
		721	pack_sockaddr $port, parse_ipv6 $_]]
		722	for @_;
		723	$cv->end;
		724	};
		725	}
		726	}
		727	}
		728	$cv->end;
		729	};
		730
		731	$node = AnyEvent::Util::idn_to_ascii $node
		732	if $node =~ /[^\x00-\x7f]/;
		733
		734	# try srv records, if applicable
		735	if ($node eq "localhost") {
		736	$resolve->(["127.0.0.1", $port], ["::1", $port]);
		737	} elsif (defined $service && !parse_address $node) {
		738	AnyEvent::DNS::srv $service, $proto, $node, sub {
		739	my (@srv) = @_;
		740
		741	if (@srv) {
		742	# the only srv record has "." ("" here) => abort
		743	$srv[0][2] ne "" \|\| $#srv
		744	or return $cb->();
		745
		746	# use srv records then
		747	$resolve->(
		748	map ["$_->[3].", $_->[2]],
		749	grep $_->[3] ne ".",
		750	@srv
		751	);
		752	} else {
		753	# no srv records, continue traditionally
		754	$resolve->([$node, $port]);
		755	}
		756	};
		757	} else {
		758	# most common case
		759	$resolve->([$node, $port]);
		760	}
261	}	761	}
262		762
263	=item $guard = tcp_connect $host, $service, $connect_cb[, $prepare_cb]	763	=item $guard = tcp_connect $host, $service, $connect_cb[, $prepare_cb]
264		764
265	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
266	non-blocking connect to the given C<$host> (which can be a hostname or a	766	100% non-blocking connect to the given C<$host> (which can be a DNS/IDN
		767	hostname or a textual IP address, or the string C<unix/> for UNIX domain
267	textual IP address) and C<$service> (which can be a numeric port number or	768	sockets) and C<$service> (which can be a numeric port number or a service
268	a service name, or a C<servicename=portnumber> string).	769	name, or a C<servicename=portnumber> string, or the pathname to a UNIX
		770	domain socket).
269		771
270	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
271	records to locate the real target(s).	773	records to locate the real target(s).
272		774
273	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
274	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
275	each in turn.	777	each in turn.
276		778
277	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
278	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
279	(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
280	respectively. The fourth argument is a code reference that you can call	782	arguments, respectively. The fourth argument is a code reference that you
281	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
282	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
283	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
284	ignore this argument.	786	simply ignore this argument.
285		787
286	$cb->($filehandle, $host, $port, $retry)	788	$cb->($filehandle, $host, $port, $retry)
287		789
288	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
289	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>
290	indicating a DNS resolution failure).	792	indicating a DNS resolution failure).
291		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
292	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
293	can be used as a normal perl file handle as well.	799	can be used as a normal perl file handle as well.
294		800
295	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
296	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
297	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.
298		806
299	Sometimes you need to "prepare" the socket before connecting, for example,	807	Sometimes you need to "prepare" the socket before connecting, for example,
300	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
301	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
302	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
…		…
305	timeout is to be used).	813	timeout is to be used).
306		814
307	Note that the socket could be either a IPv4 TCP socket or an IPv6 TCP	815	Note that the socket could be either a IPv4 TCP socket or an IPv6 TCP
308	socket (although only IPv4 is currently supported by this module).	816	socket (although only IPv4 is currently supported by this module).
309		817
		818	Note to the poor Microsoft Windows users: Windows (of course) doesn't
		819	correctly signal connection errors, so unless your event library works
		820	around this, failed connections will simply hang. The only event libraries
		821	that handle this condition correctly are L<EV> and L<Glib>. Additionally,
		822	AnyEvent works around this bug with L<Event> and in its pure-perl
		823	backend. All other libraries cannot correctly handle this condition. To
		824	lessen the impact of this windows bug, a default timeout of 30 seconds
		825	will be imposed on windows. Cygwin is not affected.
		826
310	Simple Example: connect to localhost on port 22.	827	Simple Example: connect to localhost on port 22.
311		828
312	tcp_connect localhost => 22, sub {	829	tcp_connect localhost => 22, sub {
313	my $fh = shift	830	my $fh = shift
314	or die "unable to connect: $!";	831	or die "unable to connect: $!";
315	# do something	832	# do something
316	};	833	};
317		834
318	Complex Example: connect to www.google.com on port 80 and make a simple	835	Complex Example: connect to www.google.com on port 80 and make a simple
319	GET request without much error handling. Also limit the connection timeout	836	GET request without much error handling. Also limit the connection timeout
320	to 15 seconds.	837	to 15 seconds.
321		838
…		…
325	or die "unable to connect: $!";	842	or die "unable to connect: $!";
326		843
327	my $handle; # avoid direct assignment so on_eof has it in scope.	844	my $handle; # avoid direct assignment so on_eof has it in scope.
328	$handle = new AnyEvent::Handle	845	$handle = new AnyEvent::Handle
329	fh => $fh,	846	fh => $fh,
		847	on_error => sub {
		848	warn "error $_[2]\n";
		849	$_[0]->destroy;
		850	},
330	on_eof => sub {	851	on_eof => sub {
331	undef $handle; # keep it alive till eof	852	$handle->destroy; # destroy handle
332	warn "done.\n";	853	warn "done.\n";
333	};	854	};
334		855
335	$handle->push_write ("GET / HTTP/1.0\015\012\015\012");	856	$handle->push_write ("GET / HTTP/1.0\015\012\015\012");
336		857
337	$handle->push_read_line ("\015\012\015\012", sub {	858	$handle->push_read (line => "\015\012\015\012", sub {
338	my ($handle, $line) = @_;	859	my ($handle, $line) = @_;
339		860
340	# print response header	861	# print response header
341	print "HEADER\n$line\n\nBODY\n";	862	print "HEADER\n$line\n\nBODY\n";
342		863
…		…
351	# could call $fh->bind etc. here	872	# could call $fh->bind etc. here
352		873
353	15	874	15
354	};	875	};
355		876
		877	Example: connect to a UNIX domain socket.
		878
		879	tcp_connect "unix/", "/tmp/.X11-unix/X0", sub {
		880	...
		881	}
		882
356	=cut	883	=cut
357		884
358	sub tcp_connect($$$;$) {	885	sub tcp_connect($$$;$) {
359	my ($host, $port, $connect, $prepare) = @_;	886	my ($host, $port, $connect, $prepare) = @_;
360		887
361	# see http://cr.yp.to/docs/connect.html for some background	888	# see http://cr.yp.to/docs/connect.html for some tricky aspects
		889	# also http://advogato.org/article/672.html
362		890
363	my %state = ( fh => undef );	891	my %state = ( fh => undef );
364		892
365	# name resolution	893	# name/service to type/sockaddr resolution
366	AnyEvent::DNS::addr $host, $port, 0, 0, 0, sub {	894	resolve_sockaddr $host, $port, 0, 0, undef, sub {
367	my @target = @_;	895	my @target = @_;
368		896
369	$state{next} = sub {	897	$state{next} = sub {
370	return unless exists $state{fh};	898	return unless exists $state{fh};
371		899
372	my $target = shift @target	900	my $target = shift @target
373	or do {	901	or return _postpone sub {
		902	return unless exists $state{fh};
374	%state = ();	903	%state = ();
375	return $connect->();	904	$connect->();
376	};	905	};
377		906
378	my ($domain, $type, $proto, $sockaddr) = @$target;	907	my ($domain, $type, $proto, $sockaddr) = @$target;
379		908
380	# socket creation	909	# socket creation
381	socket $state{fh}, $domain, $type, $proto	910	socket $state{fh}, $domain, $type, $proto
382	or return $state{next}();	911	or return $state{next}();
383		912
384	fh_nonblocking $state{fh}, 1;	913	fh_nonblocking $state{fh}, 1;
385		914
386	# prepare and optional timeout
387	if ($prepare) {
388	my $timeout = $prepare->($state{fh});	915	my $timeout = $prepare && $prepare->($state{fh});
389		916
		917	$timeout \|\|= 30 if AnyEvent::WIN32;
		918
390	$state{to} = AnyEvent->timer (after => $timeout, cb => sub {	919	$state{to} = AE::timer $timeout, 0, sub {
391	$! = &Errno::ETIMEDOUT;	920	$! = Errno::ETIMEDOUT;
392	$state{next}();	921	$state{next}();
393	}) if $timeout;	922	} if $timeout;
		923
		924	# now connect
		925	if (
		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)
394	}	932	) {
395		933	$state{ww} = AE::io $state{fh}, 1, sub {
396	# called when the connect was successful, which,
397	# in theory, could be the case immediately (but never is in practise)
398	my $connected = sub {
399	delete $state{ww};
400	delete $state{to};
401
402	# we are connected, or maybe there was an error	934	# we are connected, or maybe there was an error
403	if (my $sin = getpeername $state{fh}) {	935	if (my $sin = getpeername $state{fh}) {
404	my ($port, $host) = unpack_sockaddr $sin;	936	my ($port, $host) = unpack_sockaddr $sin;
405		937
		938	delete $state{ww}; delete $state{to};
		939
406	my $guard = guard {	940	my $guard = guard { %state = () };
407	%state = ();
408	};
409		941
410	$connect->($state{fh}, format_ip $host, $port, sub {	942	$connect->(delete $state{fh}, format_address $host, $port, sub {
411	$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 actually 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
412	$state{next}();	964	$state{next}();
413	});	965	}
414	} else {
415	# dummy read to fetch real error code
416	sysread $state{fh}, my $buf, 1 if $! == &Errno::ENOTCONN;
417	$state{next}();
418	}	966	};
419	};
420
421	# now connect
422	if (connect $state{fh}, $sockaddr) {
423	$connected->();
424	} elsif ($! == &Errno::EINPROGRESS \|\| $! == &Errno::EWOULDBLOCK) { # EINPROGRESS is POSIX
425	$state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $connected);
426	} else {	967	} else {
427	%state = ();	968	$state{next}();
428	$connect->();
429	}	969	}
430	};	970	};
431		971
432	$! = &Errno::ENXIO;	972	$! = Errno::ENXIO;
433	$state{next}();	973	$state{next}();
434	};	974	};
435		975
436	defined wantarray && guard { %state = () }	976	defined wantarray && guard { %state = () }
437	}	977	}
438		978
439	=item $guard = tcp_server $host, $port, $accept_cb[, $prepare_cb]	979	=item $guard = tcp_server $host, $service, $accept_cb[, $prepare_cb]
440		980
441	Create and bind a TCP socket to the given host (any IPv4 host if undef,	981	Create and bind a stream socket to the given host, and port, set the
442	otherwise it must be an IPv4 or IPv6 address) and port (service name or	982	SO_REUSEADDR flag (if applicable) and call C<listen>. Unlike the name
443	numeric port number, or an ephemeral port if given as zero or undef), set	983	implies, this function can also bind on UNIX domain sockets.
444	the SO_REUSEADDR flag and call C<listen>.
445		984
		985	For internet sockets, C<$host> must be an IPv4 or IPv6 address (or
		986	C<undef>, in which case it binds either to C<0> or to C<::>, depending
		987	on whether IPv4 or IPv6 is the preferred protocol, and maybe to both in
		988	future versions, as applicable).
		989
		990	To bind to the IPv4 wildcard address, use C<0>, to bind to the IPv6
		991	wildcard address, use C<::>.
		992
		993	The port is specified by C<$service>, which must be either a service name or
		994	a numeric port number (or C<0> or C<undef>, in which case an ephemeral
		995	port will be used).
		996
		997	For UNIX domain sockets, C<$host> must be C<unix/> and C<$service> must be
		998	the absolute pathname of the socket. This function will try to C<unlink>
		999	the socket before it tries to bind to it. See SECURITY CONSIDERATIONS,
		1000	below.
		1001
446	For each new connection that could be C<accept>ed, call the C<$accept_cb>	1002	For each new connection that could be C<accept>ed, call the C<<
447	with the file handle (in non-blocking mode) as first and the peer host and	1003	$accept_cb->($fh, $host, $port) >> with the file handle (in non-blocking
448	port as second and third arguments (see C<tcp_connect> for details).	1004	mode) as first, and the peer host and port as second and third arguments
		1005	(see C<tcp_connect> for details).
449		1006
450	Croaks on any errors.	1007	Croaks on any errors it can detect before the listen.
451		1008
452	If called in non-void context, then this function returns a guard object	1009	If called in non-void context, then this function returns a guard object
453	whose lifetime it tied to the TCP server: If the object gets destroyed,	1010	whose lifetime it tied to the TCP server: If the object gets destroyed,
454	the server will be stopped (but existing accepted connections will	1011	the server will be stopped (but existing accepted connections will
455	continue).	1012	not be affected).
456		1013
457	If you need more control over the listening socket, you can provide a	1014	If you need more control over the listening socket, you can provide a
458	C<$prepare_cb>, which is called just before the C<listen ()> call, with	1015	C<< $prepare_cb->($fh, $host, $port) >>, which is called just before the
459	the listen file handle as first argument.	1016	C<listen ()> call, with the listen file handle as first argument, and IP
		1017	address and port number of the local socket endpoint as second and third
		1018	arguments.
460		1019
461	It should return the length of the listen queue (or C<0> for the default).	1020	It should return the length of the listen queue (or C<0> for the default).
462		1021
		1022	Note to IPv6 users: RFC-compliant behaviour for IPv6 sockets listening on
		1023	C<::> is to bind to both IPv6 and IPv4 addresses by default on dual-stack
		1024	hosts. Unfortunately, only GNU/Linux seems to implement this properly, so
		1025	if you want both IPv4 and IPv6 listening sockets you should create the
		1026	IPv6 socket first and then attempt to bind on the IPv4 socket, but ignore
		1027	any C<EADDRINUSE> errors.
		1028
463	Example: bind on TCP port 8888 on the local machine and tell each client	1029	Example: bind on some TCP port on the local machine and tell each client
464	to go away.	1030	to go away.
465		1031
466	tcp_server undef, 8888, sub {	1032	tcp_server undef, undef, sub {
467	my ($fh, $host, $port) = @_;	1033	my ($fh, $host, $port) = @_;
468		1034
469	syswrite $fh, "The internet is full, $host:$port. Go away!\015\012";	1035	syswrite $fh, "The internet is full, $host:$port. Go away!\015\012";
		1036	}, sub {
		1037	my ($fh, $thishost, $thisport) = @_;
		1038	warn "bound to $thishost, port $thisport\n";
470	};	1039	};
471		1040
		1041	Example: bind a server on a unix domain socket.
		1042
		1043	tcp_server "unix/", "/tmp/mydir/mysocket", sub {
		1044	my ($fh) = @_;
		1045	};
		1046
472	=cut	1047	=cut
473		1048
474	sub tcp_server($$$;$) {	1049	sub tcp_server($$$;$) {
475	my ($host, $port, $accept, $prepare) = @_;	1050	my ($host, $service, $accept, $prepare) = @_;
		1051
		1052	$host = $AnyEvent::PROTOCOL{ipv4} < $AnyEvent::PROTOCOL{ipv6} && AF_INET6
		1053	? "::" : "0"
		1054	unless defined $host;
		1055
		1056	my $ipn = parse_address $host
		1057	or Carp::croak "AnyEvent::Socket::tcp_server: cannot parse '$host' as host address";
		1058
		1059	my $af = address_family $ipn;
476		1060
477	my %state;	1061	my %state;
478		1062
479	socket $state{fh}, &Socket::AF_INET, &Socket::SOCK_STREAM, 0	1063	# win32 perl is too stupid to get this right :/
		1064	Carp::croak "tcp_server/socket: address family not supported"
		1065	if AnyEvent::WIN32 && $af == AF_UNIX;
		1066
		1067	socket $state{fh}, $af, SOCK_STREAM, 0
480	or Carp::croak "socket: $!";	1068	or Carp::croak "tcp_server/socket: $!";
481		1069
		1070	if ($af == AF_INET \|\| $af == AF_INET6) {
482	setsockopt $state{fh}, &Socket::SOL_SOCKET, &Socket::SO_REUSEADDR, 1	1071	setsockopt $state{fh}, SOL_SOCKET, SO_REUSEADDR, 1
483	or Carp::croak "so_reuseaddr: $!";	1072	or Carp::croak "tcp_server/so_reuseaddr: $!"
		1073	unless AnyEvent::WIN32; # work around windows bug
484		1074
485	bind $state{fh}, Socket::pack_sockaddr_in _tcp_port $port, socket_inet_aton ($host \|\| "0.0.0.0")	1075	unless ($service =~ /^\d*$/) {
		1076	$service = (getservbyname $service, "tcp")[2]
		1077	or Carp::croak "$service: service unknown"
		1078	}
		1079	} elsif ($af == AF_UNIX) {
		1080	unlink $service;
		1081	}
		1082
		1083	bind $state{fh}, pack_sockaddr $service, $ipn
486	or Carp::croak "bind: $!";	1084	or Carp::croak "bind: $!";
487		1085
488	fh_nonblocking $state{fh}, 1;	1086	fh_nonblocking $state{fh}, 1;
489		1087
490	my $len = ($prepare && $prepare->($state{fh})) \|\| 128;	1088	my $len;
		1089
		1090	if ($prepare) {
		1091	my ($service, $host) = unpack_sockaddr getsockname $state{fh};
		1092	$len = $prepare && $prepare->($state{fh}, format_address $host, $service);
		1093	}
		1094
		1095	$len \|\|= 128;
491		1096
492	listen $state{fh}, $len	1097	listen $state{fh}, $len
493	or Carp::croak "listen: $!";	1098	or Carp::croak "listen: $!";
494		1099
495	$state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub {	1100	$state{aw} = AE::io $state{fh}, 0, sub {
496	# this closure keeps $state alive	1101	# this closure keeps $state alive
497	while (my $peer = accept my $fh, $state{fh}) {	1102	while ($state{fh} && (my $peer = accept my $fh, $state{fh})) {
498	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
		1104
499	my ($port, $host) = Socket::unpack_sockaddr_in $peer;	1105	my ($service, $host) = unpack_sockaddr $peer;
500	$accept->($fh, (Socket::inet_ntoa $host), $port);	1106	$accept->($fh, format_address $host, $service);
501	}	1107	}
502	});	1108	};
503		1109
504	defined wantarray	1110	defined wantarray
505	? guard { %state = () } # clear fh and watcher, which breaks the circular dependency	1111	? guard { %state = () } # clear fh and watcher, which breaks the circular dependency
506	: ()	1112	: ()
507	}	1113	}
508		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 avoidance algorithm (via the C<TCP_CONGESTION>
		1131	socket option). The default is OS-specific, but is usually
		1132	C<reno>. Typical other available choices include C<cubic>, C<lp>, C<bic>,
		1133	C<highspeed>, C<htcp>, C<hybla>, C<illinois>, C<scalable>, C<vegas>,
		1134	C<veno>, C<westwood> and C<yeah>.
		1135
		1136	=cut
		1137
		1138	sub tcp_congestion($$) {
		1139	defined TCP_CONGESTION
		1140	? setsockopt $_[0], Socket::IPPROTO_TCP (), TCP_CONGESTION, "$_[1]"
		1141	: undef
		1142	}
		1143
509	1;	1144	1;
510		1145
511	=back	1146	=back
		1147
		1148	=head1 SECURITY CONSIDERATIONS
		1149
		1150	This module is quite powerful, with with power comes the ability to abuse
		1151	as well: If you accept "hostnames" and ports from untrusted sources,
		1152	then note that this can be abused to delete files (host=C<unix/>). This
		1153	is not really a problem with this module, however, as blindly accepting
		1154	any address and protocol and trying to bind a server or connect to it is
		1155	harmful in general.
512		1156
513	=head1 AUTHOR	1157	=head1 AUTHOR
514		1158
515	Marc Lehmann <schmorp@schmorp.de>	1159	Marc Lehmann <schmorp@schmorp.de>
516	http://home.schmorp.de/	1160	http://home.schmorp.de/

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents): Revision 1.18 by root, Sat May 24 18:50:40 2008 UTC vs. Revision 1.130 by root, Fri Jan 14 17:43:11 2011 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.18 by root, Sat May 24 18:50:40 2008 UTC vs.
Revision 1.130 by root, Fri Jan 14 17:43:11 2011 UTC