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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.16 by root, Sat May 24 02:13:20 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
		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
…		…
19		33
20	=cut	34	=cut
21		35
22	package AnyEvent::Socket;	36	package AnyEvent::Socket;
23		37
24	no warnings;
25	use strict;
26
27	use Carp ();	38	use Carp ();
28	use Errno ();	39	use Errno ();
29	use Socket ();	40	use Socket qw(AF_INET AF_UNIX SOCK_STREAM SOCK_DGRAM SOL_SOCKET SO_REUSEADDR);
30		41
31	use AnyEvent ();	42	use AnyEvent (); BEGIN { AnyEvent::common_sense }
32	use AnyEvent::Util qw(guard fh_nonblocking);	43	use AnyEvent::Util qw(guard fh_nonblocking AF_INET6);
		44	use AnyEvent::DNS ();
33		45
34	use base 'Exporter';	46	use base 'Exporter';
35		47
36	BEGIN {	48	our @EXPORT = qw(
37	*socket_inet_aton = \&Socket::inet_aton; # take a copy, in case Coro::LWP overrides it	49	getprotobyname
38	}	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	);
39		60
40	BEGIN {	61	our $VERSION = $AnyEvent::VERSION;
41	my $af_inet6 = eval { &Socket::AF_INET6 };
42	eval "sub AF_INET6() { $af_inet6 }"; die if $@;
43		62
44	delete $AnyEvent::PROTOCOL{ipv6} unless $af_inet6;	63	# used in cases where we may return immediately but want the
45	}	64	# caller to do stuff first
		65	sub _postpone {
		66	my ($cb, @args) = (@_, $!);
46		67
47	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 {
48		69	undef $w;
49	our $VERSION = '1.0';	70	$! = pop @args;
		71	$cb->(@args);
		72	};
		73	}
50		74
51	=item $ipn = parse_ipv4 $dotted_quad	75	=item $ipn = parse_ipv4 $dotted_quad
52		76
53	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
54	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
…		…
66		90
67	# check leading parts against range	91	# check leading parts against range
68	return undef if grep $_ >= 256, @_[0 .. @_ - 2];	92	return undef if grep $_ >= 256, @_[0 .. @_ - 2];
69		93
70	# check trailing part against range	94	# check trailing part against range
71	return undef if $_[-1] >= 1 << (8 * (4 - $#_));	95	return undef if $_[-1] >= 2 ** (8 * (4 - $#_));
72		96
73	pack "N", (pop)	97	pack "N", (pop)
74	+ ($_[0] << 24)	98	+ ($_[0] << 24)
75	+ ($_[1] << 16)	99	+ ($_[1] << 16)
76	+ ($_[2] << 8);	100	+ ($_[2] << 8);
…		…
80		104
81	Tries to parse the given IPv6 address and return it in	105	Tries to parse the given IPv6 address and return it in
82	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).
83		107
84	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
85	forms supported by parse_ipv4).	109	forms supported by parse_ipv4). Note that scope-id's are not supported
		110	(and will not parse).
86		111
87	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
88		118
89	=cut	119	=cut
90		120
91	sub parse_ipv6($) {	121	sub parse_ipv6($) {
92	# quick test to avoid longer processing	122	# quick test to avoid longer processing
…		…
123		153
124	# and done	154	# and done
125	pack "n*", map hex, @h, @t	155	pack "n*", map hex, @h, @t
126	}	156	}
127		157
128	=item $ipn = parse_ip $text	158	sub parse_unix($) {
		159	$_[0] eq "unix/"
		160	? pack "S", AF_UNIX
		161	: undef
129		162
		163	}
		164
		165	=item $ipn = parse_address $ip
		166
