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

Comparing AnyEvent/lib/AnyEvent/Handle.pm (file contents):
Revision 1.8 by root, Fri May 2 15:36:10 2008 UTC vs.
Revision 1.28 by root, Sat May 24 22:27:11 2008 UTC

…		…
10	use Fcntl ();	10	use Fcntl ();
11	use Errno qw/EAGAIN EINTR/;	11	use Errno qw/EAGAIN EINTR/;
12		12
13	=head1 NAME	13	=head1 NAME
14		14
15	AnyEvent::Handle - non-blocking I/O on filehandles via AnyEvent	15	AnyEvent::Handle - non-blocking I/O on file handles via AnyEvent
16		16
17	=cut	17	This module is experimental.
18		18
		19	=cut
		20
19	our $VERSION = '0.02';	21	our $VERSION = '0.04';
20		22
21	=head1 SYNOPSIS	23	=head1 SYNOPSIS
22		24
23	use AnyEvent;	25	use AnyEvent;
24	use AnyEvent::Handle;	26	use AnyEvent::Handle;
…		…
43	$cv->wait;	45	$cv->wait;
44		46
45	=head1 DESCRIPTION	47	=head1 DESCRIPTION
46		48
47	This module is a helper module to make it easier to do event-based I/O on	49	This module is a helper module to make it easier to do event-based I/O on
48	filehandles (and sockets, see L<AnyEvent::Socket> for an easy way to make	50	filehandles. For utility functions for doing non-blocking connects and accepts
49	non-blocking resolves and connects).	51	on sockets see L<AnyEvent::Util>.
50		52
51	In the following, when the documentation refers to of "bytes" then this	53	In the following, when the documentation refers to of "bytes" then this
52	means characters. As sysread and syswrite are used for all I/O, their	54	means characters. As sysread and syswrite are used for all I/O, their
53	treatment of characters applies to this module as well.	55	treatment of characters applies to this module as well.
54		56
…		…
70	The filehandle this L<AnyEvent::Handle> object will operate on.	72	The filehandle this L<AnyEvent::Handle> object will operate on.
71		73
72	NOTE: The filehandle will be set to non-blocking (using	74	NOTE: The filehandle will be set to non-blocking (using
73	AnyEvent::Util::fh_nonblocking).	75	AnyEvent::Util::fh_nonblocking).
74		76
		77	=item on_eof => $cb->($self)
		78
		79	Set the callback to be called on EOF.
		80
		81	While not mandatory, it is highly recommended to set an eof callback,
		82	otherwise you might end up with a closed socket while you are still
		83	waiting for data.
		84
75	=item on_error => $cb->($self) [MANDATORY]	85	=item on_error => $cb->($self)
76		86
77	This is the fatal error callback, that is called when a fatal error ocurs,	87	This is the fatal error callback, that is called when, well, a fatal error
78	such as not being able to resolve the hostname, failure to connect or a	88	occurs, such as not being able to resolve the hostname, failure to connect
79	read error.	89	or a read error.
80		90
81	The object will not be in a usable state when this callback has been	91	The object will not be in a usable state when this callback has been
82	called.	92	called.
83		93
84	On callback entrance, the value of C<$!> contains the opertaing system	94	On callback entrance, the value of C<$!> contains the operating system
85	error (or C<ENOSPC> or C<EPIPE>).	95	error (or C<ENOSPC> or C<EPIPE>).
86		96
87	=item on_eof => $cb->($self) [MANDATORY]	97	While not mandatory, it is I<highly> recommended to set this callback, as
88		98	you will not be notified of errors otherwise. The default simply calls
89	Set the callback to be called on EOF.	99	die.
90		100
91	=item on_read => $cb->($self)	101	=item on_read => $cb->($self)
92		102
93	This sets the default read callback, which is called when data arrives	103	This sets the default read callback, which is called when data arrives
94	and no read request is in the queue. If the read callback is C<undef>	104	and no read request is in the queue.
95	or has never been set, than AnyEvent::Handle will cease reading from the
96	filehandle.
97		105
98	To access (and remove data from) the read buffer, use the C<< ->rbuf >>	106	To access (and remove data from) the read buffer, use the C<< ->rbuf >>
99	method or acces sthe C<$self->{rbuf}> member directly.	107	method or access the C<$self->{rbuf}> member directly.
100		108
101	When an EOF condition is detected then AnyEvent::Handle will first try to	109	When an EOF condition is detected then AnyEvent::Handle will first try to
102	feed all the remaining data to the queued callbacks and C<on_read> before	110	feed all the remaining data to the queued callbacks and C<on_read> before
103	calling the C<on_eof> callback. If no progress can be made, then a fatal	111	calling the C<on_eof> callback. If no progress can be made, then a fatal
104	error will be raised (with C<$!> set to C<EPIPE>).	112	error will be raised (with C<$!> set to C<EPIPE>).
…		…
131		139
132	Sets the amount of bytes (default: C<0>) that make up an "empty" write	140	Sets the amount of bytes (default: C<0>) that make up an "empty" write
133	buffer: If the write reaches this size or gets even samller it is	141	buffer: If the write reaches this size or gets even samller it is
134	considered empty.	142	considered empty.
135		143
		144	=item tls => "accept" \| "connect" \| Net::SSLeay::SSL object
		145
		146	When this parameter is given, it enables TLS (SSL) mode, that means it
		147	will start making tls handshake and will transparently encrypt/decrypt
		148	data.
		149
		150	TLS mode requires Net::SSLeay to be installed (it will be loaded
		151	automatically when you try to create a TLS handle).
		152
		153	For the TLS server side, use C<accept>, and for the TLS client side of a
		154	connection, use C<connect> mode.
		155
		156	You can also provide your own TLS connection object, but you have
		157	to make sure that you call either C<Net::SSLeay::set_connect_state>
		158	or C<Net::SSLeay::set_accept_state> on it before you pass it to
		159	AnyEvent::Handle.
		160
		161	See the C<starttls> method if you need to start TLs negotiation later.
		162
		163	=item tls_ctx => $ssl_ctx
		164
		165	Use the given Net::SSLeay::CTX object to create the new TLS connection
		166	(unless a connection object was specified directly). If this parameter is
		167	missing, then AnyEvent::Handle will use C<AnyEvent::Handle::TLS_CTX>.
		168
136	=back	169	=back
137		170
138	=cut	171	=cut
		172
		173	our (%RH, %WH);
		174
		175	sub register_read_type($$) {
		176	$RH{$_[0]} = $_[1];
		177	}
		178
		179	sub register_write_type($$) {
		180	$WH{$_[0]} = $_[1];
		181	}
