… | |
… | |
284 | my $self = shift; |
284 | my $self = shift; |
285 | |
285 | |
286 | # ideally, we would want to use "a (w/a)*" as format string, but perl |
286 | # ideally, we would want to use "a (w/a)*" as format string, but perl |
287 | # versions from at least 5.8.9 to 5.16.3 are all buggy and can't unpack |
287 | # versions from at least 5.8.9 to 5.16.3 are all buggy and can't unpack |
288 | # it. |
288 | # it. |
289 | push @{ $self->[2] }, pack "L/a*", pack "(w/a*)*", @_; |
289 | push @{ $self->[2] }, pack "a L/a*", $_[0], $_[1]; |
290 | |
290 | |
291 | unless ($self->[3]) { |
291 | $self->[3] ||= AE::io $self->[1], 1, sub { |
292 | my $wcb = sub { |
|
|
293 | do { |
292 | do { |
294 | # send the next "thing" in the queue - either a reference to an fh, |
293 | # send the next "thing" in the queue - either a reference to an fh, |
295 | # or a plain string. |
294 | # or a plain string. |
296 | |
295 | |
297 | if (ref $self->[2][0]) { |
296 | if (ref $self->[2][0]) { |
298 | # send fh |
297 | # send fh |
299 | unless (IO::FDPass::send fileno $self->[1], fileno ${ $self->[2][0] }) { |
298 | unless (IO::FDPass::send fileno $self->[1], fileno ${ $self->[2][0] }) { |
300 | return if $! == Errno::EAGAIN || $! == Errno::EWOULDBLOCK; |
299 | return if $! == Errno::EAGAIN || $! == Errno::EWOULDBLOCK; |
301 | undef $self->[3]; |
300 | undef $self->[3]; |
302 | die "AnyEvent::Fork: file descriptor send failure: $!"; |
301 | die "AnyEvent::Fork: file descriptor send failure: $!"; |
303 | } |
|
|
304 | |
|
|
305 | shift @{ $self->[2] }; |
|
|
306 | |
|
|
307 | } else { |
|
|
308 | # send string |
|
|
309 | my $len = syswrite $self->[1], $self->[2][0]; |
|
|
310 | |
|
|
311 | unless ($len) { |
|
|
312 | return if $! == Errno::EAGAIN || $! == Errno::EWOULDBLOCK; |
|
|
313 | undef $self->[3]; |
|
|
314 | die "AnyEvent::Fork: command write failure: $!"; |
|
|
315 | } |
|
|
316 | |
|
|
317 | substr $self->[2][0], 0, $len, ""; |
|
|
318 | shift @{ $self->[2] } unless length $self->[2][0]; |
|
|
319 | } |
302 | } |
|
|
303 | |
|
|
304 | shift @{ $self->[2] }; |
|
|
305 | |
|
|
306 | } else { |
|
|
307 | # send string |
|
|
308 | my $len = syswrite $self->[1], $self->[2][0]; |
|
|
309 | |
|
|
310 | unless ($len) { |
|
|
311 | return if $! == Errno::EAGAIN || $! == Errno::EWOULDBLOCK; |
|
|
312 | undef $self->[3]; |
|
|
313 | die "AnyEvent::Fork: command write failure: $!"; |
|
|
314 | } |
|
|
315 | |
|
|
316 | substr $self->[2][0], 0, $len, ""; |
|
|
317 | shift @{ $self->[2] } unless length $self->[2][0]; |
|
|
318 | } |
320 | } while @{ $self->[2] }; |
319 | } while @{ $self->[2] }; |
321 | |
320 | |
322 | # everything written |
321 | # everything written |
323 | undef $self->[3]; |
322 | undef $self->[3]; |
|
|
323 | |
324 | # invoke run callback |
324 | # invoke run callback, if any |
325 | $self->[0]->($self->[1]) if $self->[0]; |
325 | $self->[0]->($self->[1]) if $self->[0]; |
326 | }; |
|
|
327 | |
|
|
328 | $wcb->(); |
|
|
329 | |
|
|
330 | $self->[3] ||= AE::io $self->[1], 1, $wcb |
|
|
331 | if @{ $self->[2] }; |
|
|
332 | } |
326 | }; |
333 | |
327 | |
334 | () # make sure we don't leak the watcher |
328 | () # make sure we don't leak the watcher |
335 | } |
329 | } |
336 | |
330 | |
337 | sub _new { |
331 | sub _new { |
338 | my ($self, $fh) = @_; |
332 | my ($self, $fh, $pid) = @_; |
339 | |
333 | |
340 | AnyEvent::Util::fh_nonblocking $fh, 1; |
334 | AnyEvent::Util::fh_nonblocking $fh, 1; |
341 | |
335 | |
342 | $self = bless [ |
336 | $self = bless [ |
343 | undef, # run callback |
337 | undef, # run callback |
344 | $fh, |
338 | $fh, |
345 | [], # write queue - strings or fd's |
339 | [], # write queue - strings or fd's |
346 | undef, # AE watcher |
340 | undef, # AE watcher |
|
|
341 | $pid, |
347 | ], $self; |
342 | ], $self; |
348 | |
343 | |
349 | $self |
344 | $self |
350 | } |
345 | } |
351 | |
346 | |
… | |
… | |
366 | exit 0; |
361 | exit 0; |
367 | } elsif (!$pid) { |
362 | } elsif (!$pid) { |
368 | die "AnyEvent::Fork::Early/Template: unable to fork template process: $!"; |
363 | die "AnyEvent::Fork::Early/Template: unable to fork template process: $!"; |
369 | } |
364 | } |
370 | |
365 | |
371 | AnyEvent::Fork->_new ($fh) |
366 | AnyEvent::Fork->_new ($fh, $pid) |
372 | } |
367 | } |
373 | |
368 | |
374 | =item my $proc = new AnyEvent::Fork |
369 | =item my $proc = new AnyEvent::Fork |
375 | |
370 | |
376 | Create a new "empty" perl interpreter process and returns its process |
371 | Create a new "empty" perl interpreter process and returns its process |
… | |
… | |
469 | # quick. also doesn't work in win32. of course. what did you expect |
464 | # quick. also doesn't work in win32. of course. what did you expect |
470 | #local $ENV{PERL5LIB} = join ":", grep !ref, @INC; |
465 | #local $ENV{PERL5LIB} = join ":", grep !ref, @INC; |
471 | my %env = %ENV; |
466 | my %env = %ENV; |
472 | $env{PERL5LIB} = join +($^O eq "MSWin32" ? ";" : ":"), grep !ref, @INC; |
467 | $env{PERL5LIB} = join +($^O eq "MSWin32" ? ";" : ":"), grep !ref, @INC; |
473 | |
468 | |
474 | Proc::FastSpawn::spawn ( |
469 | my $pid = Proc::FastSpawn::spawn ( |
475 | $perl, |
470 | $perl, |
476 | ["perl", "-MAnyEvent::Fork::Serve", "-e", "AnyEvent::Fork::Serve::me", fileno $slave, $$], |
471 | ["perl", "-MAnyEvent::Fork::Serve", "-e", "AnyEvent::Fork::Serve::me", fileno $slave, $$], |
477 | [map "$_=$env{$_}", keys %env], |
472 | [map "$_=$env{$_}", keys %env], |
478 | ) or die "unable to spawn AnyEvent::Fork server: $!"; |
473 | ) or die "unable to spawn AnyEvent::Fork server: $!"; |
479 | |
474 | |
480 | $self->_new ($fh) |
475 | $self->_new ($fh, $pid) |
481 | } |
476 | } |
482 | |
477 | |
483 | =item $proc = $proc->eval ($perlcode, @args) |
478 | =item $proc = $proc->eval ($perlcode, @args) |
484 | |
479 | |
485 | Evaluates the given C<$perlcode> as ... perl code, while setting C<@_> to |
480 | Evaluates the given C<$perlcode> as ... perl code, while setting C<@_> to |
… | |
… | |
498 | =cut |
493 | =cut |
499 | |
494 | |
500 | sub eval { |
495 | sub eval { |
501 | my ($self, $code, @args) = @_; |
496 | my ($self, $code, @args) = @_; |
502 | |
497 | |
503 | $self->_cmd (e => $code, @args); |
498 | $self->_cmd (e => pack "(w/a*)*", $code, @args); |
504 | |
499 | |
505 | $self |
500 | $self |
506 | } |
501 | } |
507 | |
502 | |
508 | =item $proc = $proc->require ($module, ...) |
503 | =item $proc = $proc->require ($module, ...) |
… | |
… | |
568 | =cut |
563 | =cut |
569 | |
564 | |
570 | sub send_arg { |
565 | sub send_arg { |
571 | my ($self, @arg) = @_; |
566 | my ($self, @arg) = @_; |
572 | |
567 | |
573 | $self->_cmd (a => @arg); |
568 | $self->_cmd (a => pack "(w/a*)*", @arg); |
574 | |
569 | |
575 | $self |
570 | $self |
576 | } |
571 | } |
577 | |
572 | |
578 | =item $proc->run ($func, $cb->($fh)) |
573 | =item $proc->run ($func, $cb->($fh)) |
… | |
… | |
690 | This section lists typical problems that remain. I hope by recognising |
685 | This section lists typical problems that remain. I hope by recognising |
691 | them, most can be avoided. |
686 | them, most can be avoided. |
692 | |
687 | |
693 | =over 4 |
688 | =over 4 |
694 | |
689 | |
695 | =item exit runs destructors |
|
|
696 | |
|
|
697 | =item "leaked" file descriptors for exec'ed processes |
690 | =item "leaked" file descriptors for exec'ed processes |
698 | |
691 | |
699 | POSIX systems inherit file descriptors by default when exec'ing a new |
692 | POSIX systems inherit file descriptors by default when exec'ing a new |
700 | process. While perl itself laudably sets the close-on-exec flags on new |
693 | process. While perl itself laudably sets the close-on-exec flags on new |
701 | file handles, most C libraries don't care, and even if all cared, it's |
694 | file handles, most C libraries don't care, and even if all cared, it's |
… | |
… | |
741 | |
734 | |
742 | The solution is to either not load these modules before use'ing |
735 | The solution is to either not load these modules before use'ing |
743 | L<AnyEvent::Fork::Early> or L<AnyEvent::Fork::Template>, or to delay |
736 | L<AnyEvent::Fork::Early> or L<AnyEvent::Fork::Template>, or to delay |
744 | initialising them, for example, by calling C<init Gtk2> manually. |
737 | initialising them, for example, by calling C<init Gtk2> manually. |
745 | |
738 | |
|
|
739 | =item exit runs destructors |
|
|
740 | |
|
|
741 | This only applies to users of Lc<AnyEvent::Fork:Early> and |
|
|
742 | L<AnyEvent::Fork::Template>. |
|
|
743 | |
|
|
744 | When a process created by AnyEvent::Fork exits, it might do so by calling |
|
|
745 | exit, or simply letting perl reach the end of the program. At which point |
|
|
746 | Perl runs all destructors. |
|
|
747 | |
|
|
748 | Not all destructors are fork-safe - for example, an object that represents |
|
|
749 | the connection to an X display might tell the X server to free resources, |
|
|
750 | which is inconvenient when the "real" object in the parent still needs to |
|
|
751 | use them. |
|
|
752 | |
|
|
753 | This is obviously not a problem for L<AnyEvent::Fork::Early>, as you used |
|
|
754 | it as the very first thing, right? |
|
|
755 | |
|
|
756 | It is a problem for L<AnyEvent::Fork::Template> though - and the solution |
|
|
757 | is to not create objects with nontrivial destructors that might have an |
|
|
758 | effect outside of Perl. |
|
|
759 | |
746 | =back |
760 | =back |
747 | |
761 | |
748 | =head1 PORTABILITY NOTES |
762 | =head1 PORTABILITY NOTES |
749 | |
763 | |
750 | Native win32 perls are somewhat supported (AnyEvent::Fork::Early is a nop, |
764 | Native win32 perls are somewhat supported (AnyEvent::Fork::Early is a nop, |