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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.2 by elmex, Sun Apr 27 19:00:33 2008 UTC vs.
Revision 1.60 by root, Thu Aug 21 18:45:16 2008 UTC

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

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents): Revision 1.2 by elmex, Sun Apr 27 19:00:33 2008 UTC vs. Revision 1.60 by root, Thu Aug 21 18:45:16 2008 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.2 by elmex, Sun Apr 27 19:00:33 2008 UTC vs.
Revision 1.60 by root, Thu Aug 21 18:45:16 2008 UTC