# -*- cperl -*-
# Copyright (c) 2004, 2010, Oracle and/or its affiliates. All rights reserved.
#
# 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-1301  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;
use File::Find;

sub mtr_native_path($);
sub mtr_init_args ($);
sub mtr_add_arg ($$@);
sub mtr_path_exists(@);
sub mtr_script_exists(@);
sub mtr_file_exists(@);
sub mtr_exe_exists(@);
sub mtr_exe_maybe_exists(@);
sub mtr_copy_dir($$);
sub mtr_rmtree($);
sub mtr_same_opts($$);
sub mtr_cmp_opts($$);

##############################################################################
#
#  Misc
#
##############################################################################

# Convert path to OS native format
sub mtr_native_path($)
{
  my $path= shift;

  # MySQL version before 5.0 still use cygwin, no need
  # to convert path
  return $path
    if ($::mysql_version_id < 50000);

  $path=~ s/\//\\/g
    if ($::glob_win32);
  return $path;
}

# FIXME move to own lib

sub mtr_init_args ($) {
  my $args = shift;
  $$args = [];                            # Empty list
}

sub mtr_add_arg ($$@) {
  my $args=   shift;
  my $format= shift;
  my @fargs = @_;

  push(@$args, sprintf($format, @fargs));
}

##############################################################################

#
# NOTE! More specific paths should be given before less specific.
# For example /client/debug should be listed before /client
#
sub mtr_path_exists (@) {
  foreach my $path ( @_ )
  {
    return $path if -e $path;
  }
  if ( @_ == 1 )
  {
    mtr_error("Could not find $_[0]");
  }
  else
  {
    mtr_error("Could not find any of " . join(" ", @_));
  }
}

#
# NOTE! More specific paths should be given before less specific.
# For example /client/debug should be listed before /client
#
sub mtr_script_exists (@) {
  foreach my $path ( @_ )
  {
    if($::glob_win32)
    {
      return $path if -f $path;
    }
    else
    {
      return $path if -x $path;
    }
  }
  if ( @_ == 1 )
  {
    mtr_error("Could not find $_[0]");
  }
  else
  {
    mtr_error("Could not find any of " . join(" ", @_));
  }
}

#
# NOTE! More specific paths should be given before less specific.
# For example /client/debug should be listed before /client
#
sub mtr_file_exists (@) {
  foreach my $path ( @_ )
  {
    return $path if -e $path;
  }
  return "";
}

#
# NOTE! More specific paths should be given before less specific.
# For example /client/debug should be listed before /client
#
sub mtr_exe_maybe_exists (@) {
  my @path= @_;

  map {$_.= ".exe"} @path if $::glob_win32;
  foreach my $path ( @path )
  {
    if($::glob_win32)
    {
      return $path if -f $path;
    }
    else
    {
      return $path if -x $path;
    }
  }
  return "";
}

#
# NOTE! More specific paths should be given before less specific.
# For example /client/debug should be listed before /client
#
sub mtr_exe_exists (@) {
  my @path= @_;
  if (my $path= mtr_exe_maybe_exists(@path))
  {
    return $path;
  }
  # Could not find exe, show error
  if ( @path == 1 )
  {
    mtr_error("Could not find $path[0]");
  }
  else
  {
    mtr_error("Could not find any of " . join(" ", @path));
  }
}

sub mtr_copy_dir($$) {
  my $from_dir= shift;
  my $to_dir= shift;

  # mtr_verbose("Copying from $from_dir to $to_dir");

  mkpath("$to_dir");
  opendir(DIR, "$from_dir")
    or mtr_error("Can't find $from_dir$!");
  for(readdir(DIR)) {
    next if "$_" eq "." or "$_" eq "..";
    if ( -d "$from_dir/$_" )
    {
      mtr_copy_dir("$from_dir/$_", "$to_dir/$_");
      next;
    }
    copy("$from_dir/$_", "$to_dir/$_");
  }
  closedir(DIR);

}

sub mtr_rmtree($) {
  my ($dir)= @_;
  mtr_verbose("mtr_rmtree: $dir");

  # Try to use File::Path::rmtree. Recent versions
  # handles removal of directories and files that don't
  # have full permissions, while older versions
  # may have a problem with that and we use our own version

  eval { rmtree($dir); };
  if ( $@ ) {
    mtr_warning("rmtree($dir) failed, trying with File::Find...");

    my $errors= 0;

    # chmod
    find( {
	   no_chdir => 1,
	   wanted => sub {
	     chmod(0777, $_)
	       or mtr_warning("couldn't chmod(0777, $_): $!") and $errors++;
	   }
	  },
	  $dir
	);

    # rm
    finddepth( {
	   no_chdir => 1,
	   wanted => sub {
	     my $file= $_;
	     # Use special underscore (_) filehandle, caches stat info
	     if (!-l $file and -d _ ) {
	       rmdir($file) or
		 mtr_warning("couldn't rmdir($file): $!") and $errors++;
	     } else {
	       unlink($file)
		 or mtr_warning("couldn't unlink($file): $!") and $errors++;
	     }
	   }
	  },
	  $dir
	);

    mtr_error("Failed to remove '$dir'") if $errors;

    mtr_report("OK, that worked!");
  }
}

sub mtr_same_opts ($$) {
  my $l1= shift;
  my $l2= shift;
  return mtr_cmp_opts($l1,$l2) == 0;
}

sub mtr_cmp_opts ($$) {
  my $l1= shift;
  my $l2= shift;

  my @l1= @$l1;
  my @l2= @$l2;

  return -1 if @l1 < @l2;
  return  1 if @l1 > @l2;

  while ( @l1 )                         # Same length
  {
    my $e1= shift @l1;
    my $e2= shift @l2;
    my $cmp= ($e1 cmp $e2);
    return $cmp if $cmp != 0;
  }

  return 0;                             # They are the same
}

#
# Compare two arrays and put all unequal elements into a new one
#
sub mtr_diff_opts ($$) {
  my $l1= shift;
  my $l2= shift;
  my $f;
  my $l= [];
  foreach my $e1 (@$l1)
  {
    $f= undef;
    foreach my $e2 (@$l2)
    {
      $f= 1 unless ($e1 ne $e2);
    }
    push(@$l, $e1) unless (defined $f);
  }
  foreach my $e2 (@$l2)
  {
    $f= undef;
    foreach my $e1 (@$l1)
    {
      $f= 1 unless ($e1 ne $e2);
    }
    push(@$l, $e2) unless (defined $f);
  }
  return $l;
}

1;


# -*- cperl -*-
# Copyright (c) 2004-2006 MySQL AB, 2008 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-1301  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 Socket;
use Errno;
use strict;

use POSIX qw(WNOHANG SIGHUP);

sub mtr_run ($$$$$$;$);
sub mtr_spawn ($$$$$$;$);
sub mtr_check_stop_servers ($);
sub mtr_kill_leftovers ();
sub mtr_wait_blocking ($);
sub mtr_record_dead_children ();
sub mtr_ndbmgm_start($$);
sub mtr_mysqladmin_start($$$);
sub mtr_exit ($);
sub sleep_until_file_created ($$$);
sub mtr_kill_processes ($);
sub mtr_ping_with_timeout($);
sub mtr_ping_port ($);

# Local function
sub spawn_impl ($$$$$$$);

##############################################################################
#
#  Execute an external command
#
##############################################################################

sub mtr_run ($$$$$$;$) {
  my $path=       shift;
  my $arg_list_t= shift;
  my $input=      shift;
  my $output=     shift;
  my $error=      shift;
  my $pid_file=   shift; # Not used
  my $spawn_opts= shift;

  return spawn_impl($path,$arg_list_t,'run',$input,$output,$error,
    $spawn_opts);
}

sub mtr_run_test ($$$$$$;$) {
  my $path=       shift;
  my $arg_list_t= shift;
  my $input=      shift;
  my $output=     shift;
  my $error=      shift;
  my $pid_file=   shift; # Not used
  my $spawn_opts= shift;

  return spawn_impl($path,$arg_list_t,'test',$input,$output,$error,
    $spawn_opts);
}

sub mtr_spawn ($$$$$$;$) {
  my $path=       shift;
  my $arg_list_t= shift;
  my $input=      shift;
  my $output=     shift;
  my $error=      shift;
  my $pid_file=   shift; # Not used
  my $spawn_opts= shift;

  return spawn_impl($path,$arg_list_t,'spawn',$input,$output,$error,
    $spawn_opts);
}

sub spawn_impl ($$$$$$$) {
  my $path=       shift;
  my $arg_list_t= shift;
  my $mode=       shift;
  my $input=      shift;
  my $output=     shift;
  my $error=      shift;
  my $spawn_opts= shift;

  if ( $::opt_script_debug )
  {
    mtr_report("");
    mtr_debug("-" x 73);
    mtr_debug("STDIN  $input") if $input;
    mtr_debug("STDOUT $output") if $output;
    mtr_debug("STDERR $error") if $error;
    mtr_debug("$mode: $path ", join(" ",@$arg_list_t));
    mtr_debug("spawn options:");
    if ($spawn_opts)
    {
      foreach my $key (sort keys %{$spawn_opts})
      {
        mtr_debug("  - $key: $spawn_opts->{$key}");
      }
    }
    else
    {
      mtr_debug("  none");
    }
    mtr_debug("-" x 73);
    mtr_report("");
  }

  mtr_error("Can't spawn with empty \"path\"") unless defined $path;

 FORK:
  {
    my $pid= fork();

    if ( ! defined $pid )
    {
      if ( $! == $!{EAGAIN} )           # See "perldoc Errno"
      {
        mtr_warning("Got EAGAIN from fork(), sleep 1 second and redo");
        sleep(1);
        redo FORK;
      }

      mtr_error("$path ($pid) can't be forked, error: $!");

    }

    if ( $pid )
    {
      select(STDOUT) if $::glob_win32_perl;
      return spawn_parent_impl($pid,$mode,$path);
    }
    else
    {
      # Child, redirect output and exec

      $SIG{INT}= 'DEFAULT';         # Parent do some stuff, we don't

      my $log_file_open_mode = '>';

      if ($spawn_opts and $spawn_opts->{'append_log_file'})
      {
        $log_file_open_mode = '>>';
      }

      if ( $output )
      {
	if ( $::glob_win32_perl )
	{
	  # Don't redirect stdout on ActiveState perl since this is
          # just another thread in the same process.
	}
        elsif ( ! open(STDOUT,$log_file_open_mode,$output) )
        {
          mtr_child_error("can't redirect STDOUT to \"$output\": $!");
        }
      }

      if ( $error )
      {
        if ( !$::glob_win32_perl and $output eq $error )
        {
          if ( ! open(STDERR,">&STDOUT") )
          {
            mtr_child_error("can't dup STDOUT: $!");
          }
        }
        else
        {
          if ( ! open(STDERR,$log_file_open_mode,$error) )
          {
            mtr_child_error("can't redirect STDERR to \"$error\": $!");
          }
        }
      }

      if ( $input )
      {
        if ( ! open(STDIN,"<",$input) )
        {
          mtr_child_error("can't redirect STDIN to \"$input\": $!");
        }
      }

      if ( ! exec($path,@$arg_list_t) )
      {
        mtr_child_error("failed to execute \"$path\": $!");
      }
      mtr_error("Should never come here 1!");
    }
    mtr_error("Should never come here 2!");
  }
  mtr_error("Should never come here 3!");
}

sub spawn_parent_impl {
  my $pid=  shift;
  my $mode= shift;
  my $path= shift;

  if ( $mode eq 'run' or $mode eq 'test' )
  {
    if ( $mode eq 'run' )
    {
      # Simple run of command, wait blocking for it to return
      my $ret_pid= waitpid($pid,0);
      if ( $ret_pid != $pid )
      {
	# The "simple" waitpid has failed, print debug info
	# and try to handle the error
        mtr_warning("waitpid($pid, 0) returned $ret_pid " .
		    "when waiting for '$path', error: '$!'");
	if ( $ret_pid == -1 )
	{
	  # waitpid returned -1, that would indicate the process
	  # no longer exist and waitpid couldn't wait for it.
	  return 1;
	}
	mtr_error("Error handling failed");
      }

      return mtr_process_exit_status($?);
    }
    else
    {
      # We run mysqltest and wait for it to return. But we try to
      # catch dying mysqld processes as well.
      #
      # We do blocking waitpid() until we get the return from the
      # "mysqltest" call. But if a mysqld process dies that we
      # started, we take this as an error, and kill mysqltest.

      my $exit_value= -1;
      my $saved_exit_value;
      my $ret_pid;                      # What waitpid() returns

      while ( ($ret_pid= waitpid(-1,0)) != -1 )
      {
        # Someone terminated, don't know who. Collect
        # status info first before $? is lost,
        # but not $exit_value, this is flagged from

        my $timer_name= mtr_timer_timeout($::glob_timers, $ret_pid);
        if ( $timer_name )
        {
          if ( $timer_name eq "suite" )
          {
            # We give up here
            print STDERR "\n";
            kill(9, $pid); # Kill mysqltest
            mtr_kill_leftovers(); # Kill servers the hard way
            mtr_error("Test suite timeout");
          }
          elsif ( $timer_name eq "testcase" )
          {
            $saved_exit_value=  63;       # Mark as timeout
            kill(9, $pid);                # Kill mysqltest
            next;                         # Go on and catch the termination
          }
        }

        if ( $ret_pid == $pid )
        {
          # We got termination of mysqltest, we are done
          $exit_value= mtr_process_exit_status($?);
          last;
        }

        # One of the child processes died, unless this was expected
	# mysqltest should be killed and test aborted

	check_expected_crash_and_restart($ret_pid);
      }

      if ( $ret_pid != $pid )
      {
        # We terminated the waiting because a "mysqld" process died.
        # Kill the mysqltest process.
	mtr_verbose("Kill mysqltest because another process died");
        kill(9,$pid);

        $ret_pid= waitpid($pid,0);

        if ( $ret_pid != $pid )
        {
          mtr_error("$path ($pid) got lost somehow");
        }
      }

      return $saved_exit_value || $exit_value;
    }
  }
  else
  {
    # We spawned a process we don't wait for
    return $pid;
  }
}

# ----------------------------------------------------------------------
# We try to emulate how an Unix shell calculates the exit code
# ----------------------------------------------------------------------

sub mtr_process_exit_status {
  my $raw_status= shift;

  if ( $raw_status & 127 )
  {
    return ($raw_status & 127) + 128;  # Signal num + 128
  }
  else
  {
    return $raw_status >> 8;           # Exit code
  }
}

##############################################################################
#
#  Kill processes left from previous runs
#
##############################################################################

