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.43 by root, Wed May 28 23:57:38 2008 UTC vs.
Revision 1.84 by root, Thu Aug 21 19:13:05 2008 UTC

1package AnyEvent::Handle; 1package AnyEvent::Handle;
2 2
3no warnings; 3no warnings;
4use strict; 4use strict qw(subs vars);
5 5
6use AnyEvent (); 6use AnyEvent ();
7use AnyEvent::Util qw(WSAEWOULDBLOCK); 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);
12use Time::HiRes qw(time);
13 12
14=head1 NAME 13=head1 NAME
15 14
16AnyEvent::Handle - non-blocking I/O on file handles via AnyEvent 15AnyEvent::Handle - non-blocking I/O on file handles via AnyEvent
17 16
18=cut 17=cut
19 18
20our $VERSION = '0.04'; 19our $VERSION = 4.232;
21 20
22=head1 SYNOPSIS 21=head1 SYNOPSIS
23 22
24 use AnyEvent; 23 use AnyEvent;
25 use AnyEvent::Handle; 24 use AnyEvent::Handle;
50 49
51This module is a helper module to make it easier to do event-based I/O on 50This module is a helper module to make it easier to do event-based I/O on
52filehandles. For utility functions for doing non-blocking connects and accepts 51filehandles. For utility functions for doing non-blocking connects and accepts
53on sockets see L<AnyEvent::Util>. 52on sockets see L<AnyEvent::Util>.
54 53
54The L<AnyEvent::Intro> tutorial contains some well-documented
55AnyEvent::Handle examples.
56
55In the following, when the documentation refers to of "bytes" then this 57In the following, when the documentation refers to of "bytes" then this
56means characters. As sysread and syswrite are used for all I/O, their 58means characters. As sysread and syswrite are used for all I/O, their
57treatment of characters applies to this module as well. 59treatment of characters applies to this module as well.
58 60
59All callbacks will be invoked with the handle object as their first 61All callbacks will be invoked with the handle object as their first
71 73
72=item fh => $filehandle [MANDATORY] 74=item fh => $filehandle [MANDATORY]
73 75
74The filehandle this L<AnyEvent::Handle> object will operate on. 76The filehandle this L<AnyEvent::Handle> object will operate on.
75 77
76NOTE: The filehandle will be set to non-blocking (using 78NOTE: The filehandle will be set to non-blocking mode (using
77AnyEvent::Util::fh_nonblocking). 79C<AnyEvent::Util::fh_nonblocking>) by the constructor and needs to stay in
80that mode.
78 81
79=item on_eof => $cb->($handle) 82=item on_eof => $cb->($handle)
80 83
81Set the callback to be called on EOF. 84Set the callback to be called when an end-of-file condition is detected,
85i.e. in the case of a socket, when the other side has closed the
86connection cleanly.
82 87
88For sockets, this just means that the other side has stopped sending data,
89you can still try to write data, and, in fact, one can return from the eof
90callback and continue writing data, as only the read part has been shut
91down.
92
83While not mandatory, it is highly recommended to set an eof callback, 93While not mandatory, it is I<highly> recommended to set an eof callback,
84otherwise you might end up with a closed socket while you are still 94otherwise you might end up with a closed socket while you are still
85waiting for data. 95waiting for data.
86 96
97If an EOF condition has been detected but no C<on_eof> callback has been
98set, then a fatal error will be raised with C<$!> set to <0>.
99
87=item on_error => $cb->($handle) 100=item on_error => $cb->($handle, $fatal)
88 101
89This is the fatal error callback, that is called when, well, a fatal error 102This is the error callback, which is called when, well, some error
90occurs, such as not being able to resolve the hostname, failure to connect 103occured, such as not being able to resolve the hostname, failure to
91or a read error. 104connect or a read error.
92 105
93The object will not be in a usable state when this callback has been 106Some errors are fatal (which is indicated by C<$fatal> being true). On
94called. 107fatal errors the handle object will be shut down and will not be usable
108(but you are free to look at the current C< ->rbuf >). Examples of fatal
109errors are an EOF condition with active (but unsatisifable) read watchers
110(C<EPIPE>) or I/O errors.
111
112Non-fatal errors can be retried by simply returning, but it is recommended
113to simply ignore this parameter and instead abondon the handle object
114when this callback is invoked. Examples of non-fatal errors are timeouts
115C<ETIMEDOUT>) or badly-formatted data (C<EBADMSG>).
95 116
96On callback entrance, the value of C<$!> contains the operating system 117On callback entrance, the value of C<$!> contains the operating system
97error (or C<ENOSPC>, C<EPIPE>, C<ETIMEDOUT> or C<EBADMSG>). 118error (or C<ENOSPC>, C<EPIPE>, C<ETIMEDOUT> or C<EBADMSG>).
98 119
99The callback should throw an exception. If it returns, then
100AnyEvent::Handle will C<croak> for you.
101
102While not mandatory, it is I<highly> recommended to set this callback, as 120While not mandatory, it is I<highly> recommended to set this callback, as
103you will not be notified of errors otherwise. The default simply calls 121you will not be notified of errors otherwise. The default simply calls
104die. 122C<croak>.
105 123
106=item on_read => $cb->($handle) 124=item on_read => $cb->($handle)
107 125
108This sets the default read callback, which is called when data arrives 126This sets the default read callback, which is called when data arrives
109and no read request is in the queue. 127and no read request is in the queue (unlike read queue callbacks, this
128callback will only be called when at least one octet of data is in the
129read buffer).
110 130
111To access (and remove data from) the read buffer, use the C<< ->rbuf >> 131To access (and remove data from) the read buffer, use the C<< ->rbuf >>
112method or access the C<$handle->{rbuf}> member directly. 132method or access the C<$handle->{rbuf}> member directly.
113 133
114When an EOF condition is detected then AnyEvent::Handle will first try to 134When an EOF condition is detected then AnyEvent::Handle will first try to
121This sets the callback that is called when the write buffer becomes empty 141This sets the callback that is called when the write buffer becomes empty
122(or when the callback is set and the buffer is empty already). 142(or when the callback is set and the buffer is empty already).
123 143
124To append to the write buffer, use the C<< ->push_write >> method. 144To append to the write buffer, use the C<< ->push_write >> method.
125 145
146This callback is useful when you don't want to put all of your write data
147into the queue at once, for example, when you want to write the contents
148of some file to the socket you might not want to read the whole file into
149memory and push it into the queue, but instead only read more data from
150the file when the write queue becomes empty.
151
126=item timeout => $fractional_seconds 152=item timeout => $fractional_seconds
127 153
128If non-zero, then this enables an "inactivity" timeout: whenever this many 154If non-zero, then this enables an "inactivity" timeout: whenever this many
129seconds pass without a successful read or write on the underlying file 155seconds pass without a successful read or write on the underlying file
130handle, the C<on_timeout> callback will be invoked (and if that one is 156handle, the C<on_timeout> callback will be invoked (and if that one is
131missing, an C<ETIMEDOUT> errror will be raised). 157missing, an C<ETIMEDOUT> error will be raised).
132 158
133Note that timeout processing is also active when you currently do not have 159Note that timeout processing is also active when you currently do not have
134any outstanding read or write requests: If you plan to keep the connection 160any outstanding read or write requests: If you plan to keep the connection
135idle then you should disable the timout temporarily or ignore the timeout 161idle then you should disable the timout temporarily or ignore the timeout
136in the C<on_timeout> callback. 162in the C<on_timeout> callback.
153be configured to accept only so-and-so much data that it cannot act on 179be configured to accept only so-and-so much data that it cannot act on
154(for example, when expecting a line, an attacker could send an unlimited 180(for example, when expecting a line, an attacker could send an unlimited
155amount of data without a callback ever being called as long as the line 181amount of data without a callback ever being called as long as the line
156isn't finished). 182isn't finished).
157 183
184=item autocork => <boolean>
185
186When disabled (the default), then C<push_write> will try to immediately
187write the data to the handle if possible. This avoids having to register
188a write watcher and wait for the next event loop iteration, but can be
189inefficient if you write multiple small chunks (this disadvantage is
190usually avoided by your kernel's nagle algorithm, see C<low_delay>).
191
192When enabled, then writes will always be queued till the next event loop
193iteration. This is efficient when you do many small writes per iteration,
194but less efficient when you do a single write only.
195
196=item no_delay => <boolean>
197
198When doing small writes on sockets, your operating system kernel might
199wait a bit for more data before actually sending it out. This is called
200the Nagle algorithm, and usually it is beneficial.
201
202In some situations you want as low a delay as possible, which cna be
203accomplishd by setting this option to true.
204
205The default is your opertaing system's default behaviour, this option
206explicitly enables or disables it, if possible.
207
158=item read_size => <bytes> 208=item read_size => <bytes>
159 209
160The default read block size (the amount of bytes this module will try to read 210The default read block size (the amount of bytes this module will try to read
161on each [loop iteration). Default: C<4096>. 211during each (loop iteration). Default: C<8192>.
162 212
163=item low_water_mark => <bytes> 213=item low_water_mark => <bytes>
164 214
165Sets the amount of bytes (default: C<0>) that make up an "empty" write 215Sets the amount of bytes (default: C<0>) that make up an "empty" write
166buffer: If the write reaches this size or gets even samller it is 216buffer: If the write reaches this size or gets even samller it is
167considered empty. 217considered empty.
218
219=item linger => <seconds>
220
221If non-zero (default: C<3600>), then the destructor of the
222AnyEvent::Handle object will check wether there is still outstanding write
223data and will install a watcher that will write out this data. No errors
224will be reported (this mostly matches how the operating system treats
225outstanding data at socket close time).
226
227This will not work for partial TLS data that could not yet been
228encoded. This data will be lost.
168 229
169=item tls => "accept" | "connect" | Net::SSLeay::SSL object 230=item tls => "accept" | "connect" | Net::SSLeay::SSL object
170 231
171When this parameter is given, it enables TLS (SSL) mode, that means it 232When this parameter is given, it enables TLS (SSL) mode, that means it
172will start making tls handshake and will transparently encrypt/decrypt 233will start making tls handshake and will transparently encrypt/decrypt
181You can also provide your own TLS connection object, but you have 242You can also provide your own TLS connection object, but you have
182to make sure that you call either C<Net::SSLeay::set_connect_state> 243to make sure that you call either C<Net::SSLeay::set_connect_state>
183or C<Net::SSLeay::set_accept_state> on it before you pass it to 244or C<Net::SSLeay::set_accept_state> on it before you pass it to
184AnyEvent::Handle. 245AnyEvent::Handle.
185 246
186See the C<starttls> method if you need to start TLs negotiation later. 247See the C<starttls> method if you need to start TLS negotiation later.
187 248
188=item tls_ctx => $ssl_ctx 249=item tls_ctx => $ssl_ctx
189 250
190Use the given Net::SSLeay::CTX object to create the new TLS connection 251Use the given Net::SSLeay::CTX object to create the new TLS connection
191(unless a connection object was specified directly). If this parameter is 252(unless a connection object was specified directly). If this parameter is
223 if ($self->{tls}) { 284 if ($self->{tls}) {
224 require Net::SSLeay; 285 require Net::SSLeay;
225 $self->starttls (delete $self->{tls}, delete $self->{tls_ctx}); 286 $self->starttls (delete $self->{tls}, delete $self->{tls_ctx});
226 } 287 }
227 288
228# $self->on_eof (delete $self->{on_eof} ) if $self->{on_eof}; # nop
229# $self->on_error (delete $self->{on_error}) if $self->{on_error}; # nop
230# $self->on_read (delete $self->{on_read} ) if $self->{on_read}; # nop
231 $self->on_drain (delete $self->{on_drain}) if $self->{on_drain};
232
233 $self->{_activity} = time; 289 $self->{_activity} = AnyEvent->now;
234 $self->_timeout; 290 $self->_timeout;
235 291
292 $self->on_drain (delete $self->{on_drain}) if exists $self->{on_drain};
293 $self->no_delay (delete $self->{no_delay}) if exists $self->{no_delay};
294
236 $self->start_read; 295 $self->start_read
296 if $self->{on_read};
237 297
238 $self 298 $self
239} 299}
240 300
241sub _shutdown { 301sub _shutdown {
242 my ($self) = @_; 302 my ($self) = @_;
243 303
304 delete $self->{_tw};
244 delete $self->{_rw}; 305 delete $self->{_rw};
245 delete $self->{_ww}; 306 delete $self->{_ww};
246 delete $self->{fh}; 307 delete $self->{fh};
247}
248 308
309 $self->stoptls;
310
311 delete $self->{on_read};
312 delete $self->{_queue};
313}
314
249sub error { 315sub _error {
250 my ($self) = @_; 316 my ($self, $errno, $fatal) = @_;
251 317
252 {
253 local $!;
254 $self->_shutdown; 318 $self->_shutdown
255 } 319 if $fatal;
256 320
257 $self->{on_error}($self) 321 $! = $errno;
322
258 if $self->{on_error}; 323 if ($self->{on_error}) {
259 324 $self->{on_error}($self, $fatal);
325 } else {
260 Carp::croak "AnyEvent::Handle uncaught fatal error: $!"; 326 Carp::croak "AnyEvent::Handle uncaught error: $!";
327 }
261} 328}
262 329
263=item $fh = $handle->fh 330=item $fh = $handle->fh
264 331
265This method returns the file handle of the L<AnyEvent::Handle> object. 332This method returns the file handle of the L<AnyEvent::Handle> object.
296 363
297=cut 364=cut
298 365
299sub on_timeout { 366sub on_timeout {
300 $_[0]{on_timeout} = $_[1]; 367 $_[0]{on_timeout} = $_[1];
368}
369
370=item $handle->autocork ($boolean)
371
372Enables or disables the current autocork behaviour (see C<autocork>
373constructor argument).
374
375=cut
376
377=item $handle->no_delay ($boolean)
378
379Enables or disables the C<no_delay> setting (see constructor argument of
380the same name for details).
381
382=cut
383
384sub no_delay {
385 $_[0]{no_delay} = $_[1];
386
387 eval {
388 local $SIG{__DIE__};
389 setsockopt $_[0]{fh}, &Socket::IPPROTO_TCP, &Socket::TCP_NODELAY, int $_[1];
390 };
301} 391}
302 392
303############################################################################# 393#############################################################################
304 394
305=item $handle->timeout ($seconds) 395=item $handle->timeout ($seconds)
319# also check for time-outs 409# also check for time-outs
320sub _timeout { 410sub _timeout {
321 my ($self) = @_; 411 my ($self) = @_;
322 412
323 if ($self->{timeout}) { 413 if ($self->{timeout}) {
324 my $NOW = time; 414 my $NOW = AnyEvent->now;
325 415
326 # when would the timeout trigger? 416 # when would the timeout trigger?
327 my $after = $self->{_activity} + $self->{timeout} - $NOW; 417 my $after = $self->{_activity} + $self->{timeout} - $NOW;
328
329 warn "next to in $after\n";#d#
330 418
331 # now or in the past already? 419 # now or in the past already?
332 if ($after <= 0) { 420 if ($after <= 0) {
333 $self->{_activity} = $NOW; 421 $self->{_activity} = $NOW;
334 422
335 if ($self->{on_timeout}) { 423 if ($self->{on_timeout}) {
336 $self->{on_timeout}->($self); 424 $self->{on_timeout}($self);
337 } else { 425 } else {
338 $! = Errno::ETIMEDOUT; 426 $self->_error (&Errno::ETIMEDOUT);
339 $self->error;
340 } 427 }
341 428
342 # callbakx could have changed timeout value, optimise 429 # callback could have changed timeout value, optimise
343 return unless $self->{timeout}; 430 return unless $self->{timeout};
344 431
345 # calculate new after 432 # calculate new after
346 $after = $self->{timeout}; 433 $after = $self->{timeout};
347 } 434 }
348 435
349 Scalar::Util::weaken $self; 436 Scalar::Util::weaken $self;
437 return unless $self; # ->error could have destroyed $self
350 438
351 warn "after $after\n";#d#
352 $self->{_tw} ||= AnyEvent->timer (after => $after, cb => sub { 439 $self->{_tw} ||= AnyEvent->timer (after => $after, cb => sub {
353 delete $self->{_tw}; 440 delete $self->{_tw};
354 $self->_timeout; 441 $self->_timeout;
355 }); 442 });
356 } else { 443 } else {
410 my $len = syswrite $self->{fh}, $self->{wbuf}; 497 my $len = syswrite $self->{fh}, $self->{wbuf};
411 498
412 if ($len >= 0) { 499 if ($len >= 0) {
413 substr $self->{wbuf}, 0, $len, ""; 500 substr $self->{wbuf}, 0, $len, "";
414 501
415 $self->{_activity} = time; 502 $self->{_activity} = AnyEvent->now;
416 503
417 $self->{on_drain}($self) 504 $self->{on_drain}($self)
418 if $self->{low_water_mark} >= length $self->{wbuf} 505 if $self->{low_water_mark} >= length $self->{wbuf}
419 && $self->{on_drain}; 506 && $self->{on_drain};
420 507
421 delete $self->{_ww} unless length $self->{wbuf}; 508 delete $self->{_ww} unless length $self->{wbuf};
422 } elsif ($! != EAGAIN && $! != EINTR && $! != WSAEWOULDBLOCK) { 509 } elsif ($! != EAGAIN && $! != EINTR && $! != WSAEWOULDBLOCK) {
423 $self->error; 510 $self->_error ($!, 1);
424 } 511 }
425 }; 512 };
426 513
427 # try to write data immediately 514 # try to write data immediately
428 $cb->(); 515 $cb->() unless $self->{autocork};
429 516
430 # if still data left in wbuf, we need to poll 517 # if still data left in wbuf, we need to poll
431 $self->{_ww} = AnyEvent->io (fh => $self->{fh}, poll => "w", cb => $cb) 518 $self->{_ww} = AnyEvent->io (fh => $self->{fh}, poll => "w", cb => $cb)
432 if length $self->{wbuf}; 519 if length $self->{wbuf};
433 }; 520 };
448 @_ = ($WH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::push_write") 535 @_ = ($WH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::push_write")
449 ->($self, @_); 536 ->($self, @_);
450 } 537 }
451 538
452 if ($self->{filter_w}) { 539 if ($self->{filter_w}) {
453 $self->{filter_w}->($self, \$_[0]); 540 $self->{filter_w}($self, \$_[0]);
454 } else { 541 } else {
455 $self->{wbuf} .= $_[0]; 542 $self->{wbuf} .= $_[0];
456 $self->_drain_wbuf; 543 $self->_drain_wbuf;
457 } 544 }
458} 545}
459 546
460=item $handle->push_write (type => @args) 547=item $handle->push_write (type => @args)
461 548
462=item $handle->unshift_write (type => @args)
463
464Instead of formatting your data yourself, you can also let this module do 549Instead of formatting your data yourself, you can also let this module do
465the job by specifying a type and type-specific arguments. 550the job by specifying a type and type-specific arguments.
466 551
467Predefined types are (if you have ideas for additional types, feel free to 552Predefined types are (if you have ideas for additional types, feel free to
468drop by and tell us): 553drop by and tell us):
472=item netstring => $string 557=item netstring => $string
473 558
474Formats the given value as netstring 559Formats the given value as netstring
475(http://cr.yp.to/proto/netstrings.txt, this is not a recommendation to use them). 560(http://cr.yp.to/proto/netstrings.txt, this is not a recommendation to use them).
476 561
477=back
478
479=cut 562=cut
480 563
481register_write_type netstring => sub { 564register_write_type netstring => sub {
482 my ($self, $string) = @_; 565 my ($self, $string) = @_;
483 566
484 sprintf "%d:%s,", (length $string), $string 567 sprintf "%d:%s,", (length $string), $string
568};
569
570=item packstring => $format, $data
571
572An octet string prefixed with an encoded length. The encoding C<$format>
573uses the same format as a Perl C<pack> format, but must specify a single
574integer only (only one of C<cCsSlLqQiInNvVjJw> is allowed, plus an
575optional C<!>, C<< < >> or C<< > >> modifier).
576
577=cut
578
579register_write_type packstring => sub {
580 my ($self, $format, $string) = @_;
581
582 pack "$format/a*", $string
485}; 583};
486 584
487=item json => $array_or_hashref 585=item json => $array_or_hashref
488 586
489Encodes the given hash or array reference into a JSON object. Unless you 587Encodes the given hash or array reference into a JSON object. Unless you
523 621
524 $self->{json} ? $self->{json}->encode ($ref) 622 $self->{json} ? $self->{json}->encode ($ref)
525 : JSON::encode_json ($ref) 623 : JSON::encode_json ($ref)
526}; 624};
527 625
626=item storable => $reference
627
628Freezes the given reference using L<Storable> and writes it to the
629handle. Uses the C<nfreeze> format.
630
631=cut
632
633register_write_type storable => sub {
634 my ($self, $ref) = @_;
635
636 require Storable;
637
638 pack "w/a*", Storable::nfreeze ($ref)
639};
640
641=back
642
528=item AnyEvent::Handle::register_write_type type => $coderef->($handle, @args) 643=item AnyEvent::Handle::register_write_type type => $coderef->($handle, @args)
529 644
530This function (not method) lets you add your own types to C<push_write>. 645This function (not method) lets you add your own types to C<push_write>.
531Whenever the given C<type> is used, C<push_write> will invoke the code 646Whenever the given C<type> is used, C<push_write> will invoke the code
532reference with the handle object and the remaining arguments. 647reference with the handle object and the remaining arguments.
552ways, the "simple" way, using only C<on_read> and the "complex" way, using 667ways, the "simple" way, using only C<on_read> and the "complex" way, using
553a queue. 668a queue.
554 669
555In the simple case, you just install an C<on_read> callback and whenever 670In the simple case, you just install an C<on_read> callback and whenever
556new data arrives, it will be called. You can then remove some data (if 671new data arrives, it will be called. You can then remove some data (if
557enough is there) from the read buffer (C<< $handle->rbuf >>) if you want 672enough is there) from the read buffer (C<< $handle->rbuf >>). Or you cna
558or not. 673leave the data there if you want to accumulate more (e.g. when only a
674partial message has been received so far).
559 675
560In the more complex case, you want to queue multiple callbacks. In this 676In the more complex case, you want to queue multiple callbacks. In this
561case, AnyEvent::Handle will call the first queued callback each time new 677case, AnyEvent::Handle will call the first queued callback each time new
562data arrives and removes it when it has done its job (see C<push_read>, 678data arrives (also the first time it is queued) and removes it when it has
563below). 679done its job (see C<push_read>, below).
564 680
565This way you can, for example, push three line-reads, followed by reading 681This way you can, for example, push three line-reads, followed by reading
566a chunk of data, and AnyEvent::Handle will execute them in order. 682a chunk of data, and AnyEvent::Handle will execute them in order.
567 683
568Example 1: EPP protocol parser. EPP sends 4 byte length info, followed by 684Example 1: EPP protocol parser. EPP sends 4 byte length info, followed by
569the specified number of bytes which give an XML datagram. 685the specified number of bytes which give an XML datagram.
570 686
571 # in the default state, expect some header bytes 687 # in the default state, expect some header bytes
572 $handle->on_read (sub { 688 $handle->on_read (sub {
573 # some data is here, now queue the length-header-read (4 octets) 689 # some data is here, now queue the length-header-read (4 octets)
574 shift->unshift_read_chunk (4, sub { 690 shift->unshift_read (chunk => 4, sub {
575 # header arrived, decode 691 # header arrived, decode
576 my $len = unpack "N", $_[1]; 692 my $len = unpack "N", $_[1];
577 693
578 # now read the payload 694 # now read the payload
579 shift->unshift_read_chunk ($len, sub { 695 shift->unshift_read (chunk => $len, sub {
580 my $xml = $_[1]; 696 my $xml = $_[1];
581 # handle xml 697 # handle xml
582 }); 698 });
583 }); 699 });
584 }); 700 });
585 701
586Example 2: Implement a client for a protocol that replies either with 702Example 2: Implement a client for a protocol that replies either with "OK"
587"OK" and another line or "ERROR" for one request, and 64 bytes for the 703and another line or "ERROR" for the first request that is sent, and 64
588second request. Due tot he availability of a full queue, we can just 704bytes for the second request. Due to the availability of a queue, we can
589pipeline sending both requests and manipulate the queue as necessary in 705just pipeline sending both requests and manipulate the queue as necessary
590the callbacks: 706in the callbacks.
591 707
592 # request one 708When the first callback is called and sees an "OK" response, it will
709C<unshift> another line-read. This line-read will be queued I<before> the
71064-byte chunk callback.
711
712 # request one, returns either "OK + extra line" or "ERROR"
593 $handle->push_write ("request 1\015\012"); 713 $handle->push_write ("request 1\015\012");
594 714
595 # we expect "ERROR" or "OK" as response, so push a line read 715 # we expect "ERROR" or "OK" as response, so push a line read
596 $handle->push_read_line (sub { 716 $handle->push_read (line => sub {
597 # if we got an "OK", we have to _prepend_ another line, 717 # if we got an "OK", we have to _prepend_ another line,
598 # so it will be read before the second request reads its 64 bytes 718 # so it will be read before the second request reads its 64 bytes
599 # which are already in the queue when this callback is called 719 # which are already in the queue when this callback is called
600 # we don't do this in case we got an error 720 # we don't do this in case we got an error
601 if ($_[1] eq "OK") { 721 if ($_[1] eq "OK") {
602 $_[0]->unshift_read_line (sub { 722 $_[0]->unshift_read (line => sub {
603 my $response = $_[1]; 723 my $response = $_[1];
604 ... 724 ...
605 }); 725 });
606 } 726 }
607 }); 727 });
608 728
609 # request two 729 # request two, simply returns 64 octets
610 $handle->push_write ("request 2\015\012"); 730 $handle->push_write ("request 2\015\012");
611 731
612 # simply read 64 bytes, always 732 # simply read 64 bytes, always
613 $handle->push_read_chunk (64, sub { 733 $handle->push_read (chunk => 64, sub {
614 my $response = $_[1]; 734 my $response = $_[1];
615 ... 735 ...
616 }); 736 });
617 737
618=over 4 738=over 4
619 739
620=cut 740=cut
621 741
622sub _drain_rbuf { 742sub _drain_rbuf {
623 my ($self) = @_; 743 my ($self) = @_;
744
745 local $self->{_in_drain} = 1;
624 746
625 if ( 747 if (
626 defined $self->{rbuf_max} 748 defined $self->{rbuf_max}
627 && $self->{rbuf_max} < length $self->{rbuf} 749 && $self->{rbuf_max} < length $self->{rbuf}
628 ) { 750 ) {
629 $! = &Errno::ENOSPC; 751 $self->_error (&Errno::ENOSPC, 1), return;
630 $self->error;
631 } 752 }
632 753
633 return if $self->{in_drain}; 754 while () {
634 local $self->{in_drain} = 1;
635
636 while (my $len = length $self->{rbuf}) { 755 my $len = length $self->{rbuf};
637 no strict 'refs'; 756
638 if (my $cb = shift @{ $self->{_queue} }) { 757 if (my $cb = shift @{ $self->{_queue} }) {
639 unless ($cb->($self)) { 758 unless ($cb->($self)) {
640 if ($self->{_eof}) { 759 if ($self->{_eof}) {
641 # no progress can be made (not enough data and no data forthcoming) 760 # no progress can be made (not enough data and no data forthcoming)
642 $! = &Errno::EPIPE; 761 $self->_error (&Errno::EPIPE, 1), return;
643 $self->error;
644 } 762 }
645 763
646 unshift @{ $self->{_queue} }, $cb; 764 unshift @{ $self->{_queue} }, $cb;
647 return; 765 last;
648 } 766 }
649 } elsif ($self->{on_read}) { 767 } elsif ($self->{on_read}) {
768 last unless $len;
769
650 $self->{on_read}($self); 770 $self->{on_read}($self);
651 771
652 if ( 772 if (
653 $self->{_eof} # if no further data will arrive
654 && $len == length $self->{rbuf} # and no data has been consumed 773 $len == length $self->{rbuf} # if no data has been consumed
655 && !@{ $self->{_queue} } # and the queue is still empty 774 && !@{ $self->{_queue} } # and the queue is still empty
656 && $self->{on_read} # and we still want to read data 775 && $self->{on_read} # but we still have on_read
657 ) { 776 ) {
777 # no further data will arrive
658 # then no progress can be made 778 # so no progress can be made
659 $! = &Errno::EPIPE; 779 $self->_error (&Errno::EPIPE, 1), return
660 $self->error; 780 if $self->{_eof};
781
782 last; # more data might arrive
661 } 783 }
662 } else { 784 } else {
663 # read side becomes idle 785 # read side becomes idle
664 delete $self->{_rw}; 786 delete $self->{_rw};
665 return; 787 last;
666 } 788 }
667 } 789 }
668 790
669 if ($self->{_eof}) { 791 if ($self->{_eof}) {
670 $self->_shutdown; 792 if ($self->{on_eof}) {
671 $self->{on_eof}($self) 793 $self->{on_eof}($self)
672 if $self->{on_eof}; 794 } else {
795 $self->_error (0, 1);
796 }
797 }
798
799 # may need to restart read watcher
800 unless ($self->{_rw}) {
801 $self->start_read
802 if $self->{on_read} || @{ $self->{_queue} };
673 } 803 }
674} 804}
675 805
676=item $handle->on_read ($cb) 806=item $handle->on_read ($cb)
677 807
683 813
684sub on_read { 814sub on_read {
685 my ($self, $cb) = @_; 815 my ($self, $cb) = @_;
686 816
687 $self->{on_read} = $cb; 817 $self->{on_read} = $cb;
818 $self->_drain_rbuf if $cb && !$self->{_in_drain};
688} 819}
689 820
690=item $handle->rbuf 821=item $handle->rbuf
691 822
692Returns the read buffer (as a modifiable lvalue). 823Returns the read buffer (as a modifiable lvalue).
741 $cb = ($RH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::push_read") 872 $cb = ($RH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::push_read")
742 ->($self, $cb, @_); 873 ->($self, $cb, @_);
743 } 874 }
744 875
745 push @{ $self->{_queue} }, $cb; 876 push @{ $self->{_queue} }, $cb;
746 $self->_drain_rbuf; 877 $self->_drain_rbuf unless $self->{_in_drain};
747} 878}
748 879
749sub unshift_read { 880sub unshift_read {
750 my $self = shift; 881 my $self = shift;
751 my $cb = pop; 882 my $cb = pop;
757 ->($self, $cb, @_); 888 ->($self, $cb, @_);
758 } 889 }
759 890
760 891
761 unshift @{ $self->{_queue} }, $cb; 892 unshift @{ $self->{_queue} }, $cb;
762 $self->_drain_rbuf; 893 $self->_drain_rbuf unless $self->{_in_drain};
763} 894}
764 895
765=item $handle->push_read (type => @args, $cb) 896=item $handle->push_read (type => @args, $cb)
766 897
767=item $handle->unshift_read (type => @args, $cb) 898=item $handle->unshift_read (type => @args, $cb)
797 $cb->($_[0], substr $_[0]{rbuf}, 0, $len, ""); 928 $cb->($_[0], substr $_[0]{rbuf}, 0, $len, "");
798 1 929 1
799 } 930 }
800}; 931};
801 932
802# compatibility with older API
803sub push_read_chunk {
804 $_[0]->push_read (chunk => $_[1], $_[2]);
805}
806
807sub unshift_read_chunk {
808 $_[0]->unshift_read (chunk => $_[1], $_[2]);
809}
810
811=item line => [$eol, ]$cb->($handle, $line, $eol) 933=item line => [$eol, ]$cb->($handle, $line, $eol)
812 934
813The callback will be called only once a full line (including the end of 935The callback will be called only once a full line (including the end of
814line marker, C<$eol>) has been read. This line (excluding the end of line 936line marker, C<$eol>) has been read. This line (excluding the end of line
815marker) will be passed to the callback as second argument (C<$line>), and 937marker) will be passed to the callback as second argument (C<$line>), and
830=cut 952=cut
831 953
832register_read_type line => sub { 954register_read_type line => sub {
833 my ($self, $cb, $eol) = @_; 955 my ($self, $cb, $eol) = @_;
834 956
835 $eol = qr|(\015?\012)| if @_ < 3; 957 if (@_ < 3) {
836 $eol = quotemeta $eol unless ref $eol; 958 # this is more than twice as fast as the generic code below
837 $eol = qr|^(.*?)($eol)|s;
838
839 sub { 959 sub {
840 $_[0]{rbuf} =~ s/$eol// or return; 960 $_[0]{rbuf} =~ s/^([^\015\012]*)(\015?\012)// or return;
841 961
842 $cb->($_[0], $1, $2); 962 $cb->($_[0], $1, $2);
843 1
844 }
845};
846
847# compatibility with older API
848sub push_read_line {
849 my $self = shift;
850 $self->push_read (line => @_);
851}
852
853sub unshift_read_line {
854 my $self = shift;
855 $self->unshift_read (line => @_);
856}
857
858=item netstring => $cb->($handle, $string)
859
860A netstring (http://cr.yp.to/proto/netstrings.txt, this is not an endorsement).
861
862Throws an error with C<$!> set to EBADMSG on format violations.
863
864=cut
865
866register_read_type netstring => sub {
867 my ($self, $cb) = @_;
868
869 sub {
870 unless ($_[0]{rbuf} =~ s/^(0|[1-9][0-9]*)://) {
871 if ($_[0]{rbuf} =~ /[^0-9]/) {
872 $! = &Errno::EBADMSG;
873 $self->error;
874 } 963 1
875 return;
876 } 964 }
965 } else {
966 $eol = quotemeta $eol unless ref $eol;
967 $eol = qr|^(.*?)($eol)|s;
877 968
878 my $len = $1; 969 sub {
970 $_[0]{rbuf} =~ s/$eol// or return;
879 971
880 $self->unshift_read (chunk => $len, sub { 972 $cb->($_[0], $1, $2);
881 my $string = $_[1];
882 $_[0]->unshift_read (chunk => 1, sub {
883 if ($_[1] eq ",") {
884 $cb->($_[0], $string);
885 } else {
886 $! = &Errno::EBADMSG;
887 $self->error;
888 }
889 }); 973 1
890 }); 974 }
891
892 1
893 } 975 }
894}; 976};
895 977
896=item regex => $accept[, $reject[, $skip], $cb->($handle, $data) 978=item regex => $accept[, $reject[, $skip], $cb->($handle, $data)
897 979
949 return 1; 1031 return 1;
950 } 1032 }
951 1033
952 # reject 1034 # reject
953 if ($reject && $$rbuf =~ $reject) { 1035 if ($reject && $$rbuf =~ $reject) {
954 $! = &Errno::EBADMSG; 1036 $self->_error (&Errno::EBADMSG);
955 $self->error;
956 } 1037 }
957 1038
958 # skip 1039 # skip
959 if ($skip && $$rbuf =~ $skip) { 1040 if ($skip && $$rbuf =~ $skip) {
960 $data .= substr $$rbuf, 0, $+[0], ""; 1041 $data .= substr $$rbuf, 0, $+[0], "";
962 1043
963 () 1044 ()
964 } 1045 }
965}; 1046};
966 1047
1048=item netstring => $cb->($handle, $string)
1049
1050A netstring (http://cr.yp.to/proto/netstrings.txt, this is not an endorsement).
1051
1052Throws an error with C<$!> set to EBADMSG on format violations.
1053
1054=cut
1055
1056register_read_type netstring => sub {
1057 my ($self, $cb) = @_;
1058
1059 sub {
1060 unless ($_[0]{rbuf} =~ s/^(0|[1-9][0-9]*)://) {
1061 if ($_[0]{rbuf} =~ /[^0-9]/) {
1062 $self->_error (&Errno::EBADMSG);
1063 }
1064 return;
1065 }
1066
1067 my $len = $1;
1068
1069 $self->unshift_read (chunk => $len, sub {
1070 my $string = $_[1];
1071 $_[0]->unshift_read (chunk => 1, sub {
1072 if ($_[1] eq ",") {
1073 $cb->($_[0], $string);
1074 } else {
1075 $self->_error (&Errno::EBADMSG);
1076 }
1077 });
1078 });
1079
1080 1
1081 }
1082};
1083
1084=item packstring => $format, $cb->($handle, $string)
1085
1086An octet string prefixed with an encoded length. The encoding C<$format>
1087uses the same format as a Perl C<pack> format, but must specify a single
1088integer only (only one of C<cCsSlLqQiInNvVjJw> is allowed, plus an
1089optional C<!>, C<< < >> or C<< > >> modifier).
1090
1091DNS over TCP uses a prefix of C<n>, EPP uses a prefix of C<N>.
1092
1093Example: read a block of data prefixed by its length in BER-encoded
1094format (very efficient).
1095
1096 $handle->push_read (packstring => "w", sub {
1097 my ($handle, $data) = @_;
1098 });
1099
1100=cut
1101
1102register_read_type packstring => sub {
1103 my ($self, $cb, $format) = @_;
1104
1105 sub {
1106 # when we can use 5.10 we can use ".", but for 5.8 we use the re-pack method
1107 defined (my $len = eval { unpack $format, $_[0]{rbuf} })
1108 or return;
1109
1110 $format = length pack $format, $len;
1111
1112 # bypass unshift if we already have the remaining chunk
1113 if ($format + $len <= length $_[0]{rbuf}) {
1114 my $data = substr $_[0]{rbuf}, $format, $len;
1115 substr $_[0]{rbuf}, 0, $format + $len, "";
1116 $cb->($_[0], $data);
1117 } else {
1118 # remove prefix
1119 substr $_[0]{rbuf}, 0, $format, "";
1120
1121 # read remaining chunk
1122 $_[0]->unshift_read (chunk => $len, $cb);
1123 }
1124
1125 1
1126 }
1127};
1128
967=item json => $cb->($handle, $hash_or_arrayref) 1129=item json => $cb->($handle, $hash_or_arrayref)
968 1130
969Reads a JSON object or array, decodes it and passes it to the callback. 1131Reads a JSON object or array, decodes it and passes it to the callback.
970 1132
971If a C<json> object was passed to the constructor, then that will be used 1133If a C<json> object was passed to the constructor, then that will be used
981the C<json> write type description, above, for an actual example. 1143the C<json> write type description, above, for an actual example.
982 1144
983=cut 1145=cut
984 1146
985register_read_type json => sub { 1147register_read_type json => sub {
986 my ($self, $cb, $accept, $reject, $skip) = @_; 1148 my ($self, $cb) = @_;
987 1149
988 require JSON; 1150 require JSON;
989 1151
990 my $data; 1152 my $data;
991 my $rbuf = \$self->{rbuf}; 1153 my $rbuf = \$self->{rbuf};
1006 () 1168 ()
1007 } 1169 }
1008 } 1170 }
1009}; 1171};
1010 1172
1173=item storable => $cb->($handle, $ref)
1174
1175Deserialises a L<Storable> frozen representation as written by the
1176C<storable> write type (BER-encoded length prefix followed by nfreeze'd
1177data).
1178
1179Raises C<EBADMSG> error if the data could not be decoded.
1180
1181=cut
1182
1183register_read_type storable => sub {
1184 my ($self, $cb) = @_;
1185
1186 require Storable;
1187
1188 sub {
1189 # when we can use 5.10 we can use ".", but for 5.8 we use the re-pack method
1190 defined (my $len = eval { unpack "w", $_[0]{rbuf} })
1191 or return;
1192
1193 my $format = length pack "w", $len;
1194
1195 # bypass unshift if we already have the remaining chunk
1196 if ($format + $len <= length $_[0]{rbuf}) {
1197 my $data = substr $_[0]{rbuf}, $format, $len;
1198 substr $_[0]{rbuf}, 0, $format + $len, "";
1199 $cb->($_[0], Storable::thaw ($data));
1200 } else {
1201 # remove prefix
1202 substr $_[0]{rbuf}, 0, $format, "";
1203
1204 # read remaining chunk
1205 $_[0]->unshift_read (chunk => $len, sub {
1206 if (my $ref = eval { Storable::thaw ($_[1]) }) {
1207 $cb->($_[0], $ref);
1208 } else {
1209 $self->_error (&Errno::EBADMSG);
1210 }
1211 });
1212 }
1213
1214 1
1215 }
1216};
1217
1011=back 1218=back
1012 1219
1013=item AnyEvent::Handle::register_read_type type => $coderef->($handle, $cb, @args) 1220=item AnyEvent::Handle::register_read_type type => $coderef->($handle, $cb, @args)
1014 1221
1015This function (not method) lets you add your own types to C<push_read>. 1222This function (not method) lets you add your own types to C<push_read>.
1033=item $handle->stop_read 1240=item $handle->stop_read
1034 1241
1035=item $handle->start_read 1242=item $handle->start_read
1036 1243
1037In rare cases you actually do not want to read anything from the 1244In rare cases you actually do not want to read anything from the
1038socket. In this case you can call C<stop_read>. Neither C<on_read> no 1245socket. In this case you can call C<stop_read>. Neither C<on_read> nor
1039any queued callbacks will be executed then. To start reading again, call 1246any queued callbacks will be executed then. To start reading again, call
1040C<start_read>. 1247C<start_read>.
1248
1249Note that AnyEvent::Handle will automatically C<start_read> for you when
1250you change the C<on_read> callback or push/unshift a read callback, and it
1251will automatically C<stop_read> for you when neither C<on_read> is set nor
1252there are any read requests in the queue.
1041 1253
1042=cut 1254=cut
1043 1255
1044sub stop_read { 1256sub stop_read {
1045 my ($self) = @_; 1257 my ($self) = @_;
1056 $self->{_rw} = AnyEvent->io (fh => $self->{fh}, poll => "r", cb => sub { 1268 $self->{_rw} = AnyEvent->io (fh => $self->{fh}, poll => "r", cb => sub {
1057 my $rbuf = $self->{filter_r} ? \my $buf : \$self->{rbuf}; 1269 my $rbuf = $self->{filter_r} ? \my $buf : \$self->{rbuf};
1058 my $len = sysread $self->{fh}, $$rbuf, $self->{read_size} || 8192, length $$rbuf; 1270 my $len = sysread $self->{fh}, $$rbuf, $self->{read_size} || 8192, length $$rbuf;
1059 1271
1060 if ($len > 0) { 1272 if ($len > 0) {
1061 $self->{_activity} = time; 1273 $self->{_activity} = AnyEvent->now;
1062 1274
1063 $self->{filter_r} 1275 $self->{filter_r}
1064 ? $self->{filter_r}->($self, $rbuf) 1276 ? $self->{filter_r}($self, $rbuf)
1065 : $self->_drain_rbuf; 1277 : $self->{_in_drain} || $self->_drain_rbuf;
1066 1278
1067 } elsif (defined $len) { 1279 } elsif (defined $len) {
1068 delete $self->{_rw}; 1280 delete $self->{_rw};
1069 delete $self->{_ww};
1070 delete $self->{_tw};
1071 $self->{_eof} = 1; 1281 $self->{_eof} = 1;
1072 $self->_drain_rbuf; 1282 $self->_drain_rbuf unless $self->{_in_drain};
1073 1283
1074 } elsif ($! != EAGAIN && $! != EINTR && $! != WSAEWOULDBLOCK) { 1284 } elsif ($! != EAGAIN && $! != EINTR && $! != WSAEWOULDBLOCK) {
1075 return $self->error; 1285 return $self->_error ($!, 1);
1076 } 1286 }
1077 }); 1287 });
1078 } 1288 }
1079} 1289}
1080 1290
1081sub _dotls { 1291sub _dotls {
1082 my ($self) = @_; 1292 my ($self) = @_;
1293
1294 my $buf;
1083 1295
1084 if (length $self->{_tls_wbuf}) { 1296 if (length $self->{_tls_wbuf}) {
1085 while ((my $len = Net::SSLeay::write ($self->{tls}, $self->{_tls_wbuf})) > 0) { 1297 while ((my $len = Net::SSLeay::write ($self->{tls}, $self->{_tls_wbuf})) > 0) {
1086 substr $self->{_tls_wbuf}, 0, $len, ""; 1298 substr $self->{_tls_wbuf}, 0, $len, "";
1087 } 1299 }
1088 } 1300 }
1089 1301
1090 if (defined (my $buf = Net::SSLeay::BIO_read ($self->{_wbio}))) { 1302 if (length ($buf = Net::SSLeay::BIO_read ($self->{_wbio}))) {
1091 $self->{wbuf} .= $buf; 1303 $self->{wbuf} .= $buf;
1092 $self->_drain_wbuf; 1304 $self->_drain_wbuf;
1093 } 1305 }
1094 1306
1095 while (defined (my $buf = Net::SSLeay::read ($self->{tls}))) { 1307 while (defined ($buf = Net::SSLeay::read ($self->{tls}))) {
1308 if (length $buf) {
1096 $self->{rbuf} .= $buf; 1309 $self->{rbuf} .= $buf;
1097 $self->_drain_rbuf; 1310 $self->_drain_rbuf unless $self->{_in_drain};
1311 } else {
1312 # let's treat SSL-eof as we treat normal EOF
1313 $self->{_eof} = 1;
1314 $self->_shutdown;
1315 return;
1316 }
1098 } 1317 }
1099 1318
1100 my $err = Net::SSLeay::get_error ($self->{tls}, -1); 1319 my $err = Net::SSLeay::get_error ($self->{tls}, -1);
1101 1320
1102 if ($err!= Net::SSLeay::ERROR_WANT_READ ()) { 1321 if ($err!= Net::SSLeay::ERROR_WANT_READ ()) {
1103 if ($err == Net::SSLeay::ERROR_SYSCALL ()) { 1322 if ($err == Net::SSLeay::ERROR_SYSCALL ()) {
1104 $self->error; 1323 return $self->_error ($!, 1);
1105 } elsif ($err == Net::SSLeay::ERROR_SSL ()) { 1324 } elsif ($err == Net::SSLeay::ERROR_SSL ()) {
1106 $! = &Errno::EIO; 1325 return $self->_error (&Errno::EIO, 1);
1107 $self->error;
1108 } 1326 }
1109 1327
1110 # all others are fine for our purposes 1328 # all others are fine for our purposes
1111 } 1329 }
1112} 1330}
1127call and can be used or changed to your liking. Note that the handshake 1345call and can be used or changed to your liking. Note that the handshake
1128might have already started when this function returns. 1346might have already started when this function returns.
1129 1347
1130=cut 1348=cut
1131 1349
1132# TODO: maybe document...
1133sub starttls { 1350sub starttls {
1134 my ($self, $ssl, $ctx) = @_; 1351 my ($self, $ssl, $ctx) = @_;
1135 1352
1136 $self->stoptls; 1353 $self->stoptls;
1137 1354
1190 1407
1191sub DESTROY { 1408sub DESTROY {
1192 my $self = shift; 1409 my $self = shift;
1193 1410
1194 $self->stoptls; 1411 $self->stoptls;
1412
1413 my $linger = exists $self->{linger} ? $self->{linger} : 3600;
1414
1415 if ($linger && length $self->{wbuf}) {
1416 my $fh = delete $self->{fh};
1417 my $wbuf = delete $self->{wbuf};
1418
1419 my @linger;
1420
1421 push @linger, AnyEvent->io (fh => $fh, poll => "w", cb => sub {
1422 my $len = syswrite $fh, $wbuf, length $wbuf;
1423
1424 if ($len > 0) {
1425 substr $wbuf, 0, $len, "";
1426 } else {
1427 @linger = (); # end
1428 }
1429 });
1430 push @linger, AnyEvent->timer (after => $linger, cb => sub {
1431 @linger = ();
1432 });
1433 }
1195} 1434}
1196 1435
1197=item AnyEvent::Handle::TLS_CTX 1436=item AnyEvent::Handle::TLS_CTX
1198 1437
1199This function creates and returns the Net::SSLeay::CTX object used by 1438This function creates and returns the Net::SSLeay::CTX object used by
1241=over 4 1480=over 4
1242 1481
1243=item * all constructor arguments become object members. 1482=item * all constructor arguments become object members.
1244 1483
1245At least initially, when you pass a C<tls>-argument to the constructor it 1484At least initially, when you pass a C<tls>-argument to the constructor it
1246will end up in C<< $handle->{tls} >>. Those members might be changes or 1485will end up in C<< $handle->{tls} >>. Those members might be changed or
1247mutated later on (for example C<tls> will hold the TLS connection object). 1486mutated later on (for example C<tls> will hold the TLS connection object).
1248 1487
1249=item * other object member names are prefixed with an C<_>. 1488=item * other object member names are prefixed with an C<_>.
1250 1489
1251All object members not explicitly documented (internal use) are prefixed 1490All object members not explicitly documented (internal use) are prefixed

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines