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

Comparing AnyEvent-Fork/Fork.pm (file contents):
Revision 1.39 by root, Sat Apr 6 22:39:37 2013 UTC vs.
Revision 1.42 by root, Mon Apr 8 05:44:23 2013 UTC

… …
230 open my $output, ">/tmp/log" or die "$!"; 230 open my $output, ">/tmp/log" or die "$!";
231 231
232 AnyEvent::Fork 232 AnyEvent::Fork
233 ->new 233 ->new
234 ->eval (' 234 ->eval ('
235 # compile a helper function for later use
235 sub run { 236 sub run {
236 my ($fh, $output, @cmd) = @_; 237 my ($fh, $output, @cmd) = @_;
237 238
238 # perl will clear close-on-exec on STDOUT/STDERR 239 # perl will clear close-on-exec on STDOUT/STDERR
239 open STDOUT, ">&", $output or die; 240 open STDOUT, ">&", $output or die;
… …
369use AnyEvent; 370use AnyEvent;
370use AnyEvent::Util (); 371use AnyEvent::Util ();
371 372
372use IO::FDPass; 373use IO::FDPass;
373 374
374our $VERSION = 0.5; 375our $VERSION = 0.6;
375
376our $PERL; # the path to the perl interpreter, deduces with various forms of magic
377 376
378=over 4 377=over 4
379 378
380=back 379=back
381 380
… …
384# the early fork template process 383# the early fork template process
385our $EARLY; 384our $EARLY;
386 385
387# the empty template process 386# the empty template process
388our $TEMPLATE; 387our $TEMPLATE;
388
389sub QUEUE() { 0 }
390sub FH() { 1 }
391sub WW() { 2 }
392sub PID() { 3 }
393sub CB() { 4 }
394
395sub _new {
396 my ($self, $fh, $pid) = @_;
397
398 AnyEvent::Util::fh_nonblocking $fh, 1;
399
400 $self = bless [
401 [], # write queue - strings or fd's
402 $fh,
403 undef, # AE watcher
404 $pid,
405 ], $self;
406
407 $self
408}
389 409
390sub _cmd { 410sub _cmd {
391 my $self = shift; 411 my $self = shift;
392 412
393 # ideally, we would want to use "a (w/a)*" as format string, but perl 413 # ideally, we would want to use "a (w/a)*" as format string, but perl
394 # versions from at least 5.8.9 to 5.16.3 are all buggy and can't unpack 414 # versions from at least 5.8.9 to 5.16.3 are all buggy and can't unpack
395 # it. 415 # it.
396 push @{ $self->[2] }, pack "a L/a*", $_[0], $_[1]; 416 push @{ $self->[QUEUE] }, pack "a L/a*", $_[0], $_[1];
397 417
398 $self->[3] ||= AE::io $self->[1], 1, sub { 418 $self->[WW] ||= AE::io $self->[FH], 1, sub {
399 do { 419 do {
400 # send the next "thing" in the queue - either a reference to an fh, 420 # send the next "thing" in the queue - either a reference to an fh,
401 # or a plain string. 421 # or a plain string.
402 422
403 if (ref $self->[2][0]) { 423 if (ref $self->[QUEUE][0]) {
404 # send fh 424 # send fh
405 unless (IO::FDPass::send fileno $self->[1], fileno ${ $self->[2][0] }) { 425 unless (IO::FDPass::send fileno $self->[FH], fileno ${ $self->[QUEUE][0] }) {
406 return if $! == Errno::EAGAIN || $! == Errno::EWOULDBLOCK; 426 return if $! == Errno::EAGAIN || $! == Errno::EWOULDBLOCK;
407 undef $self->[3]; 427 undef $self->[WW];
408 die "AnyEvent::Fork: file descriptor send failure: $!"; 428 die "AnyEvent::Fork: file descriptor send failure: $!";
409 } 429 }
410 430
411 shift @{ $self->[2] }; 431 shift @{ $self->[QUEUE] };
412 432
413 } else { 433 } else {
414 # send string 434 # send string
415 my $len = syswrite $self->[1], $self->[2][0]; 435 my $len = syswrite $self->[FH], $self->[QUEUE][0];
416 436
417 unless ($len) { 437 unless ($len) {
418 return if $! == Errno::EAGAIN || $! == Errno::EWOULDBLOCK; 438 return if $! == Errno::EAGAIN || $! == Errno::EWOULDBLOCK;
419 undef $self->[3]; 439 undef $self->[3];
420 die "AnyEvent::Fork: command write failure: $!"; 440 die "AnyEvent::Fork: command write failure: $!";
421 } 441 }
422 442
423 substr $self->[2][0], 0, $len, ""; 443 substr $self->[QUEUE][0], 0, $len, "";
424 shift @{ $self->[2] } unless length $self->[2][0]; 444 shift @{ $self->[QUEUE] } unless length $self->[QUEUE][0];
425 } 445 }
426 } while @{ $self->[2] }; 446 } while @{ $self->[QUEUE] };
427 447
428 # everything written 448 # everything written
429 undef $self->[3]; 449 undef $self->[WW];
430 450
431 # invoke run callback, if any 451 # invoke run callback, if any
432 $self->[4]->($self->[1]) if $self->[4]; 452 $self->[CB]->($self->[FH]) if $self->[CB];
433 }; 453 };
434 454
435 () # make sure we don't leak the watcher 455 () # make sure we don't leak the watcher
436}
437
438sub _new {
439 my ($self, $fh, $pid) = @_;
440
441 AnyEvent::Util::fh_nonblocking $fh, 1;
442
443 $self = bless [
444 $pid,
445 $fh,
446 [], # write queue - strings or fd's
447 undef, # AE watcher
448 ], $self;
449
450 $self
451} 456}
452 457
453# fork template from current process, used by AnyEvent::Fork::Early/Template 458# fork template from current process, used by AnyEvent::Fork::Early/Template
454sub _new_fork { 459sub _new_fork {
455 my ($fh, $slave) = AnyEvent::Util::portable_socketpair; 460 my ($fh, $slave) = AnyEvent::Util::portable_socketpair;
… …
460 if ($pid eq 0) { 465 if ($pid eq 0) {
461 require AnyEvent::Fork::Serve; 466 require AnyEvent::Fork::Serve;
462 $AnyEvent::Fork::Serve::OWNER = $parent; 467 $AnyEvent::Fork::Serve::OWNER = $parent;
463 close $fh; 468 close $fh;
464 $0 = "$_[1] of $parent"; 469 $0 = "$_[1] of $parent";
465 $SIG{CHLD} = 'IGNORE';
466 AnyEvent::Fork::Serve::serve ($slave); 470 AnyEvent::Fork::Serve::serve ($slave);
467 exit 0; 471 exit 0;
468 } elsif (!$pid) { 472 } elsif (!$pid) {
469 die "AnyEvent::Fork::Early/Template: unable to fork template process: $!"; 473 die "AnyEvent::Fork::Early/Template: unable to fork template process: $!";
470 } 474 }
… …
589AnyEvent::Fork itself. 593AnyEvent::Fork itself.
590 594
591=cut 595=cut
592 596
593sub pid { 597sub pid {
594 $_[0][0] 598 $_[0][PID]
595} 599}
596 600
597=item $proc = $proc->eval ($perlcode, @args) 601=item $proc = $proc->eval ($perlcode, @args)
598 602
599Evaluates the given C<$perlcode> as ... perl code, while setting C<@_> to 603Evaluates the given C<$perlcode> as ... perl code, while setting C<@_> to
… …
666sub send_fh { 670sub send_fh {
667 my ($self, @fh) = @_; 671 my ($self, @fh) = @_;
668 672
669 for my $fh (@fh) { 673 for my $fh (@fh) {
670 $self->_cmd ("h"); 674 $self->_cmd ("h");
671 push @{ $self->[2] }, \$fh; 675 push @{ $self->[QUEUE] }, \$fh;
672 } 676 }
673 677
674 $self 678 $self
675} 679}
676 680
… …
762=cut 766=cut
763 767
764sub run { 768sub run {
765 my ($self, $func, $cb) = @_; 769 my ($self, $func, $cb) = @_;
766 770
767 $self->[4] = $cb; 771 $self->[CB] = $cb;
768 $self->_cmd (r => $func); 772 $self->_cmd (r => $func);
769} 773}
770 774
771=back 775=back
772 776

Diff Legend

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