diff options
Diffstat (limited to 'mysql-test/lib/My/SafeProcess/Base.pm')
| -rw-r--r-- | mysql-test/lib/My/SafeProcess/Base.pm | 227 |
1 files changed, 227 insertions, 0 deletions
diff --git a/mysql-test/lib/My/SafeProcess/Base.pm b/mysql-test/lib/My/SafeProcess/Base.pm new file mode 100644 index 00000000..1cd01cb0 --- /dev/null +++ b/mysql-test/lib/My/SafeProcess/Base.pm @@ -0,0 +1,227 @@ +# -*- cperl -*- +# Copyright (c) 2007 MySQL AB, 2008, 2009 Sun Microsystems, Inc. +# Use is subject to license terms. +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; version 2 of the License. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1335 USA + +# This is a library file used by the Perl version of mysql-test-run, +# and is part of the translation of the Bourne shell script with the +# same name. + +use strict; + +package My::SafeProcess::Base; + +# +# Utility functions for Process management +# + +use Carp; +use IO::Pipe; + +use base qw(Exporter); +our @EXPORT= qw(create_process); + + + +# +# safe_fork +# Retry a couple of times if fork returns EAGAIN +# +sub _safe_fork { + my $retries= 100; + my $pid; + + FORK: + { + $pid= fork; + if ( not defined($pid)) { + + croak("fork failed after: $!") if (!$retries--); + + warn("fork failed sleep 1 second and redo: $!"); + sleep(1); + redo FORK; + } + } + + return $pid; +}; + + +# +# Decode exit status +# +sub exit_status { + my $self= shift; + my $raw= $self->{EXIT_STATUS}; + + croak("Can't call exit_status before process has died") + unless defined $raw; + + if ($raw & 127) + { + # Killed by signal + my $signal_num= $raw & 127; + my $dumped_core= $raw & 128; + return 1; # Return error code + } + else + { + # Normal process exit + return $raw >> 8; + }; +} + +# threads.pm may not exist everywhere, so use only on Windows. + +use if $^O eq "MSWin32", "threads"; +use if $^O eq "MSWin32", "threads::shared"; + +my $win32_spawn_lock :shared; + + +# +# Create a new process +# Return pid of the new process +# +sub create_process { + my %opts= + ( + @_ + ); + + my $path = delete($opts{'path'}) or die "path required"; + my $args = delete($opts{'args'}) or die "args required"; + my $input = delete($opts{'input'}); + my $output = delete($opts{'output'}); + my $error = delete($opts{'error'}); + + my $open_mode= $opts{append} ? ">>" : ">"; + + if ($^O eq "MSWin32"){ + + lock($win32_spawn_lock); + + #printf STDERR "stdin %d, stdout %d, stderr %d\n", + # fileno STDIN, fileno STDOUT, fileno STDERR; + + # input output redirect + my ($oldin, $oldout, $olderr); + open $oldin, '<&', \*STDIN or die "Failed to save old stdin: $!"; + open $oldout, '>&', \*STDOUT or die "Failed to save old stdout: $!"; + open $olderr, '>&', \*STDERR or die "Failed to save old stderr: $!"; + + if ( $input ) { + if ( ! open(STDIN, "<", $input) ) { + croak("can't redirect STDIN to '$input': $!"); + } + } + + if ( $output ) { + if ( ! open(STDOUT, $open_mode, $output) ) { + croak("can't redirect STDOUT to '$output': $!"); + } + } + + if ( $error ) { + if ( $output eq $error ) { + if ( ! open(STDERR, ">&STDOUT") ) { + croak("can't dup STDOUT: $!"); + } + } + elsif ( ! open(STDERR, $open_mode, $error) ) { + croak("can't redirect STDERR to '$error': $!"); + } + } + + + # Magic use of 'system(1, @args)' to spawn a process + # and get a proper Win32 pid + unshift (@$args, $path); + my $pid= system(1, @$args); + if ( $pid == 0 ){ + print $olderr "create_process failed: $^E\n"; + die "create_process failed: $^E"; + } + + # Retore IO redirects + open STDERR, '>&', $olderr + or croak("unable to reestablish STDERR"); + open STDOUT, '>&', $oldout + or croak("unable to reestablish STDOUT"); + open STDIN, '<&', $oldin + or croak("unable to reestablish STDIN"); + #printf STDERR "stdin %d, stdout %d, stderr %d\n", + # fileno STDIN, fileno STDOUT, fileno STDERR; + return $pid; + + } + + local $SIG{PIPE}= sub { print STDERR "Got signal $@\n"; }; + my $pipe= IO::Pipe->new(); + my $pid= _safe_fork(); + if ($pid){ + # Parent + $pipe->reader(); + my $line= <$pipe>; # Wait for child to say it's ready + return $pid; + } + + $SIG{INT}= 'DEFAULT'; + $SIG{HUP}= 'DEFAULT'; + + # Make this process it's own process group to be able to kill + # it and any childs(that hasn't changed group themself) + setpgrp(0,0) if $opts{setpgrp}; + + if ( $output ) { + close STDOUT; + open(STDOUT, $open_mode, $output) + or croak "can't redirect STDOUT to '$output': $!"; + } + + if ( $error ) { + if ( defined $output and $output eq $error ) { + if ( ! open(STDERR, ">&STDOUT") ) { + croak("can't dup STDOUT: $!"); + } + } + else { + close STDERR; + open(STDERR, $open_mode, $error) + or croak "can't redirect STDERR to '$error': $!"; + } + } + + if ( $input ) { + if ( ! open(STDIN, "<", $input) ) { + croak("can't redirect STDIN to '$input': $!"); + } + } + + # Tell parent to continue + $pipe->writer(); + print $pipe "ready\n"; + + if ( !exec($path, @$args) ){ + croak("Failed to exec '$path': $!"); + } + + croak("Should never come here"); + +} + +1; + |