[ViewVC] Diff of: cvs/AnyEvent-Fork/Fork.pm

Comparing AnyEvent-Fork/Fork.pm (file contents):
Revision 1.18 by root, Sat Apr 6 01:33:56 2013 UTC vs.
Revision 1.23 by root, Sat Apr 6 08:29:43 2013 UTC

       while (my $socket = $listener->accept) {
          # do sth. with new socket
       }
    }
+   ##################################################################
+   # use AnyEvent::Fork as a faster fork+exec
+   # this runs /bin/echo hi, with stdout redirected to /tmp/log
+   # and stderr to the communications socket. it is usually faster
+   # than fork+exec, but still let's you prepare the environment.
+   open my $output, ">/tmp/log" or die "$!";
+   AnyEvent::Fork
+      ->new
+      ->eval ('
+           sub run {
+              my ($fh, $output, @cmd) = @_;
+              # perl will clear close-on-exec on STDOUT/STDERR
+              open STDOUT, ">&", $output or die;
+              open STDERR, ">&", $fh or die;
+              exec @cmd;
+           }
+        ')
+      ->send_fh ($output)
+      ->send_arg ("/bin/echo", "hi")
+      ->run ("run", my $cv = AE::cv);
+   my $stderr = $cv->recv;
 =head1 DESCRIPTION
 This module allows you to create new processes, without actually forking
 them from your current process (avoiding the problems of forking), but
 preserving most of the advantages of fork.
 use AnyEvent;
 use AnyEvent::Util ();
 use IO::FDPass;
-our $VERSION = 0.2;
+our $VERSION = 0.5;
 our $PERL; # the path to the perl interpreter, deduces with various forms of magic
 =item my $pool = new AnyEvent::Fork key => value...
    my $self = shift;
    # ideally, we would want to use "a (w/a)*" as format string, but perl
    # versions from at least 5.8.9 to 5.16.3 are all buggy and can't unpack
    # it.
-   push @{ $self->[2] }, pack "L/a*", pack "(w/a*)*", @_;
+   push @{ $self->[2] }, pack "a L/a*", $_[0], $_[1];
-   unless ($self->[3]) {
+   $self->[3] ||= AE::io $self->[1], 1, sub {
-      my $wcb = sub {
-         do {
+      do {
-            # send the next "thing" in the queue - either a reference to an fh,
+         # send the next "thing" in the queue - either a reference to an fh,
-            # or a plain string.
+         # or a plain string.
-            if (ref $self->[2][0]) {
+         if (ref $self->[2][0]) {
-               # send fh
+            # send fh
-               unless (IO::FDPass::send fileno $self->[1], fileno ${ $self->[2][0] }) {
+            unless (IO::FDPass::send fileno $self->[1], fileno ${ $self->[2][0] }) {
-                  return if $! == Errno::EAGAIN || $! == Errno::EWOULDBLOCK;
+               return if $! == Errno::EAGAIN || $! == Errno::EWOULDBLOCK;
-                  undef $self->[3];
+               undef $self->[3];
-                  die "AnyEvent::Fork: file descriptor send failure: $!";
+               die "AnyEvent::Fork: file descriptor send failure: $!";
-               }
-               shift @{ $self->[2] };
-            } else {
-               # send string
-               my $len = syswrite $self->[1], $self->[2][0];
-               unless ($len) {
-                  return if $! == Errno::EAGAIN || $! == Errno::EWOULDBLOCK;
-                  undef $self->[3];
-                  die "AnyEvent::Fork: command write failure: $!";
-               }
-               substr $self->[2][0], 0, $len, "";
-               shift @{ $self->[2] } unless length $self->[2][0];
             }
+            shift @{ $self->[2] };
+         } else {
+            # send string
+            my $len = syswrite $self->[1], $self->[2][0];
+            unless ($len) {
+               return if $! == Errno::EAGAIN || $! == Errno::EWOULDBLOCK;
+               undef $self->[3];
+               die "AnyEvent::Fork: command write failure: $!";
+            }
+            substr $self->[2][0], 0, $len, "";
+            shift @{ $self->[2] } unless length $self->[2][0];
+         }
-         } while @{ $self->[2] };
+      } while @{ $self->[2] };
-         # everything written
+      # everything written
-         undef $self->[3];
+      undef $self->[3];
-         # invoke run callback
+      # invoke run callback, if any
-         $self->[0]->($self->[1]) if $self->[0];
+      $self->[4]->($self->[1]) if $self->[4];
-      };
-      $wcb->();
-      $self->[3] ||= AE::io $self->[1], 1, $wcb
-         if @{ $self->[2] };
-   }
+   };
    () # make sure we don't leak the watcher
 }
 sub _new {
-   my ($self, $fh) = @_;
+   my ($self, $fh, $pid) = @_;
    AnyEvent::Util::fh_nonblocking $fh, 1;
    $self = bless [
-      undef, # run callback
+      $pid,
       $fh,
       [],    # write queue - strings or fd's
       undef, # AE watcher
    ], $self;
       exit 0;
    } elsif (!$pid) {
       die "AnyEvent::Fork::Early/Template: unable to fork template process: $!";
    }
-   AnyEvent::Fork->_new ($fh)
+   AnyEvent::Fork->_new ($fh, $pid)
 }
 =item my $proc = new AnyEvent::Fork
 Create a new "empty" perl interpreter process and returns its process
    # quick. also doesn't work in win32. of course. what did you expect
    #local $ENV{PERL5LIB} = join ":", grep !ref, @INC;
    my %env = %ENV;
    $env{PERL5LIB} = join +($^O eq "MSWin32" ? ";" : ":"), grep !ref, @INC;
