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

Comparing AnyEvent/lib/AnyEvent/Handle.pm (file contents):
Revision 1.20 by elmex, Sat May 24 08:16:50 2008 UTC vs.
Revision 1.36 by root, Mon May 26 18:26:52 2008 UTC

…		…
2		2
3	no warnings;	3	no warnings;
4	use strict;	4	use strict;
5		5
6	use AnyEvent ();	6	use AnyEvent ();
7	use AnyEvent::Util ();	7	use AnyEvent::Util qw(WSAWOULDBLOCK);
8	use Scalar::Util ();	8	use Scalar::Util ();
9	use Carp ();	9	use Carp ();
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
17	This module is experimental.
18		16
19	=cut	17	=cut
20		18
21	our $VERSION = '0.04';	19	our $VERSION = '0.04';
22		20
…		…
25	use AnyEvent;	23	use AnyEvent;
26	use AnyEvent::Handle;	24	use AnyEvent::Handle;
27		25
28	my $cv = AnyEvent->condvar;	26	my $cv = AnyEvent->condvar;
29		27
30	my $ae_fh = AnyEvent::Handle->new (fh => \*STDIN);	28	my $handle =
31
32	#TODO
33
34	# or use the constructor to pass the callback:
35
36	my $ae_fh2 =
37	AnyEvent::Handle->new (	29	AnyEvent::Handle->new (
38	fh => \*STDIN,	30	fh => \*STDIN,
39	on_eof => sub {	31	on_eof => sub {
40	$cv->broadcast;	32	$cv->broadcast;
41	},	33	},
42	#TODO
43	);	34	);
44		35
45	$cv->wait;	36	# send some request line
		37	$handle->push_write ("getinfo\015\012");
		38
		39	# read the response line
		40	$handle->push_read (line => sub {
		41	my ($handle, $line) = @_;
		42	warn "read line <$line>\n";
		43	$cv->send;
		44	});
		45
		46	$cv->recv;
46		47
47	=head1 DESCRIPTION	48	=head1 DESCRIPTION
48		49
49	This module is a helper module to make it easier to do event-based I/O on	50	This module is a helper module to make it easier to do event-based I/O on
50	filehandles. For utility functions for doing non-blocking connects and accepts	51	filehandles. For utility functions for doing non-blocking connects and accepts
…		…
90		91
91	The object will not be in a usable state when this callback has been	92	The object will not be in a usable state when this callback has been
92	called.	93	called.
93		94
94	On callback entrance, the value of C<$!> contains the operating system	95	On callback entrance, the value of C<$!> contains the operating system
95	error (or C<ENOSPC> or C<EPIPE>).	96	error (or C<ENOSPC>, C<EPIPE> or C<EBADMSG>).
96		97
97	While not mandatory, it is I<highly> recommended to set this callback, as	98	While not mandatory, it is I<highly> recommended to set this callback, as
98	you will not be notified of errors otherwise. The default simply calls	99	you will not be notified of errors otherwise. The default simply calls
99	die.	100	die.
100		101
…		…
145		146
146	When this parameter is given, it enables TLS (SSL) mode, that means it	147	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	will start making tls handshake and will transparently encrypt/decrypt
148	data.	149	data.
149		150
		151	TLS mode requires Net::SSLeay to be installed (it will be loaded
		152	automatically when you try to create a TLS handle).
		153
150	For the TLS server side, use C<accept>, and for the TLS client side of a	154	For the TLS server side, use C<accept>, and for the TLS client side of a
151	connection, use C<connect> mode.	155	connection, use C<connect> mode.
152		156
153	You can also provide your own TLS connection object, but you have	157	You can also provide your own TLS connection object, but you have
154	to make sure that you call either C<Net::SSLeay::set_connect_state>	158	to make sure that you call either C<Net::SSLeay::set_connect_state>
155	or C<Net::SSLeay::set_accept_state> on it before you pass it to	159	or C<Net::SSLeay::set_accept_state> on it before you pass it to
156	AnyEvent::Handle.	160	AnyEvent::Handle.
157		161
		162	See the C<starttls> method if you need to start TLs negotiation later.
		163
