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

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

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents): Revision 1.5 by elmex, Mon Apr 28 09:27:47 2008 UTC vs. Revision 1.114 by root, Fri Aug 21 11:59:25 2009 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.5 by elmex, Mon Apr 28 09:27:47 2008 UTC vs.
Revision 1.114 by root, Fri Aug 21 11:59:25 2009 UTC