130	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).
131		170
132	=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".
133		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
134	sub parse_ip($) {	191	sub parse_address($) {
135	&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	}
136	}	200	}
137		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
138	=item $text = format_ip $ipn	342	=item $text = format_ipv4 $ipn
139		343
140	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
141	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.
142		360
143	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, ...>,
144	except it automatically detects the address type.	362	except it automatically detects the address type.
145		363
146	=cut	364	Returns C<undef> if it cannot detect the type.
147		365
148	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
149	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($) {
150	if (4 == length $_[0]) {	418	if (4 == length $_[0]) {
151	return join ".", unpack "C4", $_[0]	419	return &format_ipv4;
152	} elsif (16 == length $_[0]) {	420	} elsif (16 == length $_[0]) {
153	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
154	# v4mapped	422	? format_ipv4 $1
155	return "::ffff:" . format_ip substr $_[0], 12;	423	: &format_ipv6;
156	} else {	424	} elsif (AF_UNIX == address_family $_[0]) {
157	my $ip = sprintf "%x:%x:%x:%x:%x:%x:%x:%x", unpack "n8", $_[0];	425	return "unix/"
158
159	$ip =~ s/^0:(?:0:)*/::/
160	or $ip =~ s/(:0)+$/::/
161	or $ip =~ s/(:0)+/:/;
162	return $ip
163	}
164	} else {	426	} else {
165	return undef	427	return undef
166	}	428	}
167	}	429	}
168		430
		431	*ntoa = \&format_address;
		432
169	=item inet_aton $name_or_address, $cb->(@addresses)	433	=item inet_aton $name_or_address, $cb->(@addresses)
170		434
171	Works similarly to its Socket counterpart, except that it uses a	435	Works similarly to its Socket counterpart, except that it uses a
172	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
173	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
174	for IPv6).	438	readable format.
175		439
176	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,
177	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
178		457
179	=cut	458	=cut
180		459
181	sub inet_aton {	460	sub inet_aton {
182	my ($name, $cb) = @_;	461	my ($name, $cb) = @_;
…		…
188	} elsif ($name eq "localhost") { # rfc2606 et al.	467	} elsif ($name eq "localhost") { # rfc2606 et al.
189	$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);
190	} else {	469	} else {
191	require AnyEvent::DNS;	470	require AnyEvent::DNS;
192		471
193	# 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;
194	AnyEvent::DNS::a ($name, sub {	485	AnyEvent::DNS::a ($name, sub {
195	if (@_) {	486	$res[$ipv4] = [map &parse_ipv4, @_];
196	$cb->(map +(parse_ipv4 $_), @_);
197	} else {
198	$cb->();	487	$cv->end;
199	#AnyEvent::DNS::aaaa ($name, $cb); need inet_pton
200	}	488	});
201	});	489	};
202	}
203	}
204		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
205	=item $sa = AnyEvent::Socket::pack_sockaddr $port, $host	520	=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host
206		521
207	Pack the given port/hst combination into a binary sockaddr structure. Handles	522	Pack the given port/host combination into a binary sockaddr
208	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: $!";
209		532
210	=cut	533	=cut
211		534
212	sub pack_sockaddr($$) {	535	sub pack_sockaddr($$) {
213	if (4 == length $_[1]) {	536	my $af = address_family $_[1];
		537
		538	if ($af == AF_INET) {
214	Socket::pack_sockaddr_in $_[0], $_[1]	539	Socket::pack_sockaddr_in $_[0], $_[1]
215	} elsif (16 == length $_[1]) {	540	} elsif ($af == AF_INET6) {
216	pack "SnL a16 L",	541	pack "$pack_family nL a16 L",
217	Socket::AF_INET6,	542	AF_INET6,
218	$_[0], # port	543	$_[0], # port
219	0, # flowinfo	544	0, # flowinfo
220	$_[1], # addr	545	$_[1], # addr
221	0 # scope id	546	0 # scope id
		547	} elsif ($af == AF_UNIX) {
		548	Socket::pack_sockaddr_un $_[0]
222	} else {	549	} else {
223	Carp::croak "pack_sockaddr: invalid host";	550	Carp::croak "pack_sockaddr: invalid host";
224	}	551	}
225	}	552	}
226		553
227	=item ($port, $host) = AnyEvent::Socket::unpack_sockaddr $sa	554	=item ($service, $host) = AnyEvent::Socket::unpack_sockaddr $sa
228		555
229	Unpack the given binary sockaddr structure (as used by bind, getpeername	556	Unpack the given binary sockaddr structure (as used by bind, getpeername
230	etc.) into a C<$port, $host> combination.	557	etc.) into a C<$service, $host> combination.
231		558
232	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).
233		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
234	=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;
235		573
236	sub unpack_sockaddr($) {	574	sub unpack_sockaddr($) {
237	my $af = unpack "S", $_[0];	575	my $af = sockaddr_family $_[0];
238		576
239	if ($af == &Socket::AF_INET) {	577	if ($af == AF_INET) {
240	Socket::unpack_sockaddr_in $_[0]	578	Socket::unpack_sockaddr_in $_[0]
241	} elsif ($af == AF_INET6) {	579	} elsif ($af == AF_INET6) {
242	(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)
243	} else {	583	} else {
244	Carp::croak "unpack_sockaddr: unsupported protocol family $af";	584	Carp::croak "unpack_sockaddr: unsupported protocol family $af";
245	}	585	}
246	}	586	}
247		587
248	sub _tcp_port($) {	588	=item resolve_sockaddr $node, $service, $proto, $family, $type, $cb->([$family, $type, $proto, $sockaddr], ...)
249	$_[0] =~ /^(\d)$/ and return $11;
250		589
251	(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
252	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	}
253	}	761	}
254		762
255	=item $guard = tcp_connect $host, $service, $connect_cb[, $prepare_cb]	763	=item $guard = tcp_connect $host, $service, $connect_cb[, $prepare_cb]
256		764
257	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
258	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
259	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
260	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).
261		771
262	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
263	records to locate the real target(s).	773	records to locate the real target(s).
264		774
265	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
266	hosts or hosts with both IPv4 and IPV6 addrsesses) and try to connetc to	776	hosts or hosts with both IPv4 and IPv6 addresses) and try to connect to
267	each in turn.	777	each in turn.
268		778
269	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
270	the socket filehandle (in non-blocking mode) as first and the peer host	780	invoked with the socket file handle (in non-blocking mode) as first, and
271	(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
272	respectively. The fourth argument is a code reference that you can call	782	arguments, respectively. The fourth argument is a code reference that you
273	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
274	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
275	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
276	ignore this argument.	786	simply ignore this argument.
277		787
278	$cb->($filehandle, $host, $port, $retry)	788	$cb->($filehandle, $host, $port, $retry)
279		789
280	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
281	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>
282	indicating a dns resolution failure).	792	indicating a DNS resolution failure).
283		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
284	The filehandle is suitable to be plugged into L<AnyEvent::Handle>, but can	798	The file handle is perfect for being plugged into L<AnyEvent::Handle>, but
285	be used as a normal perl file handle as well.	799	can be used as a normal perl file handle as well.
286		800
287	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
288	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
289	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.
290		806
291	Sometimes you need to "prepare" the socket before connecting, for example,	807	Sometimes you need to "prepare" the socket before connecting, for example,
292	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
293	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
294	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
295	in not-yet-connected state as only argument and must return the connection	811	in not-yet-connected state as only argument and must return the connection
296	timeout value (or C<0>, C<undef> or the empty list to indicate the default	812	timeout value (or C<0>, C<undef> or the empty list to indicate the default
297	timeout is to be used).	813	timeout is to be used).
298		814
299	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
300	socket (although only IPv4 is currently supported by this module).	816	socket (although only IPv4 is currently supported by this module).
301		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
302	Simple Example: connect to localhost on port 22.	827	Simple Example: connect to localhost on port 22.
303		828
304	tcp_connect localhost => 22, sub {	829	tcp_connect localhost => 22, sub {
305	my $fh = shift	830	my $fh = shift
306	or die "unable to connect: $!";	831	or die "unable to connect: $!";
307	# do something	832	# do something
308	};	833	};
309		834
310	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
311	GET request without much error handling. Also limit the connection timeout	836	GET request without much error handling. Also limit the connection timeout
312	to 15 seconds.	837	to 15 seconds.
313		838
…		…
317	or die "unable to connect: $!";	842	or die "unable to connect: $!";
318		843
319	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.
320	$handle = new AnyEvent::Handle	845	$handle = new AnyEvent::Handle
321	fh => $fh,	846	fh => $fh,
		847	on_error => sub {
		848	warn "error $_[2]\n";
		849	$_[0]->destroy;
		850	},
322	on_eof => sub {	851	on_eof => sub {
323	undef $handle; # keep it alive till eof	852	$handle->destroy; # destroy handle
324	warn "done.\n";	853	warn "done.\n";
325	};	854	};
326		855
327	$handle->push_write ("GET / HTTP/1.0\015\012\015\012");	856	$handle->push_write ("GET / HTTP/1.0\015\012\015\012");
328		857
329	$handle->push_read_line ("\015\012\015\012", sub {	858	$handle->push_read (line => "\015\012\015\012", sub {
330	my ($handle, $line) = @_;	859	my ($handle, $line) = @_;
331		860
332	# print response header	861	# print response header
333	print "HEADER\n$line\n\nBODY\n";	862	print "HEADER\n$line\n\nBODY\n";
334		863
…		…
343	# could call $fh->bind etc. here	872	# could call $fh->bind etc. here
344		873
345	15	874	15
346	};	875	};
347		876
		877	Example: connect to a UNIX domain socket.
		878
		879	tcp_connect "unix/", "/tmp/.X11-unix/X0", sub {
		880	...
		881	}
		882
348	=cut	883	=cut
349		884
350	sub tcp_connect($$$;$) {	885	sub tcp_connect($$$;$) {
351	my ($host, $port, $connect, $prepare) = @_;	886	my ($host, $port, $connect, $prepare) = @_;
352		887
353	# 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
354		890
355	my %state = ( fh => undef );	891	my %state = ( fh => undef );
356		892
357	# name resolution	893	# name/service to type/sockaddr resolution
358	AnyEvent::DNS::addr $host, $port, 0, 0, 0, sub {	894	resolve_sockaddr $host, $port, 0, 0, undef, sub {
359	my @target = @_;	895	my @target = @_;
360		896
361	$state{next} = sub {	897	$state{next} = sub {
362	return unless exists $state{fh};	898	return unless exists $state{fh};
363		899
364	my $target = shift @target	900	my $target = shift @target
365	or do {	901	or return _postpone sub {
		902	return unless exists $state{fh};
366	%state = ();	903	%state = ();
367	return $connect->();	904	$connect->();
368	};	905	};
369		906
370	my ($domain, $type, $proto, $sockaddr) = @$target;	907	my ($domain, $type, $proto, $sockaddr) = @$target;
371		908
372	# socket creation	909	# socket creation
373	socket $state{fh}, $domain, $type, $proto	910	socket $state{fh}, $domain, $type, $proto
374	or return $state{next}();	911	or return $state{next}();
375		912
376	fh_nonblocking $state{fh}, 1;	913	fh_nonblocking $state{fh}, 1;
377		914
378	# prepare and optional timeout
379	if ($prepare) {
380	my $timeout = $prepare->($state{fh});	915	my $timeout = $prepare && $prepare->($state{fh});
381		916
		917	$timeout \|\|= 30 if AnyEvent::WIN32;
		918
382	$state{to} = AnyEvent->timer (after => $timeout, cb => sub {	919	$state{to} = AE::timer $timeout, 0, sub {
383	$! = &Errno::ETIMEDOUT;	920	$! = Errno::ETIMEDOUT;
384	$state{next}();	921	$state{next}();
385	}) 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)
386	}	932	) {
387		933	$state{ww} = AE::io $state{fh}, 1, sub {
388	# called when the connect was successful, which,
389	# in theory, could be the case immediately (but never is in practise)
390	my $connected = sub {
391	delete $state{ww};
392	delete $state{to};
393
394	# we are connected, or maybe there was an error	934	# we are connected, or maybe there was an error
395	if (my $sin = getpeername $state{fh}) {	935	if (my $sin = getpeername $state{fh}) {
396	my ($port, $host) = unpack_sockaddr $sin;	936	my ($port, $host) = unpack_sockaddr $sin;
397		937
		938	delete $state{ww}; delete $state{to};
		939
398	my $guard = guard {	940	my $guard = guard { %state = () };
399	%state = ();
400	};
401		941
402	$connect->($state{fh}, format_ip $host, $port, sub {	942	$connect->(delete $state{fh}, format_address $host, $port, sub {
403	$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
404	$state{next}();	964	$state{next}();
405	});	965	}
406	} else {
407	# dummy read to fetch real error code
408	sysread $state{fh}, my $buf, 1 if $! == &Errno::ENOTCONN;
409	$state{next}();
410	}	966	};
411	};
412
413	# now connect
414	if (connect $state{fh}, $sockaddr) {
415	$connected->();
416	} elsif ($! == &Errno::EINPROGRESS \|\| $! == &Errno::EWOULDBLOCK) { # EINPROGRESS is POSIX
417	$state{ww} = AnyEvent->io (fh => $state{fh}, poll => 'w', cb => $connected);
418	} else {	967	} else {
419	%state = ();	968	$state{next}();
420	$connect->();
421	}	969	}
422	};	970	};
423		971
424	$! = &Errno::ENXIO;	972	$! = Errno::ENXIO;
425	$state{next}();	973	$state{next}();
426	};	974	};
427		975
428	defined wantarray && guard { %state = () }	976	defined wantarray && guard { %state = () }
429	}	977	}
430		978
431	=item $guard = tcp_server $host, $port, $accept_cb[, $prepare_cb]	979	=item $guard = tcp_server $host, $service, $accept_cb[, $prepare_cb]
432		980
433	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
434	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
435	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.
436	the SO_REUSEADDR flag and call C<listen>.
437		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
438	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<<
439	with the filehandle (in non-blocking mode) as first and the peer host and	1003	$accept_cb->($fh, $host, $port) >> with the file handle (in non-blocking
440	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).
441		1006
442	Croaks on any errors.	1007	Croaks on any errors it can detect before the listen.
443		1008
444	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
445	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,
446	the server will be stopped (but existing accepted connections will	1011	the server will be stopped (but existing accepted connections will
447	continue).	1012	not be affected).
448		1013
449	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
450	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
451	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.
452		1019
453	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).
454		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
455	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
456	to go away.	1030	to go away.
457		1031
458	tcp_server undef, 8888, sub {	1032	tcp_server undef, undef, sub {
459	my ($fh, $host, $port) = @_;	1033	my ($fh, $host, $port) = @_;
460		1034
461	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";
462	};	1039	};
463		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
464	=cut	1047	=cut
465		1048
466	sub tcp_server($$$;$) {	1049	sub tcp_server($$$;$) {
467	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;
468		1060
469	my %state;	1061	my %state;
470		1062
471	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
472	or Carp::croak "socket: $!";	1068	or Carp::croak "tcp_server/socket: $!";
473		1069
		1070	if ($af == AF_INET \|\| $af == AF_INET6) {
474	setsockopt $state{fh}, &Socket::SOL_SOCKET, &Socket::SO_REUSEADDR, 1	1071	setsockopt $state{fh}, SOL_SOCKET, SO_REUSEADDR, 1
475	or Carp::croak "so_reuseaddr: $!";	1072	or Carp::croak "tcp_server/so_reuseaddr: $!"
		1073	unless AnyEvent::WIN32; # work around windows bug
476		1074
477	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
478	or Carp::croak "bind: $!";	1084	or Carp::croak "bind: $!";
479		1085
480	fh_nonblocking $state{fh}, 1;	1086	fh_nonblocking $state{fh}, 1;
481		1087
482	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;
483		1096
484	listen $state{fh}, $len	1097	listen $state{fh}, $len
485	or Carp::croak "listen: $!";	1098	or Carp::croak "listen: $!";
486		1099
487	$state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub {	1100	$state{aw} = AE::io $state{fh}, 0, sub {
488	# this closure keeps $state alive	1101	# this closure keeps $state alive
489	while (my $peer = accept my $fh, $state{fh}) {	1102	while ($state{fh} && (my $peer = accept my $fh, $state{fh})) {
490	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
491	my ($port, $host) = Socket::unpack_sockaddr_in $peer;	1105	my ($service, $host) = unpack_sockaddr $peer;
492	$accept->($fh, (Socket::inet_ntoa $host), $port);	1106	$accept->($fh, format_address $host, $service);
493	}	1107	}
494	});	1108	};
495		1109
496	defined wantarray	1110	defined wantarray
497	? guard { %state = () } # clear fh and watcher, which breaks the circular dependency	1111	? guard { %state = () } # clear fh and watcher, which breaks the circular dependency
498	: ()	1112	: ()
499	}	1113	}
500		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
501	1;	1144	1;
502		1145
503	=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.
504		1156
505	=head1 AUTHOR	1157	=head1 AUTHOR
506		1158
507	Marc Lehmann <schmorp@schmorp.de>	1159	Marc Lehmann <schmorp@schmorp.de>
508	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.16 by root, Sat May 24 02:13:20 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.16 by root, Sat May 24 02:13:20 2008 UTC vs.
Revision 1.130 by root, Fri Jan 14 17:43:11 2011 UTC