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.17 by root, Sat May 24 04:17:45 2008 UTC vs.
Revision 1.29 by root, Sat May 24 23:10:18 2008 UTC

… …
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 filehandles via AnyEvent 15AnyEvent::Handle - non-blocking I/O on file handles via AnyEvent
16 16
17This module is experimental. 17This module is experimental.
18 18
19=cut 19=cut
20 20
… …
83waiting for data. 83waiting for data.
84 84
85=item on_error => $cb->($self) 85=item on_error => $cb->($self)
86 86
87This is the fatal error callback, that is called when, well, a fatal error 87This is the fatal error callback, that is called when, well, a fatal error
88ocurs, such as not being able to resolve the hostname, failure to connect 88occurs, such as not being able to resolve the hostname, failure to connect
89or a read error. 89or a read error.
90 90
91The object will not be in a usable state when this callback has been 91The object will not be in a usable state when this callback has been
92called. 92called.
93 93
94On callback entrance, the value of C<$!> contains the operating system 94On callback entrance, the value of C<$!> contains the operating system
95error (or C<ENOSPC> or C<EPIPE>). 95error (or C<ENOSPC>, C<EPIPE> or C<EBADMSG>).
96 96
97While not mandatory, it is I<highly> recommended to set this callback, as 97While not mandatory, it is I<highly> recommended to set this callback, as
98you will not be notified of errors otherwise. The default simply calls 98you will not be notified of errors otherwise. The default simply calls
99die. 99die.
100 100
… …
102 102
103This sets the default read callback, which is called when data arrives 103This sets the default read callback, which is called when data arrives
104and no read request is in the queue. 104and no read request is in the queue.
105 105
106To access (and remove data from) the read buffer, use the C<< ->rbuf >> 106To access (and remove data from) the read buffer, use the C<< ->rbuf >>
107method or acces sthe C<$self->{rbuf}> member directly. 107method or access the C<$self->{rbuf}> member directly.
108 108
109When an EOF condition is detected then AnyEvent::Handle will first try to 109When an EOF condition is detected then AnyEvent::Handle will first try to
110feed all the remaining data to the queued callbacks and C<on_read> before 110feed all the remaining data to the queued callbacks and C<on_read> before
111calling the C<on_eof> callback. If no progress can be made, then a fatal 111calling the C<on_eof> callback. If no progress can be made, then a fatal
112error will be raised (with C<$!> set to C<EPIPE>). 112error will be raised (with C<$!> set to C<EPIPE>).
… …
139 139
140Sets the amount of bytes (default: C<0>) that make up an "empty" write 140Sets the amount of bytes (default: C<0>) that make up an "empty" write
141buffer: If the write reaches this size or gets even samller it is 141buffer: If the write reaches this size or gets even samller it is
142considered empty. 142considered empty.
143 143
144=item tls => "accept" | "connect" | Net::SSLeay::SSL object
145
146When this parameter is given, it enables TLS (SSL) mode, that means it
147will start making tls handshake and will transparently encrypt/decrypt
148data.
149
150TLS mode requires Net::SSLeay to be installed (it will be loaded
151automatically when you try to create a TLS handle).
152
153For the TLS server side, use C<accept>, and for the TLS client side of a
154connection, use C<connect> mode.
155
156You can also provide your own TLS connection object, but you have
157to make sure that you call either C<Net::SSLeay::set_connect_state>
158or C<Net::SSLeay::set_accept_state> on it before you pass it to
159AnyEvent::Handle.
160
161See the C<starttls> method if you need to start TLs negotiation later.
162
163=item tls_ctx => $ssl_ctx
164
165Use the given Net::SSLeay::CTX object to create the new TLS connection
166(unless a connection object was specified directly). If this parameter is
167missing, then AnyEvent::Handle will use C<AnyEvent::Handle::TLS_CTX>.
168
144=back 169=back
145 170
146=cut 171=cut
172
173our (%RH, %WH);
174
175sub register_read_type($$) {
176 $RH{$_[0]} = $_[1];
177}
178
179sub register_write_type($$) {
180 $WH{$_[0]} = $_[1];
181}
147 182
148sub new { 183sub new {
149 my $class = shift; 184 my $class = shift;
150 185
151 my $self = bless { @_ }, $class; 186 my $self = bless { @_ }, $class;
152 187
153 $self->{fh} or Carp::croak "mandatory argument fh is missing"; 188 $self->{fh} or Carp::croak "mandatory argument fh is missing";
154 189
155 AnyEvent::Util::fh_nonblocking $self->{fh}, 1; 190 AnyEvent::Util::fh_nonblocking $self->{fh}, 1;
191
192 if ($self->{tls}) {
193 require Net::SSLeay;
194 $self->starttls (delete $self->{tls}, delete $self->{tls_ctx});
195 }
156 196
157 $self->on_eof (delete $self->{on_eof} ) if $self->{on_eof}; 197 $self->on_eof (delete $self->{on_eof} ) if $self->{on_eof};
158 $self->on_error (delete $self->{on_error}) if $self->{on_error}; 198 $self->on_error (delete $self->{on_error}) if $self->{on_error};
159 $self->on_drain (delete $self->{on_drain}) if $self->{on_drain}; 199 $self->on_drain (delete $self->{on_drain}) if $self->{on_drain};
160 $self->on_read (delete $self->{on_read} ) if $self->{on_read}; 200 $self->on_read (delete $self->{on_read} ) if $self->{on_read};
… …
181 } 221 }
182 222
183 if ($self->{on_error}) { 223 if ($self->{on_error}) {
184 $self->{on_error}($self); 224 $self->{on_error}($self);
185 } else { 225 } else {
186 die "AnyEvent::Handle uncaught fatal error: $!"; 226 Carp::croak "AnyEvent::Handle uncaught fatal error: $!";
187 } 227 }
188} 228}
189 229
190=item $fh = $handle->fh 230=item $fh = $handle->fh
191 231
192This method returns the filehandle of the L<AnyEvent::Handle> object. 232This method returns the file handle of the L<AnyEvent::Handle> object.
193 233
194=cut 234=cut
195 235
196sub fh { $_[0]->{fh} } 236sub fh { $_[0]->{fh} }
197 237
… …
225for reading. 265for reading.
226 266
227The write queue is very simple: you can add data to its end, and 267The write queue is very simple: you can add data to its end, and
228AnyEvent::Handle will automatically try to get rid of it for you. 268AnyEvent::Handle will automatically try to get rid of it for you.
229 269
230When data could be writtena nd the write buffer is shorter then the low 270When data could be written and the write buffer is shorter then the low
231water mark, the C<on_drain> callback will be invoked. 271water mark, the C<on_drain> callback will be invoked.
232 272
233=over 4 273=over 4
234 274
235=item $handle->on_drain ($cb) 275=item $handle->on_drain ($cb)
… …
257=cut 297=cut
258 298
259sub _drain_wbuf { 299sub _drain_wbuf {
260 my ($self) = @_; 300 my ($self) = @_;
261 301
262 unless ($self->{ww}) { 302 if (!$self->{ww} && length $self->{wbuf}) {
263 Scalar::Util::weaken $self; 303 Scalar::Util::weaken $self;
264 my $cb = sub { 304 my $cb = sub {
265 my $len = syswrite $self->{fh}, $self->{wbuf}; 305 my $len = syswrite $self->{fh}, $self->{wbuf};
266 306
267 if ($len > 0) { 307 if ($len >= 0) {
268 substr $self->{wbuf}, 0, $len, ""; 308 substr $self->{wbuf}, 0, $len, "";
269 309
270 $self->{on_drain}($self) 310 $self->{on_drain}($self)
271 if $self->{low_water_mark} >= length $self->{wbuf} 311 if $self->{low_water_mark} >= length $self->{wbuf}
272 && $self->{on_drain}; 312 && $self->{on_drain};
… …
284} 324}
285 325
286sub push_write { 326sub push_write {
287 my $self = shift; 327 my $self = shift;
288 328
329 if (@_ > 1) {
330 my $type = shift;
331
332 @_ = ($WH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::push_write")
333 ->($self, @_);
334 }
335
289 if ($self->{filter_w}) { 336 if ($self->{filter_w}) {
290 $self->{filter_w}->(\$_[0]); 337 $self->{filter_w}->($self, \$_[0]);
291 } else { 338 } else {
292 $self->{wbuf} .= $_[0]; 339 $self->{wbuf} .= $_[0];
293 $self->_drain_wbuf; 340 $self->_drain_wbuf;
294 } 341 }
295} 342}
343
344=item $handle->push_write (type => @args)
345
346=item $handle->unshift_write (type => @args)
347
348Instead of formatting your data yourself, you can also let this module do
349the job by specifying a type and type-specific arguments.
350
351Predefined types are:
352
353=over 4
354
355=item netstring => $string
356
357Formats the given value as netstring
358(http://cr.yp.to/proto/netstrings.txt, this is not a recommendation to use them).
359
360=cut
361
362register_write_type netstring => sub {
363 my ($self, $string) = @_;
364
365 sprintf "%d:%s,", (length $string), $string
366};
367
368=back
369
370=cut
371
372
296 373
297############################################################################# 374#############################################################################
298 375
299=back 376=back
300 377
… …
388 local $self->{in_drain} = 1; 465 local $self->{in_drain} = 1;
389 466
390 while (my $len = length $self->{rbuf}) { 467 while (my $len = length $self->{rbuf}) {
391 no strict 'refs'; 468 no strict 'refs';
392 if (my $cb = shift @{ $self->{queue} }) { 469 if (my $cb = shift @{ $self->{queue} }) {
393 if (!$cb->($self)) { 470 unless ($cb->($self)) {
394 if ($self->{eof}) { 471 if ($self->{eof}) {
395 # no progress can be made (not enough data and no data forthcoming) 472 # no progress can be made (not enough data and no data forthcoming)
396 $! = &Errno::EPIPE; return $self->error; 473 $! = &Errno::EPIPE; return $self->error;
397 } 474 }
398 475
… …
463Append the given callback to the end of the queue (C<push_read>) or 540Append the given callback to the end of the queue (C<push_read>) or
464prepend it (C<unshift_read>). 541prepend it (C<unshift_read>).
465 542
466The callback is called each time some additional read data arrives. 543The callback is called each time some additional read data arrives.
467 544
468It must check wether enough data is in the read buffer already. 545It must check whether enough data is in the read buffer already.
469 546
470If not enough data is available, it must return the empty list or a false 547If not enough data is available, it must return the empty list or a false
471value, in which case it will be called repeatedly until enough data is 548value, in which case it will be called repeatedly until enough data is
472available (or an error condition is detected). 549available (or an error condition is detected).
473 550
… …
476true, it will be removed from the queue. 553true, it will be removed from the queue.
477 554
478=cut 555=cut
479 556
480sub push_read { 557sub push_read {
481 my ($self, $cb) = @_; 558 my $self = shift;
559 my $cb = pop;
560
561 if (@_) {
562 my $type = shift;
563
564 $cb = ($RH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::push_read")
565 ->($self, $cb, @_);
566 }
482 567
483 push @{ $self->{queue} }, $cb; 568 push @{ $self->{queue} }, $cb;
484 $self->_drain_rbuf; 569 $self->_drain_rbuf;
485} 570}
486 571
487sub unshift_read { 572sub unshift_read {
488 my ($self, $cb) = @_; 573 my $self = shift;
574 my $cb = pop;
489 575
576 if (@_) {
577 my $type = shift;
578
579 $cb = ($RH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::unshift_read")
580 ->($self, $cb, @_);
581 }
582
583
490 push @{ $self->{queue} }, $cb; 584 unshift @{ $self->{queue} }, $cb;
491 $self->_drain_rbuf; 585 $self->_drain_rbuf;
492} 586}
493 587
494=item $handle->push_read_chunk ($len, $cb->($self, $data)) 588=item $handle->push_read (type => @args, $cb)
495 589
496=item $handle->unshift_read_chunk ($len, $cb->($self, $data)) 590=item $handle->unshift_read (type => @args, $cb)
497 591
498Append the given callback to the end of the queue (C<push_read_chunk>) or 592Instead of providing a callback that parses the data itself you can chose
499prepend it (C<unshift_read_chunk>). 593between a number of predefined parsing formats, for chunks of data, lines
594etc.
500 595
501The callback will be called only once C<$len> bytes have been read, and 596The types currently supported are:
502these C<$len> bytes will be passed to the callback.
503 597
504=cut 598=over 4
505 599
506sub _read_chunk($$) { 600=item chunk => $octets, $cb->($self, $data)
601
602Invoke the callback only once C<$octets> bytes have been read. Pass the
603data read to the callback. The callback will never be called with less
604data.
605
606Example: read 2 bytes.
607
608 $handle->push_read (chunk => 2, sub {
609 warn "yay ", unpack "H*", $_[1];
610 });
611
612=cut
613
614register_read_type chunk => sub {
507 my ($self, $len, $cb) = @_; 615 my ($self, $cb, $len) = @_;
508 616
509 sub { 617 sub {
510 $len <= length $_[0]{rbuf} or return; 618 $len <= length $_[0]{rbuf} or return;
511 $cb->($_[0], substr $_[0]{rbuf}, 0, $len, ""); 619 $cb->($_[0], substr $_[0]{rbuf}, 0, $len, "");
512 1 620 1
513 } 621 }
514} 622};
515 623
624# compatibility with older API
516sub push_read_chunk { 625sub push_read_chunk {
517 $_[0]->push_read (&_read_chunk); 626 $_[0]->push_read (chunk => $_[1], $_[2]);
518} 627}
519
520 628
521sub unshift_read_chunk { 629sub unshift_read_chunk {
522 $_[0]->unshift_read (&_read_chunk); 630 $_[0]->unshift_read (chunk => $_[1], $_[2]);
523} 631}
524 632
525=item $handle->push_read_line ([$eol, ]$cb->($self, $line, $eol)) 633=item line => [$eol, ]$cb->($self, $line, $eol)
526
527=item $handle->unshift_read_line ([$eol, ]$cb->($self, $line, $eol))
528
529Append the given callback to the end of the queue (C<push_read_line>) or
530prepend it (C<unshift_read_line>).
531 634
532The callback will be called only once a full line (including the end of 635The callback will be called only once a full line (including the end of
533line marker, C<$eol>) has been read. This line (excluding the end of line 636line marker, C<$eol>) has been read. This line (excluding the end of line
534marker) will be passed to the callback as second argument (C<$line>), and 637marker) will be passed to the callback as second argument (C<$line>), and
535the end of line marker as the third argument (C<$eol>). 638the end of line marker as the third argument (C<$eol>).
… …
546Partial lines at the end of the stream will never be returned, as they are 649Partial lines at the end of the stream will never be returned, as they are
547not marked by the end of line marker. 650not marked by the end of line marker.
548 651
549=cut 652=cut
550 653
551sub _read_line($$) { 654register_read_type line => sub {
552 my $self = shift; 655 my ($self, $cb, $eol) = @_;
553 my $cb = pop;
554 my $eol = @_ ? shift : qr|(\015?\012)|;
555 my $pos;
556 656
657 $eol = qr|(\015?\012)| if @_ < 3;
557 $eol = quotemeta $eol unless ref $eol; 658 $eol = quotemeta $eol unless ref $eol;
558 $eol = qr|^(.*?)($eol)|s; 659 $eol = qr|^(.*?)($eol)|s;
559 660
560 sub { 661 sub {
561 $_[0]{rbuf} =~ s/$eol// or return; 662 $_[0]{rbuf} =~ s/$eol// or return;
562 663
563 $cb->($_[0], $1, $2); 664 $cb->($_[0], $1, $2);
564 1 665 1
565 } 666 }
566} 667};
567 668
669# compatibility with older API
568sub push_read_line { 670sub push_read_line {
569 $_[0]->push_read (&_read_line); 671 my $self = shift;
672 $self->push_read (line => @_);
570} 673}
571 674
572sub unshift_read_line { 675sub unshift_read_line {
573 $_[0]->unshift_read (&_read_line); 676 my $self = shift;
677 $self->unshift_read (line => @_);
574} 678}
679
680=item netstring => $cb->($string)
681
682A netstring (http://cr.yp.to/proto/netstrings.txt, this is not an endorsement).
683
684Throws an error with C<$!> set to EBADMSG on format violations.
685
686=cut
687
688register_read_type netstring => sub {
689 my ($self, $cb) = @_;
690
691 sub {
692 unless ($_[0]{rbuf} =~ s/^(0|[1-9][0-9]*)://) {
693 if ($_[0]{rbuf} =~ /[^0-9]/) {
694 $! = &Errno::EBADMSG;
695 $self->error;
696 }
697 return;
698 }
699
700 my $len = $1;
701
702 $self->unshift_read (chunk => $len, sub {
703 my $string = $_[1];
704 $_[0]->unshift_read (chunk => 1, sub {
705 if ($_[1] eq ",") {
706 $cb->($_[0], $string);
707 } else {
708 $! = &Errno::EBADMSG;
709 $self->error;
710 }
711 });
712 });
713
714 1
715 }
716};
717
718=back
575 719
576=item $handle->stop_read 720=item $handle->stop_read
577 721
578=item $handle->start_read 722=item $handle->start_read
579 723
580In rare cases you actually do not want to read anything form the 724In rare cases you actually do not want to read anything from the
581socket. In this case you can call C<stop_read>. Neither C<on_read> no 725socket. In this case you can call C<stop_read>. Neither C<on_read> no
582any queued callbacks will be executed then. To start readign again, call 726any queued callbacks will be executed then. To start reading again, call
583C<start_read>. 727C<start_read>.
584 728
585=cut 729=cut
586 730
587sub stop_read { 731sub stop_read {
… …
600 my $rbuf = $self->{filter_r} ? \my $buf : \$self->{rbuf}; 744 my $rbuf = $self->{filter_r} ? \my $buf : \$self->{rbuf};
601 my $len = sysread $self->{fh}, $$rbuf, $self->{read_size} || 8192, length $$rbuf; 745 my $len = sysread $self->{fh}, $$rbuf, $self->{read_size} || 8192, length $$rbuf;
602 746
603 if ($len > 0) { 747 if ($len > 0) {
604 $self->{filter_r} 748 $self->{filter_r}
605 ? $self->{filter_r}->($rbuf) 749 ? $self->{filter_r}->($self, $rbuf)
606 : $self->_drain_rbuf; 750 : $self->_drain_rbuf;
607 751
608 } elsif (defined $len) { 752 } elsif (defined $len) {
609 delete $self->{rw}; 753 delete $self->{rw};
610 $self->{eof} = 1; 754 $self->{eof} = 1;
… …
615 } 759 }
616 }); 760 });
617 } 761 }
618} 762}
619 763
764sub _dotls {
765 my ($self) = @_;
766
767 if (length $self->{tls_wbuf}) {
768 while ((my $len = Net::SSLeay::write ($self->{tls}, $self->{tls_wbuf})) > 0) {
769 substr $self->{tls_wbuf}, 0, $len, "";
770 }
771 }
772
773 if (defined (my $buf = Net::SSLeay::BIO_read ($self->{tls_wbio}))) {
774 $self->{wbuf} .= $buf;
775 $self->_drain_wbuf;
776 }
777
778 while (defined (my $buf = Net::SSLeay::read ($self->{tls}))) {
779 $self->{rbuf} .= $buf;
780 $self->_drain_rbuf;
781 }
782
783 my $err = Net::SSLeay::get_error ($self->{tls}, -1);
784
785 if ($err!= Net::SSLeay::ERROR_WANT_READ ()) {
786 if ($err == Net::SSLeay::ERROR_SYSCALL ()) {
787 $self->error;
788 } elsif ($err == Net::SSLeay::ERROR_SSL ()) {
789 $! = &Errno::EIO;
790 $self->error;
791 }
792
793 # all others are fine for our purposes
794 }
795}
796
797=item $handle->starttls ($tls[, $tls_ctx])
798
799Instead of starting TLS negotiation immediately when the AnyEvent::Handle
800object is created, you can also do that at a later time by calling
801C<starttls>.
802
803The first argument is the same as the C<tls> constructor argument (either
804C<"connect">, C<"accept"> or an existing Net::SSLeay object).
805
806The second argument is the optional C<Net::SSLeay::CTX> object that is
807used when AnyEvent::Handle has to create its own TLS connection object.
808
809=cut
810
811# TODO: maybe document...
812sub starttls {
813 my ($self, $ssl, $ctx) = @_;
814
815 $self->stoptls;
816
817 if ($ssl eq "accept") {
818 $ssl = Net::SSLeay::new ($ctx || TLS_CTX ());
819 Net::SSLeay::set_accept_state ($ssl);
820 } elsif ($ssl eq "connect") {
821 $ssl = Net::SSLeay::new ($ctx || TLS_CTX ());
822 Net::SSLeay::set_connect_state ($ssl);
823 }
824
825 $self->{tls} = $ssl;
826
827 # basically, this is deep magic (because SSL_read should have the same issues)
828 # but the openssl maintainers basically said: "trust us, it just works".
829 # (unfortunately, we have to hardcode constants because the abysmally misdesigned
830 # and mismaintained ssleay-module doesn't even offer them).
831 # http://www.mail-archive.com/openssl-dev@openssl.org/msg22420.html
832 Net::SSLeay::CTX_set_mode ($self->{tls},
833 (eval { Net::SSLeay::MODE_ENABLE_PARTIAL_WRITE () } || 1)
834 | (eval { Net::SSLeay::MODE_ACCEPT_MOVING_WRITE_BUFFER () } || 2));
835
836 $self->{tls_rbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ());
837 $self->{tls_wbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ());
838
839 Net::SSLeay::set_bio ($ssl, $self->{tls_rbio}, $self->{tls_wbio});
840
841 $self->{filter_w} = sub {
842 $_[0]{tls_wbuf} .= ${$_[1]};
843 &_dotls;
844 };
845 $self->{filter_r} = sub {
846 Net::SSLeay::BIO_write ($_[0]{tls_rbio}, ${$_[1]});
847 &_dotls;
848 };
849}
850
851=item $handle->stoptls
852
853Destroys the SSL connection, if any. Partial read or write data will be
854lost.
855
856=cut
857
858sub stoptls {
859 my ($self) = @_;
860
861 Net::SSLeay::free (delete $self->{tls}) if $self->{tls};
862 delete $self->{tls_rbio};
863 delete $self->{tls_wbio};
864 delete $self->{tls_wbuf};
865 delete $self->{filter_r};
866 delete $self->{filter_w};
867}
868
869sub DESTROY {
870 my $self = shift;
871
872 $self->stoptls;
873}
874
875=item AnyEvent::Handle::TLS_CTX
876
877This function creates and returns the Net::SSLeay::CTX object used by
878default for TLS mode.
879
880The context is created like this:
881
882 Net::SSLeay::load_error_strings;
883 Net::SSLeay::SSLeay_add_ssl_algorithms;
884 Net::SSLeay::randomize;
885
886 my $CTX = Net::SSLeay::CTX_new;
887
888 Net::SSLeay::CTX_set_options $CTX, Net::SSLeay::OP_ALL
889
890=cut
891
892our $TLS_CTX;
893
894sub TLS_CTX() {
895 $TLS_CTX || do {
896 require Net::SSLeay;
897
898 Net::SSLeay::load_error_strings ();
899 Net::SSLeay::SSLeay_add_ssl_algorithms ();
900 Net::SSLeay::randomize ();
901
902 $TLS_CTX = Net::SSLeay::CTX_new ();
903
904 Net::SSLeay::CTX_set_options ($TLS_CTX, Net::SSLeay::OP_ALL ());
905
906 $TLS_CTX
907 }
908}
909
620=back 910=back
621 911
622=head1 AUTHOR 912=head1 AUTHOR
623 913
624Robin Redeker C<< <elmex at ta-sa.org> >>, Marc Lehmann <schmorp@schmorp.de>. 914Robin Redeker C<< <elmex at ta-sa.org> >>, Marc Lehmann <schmorp@schmorp.de>.

Diff Legend

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