158	=item tls_ctx => $ssl_ctx	164	=item tls_ctx => $ssl_ctx
159		165
160	Use the given Net::SSLeay::CTX object to create the new TLS connection	166	Use the given Net::SSLeay::CTX object to create the new TLS connection
161	(unless a connection object was specified directly). If this parameter is	167	(unless a connection object was specified directly). If this parameter is
162	missing, then AnyEvent::Handle will use C<AnyEvent::Handle::TLS_CTX>.	168	missing, then AnyEvent::Handle will use C<AnyEvent::Handle::TLS_CTX>.
…		…
206	}	212	}
207		213
208	if ($self->{on_error}) {	214	if ($self->{on_error}) {
209	$self->{on_error}($self);	215	$self->{on_error}($self);
210	} else {	216	} else {
211	die "AnyEvent::Handle uncaught fatal error: $!";	217	Carp::croak "AnyEvent::Handle uncaught fatal error: $!";
212	}	218	}
213	}	219	}
214		220
215	=item $fh = $handle->fh	221	=item $fh = $handle->fh
216		222
217	This method returns the filehandle of the L<AnyEvent::Handle> object.	223	This method returns the file handle of the L<AnyEvent::Handle> object.
218		224
219	=cut	225	=cut
220		226
221	sub fh { $_[0]->{fh} }	227	sub fh { $_[0]->{fh} }
222		228
…		…
282	=cut	288	=cut
283		289
284	sub _drain_wbuf {	290	sub _drain_wbuf {
285	my ($self) = @_;	291	my ($self) = @_;
286		292
287	unless ($self->{ww}) {	293	if (!$self->{ww} && length $self->{wbuf}) {
		294
288	Scalar::Util::weaken $self;	295	Scalar::Util::weaken $self;
		296
289	my $cb = sub {	297	my $cb = sub {
290	my $len = syswrite $self->{fh}, $self->{wbuf};	298	my $len = syswrite $self->{fh}, $self->{wbuf};
291		299
292	if ($len > 0) {	300	if ($len >= 0) {
293	substr $self->{wbuf}, 0, $len, "";	301	substr $self->{wbuf}, 0, $len, "";
294		302
295	$self->{on_drain}($self)	303	$self->{on_drain}($self)
296	if $self->{low_water_mark} >= length $self->{wbuf}	304	if $self->{low_water_mark} >= length $self->{wbuf}
297	&& $self->{on_drain};	305	&& $self->{on_drain};
298		306
299	delete $self->{ww} unless length $self->{wbuf};	307	delete $self->{ww} unless length $self->{wbuf};
300	} elsif ($! != EAGAIN && $! != EINTR) {	308	} elsif ($! != EAGAIN && $! != EINTR && $! != WSAWOULDBLOCK) {
301	$self->error;	309	$self->error;
302	}	310	}
303	};	311	};
304		312
		313	# try to write data immediately
		314	$cb->();
		315
		316	# if still data left in wbuf, we need to poll
305	$self->{ww} = AnyEvent->io (fh => $self->{fh}, poll => "w", cb => $cb);	317	$self->{ww} = AnyEvent->io (fh => $self->{fh}, poll => "w", cb => $cb)
306		318	if length $self->{wbuf};
307	$cb->($self);
308	};	319	};
		320	}
		321
		322	our %WH;
		323
		324	sub register_write_type($$) {
		325	$WH{$_[0]} = $_[1];
309	}	326	}
310		327
311	sub push_write {	328	sub push_write {
312	my $self = shift;	329	my $self = shift;
		330
		331	if (@_ > 1) {
		332	my $type = shift;
		333
		334	@_ = ($WH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::push_write")
		335	->($self, @_);
		336	}
313		337
314	if ($self->{filter_w}) {	338	if ($self->{filter_w}) {
315	$self->{filter_w}->($self, \$_[0]);	339	$self->{filter_w}->($self, \$_[0]);
316	} else {	340	} else {
317	$self->{wbuf} .= $_[0];	341	$self->{wbuf} .= $_[0];
318	$self->_drain_wbuf;	342	$self->_drain_wbuf;
319	}	343	}
320	}	344	}
		345
		346	=item $handle->push_write (type => @args)
		347
		348	=item $handle->unshift_write (type => @args)
		349
		350	Instead of formatting your data yourself, you can also let this module do
		351	the job by specifying a type and type-specific arguments.
		352
		353	Predefined types are (if you have ideas for additional types, feel free to
		354	drop by and tell us):
		355
		356	=over 4
		357
		358	=item netstring => $string
		359
		360	Formats the given value as netstring
		361	(http://cr.yp.to/proto/netstrings.txt, this is not a recommendation to use them).
		362
		363	=back
		364
		365	=cut
		366
		367	register_write_type netstring => sub {
		368	my ($self, $string) = @_;
		369
		370	sprintf "%d:%s,", (length $string), $string
		371	};
		372
		373	=item AnyEvent::Handle::register_write_type type => $coderef->($self, @args)
		374
		375	This function (not method) lets you add your own types to C<push_write>.
		376	Whenever the given C<type> is used, C<push_write> will invoke the code
		377	reference with the handle object and the remaining arguments.
		378
		379	The code reference is supposed to return a single octet string that will
		380	be appended to the write buffer.
		381
		382	Note that this is a function, and all types registered this way will be
		383	global, so try to use unique names.
		384
		385	=cut
321		386
322	#############################################################################	387	#############################################################################
323		388
324	=back	389	=back
325		390
…		…
413	local $self->{in_drain} = 1;	478	local $self->{in_drain} = 1;
414		479
415	while (my $len = length $self->{rbuf}) {	480	while (my $len = length $self->{rbuf}) {
416	no strict 'refs';	481	no strict 'refs';
417	if (my $cb = shift @{ $self->{queue} }) {	482	if (my $cb = shift @{ $self->{queue} }) {
418	if (!$cb->($self)) {	483	unless ($cb->($self)) {
419	if ($self->{eof}) {	484	if ($self->{eof}) {
420	# no progress can be made (not enough data and no data forthcoming)	485	# no progress can be made (not enough data and no data forthcoming)
421	$! = &Errno::EPIPE; return $self->error;	486	$! = &Errno::EPIPE; return $self->error;
422	}	487	}
423		488
…		…
500	interested in (which can be none at all) and return a true value. After returning	565	interested in (which can be none at all) and return a true value. After returning
501	true, it will be removed from the queue.	566	true, it will be removed from the queue.
502		567
503	=cut	568	=cut
504		569
		570	our %RH;
		571
		572	sub register_read_type($$) {
		573	$RH{$_[0]} = $_[1];
		574	}
		575
505	sub push_read {	576	sub push_read {
506	my ($self, $cb) = @_;	577	my $self = shift;
		578	my $cb = pop;
		579
		580	if (@_) {
		581	my $type = shift;
		582
		583	$cb = ($RH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::push_read")
		584	->($self, $cb, @_);
		585	}
507		586
508	push @{ $self->{queue} }, $cb;	587	push @{ $self->{queue} }, $cb;
509	$self->_drain_rbuf;	588	$self->_drain_rbuf;
510	}	589	}
511		590
512	sub unshift_read {	591	sub unshift_read {
513	my ($self, $cb) = @_;	592	my $self = shift;
		593	my $cb = pop;
514		594
		595	if (@_) {
		596	my $type = shift;
		597
		598	$cb = ($RH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::unshift_read")
		599	->($self, $cb, @_);
		600	}
		601
		602
515	push @{ $self->{queue} }, $cb;	603	unshift @{ $self->{queue} }, $cb;
516	$self->_drain_rbuf;	604	$self->_drain_rbuf;
517	}	605	}
518		606
519	=item $handle->push_read_chunk ($len, $cb->($self, $data))	607	=item $handle->push_read (type => @args, $cb)
520		608
521	=item $handle->unshift_read_chunk ($len, $cb->($self, $data))	609	=item $handle->unshift_read (type => @args, $cb)
522		610
523	Append the given callback to the end of the queue (C<push_read_chunk>) or	611	Instead of providing a callback that parses the data itself you can chose
524	prepend it (C<unshift_read_chunk>).	612	between a number of predefined parsing formats, for chunks of data, lines
		613	etc.
525		614
526	The callback will be called only once C<$len> bytes have been read, and	615	Predefined types are (if you have ideas for additional types, feel free to
527	these C<$len> bytes will be passed to the callback.	616	drop by and tell us):
528		617
529	=cut	618	=over 4
530		619
531	sub _read_chunk($$) {	620	=item chunk => $octets, $cb->($self, $data)
		621
		622	Invoke the callback only once C<$octets> bytes have been read. Pass the
		623	data read to the callback. The callback will never be called with less
		624	data.
		625
		626	Example: read 2 bytes.
		627
		628	$handle->push_read (chunk => 2, sub {
		629	warn "yay ", unpack "H*", $_[1];
		630	});
		631
		632	=cut
		633
		634	register_read_type chunk => sub {
532	my ($self, $len, $cb) = @_;	635	my ($self, $cb, $len) = @_;
533		636
534	sub {	637	sub {
535	$len <= length $_[0]{rbuf} or return;	638	$len <= length $_[0]{rbuf} or return;
536	$cb->($_[0], substr $_[0]{rbuf}, 0, $len, "");	639	$cb->($_[0], substr $_[0]{rbuf}, 0, $len, "");
537	1	640	1
538	}	641	}
539	}	642	};
540		643
		644	# compatibility with older API
541	sub push_read_chunk {	645	sub push_read_chunk {
542	$_[0]->push_read (&_read_chunk);	646	$_[0]->push_read (chunk => $_[1], $_[2]);
543	}	647	}
544
545		648
546	sub unshift_read_chunk {	649	sub unshift_read_chunk {
547	$_[0]->unshift_read (&_read_chunk);	650	$_[0]->unshift_read (chunk => $_[1], $_[2]);
548	}	651	}
549		652
550	=item $handle->push_read_line ([$eol, ]$cb->($self, $line, $eol))	653	=item line => [$eol, ]$cb->($self, $line, $eol)
551
552	=item $handle->unshift_read_line ([$eol, ]$cb->($self, $line, $eol))
553
554	Append the given callback to the end of the queue (C<push_read_line>) or
555	prepend it (C<unshift_read_line>).
556		654
557	The callback will be called only once a full line (including the end of	655	The callback will be called only once a full line (including the end of
558	line marker, C<$eol>) has been read. This line (excluding the end of line	656	line marker, C<$eol>) has been read. This line (excluding the end of line
559	marker) will be passed to the callback as second argument (C<$line>), and	657	marker) will be passed to the callback as second argument (C<$line>), and
560	the end of line marker as the third argument (C<$eol>).	658	the end of line marker as the third argument (C<$eol>).
…		…
571	Partial lines at the end of the stream will never be returned, as they are	669	Partial lines at the end of the stream will never be returned, as they are
572	not marked by the end of line marker.	670	not marked by the end of line marker.
573		671
574	=cut	672	=cut
575		673
576	sub _read_line($$) {	674	register_read_type line => sub {
577	my $self = shift;	675	my ($self, $cb, $eol) = @_;
578	my $cb = pop;
579	my $eol = @_ ? shift : qr\|(\015?\012)\|;
580	my $pos;
581		676
		677	$eol = qr\|(\015?\012)\| if @_ < 3;
582	$eol = quotemeta $eol unless ref $eol;	678	$eol = quotemeta $eol unless ref $eol;
583	$eol = qr\|^(.*?)($eol)\|s;	679	$eol = qr\|^(.*?)($eol)\|s;
584		680
585	sub {	681	sub {
586	$_[0]{rbuf} =~ s/$eol// or return;	682	$_[0]{rbuf} =~ s/$eol// or return;
587		683
588	$cb->($_[0], $1, $2);	684	$cb->($_[0], $1, $2);
589	1	685	1
590	}	686	}
591	}	687	};
592		688
		689	# compatibility with older API
593	sub push_read_line {	690	sub push_read_line {
594	$_[0]->push_read (&_read_line);	691	my $self = shift;
		692	$self->push_read (line => @_);
595	}	693	}
596		694
597	sub unshift_read_line {	695	sub unshift_read_line {
598	$_[0]->unshift_read (&_read_line);	696	my $self = shift;
		697	$self->unshift_read (line => @_);
599	}	698	}
		699
		700	=item netstring => $cb->($string)
		701
		702	A netstring (http://cr.yp.to/proto/netstrings.txt, this is not an endorsement).
		703
		704	Throws an error with C<$!> set to EBADMSG on format violations.
		705
		706	=cut
		707
		708	register_read_type netstring => sub {
		709	my ($self, $cb) = @_;
		710
		711	sub {
		712	unless ($_[0]{rbuf} =~ s/^(0\|[1-9][0-9]*)://) {
		713	if ($_[0]{rbuf} =~ /[^0-9]/) {
		714	$! = &Errno::EBADMSG;
		715	$self->error;
		716	}
		717	return;
		718	}
		719
		720	my $len = $1;
		721
		722	$self->unshift_read (chunk => $len, sub {
		723	my $string = $_[1];
		724	$_[0]->unshift_read (chunk => 1, sub {
		725	if ($_[1] eq ",") {
		726	$cb->($_[0], $string);
		727	} else {
		728	$! = &Errno::EBADMSG;
		729	$self->error;
		730	}
		731	});
		732	});
		733
		734	1
		735	}
		736	};
		737
		738	=item regex => $accept[, $reject[, $skip], $cb->($data)
		739
		740	Makes a regex match against the regex object C<$accept> and returns
		741	everything up to and including the match.
		742
		743	Example: read a single line terminated by '\n'.
		744
		745	$handle->push_read (regex => qr<\n>, sub { ... });
		746
		747	If C<$reject> is given and not undef, then it determines when the data is
		748	to be rejected: it is matched against the data when the C<$accept> regex
		749	does not match and generates an C<EBADMSG> error when it matches. This is
		750	useful to quickly reject wrong data (to avoid waiting for a timeout or a
		751	receive buffer overflow).
		752
		753	Example: expect a single decimal number followed by whitespace, reject
		754	anything else (not the use of an anchor).
		755
		756	$handle->push_read (regex => qr<^[0-9]+\s>, qr<[^0-9]>, sub { ... });
		757
		758	If C<$skip> is given and not C<undef>, then it will be matched against
		759	the receive buffer when neither C<$accept> nor C<$reject> match,
		760	and everything preceding and including the match will be accepted
		761	unconditionally. This is useful to skip large amounts of data that you
		762	know cannot be matched, so that the C<$accept> or C<$reject> regex do not
		763	have to start matching from the beginning. This is purely an optimisation
		764	and is usually worth only when you expect more than a few kilobytes.
		765
		766	Example: expect a http header, which ends at C<\015\012\015\012>. Since we
		767	expect the header to be very large (it isn't in practise, but...), we use
		768	a skip regex to skip initial portions. The skip regex is tricky in that
		769	it only accepts something not ending in either \015 or \012, as these are
		770	required for the accept regex.
		771
		772	$handle->push_read (regex =>
		773	qr<\015\012\015\012>,
		774	undef, # no reject
		775	qr<^.*[^\015\012]>,
		776	sub { ... });
		777
		778	=cut
		779
		780	register_read_type regex => sub {
		781	my ($self, $cb, $accept, $reject, $skip) = @_;
		782
		783	my $data;
		784	my $rbuf = \$self->{rbuf};
		785
		786	sub {
		787	# accept
		788	if ($$rbuf =~ $accept) {
		789	$data .= substr $$rbuf, 0, $+[0], "";
		790	$cb->($self, $data);
		791	return 1;
		792	}
		793
		794	# reject
		795	if ($reject && $$rbuf =~ $reject) {
		796	$! = &Errno::EBADMSG;
		797	$self->error;
		798	}
		799
		800	# skip
		801	if ($skip && $$rbuf =~ $skip) {
		802	$data .= substr $$rbuf, 0, $+[0], "";
		803	}
		804
		805	()
		806	}
		807	};
		808
		809	=back
		810
		811	=item AnyEvent::Handle::register_read_type type => $coderef->($self, $cb, @args)
		812
		813	This function (not method) lets you add your own types to C<push_read>.
		814
		815	Whenever the given C<type> is used, C<push_read> will invoke the code
		816	reference with the handle object, the callback and the remaining
		817	arguments.
		818
		819	The code reference is supposed to return a callback (usually a closure)
		820	that works as a plain read callback (see C<< ->push_read ($cb) >>).
		821
		822	It should invoke the passed callback when it is done reading (remember to
		823	pass C<$self> as first argument as all other callbacks do that).
		824
		825	Note that this is a function, and all types registered this way will be
		826	global, so try to use unique names.
		827
		828	For examples, see the source of this module (F<perldoc -m AnyEvent::Handle>,
		829	search for C<register_read_type>)).
600		830
601	=item $handle->stop_read	831	=item $handle->stop_read
602		832
603	=item $handle->start_read	833	=item $handle->start_read
604		834
605	In rare cases you actually do not want to read anything from the	835	In rare cases you actually do not want to read anything from the
606	socket. In this case you can call C<stop_read>. Neither C<on_read> no	836	socket. In this case you can call C<stop_read>. Neither C<on_read> no
607	any queued callbacks will be executed then. To start readign again, call	837	any queued callbacks will be executed then. To start reading again, call
608	C<start_read>.	838	C<start_read>.
609		839
610	=cut	840	=cut
611		841
612	sub stop_read {	842	sub stop_read {
…		…
633	} elsif (defined $len) {	863	} elsif (defined $len) {
634	delete $self->{rw};	864	delete $self->{rw};
635	$self->{eof} = 1;	865	$self->{eof} = 1;
636	$self->_drain_rbuf;	866	$self->_drain_rbuf;
637		867
638	} elsif ($! != EAGAIN && $! != EINTR) {	868	} elsif ($! != EAGAIN && $! != EINTR && $! != &AnyEvent::Util::WSAWOULDBLOCK) {
639	return $self->error;	869	return $self->error;
640	}	870	}
641	});	871	});
642	}	872	}
643	}	873	}
644		874
645	sub _dotls {	875	sub _dotls {
646	my ($self) = @_;	876	my ($self) = @_;
647		877
648	if (length $self->{tls_wbuf}) {	878	if (length $self->{tls_wbuf}) {
649	my $len = Net::SSLeay::write ($self->{tls}, $self->{tls_wbuf});	879	while ((my $len = Net::SSLeay::write ($self->{tls}, $self->{tls_wbuf})) > 0) {
650	substr $self->{tls_wbuf}, 0, $len, "" if $len > 0;	880	substr $self->{tls_wbuf}, 0, $len, "";
		881	}
651	}	882	}
652		883
653	if (defined (my $buf = Net::SSLeay::BIO_read ($self->{tls_wbio}))) {	884	if (defined (my $buf = Net::SSLeay::BIO_read ($self->{tls_wbio}))) {
654	$self->{wbuf} .= $buf;	885	$self->{wbuf} .= $buf;
655	$self->_drain_wbuf;	886	$self->_drain_wbuf;
656	}	887	}
657		888
658	if (defined (my $buf = Net::SSLeay::read ($self->{tls}))) {	889	while (defined (my $buf = Net::SSLeay::read ($self->{tls}))) {
659	$self->{rbuf} .= $buf;	890	$self->{rbuf} .= $buf;
660	$self->_drain_rbuf;	891	$self->_drain_rbuf;
661	} elsif (	892	}
		893
662	(my $err = Net::SSLeay::get_error ($self->{tls}, -1))	894	my $err = Net::SSLeay::get_error ($self->{tls}, -1);
		895
663	!= Net::SSLeay::ERROR_WANT_READ ()	896	if ($err!= Net::SSLeay::ERROR_WANT_READ ()) {
664	) {
665	if ($err == Net::SSLeay::ERROR_SYSCALL ()) {	897	if ($err == Net::SSLeay::ERROR_SYSCALL ()) {
666	$self->error;	898	$self->error;
667	} elsif ($err == Net::SSLeay::ERROR_SSL ()) {	899	} elsif ($err == Net::SSLeay::ERROR_SSL ()) {
668	$! = &Errno::EIO;	900	$! = &Errno::EIO;
669	$self->error;	901	$self->error;
…		…
671		903
672	# all others are fine for our purposes	904	# all others are fine for our purposes
673	}	905	}
674	}	906	}
675		907
		908	=item $handle->starttls ($tls[, $tls_ctx])
		909
		910	Instead of starting TLS negotiation immediately when the AnyEvent::Handle
		911	object is created, you can also do that at a later time by calling
		912	C<starttls>.
		913
		914	The first argument is the same as the C<tls> constructor argument (either
		915	C<"connect">, C<"accept"> or an existing Net::SSLeay object).
		916
		917	The second argument is the optional C<Net::SSLeay::CTX> object that is
		918	used when AnyEvent::Handle has to create its own TLS connection object.
		919
		920	=cut
		921
676	# TODO: maybe document...	922	# TODO: maybe document...
677	sub starttls {	923	sub starttls {
678	my ($self, $ssl, $ctx) = @_;	924	my ($self, $ssl, $ctx) = @_;
		925
		926	$self->stoptls;
679		927
680	if ($ssl eq "accept") {	928	if ($ssl eq "accept") {
681	$ssl = Net::SSLeay::new ($ctx \|\| TLS_CTX ());	929	$ssl = Net::SSLeay::new ($ctx \|\| TLS_CTX ());
682	Net::SSLeay::set_accept_state ($ssl);	930	Net::SSLeay::set_accept_state ($ssl);
683	} elsif ($ssl eq "connect") {	931	} elsif ($ssl eq "connect") {
684	$ssl = Net::SSLeay::new ($ctx \|\| TLS_CTX ());	932	$ssl = Net::SSLeay::new ($ctx \|\| TLS_CTX ());
685	Net::SSLeay::set_connect_state ($ssl);	933	Net::SSLeay::set_connect_state ($ssl);
686	}	934	}
687		935
688	$self->{tls} = $ssl;	936	$self->{tls} = $ssl;
		937
		938	# basically, this is deep magic (because SSL_read should have the same issues)
		939	# but the openssl maintainers basically said: "trust us, it just works".
		940	# (unfortunately, we have to hardcode constants because the abysmally misdesigned
		941	# and mismaintained ssleay-module doesn't even offer them).
		942	# http://www.mail-archive.com/openssl-dev@openssl.org/msg22420.html
		943	Net::SSLeay::CTX_set_mode ($self->{tls},
		944	(eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ENABLE_PARTIAL_WRITE () } \|\| 1)
		945	\| (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ACCEPT_MOVING_WRITE_BUFFER () } \|\| 2));
689		946
690	$self->{tls_rbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ());	947	$self->{tls_rbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ());
691	$self->{tls_wbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ());	948	$self->{tls_wbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ());
692		949
693	Net::SSLeay::set_bio ($ssl, $self->{tls_rbio}, $self->{tls_wbio});	950	Net::SSLeay::set_bio ($ssl, $self->{tls_rbio}, $self->{tls_wbio});
…		…
700	Net::SSLeay::BIO_write ($_[0]{tls_rbio}, ${$_[1]});	957	Net::SSLeay::BIO_write ($_[0]{tls_rbio}, ${$_[1]});
701	&_dotls;	958	&_dotls;
702	};	959	};
703	}	960	}
704		961
		962	=item $handle->stoptls
		963
		964	Destroys the SSL connection, if any. Partial read or write data will be
		965	lost.
		966
		967	=cut
		968
		969	sub stoptls {
		970	my ($self) = @_;
		971
		972	Net::SSLeay::free (delete $self->{tls}) if $self->{tls};
		973	delete $self->{tls_rbio};
		974	delete $self->{tls_wbio};
		975	delete $self->{tls_wbuf};
		976	delete $self->{filter_r};
		977	delete $self->{filter_w};
		978	}
		979
705	sub DESTROY {	980	sub DESTROY {
706	my $self = shift;	981	my $self = shift;
707		982
708	Net::SSLeay::free (delete $self->{tls}) if $self->{tls};	983	$self->stoptls;
709	}	984	}
710		985
711	=item AnyEvent::Handle::TLS_CTX	986	=item AnyEvent::Handle::TLS_CTX
712		987
713	This function creates and returns the Net::SSLeay::CTX object used by	988	This function creates and returns the Net::SSLeay::CTX object used by

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/Handle.pm (file contents): Revision 1.20 by elmex, Sat May 24 08:16:50 2008 UTC vs. Revision 1.36 by root, Mon May 26 18:26:52 2008 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/Handle.pm (file contents):
Revision 1.20 by elmex, Sat May 24 08:16:50 2008 UTC vs.
Revision 1.36 by root, Mon May 26 18:26:52 2008 UTC