-   Proc::FastSpawn::spawn (
+   my $pid = Proc::FastSpawn::spawn (
       $perl,
       ["perl", "-MAnyEvent::Fork::Serve", "-e", "AnyEvent::Fork::Serve::me", fileno $slave, $$],
       [map "$_=$env{$_}", keys %env],
    ) or die "unable to spawn AnyEvent::Fork server: $!";
-   $self->_new ($fh)
+   $self->_new ($fh, $pid)
+}
+=item $pid = $proc->pid
+Returns the process id of the process I<iff it is a direct child of the
+process> running AnyEvent::Fork, and C<undef> otherwise.
+Normally, only processes created via C<< AnyEvent::Fork->new_exec >> and
+L<AnyEvent::Fork::Template> are direct children, and you are responsible
+to clean up their zombies when they die.
+All other processes are not direct children, and will be cleaned up by
+AnyEvent::Fork.
+=cut
+sub pid {
+   $_[0][0]
 }
 =item $proc = $proc->eval ($perlcode, @args)
 Evaluates the given C<$perlcode> as ... perl code, while setting C<@_> to
-the strings specified by C<@args>.
+the strings specified by C<@args>, in the "main" package.
 This call is meant to do any custom initialisation that might be required
 (for example, the C<require> method uses it). It's not supposed to be used
 to completely take over the process, use C<run> for that.
 The code will usually be executed after this call returns, and there is no
 way to pass anything back to the calling process. Any evaluation errors
 will be reported to stderr and cause the process to exit.
+If you want to execute some code to take over the process (see the
+"fork+exec" example in the SYNOPSIS), you should compile a function via
+C<eval> first, and then call it via C<run>. This also gives you access to
+any arguments passed via the C<send_xxx> methods, such as file handles.
 Returns the process object for easy chaining of method calls.
 =cut
 sub eval {
    my ($self, $code, @args) = @_;
-   $self->_cmd (e => $code, @args);
+   $self->_cmd (e => pack "(w/a*)*", $code, @args);
    $self
 }
 =item $proc = $proc->require ($module, ...)
 =cut
 sub send_arg {
    my ($self, @arg) = @_;
-   $self->_cmd (a => @arg);
+   $self->_cmd (a => pack "(w/a*)*", @arg);
    $self
 }
 =item $proc->run ($func, $cb->($fh))
-Enter the function specified by the fully qualified name in C<$func> in
+Enter the function specified by the function name in C<$func> in the
-the process. The function is called with the communication socket as first
+process. The function is called with the communication socket as first
 argument, followed by all file handles and string arguments sent earlier
 via C<send_fh> and C<send_arg> methods, in the order they were called.
-If the called function returns, the process exits.
+The function name should be fully qualified, but if it isn't, it will be
+looked up in the main package.
-Preparing the process can take time - when the process is ready, the
+If the called function returns, doesn't exist, or any error occurs, the
+process exits.
+Preparing the process is done in the background - when all commands have
-callback is invoked with the local communications socket as argument.
+been sent, the callback is invoked with the local communications socket
+as argument. At this point you can start using the socket in any way you
+like.
-The process object becomes unusable on return from this function.
+The process object becomes unusable on return from this function - any
+further method calls result in undefined behaviour.
 If the communication socket isn't used, it should be closed on both sides,
 to save on kernel memory.
 The socket is non-blocking in the parent, and blocking in the newly
-created process. The close-on-exec flag is set on both. Even if not used
+created process. The close-on-exec flag is set in both.
-otherwise, the socket can be a good indicator for the existence of the
+Even if not used otherwise, the socket can be a good indicator for the
-process - if the other process exits, you get a readable event on it,
+existence of the process - if the other process exits, you get a readable
-because exiting the process closes the socket (if it didn't create any
+event on it, because exiting the process closes the socket (if it didn't
-children using fork).
+create any children using fork).
 Example: create a template for a process pool, pass a few strings, some
 file handles, then fork, pass one more string, and run some code.
    my $pool = AnyEvent::Fork
          ->send_arg ("str3")
          ->run ("Some::function", sub {
             my ($fh) = @_;
             # fh is nonblocking, but we trust that the OS can accept these
-            # extra 3 octets anyway.
+            # few octets anyway.
             syswrite $fh, "hi #$_\n";
             # $fh is being closed here, as we don't store it anywhere
          });
    }
    # Some::function might look like this - all parameters passed before fork
    # and after will be passed, in order, after the communications socket.
    sub Some::function {
       my ($fh, $str1, $str2, $fh1, $fh2, $str3) = @_;
-      print scalar <$fh>; # prints "hi 1\n" and "hi 2\n"
+      print scalar <$fh>; # prints "hi #1\n" and "hi #2\n" in any order
    }
 =cut
 sub run {
    my ($self, $func, $cb) = @_;
-   $self->[0] = $cb;
+   $self->[4] = $cb;
    $self->_cmd (r => $func);
 }
 =back
 This section lists typical problems that remain. I hope by recognising
 them, most can be avoided.
 =over 4
-=item exit runs destructors
 =item "leaked" file descriptors for exec'ed processes
 POSIX systems inherit file descriptors by default when exec'ing a new
 process. While perl itself laudably sets the close-on-exec flags on new
 file handles, most C libraries don't care, and even if all cared, it's
 The solution is to either not load these modules before use'ing
 L<AnyEvent::Fork::Early> or L<AnyEvent::Fork::Template>, or to delay
 initialising them, for example, by calling C<init Gtk2> manually.
+=item exit runs destructors
+This only applies to users of Lc<AnyEvent::Fork:Early> and
+L<AnyEvent::Fork::Template>.
+When a process created by AnyEvent::Fork exits, it might do so by calling
+exit, or simply letting perl reach the end of the program. At which point
+Perl runs all destructors.
+Not all destructors are fork-safe - for example, an object that represents
+the connection to an X display might tell the X server to free resources,
+which is inconvenient when the "real" object in the parent still needs to
+use them.
+This is obviously not a problem for L<AnyEvent::Fork::Early>, as you used
+it as the very first thing, right?
+It is a problem for L<AnyEvent::Fork::Template> though - and the solution
+is to not create objects with nontrivial destructors that might have an
+effect outside of Perl.
 =back
 =head1 PORTABILITY NOTES
 Native win32 perls are somewhat supported (AnyEvent::Fork::Early is a nop,

Diff Legend

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

Comparing AnyEvent-Fork/Fork.pm (file contents): Revision 1.18 by root, Sat Apr 6 01:33:56 2013 UTC vs. Revision 1.23 by root, Sat Apr 6 08:29:43 2013 UTC

Diff Legend

Comparing AnyEvent-Fork/Fork.pm (file contents):
Revision 1.18 by root, Sat Apr 6 01:33:56 2013 UTC vs.
Revision 1.23 by root, Sat Apr 6 08:29:43 2013 UTC