139		182
140	sub new {	183	sub new {
141	my $class = shift;	184	my $class = shift;
142		185
143	my $self = bless { @_ }, $class;	186	my $self = bless { @_ }, $class;
144		187
145	$self->{fh} or Carp::croak "mandatory argument fh is missing";	188	$self->{fh} or Carp::croak "mandatory argument fh is missing";
146		189
147	AnyEvent::Util::fh_nonblocking $self->{fh}, 1;	190	AnyEvent::Util::fh_nonblocking $self->{fh}, 1;
148		191
149	$self->on_error ((delete $self->{on_error}) or Carp::croak "mandatory argument on_error is missing");	192	if ($self->{tls}) {
150	$self->on_eof ((delete $self->{on_eof} ) or Carp::croak "mandatory argument on_eof is missing");	193	require Net::SSLeay;
		194	$self->starttls (delete $self->{tls}, delete $self->{tls_ctx});
		195	}
151		196
		197	$self->on_eof (delete $self->{on_eof} ) if $self->{on_eof};
		198	$self->on_error (delete $self->{on_error}) if $self->{on_error};
152	$self->on_drain (delete $self->{on_drain}) if $self->{on_drain};	199	$self->on_drain (delete $self->{on_drain}) if $self->{on_drain};
153	$self->on_read (delete $self->{on_read} ) if $self->{on_read};	200	$self->on_read (delete $self->{on_read} ) if $self->{on_read};
		201
		202	$self->start_read;
154		203
155	$self	204	$self
156	}	205	}
157		206
158	sub _shutdown {	207	sub _shutdown {
…		…
169	{	218	{
170	local $!;	219	local $!;
171	$self->_shutdown;	220	$self->_shutdown;
172	}	221	}
173		222
		223	if ($self->{on_error}) {
174	$self->{on_error}($self);	224	$self->{on_error}($self);
		225	} else {
		226	die "AnyEvent::Handle uncaught fatal error: $!";
		227	}
175	}	228	}
176		229
177	=item $fh = $handle->fh	230	=item $fh = $handle->fh
178		231
179	This method returns the filehandle of the L<AnyEvent::Handle> object.	232	This method returns the file handle of the L<AnyEvent::Handle> object.
180		233
181	=cut	234	=cut
182		235
183	sub fh { $_[0]->{fh} }	236	sub fh { $_[0]->{fh} }
184		237
…		…
196		249
197	Replace the current C<on_eof> callback (see the C<on_eof> constructor argument).	250	Replace the current C<on_eof> callback (see the C<on_eof> constructor argument).
198		251
199	=cut	252	=cut
200		253
201	#############################################################################
202
203	sub on_eof {	254	sub on_eof {
204	$_[0]{on_eof} = $_[1];	255	$_[0]{on_eof} = $_[1];
205	}	256	}
		257
		258	#############################################################################
		259
		260	=back
		261
		262	=head2 WRITE QUEUE
		263
		264	AnyEvent::Handle manages two queues per handle, one for writing and one
		265	for reading.
		266
		267	The write queue is very simple: you can add data to its end, and
		268	AnyEvent::Handle will automatically try to get rid of it for you.
		269
		270	When data could be written and the write buffer is shorter then the low
		271	water mark, the C<on_drain> callback will be invoked.
		272
		273	=over 4