# Kill all processes(mysqld, ndbd, ndb_mgmd and im) that would conflict with
# this run
# Make sure to remove the PID file, if any.
# kill IM manager first, else it will restart the servers
sub mtr_kill_leftovers () {

  mtr_report("Killing Possible Leftover Processes");
  mtr_debug("mtr_kill_leftovers(): started.");

  my @kill_pids;
  my %admin_pids;

  foreach my $srv (@{$::master}, @{$::slave})
  {
    mtr_debug("  - mysqld " .
              "(pid: $srv->{pid}; " .
              "pid file: '$srv->{path_pid}'; " .
              "socket: '$srv->{path_sock}'; ".
              "port: $srv->{port})");

    my $pid= mtr_mysqladmin_start($srv, "shutdown", 20);

    # Save the pid of the mysqladmin process
    $admin_pids{$pid}= 1;

    push(@kill_pids,{
		     pid      => $srv->{'pid'},
		     pidfile  => $srv->{'path_pid'},
		     sockfile => $srv->{'path_sock'},
		     port     => $srv->{'port'},
		    });
    $srv->{'pid'}= 0; # Assume we are done with it
  }

  if ( ! $::opt_skip_ndbcluster )
  {

    foreach my $cluster (@{$::clusters})
    {

      # Don't shut down a "running" cluster
      next if $cluster->{'use_running'};

      mtr_debug("  - cluster " .
		"(pid: $cluster->{pid}; " .
		"pid file: '$cluster->{path_pid})");

      my $pid= mtr_ndbmgm_start($cluster, "shutdown");

      # Save the pid of the ndb_mgm process
      $admin_pids{$pid}= 1;

      push(@kill_pids,{
		       pid      => $cluster->{'pid'},
		       pidfile  => $cluster->{'path_pid'}
		      });

      $cluster->{'pid'}= 0; # Assume we are done with it

      foreach my $ndbd (@{$cluster->{'ndbds'}})
      {
	mtr_debug("    - ndbd " .
		  "(pid: $ndbd->{pid}; " .
		  "pid file: '$ndbd->{path_pid})");

	push(@kill_pids,{
			 pid      => $ndbd->{'pid'},
			 pidfile  => $ndbd->{'path_pid'},
			});
	$ndbd->{'pid'}= 0; # Assume we are done with it
      }
    }
  }

  # Wait for all the admin processes to complete
  mtr_wait_blocking(\%admin_pids);

  # If we trusted "mysqladmin --shutdown_timeout= ..." we could just
  # terminate now, but we don't (FIXME should be debugged).
  # So we try again to ping and at least wait the same amount of time
  # mysqladmin would for all to die.

  mtr_ping_with_timeout(\@kill_pids);

  # We now have tried to terminate nice. We have waited for the listen
  # port to be free, but can't really tell if the mysqld process died
  # or not. We now try to find the process PID from the PID file, and
  # send a kill to that process. Note that Perl let kill(0,@pids) be
  # a way to just return the numer of processes the kernel can send
  # signals to. So this can be used (except on Cygwin) to determine
  # if there are processes left running that we cound out might exists.
  #
  # But still after all this work, all we know is that we have
  # the ports free.

  # We scan the "var/run/" directory for other process id's to kill

  my $rundir= "$::opt_vardir/run";

  mtr_debug("Processing PID files in directory '$rundir'...");

  if ( -d $rundir )
  {
    opendir(RUNDIR, $rundir)
      or mtr_error("can't open directory \"$rundir\": $!");

    my @pids;

    while ( my $elem= readdir(RUNDIR) )
    {
      # Only read pid from files that end with .pid
      if ( $elem =~ /.*[.]pid$/)
      {
	my $pidfile= "$rundir/$elem";

	if ( -f $pidfile )
	{
	  mtr_debug("Processing PID file: '$pidfile'...");

	  my $pid= mtr_get_pid_from_file($pidfile);

	  mtr_debug("Got pid: $pid from file '$pidfile'");

	  if ( $::glob_cygwin_perl or kill(0, $pid) )
	  {
	    mtr_debug("There is process with pid $pid -- scheduling for kill.");
	    push(@pids, $pid);            # We know (cygwin guess) it exists
	  }
	  else
	  {
	    mtr_debug("There is no process with pid $pid -- skipping.");
	  }
	}
      }
      else
      {
	mtr_warning("Found non pid file $elem in $rundir")
	  if -f "$rundir/$elem";
	next;
      }
    }
    closedir(RUNDIR);

    if ( @pids )
    {
      mtr_debug("Killing the following processes with PID files: " .
                join(' ', @pids) . "...");

      start_reap_all();

      if ( $::glob_cygwin_perl )
      {
        # We have no (easy) way of knowing the Cygwin controlling
        # process, in the PID file we only have the Windows process id.
        system("kill -f " . join(" ",@pids)); # Hope for the best....
        mtr_debug("Sleep 5 seconds waiting for processes to die");
        sleep(5);
      }
      else
      {
        my $retries= 10;                    # 10 seconds
        do
        {
          mtr_debug("Sending SIGKILL to pids: " . join(' ', @pids));
          kill(9, @pids);
          mtr_report("Sleep 1 second waiting for processes to die");
          sleep(1)                      # Wait one second
        } while ( $retries-- and  kill(0, @pids) );

        if ( kill(0, @pids) )           # Check if some left
        {
          mtr_warning("can't kill process(es) " . join(" ", @pids));
        }
      }

      stop_reap_all();
    }
  }
  else
  {
    mtr_debug("Directory for PID files ($rundir) does not exist.");
  }

  # We may have failed everything, but we now check again if we have
  # the listen ports free to use, and if they are free, just go for it.

  mtr_debug("Checking known mysqld servers...");

  foreach my $srv ( @kill_pids )
  {
    if ( defined $srv->{'port'} and mtr_ping_port($srv->{'port'}) )
    {
      mtr_warning("can't kill old process holding port $srv->{'port'}");
    }
  }

  mtr_debug("mtr_kill_leftovers(): finished.");
}

#
# Check that all processes in "spec" are shutdown gracefully
# else kill them off hard
#
sub mtr_check_stop_servers ($) {
  my $spec=  shift;

  # Return if no processes are defined
  return if ! @$spec;

  mtr_verbose("mtr_check_stop_servers");

  # ----------------------------------------------------------------------
  # Wait until servers in "spec" has stopped listening
  # to their ports or timeout occurs
  # ----------------------------------------------------------------------
  mtr_ping_with_timeout(\@$spec);

  # ----------------------------------------------------------------------
  # Use waitpid() nonblocking for a little while, to see how
  # many process's will exit sucessfully.
  # This is the normal case.
  # ----------------------------------------------------------------------
  my $wait_counter= 50; # Max number of times to redo the loop
  foreach my $srv ( @$spec )
  {
    my $pid= $srv->{'pid'};
    my $ret_pid;
    if ( $pid )
    {
      $ret_pid= waitpid($pid,&WNOHANG);
      if ($ret_pid == $pid)
      {
	mtr_verbose("Caught exit of process $ret_pid");
	$srv->{'pid'}= 0;
      }
      elsif ($ret_pid == 0)
      {
	mtr_verbose("Process $pid is still alive");
	if ($wait_counter-- > 0)
	{
	  # Give the processes more time to exit
	  select(undef, undef, undef, (0.1));
	  redo;
	}
      }
      else
      {
	mtr_warning("caught exit of unknown child $ret_pid");
      }
    }
  }

  # ----------------------------------------------------------------------
  # The processes that haven't yet exited need to
  # be killed hard, put them in "kill_pids" hash
  # ----------------------------------------------------------------------
  my %kill_pids;
  foreach my $srv ( @$spec )
  {
    my $pid= $srv->{'pid'};
    if ( $pid )
    {
      # Server is still alive, put it in list to be hard killed
      if ($::glob_win32_perl)
      {
	# Kill the real process if it's known
	$pid= $srv->{'real_pid'} if ($srv->{'real_pid'});
      }
      $kill_pids{$pid}= 1;

      # Write a message to the process's error log (if it has one)
      # that it's being killed hard.
      if ( defined $srv->{'errfile'} )
      {
	mtr_tofile($srv->{'errfile'}, "Note: Forcing kill of process $pid\n");
      }
      mtr_warning("Forcing kill of process $pid");

    }
    else
    {
      # Server is dead, remove the pidfile if it exists
      #
      # Race, could have been removed between test with -f
      # and the unlink() below, so better check again with -f
      if ( -f $srv->{'pidfile'} and ! unlink($srv->{'pidfile'}) and
           -f $srv->{'pidfile'} )
      {
        mtr_error("can't remove $srv->{'pidfile'}");
      }
    }
  }

  if ( ! keys %kill_pids )
  {
    # All processes has exited gracefully
    return;
  }

  mtr_kill_processes(\%kill_pids);

  # ----------------------------------------------------------------------
  # All processes are killed, cleanup leftover files
  # ----------------------------------------------------------------------
  {
    my $errors= 0;
    foreach my $srv ( @$spec )
    {
      if ( $srv->{'pid'} )
      {
	# Server has been hard killed, clean it's resources
	foreach my $file ($srv->{'pidfile'}, $srv->{'sockfile'})
        {
	  # Know it is dead so should be no race, careful anyway
	  if ( defined $file and -f $file and ! unlink($file) and -f $file )
          {
	    $errors++;
	    mtr_warning("couldn't delete $file");
	  }
	}

	if ($::glob_win32_perl and $srv->{'real_pid'})
	{
	  # Wait for the pseudo pid - if the real_pid was known
	  # the pseudo pid has not been waited for yet, wai blocking
	  # since it's "such a simple program"
	  mtr_verbose("Wait for pseudo process $srv->{'pid'}");
	  my $ret_pid= waitpid($srv->{'pid'}, 0);
	  mtr_verbose("Pseudo process $ret_pid died");
	}

	$srv->{'pid'}= 0;
      }
    }
    if ( $errors )
    {
      # There where errors killing processes
      # do one last attempt to ping the servers
      # and if they can't be pinged, assume they are dead
      if ( ! mtr_ping_with_timeout( \@$spec ) )
      {
	mtr_error("we could not kill or clean up all processes");
      }
      else
      {
	mtr_verbose("All ports were free, continuing");
      }
    }
  }
}

# Wait for all the process in the list to terminate
sub mtr_wait_blocking($) {
  my $admin_pids= shift;

  # Return if no processes defined
  return if ! %$admin_pids;

  mtr_verbose("mtr_wait_blocking");

  # Wait for all the started processes to exit
  # As mysqladmin is such a simple program, we trust it to terminate itself.
  # I.e. we wait blocking, and wait for them all before we go on.
  foreach my $pid (keys %{$admin_pids})
  {
    my $ret_pid= waitpid($pid,0);

  }
}

# Start "mysqladmin <command>" for a specific mysqld
sub mtr_mysqladmin_start($$$) {
  my $srv= shift;
  my $command= shift;
  my $adm_shutdown_tmo= shift;

  my $args;
  mtr_init_args(\$args);

  mtr_add_arg($args, "--no-defaults");
  mtr_add_arg($args, "--user=%s", $::opt_user);
  mtr_add_arg($args, "--password=");
  mtr_add_arg($args, "--silent");
  if ( -e $srv->{'path_sock'} )
  {
    mtr_add_arg($args, "--socket=%s", $srv->{'path_sock'});
  }
  if ( $srv->{'port'} )
  {
    mtr_add_arg($args, "--port=%s", $srv->{'port'});
  }
  if ( $srv->{'port'} and ! -e $srv->{'path_sock'} )
  {
    mtr_add_arg($args, "--protocol=tcp"); # Needed if no --socket
  }
  mtr_add_arg($args, "--connect_timeout=5");

  # Shutdown time must be high as slave may be in reconnect
  mtr_add_arg($args, "--shutdown_timeout=$adm_shutdown_tmo");
  mtr_add_arg($args, "$command");
  my $pid= mtr_spawn($::exe_mysqladmin, $args,
		     "", "", "", "",
		     { append_log_file => 1 });
  mtr_verbose("mtr_mysqladmin_start, pid: $pid");
  return $pid;

}

# Start "ndb_mgm shutdown" for a specific cluster, it will
# shutdown all data nodes and leave the ndb_mgmd running
sub mtr_ndbmgm_start($$) {
  my $cluster= shift;
  my $command= shift;

  my $args;

  mtr_init_args(\$args);

  mtr_add_arg($args, "--no-defaults");
  mtr_add_arg($args, "--core");
  mtr_add_arg($args, "--try-reconnect=1");
  mtr_add_arg($args, "--ndb_connectstring=%s", $cluster->{'connect_string'});
  mtr_add_arg($args, "-e");
  mtr_add_arg($args, "$command");

  my $pid= mtr_spawn($::exe_ndb_mgm, $args,
		     "", "/dev/null", "/dev/null", "",
		     {});
  mtr_verbose("mtr_ndbmgm_start, pid: $pid");
  return $pid;

}

# Ping all servers in list, exit when none of them answers
# or when timeout has passed
sub mtr_ping_with_timeout($) {
  my $spec= shift;
  my $timeout= 200;                     # 20 seconds max
  my $res= 1;                           # If we just fall through, we are done
                                        # in the sense that the servers don't
                                        # listen to their ports any longer

  mtr_debug("Waiting for mysqld servers to stop...");

 TIME:
  while ( $timeout-- )
  {
    foreach my $srv ( @$spec )
    {
      $res= 1;                          # We are optimistic
      if ( $srv->{'pid'} and defined $srv->{'port'} )
      {
	if ( mtr_ping_port($srv->{'port'}) )
	{
	  mtr_verbose("waiting for process $srv->{'pid'} to stop ".
		      "using port $srv->{'port'}");

	  # Millisceond sleep emulated with select
	  select(undef, undef, undef, (0.1));
	  $res= 0;
	  next TIME;
	}
	else
	{
	  # Process was not using port
	}
      }
    }
    last;                               # If we got here, we are done
  }

  if ($res)
  {
    mtr_debug("mtr_ping_with_timeout(): All mysqld instances are down.");
  }
  else
  {
    mtr_report("mtr_ping_with_timeout(): At least one server is alive.");
  }

  return $res;
}

#
# Loop through our list of processes and look for and entry
# with the provided pid
# Set the pid of that process to 0 if found
#
sub mark_process_dead($)
{
  my $ret_pid= shift;

  foreach my $mysqld (@{$::master}, @{$::slave})
  {
    if ( $mysqld->{'pid'} eq $ret_pid )
    {
      mtr_verbose("$mysqld->{'type'} $mysqld->{'idx'} exited, pid: $ret_pid");
      $mysqld->{'pid'}= 0;
      return;
    }
  }

  foreach my $cluster (@{$::clusters})
  {
    if ( $cluster->{'pid'} eq $ret_pid )
    {
      mtr_verbose("$cluster->{'name'} cluster ndb_mgmd exited, pid: $ret_pid");
      $cluster->{'pid'}= 0;
      return;
    }

    foreach my $ndbd (@{$cluster->{'ndbds'}})
    {
      if ( $ndbd->{'pid'} eq $ret_pid )
      {
	mtr_verbose("$cluster->{'name'} cluster ndbd exited, pid: $ret_pid");
	$ndbd->{'pid'}= 0;
	return;
      }
    }
  }
  mtr_warning("mark_process_dead couldn't find an entry for pid: $ret_pid");

}

#
# Loop through our list of processes and look for and entry
# with the provided pid, if found check for the file indicating
# expected crash and restart it.
#
sub check_expected_crash_and_restart($)
{
  my $ret_pid= shift;

  foreach my $mysqld (@{$::master}, @{$::slave})
  {
    if ( $mysqld->{'pid'} eq $ret_pid )
    {
      mtr_verbose("$mysqld->{'type'} $mysqld->{'idx'} exited, pid: $ret_pid");
      $mysqld->{'pid'}= 0;

      # Check if crash expected and restart if it was
      my $expect_file= "$::opt_vardir/tmp/" . "$mysqld->{'type'}" .
	"$mysqld->{'idx'}" . ".expect";
      if ( -f $expect_file )
      {
	mtr_verbose("Crash was expected, file $expect_file exists");
	mysqld_start($mysqld, $mysqld->{'start_opts'},
		     $mysqld->{'start_slave_master_info'});
	unlink($expect_file);
      }

      return;
    }
  }

  foreach my $cluster (@{$::clusters})
  {
    if ( $cluster->{'pid'} eq $ret_pid )
    {
      mtr_verbose("$cluster->{'name'} cluster ndb_mgmd exited, pid: $ret_pid");
      $cluster->{'pid'}= 0;

      # Check if crash expected and restart if it was
      my $expect_file= "$::opt_vardir/tmp/ndb_mgmd_" . "$cluster->{'type'}" .
	".expect";
      if ( -f $expect_file )
      {
	mtr_verbose("Crash was expected, file $expect_file exists");
	ndbmgmd_start($cluster);
	unlink($expect_file);
      }
      return;
    }

    foreach my $ndbd (@{$cluster->{'ndbds'}})
    {
      if ( $ndbd->{'pid'} eq $ret_pid )
      {
	mtr_verbose("$cluster->{'name'} cluster ndbd exited, pid: $ret_pid");
	$ndbd->{'pid'}= 0;

	# Check if crash expected and restart if it was
	my $expect_file= "$::opt_vardir/tmp/ndbd_" . "$cluster->{'type'}" .
	  "$ndbd->{'idx'}" . ".expect";
	if ( -f $expect_file )
	{
	  mtr_verbose("Crash was expected, file $expect_file exists");
	  ndbd_start($cluster, $ndbd->{'idx'},
		     $ndbd->{'start_extra_args'});
	  unlink($expect_file);
	}
	return;
      }
    }
  }

  if ($::instance_manager->{'spawner_pid'} eq $ret_pid)
  {
    return;
  }

  mtr_warning("check_expected_crash_and_restart couldn't find an entry for pid: $ret_pid");

}

##############################################################################
#
#  The operating system will keep information about dead children,
#  we read this information here, and if we have records the process
#  is alive, we mark it as dead.
#
##############################################################################

sub mtr_record_dead_children () {

  my $process_died= 0;
  my $ret_pid;

  # Wait without blockinng to see if any processes had died
  # -1 or 0 means there are no more procesess to wait for
  while ( ($ret_pid= waitpid(-1,&WNOHANG)) != 0 and $ret_pid != -1)
  {
    mtr_warning("mtr_record_dead_children: $ret_pid");
    mark_process_dead($ret_pid);
    $process_died= 1;
  }
  return $process_died;
}

sub start_reap_all {
  # This causes terminating processes to not become zombies, avoiding
  # the need for (or possibility of) explicit waitpid().
  $SIG{CHLD}= 'IGNORE';

  # On some platforms (Linux, QNX, OSX, ...) there is potential race
  # here. If a process terminated before setting $SIG{CHLD} (but after
  # any attempt to waitpid() it), it will still be a zombie. So we
  # have to handle any such process here.
  my $pid;
  while(($pid= waitpid(-1, &WNOHANG)) != 0 and $pid != -1)
  {
    mtr_warning("start_reap_all pid: $pid");
    mark_process_dead($pid);
  };
}

sub stop_reap_all {
  $SIG{CHLD}= 'DEFAULT';
}

sub mtr_ping_port ($) {
  my $port= shift;

  mtr_verbose("mtr_ping_port: $port");

  my $remote= "localhost";
  my $iaddr=  inet_aton($remote);
  if ( ! $iaddr )
  {
    mtr_error("can't find IP number for $remote");
  }
  my $paddr=  sockaddr_in($port, $iaddr);
  my $proto=  getprotobyname('tcp');
  if ( ! socket(SOCK, PF_INET, SOCK_STREAM, $proto) )
  {
    mtr_error("can't create socket: $!");
  }

  mtr_debug("Pinging server (port: $port)...");

  if ( connect(SOCK, $paddr) )
  {
    close(SOCK);                        # FIXME check error?
    mtr_verbose("USED");
    return 1;
  }
  else
  {
    mtr_verbose("FREE");
    return 0;
  }
}

##############################################################################
#
#  Wait for a file to be created
#
##############################################################################

# FIXME check that the pidfile contains the expected pid!

sub sleep_until_file_created ($$$) {
  my $pidfile= shift;
  my $timeout= shift;
  my $pid=     shift;
  my $sleeptime= 100; # Milliseconds
  my $loops= ($timeout * 1000) / $sleeptime;

  for ( my $loop= 1; $loop <= $loops; $loop++ )
  {
    if ( -r $pidfile )
    {
      return 1;
    }

    # Check if it died after the fork() was successful
    if ( $pid != 0 && waitpid($pid,&WNOHANG) == $pid )
    {
      mtr_warning("Process $pid died");
      return 0;
    }

    mtr_debug("Sleep $sleeptime milliseconds waiting for $pidfile");

    # Print extra message every 60 seconds
    my $seconds= ($loop * $sleeptime) / 1000;
    if ( $seconds > 1 and int($seconds * 10) % 600 == 0 )
    {
      my $left= $timeout - $seconds;
      mtr_warning("Waited $seconds seconds for $pidfile to be created, " .
                  "still waiting for $left seconds...");
    }

    # Millisceond sleep emulated with select
    select(undef, undef, undef, ($sleeptime/1000));
  }

  return 0;
}

sub mtr_kill_processes ($) {
  my $pids = shift;

  mtr_verbose("mtr_kill_processes (" . join(" ", keys %{$pids}) . ")");

  foreach my $pid (keys %{$pids})
  {

    if ($pid <= 0)
    {
      mtr_warning("Trying to kill illegal pid: $pid");
      next;
    }

    my $signaled_procs= kill(9, $pid);
    if ($signaled_procs == 0)
    {
      # No such process existed, assume it's killed
      mtr_verbose("killed $pid(no such process)");
    }
    else
    {
      my $ret_pid= waitpid($pid,0);
      if ($ret_pid == $pid)
      {
	mtr_verbose("killed $pid(got the pid)");
      }
      elsif ($ret_pid == -1)
      {
	mtr_verbose("killed $pid(got -1)");
      }
    }
  }
  mtr_verbose("done killing processes");
}

##############################################################################
#
#  When we exit, we kill off all children
#
##############################################################################

sub mtr_exit ($) {
  my $code= shift;
  mtr_timer_stop_all($::glob_timers);
  local $SIG{HUP} = 'IGNORE';
  # ToDo: Signalling -$$ will only work if we are the process group
  # leader (in fact on QNX it will signal our session group leader,
  # which might be Do-compile or Pushbuild, causing tests to be
  # aborted). So we only do it if we are the group leader. We might
  # set ourselves as the group leader at startup (with
  # POSIX::setpgrp(0,0)), but then care must be needed to always do
  # proper child process cleanup.
  POSIX::kill(SIGHUP, -$$) if !$::glob_win32_perl and $$ == getpgrp();

  exit($code);
}

###########################################################################

1;


# -*- cperl -*-
# Copyright (c) 2004, 2010, Oracle and/or its affiliates. All rights reserved.
#
# 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-1301  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;
use warnings;

sub mtr_report_test_name($);
sub mtr_report_test_passed($);
sub mtr_report_test_failed($);
sub mtr_report_test_skipped($);
sub mtr_report_test_not_skipped_though_disabled($);

sub mtr_report_stats ($);
sub mtr_print_line ();
sub mtr_print_thick_line ();
sub mtr_print_header ();
sub mtr_report (@);
sub mtr_warning (@);
sub mtr_error (@);
sub mtr_child_error (@);
sub mtr_debug (@);
sub mtr_verbose (@);

my $tot_real_time= 0;

##############################################################################
#
#
#
##############################################################################

sub mtr_report_test_name ($) {
  my $tinfo= shift;
  my $tname= $tinfo->{name};

  $tname.= " '$tinfo->{combination}'"
    if defined $tinfo->{combination};

  _mtr_log($tname);
  printf "%-30s ", $tname;
}

sub mtr_report_test_skipped ($) {
  my $tinfo= shift;

  $tinfo->{'result'}= 'MTR_RES_SKIPPED';
  if ( $tinfo->{'disable'} )
  {
    mtr_report("[ disabled ]  $tinfo->{'comment'}");
  }
  elsif ( $tinfo->{'comment'} )
  {
    mtr_report("[ skipped ]   $tinfo->{'comment'}");
  }
  else
  {
    mtr_report("[ skipped ]");
  }
}

sub mtr_report_tests_not_skipped_though_disabled ($) {
  my $tests= shift;

  if ( $::opt_enable_disabled )
  {
    my @disabled_tests= grep {$_->{'dont_skip_though_disabled'}} @$tests;
    if ( @disabled_tests )
    {
      print "\nTest(s) which will be run though they are marked as disabled:\n";
      foreach my $tinfo ( sort {$a->{'name'} cmp $b->{'name'}} @disabled_tests )
      {
        printf "  %-20s : %s\n", $tinfo->{'name'}, $tinfo->{'comment'};
      }
    }
  }
}

sub mtr_report_test_passed ($) {
  my $tinfo= shift;

  my $timer=  "";
  if ( $::opt_timer and -f "$::opt_vardir/log/timer" )
  {
    $timer= mtr_fromfile("$::opt_vardir/log/timer");
    $tot_real_time += ($timer/1000);
    $timer= sprintf "%12s", $timer;
  }
  $tinfo->{'result'}= 'MTR_RES_PASSED';
  mtr_report("[ pass ]   $timer");
}

sub mtr_report_test_failed ($) {
  my $tinfo= shift;

  $tinfo->{'result'}= 'MTR_RES_FAILED';
  if ( defined $tinfo->{'timeout'} )
  {
    mtr_report("[ fail ]  timeout");
    return;
  }
  else
  {
    mtr_report("[ fail ]");
  }

  if ( $tinfo->{'comment'} )
  {
    # The test failure has been detected by mysql-test-run.pl
    # when starting the servers or due to other error, the reason for
    # failing the test is saved in "comment"
    mtr_report("\nERROR: $tinfo->{'comment'}");
  }
  elsif ( -f $::path_timefile )
  {
    # Test failure was detected by test tool and it's report
    # about what failed has been saved to file. Display the report.
    print "\n";
    print mtr_fromfile($::path_timefile); # FIXME print_file() instead
    print "\n";
  }
  else
  {
    # Neither this script or the test tool has recorded info
    # about why the test has failed. Should be debugged.
    mtr_report("\nUnexpected termination, probably when starting mysqld");;
  }
}

sub mtr_report_stats ($) {
  my $tests= shift;

  # ----------------------------------------------------------------------
  # Find out how we where doing
  # ----------------------------------------------------------------------

  my $tot_skiped= 0;
  my $tot_passed= 0;
  my $tot_failed= 0;
  my $tot_tests=  0;
  my $tot_restarts= 0;
  my $found_problems= 0; # Some warnings in the logfiles are errors...

  foreach my $tinfo (@$tests)
  {
    if ( $tinfo->{'result'} eq 'MTR_RES_SKIPPED' )
    {
      $tot_skiped++;
    }
    elsif ( $tinfo->{'result'} eq 'MTR_RES_PASSED' )
    {
      $tot_tests++;
      $tot_passed++;
    }
    elsif ( $tinfo->{'result'} eq 'MTR_RES_FAILED' )
    {
      $tot_tests++;
      $tot_failed++;
    }
    if ( $tinfo->{'restarted'} )
    {
      $tot_restarts++;
    }
  }

  # ----------------------------------------------------------------------
  # Print out a summary report to screen
  # ----------------------------------------------------------------------

  if ( ! $tot_failed )
  {
    print "All $tot_tests tests were successful.\n";
  }
  else
  {
    my $ratio=  $tot_passed * 100 / $tot_tests;
    print "Failed $tot_failed/$tot_tests tests, ";
    printf("%.2f", $ratio);
    print "\% were successful.\n\n";
    print
      "The log files in var/log may give you some hint\n",
      "of what went wrong.\n",
      "If you want to report this error, please read first ",
      "the documentation at\n",
      "http://dev.mysql.com/doc/mysql/en/mysql-test-suite.html\n";
  }
  if (!$::opt_extern)
  {
    print "The servers were restarted $tot_restarts times\n";
  }

  if ( $::opt_timer )
  {
    use English;

    mtr_report("Spent", sprintf("%.3f", $tot_real_time),"of",
	       time - $BASETIME, "seconds executing testcases");
  }

  # ----------------------------------------------------------------------
  # If a debug run, there might be interesting information inside
  # the "var/log/*.err" files. We save this info in "var/log/warnings"
  # ----------------------------------------------------------------------

  if ( ! $::glob_use_running_server )
  {
    # Save and report if there was any fatal warnings/errors in err logs

    my $warnlog= "$::opt_vardir/log/warnings";

    unless ( open(WARN, ">$warnlog") )
    {
      mtr_warning("can't write to the file \"$warnlog\": $!");
    }
    else
    {
      # We report different types of problems in order
      foreach my $pattern ( "^Warning:",
			    "\\[Warning\\]",
			    "\\[ERROR\\]",
			    "^Error:", "^==.* at 0x",
			    "InnoDB: Warning",
			    "InnoDB: Error",
			    "^safe_mutex:",
			    "missing DBUG_RETURN",
			    "mysqld: Warning",
			    "allocated at line",
			    "Attempting backtrace", "Assertion .* failed" )
      {
        foreach my $errlog ( sort glob("$::opt_vardir/log/*.err") )
        {
	  my $testname= "";
          unless ( open(ERR, $errlog) )
          {
            mtr_warning("can't read $errlog");
            next;
          }
          while ( <ERR> )
          {
            # Skip some non fatal warnings from the log files
            if (
		/\"SELECT UNIX_TIMESTAMP\(\)\" failed on master/ or
		/Aborted connection/ or
		/Client requested master to start replication from impossible position/ or
		/Could not find first log file name in binary log/ or
		/Enabling keys got errno/ or
		/Error reading master configuration/ or
		/Error reading packet/ or
		/Event Scheduler/ or
		/Failed to open log/ or
		/Failed to open the existing master info file/ or
		/Forcing shutdown of [0-9]* plugins/ or
                /Can't open shared library .*\bha_example\b/ or
                /Couldn't load plugin .*\bha_example\b/ or

		# Due to timing issues, it might be that this warning
		# is printed when the server shuts down and the
		# computer is loaded.
		/Forcing close of thread \d+  user: '.*?'/ or

		/Got error [0-9]* when reading table/ or
		/Incorrect definition of table/ or
		/Incorrect information in file/ or
		/InnoDB: Warning: we did not need to do crash recovery/ or
		/Invalid \(old\?\) table or database name/ or
		/Lock wait timeout exceeded/ or
		/Log entry on master is longer than max_allowed_packet/ or
                /unknown option '--loose-/ or
                /unknown variable 'loose-/ or
		/You have forced lower_case_table_names to 0 through a command-line option/ or
		/Setting lower_case_table_names=2/ or
		/NDB Binlog:/ or
		/NDB: failed to setup table/ or
		/NDB: only row based binary logging/ or
		/Neither --relay-log nor --relay-log-index were used/ or
		/Query partially completed/ or
		/Slave I.O thread aborted while waiting for relay log/ or
		/Slave SQL thread is stopped because UNTIL condition/ or
		/Slave SQL thread retried transaction/ or
		/Slave \(additional info\)/ or
		/Slave: .*Duplicate column name/ or
		/Slave: .*master may suffer from/ or
		/Slave: According to the master's version/ or
		/Slave: Column [0-9]* type mismatch/ or
		/Slave: Error .* doesn't exist/ or
		/Slave: Deadlock found/ or
		/Slave: Error .*Unknown table/ or
		/Slave: Error in Write_rows event: / or
		/Slave: Field .* of table .* has no default value/ or
                /Slave: Field .* doesn't have a default value/ or
		/Slave: Query caused different errors on master and slave/ or
		/Slave: Table .* doesn't exist/ or
		/Slave: Table width mismatch/ or
		/Slave: The incident LOST_EVENTS occured on the master/ or
		/Slave: Unknown error.* 1105/ or
		/Slave: Can't drop database.* database doesn't exist/ or
                /Slave SQL:.*(?:Error_code: \d+|Query:.*)/ or
		/Sort aborted/ or
		/Time-out in NDB/ or
		/One can only use the --user.*root/ or
		/Table:.* on (delete|rename)/ or
		/You have an error in your SQL syntax/ or
		/deprecated/ or
		/description of time zone/ or
		/equal MySQL server ids/ or
		/error .*connecting to master/ or
		/error reading log entry/ or
		/lower_case_table_names is set/ or
		/skip-name-resolve mode/ or
		/slave SQL thread aborted/ or
		/Slave: .*Duplicate entry/ or
		# Special case for Bug #26402 in show_check.test
		# Question marks are not valid file name parts
		# on Windows platforms. Ignore this error message.
		/\QCan't find file: '.\test\????????.frm'\E/ or
		# Special case, made as specific as possible, for:
		# Bug #28436: Incorrect position in SHOW BINLOG EVENTS causes
		#             server coredump
		/\QError in Log_event::read_log_event(): 'Sanity check failed', data_len: 258, event_type: 49\E/ or
                /Statement is not safe to log in statement format/ or

                # test case for Bug#bug29807 copies a stray frm into database
                /InnoDB: Error: table `test`.`bug29807` does not exist in the InnoDB internal/ or
                /InnoDB: Cannot open table test\/bug29807 from/ or

                # innodb foreign key tests that fail in ALTER or RENAME produce this
                /InnoDB: Error: in ALTER TABLE `test`.`t[12]`/ or
                /InnoDB: Error: in RENAME TABLE table `test`.`t1`/ or
                /InnoDB: Error: table `test`.`t[12]` does not exist in the InnoDB internal/ or

                # Test case for Bug#14233 produces the following warnings:
                /Stored routine 'test'.'bug14233_1': invalid value in column mysql.proc/ or
                /Stored routine 'test'.'bug14233_2': invalid value in column mysql.proc/ or
                /Stored routine 'test'.'bug14233_3': invalid value in column mysql.proc/ or

                # BUG#29839 - lowercase_table3.test: Cannot find table test/T1
                #             from the internal data dictiona
                /Cannot find table test\/BUG29839 from the internal data dictionary/ or
                # BUG#32080 - Excessive warnings on Solaris: setrlimit could not
                #             change the size of core files
                /setrlimit could not change the size of core files to 'infinity'/ or

		# rpl_extrColmaster_*.test, the slave thread produces warnings
		# when it get updates to a table that has more columns on the
		# master
		/Slave: Unknown column 'c7' in 't15' Error_code: 1054/ or
		/Slave: Can't DROP 'c7'.* 1091/ or
		/Slave: Key column 'c6'.* 1072/ or

    # Warnings generated until bug#42147 is properly resolved
    /Found lock of type 6 that is write and read locked/ or

		# rpl_idempotency.test produces warnings for the slave.
		($testname eq 'rpl.rpl_idempotency' and
		 (/Slave: Can\'t find record in \'t1\' Error_code: 1032/ or
                  /Slave: Cannot add or update a child row: a foreign key constraint fails .* Error_code: 1452/
		 )) or

		# These tests does "kill" on queries, causing sporadic errors when writing to logs
		(($testname eq 'rpl.rpl_skip_error' or
		  $testname eq 'rpl.rpl_err_ignoredtable' or
		  $testname eq 'binlog.binlog_killed_simulate' or
		  $testname eq 'binlog.binlog_killed') and
		 (/Failed to write to mysql\.\w+_log/
		 )) or

		# rpl_bug33931 has deliberate failures
		($testname eq 'rpl.rpl_bug33931' and
		 (/Failed during slave.*thread initialization/
		  )) or

		# rpl_temporary has an error on slave that can be ignored
		($testname eq 'rpl.rpl_temporary' and
		 (/Slave: Can\'t find record in \'user\' Error_code: 1032/
		 )) or

                # Test case for Bug#31590 produces the following error:
                /Out of sort memory; increase server sort buffer size/ or

                # Bug#35161, test of auto repair --myisam-recover
                /able.*_will_crash/ or

                # lowercase_table3 using case sensitive option on
                # case insensitive filesystem (InnoDB error).
                /InnoDB: Cannot open table test\/BUG29839 from/ or

                # When trying to set lower_case_table_names = 2
                # on a case sensitive file system. Bug#37402.
                /lower_case_table_names was set to 2, even though your the file system '.*' is case sensitive.  Now setting lower_case_table_names to 0 to avoid future problems./
		)
            {
              next;                       # Skip these lines
            }
	    if ( /CURRENT_TEST: (.*)/ )
	    {
	      $testname= $1;
	    }
            if ( /$pattern/ )
            {
              $found_problems= 1;
              print WARN basename($errlog) . ": $testname: $_";
            }
          }
        }
      }

      if ( $::opt_check_testcases )
      {
        # Look for warnings produced by mysqltest in testname.warnings
        foreach my $test_warning_file
	  ( glob("$::glob_mysql_test_dir/r/*.warnings") )
        {
          $found_problems= 1;
	  print WARN "Check myqltest warnings in $test_warning_file\n";
        }
      }

      if ( $found_problems )
      {
	mtr_warning("Got errors/warnings while running tests, please examine",
		    "\"$warnlog\" for details.");
      }
    }
  }

  print "\n";

  # Print a list of testcases that failed
  if ( $tot_failed != 0 )
  {
    my $test_mode= join(" ", @::glob_test_mode) || "default";
    print "mysql-test-run in $test_mode mode: *** Failing the test(s):";

    foreach my $tinfo (@$tests)
    {
      if ( $tinfo->{'result'} eq 'MTR_RES_FAILED' )
      {
        print " $tinfo->{'name'}";
      }
    }
    print "\n";

  }

  # Print a list of check_testcases that failed(if any)
  if ( $::opt_check_testcases )
  {
    my @check_testcases= ();

    foreach my $tinfo (@$tests)
    {
      if ( defined $tinfo->{'check_testcase_failed'} )
      {
	push(@check_testcases, $tinfo->{'name'});
      }
    }

    if ( @check_testcases )
    {
      print "Check of testcase failed for: ";
      print join(" ", @check_testcases);
      print "\n\n";
    }
  }

  if ( $tot_failed != 0 || $found_problems)
  {
    mtr_error("there were failing test cases");
  }
}

##############################################################################
#
#  Text formatting
#
##############################################################################

sub mtr_print_line () {
  print '-' x 55, "\n";
}

sub mtr_print_thick_line () {
  print '=' x 55, "\n";
}

sub mtr_print_header () {
  print "\n";
  if ( $::opt_timer )
  {
    print "TEST                           RESULT         TIME (ms)\n";
  }
  else
  {
    print "TEST                           RESULT\n";
  }
  mtr_print_line();
  print "\n";
}

##############################################################################
#
#  Log and reporting functions
#
##############################################################################

use IO::File;

my $log_file_ref= undef;

sub mtr_log_init ($) {
  my ($filename)= @_;

  mtr_error("Log is already open") if defined $log_file_ref;

  $log_file_ref= IO::File->new($filename, "a") or
    mtr_warning("Could not create logfile $filename: $!");
}

sub _mtr_log (@) {
  print $log_file_ref join(" ", @_),"\n"
    if defined $log_file_ref;
}

sub mtr_report (@) {
  # Print message to screen and log
  _mtr_log(@_);
  print join(" ", @_),"\n";
}

sub mtr_warning (@) {
  # Print message to screen and log
  _mtr_log("WARNING: ", @_);
  print STDERR "mysql-test-run: WARNING: ",join(" ", @_),"\n";
}

sub mtr_error (@) {
  # Print message to screen and log
  _mtr_log("ERROR: ", @_);
  print STDERR "mysql-test-run: *** ERROR: ",join(" ", @_),"\n";
  mtr_exit(1);
}

sub mtr_child_error (@) {
  # Print message to screen and log
  _mtr_log("ERROR(child): ", @_);
  print STDERR "mysql-test-run: *** ERROR(child): ",join(" ", @_),"\n";
  exit(1);
}

sub mtr_debug (@) {
  # Only print if --script-debug is used
  if ( $::opt_script_debug )
  {
    _mtr_log("###: ", @_);
    print STDERR "####: ",join(" ", @_),"\n";
  }
}

sub mtr_verbose (@) {
  # Always print to log, print to screen only when --verbose is used
  _mtr_log("> ",@_);
  if ( $::opt_verbose )
  {
    print STDERR "> ",join(" ", @_),"\n";
  }
}

1;


# -*- cperl -*-
# Copyright (c) 2006 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-1301  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;
use File::Spec;

# These are not to be prefixed with "mtr_"

sub run_stress_test ();

##############################################################################
#
#  Run tests in the stress mode
#
##############################################################################

sub run_stress_test ()
{

  my $args;
  my $stress_suitedir;

  mtr_report("Starting stress testing\n");

  if ( ! $::glob_use_embedded_server )
  {
    if ( ! mysqld_start($::master->[0],[],[]) )
    {
      mtr_error("Can't start the mysqld server");
    }
  }

  my $stress_basedir=File::Spec->catdir($::opt_vardir, "stress");

  #Clean up stress dir
  if ( -d $stress_basedir )
  {
    rmtree($stress_basedir);
  }
  mkpath($stress_basedir);

  if ($::opt_stress_suite ne 'main' && $::opt_stress_suite ne 'default' )
  {
    $stress_suitedir=File::Spec->catdir($::glob_mysql_test_dir, "suite",
                                         $::opt_stress_suite);
  }
  else
  {
    $stress_suitedir=$::glob_mysql_test_dir;
  }

  if ( -d $stress_suitedir )
  {
    #$stress_suite_t_dir=File::Spec->catdir($stress_suitedir, "t");
    #$stress_suite_r_dir=File::Spec->catdir($stress_suitedir, "r");
    #FIXME: check dirs above for existence to ensure that test suite
    #       contains tests and results dirs
  }
  else
  {
    mtr_error("Specified test suite $::opt_stress_suite doesn't exist");
  }

  if ( @::opt_cases )
  {
    $::opt_stress_test_file=File::Spec->catfile($stress_basedir, "stress_tests.txt");
    open(STRESS_FILE, ">$::opt_stress_test_file");
    print STRESS_FILE join("\n",@::opt_cases),"\n";
    close(STRESS_FILE);
  }
  elsif ( $::opt_stress_test_file )
  {
    $::opt_stress_test_file=File::Spec->catfile($stress_suitedir,
                                              $::opt_stress_test_file);
    if ( ! -f $::opt_stress_test_file )
    {
      mtr_error("Specified file $::opt_stress_test_file with list of tests does not exist\n",
                "Please ensure that file exists and has proper permissions");
    }
  }
  else
  {
    $::opt_stress_test_file=File::Spec->catfile($stress_suitedir,
                                              "stress_tests.txt");
    if ( ! -f $::opt_stress_test_file )
    {
      mtr_error("Default file $::opt_stress_test_file with list of tests does not exist\n",
          "Please use --stress-test-file option to specify custom one or you can\n",
          "just specify name of test for testing as last argument in command line");

    }
  }

  if ( $::opt_stress_init_file )
  {
    $::opt_stress_init_file=File::Spec->catfile($stress_suitedir,
                                              $::opt_stress_init_file);
    if ( ! -f $::opt_stress_init_file )
    {
      mtr_error("Specified file $::opt_stress_init_file with list of tests does not exist\n",
                "Please ensure that file exists and has proper permissions");
    }
  }
  else
  {
    $::opt_stress_init_file=File::Spec->catfile($stress_suitedir,
                                              "stress_init.txt");
    if ( ! -f $::opt_stress_init_file )
    {
      $::opt_stress_init_file='';
    }
  }

  if ( $::opt_stress_mode ne 'random' && $::opt_stress_mode ne 'seq' )
  {
    mtr_error("You specified wrong mode $::opt_stress_mode for stress test\n",
              "Correct values are 'random' or 'seq'");
  }

  mtr_init_args(\$args);

  mtr_add_arg($args, "--server-socket=%s", $::master->[0]->{'path_sock'});
  mtr_add_arg($args, "--server-user=%s", $::opt_user);
  mtr_add_arg($args, "--server-database=%s", "test");
  mtr_add_arg($args, "--stress-suite-basedir=%s", $::glob_mysql_test_dir);
  mtr_add_arg($args, "--suite=%s", $::opt_stress_suite);
  mtr_add_arg($args, "--stress-tests-file=%s", $::opt_stress_test_file);
  mtr_add_arg($args, "--stress-basedir=%s", $stress_basedir);
  mtr_add_arg($args, "--server-logs-dir=%s", $stress_basedir);
  mtr_add_arg($args, "--stress-mode=%s", $::opt_stress_mode);
  mtr_add_arg($args, "--mysqltest=%s", $::exe_mysqltest);
  mtr_add_arg($args, "--threads=%s", $::opt_stress_threads);
  mtr_add_arg($args, "--verbose");
  mtr_add_arg($args, "--cleanup");
  mtr_add_arg($args, "--log-error-details");
  mtr_add_arg($args, "--abort-on-error=1");

  if ( $::opt_stress_init_file )
  {
    mtr_add_arg($args, "--stress-init-file=%s", $::opt_stress_init_file);
  }

  if ( !$::opt_stress_loop_count && !$::opt_stress_test_count &&
       !$::opt_stress_test_duration )
  {
    #Limit stress testing with 20 loops in case when any limit parameter
    #was specified
    $::opt_stress_test_count=20;
  }

  if ( $::opt_stress_loop_count )
  {
    mtr_add_arg($args, "--loop-count=%s", $::opt_stress_loop_count);
  }

  if ( $::opt_stress_test_count )
  {
    mtr_add_arg($args, "--test-count=%s", $::opt_stress_test_count);
  }

  if ( $::opt_stress_test_duration )
  {
    mtr_add_arg($args, "--test-duration=%s", $::opt_stress_test_duration);
  }

  #Run stress test
  mtr_run("$::glob_mysql_test_dir/mysql-stress-test.pl", $args, "", "", "", "");
  if ( ! $::glob_use_embedded_server )
  {
    stop_all_servers();
  }
}

1;


# -*- cperl -*-
# Copyright (c) 2005, 2006 MySQL AB, 2008 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-1301  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 Errno;
use strict;

sub mtr_init_timers ();
sub mtr_timer_start($$$);
sub mtr_timer_stop($$);
sub mtr_timer_stop_all($);

##############################################################################
#
#  Initiate the structure shared by all timers
#
##############################################################################

sub mtr_init_timers () {
  my $timers = { timers => {}, pids => {}};
  return $timers;
}

##############################################################################
#
#  Start, stop and poll a timer
#
#  As alarm() isn't portable to Windows, we use separate processes to
#  implement timers.
#
##############################################################################

sub mtr_timer_start($$$) {
  my ($timers,$name,$duration)= @_;

  if ( exists $timers->{'timers'}->{$name} )
  {
    # We have an old running timer, kill it
    mtr_warning("There is an old timer running");
    mtr_timer_stop($timers,$name);
  }

 FORK:
  {
    my $tpid= fork();

    if ( ! defined $tpid )
    {
      if ( $! == $!{EAGAIN} )           # See "perldoc Errno"
      {
        mtr_warning("Got EAGAIN from fork(), sleep 1 second and redo");
        sleep(1);
        redo FORK;
      }
      else
      {
        mtr_error("can't fork timer, error: $!");
      }
    }

    if ( $tpid )
    {
      # Parent, record the information
      mtr_verbose("Starting timer for '$name',",
		  "duration: $duration, pid: $tpid");
      $timers->{'timers'}->{$name}->{'pid'}= $tpid;
      $timers->{'timers'}->{$name}->{'duration'}= $duration;
      $timers->{'pids'}->{$tpid}= $name;
    }
    else
    {
      # Child, install signal handlers and sleep for "duration"

      # Don't do the ^C cleanup in the timeout child processes!
      # There is actually a race here, if we get ^C after fork(), but before
      # clearing the signal handler.
      $SIG{INT}= 'DEFAULT';

      $SIG{TERM}= sub {
	mtr_verbose("timer $$ woke up, exiting!");
	exit(0);
      };

      $0= "mtr_timer(timers,$name,$duration)";
      sleep($duration);
      mtr_verbose("timer $$ expired after $duration seconds");
      exit(0);
    }
  }
}

sub mtr_timer_stop ($$) {
  my ($timers,$name)= @_;

  if ( exists $timers->{'timers'}->{$name} )
  {
    my $tpid= $timers->{'timers'}->{$name}->{'pid'};
    mtr_verbose("Stopping timer for '$name' with pid $tpid");

    # FIXME as Cygwin reuses pids fast, maybe check that is
    # the expected process somehow?!
    kill(15, $tpid);

    # As the timers are so simple programs, we trust them to terminate,
    # and use blocking wait for it. We wait just to avoid a zombie.
    waitpid($tpid,0);

    delete $timers->{'timers'}->{$name}; # Remove the timer information
    delete $timers->{'pids'}->{$tpid};   # and PID reference

    return 1;
  }

  mtr_error("Asked to stop timer '$name' not started");
}

sub mtr_timer_stop_all ($) {
  my $timers= shift;

  foreach my $name ( keys %{$timers->{'timers'}} )
  {
    mtr_timer_stop($timers, $name);
  }
  return 1;
}

sub mtr_timer_timeout ($$) {
  my ($timers,$pid)= @_;

  return "" unless exists $timers->{'pids'}->{$pid};

  # Got a timeout(the process with $pid is recorded as being a timer)
  # return the name of the timer
  return $timers->{'pids'}->{$pid};
}

1;


# -*- cperl -*-
# Copyright (c) 2006 MySQL AB, 2008 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-1301  USA

#
# This file is used from mysql-test-run.pl when choosing
# port numbers and directories to use for running mysqld.
#

use strict;
use Fcntl ':flock';

#
# Requested IDs are stored in a hash and released upon END.
#
my %mtr_unique_assigned_ids = ();
my $mtr_unique_pid;
BEGIN {
	$mtr_unique_pid = $$ unless defined $mtr_unique_pid;
}
END {
	if($mtr_unique_pid == $$) {
		while(my ($id,$file) = each(%mtr_unique_assigned_ids)) {
			print "Autoreleasing $file:$id\n";
			mtr_release_unique_id($file, $id);
		}
	}
}

#
# Require a unique, numerical ID, given a file name (where all
# requested IDs are stored), a minimum and a maximum value.
#
# We use flock to implement locking for the ID file and ignore
# possible problems arising from lack of support for it on
# some platforms (it should work on most, and the possible
# race condition would occur rarely). The proper solution for
# this is a daemon that manages IDs, of course.
#
# If no unique ID within the specified parameters can be
# obtained, return undef.
#
sub mtr_require_unique_id($$$) {
	my $file = shift;
	my $min = shift;
	my $max = shift;
	my $ret = undef;
	my $changed = 0;

	my $can_use_ps = `ps -e | grep '^[ ]*$$ '`;

	if(eval("readlink '$file'") || eval("readlink '$file.sem'")) {
		die 'lock file is a symbolic link';
	}

	chmod 0777, "$file.sem";
	open SEM, ">", "$file.sem" or die "can't write to $file.sem";
	flock SEM, LOCK_EX or die "can't lock $file.sem";
	if(! -e $file) {
		open FILE, ">", $file or die "can't create $file";
		close FILE;
	}

	if(eval("readlink '$file'") || eval("readlink '$file.sem'")) {
		die 'lock file is a symbolic link';
	}

	chmod 0777, $file;
	open FILE, "+<", $file or die "can't open $file";
	select undef,undef,undef,0.2;
	seek FILE, 0, 0;
	my %taken = ();
	while(<FILE>) {
		chomp;
		my ($id, $pid) = split / /;
		$taken{$id} = $pid;
		if($can_use_ps) {
			my $res = `ps -e | grep '^[ ]*$pid '`;
			if(!$res) {
				print "Ignoring slot $id used by missing process $pid.\n";
				delete $taken{$id};
				++$changed;
			}
		}
	}
	for(my $i=$min; $i<=$max; ++$i) {
		if(! exists $taken{$i}) {
			$ret = $i;
			$taken{$i} = $$;
			++$changed;
			last;
		}
	}
	if($changed) {
		seek FILE, 0, 0;
		truncate FILE, 0 or die "can't truncate $file";
		for my $k (keys %taken) {
			print FILE $k . ' ' . $taken{$k} . "\n";
		}
	}
	close FILE;
	flock SEM, LOCK_UN or warn "can't unlock $file.sem";
	close SEM;
	$mtr_unique_assigned_ids{$ret} = $file if defined $ret;
	return $ret;
}

#
# Require a unique ID like above, but sleep if no ID can be
# obtained immediately.
#
sub mtr_require_unique_id_and_wait($$$) {
	my $ret = mtr_require_unique_id($_[0],$_[1],$_[2]);
	while(! defined $ret) {
		sleep 30;
		$ret = mtr_require_unique_id($_[0],$_[1],$_[2]);
		print "Waiting for unique id to become available...\n" unless $ret;
	}
	return $ret;
}

#
# Release a unique ID.
#
sub mtr_release_unique_id($$) {
	my $file = shift;
	my $myid = shift;

	if(eval("readlink '$file'") || eval("readlink '$file.sem'")) {
		die 'lock file is a symbolic link';
	}

	open SEM, ">", "$file.sem" or die "can't write to $file.sem";
	flock SEM, LOCK_EX or die "can't lock $file.sem";

	if(eval("readlink '$file'") || eval("readlink '$file.sem'")) {
		die 'lock file is a symbolic link';
	}

	if(! -e $file) {
		open FILE, ">", $file or die "can't create $file";
		close FILE;
	}
	open FILE, "+<", $file or die "can't open $file";
	select undef,undef,undef,0.2;
	seek FILE, 0, 0;
	my %taken = ();
	while(<FILE>) {
		chomp;
		my ($id, $pid) = split / /;
		$taken{$id} = $pid;
	}
	delete $taken{$myid};
	seek FILE, 0, 0;
	truncate FILE, 0 or die "can't truncate $file";
	for my $k (keys %taken) {
		print FILE $k . ' ' . $taken{$k} . "\n";
	}
	close FILE;
	flock SEM, LOCK_UN or warn "can't unlock $file.sem";
	close SEM;
	delete $mtr_unique_assigned_ids{$myid};
}

1;