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.88 by root, Thu Aug 21 23:48:35 2008 UTC vs.
Revision 1.97 by root, Thu Oct 2 11:07:59 2008 UTC

… …
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 = 4.233; 19our $VERSION = 4.3;
20 20
21=head1 SYNOPSIS 21=head1 SYNOPSIS
22 22
23 use AnyEvent; 23 use AnyEvent;
24 use AnyEvent::Handle; 24 use AnyEvent::Handle;
… …
59treatment of characters applies to this module as well. 59treatment of characters applies to this module as well.
60 60
61All callbacks will be invoked with the handle object as their first 61All callbacks will be invoked with the handle object as their first
62argument. 62argument.
63 63
64=head2 SIGPIPE is not handled by this module
65
66SIGPIPE is not handled by this module, so one of the practical
67requirements of using it is to ignore SIGPIPE (C<$SIG{PIPE} =
68'IGNORE'>). At least, this is highly recommend in a networked program: If
69you use AnyEvent::Handle in a filter program (like sort), exiting on
70SIGPIPE is probably the right thing to do.
71
64=head1 METHODS 72=head1 METHODS
65 73
66=over 4 74=over 4
67 75
68=item B<new (%args)> 76=item B<new (%args)>
… …
232write data and will install a watcher that will write this data to the 240write data and will install a watcher that will write this data to the
233socket. No errors will be reported (this mostly matches how the operating 241socket. No errors will be reported (this mostly matches how the operating
234system treats outstanding data at socket close time). 242system treats outstanding data at socket close time).
235 243
236This will not work for partial TLS data that could not be encoded 244This will not work for partial TLS data that could not be encoded
237yet. This data will be lost. 245yet. This data will be lost. Calling the C<stoptls> method in time might
246help.
238 247
239=item tls => "accept" | "connect" | Net::SSLeay::SSL object 248=item tls => "accept" | "connect" | Net::SSLeay::SSL object
240 249
241When this parameter is given, it enables TLS (SSL) mode, that means 250When this parameter is given, it enables TLS (SSL) mode, that means
242AnyEvent will start a TLS handshake as soon as the conenction has been 251AnyEvent will start a TLS handshake as soon as the conenction has been
… …
273texts. 282texts.
274 283
275Note that you are responsible to depend on the JSON module if you want to 284Note that you are responsible to depend on the JSON module if you want to
276use this functionality, as AnyEvent does not have a dependency itself. 285use this functionality, as AnyEvent does not have a dependency itself.
277 286
278=item filter_r => $cb
279
280=item filter_w => $cb
281
282These exist, but are undocumented at this time. (They are used internally
283by the TLS code).
284
285=back 287=back
286 288
287=cut 289=cut
288 290
289sub new { 291sub new {
… …
293 295
294 $self->{fh} or Carp::croak "mandatory argument fh is missing"; 296 $self->{fh} or Carp::croak "mandatory argument fh is missing";
295 297
296 AnyEvent::Util::fh_nonblocking $self->{fh}, 1; 298 AnyEvent::Util::fh_nonblocking $self->{fh}, 1;
297 299
298 if ($self->{tls}) {
299 require Net::SSLeay;
300 $self->starttls (delete $self->{tls}, delete $self->{tls_ctx}); 300 $self->starttls (delete $self->{tls}, delete $self->{tls_ctx})
301 } 301 if $self->{tls};
302 302
303 $self->{_activity} = AnyEvent->now; 303 $self->{_activity} = AnyEvent->now;
304 $self->_timeout; 304 $self->_timeout;
305 305
306 $self->on_drain (delete $self->{on_drain}) if exists $self->{on_drain}; 306 $self->on_drain (delete $self->{on_drain}) if exists $self->{on_drain};
… …
318 delete $self->{_tw}; 318 delete $self->{_tw};
319 delete $self->{_rw}; 319 delete $self->{_rw};
320 delete $self->{_ww}; 320 delete $self->{_ww};
321 delete $self->{fh}; 321 delete $self->{fh};
322 322
323 $self->stoptls; 323 &_freetls;
324 324
325 delete $self->{on_read}; 325 delete $self->{on_read};
326 delete $self->{_queue}; 326 delete $self->{_queue};
327} 327}
328 328
… …
487 my ($self, $cb) = @_; 487 my ($self, $cb) = @_;
488 488
489 $self->{on_drain} = $cb; 489 $self->{on_drain} = $cb;
490 490
491 $cb->($self) 491 $cb->($self)
492 if $cb && $self->{low_water_mark} >= length $self->{wbuf}; 492 if $cb && $self->{low_water_mark} >= (length $self->{wbuf}) + (length $self->{_tls_wbuf});
493} 493}
494 494
495=item $handle->push_write ($data) 495=item $handle->push_write ($data)
496 496
497Queues the given scalar to be written. You can push as much data as you 497Queues the given scalar to be written. You can push as much data as you
… …
514 substr $self->{wbuf}, 0, $len, ""; 514 substr $self->{wbuf}, 0, $len, "";
515 515
516 $self->{_activity} = AnyEvent->now; 516 $self->{_activity} = AnyEvent->now;
517 517
518 $self->{on_drain}($self) 518 $self->{on_drain}($self)
519 if $self->{low_water_mark} >= length $self->{wbuf} 519 if $self->{low_water_mark} >= (length $self->{wbuf}) + (length $self->{_tls_wbuf})
520 && $self->{on_drain}; 520 && $self->{on_drain};
521 521
522 delete $self->{_ww} unless length $self->{wbuf}; 522 delete $self->{_ww} unless length $self->{wbuf};
523 } elsif ($! != EAGAIN && $! != EINTR && $! != WSAEWOULDBLOCK) { 523 } elsif ($! != EAGAIN && $! != EINTR && $! != WSAEWOULDBLOCK) {
524 $self->_error ($!, 1); 524 $self->_error ($!, 1);
… …
548 548
549 @_ = ($WH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::push_write") 549 @_ = ($WH{$type} or Carp::croak "unsupported type passed to AnyEvent::Handle::push_write")
550 ->($self, @_); 550 ->($self, @_);
551 } 551 }
552 552
553 if ($self->{filter_w}) { 553 if ($self->{tls}) {
554 $self->{filter_w}($self, \$_[0]); 554 $self->{_tls_wbuf} .= $_[0];
555
556 &_dotls ($self);
555 } else { 557 } else {
556 $self->{wbuf} .= $_[0]; 558 $self->{wbuf} .= $_[0];
557 $self->_drain_wbuf; 559 $self->_drain_wbuf;
558 } 560 }
559} 561}
… …
576=cut 578=cut
577 579
578register_write_type netstring => sub { 580register_write_type netstring => sub {
579 my ($self, $string) = @_; 581 my ($self, $string) = @_;
580 582
581 sprintf "%d:%s,", (length $string), $string 583 (length $string) . ":$string,"
582}; 584};
583 585
584=item packstring => $format, $data 586=item packstring => $format, $data
585 587
586An octet string prefixed with an encoded length. The encoding C<$format> 588An octet string prefixed with an encoded length. The encoding C<$format>
… …
795 797
796 last; # more data might arrive 798 last; # more data might arrive
797 } 799 }
798 } else { 800 } else {
799 # read side becomes idle 801 # read side becomes idle
800 delete $self->{_rw}; 802 delete $self->{_rw} unless $self->{tls};
801 last; 803 last;
802 } 804 }
803 } 805 }
804 806
805 if ($self->{_eof}) { 807 if ($self->{_eof}) {
… …
1100An octet string prefixed with an encoded length. The encoding C<$format> 1102An octet string prefixed with an encoded length. The encoding C<$format>
1101uses the same format as a Perl C<pack> format, but must specify a single 1103uses the same format as a Perl C<pack> format, but must specify a single
1102integer only (only one of C<cCsSlLqQiInNvVjJw> is allowed, plus an 1104integer only (only one of C<cCsSlLqQiInNvVjJw> is allowed, plus an
1103optional C<!>, C<< < >> or C<< > >> modifier). 1105optional C<!>, C<< < >> or C<< > >> modifier).
1104 1106
1105DNS over TCP uses a prefix of C<n>, EPP uses a prefix of C<N>. 1107For example, DNS over TCP uses a prefix of C<n> (2 octet network order),
1108EPP uses a prefix of C<N> (4 octtes).
1106 1109
1107Example: read a block of data prefixed by its length in BER-encoded 1110Example: read a block of data prefixed by its length in BER-encoded
1108format (very efficient). 1111format (very efficient).
1109 1112
1110 $handle->push_read (packstring => "w", sub { 1113 $handle->push_read (packstring => "w", sub {
… …
1263Note that AnyEvent::Handle will automatically C<start_read> for you when 1266Note that AnyEvent::Handle will automatically C<start_read> for you when
1264you change the C<on_read> callback or push/unshift a read callback, and it 1267you change the C<on_read> callback or push/unshift a read callback, and it
1265will automatically C<stop_read> for you when neither C<on_read> is set nor 1268will automatically C<stop_read> for you when neither C<on_read> is set nor
1266there are any read requests in the queue. 1269there are any read requests in the queue.
1267 1270
1271These methods will have no effect when in TLS mode (as TLS doesn't support
1272half-duplex connections).
1273
1268=cut 1274=cut
1269 1275
1270sub stop_read { 1276sub stop_read {
1271 my ($self) = @_; 1277 my ($self) = @_;
1272 1278
1273 delete $self->{_rw}; 1279 delete $self->{_rw} unless $self->{tls};
1274} 1280}
1275 1281
1276sub start_read { 1282sub start_read {
1277 my ($self) = @_; 1283 my ($self) = @_;
1278 1284
1279 unless ($self->{_rw} || $self->{_eof}) { 1285 unless ($self->{_rw} || $self->{_eof}) {
1280 Scalar::Util::weaken $self; 1286 Scalar::Util::weaken $self;
1281 1287
1282 $self->{_rw} = AnyEvent->io (fh => $self->{fh}, poll => "r", cb => sub { 1288 $self->{_rw} = AnyEvent->io (fh => $self->{fh}, poll => "r", cb => sub {
1283 my $rbuf = $self->{filter_r} ? \my $buf : \$self->{rbuf}; 1289 my $rbuf = \($self->{tls} ? my $buf : $self->{rbuf});
1284 my $len = sysread $self->{fh}, $$rbuf, $self->{read_size} || 8192, length $$rbuf; 1290 my $len = sysread $self->{fh}, $$rbuf, $self->{read_size} || 8192, length $$rbuf;
1285 1291
1286 if ($len > 0) { 1292 if ($len > 0) {
1287 $self->{_activity} = AnyEvent->now; 1293 $self->{_activity} = AnyEvent->now;
1288 1294
1289 $self->{filter_r} 1295 if ($self->{tls}) {
1290 ? $self->{filter_r}($self, $rbuf) 1296 Net::SSLeay::BIO_write ($self->{_rbio}, $$rbuf);
1291 : $self->{_in_drain} || $self->_drain_rbuf; 1297
1298 &_dotls ($self);
1299 } else {
1300 $self->_drain_rbuf unless $self->{_in_drain};
1301 }
1292 1302
1293 } elsif (defined $len) { 1303 } elsif (defined $len) {
1294 delete $self->{_rw}; 1304 delete $self->{_rw};
1295 $self->{_eof} = 1; 1305 $self->{_eof} = 1;
1296 $self->_drain_rbuf unless $self->{_in_drain}; 1306 $self->_drain_rbuf unless $self->{_in_drain};
… …
1300 } 1310 }
1301 }); 1311 });
1302 } 1312 }
1303} 1313}
1304 1314
1315# poll the write BIO and send the data if applicable
1305sub _dotls { 1316sub _dotls {
1306 my ($self) = @_; 1317 my ($self) = @_;
1307 1318
1308 my $buf; 1319 my $tmp;
1309 1320
1310 if (length $self->{_tls_wbuf}) { 1321 if (length $self->{_tls_wbuf}) {
1311 while ((my $len = Net::SSLeay::write ($self->{tls}, $self->{_tls_wbuf})) > 0) { 1322 while (($tmp = Net::SSLeay::write ($self->{tls}, $self->{_tls_wbuf})) > 0) {
1312 substr $self->{_tls_wbuf}, 0, $len, ""; 1323 substr $self->{_tls_wbuf}, 0, $tmp, "";
1313 } 1324 }
1314 } 1325 }
1315 1326
1316 if (length ($buf = Net::SSLeay::BIO_read ($self->{_wbio}))) {
1317 $self->{wbuf} .= $buf;
1318 $self->_drain_wbuf;
1319 }
1320
1321 while (defined ($buf = Net::SSLeay::read ($self->{tls}))) { 1327 while (defined ($tmp = Net::SSLeay::read ($self->{tls}))) {
1322 if (length $buf) { 1328 unless (length $tmp) {
1323 $self->{rbuf} .= $buf;
1324 $self->_drain_rbuf unless $self->{_in_drain};
1325 } else {
1326 # let's treat SSL-eof as we treat normal EOF 1329 # let's treat SSL-eof as we treat normal EOF
1330 delete $self->{_rw};
1327 $self->{_eof} = 1; 1331 $self->{_eof} = 1;
1328 $self->_shutdown; 1332 &_freetls;
1329 return;
1330 } 1333 }
1331 }
1332 1334
1335 $self->{rbuf} .= $tmp;
1336 $self->_drain_rbuf unless $self->{_in_drain};
1337 $self->{tls} or return; # tls session might have gone away in callback
1338 }
1339
1333 my $err = Net::SSLeay::get_error ($self->{tls}, -1); 1340 $tmp = Net::SSLeay::get_error ($self->{tls}, -1);
1334 1341
1335 if ($err!= Net::SSLeay::ERROR_WANT_READ ()) { 1342 if ($tmp != Net::SSLeay::ERROR_WANT_READ ()) {
1336 if ($err == Net::SSLeay::ERROR_SYSCALL ()) { 1343 if ($tmp == Net::SSLeay::ERROR_SYSCALL ()) {
1337 return $self->_error ($!, 1); 1344 return $self->_error ($!, 1);
1338 } elsif ($err == Net::SSLeay::ERROR_SSL ()) { 1345 } elsif ($tmp == Net::SSLeay::ERROR_SSL ()) {
1339 return $self->_error (&Errno::EIO, 1); 1346 return $self->_error (&Errno::EIO, 1);
1340 } 1347 }
1341 1348
1342 # all others are fine for our purposes 1349 # all other errors are fine for our purposes
1350 }
1351
1352 while (length ($tmp = Net::SSLeay::BIO_read ($self->{_wbio}))) {
1353 $self->{wbuf} .= $tmp;
1354 $self->_drain_wbuf;
1343 } 1355 }
1344} 1356}
1345 1357
1346=item $handle->starttls ($tls[, $tls_ctx]) 1358=item $handle->starttls ($tls[, $tls_ctx])
1347 1359
… …
1357 1369
1358The TLS connection object will end up in C<< $handle->{tls} >> after this 1370The TLS connection object will end up in C<< $handle->{tls} >> after this
1359call and can be used or changed to your liking. Note that the handshake 1371call and can be used or changed to your liking. Note that the handshake
1360might have already started when this function returns. 1372might have already started when this function returns.
1361 1373
1374If it an error to start a TLS handshake more than once per
1375AnyEvent::Handle object (this is due to bugs in OpenSSL).
1376
1362=cut 1377=cut
1363 1378
1364sub starttls { 1379sub starttls {
1365 my ($self, $ssl, $ctx) = @_; 1380 my ($self, $ssl, $ctx) = @_;
1366 1381
1367 $self->stoptls; 1382 require Net::SSLeay;
1368 1383
1384 Carp::croak "it is an error to call starttls more than once on an Anyevent::Handle object"
1385 if $self->{tls};
1386
1369 if ($ssl eq "accept") { 1387 if ($ssl eq "accept") {
1370 $ssl = Net::SSLeay::new ($ctx || TLS_CTX ()); 1388 $ssl = Net::SSLeay::new ($ctx || TLS_CTX ());
1371 Net::SSLeay::set_accept_state ($ssl); 1389 Net::SSLeay::set_accept_state ($ssl);
1372 } elsif ($ssl eq "connect") { 1390 } elsif ($ssl eq "connect") {
1373 $ssl = Net::SSLeay::new ($ctx || TLS_CTX ()); 1391 $ssl = Net::SSLeay::new ($ctx || TLS_CTX ());
… …
1382 # and mismaintained ssleay-module doesn't even offer them). 1400 # and mismaintained ssleay-module doesn't even offer them).
1383 # http://www.mail-archive.com/openssl-dev@openssl.org/msg22420.html 1401 # http://www.mail-archive.com/openssl-dev@openssl.org/msg22420.html
1384 # 1402 #
1385 # in short: this is a mess. 1403 # in short: this is a mess.
1386 # 1404 #
1387 # note that we do not try to kepe the length constant between writes as we are required to do. 1405 # note that we do not try to keep the length constant between writes as we are required to do.
1388 # we assume that most (but not all) of this insanity only applies to non-blocking cases, 1406 # we assume that most (but not all) of this insanity only applies to non-blocking cases,
1389 # and we drive openssl fully in blocking mode here. 1407 # and we drive openssl fully in blocking mode here. Or maybe we don't - openssl seems to
1408 # have identity issues in that area.
1390 Net::SSLeay::CTX_set_mode ($self->{tls}, 1409 Net::SSLeay::CTX_set_mode ($self->{tls},
1391 (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ENABLE_PARTIAL_WRITE () } || 1) 1410 (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ENABLE_PARTIAL_WRITE () } || 1)
1392 | (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ACCEPT_MOVING_WRITE_BUFFER () } || 2)); 1411 | (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ACCEPT_MOVING_WRITE_BUFFER () } || 2));
1393 1412
1394 $self->{_rbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ()); 1413 $self->{_rbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ());
1395 $self->{_wbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ()); 1414 $self->{_wbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ());
1396 1415
1397 Net::SSLeay::set_bio ($ssl, $self->{_rbio}, $self->{_wbio}); 1416 Net::SSLeay::set_bio ($ssl, $self->{_rbio}, $self->{_wbio});
1398 1417
1399 $self->{filter_w} = sub { 1418 &_dotls; # need to trigger the initial handshake
1400 $_[0]{_tls_wbuf} .= ${$_[1]}; 1419 $self->start_read; # make sure we actually do read
1401 &_dotls;
1402 };
1403 $self->{filter_r} = sub {
1404 Net::SSLeay::BIO_write ($_[0]{_rbio}, ${$_[1]});
1405 &_dotls;
1406 };
1407} 1420}
1408 1421
1409=item $handle->stoptls 1422=item $handle->stoptls
1410 1423
1411Destroys the SSL connection, if any. Partial read or write data will be 1424Shuts down the SSL connection - this makes a proper EOF handshake by
1412lost. 1425sending a close notify to the other side, but since OpenSSL doesn't
1426support non-blocking shut downs, it is not possible to re-use the stream
1427afterwards.
1413 1428
1414=cut 1429=cut
1415 1430
1416sub stoptls { 1431sub stoptls {
1417 my ($self) = @_; 1432 my ($self) = @_;
1418 1433
1434 if ($self->{tls}) {
1435 Net::SSLeay::shutdown ($self->{tls});
1436
1437 &_dotls;
1438
1439 # we don't give a shit. no, we do, but we can't. no...
1440 # we, we... have to use openssl :/
1441 &_freetls;
1442 }
1443}
1444
1445sub _freetls {
1446 my ($self) = @_;
1447
1448 return unless $self->{tls};
1449
1419 Net::SSLeay::free (delete $self->{tls}) if $self->{tls}; 1450 Net::SSLeay::free (delete $self->{tls});
1420 1451
1421 delete $self->{_rbio}; 1452 delete @$self{qw(_rbio _wbio _tls_wbuf)};
1422 delete $self->{_wbio};
1423 delete $self->{_tls_wbuf};
1424 delete $self->{filter_r};
1425 delete $self->{filter_w};
1426} 1453}
1427 1454
1428sub DESTROY { 1455sub DESTROY {
1429 my $self = shift; 1456 my $self = shift;
1430 1457
1431 $self->stoptls; 1458 &_freetls;
1432 1459
1433 my $linger = exists $self->{linger} ? $self->{linger} : 3600; 1460 my $linger = exists $self->{linger} ? $self->{linger} : 3600;
1434 1461
1435 if ($linger && length $self->{wbuf}) { 1462 if ($linger && length $self->{wbuf}) {
1436 my $fh = delete $self->{fh}; 1463 my $fh = delete $self->{fh};
… …
1488 } 1515 }
1489} 1516}
1490 1517
1491=back 1518=back
1492 1519
1520
1521=head1 NONFREQUENTLY ASKED QUESTIONS
1522
1523=over 4
1524
1525=item How do I read data until the other side closes the connection?
1526
1527If you just want to read your data into a perl scalar, the easiest way
1528to achieve this is by setting an C<on_read> callback that does nothing,
1529clearing the C<on_eof> callback and in the C<on_error> callback, the data
1530will be in C<$_[0]{rbuf}>:
1531
1532 $handle->on_read (sub { });
1533 $handle->on_eof (undef);
1534 $handle->on_error (sub {
1535 my $data = delete $_[0]{rbuf};
1536 undef $handle;
1537 });
1538
1539The reason to use C<on_error> is that TCP connections, due to latencies
1540and packets loss, might get closed quite violently with an error, when in
1541fact, all data has been received.
1542
1543It is usually better to use acknowledgements when transfering data,
1544to make sure the other side hasn't just died and you got the data
1545intact. This is also one reason why so many internet protocols have an
1546explicit QUIT command.
1547
1548
1549=item I don't want to destroy the handle too early - how do I wait until
1550all data has been written?
1551
1552After writing your last bits of data, set the C<on_drain> callback
1553and destroy the handle in there - with the default setting of
1554C<low_water_mark> this will be called precisely when all data has been
1555written to the socket:
1556
1557 $handle->push_write (...);
1558 $handle->on_drain (sub {
1559 warn "all data submitted to the kernel\n";
1560 undef $handle;
1561 });
1562
1563=back
1564
1565
1493=head1 SUBCLASSING AnyEvent::Handle 1566=head1 SUBCLASSING AnyEvent::Handle
1494 1567
1495In many cases, you might want to subclass AnyEvent::Handle. 1568In many cases, you might want to subclass AnyEvent::Handle.
1496 1569
1497To make this easier, a given version of AnyEvent::Handle uses these 1570To make this easier, a given version of AnyEvent::Handle uses these

Diff Legend

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