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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.9 by root, Fri May 23 19:46:38 2008 UTC vs.
Revision 1.48 by root, Thu Jun 5 18:30:08 2008 UTC

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

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents): Revision 1.9 by root, Fri May 23 19:46:38 2008 UTC vs. Revision 1.48 by root, Thu Jun 5 18:30:08 2008 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.9 by root, Fri May 23 19:46:38 2008 UTC vs.
Revision 1.48 by root, Thu Jun 5 18:30:08 2008 UTC