ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/AnyEvent/lib/AnyEvent/Handle.pm
(Generate patch)

Comparing AnyEvent/lib/AnyEvent/Handle.pm (file contents):
Revision 1.36 by root, Mon May 26 18:26:52 2008 UTC vs.
Revision 1.77 by root, Sun Jul 27 07:25:39 2008 UTC

… …
2 2
3no warnings; 3no warnings;
4use strict; 4use strict;
5 5
6use AnyEvent (); 6use AnyEvent ();
7use AnyEvent::Util qw(WSAWOULDBLOCK); 7use AnyEvent::Util qw(WSAEWOULDBLOCK);
8use Scalar::Util (); 8use Scalar::Util ();
9use Carp (); 9use Carp ();
10use Fcntl (); 10use Fcntl ();
11use Errno qw/EAGAIN EINTR/; 11use Errno qw(EAGAIN EINTR);
12 12
13=head1 NAME 13=head1 NAME
14 14
15AnyEvent::Handle - non-blocking I/O on file handles via AnyEvent 15AnyEvent::Handle - non-blocking I/O on file handles via AnyEvent
16 16
17=cut 17=cut
18 18
19our $VERSION = '0.04'; 19our $VERSION = 4.22;
20 20
21=head1 SYNOPSIS 21=head1 SYNOPSIS
22 22
23 use AnyEvent; 23 use AnyEvent;
24 use AnyEvent::Handle; 24 use AnyEvent::Handle;
… …
73The filehandle this L<AnyEvent::Handle> object will operate on. 73The filehandle this L<AnyEvent::Handle> object will operate on.
74 74
75NOTE: The filehandle will be set to non-blocking (using 75NOTE: The filehandle will be set to non-blocking (using
76AnyEvent::Util::fh_nonblocking). 76AnyEvent::Util::fh_nonblocking).
77 77
78=item on_eof => $cb->($self) 78=item on_eof => $cb->($handle)
79 79
80Set the callback to be called on EOF. 80Set the callback to be called when an end-of-file condition is detected,
81i.e. in the case of a socket, when the other side has closed the
82connection cleanly.
81 83
82While not mandatory, it is highly recommended to set an eof callback, 84While not mandatory, it is highly recommended to set an eof callback,
83otherwise you might end up with a closed socket while you are still 85otherwise you might end up with a closed socket while you are still
84waiting for data. 86waiting for data.
85 87
86=item on_error => $cb->($self) 88=item on_error => $cb->($handle, $fatal)
87 89
88This is the fatal error callback, that is called when, well, a fatal error 90This is the error callback, which is called when, well, some error
89occurs, such as not being able to resolve the hostname, failure to connect 91occured, such as not being able to resolve the hostname, failure to
90or a read error. 92connect or a read error.
91 93
92The object will not be in a usable state when this callback has been 94Some errors are fatal (which is indicated by C<$fatal> being true). On
93called. 95fatal errors the handle object will be shut down and will not be
96usable. Non-fatal errors can be retried by simply returning, but it is
97recommended to simply ignore this parameter and instead abondon the handle
98object when this callback is invoked.
94 99
95On callback entrance, the value of C<$!> contains the operating system 100On callback entrance, the value of C<$!> contains the operating system
96error (or C<ENOSPC>, C<EPIPE> or C<EBADMSG>). 101error (or C<ENOSPC>, C<EPIPE>, C<ETIMEDOUT> or C<EBADMSG>).
97 102
98While not mandatory, it is I<highly> recommended to set this callback, as 103While not mandatory, it is I<highly> recommended to set this callback, as
99you will not be notified of errors otherwise. The default simply calls 104you will not be notified of errors otherwise. The default simply calls
100die. 105C<croak>.
101 106
102=item on_read => $cb->($self) 107=item on_read => $cb->($handle)
103 108
104This sets the default read callback, which is called when data arrives 109This sets the default read callback, which is called when data arrives
105and no read request is in the queue. 110and no read request is in the queue (unlike read queue callbacks, this
111callback will only be called when at least one octet of data is in the
112read buffer).
106 113
107To access (and remove data from) the read buffer, use the C<< ->rbuf >> 114To access (and remove data from) the read buffer, use the C<< ->rbuf >>
108method or access the C<$self->{rbuf}> member directly. 115method or access the C<$handle->{rbuf}> member directly.
109 116
110When an EOF condition is detected then AnyEvent::Handle will first try to 117When an EOF condition is detected then AnyEvent::Handle will first try to
111feed all the remaining data to the queued callbacks and C<on_read> before 118feed all the remaining data to the queued callbacks and C<on_read> before
112calling the C<on_eof> callback. If no progress can be made, then a fatal 119calling the C<on_eof> callback. If no progress can be made, then a fatal
113error will be raised (with C<$!> set to C<EPIPE>). 120error will be raised (with C<$!> set to C<EPIPE>).
114 121
115=item on_drain => $cb->() 122=item on_drain => $cb->($handle)
116 123
117This sets the callback that is called when the write buffer becomes empty 124This sets the callback that is called when the write buffer becomes empty
118(or when the callback is set and the buffer is empty already). 125(or when the callback is set and the buffer is empty already).
119 126
120To append to the write buffer, use the C<< ->push_write >> method. 127To append to the write buffer, use the C<< ->push_write >> method.
128
129This callback is useful when you don't want to put all of your write data
130into the queue at once, for example, when you want to write the contents
131of some file to the socket you might not want to read the whole file into
132memory and push it into the queue, but instead only read more data from
133the file when the write queue becomes empty.
134
135=item timeout => $fractional_seconds
136
137If non-zero, then this enables an "inactivity" timeout: whenever this many
138seconds pass without a successful read or write on the underlying file
139handle, the C<on_timeout> callback will be invoked (and if that one is
140missing, an C<ETIMEDOUT> error will be raised).
141
142Note that timeout processing is also active when you currently do not have
143any outstanding read or write requests: If you plan to keep the connection
144idle then you should disable the timout temporarily or ignore the timeout
145in the C<on_timeout> callback.
146
147Zero (the default) disables this timeout.
148
149=item on_timeout => $cb->($handle)
150
151Called whenever the inactivity timeout passes. If you return from this
152callback, then the timeout will be reset as if some activity had happened,
153so this condition is not fatal in any way.
121 154
122=item rbuf_max => <bytes> 155=item rbuf_max => <bytes>
123 156
124If defined, then a fatal error will be raised (with C<$!> set to C<ENOSPC>) 157If defined, then a fatal error will be raised (with C<$!> set to C<ENOSPC>)
125when the read buffer ever (strictly) exceeds this size. This is useful to 158when the read buffer ever (strictly) exceeds this size. This is useful to
… …
129be configured to accept only so-and-so much data that it cannot act on 162be configured to accept only so-and-so much data that it cannot act on
130(for example, when expecting a line, an attacker could send an unlimited 163(for example, when expecting a line, an attacker could send an unlimited
131amount of data without a callback ever being called as long as the line 164amount of data without a callback ever being called as long as the line
132isn't finished). 165isn't finished).
133 166
167=item autocork => <boolean>
168
169When disabled (the default), then C<push_write> will try to immediately
170write the data to the handle if possible. This avoids having to register
171a write watcher and wait for the next event loop iteration, but can be
172inefficient if you write multiple small chunks (this disadvantage is
173usually avoided by your kernel's nagle algorithm, see C<low_delay>).
174
175When enabled, then writes will always be queued till the next event loop
176iteration. This is efficient when you do many small writes per iteration,
177but less efficient when you do a single write only.
178
179=item no_delay => <boolean>
180
181When doing small writes on sockets, your operating system kernel might
182wait a bit for more data before actually sending it out. This is called
183the Nagle algorithm, and usually it is beneficial.
184
185In some situations you want as low a delay as possible, which cna be
186accomplishd by setting this option to true.
187
188The default is your opertaing system's default behaviour, this option
189explicitly enables or disables it, if possible.
190
134=item read_size => <bytes> 191=item read_size => <bytes>
135 192
136The default read block size (the amount of bytes this module will try to read 193The default read block size (the amount of bytes this module will try to read
137on each [loop iteration). Default: C<4096>. 194during each (loop iteration). Default: C<8192>.
138 195
139=item low_water_mark => <bytes> 196=item low_water_mark => <bytes>
140 197
141Sets the amount of bytes (default: C<0>) that make up an "empty" write 198Sets the amount of bytes (default: C<0>) that make up an "empty" write
142buffer: If the write reaches this size or gets even samller it is 199buffer: If the write reaches this size or gets even samller it is
143considered empty. 200considered empty.
201
202=item linger => <seconds>
203
204If non-zero (default: C<3600>), then the destructor of the
205AnyEvent::Handle object will check wether there is still outstanding write
206data and will install a watcher that will write out this data. No errors
207will be reported (this mostly matches how the operating system treats
208outstanding data at socket close time).
209
210This will not work for partial TLS data that could not yet been
211encoded. This data will be lost.
144 212
145=item tls => "accept" | "connect" | Net::SSLeay::SSL object 213=item tls => "accept" | "connect" | Net::SSLeay::SSL object
146 214
147When this parameter is given, it enables TLS (SSL) mode, that means it 215When this parameter is given, it enables TLS (SSL) mode, that means it
148will start making tls handshake and will transparently encrypt/decrypt 216will start making tls handshake and will transparently encrypt/decrypt
… …
157You can also provide your own TLS connection object, but you have 225You can also provide your own TLS connection object, but you have
158to make sure that you call either C<Net::SSLeay::set_connect_state> 226to make sure that you call either C<Net::SSLeay::set_connect_state>
159or C<Net::SSLeay::set_accept_state> on it before you pass it to 227or C<Net::SSLeay::set_accept_state> on it before you pass it to
160AnyEvent::Handle. 228AnyEvent::Handle.
161 229
162See the C<starttls> method if you need to start TLs negotiation later. 230See the C<starttls> method if you need to start TLS negotiation later.
163 231
164=item tls_ctx => $ssl_ctx 232=item tls_ctx => $ssl_ctx
165 233
166Use the given Net::SSLeay::CTX object to create the new TLS connection 234Use the given Net::SSLeay::CTX object to create the new TLS connection
167(unless a connection object was specified directly). If this parameter is 235(unless a connection object was specified directly). If this parameter is
168missing, then AnyEvent::Handle will use C<AnyEvent::Handle::TLS_CTX>. 236missing, then AnyEvent::Handle will use C<AnyEvent::Handle::TLS_CTX>.
169 237
238=item json => JSON or JSON::XS object
239
240This is the json coder object used by the C<json> read and write types.
241
242If you don't supply it, then AnyEvent::Handle will create and use a
243suitable one, which will write and expect UTF-8 encoded JSON texts.
244
245Note that you are responsible to depend on the JSON module if you want to
246use this functionality, as AnyEvent does not have a dependency itself.
247
248=item filter_r => $cb
249
250=item filter_w => $cb
251
252These exist, but are undocumented at this time.
253
170=back 254=back
171 255
172=cut 256=cut
173 257
174sub new { 258sub new {
… …
183 if ($self->{tls}) { 267 if ($self->{tls}) {
184 require Net::SSLeay; 268 require Net::SSLeay;
185 $self->starttls (delete $self->{tls}, delete $self->{tls_ctx}); 269 $self->starttls (delete $self->{tls}, delete $self->{tls_ctx});
186 } 270 }
187 271
188 $self->on_eof (delete $self->{on_eof} ) if $self->{on_eof}; 272 $self->{_activity} = AnyEvent->now;
189 $self->on_error (delete $self->{on_error}) if $self->{on_error}; 273 $self->_timeout;
274
190 $self->on_drain (delete $self->{on_drain}) if $self->{on_drain}; 275 $self->on_drain (delete $self->{on_drain}) if exists $self->{on_drain};
191 $self->on_read (delete $self->{on_read} ) if $self->{on_read}; 276 $self->no_delay (delete $self->{no_delay}) if exists $self->{no_delay};
192 277
193 $self->start_read; 278 $self->start_read
279 if $self->{on_read};
194 280
195 $self 281 $self
196} 282}
197 283
198sub _shutdown { 284sub _shutdown {
199 my ($self) = @_; 285 my ($self) = @_;
200 286
287 delete $self->{_tw};
201 delete $self->{rw}; 288 delete $self->{_rw};
202 delete $self->{ww}; 289 delete $self->{_ww};
203 delete $self->{fh}; 290 delete $self->{fh};
204}
205 291
292 $self->stoptls;
293}
294
206sub error { 295sub _error {
207 my ($self) = @_; 296 my ($self, $errno, $fatal) = @_;
208 297
209 {
210 local $!;
211 $self->_shutdown; 298 $self->_shutdown
212 } 299 if $fatal;
300
301 $! = $errno;
213 302
214 if ($self->{on_error}) { 303 if ($self->{on_error}) {
215 $self->{on_error}($self); 304 $self->{on_error}($self, $fatal);
216 } else { 305 } else {
217 Carp::croak "AnyEvent::Handle uncaught fatal error: $!"; 306 Carp::croak "AnyEvent::Handle uncaught error: $!";
218 } 307 }
219} 308}
220 309
221=item $fh = $handle->fh 310=item $fh = $handle->fh
222 311
223This method returns the file handle of the L<AnyEvent::Handle> object. 312This method returns the file handle of the L<AnyEvent::Handle> object.
224 313
225=cut 314=cut
226 315
227sub fh { $_[0]->{fh} } 316sub fh { $_[0]{fh} }
228 317
229=item $handle->on_error ($cb) 318=item $handle->on_error ($cb)
230 319
231Replace the current C<on_error> callback (see the C<on_error> constructor argument). 320Replace the current C<on_error> callback (see the C<on_error> constructor argument).
232 321
… …
242 331
243=cut 332=cut
244 333
245sub on_eof { 334sub on_eof {
246 $_[0]{on_eof} = $_[1]; 335 $_[0]{on_eof} = $_[1];
336}
337
338=item $handle->on_timeout ($cb)
339
340Replace the current C<on_timeout> callback, or disables the callback
341(but not the timeout) if C<$cb> = C<undef>. See C<timeout> constructor
342argument.
343
344=cut
345
346sub on_timeout {
347 $_[0]{on_timeout} = $_[1];
348}
349
350=item $handle->autocork ($boolean)
351
352Enables or disables the current autocork behaviour (see C<autocork>
353constructor argument).
354
355=cut
356
357=item $handle->no_delay ($boolean)
358
359Enables or disables the C<no_delay> setting (see constructor argument of
360the same name for details).
361
362=cut
363
364sub no_delay {
365 $_[0]{no_delay} = $_[1];
366
367 eval {
368 local $SIG{__DIE__};
369 setsockopt $_[0]{fh}, &Socket::IPPROTO_TCP, &Socket::TCP_NODELAY, int $_[1];
370 };
371}
372
373#############################################################################
374
375=item $handle->timeout ($seconds)
376
377Configures (or disables) the inactivity timeout.
378
379=cut
380
381sub timeout {
382 my ($self, $timeout) = @_;
383
384 $self->{timeout} = $timeout;
385 $self->_timeout;
386}
387
388# reset the timeout watcher, as neccessary
389# also check for time-outs
390sub _timeout {
391 my ($self) = @_;
392
393 if ($self->{timeout}) {
394 my $NOW = AnyEvent->now;
395
396 # when would the timeout trigger?
397 my $after = $self->{_activity} + $self->{timeout} - $NOW;
398
399 # now or in the past already?
400 if ($after <= 0) {
401 $self->{_activity} = $NOW;
402
403 if ($self->{on_timeout}) {
404 $self->{on_timeout}($self);
405 } else {
406 $self->_error (&Errno::ETIMEDOUT);
407 }
408
409 # callback could have changed timeout value, optimise
410 return unless $self->{timeout};
411
412 # calculate new after
413 $after = $self->{timeout};
414 }
415
416 Scalar::Util::weaken $self;
417 return unless $self; # ->error could have destroyed $self
418
419 $self->{_tw} ||= AnyEvent->timer (after => $after, cb => sub {
420 delete $self->{_tw};
421 $self->_timeout;
422 });
423 } else {
424 delete $self->{_tw};
425 }
247} 426}
248 427
249############################################################################# 428#############################################################################
250 429
251=back 430=back
… …
288=cut 467=cut
289 468
290sub _drain_wbuf { 469sub _drain_wbuf {
291 my ($self) = @_; 470 my ($self) = @_;
292 471
293 if (!$self->{ww} && length $self->{wbuf}) { 472 if (!$self->{_ww} && length $self->{wbuf}) {
294 473
295 Scalar::Util::weaken $self; 474 Scalar::Util::weaken $self;
296 475
297 my $cb = sub { 476 my $cb = sub {
298 my $len = syswrite $self->{fh}, $self->{wbuf}; 477 my $len = syswrite $self->{fh}, $self->{wbuf};
299 478
300 if ($len >= 0) { 479 if ($len >= 0) {
301 substr $self->{wbuf}, 0, $len, ""; 480 substr $self->{wbuf}, 0, $len, "";
481
482 $self->{_activity} = AnyEvent->now;
302 483
303 $self->{on_drain}($self) 484 $self->{on_drain}($self)
304 if $self->{low_water_mark} >= length $self->{wbuf} 485 if $self->{low_water_mark} >= length $self->{wbuf}
305 && $self->{on_drain}; 486 && $self->{on_drain};
306 487
307 delete $self->{ww} unless length $self->{wbuf}; 488 delete $self->{_ww} unless length $self->{wbuf};
308 } elsif ($! != EAGAIN && $! != EINTR && $! != WSAWOULDBLOCK) { 489 } elsif ($! != EAGAIN && $! != EINTR && $! != WSAEWOULDBLOCK) {
309 $self->error; 490 $self->_error ($!, 1);
310 } 491 }
311 }; 492 };
312 493
313 # try to write data immediately 494 # try to write data immediately
314 $cb->(); 495 $cb->() unless $self->{autocork};
315 496
316 # if still data left in wbuf, we need to poll 497 # if still data left in wbuf, we need to poll
317 $self->{ww} = AnyEvent->io (fh => $self->{fh}, poll => "w", cb => $cb) 498 $self->{_ww} = AnyEvent->io (fh => $self->{fh}, poll => "w", cb => $cb)
318 if length $self->{wbuf}; 499 if length $self->{wbuf};
319 }; 500 };
320} 501}
321 502
322our %WH; 503our %WH;
… …
334 @_ = ($WH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::push_write") 515 @_ = ($WH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::push_write")
335 ->($self, @_); 516 ->($self, @_);
336 } 517 }
337 518
338 if ($self->{filter_w}) { 519 if ($self->{filter_w}) {
339 $self->{filter_w}->($self, \$_[0]); 520 $self->{filter_w}($self, \$_[0]);
340 } else { 521 } else {
341 $self->{wbuf} .= $_[0]; 522 $self->{wbuf} .= $_[0];
342 $self->_drain_wbuf; 523 $self->_drain_wbuf;
343 } 524 }
344} 525}
345 526
346=item $handle->push_write (type => @args) 527=item $handle->push_write (type => @args)
347 528
348=item $handle->unshift_write (type => @args)
349
350Instead of formatting your data yourself, you can also let this module do 529Instead of formatting your data yourself, you can also let this module do
351the job by specifying a type and type-specific arguments. 530the job by specifying a type and type-specific arguments.
352 531
353Predefined types are (if you have ideas for additional types, feel free to 532Predefined types are (if you have ideas for additional types, feel free to
354drop by and tell us): 533drop by and tell us):
… …
358=item netstring => $string 537=item netstring => $string
359 538
360Formats the given value as netstring 539Formats the given value as netstring
361(http://cr.yp.to/proto/netstrings.txt, this is not a recommendation to use them). 540(http://cr.yp.to/proto/netstrings.txt, this is not a recommendation to use them).
362 541
363=back
364
365=cut 542=cut
366 543
367register_write_type netstring => sub { 544register_write_type netstring => sub {
368 my ($self, $string) = @_; 545 my ($self, $string) = @_;
369 546
370 sprintf "%d:%s,", (length $string), $string 547 sprintf "%d:%s,", (length $string), $string
371}; 548};
372 549
550=item packstring => $format, $data
551
552An octet string prefixed with an encoded length. The encoding C<$format>
553uses the same format as a Perl C<pack> format, but must specify a single
554integer only (only one of C<cCsSlLqQiInNvVjJw> is allowed, plus an
555optional C<!>, C<< < >> or C<< > >> modifier).
556
557=cut
558
559register_write_type packstring => sub {
560 my ($self, $format, $string) = @_;
561
562 pack "$format/a*", $string
563};
564
565=item json => $array_or_hashref
566
567Encodes the given hash or array reference into a JSON object. Unless you
568provide your own JSON object, this means it will be encoded to JSON text
569in UTF-8.
570
571JSON objects (and arrays) are self-delimiting, so you can write JSON at
572one end of a handle and read them at the other end without using any
573additional framing.
574
575The generated JSON text is guaranteed not to contain any newlines: While
576this module doesn't need delimiters after or between JSON texts to be
577able to read them, many other languages depend on that.
578
579A simple RPC protocol that interoperates easily with others is to send
580JSON arrays (or objects, although arrays are usually the better choice as
581they mimic how function argument passing works) and a newline after each
582JSON text:
583
584 $handle->push_write (json => ["method", "arg1", "arg2"]); # whatever
585 $handle->push_write ("\012");
586
587An AnyEvent::Handle receiver would simply use the C<json> read type and
588rely on the fact that the newline will be skipped as leading whitespace:
589
590 $handle->push_read (json => sub { my $array = $_[1]; ... });
591
592Other languages could read single lines terminated by a newline and pass
593this line into their JSON decoder of choice.
594
595=cut
596
597register_write_type json => sub {
598 my ($self, $ref) = @_;
599
600 require JSON;
601
602 $self->{json} ? $self->{json}->encode ($ref)
603 : JSON::encode_json ($ref)
604};
605
606=item storable => $reference
607
608Freezes the given reference using L<Storable> and writes it to the
609handle. Uses the C<nfreeze> format.
610
611=cut
612
613register_write_type storable => sub {
614 my ($self, $ref) = @_;
615
616 require Storable;
617
618 pack "w/a*", Storable::nfreeze ($ref)
619};
620
621=back
622
373=item AnyEvent::Handle::register_write_type type => $coderef->($self, @args) 623=item AnyEvent::Handle::register_write_type type => $coderef->($handle, @args)
374 624
375This function (not method) lets you add your own types to C<push_write>. 625This function (not method) lets you add your own types to C<push_write>.
376Whenever the given C<type> is used, C<push_write> will invoke the code 626Whenever the given C<type> is used, C<push_write> will invoke the code
377reference with the handle object and the remaining arguments. 627reference with the handle object and the remaining arguments.
378 628
… …
397ways, the "simple" way, using only C<on_read> and the "complex" way, using 647ways, the "simple" way, using only C<on_read> and the "complex" way, using
398a queue. 648a queue.
399 649
400In the simple case, you just install an C<on_read> callback and whenever 650In the simple case, you just install an C<on_read> callback and whenever
401new data arrives, it will be called. You can then remove some data (if 651new data arrives, it will be called. You can then remove some data (if
402enough is there) from the read buffer (C<< $handle->rbuf >>) if you want 652enough is there) from the read buffer (C<< $handle->rbuf >>). Or you cna
403or not. 653leave the data there if you want to accumulate more (e.g. when only a
654partial message has been received so far).
404 655
405In the more complex case, you want to queue multiple callbacks. In this 656In the more complex case, you want to queue multiple callbacks. In this
406case, AnyEvent::Handle will call the first queued callback each time new 657case, AnyEvent::Handle will call the first queued callback each time new
407data arrives and removes it when it has done its job (see C<push_read>, 658data arrives (also the first time it is queued) and removes it when it has
408below). 659done its job (see C<push_read>, below).
409 660
410This way you can, for example, push three line-reads, followed by reading 661This way you can, for example, push three line-reads, followed by reading
411a chunk of data, and AnyEvent::Handle will execute them in order. 662a chunk of data, and AnyEvent::Handle will execute them in order.
412 663
413Example 1: EPP protocol parser. EPP sends 4 byte length info, followed by 664Example 1: EPP protocol parser. EPP sends 4 byte length info, followed by
414the specified number of bytes which give an XML datagram. 665the specified number of bytes which give an XML datagram.
415 666
416 # in the default state, expect some header bytes 667 # in the default state, expect some header bytes
417 $handle->on_read (sub { 668 $handle->on_read (sub {
418 # some data is here, now queue the length-header-read (4 octets) 669 # some data is here, now queue the length-header-read (4 octets)
419 shift->unshift_read_chunk (4, sub { 670 shift->unshift_read (chunk => 4, sub {
420 # header arrived, decode 671 # header arrived, decode
421 my $len = unpack "N", $_[1]; 672 my $len = unpack "N", $_[1];
422 673
423 # now read the payload 674 # now read the payload
424 shift->unshift_read_chunk ($len, sub { 675 shift->unshift_read (chunk => $len, sub {
425 my $xml = $_[1]; 676 my $xml = $_[1];
426 # handle xml 677 # handle xml
427 }); 678 });
428 }); 679 });
429 }); 680 });
430 681
431Example 2: Implement a client for a protocol that replies either with 682Example 2: Implement a client for a protocol that replies either with "OK"
432"OK" and another line or "ERROR" for one request, and 64 bytes for the 683and another line or "ERROR" for the first request that is sent, and 64
433second request. Due tot he availability of a full queue, we can just 684bytes for the second request. Due to the availability of a queue, we can
434pipeline sending both requests and manipulate the queue as necessary in 685just pipeline sending both requests and manipulate the queue as necessary
435the callbacks: 686in the callbacks.
436 687
437 # request one 688When the first callback is called and sees an "OK" response, it will
689C<unshift> another line-read. This line-read will be queued I<before> the
69064-byte chunk callback.
691
692 # request one, returns either "OK + extra line" or "ERROR"
438 $handle->push_write ("request 1\015\012"); 693 $handle->push_write ("request 1\015\012");
439 694
440 # we expect "ERROR" or "OK" as response, so push a line read 695 # we expect "ERROR" or "OK" as response, so push a line read
441 $handle->push_read_line (sub { 696 $handle->push_read (line => sub {
442 # if we got an "OK", we have to _prepend_ another line, 697 # if we got an "OK", we have to _prepend_ another line,
443 # so it will be read before the second request reads its 64 bytes 698 # so it will be read before the second request reads its 64 bytes
444 # which are already in the queue when this callback is called 699 # which are already in the queue when this callback is called
445 # we don't do this in case we got an error 700 # we don't do this in case we got an error
446 if ($_[1] eq "OK") { 701 if ($_[1] eq "OK") {
447 $_[0]->unshift_read_line (sub { 702 $_[0]->unshift_read (line => sub {
448 my $response = $_[1]; 703 my $response = $_[1];
449 ... 704 ...
450 }); 705 });
451 } 706 }
452 }); 707 });
453 708
454 # request two 709 # request two, simply returns 64 octets
455 $handle->push_write ("request 2\015\012"); 710 $handle->push_write ("request 2\015\012");
456 711
457 # simply read 64 bytes, always 712 # simply read 64 bytes, always
458 $handle->push_read_chunk (64, sub { 713 $handle->push_read (chunk => 64, sub {
459 my $response = $_[1]; 714 my $response = $_[1];
460 ... 715 ...
461 }); 716 });
462 717
463=over 4 718=over 4
464 719
465=cut 720=cut
466 721
467sub _drain_rbuf { 722sub _drain_rbuf {
468 my ($self) = @_; 723 my ($self) = @_;
724
725 local $self->{_in_drain} = 1;
469 726
470 if ( 727 if (
471 defined $self->{rbuf_max} 728 defined $self->{rbuf_max}
472 && $self->{rbuf_max} < length $self->{rbuf} 729 && $self->{rbuf_max} < length $self->{rbuf}
473 ) { 730 ) {
474 $! = &Errno::ENOSPC; return $self->error; 731 return $self->_error (&Errno::ENOSPC, 1);
475 } 732 }
476 733
477 return if $self->{in_drain}; 734 while () {
478 local $self->{in_drain} = 1;
479
480 while (my $len = length $self->{rbuf}) {
481 no strict 'refs'; 735 no strict 'refs';
736
737 my $len = length $self->{rbuf};
738
482 if (my $cb = shift @{ $self->{queue} }) { 739 if (my $cb = shift @{ $self->{_queue} }) {
483 unless ($cb->($self)) { 740 unless ($cb->($self)) {
484 if ($self->{eof}) { 741 if ($self->{_eof}) {
485 # no progress can be made (not enough data and no data forthcoming) 742 # no progress can be made (not enough data and no data forthcoming)
486 $! = &Errno::EPIPE; return $self->error; 743 $self->_error (&Errno::EPIPE, 1), last;
487 } 744 }
488 745
489 unshift @{ $self->{queue} }, $cb; 746 unshift @{ $self->{_queue} }, $cb;
490 return; 747 last;
491 } 748 }
492 } elsif ($self->{on_read}) { 749 } elsif ($self->{on_read}) {
750 last unless $len;
751
493 $self->{on_read}($self); 752 $self->{on_read}($self);
494 753
495 if ( 754 if (
496 $self->{eof} # if no further data will arrive
497 && $len == length $self->{rbuf} # and no data has been consumed 755 $len == length $self->{rbuf} # if no data has been consumed
498 && !@{ $self->{queue} } # and the queue is still empty 756 && !@{ $self->{_queue} } # and the queue is still empty
499 && $self->{on_read} # and we still want to read data 757 && $self->{on_read} # but we still have on_read
500 ) { 758 ) {
759 # no further data will arrive
501 # then no progress can be made 760 # so no progress can be made
502 $! = &Errno::EPIPE; return $self->error; 761 $self->_error (&Errno::EPIPE, 1), last
762 if $self->{_eof};
763
764 last; # more data might arrive
503 } 765 }
504 } else { 766 } else {
505 # read side becomes idle 767 # read side becomes idle
506 delete $self->{rw}; 768 delete $self->{_rw};
507 return; 769 last;
508 } 770 }
509 } 771 }
510 772
511 if ($self->{eof}) {
512 $self->_shutdown;
513 $self->{on_eof}($self) 773 $self->{on_eof}($self)
514 if $self->{on_eof}; 774 if $self->{_eof} && $self->{on_eof};
775
776 # may need to restart read watcher
777 unless ($self->{_rw}) {
778 $self->start_read
779 if $self->{on_read} || @{ $self->{_queue} };
515 } 780 }
516} 781}
517 782
518=item $handle->on_read ($cb) 783=item $handle->on_read ($cb)
519 784
… …
525 790
526sub on_read { 791sub on_read {
527 my ($self, $cb) = @_; 792 my ($self, $cb) = @_;
528 793
529 $self->{on_read} = $cb; 794 $self->{on_read} = $cb;
795 $self->_drain_rbuf if $cb && !$self->{_in_drain};
530} 796}
531 797
532=item $handle->rbuf 798=item $handle->rbuf
533 799
534Returns the read buffer (as a modifiable lvalue). 800Returns the read buffer (as a modifiable lvalue).
… …
582 848
583 $cb = ($RH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::push_read") 849 $cb = ($RH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::push_read")
584 ->($self, $cb, @_); 850 ->($self, $cb, @_);
585 } 851 }
586 852
587 push @{ $self->{queue} }, $cb; 853 push @{ $self->{_queue} }, $cb;
588 $self->_drain_rbuf; 854 $self->_drain_rbuf unless $self->{_in_drain};
589} 855}
590 856
591sub unshift_read { 857sub unshift_read {
592 my $self = shift; 858 my $self = shift;
593 my $cb = pop; 859 my $cb = pop;
… …
598 $cb = ($RH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::unshift_read") 864 $cb = ($RH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::unshift_read")
599 ->($self, $cb, @_); 865 ->($self, $cb, @_);
600 } 866 }
601 867
602 868
603 unshift @{ $self->{queue} }, $cb; 869 unshift @{ $self->{_queue} }, $cb;
604 $self->_drain_rbuf; 870 $self->_drain_rbuf unless $self->{_in_drain};
605} 871}
606 872
607=item $handle->push_read (type => @args, $cb) 873=item $handle->push_read (type => @args, $cb)
608 874
609=item $handle->unshift_read (type => @args, $cb) 875=item $handle->unshift_read (type => @args, $cb)
… …
615Predefined types are (if you have ideas for additional types, feel free to 881Predefined types are (if you have ideas for additional types, feel free to
616drop by and tell us): 882drop by and tell us):
617 883
618=over 4 884=over 4
619 885
620=item chunk => $octets, $cb->($self, $data) 886=item chunk => $octets, $cb->($handle, $data)
621 887
622Invoke the callback only once C<$octets> bytes have been read. Pass the 888Invoke the callback only once C<$octets> bytes have been read. Pass the
623data read to the callback. The callback will never be called with less 889data read to the callback. The callback will never be called with less
624data. 890data.
625 891
… …
648 914
649sub unshift_read_chunk { 915sub unshift_read_chunk {
650 $_[0]->unshift_read (chunk => $_[1], $_[2]); 916 $_[0]->unshift_read (chunk => $_[1], $_[2]);
651} 917}
652 918
653=item line => [$eol, ]$cb->($self, $line, $eol) 919=item line => [$eol, ]$cb->($handle, $line, $eol)
654 920
655The callback will be called only once a full line (including the end of 921The callback will be called only once a full line (including the end of
656line marker, C<$eol>) has been read. This line (excluding the end of line 922line marker, C<$eol>) has been read. This line (excluding the end of line
657marker) will be passed to the callback as second argument (C<$line>), and 923marker) will be passed to the callback as second argument (C<$line>), and
658the end of line marker as the third argument (C<$eol>). 924the end of line marker as the third argument (C<$eol>).
… …
672=cut 938=cut
673 939
674register_read_type line => sub { 940register_read_type line => sub {
675 my ($self, $cb, $eol) = @_; 941 my ($self, $cb, $eol) = @_;
676 942
677 $eol = qr|(\015?\012)| if @_ < 3; 943 if (@_ < 3) {
944 # this is more than twice as fast as the generic code below
945 sub {
946 $_[0]{rbuf} =~ s/^([^\015\012]*)(\015?\012)// or return;
947
948 $cb->($_[0], $1, $2);
949 1
950 }
951 } else {
678 $eol = quotemeta $eol unless ref $eol; 952 $eol = quotemeta $eol unless ref $eol;
679 $eol = qr|^(.*?)($eol)|s; 953 $eol = qr|^(.*?)($eol)|s;
680 954
681 sub { 955 sub {
682 $_[0]{rbuf} =~ s/$eol// or return; 956 $_[0]{rbuf} =~ s/$eol// or return;
683 957
684 $cb->($_[0], $1, $2); 958 $cb->($_[0], $1, $2);
959 1
685 1 960 }
686 } 961 }
687}; 962};
688 963
689# compatibility with older API 964# compatibility with older API
690sub push_read_line { 965sub push_read_line {
… …
695sub unshift_read_line { 970sub unshift_read_line {
696 my $self = shift; 971 my $self = shift;
697 $self->unshift_read (line => @_); 972 $self->unshift_read (line => @_);
698} 973}
699 974
700=item netstring => $cb->($string)
701
702A netstring (http://cr.yp.to/proto/netstrings.txt, this is not an endorsement).
703
704Throws an error with C<$!> set to EBADMSG on format violations.
705
706=cut
707
708register_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) 975=item regex => $accept[, $reject[, $skip], $cb->($handle, $data)
739 976
740Makes a regex match against the regex object C<$accept> and returns 977Makes a regex match against the regex object C<$accept> and returns
741everything up to and including the match. 978everything up to and including the match.
742 979
743Example: read a single line terminated by '\n'. 980Example: read a single line terminated by '\n'.
… …
791 return 1; 1028 return 1;
792 } 1029 }
793 1030
794 # reject 1031 # reject
795 if ($reject && $$rbuf =~ $reject) { 1032 if ($reject && $$rbuf =~ $reject) {
796 $! = &Errno::EBADMSG; 1033 $self->_error (&Errno::EBADMSG);
797 $self->error;
798 } 1034 }
799 1035
800 # skip 1036 # skip
801 if ($skip && $$rbuf =~ $skip) { 1037 if ($skip && $$rbuf =~ $skip) {
802 $data .= substr $$rbuf, 0, $+[0], ""; 1038 $data .= substr $$rbuf, 0, $+[0], "";
… …
804 1040
805 () 1041 ()
806 } 1042 }
807}; 1043};
808 1044
1045=item netstring => $cb->($handle, $string)
1046
1047A netstring (http://cr.yp.to/proto/netstrings.txt, this is not an endorsement).
1048
1049Throws an error with C<$!> set to EBADMSG on format violations.
1050
1051=cut
1052
1053register_read_type netstring => sub {
1054 my ($self, $cb) = @_;
1055
1056 sub {
1057 unless ($_[0]{rbuf} =~ s/^(0|[1-9][0-9]*)://) {
1058 if ($_[0]{rbuf} =~ /[^0-9]/) {
1059 $self->_error (&Errno::EBADMSG);
1060 }
1061 return;
1062 }
1063
1064 my $len = $1;
1065
1066 $self->unshift_read (chunk => $len, sub {
1067 my $string = $_[1];
1068 $_[0]->unshift_read (chunk => 1, sub {
1069 if ($_[1] eq ",") {
1070 $cb->($_[0], $string);
1071 } else {
1072 $self->_error (&Errno::EBADMSG);
1073 }
1074 });
1075 });
1076
1077 1
1078 }
1079};
1080
1081=item packstring => $format, $cb->($handle, $string)
1082
1083An octet string prefixed with an encoded length. The encoding C<$format>
1084uses the same format as a Perl C<pack> format, but must specify a single
1085integer only (only one of C<cCsSlLqQiInNvVjJw> is allowed, plus an
1086optional C<!>, C<< < >> or C<< > >> modifier).
1087
1088DNS over TCP uses a prefix of C<n>, EPP uses a prefix of C<N>.
1089
1090Example: read a block of data prefixed by its length in BER-encoded
1091format (very efficient).
1092
1093 $handle->push_read (packstring => "w", sub {
1094 my ($handle, $data) = @_;
1095 });
1096
1097=cut
1098
1099register_read_type packstring => sub {
1100 my ($self, $cb, $format) = @_;
1101
1102 sub {
1103 # when we can use 5.10 we can use ".", but for 5.8 we use the re-pack method
1104 defined (my $len = eval { unpack $format, $_[0]{rbuf} })
1105 or return;
1106
1107 $format = length pack $format, $len;
1108
1109 # bypass unshift if we already have the remaining chunk
1110 if ($format + $len <= length $_[0]{rbuf}) {
1111 my $data = substr $_[0]{rbuf}, $format, $len;
1112 substr $_[0]{rbuf}, 0, $format + $len, "";
1113 $cb->($_[0], $data);
1114 } else {
1115 # remove prefix
1116 substr $_[0]{rbuf}, 0, $format, "";
1117
1118 # read remaining chunk
1119 $_[0]->unshift_read (chunk => $len, $cb);
1120 }
1121
1122 1
1123 }
1124};
1125
1126=item json => $cb->($handle, $hash_or_arrayref)
1127
1128Reads a JSON object or array, decodes it and passes it to the callback.
1129
1130If a C<json> object was passed to the constructor, then that will be used
1131for the final decode, otherwise it will create a JSON coder expecting UTF-8.
1132
1133This read type uses the incremental parser available with JSON version
11342.09 (and JSON::XS version 2.2) and above. You have to provide a
1135dependency on your own: this module will load the JSON module, but
1136AnyEvent does not depend on it itself.
1137
1138Since JSON texts are fully self-delimiting, the C<json> read and write
1139types are an ideal simple RPC protocol: just exchange JSON datagrams. See
1140the C<json> write type description, above, for an actual example.
1141
1142=cut
1143
1144register_read_type json => sub {
1145 my ($self, $cb) = @_;
1146
1147 require JSON;
1148
1149 my $data;
1150 my $rbuf = \$self->{rbuf};
1151
1152 my $json = $self->{json} ||= JSON->new->utf8;
1153
1154 sub {
1155 my $ref = $json->incr_parse ($self->{rbuf});
1156
1157 if ($ref) {
1158 $self->{rbuf} = $json->incr_text;
1159 $json->incr_text = "";
1160 $cb->($self, $ref);
1161
1162 1
1163 } else {
1164 $self->{rbuf} = "";
1165 ()
1166 }
1167 }
1168};
1169
1170=item storable => $cb->($handle, $ref)
1171
1172Deserialises a L<Storable> frozen representation as written by the
1173C<storable> write type (BER-encoded length prefix followed by nfreeze'd
1174data).
1175
1176Raises C<EBADMSG> error if the data could not be decoded.
1177
1178=cut
1179
1180register_read_type storable => sub {
1181 my ($self, $cb) = @_;
1182
1183 require Storable;
1184
1185 sub {
1186 # when we can use 5.10 we can use ".", but for 5.8 we use the re-pack method
1187 defined (my $len = eval { unpack "w", $_[0]{rbuf} })
1188 or return;
1189
1190 my $format = length pack "w", $len;
1191
1192 # bypass unshift if we already have the remaining chunk
1193 if ($format + $len <= length $_[0]{rbuf}) {
1194 my $data = substr $_[0]{rbuf}, $format, $len;
1195 substr $_[0]{rbuf}, 0, $format + $len, "";
1196 $cb->($_[0], Storable::thaw ($data));
1197 } else {
1198 # remove prefix
1199 substr $_[0]{rbuf}, 0, $format, "";
1200
1201 # read remaining chunk
1202 $_[0]->unshift_read (chunk => $len, sub {
1203 if (my $ref = eval { Storable::thaw ($_[1]) }) {
1204 $cb->($_[0], $ref);
1205 } else {
1206 $self->_error (&Errno::EBADMSG);
1207 }
1208 });
1209 }
1210
1211 1
1212 }
1213};
1214
809=back 1215=back
810 1216
811=item AnyEvent::Handle::register_read_type type => $coderef->($self, $cb, @args) 1217=item AnyEvent::Handle::register_read_type type => $coderef->($handle, $cb, @args)
812 1218
813This function (not method) lets you add your own types to C<push_read>. 1219This function (not method) lets you add your own types to C<push_read>.
814 1220
815Whenever the given C<type> is used, C<push_read> will invoke the code 1221Whenever the given C<type> is used, C<push_read> will invoke the code
816reference with the handle object, the callback and the remaining 1222reference with the handle object, the callback and the remaining
… …
818 1224
819The code reference is supposed to return a callback (usually a closure) 1225The code reference is supposed to return a callback (usually a closure)
820that works as a plain read callback (see C<< ->push_read ($cb) >>). 1226that works as a plain read callback (see C<< ->push_read ($cb) >>).
821 1227
822It should invoke the passed callback when it is done reading (remember to 1228It should invoke the passed callback when it is done reading (remember to
823pass C<$self> as first argument as all other callbacks do that). 1229pass C<$handle> as first argument as all other callbacks do that).
824 1230
825Note that this is a function, and all types registered this way will be 1231Note that this is a function, and all types registered this way will be
826global, so try to use unique names. 1232global, so try to use unique names.
827 1233
828For examples, see the source of this module (F<perldoc -m AnyEvent::Handle>, 1234For examples, see the source of this module (F<perldoc -m AnyEvent::Handle>,
… …
831=item $handle->stop_read 1237=item $handle->stop_read
832 1238
833=item $handle->start_read 1239=item $handle->start_read
834 1240
835In rare cases you actually do not want to read anything from the 1241In rare cases you actually do not want to read anything from the
836socket. In this case you can call C<stop_read>. Neither C<on_read> no 1242socket. In this case you can call C<stop_read>. Neither C<on_read> nor
837any queued callbacks will be executed then. To start reading again, call 1243any queued callbacks will be executed then. To start reading again, call
838C<start_read>. 1244C<start_read>.
839 1245
1246Note that AnyEvent::Handle will automatically C<start_read> for you when
1247you change the C<on_read> callback or push/unshift a read callback, and it
1248will automatically C<stop_read> for you when neither C<on_read> is set nor
1249there are any read requests in the queue.
1250
840=cut 1251=cut
841 1252
842sub stop_read { 1253sub stop_read {
843 my ($self) = @_; 1254 my ($self) = @_;
844 1255
845 delete $self->{rw}; 1256 delete $self->{_rw};
846} 1257}
847 1258
848sub start_read { 1259sub start_read {
849 my ($self) = @_; 1260 my ($self) = @_;
850 1261
851 unless ($self->{rw} || $self->{eof}) { 1262 unless ($self->{_rw} || $self->{_eof}) {
852 Scalar::Util::weaken $self; 1263 Scalar::Util::weaken $self;
853 1264
854 $self->{rw} = AnyEvent->io (fh => $self->{fh}, poll => "r", cb => sub { 1265 $self->{_rw} = AnyEvent->io (fh => $self->{fh}, poll => "r", cb => sub {
855 my $rbuf = $self->{filter_r} ? \my $buf : \$self->{rbuf}; 1266 my $rbuf = $self->{filter_r} ? \my $buf : \$self->{rbuf};
856 my $len = sysread $self->{fh}, $$rbuf, $self->{read_size} || 8192, length $$rbuf; 1267 my $len = sysread $self->{fh}, $$rbuf, $self->{read_size} || 8192, length $$rbuf;
857 1268
858 if ($len > 0) { 1269 if ($len > 0) {
1270 $self->{_activity} = AnyEvent->now;
1271
859 $self->{filter_r} 1272 $self->{filter_r}
860 ? $self->{filter_r}->($self, $rbuf) 1273 ? $self->{filter_r}($self, $rbuf)
861 : $self->_drain_rbuf; 1274 : $self->{_in_drain} || $self->_drain_rbuf;
862 1275
863 } elsif (defined $len) { 1276 } elsif (defined $len) {
864 delete $self->{rw}; 1277 delete $self->{_rw};
865 $self->{eof} = 1; 1278 $self->{_eof} = 1;
866 $self->_drain_rbuf; 1279 $self->_drain_rbuf unless $self->{_in_drain};
867 1280
868 } elsif ($! != EAGAIN && $! != EINTR && $! != &AnyEvent::Util::WSAWOULDBLOCK) { 1281 } elsif ($! != EAGAIN && $! != EINTR && $! != WSAEWOULDBLOCK) {
869 return $self->error; 1282 return $self->_error ($!, 1);
870 } 1283 }
871 }); 1284 });
872 } 1285 }
873} 1286}
874 1287
875sub _dotls { 1288sub _dotls {
876 my ($self) = @_; 1289 my ($self) = @_;
877 1290
1291 my $buf;
1292
878 if (length $self->{tls_wbuf}) { 1293 if (length $self->{_tls_wbuf}) {
879 while ((my $len = Net::SSLeay::write ($self->{tls}, $self->{tls_wbuf})) > 0) { 1294 while ((my $len = Net::SSLeay::write ($self->{tls}, $self->{_tls_wbuf})) > 0) {
880 substr $self->{tls_wbuf}, 0, $len, ""; 1295 substr $self->{_tls_wbuf}, 0, $len, "";
881 } 1296 }
882 } 1297 }
883 1298
884 if (defined (my $buf = Net::SSLeay::BIO_read ($self->{tls_wbio}))) { 1299 if (length ($buf = Net::SSLeay::BIO_read ($self->{_wbio}))) {
885 $self->{wbuf} .= $buf; 1300 $self->{wbuf} .= $buf;
886 $self->_drain_wbuf; 1301 $self->_drain_wbuf;
887 } 1302 }
888 1303
889 while (defined (my $buf = Net::SSLeay::read ($self->{tls}))) { 1304 while (defined ($buf = Net::SSLeay::read ($self->{tls}))) {
1305 if (length $buf) {
890 $self->{rbuf} .= $buf; 1306 $self->{rbuf} .= $buf;
891 $self->_drain_rbuf; 1307 $self->_drain_rbuf unless $self->{_in_drain};
1308 } else {
1309 # let's treat SSL-eof as we treat normal EOF
1310 $self->{_eof} = 1;
1311 $self->_shutdown;
1312 return;
1313 }
892 } 1314 }
893 1315
894 my $err = Net::SSLeay::get_error ($self->{tls}, -1); 1316 my $err = Net::SSLeay::get_error ($self->{tls}, -1);
895 1317
896 if ($err!= Net::SSLeay::ERROR_WANT_READ ()) { 1318 if ($err!= Net::SSLeay::ERROR_WANT_READ ()) {
897 if ($err == Net::SSLeay::ERROR_SYSCALL ()) { 1319 if ($err == Net::SSLeay::ERROR_SYSCALL ()) {
898 $self->error; 1320 return $self->_error ($!, 1);
899 } elsif ($err == Net::SSLeay::ERROR_SSL ()) { 1321 } elsif ($err == Net::SSLeay::ERROR_SSL ()) {
900 $! = &Errno::EIO; 1322 return $self->_error (&Errno::EIO, 1);
901 $self->error;
902 } 1323 }
903 1324
904 # all others are fine for our purposes 1325 # all others are fine for our purposes
905 } 1326 }
906} 1327}
… …
915C<"connect">, C<"accept"> or an existing Net::SSLeay object). 1336C<"connect">, C<"accept"> or an existing Net::SSLeay object).
916 1337
917The second argument is the optional C<Net::SSLeay::CTX> object that is 1338The second argument is the optional C<Net::SSLeay::CTX> object that is
918used when AnyEvent::Handle has to create its own TLS connection object. 1339used when AnyEvent::Handle has to create its own TLS connection object.
919 1340
920=cut 1341The TLS connection object will end up in C<< $handle->{tls} >> after this
1342call and can be used or changed to your liking. Note that the handshake
1343might have already started when this function returns.
921 1344
922# TODO: maybe document... 1345=cut
1346
923sub starttls { 1347sub starttls {
924 my ($self, $ssl, $ctx) = @_; 1348 my ($self, $ssl, $ctx) = @_;
925 1349
926 $self->stoptls; 1350 $self->stoptls;
927 1351
… …
942 # http://www.mail-archive.com/openssl-dev@openssl.org/msg22420.html 1366 # http://www.mail-archive.com/openssl-dev@openssl.org/msg22420.html
943 Net::SSLeay::CTX_set_mode ($self->{tls}, 1367 Net::SSLeay::CTX_set_mode ($self->{tls},
944 (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ENABLE_PARTIAL_WRITE () } || 1) 1368 (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ENABLE_PARTIAL_WRITE () } || 1)
945 | (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ACCEPT_MOVING_WRITE_BUFFER () } || 2)); 1369 | (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ACCEPT_MOVING_WRITE_BUFFER () } || 2));
946 1370
947 $self->{tls_rbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ()); 1371 $self->{_rbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ());
948 $self->{tls_wbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ()); 1372 $self->{_wbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ());
949 1373
950 Net::SSLeay::set_bio ($ssl, $self->{tls_rbio}, $self->{tls_wbio}); 1374 Net::SSLeay::set_bio ($ssl, $self->{_rbio}, $self->{_wbio});
951 1375
952 $self->{filter_w} = sub { 1376 $self->{filter_w} = sub {
953 $_[0]{tls_wbuf} .= ${$_[1]}; 1377 $_[0]{_tls_wbuf} .= ${$_[1]};
954 &_dotls; 1378 &_dotls;
955 }; 1379 };
956 $self->{filter_r} = sub { 1380 $self->{filter_r} = sub {
957 Net::SSLeay::BIO_write ($_[0]{tls_rbio}, ${$_[1]}); 1381 Net::SSLeay::BIO_write ($_[0]{_rbio}, ${$_[1]});
958 &_dotls; 1382 &_dotls;
959 }; 1383 };
960} 1384}
961 1385
962=item $handle->stoptls 1386=item $handle->stoptls
… …
968 1392
969sub stoptls { 1393sub stoptls {
970 my ($self) = @_; 1394 my ($self) = @_;
971 1395
972 Net::SSLeay::free (delete $self->{tls}) if $self->{tls}; 1396 Net::SSLeay::free (delete $self->{tls}) if $self->{tls};
1397
973 delete $self->{tls_rbio}; 1398 delete $self->{_rbio};
974 delete $self->{tls_wbio}; 1399 delete $self->{_wbio};
975 delete $self->{tls_wbuf}; 1400 delete $self->{_tls_wbuf};
976 delete $self->{filter_r}; 1401 delete $self->{filter_r};
977 delete $self->{filter_w}; 1402 delete $self->{filter_w};
978} 1403}
979 1404
980sub DESTROY { 1405sub DESTROY {
981 my $self = shift; 1406 my $self = shift;
982 1407
983 $self->stoptls; 1408 $self->stoptls;
1409
1410 my $linger = exists $self->{linger} ? $self->{linger} : 3600;
1411
1412 if ($linger && length $self->{wbuf}) {
1413 my $fh = delete $self->{fh};
1414 my $wbuf = delete $self->{wbuf};
1415
1416 my @linger;
1417
1418 push @linger, AnyEvent->io (fh => $fh, poll => "w", cb => sub {
1419 my $len = syswrite $fh, $wbuf, length $wbuf;
1420
1421 if ($len > 0) {
1422 substr $wbuf, 0, $len, "";
1423 } else {
1424 @linger = (); # end
1425 }
1426 });
1427 push @linger, AnyEvent->timer (after => $linger, cb => sub {
1428 @linger = ();
1429 });
1430 }
984} 1431}
985 1432
986=item AnyEvent::Handle::TLS_CTX 1433=item AnyEvent::Handle::TLS_CTX
987 1434
988This function creates and returns the Net::SSLeay::CTX object used by 1435This function creates and returns the Net::SSLeay::CTX object used by
… …
1018 } 1465 }
1019} 1466}
1020 1467
1021=back 1468=back
1022 1469
1470=head1 SUBCLASSING AnyEvent::Handle
1471
1472In many cases, you might want to subclass AnyEvent::Handle.
1473
1474To make this easier, a given version of AnyEvent::Handle uses these
1475conventions:
1476
1477=over 4
1478
1479=item * all constructor arguments become object members.
1480
1481At least initially, when you pass a C<tls>-argument to the constructor it
1482will end up in C<< $handle->{tls} >>. Those members might be changed or
1483mutated later on (for example C<tls> will hold the TLS connection object).
1484
1485=item * other object member names are prefixed with an C<_>.
1486
1487All object members not explicitly documented (internal use) are prefixed
1488with an underscore character, so the remaining non-C<_>-namespace is free
1489for use for subclasses.
1490
1491=item * all members not documented here and not prefixed with an underscore
1492are free to use in subclasses.
1493
1494Of course, new versions of AnyEvent::Handle may introduce more "public"
1495member variables, but thats just life, at least it is documented.
1496
1497=back
1498
1023=head1 AUTHOR 1499=head1 AUTHOR
1024 1500
1025Robin Redeker C<< <elmex at ta-sa.org> >>, Marc Lehmann <schmorp@schmorp.de>. 1501Robin Redeker C<< <elmex at ta-sa.org> >>, Marc Lehmann <schmorp@schmorp.de>.
1026 1502
1027=cut 1503=cut

Diff Legend

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