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.39 by root, Tue May 27 04:59:51 2008 UTC vs.
Revision 1.74 by root, Fri Jul 18 01:29:58 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
98The callback should throw an exception. If it returns, then
99AnyEvent::Handle will C<croak> for you.
100 102
101While 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
102you will not be notified of errors otherwise. The default simply calls 104you will not be notified of errors otherwise. The default simply calls
103die. 105C<croak>.
104 106
105=item on_read => $cb->($self) 107=item on_read => $cb->($handle)
106 108
107This sets the default read callback, which is called when data arrives 109This sets the default read callback, which is called when data arrives
108and 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).
109 113
110To 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 >>
111method or access the C<$self->{rbuf}> member directly. 115method or access the C<$handle->{rbuf}> member directly.
112 116
113When 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
114feed 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
115calling 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
116error will be raised (with C<$!> set to C<EPIPE>). 120error will be raised (with C<$!> set to C<EPIPE>).
117 121
118=item on_drain => $cb->() 122=item on_drain => $cb->($handle)
119 123
120This 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
121(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).
122 126
123To 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.
124 154
125=item rbuf_max => <bytes> 155=item rbuf_max => <bytes>
126 156
127If 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>)
128when 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
132be 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
133(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
134amount 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
135isn't finished). 165isn't finished).
136 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
137=item read_size => <bytes> 191=item read_size => <bytes>
138 192
139The 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
140on each [loop iteration). Default: C<4096>. 194during each (loop iteration). Default: C<8192>.
141 195
142=item low_water_mark => <bytes> 196=item low_water_mark => <bytes>
143 197
144Sets 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
145buffer: 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
146considered 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.
147 212
148=item tls => "accept" | "connect" | Net::SSLeay::SSL object 213=item tls => "accept" | "connect" | Net::SSLeay::SSL object
149 214
150When 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
151will start making tls handshake and will transparently encrypt/decrypt 216will start making tls handshake and will transparently encrypt/decrypt
168 233
169Use 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
170(unless a connection object was specified directly). If this parameter is 235(unless a connection object was specified directly). If this parameter is
171missing, then AnyEvent::Handle will use C<AnyEvent::Handle::TLS_CTX>. 236missing, then AnyEvent::Handle will use C<AnyEvent::Handle::TLS_CTX>.
172 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
173=item filter_r => $cb 248=item filter_r => $cb
174 249
175=item filter_w => $cb 250=item filter_w => $cb
176 251
177These exist, but are undocumented at this time. 252These exist, but are undocumented at this time.
192 if ($self->{tls}) { 267 if ($self->{tls}) {
193 require Net::SSLeay; 268 require Net::SSLeay;
194 $self->starttls (delete $self->{tls}, delete $self->{tls_ctx}); 269 $self->starttls (delete $self->{tls}, delete $self->{tls_ctx});
195 } 270 }
196 271
197 $self->on_eof (delete $self->{on_eof} ) if $self->{on_eof}; 272 $self->{_activity} = AnyEvent->now;
198 $self->on_error (delete $self->{on_error}) if $self->{on_error}; 273 $self->_timeout;
274
199 $self->on_drain (delete $self->{on_drain}) if $self->{on_drain}; 275 $self->on_drain (delete $self->{on_drain}) if exists $self->{on_drain};
200 $self->on_read (delete $self->{on_read} ) if $self->{on_read}; 276 $self->no_delay (delete $self->{no_delay}) if exists $self->{no_delay};
201 277
202 $self->start_read; 278 $self->start_read
279 if $self->{on_read};
203 280
204 $self 281 $self
205} 282}
206 283
207sub _shutdown { 284sub _shutdown {
208 my ($self) = @_; 285 my ($self) = @_;
209 286
287 delete $self->{_tw};
210 delete $self->{_rw}; 288 delete $self->{_rw};
211 delete $self->{_ww}; 289 delete $self->{_ww};
212 delete $self->{fh}; 290 delete $self->{fh};
213}
214 291
292 $self->stoptls;
293}
294
215sub error { 295sub _error {
216 my ($self) = @_; 296 my ($self, $errno, $fatal) = @_;
217 297
218 {
219 local $!;
220 $self->_shutdown; 298 $self->_shutdown
221 } 299 if $fatal;
222 300
223 $self->{on_error}($self) 301 $! = $errno;
302
224 if $self->{on_error}; 303 if ($self->{on_error}) {
225 304 $self->{on_error}($self, $fatal);
305 } else {
226 Carp::croak "AnyEvent::Handle uncaught fatal error: $!"; 306 Carp::croak "AnyEvent::Handle uncaught error: $!";
307 }
227} 308}
228 309
229=item $fh = $handle->fh 310=item $fh = $handle->fh
230 311
231This method returns the file handle of the L<AnyEvent::Handle> object. 312This method returns the file handle of the L<AnyEvent::Handle> object.
250 331
251=cut 332=cut
252 333
253sub on_eof { 334sub on_eof {
254 $_[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 }
255} 426}
256 427
257############################################################################# 428#############################################################################
258 429
259=back 430=back
306 my $len = syswrite $self->{fh}, $self->{wbuf}; 477 my $len = syswrite $self->{fh}, $self->{wbuf};
307 478
308 if ($len >= 0) { 479 if ($len >= 0) {
309 substr $self->{wbuf}, 0, $len, ""; 480 substr $self->{wbuf}, 0, $len, "";
310 481
482 $self->{_activity} = AnyEvent->now;
483
311 $self->{on_drain}($self) 484 $self->{on_drain}($self)
312 if $self->{low_water_mark} >= length $self->{wbuf} 485 if $self->{low_water_mark} >= length $self->{wbuf}
313 && $self->{on_drain}; 486 && $self->{on_drain};
314 487
315 delete $self->{_ww} unless length $self->{wbuf}; 488 delete $self->{_ww} unless length $self->{wbuf};
316 } elsif ($! != EAGAIN && $! != EINTR && $! != WSAWOULDBLOCK) { 489 } elsif ($! != EAGAIN && $! != EINTR && $! != WSAEWOULDBLOCK) {
317 $self->error; 490 $self->_error ($!, 1);
318 } 491 }
319 }; 492 };
320 493
321 # try to write data immediately 494 # try to write data immediately
322 $cb->(); 495 $cb->() unless $self->{autocork};
323 496
324 # if still data left in wbuf, we need to poll 497 # if still data left in wbuf, we need to poll
325 $self->{_ww} = AnyEvent->io (fh => $self->{fh}, poll => "w", cb => $cb) 498 $self->{_ww} = AnyEvent->io (fh => $self->{fh}, poll => "w", cb => $cb)
326 if length $self->{wbuf}; 499 if length $self->{wbuf};
327 }; 500 };
342 @_ = ($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")
343 ->($self, @_); 516 ->($self, @_);
344 } 517 }
345 518
346 if ($self->{filter_w}) { 519 if ($self->{filter_w}) {
347 $self->{filter_w}->($self, \$_[0]); 520 $self->{filter_w}($self, \$_[0]);
348 } else { 521 } else {
349 $self->{wbuf} .= $_[0]; 522 $self->{wbuf} .= $_[0];
350 $self->_drain_wbuf; 523 $self->_drain_wbuf;
351 } 524 }
352} 525}
353 526
354=item $handle->push_write (type => @args) 527=item $handle->push_write (type => @args)
355 528
356=item $handle->unshift_write (type => @args)
357
358Instead 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
359the job by specifying a type and type-specific arguments. 530the job by specifying a type and type-specific arguments.
360 531
361Predefined 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
362drop by and tell us): 533drop by and tell us):
366=item netstring => $string 537=item netstring => $string
367 538
368Formats the given value as netstring 539Formats the given value as netstring
369(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).
370 541
371=back
372
373=cut 542=cut
374 543
375register_write_type netstring => sub { 544register_write_type netstring => sub {
376 my ($self, $string) = @_; 545 my ($self, $string) = @_;
377 546
378 sprintf "%d:%s,", (length $string), $string 547 sprintf "%d:%s,", (length $string), $string
379}; 548};
380 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
381=item json => $array_or_hashref 565=item json => $array_or_hashref
382 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
383=item AnyEvent::Handle::register_write_type type => $coderef->($self, @args) 623=item AnyEvent::Handle::register_write_type type => $coderef->($handle, @args)
384 624
385This 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>.
386Whenever 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
387reference with the handle object and the remaining arguments. 627reference with the handle object and the remaining arguments.
388 628
407ways, 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
408a queue. 648a queue.
409 649
410In 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
411new 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
412enough 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
413or not. 653leave the data there if you want to accumulate more (e.g. when only a
654partial message has been received so far).
414 655
415In 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
416case, AnyEvent::Handle will call the first queued callback each time new 657case, AnyEvent::Handle will call the first queued callback each time new
417data 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
418below). 659done its job (see C<push_read>, below).
419 660
420This 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
421a chunk of data, and AnyEvent::Handle will execute them in order. 662a chunk of data, and AnyEvent::Handle will execute them in order.
422 663
423Example 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
424the specified number of bytes which give an XML datagram. 665the specified number of bytes which give an XML datagram.
425 666
426 # in the default state, expect some header bytes 667 # in the default state, expect some header bytes
427 $handle->on_read (sub { 668 $handle->on_read (sub {
428 # 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)
429 shift->unshift_read_chunk (4, sub { 670 shift->unshift_read (chunk => 4, sub {
430 # header arrived, decode 671 # header arrived, decode
431 my $len = unpack "N", $_[1]; 672 my $len = unpack "N", $_[1];
432 673
433 # now read the payload 674 # now read the payload
434 shift->unshift_read_chunk ($len, sub { 675 shift->unshift_read (chunk => $len, sub {
435 my $xml = $_[1]; 676 my $xml = $_[1];
436 # handle xml 677 # handle xml
437 }); 678 });
438 }); 679 });
439 }); 680 });
440 681
441Example 2: Implement a client for a protocol that replies either with 682Example 2: Implement a client for a protocol that replies either with "OK"
442"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
443second 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
444pipeline sending both requests and manipulate the queue as necessary in 685just pipeline sending both requests and manipulate the queue as necessary
445the callbacks: 686in the callbacks.
446 687
447 # 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"
448 $handle->push_write ("request 1\015\012"); 693 $handle->push_write ("request 1\015\012");
449 694
450 # 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
451 $handle->push_read_line (sub { 696 $handle->push_read (line => sub {
452 # if we got an "OK", we have to _prepend_ another line, 697 # if we got an "OK", we have to _prepend_ another line,
453 # 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
454 # which are already in the queue when this callback is called 699 # which are already in the queue when this callback is called
455 # we don't do this in case we got an error 700 # we don't do this in case we got an error
456 if ($_[1] eq "OK") { 701 if ($_[1] eq "OK") {
457 $_[0]->unshift_read_line (sub { 702 $_[0]->unshift_read (line => sub {
458 my $response = $_[1]; 703 my $response = $_[1];
459 ... 704 ...
460 }); 705 });
461 } 706 }
462 }); 707 });
463 708
464 # request two 709 # request two, simply returns 64 octets
465 $handle->push_write ("request 2\015\012"); 710 $handle->push_write ("request 2\015\012");
466 711
467 # simply read 64 bytes, always 712 # simply read 64 bytes, always
468 $handle->push_read_chunk (64, sub { 713 $handle->push_read (chunk => 64, sub {
469 my $response = $_[1]; 714 my $response = $_[1];
470 ... 715 ...
471 }); 716 });
472 717
473=over 4 718=over 4
474 719
475=cut 720=cut
476 721
477sub _drain_rbuf { 722sub _drain_rbuf {
478 my ($self) = @_; 723 my ($self) = @_;
724
725 local $self->{_in_drain} = 1;
479 726
480 if ( 727 if (
481 defined $self->{rbuf_max} 728 defined $self->{rbuf_max}
482 && $self->{rbuf_max} < length $self->{rbuf} 729 && $self->{rbuf_max} < length $self->{rbuf}
483 ) { 730 ) {
484 $! = &Errno::ENOSPC; 731 return $self->_error (&Errno::ENOSPC, 1);
485 $self->error;
486 } 732 }
487 733
488 return if $self->{in_drain}; 734 while () {
489 local $self->{in_drain} = 1;
490
491 while (my $len = length $self->{rbuf}) {
492 no strict 'refs'; 735 no strict 'refs';
736
737 my $len = length $self->{rbuf};
738
493 if (my $cb = shift @{ $self->{_queue} }) { 739 if (my $cb = shift @{ $self->{_queue} }) {
494 unless ($cb->($self)) { 740 unless ($cb->($self)) {
495 if ($self->{_eof}) { 741 if ($self->{_eof}) {
496 # 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)
497 $! = &Errno::EPIPE; 743 $self->_error (&Errno::EPIPE, 1), last;
498 $self->error;
499 } 744 }
500 745
501 unshift @{ $self->{_queue} }, $cb; 746 unshift @{ $self->{_queue} }, $cb;
502 return; 747 last;
503 } 748 }
504 } elsif ($self->{on_read}) { 749 } elsif ($self->{on_read}) {
750 last unless $len;
751
505 $self->{on_read}($self); 752 $self->{on_read}($self);
506 753
507 if ( 754 if (
508 $self->{_eof} # if no further data will arrive
509 && $len == length $self->{rbuf} # and no data has been consumed 755 $len == length $self->{rbuf} # if no data has been consumed
510 && !@{ $self->{_queue} } # and the queue is still empty 756 && !@{ $self->{_queue} } # and the queue is still empty
511 && $self->{on_read} # and we still want to read data 757 && $self->{on_read} # but we still have on_read
512 ) { 758 ) {
759 # no further data will arrive
513 # then no progress can be made 760 # so no progress can be made
514 $! = &Errno::EPIPE; 761 $self->_error (&Errno::EPIPE, 1), last
515 $self->error; 762 if $self->{_eof};
763
764 last; # more data might arrive
516 } 765 }
517 } else { 766 } else {
518 # read side becomes idle 767 # read side becomes idle
519 delete $self->{_rw}; 768 delete $self->{_rw};
520 return; 769 last;
521 } 770 }
522 } 771 }
523 772
524 if ($self->{_eof}) {
525 $self->_shutdown;
526 $self->{on_eof}($self) 773 $self->{on_eof}($self)
527 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} };
528 } 780 }
529} 781}
530 782
531=item $handle->on_read ($cb) 783=item $handle->on_read ($cb)
532 784
538 790
539sub on_read { 791sub on_read {
540 my ($self, $cb) = @_; 792 my ($self, $cb) = @_;
541 793
542 $self->{on_read} = $cb; 794 $self->{on_read} = $cb;
795 $self->_drain_rbuf if $cb && !$self->{_in_drain};
543} 796}
544 797
545=item $handle->rbuf 798=item $handle->rbuf
546 799
547Returns the read buffer (as a modifiable lvalue). 800Returns the read buffer (as a modifiable lvalue).
596 $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")
597 ->($self, $cb, @_); 850 ->($self, $cb, @_);
598 } 851 }
599 852
600 push @{ $self->{_queue} }, $cb; 853 push @{ $self->{_queue} }, $cb;
601 $self->_drain_rbuf; 854 $self->_drain_rbuf unless $self->{_in_drain};
602} 855}
603 856
604sub unshift_read { 857sub unshift_read {
605 my $self = shift; 858 my $self = shift;
606 my $cb = pop; 859 my $cb = pop;
612 ->($self, $cb, @_); 865 ->($self, $cb, @_);
613 } 866 }
614 867
615 868
616 unshift @{ $self->{_queue} }, $cb; 869 unshift @{ $self->{_queue} }, $cb;
617 $self->_drain_rbuf; 870 $self->_drain_rbuf unless $self->{_in_drain};
618} 871}
619 872
620=item $handle->push_read (type => @args, $cb) 873=item $handle->push_read (type => @args, $cb)
621 874
622=item $handle->unshift_read (type => @args, $cb) 875=item $handle->unshift_read (type => @args, $cb)
628Predefined 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
629drop by and tell us): 882drop by and tell us):
630 883
631=over 4 884=over 4
632 885
633=item chunk => $octets, $cb->($self, $data) 886=item chunk => $octets, $cb->($handle, $data)
634 887
635Invoke 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
636data 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
637data. 890data.
638 891
661 914
662sub unshift_read_chunk { 915sub unshift_read_chunk {
663 $_[0]->unshift_read (chunk => $_[1], $_[2]); 916 $_[0]->unshift_read (chunk => $_[1], $_[2]);
664} 917}
665 918
666=item line => [$eol, ]$cb->($self, $line, $eol) 919=item line => [$eol, ]$cb->($handle, $line, $eol)
667 920
668The 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
669line 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
670marker) 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
671the end of line marker as the third argument (C<$eol>). 924the end of line marker as the third argument (C<$eol>).
708sub unshift_read_line { 961sub unshift_read_line {
709 my $self = shift; 962 my $self = shift;
710 $self->unshift_read (line => @_); 963 $self->unshift_read (line => @_);
711} 964}
712 965
713=item netstring => $cb->($string)
714
715A netstring (http://cr.yp.to/proto/netstrings.txt, this is not an endorsement).
716
717Throws an error with C<$!> set to EBADMSG on format violations.
718
719=cut
720
721register_read_type netstring => sub {
722 my ($self, $cb) = @_;
723
724 sub {
725 unless ($_[0]{rbuf} =~ s/^(0|[1-9][0-9]*)://) {
726 if ($_[0]{rbuf} =~ /[^0-9]/) {
727 $! = &Errno::EBADMSG;
728 $self->error;
729 }
730 return;
731 }
732
733 my $len = $1;
734
735 $self->unshift_read (chunk => $len, sub {
736 my $string = $_[1];
737 $_[0]->unshift_read (chunk => 1, sub {
738 if ($_[1] eq ",") {
739 $cb->($_[0], $string);
740 } else {
741 $! = &Errno::EBADMSG;
742 $self->error;
743 }
744 });
745 });
746
747 1
748 }
749};
750
751=item regex => $accept[, $reject[, $skip], $cb->($data) 966=item regex => $accept[, $reject[, $skip], $cb->($handle, $data)
752 967
753Makes a regex match against the regex object C<$accept> and returns 968Makes a regex match against the regex object C<$accept> and returns
754everything up to and including the match. 969everything up to and including the match.
755 970
756Example: read a single line terminated by '\n'. 971Example: read a single line terminated by '\n'.
804 return 1; 1019 return 1;
805 } 1020 }
806 1021
807 # reject 1022 # reject
808 if ($reject && $$rbuf =~ $reject) { 1023 if ($reject && $$rbuf =~ $reject) {
809 $! = &Errno::EBADMSG; 1024 $self->_error (&Errno::EBADMSG);
810 $self->error;
811 } 1025 }
812 1026
813 # skip 1027 # skip
814 if ($skip && $$rbuf =~ $skip) { 1028 if ($skip && $$rbuf =~ $skip) {
815 $data .= substr $$rbuf, 0, $+[0], ""; 1029 $data .= substr $$rbuf, 0, $+[0], "";
817 1031
818 () 1032 ()
819 } 1033 }
820}; 1034};
821 1035
1036=item netstring => $cb->($handle, $string)
1037
1038A netstring (http://cr.yp.to/proto/netstrings.txt, this is not an endorsement).
1039
1040Throws an error with C<$!> set to EBADMSG on format violations.
1041
1042=cut
1043
1044register_read_type netstring => sub {
1045 my ($self, $cb) = @_;
1046
1047 sub {
1048 unless ($_[0]{rbuf} =~ s/^(0|[1-9][0-9]*)://) {
1049 if ($_[0]{rbuf} =~ /[^0-9]/) {
1050 $self->_error (&Errno::EBADMSG);
1051 }
1052 return;
1053 }
1054
1055 my $len = $1;
1056
1057 $self->unshift_read (chunk => $len, sub {
1058 my $string = $_[1];
1059 $_[0]->unshift_read (chunk => 1, sub {
1060 if ($_[1] eq ",") {
1061 $cb->($_[0], $string);
1062 } else {
1063 $self->_error (&Errno::EBADMSG);
1064 }
1065 });
1066 });
1067
1068 1
1069 }
1070};
1071
1072=item packstring => $format, $cb->($handle, $string)
1073
1074An octet string prefixed with an encoded length. The encoding C<$format>
1075uses the same format as a Perl C<pack> format, but must specify a single
1076integer only (only one of C<cCsSlLqQiInNvVjJw> is allowed, plus an
1077optional C<!>, C<< < >> or C<< > >> modifier).
1078
1079DNS over TCP uses a prefix of C<n>, EPP uses a prefix of C<N>.
1080
1081Example: read a block of data prefixed by its length in BER-encoded
1082format (very efficient).
1083
1084 $handle->push_read (packstring => "w", sub {
1085 my ($handle, $data) = @_;
1086 });
1087
1088=cut
1089
1090register_read_type packstring => sub {
1091 my ($self, $cb, $format) = @_;
1092
1093 sub {
1094 # when we can use 5.10 we can use ".", but for 5.8 we use the re-pack method
1095 defined (my $len = eval { unpack $format, $_[0]->{rbuf} })
1096 or return;
1097
1098 # remove prefix
1099 substr $_[0]->{rbuf}, 0, (length pack $format, $len), "";
1100
1101 # read rest
1102 $_[0]->unshift_read (chunk => $len, $cb);
1103
1104 1
1105 }
1106};
1107
1108=item json => $cb->($handle, $hash_or_arrayref)
1109
1110Reads a JSON object or array, decodes it and passes it to the callback.
1111
1112If a C<json> object was passed to the constructor, then that will be used
1113for the final decode, otherwise it will create a JSON coder expecting UTF-8.
1114
1115This read type uses the incremental parser available with JSON version
11162.09 (and JSON::XS version 2.2) and above. You have to provide a
1117dependency on your own: this module will load the JSON module, but
1118AnyEvent does not depend on it itself.
1119
1120Since JSON texts are fully self-delimiting, the C<json> read and write
1121types are an ideal simple RPC protocol: just exchange JSON datagrams. See
1122the C<json> write type description, above, for an actual example.
1123
1124=cut
1125
1126register_read_type json => sub {
1127 my ($self, $cb) = @_;
1128
1129 require JSON;
1130
1131 my $data;
1132 my $rbuf = \$self->{rbuf};
1133
1134 my $json = $self->{json} ||= JSON->new->utf8;
1135
1136 sub {
1137 my $ref = $json->incr_parse ($self->{rbuf});
1138
1139 if ($ref) {
1140 $self->{rbuf} = $json->incr_text;
1141 $json->incr_text = "";
1142 $cb->($self, $ref);
1143
1144 1
1145 } else {
1146 $self->{rbuf} = "";
1147 ()
1148 }
1149 }
1150};
1151
1152=item storable => $cb->($handle, $ref)
1153
1154Deserialises a L<Storable> frozen representation as written by the
1155C<storable> write type (BER-encoded length prefix followed by nfreeze'd
1156data).
1157
1158Raises C<EBADMSG> error if the data could not be decoded.
1159
1160=cut
1161
1162register_read_type storable => sub {
1163 my ($self, $cb) = @_;
1164
1165 require Storable;
1166
1167 sub {
1168 # when we can use 5.10 we can use ".", but for 5.8 we use the re-pack method
1169 defined (my $len = eval { unpack "w", $_[0]->{rbuf} })
1170 or return;
1171
1172 # remove prefix
1173 substr $_[0]->{rbuf}, 0, (length pack "w", $len), "";
1174
1175 # read rest
1176 $_[0]->unshift_read (chunk => $len, sub {
1177 if (my $ref = eval { Storable::thaw ($_[1]) }) {
1178 $cb->($_[0], $ref);
1179 } else {
1180 $self->_error (&Errno::EBADMSG);
1181 }
1182 });
1183 }
1184};
1185
822=back 1186=back
823 1187
824=item AnyEvent::Handle::register_read_type type => $coderef->($self, $cb, @args) 1188=item AnyEvent::Handle::register_read_type type => $coderef->($handle, $cb, @args)
825 1189
826This function (not method) lets you add your own types to C<push_read>. 1190This function (not method) lets you add your own types to C<push_read>.
827 1191
828Whenever the given C<type> is used, C<push_read> will invoke the code 1192Whenever the given C<type> is used, C<push_read> will invoke the code
829reference with the handle object, the callback and the remaining 1193reference with the handle object, the callback and the remaining
831 1195
832The code reference is supposed to return a callback (usually a closure) 1196The code reference is supposed to return a callback (usually a closure)
833that works as a plain read callback (see C<< ->push_read ($cb) >>). 1197that works as a plain read callback (see C<< ->push_read ($cb) >>).
834 1198
835It should invoke the passed callback when it is done reading (remember to 1199It should invoke the passed callback when it is done reading (remember to
836pass C<$self> as first argument as all other callbacks do that). 1200pass C<$handle> as first argument as all other callbacks do that).
837 1201
838Note that this is a function, and all types registered this way will be 1202Note that this is a function, and all types registered this way will be
839global, so try to use unique names. 1203global, so try to use unique names.
840 1204
841For examples, see the source of this module (F<perldoc -m AnyEvent::Handle>, 1205For examples, see the source of this module (F<perldoc -m AnyEvent::Handle>,
844=item $handle->stop_read 1208=item $handle->stop_read
845 1209
846=item $handle->start_read 1210=item $handle->start_read
847 1211
848In rare cases you actually do not want to read anything from the 1212In rare cases you actually do not want to read anything from the
849socket. In this case you can call C<stop_read>. Neither C<on_read> no 1213socket. In this case you can call C<stop_read>. Neither C<on_read> nor
850any queued callbacks will be executed then. To start reading again, call 1214any queued callbacks will be executed then. To start reading again, call
851C<start_read>. 1215C<start_read>.
1216
1217Note that AnyEvent::Handle will automatically C<start_read> for you when
1218you change the C<on_read> callback or push/unshift a read callback, and it
1219will automatically C<stop_read> for you when neither C<on_read> is set nor
1220there are any read requests in the queue.
852 1221
853=cut 1222=cut
854 1223
855sub stop_read { 1224sub stop_read {
856 my ($self) = @_; 1225 my ($self) = @_;
867 $self->{_rw} = AnyEvent->io (fh => $self->{fh}, poll => "r", cb => sub { 1236 $self->{_rw} = AnyEvent->io (fh => $self->{fh}, poll => "r", cb => sub {
868 my $rbuf = $self->{filter_r} ? \my $buf : \$self->{rbuf}; 1237 my $rbuf = $self->{filter_r} ? \my $buf : \$self->{rbuf};
869 my $len = sysread $self->{fh}, $$rbuf, $self->{read_size} || 8192, length $$rbuf; 1238 my $len = sysread $self->{fh}, $$rbuf, $self->{read_size} || 8192, length $$rbuf;
870 1239
871 if ($len > 0) { 1240 if ($len > 0) {
1241 $self->{_activity} = AnyEvent->now;
1242
872 $self->{filter_r} 1243 $self->{filter_r}
873 ? $self->{filter_r}->($self, $rbuf) 1244 ? $self->{filter_r}($self, $rbuf)
874 : $self->_drain_rbuf; 1245 : $self->{_in_drain} || $self->_drain_rbuf;
875 1246
876 } elsif (defined $len) { 1247 } elsif (defined $len) {
877 delete $self->{_rw}; 1248 delete $self->{_rw};
878 $self->{_eof} = 1; 1249 $self->{_eof} = 1;
879 $self->_drain_rbuf; 1250 $self->_drain_rbuf unless $self->{_in_drain};
880 1251
881 } elsif ($! != EAGAIN && $! != EINTR && $! != &AnyEvent::Util::WSAWOULDBLOCK) { 1252 } elsif ($! != EAGAIN && $! != EINTR && $! != WSAEWOULDBLOCK) {
882 return $self->error; 1253 return $self->_error ($!, 1);
883 } 1254 }
884 }); 1255 });
885 } 1256 }
886} 1257}
887 1258
888sub _dotls { 1259sub _dotls {
889 my ($self) = @_; 1260 my ($self) = @_;
1261
1262 my $buf;
890 1263
891 if (length $self->{_tls_wbuf}) { 1264 if (length $self->{_tls_wbuf}) {
892 while ((my $len = Net::SSLeay::write ($self->{tls}, $self->{_tls_wbuf})) > 0) { 1265 while ((my $len = Net::SSLeay::write ($self->{tls}, $self->{_tls_wbuf})) > 0) {
893 substr $self->{_tls_wbuf}, 0, $len, ""; 1266 substr $self->{_tls_wbuf}, 0, $len, "";
894 } 1267 }
895 } 1268 }
896 1269
897 if (defined (my $buf = Net::SSLeay::BIO_read ($self->{_wbio}))) { 1270 if (length ($buf = Net::SSLeay::BIO_read ($self->{_wbio}))) {
898 $self->{wbuf} .= $buf; 1271 $self->{wbuf} .= $buf;
899 $self->_drain_wbuf; 1272 $self->_drain_wbuf;
900 } 1273 }
901 1274
902 while (defined (my $buf = Net::SSLeay::read ($self->{tls}))) { 1275 while (defined ($buf = Net::SSLeay::read ($self->{tls}))) {
1276 if (length $buf) {
903 $self->{rbuf} .= $buf; 1277 $self->{rbuf} .= $buf;
904 $self->_drain_rbuf; 1278 $self->_drain_rbuf unless $self->{_in_drain};
1279 } else {
1280 # let's treat SSL-eof as we treat normal EOF
1281 $self->{_eof} = 1;
1282 $self->_shutdown;
1283 return;
1284 }
905 } 1285 }
906 1286
907 my $err = Net::SSLeay::get_error ($self->{tls}, -1); 1287 my $err = Net::SSLeay::get_error ($self->{tls}, -1);
908 1288
909 if ($err!= Net::SSLeay::ERROR_WANT_READ ()) { 1289 if ($err!= Net::SSLeay::ERROR_WANT_READ ()) {
910 if ($err == Net::SSLeay::ERROR_SYSCALL ()) { 1290 if ($err == Net::SSLeay::ERROR_SYSCALL ()) {
911 $self->error; 1291 return $self->_error ($!, 1);
912 } elsif ($err == Net::SSLeay::ERROR_SSL ()) { 1292 } elsif ($err == Net::SSLeay::ERROR_SSL ()) {
913 $! = &Errno::EIO; 1293 return $self->_error (&Errno::EIO, 1);
914 $self->error;
915 } 1294 }
916 1295
917 # all others are fine for our purposes 1296 # all others are fine for our purposes
918 } 1297 }
919} 1298}
934call and can be used or changed to your liking. Note that the handshake 1313call and can be used or changed to your liking. Note that the handshake
935might have already started when this function returns. 1314might have already started when this function returns.
936 1315
937=cut 1316=cut
938 1317
939# TODO: maybe document...
940sub starttls { 1318sub starttls {
941 my ($self, $ssl, $ctx) = @_; 1319 my ($self, $ssl, $ctx) = @_;
942 1320
943 $self->stoptls; 1321 $self->stoptls;
944 1322
997 1375
998sub DESTROY { 1376sub DESTROY {
999 my $self = shift; 1377 my $self = shift;
1000 1378
1001 $self->stoptls; 1379 $self->stoptls;
1380
1381 my $linger = exists $self->{linger} ? $self->{linger} : 3600;
1382
1383 if ($linger && length $self->{wbuf}) {
1384 my $fh = delete $self->{fh};
1385 my $wbuf = delete $self->{wbuf};
1386
1387 my @linger;
1388
1389 push @linger, AnyEvent->io (fh => $fh, poll => "w", cb => sub {
1390 my $len = syswrite $fh, $wbuf, length $wbuf;
1391
1392 if ($len > 0) {
1393 substr $wbuf, 0, $len, "";
1394 } else {
1395 @linger = (); # end
1396 }
1397 });
1398 push @linger, AnyEvent->timer (after => $linger, cb => sub {
1399 @linger = ();
1400 });
1401 }
1002} 1402}
1003 1403
1004=item AnyEvent::Handle::TLS_CTX 1404=item AnyEvent::Handle::TLS_CTX
1005 1405
1006This function creates and returns the Net::SSLeay::CTX object used by 1406This function creates and returns the Net::SSLeay::CTX object used by

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines