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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.10 by root, Fri May 23 19:52:29 2008 UTC vs.
Revision 1.36 by root, Wed May 28 21:29:03 2008 UTC

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

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents): Revision 1.10 by root, Fri May 23 19:52:29 2008 UTC vs. Revision 1.36 by root, Wed May 28 21:29:03 2008 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.10 by root, Fri May 23 19:52:29 2008 UTC vs.
Revision 1.36 by root, Wed May 28 21:29:03 2008 UTC