206		274
207	=item $handle->on_drain ($cb)	275	=item $handle->on_drain ($cb)
208		276
209	Sets the C<on_drain> callback or clears it (see the description of	277	Sets the C<on_drain> callback or clears it (see the description of
210	C<on_drain> in the constructor).	278	C<on_drain> in the constructor).
…		…
226	want (only limited by the available memory), as C<AnyEvent::Handle>	294	want (only limited by the available memory), as C<AnyEvent::Handle>
227	buffers it independently of the kernel.	295	buffers it independently of the kernel.
228		296
229	=cut	297	=cut
230		298
231	sub push_write {	299	sub _drain_wbuf {
232	my ($self, $data) = @_;	300	my ($self) = @_;
233
234	$self->{wbuf} .= $data;
235		301
236	unless ($self->{ww}) {	302	unless ($self->{ww}) {
237	Scalar::Util::weaken $self;	303	Scalar::Util::weaken $self;
238	my $cb = sub {	304	my $cb = sub {
239	my $len = syswrite $self->{fh}, $self->{wbuf};	305	my $len = syswrite $self->{fh}, $self->{wbuf};
240		306
241	if ($len > 0) {	307	if ($len > 0) {
242	substr $self->{wbuf}, 0, $len, "";	308	substr $self->{wbuf}, 0, $len, "";
243
244		309
245	$self->{on_drain}($self)	310	$self->{on_drain}($self)
246	if $self->{low_water_mark} >= length $self->{wbuf}	311	if $self->{low_water_mark} >= length $self->{wbuf}
247	&& $self->{on_drain};	312	&& $self->{on_drain};
248		313
…		…
256		321
257	$cb->($self);	322	$cb->($self);
258	};	323	};
259	}	324	}
260		325
		326	sub push_write {
		327	my $self = shift;
		328
		329	if ($self->{filter_w}) {
		330	$self->{filter_w}->($self, \$_[0]);
		331	} else {
		332	$self->{wbuf} .= $_[0];
		333	$self->_drain_wbuf;
		334	}
		335	}
		336
261	#############################################################################	337	#############################################################################
		338
		339	=back
		340
		341	=head2 READ QUEUE
		342
		343	AnyEvent::Handle manages two queues per handle, one for writing and one
		344	for reading.
		345
		346	The read queue is more complex than the write queue. It can be used in two
		347	ways, the "simple" way, using only C<on_read> and the "complex" way, using
		348	a queue.
		349
		350	In the simple case, you just install an C<on_read> callback and whenever
		351	new data arrives, it will be called. You can then remove some data (if
		352	enough is there) from the read buffer (C<< $handle->rbuf >>) if you want
		353	or not.
		354
		355	In the more complex case, you want to queue multiple callbacks. In this
		356	case, AnyEvent::Handle will call the first queued callback each time new
		357	data arrives and removes it when it has done its job (see C<push_read>,
		358	below).
		359
		360	This way you can, for example, push three line-reads, followed by reading
		361	a chunk of data, and AnyEvent::Handle will execute them in order.
		362
		363	Example 1: EPP protocol parser. EPP sends 4 byte length info, followed by
		364	the specified number of bytes which give an XML datagram.
		365
		366	# in the default state, expect some header bytes
		367	$handle->on_read (sub {
		368	# some data is here, now queue the length-header-read (4 octets)
		369	shift->unshift_read_chunk (4, sub {
		370	# header arrived, decode
		371	my $len = unpack "N", $_[1];
		372
		373	# now read the payload
		374	shift->unshift_read_chunk ($len, sub {
		375	my $xml = $_[1];
		376	# handle xml
		377	});
		378	});
		379	});
		380
		381	Example 2: Implement a client for a protocol that replies either with
		382	"OK" and another line or "ERROR" for one request, and 64 bytes for the
		383	second request. Due tot he availability of a full queue, we can just
		384	pipeline sending both requests and manipulate the queue as necessary in
		385	the callbacks:
		386
		387	# request one
		388	$handle->push_write ("request 1\015\012");
		389
		390	# we expect "ERROR" or "OK" as response, so push a line read
		391	$handle->push_read_line (sub {
		392	# if we got an "OK", we have to _prepend_ another line,
		393	# so it will be read before the second request reads its 64 bytes
		394	# which are already in the queue when this callback is called
		395	# we don't do this in case we got an error
		396	if ($_[1] eq "OK") {
		397	$_[0]->unshift_read_line (sub {
		398	my $response = $_[1];
		399	...
		400	});
		401	}
		402	});
		403
		404	# request two
		405	$handle->push_write ("request 2\015\012");
		406
		407	# simply read 64 bytes, always
		408	$handle->push_read_chunk (64, sub {
		409	my $response = $_[1];
		410	...
		411	});
		412
		413	=over 4
		414
		415	=cut
262		416
263	sub _drain_rbuf {	417	sub _drain_rbuf {
264	my ($self) = @_;	418	my ($self) = @_;
265		419
		420	if (
		421	defined $self->{rbuf_max}
		422	&& $self->{rbuf_max} < length $self->{rbuf}
		423	) {
		424	$! = &Errno::ENOSPC; return $self->error;
		425	}
		426
266	return if exists $self->{in_drain};	427	return if $self->{in_drain};
267	local $self->{in_drain} = 1;	428	local $self->{in_drain} = 1;
268		429
269	while (my $len = length $self->{rbuf}) {	430	while (my $len = length $self->{rbuf}) {
270	no strict 'refs';	431	no strict 'refs';
271	if (@{ $self->{queue} }) {	432	if (my $cb = shift @{ $self->{queue} }) {
272	if ($self->{queue}[0]($self)) {	433	if (!$cb->($self)) {
273	shift @{ $self->{queue} };
274	} elsif ($self->{eof}) {	434	if ($self->{eof}) {
275	# no progress can be made (not enough data and no data forthcoming)	435	# no progress can be made (not enough data and no data forthcoming)
276	$! = &Errno::EPIPE; return $self->error;	436	$! = &Errno::EPIPE; return $self->error;
277	} else {	437	}
		438
		439	unshift @{ $self->{queue} }, $cb;
278	return;	440	return;
279	}	441	}
280	} elsif ($self->{on_read}) {	442	} elsif ($self->{on_read}) {
281	$self->{on_read}($self);	443	$self->{on_read}($self);
282		444
…		…
296	}	458	}
297	}	459	}
298		460
299	if ($self->{eof}) {	461	if ($self->{eof}) {
300	$self->_shutdown;	462	$self->_shutdown;
301	$self->{on_eof}($self);	463	$self->{on_eof}($self)
		464	if $self->{on_eof};
302	}	465	}
303	}	466	}
304		467
305	=item $handle->on_read ($cb)	468	=item $handle->on_read ($cb)
306		469
…		…
312		475
313	sub on_read {	476	sub on_read {
314	my ($self, $cb) = @_;	477	my ($self, $cb) = @_;
315		478
316	$self->{on_read} = $cb;	479	$self->{on_read} = $cb;
317
318	unless ($self->{rw} \|\| $self->{eof}) {
319	Scalar::Util::weaken $self;
320
321	$self->{rw} = AnyEvent->io (fh => $self->{fh}, poll => "r", cb => sub {
322	my $len = sysread $self->{fh}, $self->{rbuf}, $self->{read_size} \|\| 8192, length $self->{rbuf};
323
324	if ($len > 0) {
325	if (exists $self->{rbuf_max}) {
326	if ($self->{rbuf_max} < length $self->{rbuf}) {
327	$! = &Errno::ENOSPC; return $self->error;
328	}
329	}
330
331	} elsif (defined $len) {
332	$self->{eof} = 1;
333	delete $self->{rw};
334
335	} elsif ($! != EAGAIN && $! != EINTR) {
336	return $self->error;
337	}
338
339	$self->_drain_rbuf;
340	});
341	}
342	}	480	}
343		481
344	=item $handle->rbuf	482	=item $handle->rbuf
345		483
346	Returns the read buffer (as a modifiable lvalue).	484	Returns the read buffer (as a modifiable lvalue).
…		…
365	Append the given callback to the end of the queue (C<push_read>) or	503	Append the given callback to the end of the queue (C<push_read>) or
366	prepend it (C<unshift_read>).	504	prepend it (C<unshift_read>).
367		505
368	The callback is called each time some additional read data arrives.	506	The callback is called each time some additional read data arrives.
369		507
370	It must check wether enough data is in the read buffer already.	508	It must check whether enough data is in the read buffer already.
371		509
372	If not enough data is available, it must return the empty list or a false	510	If not enough data is available, it must return the empty list or a false
373	value, in which case it will be called repeatedly until enough data is	511	value, in which case it will be called repeatedly until enough data is
374	available (or an error condition is detected).	512	available (or an error condition is detected).
375		513
…		…
378	true, it will be removed from the queue.	516	true, it will be removed from the queue.
379		517
380	=cut	518	=cut
381		519
382	sub push_read {	520	sub push_read {
383	my ($self, $cb) = @_;	521	my $self = shift;
		522	my $cb = pop;
		523
		524	if (@_) {
		525	my $type = shift;
		526
		527	$cb = ($RH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::push_read")
		528	->($self, $cb, @_);
		529	}
384		530
385	push @{ $self->{queue} }, $cb;	531	push @{ $self->{queue} }, $cb;
386	$self->_drain_rbuf;	532	$self->_drain_rbuf;
387	}	533	}
388		534
389	sub unshift_read {	535	sub unshift_read {
390	my ($self, $cb) = @_;	536	my $self = shift;
		537	my $cb = pop;
391		538
		539	if (@_) {
		540	my $type = shift;
		541
		542	$cb = ($RH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::unshift_read")
		543	->($self, $cb, @_);
		544	}
		545
		546
392	push @{ $self->{queue} }, $cb;	547	unshift @{ $self->{queue} }, $cb;
393	$self->_drain_rbuf;	548	$self->_drain_rbuf;
394	}	549	}
395		550
396	=item $handle->push_read_chunk ($len, $cb->($self, $data))	551	=item $handle->push_read (type => @args, $cb)
397		552
398	=item $handle->unshift_read_chunk ($len, $cb->($self, $data))	553	=item $handle->unshift_read (type => @args, $cb)
399		554
400	Append the given callback to the end of the queue (C<push_read_chunk>) or	555	Instead of providing a callback that parses the data itself you can chose
401	prepend it (C<unshift_read_chunk>).	556	between a number of predefined parsing formats, for chunks of data, lines
		557	etc.
402		558
403	The callback will be called only once C<$len> bytes have been read, and	559	The types currently supported are:
404	these C<$len> bytes will be passed to the callback.
405		560
406	=cut	561	=over 4
407		562
408	sub _read_chunk($$) {	563	=item chunk => $octets, $cb->($self, $data)
409	my ($len, $cb) = @_;	564
		565	Invoke the callback only once C<$octets> bytes have been read. Pass the
		566	data read to the callback. The callback will never be called with less
		567	data.
		568
		569	Example: read 2 bytes.
		570
		571	$handle->push_read (chunk => 2, sub {
		572	warn "yay ", unpack "H*", $_[1];
		573	});
		574
		575	=cut
		576
		577	register_read_type chunk => sub {
		578	my ($self, $cb, $len) = @_;
410		579
411	sub {	580	sub {
412	$len <= length $_[0]{rbuf} or return;	581	$len <= length $_[0]{rbuf} or return;
413	$cb->($_[0], substr $_[0]{rbuf}, 0, $len, "");	582	$cb->($_[0], substr $_[0]{rbuf}, 0, $len, "");
414	1	583	1
415	}	584	}
416	}	585	};
417		586
		587	# compatibility with older API
418	sub push_read_chunk {	588	sub push_read_chunk {
419	my ($self, $len, $cb) = @_;	589	$_[0]->push_read (chunk => $_[1], $_[2]);
420
421	$self->push_read (_read_chunk $len, $cb);
422	}	590	}
423
424		591
425	sub unshift_read_chunk {	592	sub unshift_read_chunk {
426	my ($self, $len, $cb) = @_;	593	$_[0]->unshift_read (chunk => $_[1], $_[2]);
427
428	$self->unshift_read (_read_chunk $len, $cb);
429	}	594	}
430		595
431	=item $handle->push_read_line ([$eol, ]$cb->($self, $line, $eol))	596	=item line => [$eol, ]$cb->($self, $line, $eol)
432
433	=item $handle->unshift_read_line ([$eol, ]$cb->($self, $line, $eol))
434
435	Append the given callback to the end of the queue (C<push_read_line>) or
436	prepend it (C<unshift_read_line>).
437		597
438	The callback will be called only once a full line (including the end of	598	The callback will be called only once a full line (including the end of
439	line marker, C<$eol>) has been read. This line (excluding the end of line	599	line marker, C<$eol>) has been read. This line (excluding the end of line
440	marker) will be passed to the callback as second argument (C<$line>), and	600	marker) will be passed to the callback as second argument (C<$line>), and
441	the end of line marker as the third argument (C<$eol>).	601	the end of line marker as the third argument (C<$eol>).
…		…
452	Partial lines at the end of the stream will never be returned, as they are	612	Partial lines at the end of the stream will never be returned, as they are
453	not marked by the end of line marker.	613	not marked by the end of line marker.
454		614
455	=cut	615	=cut
456		616
457	sub _read_line($$) {	617	register_read_type line => sub {
458	my $cb = pop;	618	my ($self, $cb, $eol) = @_;
459	my $eol = @_ ? shift : qr\|(\015?\012)\|;
460	my $pos;
461		619
		620	$eol = qr\|(\015?\012)\| if @_ < 3;
462	$eol = qr\|(\Q$eol\E)\| unless ref $eol;	621	$eol = quotemeta $eol unless ref $eol;
463	$eol = qr\|^(.*?)($eol)\|;	622	$eol = qr\|^(.*?)($eol)\|s;
464		623
465	sub {	624	sub {
466	$_[0]{rbuf} =~ s/$eol// or return;	625	$_[0]{rbuf} =~ s/$eol// or return;
467		626
468	$cb->($1, $2);	627	$cb->($_[0], $1, $2);
469	1	628	1
470	}	629	}
471	}	630	};
472		631
		632	# compatibility with older API
473	sub push_read_line {	633	sub push_read_line {
474	my $self = shift;	634	my $self = shift;
475
476	$self->push_read (&_read_line);	635	$self->push_read (line => @_);
477	}	636	}
478		637
479	sub unshift_read_line {	638	sub unshift_read_line {
480	my $self = shift;	639	my $self = shift;
481
482	$self->unshift_read (&_read_line);	640	$self->unshift_read (line => @_);
483	}	641	}
484		642
485	=back	643	=back
486		644
		645	=item $handle->stop_read
		646
		647	=item $handle->start_read
		648
		649	In rare cases you actually do not want to read anything from the
		650	socket. In this case you can call C<stop_read>. Neither C<on_read> no
		651	any queued callbacks will be executed then. To start reading again, call
		652	C<start_read>.
		653
		654	=cut
		655
		656	sub stop_read {
		657	my ($self) = @_;
		658
		659	delete $self->{rw};
		660	}
		661
		662	sub start_read {
		663	my ($self) = @_;
		664
		665	unless ($self->{rw} \|\| $self->{eof}) {
		666	Scalar::Util::weaken $self;
		667
		668	$self->{rw} = AnyEvent->io (fh => $self->{fh}, poll => "r", cb => sub {
		669	my $rbuf = $self->{filter_r} ? \my $buf : \$self->{rbuf};
		670	my $len = sysread $self->{fh}, $$rbuf, $self->{read_size} \|\| 8192, length $$rbuf;
		671
		672	if ($len > 0) {
		673	$self->{filter_r}
		674	? $self->{filter_r}->($self, $rbuf)
		675	: $self->_drain_rbuf;
		676
		677	} elsif (defined $len) {
		678	delete $self->{rw};
		679	$self->{eof} = 1;
		680	$self->_drain_rbuf;
		681
		682	} elsif ($! != EAGAIN && $! != EINTR) {
		683	return $self->error;
		684	}
		685	});
		686	}
		687	}
		688
		689	sub _dotls {
		690	my ($self) = @_;
		691
		692	if (length $self->{tls_wbuf}) {
		693	while ((my $len = Net::SSLeay::write ($self->{tls}, $self->{tls_wbuf})) > 0) {
		694	substr $self->{tls_wbuf}, 0, $len, "";
		695	}
		696	}
		697
		698	if (defined (my $buf = Net::SSLeay::BIO_read ($self->{tls_wbio}))) {
		699	$self->{wbuf} .= $buf;
		700	$self->_drain_wbuf;
		701	}
		702
		703	while (defined (my $buf = Net::SSLeay::read ($self->{tls}))) {
		704	$self->{rbuf} .= $buf;
		705	$self->_drain_rbuf;
		706	}
		707
		708	my $err = Net::SSLeay::get_error ($self->{tls}, -1);
		709
		710	if ($err!= Net::SSLeay::ERROR_WANT_READ ()) {
		711	if ($err == Net::SSLeay::ERROR_SYSCALL ()) {
		712	$self->error;
		713	} elsif ($err == Net::SSLeay::ERROR_SSL ()) {
		714	$! = &Errno::EIO;
		715	$self->error;
		716	}
		717
		718	# all others are fine for our purposes
		719	}
		720	}
		721
		722	=item $handle->starttls ($tls[, $tls_ctx])
		723
		724	Instead of starting TLS negotiation immediately when the AnyEvent::Handle
		725	object is created, you can also do that at a later time by calling
		726	C<starttls>.
		727
		728	The first argument is the same as the C<tls> constructor argument (either
		729	C<"connect">, C<"accept"> or an existing Net::SSLeay object).
		730
		731	The second argument is the optional C<Net::SSLeay::CTX> object that is
		732	used when AnyEvent::Handle has to create its own TLS connection object.
		733
		734	=cut
		735
		736	# TODO: maybe document...
		737	sub starttls {
		738	my ($self, $ssl, $ctx) = @_;
		739
		740	$self->stoptls;
		741
		742	if ($ssl eq "accept") {
		743	$ssl = Net::SSLeay::new ($ctx \|\| TLS_CTX ());
		744	Net::SSLeay::set_accept_state ($ssl);
		745	} elsif ($ssl eq "connect") {
		746	$ssl = Net::SSLeay::new ($ctx \|\| TLS_CTX ());
		747	Net::SSLeay::set_connect_state ($ssl);
		748	}
		749
		750	$self->{tls} = $ssl;
		751
		752	# basically, this is deep magic (because SSL_read should have the same issues)
		753	# but the openssl maintainers basically said: "trust us, it just works".
		754	# (unfortunately, we have to hardcode constants because the abysmally misdesigned
		755	# and mismaintained ssleay-module doesn't even offer them).
		756	# http://www.mail-archive.com/openssl-dev@openssl.org/msg22420.html
		757	Net::SSLeay::CTX_set_mode ($self->{tls},
		758	(eval { Net::SSLeay::MODE_ENABLE_PARTIAL_WRITE () } \|\| 1)
		759	\| (eval { Net::SSLeay::MODE_ACCEPT_MOVING_WRITE_BUFFER () } \|\| 2));
		760
		761	$self->{tls_rbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ());
		762	$self->{tls_wbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ());
		763
		764	Net::SSLeay::set_bio ($ssl, $self->{tls_rbio}, $self->{tls_wbio});
		765
		766	$self->{filter_w} = sub {
		767	$_[0]{tls_wbuf} .= ${$_[1]};
		768	&_dotls;
		769	};
		770	$self->{filter_r} = sub {
		771	Net::SSLeay::BIO_write ($_[0]{tls_rbio}, ${$_[1]});
		772	&_dotls;
		773	};
		774	}
		775
		776	=item $handle->stoptls
		777
		778	Destroys the SSL connection, if any. Partial read or write data will be
		779	lost.
		780
		781	=cut
		782
		783	sub stoptls {
		784	my ($self) = @_;
		785
		786	Net::SSLeay::free (delete $self->{tls}) if $self->{tls};
		787	delete $self->{tls_rbio};
		788	delete $self->{tls_wbio};
		789	delete $self->{tls_wbuf};
		790	delete $self->{filter_r};
		791	delete $self->{filter_w};
		792	}
		793
		794	sub DESTROY {
		795	my $self = shift;
		796
		797	$self->stoptls;
		798	}
		799
		800	=item AnyEvent::Handle::TLS_CTX
		801
		802	This function creates and returns the Net::SSLeay::CTX object used by
		803	default for TLS mode.
		804
		805	The context is created like this:
		806
		807	Net::SSLeay::load_error_strings;
		808	Net::SSLeay::SSLeay_add_ssl_algorithms;
		809	Net::SSLeay::randomize;
		810
		811	my $CTX = Net::SSLeay::CTX_new;
		812
		813	Net::SSLeay::CTX_set_options $CTX, Net::SSLeay::OP_ALL
		814
		815	=cut
		816
		817	our $TLS_CTX;
		818
		819	sub TLS_CTX() {
		820	$TLS_CTX \|\| do {
		821	require Net::SSLeay;
		822
		823	Net::SSLeay::load_error_strings ();
		824	Net::SSLeay::SSLeay_add_ssl_algorithms ();
		825	Net::SSLeay::randomize ();
		826
		827	$TLS_CTX = Net::SSLeay::CTX_new ();
		828
		829	Net::SSLeay::CTX_set_options ($TLS_CTX, Net::SSLeay::OP_ALL ());
		830
		831	$TLS_CTX
		832	}
		833	}
		834
		835	=back
		836
487	=head1 AUTHOR	837	=head1 AUTHOR
488		838
489	Robin Redeker C<< <elmex at ta-sa.org> >>, Marc Lehmann <schmorp@schmorp.de>.	839	Robin Redeker C<< <elmex at ta-sa.org> >>, Marc Lehmann <schmorp@schmorp.de>.
490		840
491	=cut	841	=cut

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/Handle.pm (file contents): Revision 1.8 by root, Fri May 2 15:36:10 2008 UTC vs. Revision 1.28 by root, Sat May 24 22:27:11 2008 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/Handle.pm (file contents):
Revision 1.8 by root, Fri May 2 15:36:10 2008 UTC vs.
Revision 1.28 by root, Sat May 24 22:27:11 2008 UTC