WL#4189 Add full backward compatibility to mysql-test-run.pl

 - Add copy of mtr v1 and make it possible to run it using MTR_VERSION=1

mysql-test/Makefile.am

@@ -24,7 +24,25 @@ test_SCRIPTS =	mtr \
 		mysql-test-run.pl \
 		mysql-stress-test.pl
 
-nobase_test_DATA = lib/mtr_cases.pm \
+nobase_test_DATA = \
+	lib/v1/mysql-test-run.pl \
+	lib/v1/mtr_cases.pl \
+	lib/v1/mtr_io.pl \
+	lib/v1/mtr_report.pl \
+	lib/v1/My/Config.pm \
+	lib/v1/mtr_gcov.pl \
+	lib/v1/mtr_match.pl \
+	lib/v1/mtr_stress.pl \
+	lib/v1/ndb_config_1_node.ini \
+	lib/v1/ndb_config_2_node.ini \
+	lib/v1/mtr_gprof.pl \
+	lib/v1/mtr_misc.pl \
+	lib/v1/mtr_timer.pl \
+	lib/v1/mtr_im.pl \
+	lib/v1/mtr_process.pl \
+	lib/v1/mtr_unique.pl \
+\
+	lib/mtr_cases.pm \
 	lib/mtr_gcov.pl \
 	lib/mtr_gprof.pl \
 	lib/mtr_io.pl \

mysql-test/lib/v1/My/Config.pm

+# -*- cperl -*-
+
+package My::Config::Option;
+
+use strict;
+use warnings;
+
+
+sub new {
+  my ($class, $option_name, $option_value)= @_;
+  my $self= bless { name => $option_name,
+		    value => $option_value
+		  }, $class;
+  return $self;
+}
+
+
+sub name {
+  my ($self)= @_;
+  return $self->{name};
+}
+
+
+sub value {
+  my ($self)= @_;
+  return $self->{value};
+}
+
+
+package My::Config::Group;
+
+use strict;
+use warnings;
+
+
+sub new {
+  my ($class, $group_name)= @_;
+  my $self= bless { name => $group_name,
+		    options => [],
+		    options_by_name => {},
+		  }, $class;
+  return $self;
+}
+
+
+sub insert {
+  my ($self, $option_name, $value, $if_not_exist)= @_;
+  my $option= $self->option($option_name);
+  if (defined($option) and !$if_not_exist) {
+    $option->{value}= $value;
+  }
+  else {
+    my $option= My::Config::Option->new($option_name, $value);
+    # Insert option in list
+    push(@{$self->{options}}, $option);
+    # Insert option in hash
+    $self->{options_by_name}->{$option_name}= $option;
+  }
+  return $option;
+}
+
+sub remove {
+  my ($self, $option_name)= @_;
+
+  # Check that option exists
+  my $option= $self->option($option_name);
+
+  return undef unless defined $option;
+
+  # Remove from the hash
+  delete($self->{options_by_name}->{$option_name}) or die;
+
+  # Remove from the array
+  @{$self->{options}}= grep { $_->name ne $option_name } @{$self->{options}};
+
+  return $option;
+}
+
+
+sub options {
+  my ($self)= @_;
+  return @{$self->{options}};
+}
+
+
+sub name {
+  my ($self)= @_;
+  return $self->{name};
+}
+
+
+#
+# Return a specific option in the group
+#
+sub option {
+  my ($self, $option_name)= @_;
+
+  return $self->{options_by_name}->{$option_name};
+}
+
+
+#
+# Return a specific value for an option in the group
+#
+sub value {
+  my ($self, $option_name)= @_;
+  my $option= $self->option($option_name);
+
+  die "No option named '$option_name' in this group"
+    if ! defined($option);
+
+  return $option->value();
+}
+
+
+package My::Config;
+
+use strict;
+use warnings;
+use IO::File;
+use File::Basename;
+
+#
+# Constructor for My::Config
+# - represents a my.cnf config file
+#
+# Array of arrays
+#
+sub new {
+  my ($class, $path)= @_;
+  my $group_name= undef;
+
+  my $self= bless { groups => [] }, $class;
+  my $F= IO::File->new($path, "<")
+    or die "Could not open '$path': $!";
+
+  while (  my $line= <$F> ) {
+    chomp($line);
+
+    # [group]
+    if ( $line =~ /\[(.*)\]/ ) {
+      # New group found
+      $group_name= $1;
+      #print "group: $group_name\n";
+
+      $self->insert($group_name, undef, undef);
+    }
+
+    # Magic #! comments
+    elsif ( $line =~ /^#\!/) {
+      my $magic= $line;
+      die "Found magic comment '$magic' outside of group"
+	unless $group_name;
+
+      #print "$magic\n";
+      $self->insert($group_name, $magic, undef);
+    }
+
+    # Comments
+    elsif ( $line =~ /^#/ || $line =~ /^;/) {
+      # Skip comment
+      next;
+    }
+
+    # Empty lines
+    elsif ( $line =~ /^$/ ) {
+      # Skip empty lines
+      next;
+    }
+
+    # !include <filename>
+    elsif ( $line =~ /^\!include\s*(.*?)\s*$/ ) {
+      my $include_file_name= dirname($path)."/".$1;
+      # Check that the file exists
+      die "The include file '$include_file_name' does not exist"
+	unless -f $include_file_name;
+
+      $self->append(My::Config->new($include_file_name));
+    }
+
+    # <option>
+    elsif ( $line =~ /^([\@\w-]+)\s*$/ ) {
+      my $option= $1;
+
+      die "Found option '$option' outside of group"
+	unless $group_name;
+
+      #print "$option\n";
+      $self->insert($group_name, $option, undef);
+    }
+
+    # <option>=<value>
+    elsif ( $line =~ /^([\@\w-]+)\s*=\s*(.*?)\s*$/ ) {
+      my $option= $1;
+      my $value= $2;
+
+      die "Found option '$option=$value' outside of group"
+	unless $group_name;
+
+      #print "$option=$value\n";
+      $self->insert($group_name, $option, $value);
+    } else {
+      die "Unexpected line '$line' found in '$path'";
+    }
+
+  }
+  undef $F;			# Close the file
+
+  return $self;
+}
+
+#
+# Insert a new group if it does not already exist
+# and add option if defined
+#
+sub insert {
+  my ($self, $group_name, $option, $value, $if_not_exist)= @_;
+  my $group;
+
+  # Create empty array for the group if it doesn't exist
+  if ( !$self->group_exists($group_name) ) {
+    $group= $self->_group_insert($group_name);
+  }
+  else {
+    $group= $self->group($group_name);
+  }
+
+  if ( defined $option ) {
+    #print "option: $option, value: $value\n";
+
+    # Add the option to the group
+    $group->insert($option, $value, $if_not_exist);
+  }
+}
+
+#
+# Remove a option, given group and option name
+#
+sub remove {
+  my ($self, $group_name, $option_name)= @_;
+  my $group= $self->group($group_name);
+
+  die "group '$group_name' does not exist"
+    unless defined($group);
+
+  $group->remove($option_name) or
+    die "option '$option_name' does not exist";
+}
+
+
+
+#
+# Check if group with given name exists in config
+#
+sub group_exists {
+  my ($self, $group_name)= @_;
+
+  foreach my $group ($self->groups()) {
+    return 1 if $group->{name} eq $group_name;
+  }
+  return 0;
+}
+
+
+#
+# Insert a new group into config
+#
+sub _group_insert {
+  my ($self, $group_name)= @_;
+  caller eq __PACKAGE__ or die;
+
+  # Check that group does not already exist
+  die "Group already exists" if $self->group_exists($group_name);
+
+  my $group= My::Config::Group->new($group_name);
+  push(@{$self->{groups}}, $group);
+  return $group;
+}
+
+
+#
+# Append a configuration to current config
+#
+sub append {
+  my ($self, $from)= @_;
+
+  foreach my $group ($from->groups()) {
+    foreach my $option ($group->options()) {
+      $self->insert($group->name(), $option->name(), $option->value());
+    }
+
+  }
+}
+
+
+#
+# Return a list with all the groups in config
+#
+sub groups {
+  my ($self)= @_;
+  return ( @{$self->{groups}} );
+}
+
+
+#
+# Return a list of all the groups in config
+# starting with the given string
+#
+sub like {
+  my ($self, $prefix)= @_;
+  return ( grep ( $_->{name} =~ /^$prefix/, $self->groups()) );
+}
+
+
+#
+# Return the first group in config
+# starting with the given string
+#
+sub first_like {
+  my ($self, $prefix)= @_;
+  return ($self->like($prefix))[0];
+}
+
+
+#
+# Return a specific group in the config
+#
+sub group {
+  my ($self, $group_name)= @_;
+
+  foreach my $group ( $self->groups() ) {
+    return $group if $group->{name} eq $group_name;
+  }
+  return undef;
+}
+
+
+#
+# Return a list of all options in a specific group in the config
+#
+sub options_in_group {
+  my ($self, $group_name)= @_;
+
+  my $group= $self->group($group_name);
+  return () unless defined $group;
+  return $group->options();
+}
+
+
+#
+# Return a value given group and option name
+#
+sub value {
+  my ($self, $group_name, $option_name)= @_;
+  my $group= $self->group($group_name);
+
+  die "group '$group_name' does not exist"
+    unless defined($group);
+
+  my $option= $group->option($option_name);
+  die "option '$option_name' does not exist"
+    unless defined($option);
+
+  return $option->value();
+}
+
+
+#
+# Check if an option exists
+#
+sub exists {
+  my ($self, $group_name, $option_name)= @_;
+  my $group= $self->group($group_name);
+
+  die "group '$group_name' does not exist"
+    unless defined($group);
+
+  my $option= $group->option($option_name);
+  return defined($option);
+}
+
+
+# Overload "to string"-operator with 'stringify'
+use overload
+    '""' => \&stringify;
+
+#
+# Return the config as a string in my.cnf file format
+#
+sub stringify {
+  my ($self)= @_;
+  my $res;
+
+  foreach my $group ($self->groups()) {
+    $res .= "[$group->{name}]\n";
+
+    foreach my $option ($group->options()) {
+      $res .= $option->name();
+      my $value= $option->value();
+      if (defined $value) {
+	$res .= "=$value";
+      }
+      $res .= "\n";
+    }
+    $res .= "\n";
+  }
+  return $res;
+}
+
+
+#
+# Save the config to named file
+#
+sub save {
+    my ($self, $path)= @_;
+    my $F= IO::File->new($path, ">")
+	or die "Could not open '$path': $!";
+    print $F $self;
+    undef $F; # Close the file
+}
+
+1;

mysql-test/lib/v1/mtr_cases.pl

+# -*- cperl -*-
+# Copyright (C) 2005-2006 MySQL AB
+# 
+# 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 File::Basename;
+use IO::File();
+use strict;
+
+use My::Config;
+
+sub collect_test_cases ($);
+sub collect_one_suite ($);
+sub collect_one_test_case ($$$$$$$$$);
+
+sub mtr_options_from_test_file($$);
+
+my $do_test;
+my $skip_test;
+
+sub init_pattern {
+  my ($from, $what)= @_;
+  if ( $from =~ /^[a-z0-9]$/ ) {
+    # Does not contain any regex, make the pattern match
+    # beginning of string
+    $from= "^$from";
+  }
+  # Check that pattern is a valid regex
+  eval { "" =~/$from/; 1 } or
+    mtr_error("Invalid regex '$from' passed to $what\nPerl says: $@");
+  return $from;
+}
+
+
+
+##############################################################################
+#
+#  Collect information about test cases we are to run
+#
+##############################################################################
+
+sub collect_test_cases ($) {
+  $do_test= init_pattern($::opt_do_test, "--do-test");
+  $skip_test= init_pattern($::opt_skip_test, "--skip-test");
+
+  my $suites= shift; # Semicolon separated list of test suites
+  my $cases = [];    # Array of hash
+
+  foreach my $suite (split(",", $suites))
+  {
+    push(@$cases, collect_one_suite($suite));
+  }
+
+
+  if ( @::opt_cases )
+  {
+    # Check that the tests specified was found
+    # in at least one suite
+    foreach my $test_name_spec ( @::opt_cases )
+    {
+      my $found= 0;
+      my ($sname, $tname, $extension)= split_testname($test_name_spec);
+      foreach my $test ( @$cases )
+      {
+	# test->{name} is always in suite.name format
+	if ( $test->{name} =~ /.*\.$tname/ )
+	{
+	  $found= 1;
+	}
+      }
+      if ( not $found )
+      {
+	mtr_error("Could not find $tname in any suite");
+      }
+    }
+  }
+
+  if ( $::opt_reorder )
+  {
+    # Reorder the test cases in an order that will make them faster to run
+    my %sort_criteria;
+
+    # Make a mapping of test name to a string that represents how that test
+    # should be sorted among the other tests.  Put the most important criterion
+    # first, then a sub-criterion, then sub-sub-criterion, et c.
+    foreach my $tinfo (@$cases)
+    {
+      my @criteria = ();
+
+      # Look for tests that muct be in run in a defined order
+      # that is defined by test having the same name except for
+      # the ending digit
+
+      # Put variables into hash
+      my $test_name= $tinfo->{'name'};
+      my $depend_on_test_name;
+      if ( $test_name =~ /^([\D]+)([0-9]{1})$/ )
+      {
+	my $base_name= $1;
+	my $idx= $2;
+	mtr_verbose("$test_name =>  $base_name idx=$idx");
+	if ( $idx > 1 )
+	{
+	  $idx-= 1;
+	  $base_name= "$base_name$idx";
+	  mtr_verbose("New basename $base_name");
+	}
+
+	foreach my $tinfo2 (@$cases)
+	{
+	  if ( $tinfo2->{'name'} eq $base_name )
+	  {
+	    mtr_verbose("found dependent test $tinfo2->{'name'}");
+	    $depend_on_test_name=$base_name;
+	  }
+	}
+      }
+
+      if ( defined $depend_on_test_name )
+      {
+	mtr_verbose("Giving $test_name same critera as $depend_on_test_name");
+	$sort_criteria{$test_name} = $sort_criteria{$depend_on_test_name};
+      }
+      else
+      {
+	#
+	# Append the criteria for sorting, in order of importance.
+	#
+	push(@criteria, "ndb=" . ($tinfo->{'ndb_test'} ? "1" : "0"));
+	# Group test with equal options together.
+	# Ending with "~" makes empty sort later than filled
+	push(@criteria, join("!", sort @{$tinfo->{'master_opt'}}) . "~");
+
+	$sort_criteria{$test_name} = join(" ", @criteria);
+      }
+    }
+
+    @$cases = sort {
+      $sort_criteria{$a->{'name'}} . $a->{'name'} cmp
+	$sort_criteria{$b->{'name'}} . $b->{'name'}; } @$cases;
+
+    if ( $::opt_script_debug )
+    {
+      # For debugging the sort-order
+      foreach my $tinfo (@$cases)
+      {
+	print("$sort_criteria{$tinfo->{'name'}} -> \t$tinfo->{'name'}\n");
+      }
+    }
+  }
+
+  return $cases;
+
+}
+
+# Valid extensions and their corresonding component id
+my %exts = ( 'test' => 'mysqld',
+	     'imtest' => 'im'
+	   );
+
+
+# Returns (suitename, testname, extension)
+sub split_testname {
+  my ($test_name)= @_;
+
+  # Get rid of directory part and split name on .'s
+  my @parts= split(/\./, basename($test_name));
+
+  if (@parts == 1){
+    # Only testname given, ex: alias
+    return (undef , $parts[0], undef);
+  } elsif (@parts == 2) {
+    # Either testname.test or suite.testname given
+    # Ex. main.alias or alias.test
+
+    if (defined $exts{$parts[1]})
+    {
+      return (undef , $parts[0], $parts[1]);
+    }
+    else
+    {
+      return ($parts[0], $parts[1], undef);
+    }
+
+  } elsif (@parts == 3) {
+    # Fully specified suitename.testname.test
+    # ex main.alias.test
+    return ( $parts[0], $parts[1], $parts[2]);
+  }
+
+  mtr_error("Illegal format of test name: $test_name");
+}
+
+
+sub collect_one_suite($)
+{
+  my $suite= shift;  # Test suite name
+  my @cases;  # Array of hash
+
+  mtr_verbose("Collecting: $suite");
+
+  my $suitedir= "$::glob_mysql_test_dir"; # Default
+  if ( $suite ne "main" )
+  {
+    $suitedir= mtr_path_exists("$suitedir/suite/$suite",
+			       "$suitedir/$suite");
+    mtr_verbose("suitedir: $suitedir");
+  }
+
+  my $testdir= "$suitedir/t";
+  my $resdir=  "$suitedir/r";
+
+  # ----------------------------------------------------------------------
+  # Build a hash of disabled testcases for this suite
+  # ----------------------------------------------------------------------
+  my %disabled;
+  if ( open(DISABLED, "$testdir/disabled.def" ) )
+  {
+    while ( <DISABLED> )
+      {
+        chomp;
+        if ( /^\s*(\S+)\s*:\s*(.*?)\s*$/ )
+          {
+            $disabled{$1}= $2;
+          }
+      }
+    close DISABLED;
+  }
+
+  # Read suite.opt file
+  my $suite_opt_file=  "$testdir/suite.opt";
+  my $suite_opts= [];
+  if ( -f $suite_opt_file )
+  {
+    $suite_opts= mtr_get_opts_from_file($suite_opt_file);
+  }
+
+  if ( @::opt_cases )
+  {
+    # Collect in specified order
+    foreach my $test_name_spec ( @::opt_cases )
+    {
+      my ($sname, $tname, $extension)= split_testname($test_name_spec);
+
+      # The test name parts have now been defined
+      #print "  suite_name: $sname\n";
+      #print "  tname:      $tname\n";
+      #print "  extension:  $extension\n";
+
+      # Check cirrect suite if suitename is defined
+      next if (defined $sname and $suite ne $sname);
+
+      my $component_id;
+      if ( defined $extension )
+      {
+	my $full_name= "$testdir/$tname.$extension";
+	# Extension was specified, check if the test exists
+        if ( ! -f $full_name)
+        {
+	  # This is only an error if suite was specified, otherwise it
+	  # could exist in another suite
+          mtr_error("Test '$full_name' was not found in suite '$sname'")
+	    if $sname;
+
+	  next;
+        }
+	$component_id= $exts{$extension};
+      }
+      else
+      {
+	# No extension was specified
+	my ($ext, $component);
+	while (($ext, $component)= each %exts) {
+	  my $full_name= "$testdir/$tname.$ext";
+
+	  if ( ! -f $full_name ) {
+	    next;
+	  }
+	  $component_id= $component;
+	  $extension= $ext;
+	}
+	# Test not found here, could exist in other suite
+	next unless $component_id;
+      }
+
+      collect_one_test_case($testdir,$resdir,$suite,$tname,
+                            "$tname.$extension",\@cases,\%disabled,
+			    $component_id,$suite_opts);
+    }
+  }
+  else
+  {
+    opendir(TESTDIR, $testdir) or mtr_error("Can't open dir \"$testdir\": $!");
+
+    foreach my $elem ( sort readdir(TESTDIR) )
+    {
+      my $component_id= undef;
+      my $tname= undef;
+
+      if ($tname= mtr_match_extension($elem, 'test'))
+      {
+        $component_id = 'mysqld';
+      }
+      elsif ($tname= mtr_match_extension($elem, 'imtest'))
+      {
+        $component_id = 'im';
+      }
+      else
+      {
+        next;
+      }
+
+      # Skip tests that does not match the --do-test= filter
+      next if ($do_test and not $tname =~ /$do_test/o);
+
+      collect_one_test_case($testdir,$resdir,$suite,$tname,
+                            $elem,\@cases,\%disabled,$component_id,
+			    $suite_opts);
+    }
+    closedir TESTDIR;
+  }
+
+
+  #  Return empty list if no testcases found
+  return if (@cases == 0);
+
+  # ----------------------------------------------------------------------
+  # Read combinations for this suite and build testcases x combinations
+  # if any combinations exists
+  # ----------------------------------------------------------------------
+  if ( ! $::opt_skip_combination )
+  {
+    my @combinations;
+    my $combination_file= "$suitedir/combinations";
+    #print "combination_file: $combination_file\n";
+    if (@::opt_combinations)
+    {
+      # take the combination from command-line
+      mtr_verbose("Take the combination from command line");
+      foreach my $combination (@::opt_combinations) {
+	my $comb= {};
+	$comb->{name}= $combination;
+	push(@{$comb->{comb_opt}}, $combination);
+	push(@combinations, $comb);
+      }
+    }
+    elsif (-f $combination_file )
+    {
+      # Read combinations file in my.cnf format
+      mtr_verbose("Read combinations file");
+      my $config= My::Config->new($combination_file);
+
+      foreach my $group ($config->groups()) {
+	my $comb= {};
+	$comb->{name}= $group->name();
+        foreach my $option ( $group->options() ) {
+	  push(@{$comb->{comb_opt}}, $option->name()."=".$option->value());
+	}
+	push(@combinations, $comb);
+      }
+    }
+
+    if (@combinations)
+    {
+      print " - adding combinations\n";
+      #print_testcases(@cases);
+
+      my @new_cases;
+      foreach my $comb (@combinations)
+      {
+	foreach my $test (@cases)
+	{
+	  #print $test->{name}, " ", $comb, "\n";
+	  my $new_test= {};
+
+	  while (my ($key, $value) = each(%$test)) {
+	    if (ref $value eq "ARRAY") {
+	      push(@{$new_test->{$key}}, @$value);
+	    } else {
+	      $new_test->{$key}= $value;
+	    }
+	  }
+
+	  # Append the combination options to master_opt and slave_opt
+	  push(@{$new_test->{master_opt}}, @{$comb->{comb_opt}});
+	  push(@{$new_test->{slave_opt}}, @{$comb->{comb_opt}});
+
+	  # Add combination name shrt name
+	  $new_test->{combination}= $comb->{name};
+
+	  # Add the new test to new test cases list
+	  push(@new_cases, $new_test);
+	}
+      }
+      #print_testcases(@new_cases);
+      @cases= @new_cases;
+      #print_testcases(@cases);
+    }
+  }
+
+  optimize_cases(\@cases);
+  #print_testcases(@cases);
+
+  return @cases;
+}
+
+
+#
+# Loop through all test cases
+# - optimize which test to run by skipping unnecessary ones
+# - update settings if necessary
+#
+sub optimize_cases {
+  my ($cases)= @_;
+
+  foreach my $tinfo ( @$cases )
+  {
+    # Skip processing if already marked as skipped
+    next if $tinfo->{skip};
+
+    # =======================================================
+    # If a special binlog format was selected with
+    # --mysqld=--binlog-format=x, skip all test that does not
+    # support it
+    # =======================================================
+    #print "used_binlog_format: $::used_binlog_format\n";
+    if (defined $::used_binlog_format )
+    {
+      # =======================================================
+      # Fixed --binlog-format=x specified on command line
+      # =======================================================
+      if ( defined $tinfo->{'binlog_formats'} )
+      {
+	#print "binlog_formats: ". join(", ", @{$tinfo->{binlog_formats}})."\n";
+
+	# The test supports different binlog formats
+	# check if the selected one is ok
+	my $supported=
+	  grep { $_ eq $::used_binlog_format } @{$tinfo->{'binlog_formats'}};
+	if ( !$supported )
+	{
+	  $tinfo->{'skip'}= 1;
+	  $tinfo->{'comment'}=
+	    "Doesn't support --binlog-format='$::used_binlog_format'";
+	}
+      }
+    }
+    else
+    {
+      # =======================================================
+      # Use dynamic switching of binlog format
+      # =======================================================
+
+      # Get binlog-format used by this test from master_opt
+      my $test_binlog_format;
+      foreach my $opt ( @{$tinfo->{master_opt}} ) {
+	$test_binlog_format=
+	  mtr_match_prefix($opt, "--binlog-format=") || $test_binlog_format;
+      }
+
+      if (defined $test_binlog_format and
+	  defined $tinfo->{binlog_formats} )
+      {
+	my $supported=
+	  grep { $_ eq $test_binlog_format } @{$tinfo->{'binlog_formats'}};
+	if ( !$supported )
+	{
+	  $tinfo->{'skip'}= 1;
+	  $tinfo->{'comment'}=
+	    "Doesn't support --binlog-format='$test_binlog_format'";
+	  next;
+	}
+      }
+    }
+
+  }
+}
+
+
+##############################################################################
+#
+#  Collect information about a single test case
+#
+##############################################################################
+
+
+sub collect_one_test_case($$$$$$$$$) {
+  my $testdir= shift;
+  my $resdir=  shift;
+  my $suite=   shift;
+  my $tname=   shift;
+  my $elem=    shift;
+  my $cases=   shift;
+  my $disabled=shift;
+  my $component_id= shift;
+  my $suite_opts= shift;
+
+  my $path= "$testdir/$elem";
+
+  # ----------------------------------------------------------------------
+  # Skip some tests silently
+  # ----------------------------------------------------------------------
+
+  if ( $::opt_start_from and $tname lt $::opt_start_from )
+  {
+    return;
+  }
+
+
+  my $tinfo= {};
+  $tinfo->{'name'}= basename($suite) . ".$tname";
+  $tinfo->{'result_file'}= "$resdir/$tname.result";
+  $tinfo->{'component_id'} = $component_id;
+  push(@$cases, $tinfo);
+
+  # ----------------------------------------------------------------------
+  # Skip some tests but include in list, just mark them to skip
+  # ----------------------------------------------------------------------
+
+  if ( $skip_test and $tname =~ /$skip_test/o )
+  {
+    $tinfo->{'skip'}= 1;
+    return;
+  }
+
+  # ----------------------------------------------------------------------
+  # Collect information about test case
+  # ----------------------------------------------------------------------
+
+  $tinfo->{'path'}= $path;
+  $tinfo->{'timezone'}= "GMT-3"; # for UNIX_TIMESTAMP tests to work
+
+  $tinfo->{'slave_num'}= 0; # Default, no slave
+  $tinfo->{'master_num'}= 1; # Default, 1 master
+  if ( defined mtr_match_prefix($tname,"rpl") )
+  {
+    if ( $::opt_skip_rpl )
+    {
+      $tinfo->{'skip'}= 1;
+      $tinfo->{'comment'}= "No replication tests(--skip-rpl)";
+      return;
+    }
+
+    $tinfo->{'slave_num'}= 1; # Default for rpl* tests, use one slave
+
+  }
+
+  if ( defined mtr_match_prefix($tname,"federated") )
+  {
+    # Default, federated uses the first slave as it's federated database
+    $tinfo->{'slave_num'}= 1;
+  }
+
+  my $master_opt_file= "$testdir/$tname-master.opt";
+  my $slave_opt_file=  "$testdir/$tname-slave.opt";
+  my $slave_mi_file=   "$testdir/$tname.slave-mi";
+  my $master_sh=       "$testdir/$tname-master.sh";
+  my $slave_sh=        "$testdir/$tname-slave.sh";
+  my $disabled_file=   "$testdir/$tname.disabled";
+  my $im_opt_file=     "$testdir/$tname-im.opt";
+
+  $tinfo->{'master_opt'}= [];
+  $tinfo->{'slave_opt'}=  [];
+  $tinfo->{'slave_mi'}=   [];
+
+
+  # Add suite opts
+  foreach my $opt ( @$suite_opts )
+  {
+    mtr_verbose($opt);
+    push(@{$tinfo->{'master_opt'}}, $opt);
+    push(@{$tinfo->{'slave_opt'}}, $opt);
+  }
+
+  # Add master opts
+  if ( -f $master_opt_file )
+  {
+
+    my $master_opt= mtr_get_opts_from_file($master_opt_file);
+
+    foreach my $opt ( @$master_opt )
+    {
+      my $value;
+
+      # The opt file is used both to send special options to the mysqld
+      # as well as pass special test case specific options to this
+      # script
+
+      $value= mtr_match_prefix($opt, "--timezone=");
+      if ( defined $value )
+      {
+	$tinfo->{'timezone'}= $value;
+	next;
+      }
+
+      $value= mtr_match_prefix($opt, "--slave-num=");
+      if ( defined $value )
+      {
+	$tinfo->{'slave_num'}= $value;
+	next;
+      }
+
+      $value= mtr_match_prefix($opt, "--result-file=");
+      if ( defined $value )
+      {
+	# Specifies the file mysqltest should compare
+	# output against
+	$tinfo->{'result_file'}= "r/$value.result";
+	next;
+      }
+
+      # If we set default time zone, remove the one we have
+      $value= mtr_match_prefix($opt, "--default-time-zone=");
+      if ( defined $value )
+      {
+	# Set timezone for this test case to something different
+	$tinfo->{'timezone'}= "GMT-8";
+	# Fallthrough, add the --default-time-zone option
+      }
+
+      # The --restart option forces a restart even if no special
+      # option is set. If the options are the same as next testcase
+      # there is no need to restart after the testcase
+      # has completed
+      if ( $opt eq "--force-restart" )
+      {
+	$tinfo->{'force_restart'}= 1;
+	next;
+      }
+
+      # Ok, this was a real option, add it
+      push(@{$tinfo->{'master_opt'}}, $opt);
+    }
+  }
+
+  # Add slave opts
+  if ( -f $slave_opt_file )
+  {
+    my $slave_opt= mtr_get_opts_from_file($slave_opt_file);
+
+    foreach my $opt ( @$slave_opt )
+    {
+      # If we set default time zone, remove the one we have
+      my $value= mtr_match_prefix($opt, "--default-time-zone=");
+      $tinfo->{'slave_opt'}= [] if defined $value;
+    }
+    push(@{$tinfo->{'slave_opt'}}, @$slave_opt);
+  }
+
+  if ( -f $slave_mi_file )
+  {
+    $tinfo->{'slave_mi'}= mtr_get_opts_from_file($slave_mi_file);
+  }
+
+  if ( -f $master_sh )
+  {
+    if ( $::glob_win32_perl )
+    {
+      $tinfo->{'skip'}= 1;
+      $tinfo->{'comment'}= "No tests with sh scripts on Windows";
+      return;
+    }
+    else
+    {
+      $tinfo->{'master_sh'}= $master_sh;
+    }
+  }
+
+  if ( -f $slave_sh )
+  {
+    if ( $::glob_win32_perl )
+    {
+      $tinfo->{'skip'}= 1;
+      $tinfo->{'comment'}= "No tests with sh scripts on Windows";
+      return;
+    }
+    else
+    {
+      $tinfo->{'slave_sh'}= $slave_sh;
+    }
+  }
+
+  if ( -f $im_opt_file )
+  {
+    $tinfo->{'im_opts'} = mtr_get_opts_from_file($im_opt_file);
+  }
+  else
+  {
+    $tinfo->{'im_opts'} = [];
+  }
+
+  # FIXME why this late?
+  my $marked_as_disabled= 0;
+  if ( $disabled->{$tname} )
+  {
+    $marked_as_disabled= 1;
+    $tinfo->{'comment'}= $disabled->{$tname};
+  }
+
+  if ( -f $disabled_file )
+  {
+    $marked_as_disabled= 1;
+    $tinfo->{'comment'}= mtr_fromfile($disabled_file);
+  }
+
+  # If test was marked as disabled, either opt_enable_disabled is off and then
+  # we skip this test, or it is on and then we run this test but warn
+
+  if ( $marked_as_disabled )
+  {
+    if ( $::opt_enable_disabled )
+    {
+      $tinfo->{'dont_skip_though_disabled'}= 1;
+    }
+    else
+    {
+      $tinfo->{'skip'}= 1;
+      $tinfo->{'disable'}= 1;   # Sub type of 'skip'
+      return;
+    }
+  }
+
+  if ( $component_id eq 'im' )
+  {
+    if ( $::glob_use_embedded_server )
+    {
+      $tinfo->{'skip'}= 1;
+      $tinfo->{'comment'}= "No IM with embedded server";
+      return;
+    }
+    elsif ( $::opt_ps_protocol )
+    {
+      $tinfo->{'skip'}= 1;
+      $tinfo->{'comment'}= "No IM with --ps-protocol";
+      return;
+    }
+    elsif ( $::opt_skip_im )
+    {
+      $tinfo->{'skip'}= 1;
+      $tinfo->{'comment'}= "No IM tests(--skip-im)";
+      return;
+    }
+  }
+  else
+  {
+    mtr_options_from_test_file($tinfo,"$testdir/${tname}.test");
+
+    if ( defined $::used_default_engine )
+    {
+      # Different default engine is used
+      # tag test to require that engine
+      $tinfo->{'ndb_test'}= 1
+	if ( $::used_default_engine =~ /^ndb/i );
+
+      $tinfo->{'innodb_test'}= 1
+	if ( $::used_default_engine =~ /^innodb/i );
+    }
+
+    #enable federated for this test
+    if ($tinfo->{'federated_test'})
+    {
+      push(@{$tinfo->{'master_opt'}}, "--loose-federated");
+      push(@{$tinfo->{'slave_opt'}}, "--loose-federated");
+    }
+
+    if ( $tinfo->{'big_test'} and ! $::opt_big_test )
+    {
+      $tinfo->{'skip'}= 1;
+      $tinfo->{'comment'}= "Test need 'big-test' option";
+      return;
+    }
+
+    if ( $tinfo->{'ndb_extra'} and ! $::opt_ndb_extra_test )
+    {
+      $tinfo->{'skip'}= 1;
+      $tinfo->{'comment'}= "Test need 'ndb_extra' option";
+      return;
+    }
+
+    if ( $tinfo->{'require_manager'} )
+    {
+      $tinfo->{'skip'}= 1;
+      $tinfo->{'comment'}= "Test need the _old_ manager(to be removed)";
+      return;
+    }
+
+    if ( $tinfo->{'need_debug'} && ! $::debug_compiled_binaries )
+    {
+      $tinfo->{'skip'}= 1;
+      $tinfo->{'comment'}= "Test need debug binaries";
+      return;
+    }
+
+    if ( $tinfo->{'ndb_test'} )
+    {
+      # This is a NDB test
+      if ( ! $::glob_ndbcluster_supported )
+      {
+	# Ndb is not supported, skip it
+	$tinfo->{'skip'}= 1;
+	$tinfo->{'comment'}= "No ndbcluster support";
+	return;
+      }
+      elsif ( $::opt_skip_ndbcluster )
+      {
+	# All ndb test's should be skipped
+	$tinfo->{'skip'}= 1;
+	$tinfo->{'comment'}= "No ndbcluster tests(--skip-ndbcluster)";
+	return;
+      }
+      # Ndb tests run with two mysqld masters
+      $tinfo->{'master_num'}= 2;
+    }
+    else
+    {
+      # This is not a ndb test
+      if ( $::opt_with_ndbcluster_only )
+      {
+	# Only the ndb test should be run, all other should be skipped
+	$tinfo->{'skip'}= 1;
+	$tinfo->{'comment'}= "Only ndbcluster tests(--with-ndbcluster-only)";
+	return;
+      }
+    }
+
+    if ( $tinfo->{'innodb_test'} )
+    {
+      # This is a test that need innodb
+      if ( $::mysqld_variables{'innodb'} ne "TRUE" )
+      {
+	# innodb is not supported, skip it
+	$tinfo->{'skip'}= 1;
+	$tinfo->{'comment'}= "No innodb support";
+	return;
+      }
+    }
+
+    if ( $tinfo->{'need_binlog'} )
+    {
+      if (grep(/^--skip-log-bin/,  @::opt_extra_mysqld_opt) )
+      {
+	$tinfo->{'skip'}= 1;
+	$tinfo->{'comment'}= "Test need binlog";
+	return;
+      }
+    }
+    else
+    {
+      if ( $::mysql_version_id >= 50100 )
+      {
+	# Test does not need binlog, add --skip-binlog to
+	# the options used when starting it
+	push(@{$tinfo->{'master_opt'}}, "--skip-log-bin");
+      }
+    }
+
+  }
+}
+
+
+# List of tags in the .test files that if found should set
+# the specified value in "tinfo"
+our @tags=
+(
+
+ ["include/have_binlog_format_row.inc", "binlog_formats", ["row"]],
+ ["include/have_binlog_format_statement.inc", "binlog_formats", ["statement"]],
+ ["include/have_binlog_format_mixed.inc", "binlog_formats", ["mixed"]],
+ ["include/have_binlog_format_mixed_or_row.inc",
+  "binlog_formats", ["mixed", "row"]],
+ ["include/have_binlog_format_mixed_or_statement.inc",
+  "binlog_formats", ["mixed", "statement"]],
+ ["include/have_binlog_format_row_or_statement.inc",
+  "binlog_formats", ["row", "statement"]],
+
+ ["include/have_innodb.inc", "innodb_test", 1],
+ ["include/have_log_bin.inc", "need_binlog", 1],
+ ["include/big_test.inc", "big_test", 1],
+ ["include/have_debug.inc", "need_debug", 1],
+ ["include/have_ndb.inc", "ndb_test", 1],
+ ["include/have_multi_ndb.inc", "ndb_test", 1],
+ ["include/have_ndb_extra.inc", "ndb_extra", 1],
+ ["include/ndb_master-slave.inc", "ndb_test", 1],
+ ["require_manager", "require_manager", 1],
+ ["include/federated.inc", "federated_test", 1],
+ ["include/have_federated_db.inc", "federated_test", 1],
+);
+
+sub mtr_options_from_test_file($$) {
+  my $tinfo= shift;
+  my $file= shift;
+  #mtr_verbose("$file");
+  my $F= IO::File->new($file) or mtr_error("can't open file \"$file\": $!");
+
+  while ( my $line= <$F> )
+  {
+
+    # Skip line if it start's with #
+    next if ( $line =~ /^#/ );
+
+    # Match this line against tag in "tags" array
+    foreach my $tag (@tags)
+    {
+      if ( index($line, $tag->[0]) >= 0 )
+      {
+    	  # Tag matched, assign value to "tinfo"
+        $tinfo->{"$tag->[1]"}= $tag->[2];
+      }
+    }
+
+    # If test sources another file, open it as well
+    if ( $line =~ /^\-\-([[:space:]]*)source(.*)$/ or
+	 $line =~ /^([[:space:]]*)source(.*);$/ )
+    {
+      my $value= $2;
+      $value =~ s/^\s+//;  # Remove leading space
+      $value =~ s/[[:space:]]+$//;  # Remove ending space
+
+      my $sourced_file= "$::glob_mysql_test_dir/$value";
+      if ( -f $sourced_file )
+      {
+	# Only source the file if it exists, we may get
+	# false positives in the regexes above if someone
+	# writes "source nnnn;" in a test case(such as mysqltest.test)
+	mtr_options_from_test_file($tinfo, $sourced_file);
+      }
+    }
+  }
+}
+
+
+sub print_testcases {
+  my (@cases)= @_;
+
+  print "=" x 60, "\n";
+  foreach my $test (@cases){
+    print "[", $test->{name}, "]", "\n";
+    while ((my ($key, $value)) = each(%$test)) {
+      print " ", $key, "=";
+      if (ref $value eq "ARRAY") {
+	print join(", ", @$value);
+      } else {
+	print $value;
+      }
+      print "\n";
+    }
+    print "\n";
+  }
+  print "=" x 60, "\n";
+}
+
+
+1;

mysql-test/lib/v1/mtr_gcov.pl

+# -*- cperl -*-
+# Copyright (C) 2004, 2006 MySQL AB
+# 
+# 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;
+
+# These are not to be prefixed with "mtr_"
+
+sub gcov_prepare ();
+sub gcov_collect ();
+
+##############################################################################
+#
+#  
+#
+##############################################################################
+
+sub gcov_prepare () {
+
+  `find $::glob_basedir -name \*.gcov \
+    -or -name \*.da | xargs rm`;
+}
+
+# Used by gcov
+our @mysqld_src_dirs=
+  (
+   "strings",
+   "mysys",
+   "include",
+   "extra",
+   "regex",
+   "isam",
+   "merge",
+   "myisam",
+   "myisammrg",
+   "heap",
+   "sql",
+  );
+
+sub gcov_collect () {
+
+  print "Collecting source coverage info...\n";
+  -f $::opt_gcov_msg and unlink($::opt_gcov_msg);
+  -f $::opt_gcov_err and unlink($::opt_gcov_err);
+  foreach my $d ( @mysqld_src_dirs )
+  {
+    chdir("$::glob_basedir/$d");
+    foreach my $f ( (glob("*.h"), glob("*.cc"), glob("*.c")) )
+    {
+      `$::opt_gcov $f 2>>$::opt_gcov_err  >>$::opt_gcov_msg`;
+    }
+    chdir($::glob_mysql_test_dir);
+  }
+  print "gcov info in $::opt_gcov_msg, errors in $::opt_gcov_err\n";
+}
+
+
+1;

mysql-test/lib/v1/mtr_gprof.pl

+# -*- cperl -*-
+# Copyright (C) 2004 MySQL AB
+# 
+# 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;
+
+# These are not to be prefixed with "mtr_"
+
+sub gprof_prepare ();
+sub gprof_collect ();
+
+##############################################################################
+#
+#  
+#
+##############################################################################
+
+sub gprof_prepare () {
+
+  rmtree($::opt_gprof_dir);
+  mkdir($::opt_gprof_dir);
+}
+
+# FIXME what about master1 and slave1?!
+sub gprof_collect () {
+
+  if ( -f "$::master->[0]->{'path_myddir'}/gmon.out" )
+  {
+    # FIXME check result code?!
+    mtr_run("gprof",
+            [$::exe_master_mysqld,
+             "$::master->[0]->{'path_myddir'}/gmon.out"],
+            $::opt_gprof_master, "", "", "");
+    print "Master execution profile has been saved in $::opt_gprof_master\n";
+  }
+  if ( -f "$::slave->[0]->{'path_myddir'}/gmon.out" )
+  {
+    # FIXME check result code?!
+    mtr_run("gprof",
+            [$::exe_slave_mysqld,
+             "$::slave->[0]->{'path_myddir'}/gmon.out"],
+            $::opt_gprof_slave, "", "", "");
+    print "Slave execution profile has been saved in $::opt_gprof_slave\n";
+  }
+}
+
+
+1;

mysql-test/lib/v1/mtr_im.pl

+# -*- cperl -*-
+# Copyright (C) 2006 MySQL AB
+# 
+# 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;
+
+# Private IM-related operations.
+
+sub mtr_im_kill_process ($$$$);
+sub mtr_im_load_pids ($);
+sub mtr_im_terminate ($);
+sub mtr_im_check_alive ($);
+sub mtr_im_check_main_alive ($);
+sub mtr_im_check_angel_alive ($);
+sub mtr_im_check_mysqlds_alive ($);
+sub mtr_im_check_mysqld_alive ($);
+sub mtr_im_cleanup ($);
+sub mtr_im_rm_file ($);
+sub mtr_im_errlog ($);
+sub mtr_im_kill ($);
+sub mtr_im_wait_for_connection ($$$);
+sub mtr_im_wait_for_mysqld($$$);
+
+# Public IM-related operations.
+
+sub mtr_im_start ($$);
+sub mtr_im_stop ($);
+
+##############################################################################
+#
+#  Private operations.
+#
+##############################################################################
+
+sub mtr_im_kill_process ($$$$) {
+  my $pid_lst= shift;
+  my $signal= shift;
+  my $total_retries= shift;
+  my $timeout= shift;
+
+  my %pids;
+
+  foreach my $pid ( @{$pid_lst} )
+  {
+    $pids{$pid}= 1;
+  }
+
+  for ( my $cur_attempt= 1; $cur_attempt <= $total_retries; ++$cur_attempt )
+  {
+    foreach my $pid ( keys %pids )
+    {
+      mtr_debug("Sending $signal to $pid...");
+
+      kill($signal, $pid);
+
+      unless ( kill (0, $pid) )
+      {
+        mtr_debug("Process $pid died.");
+        delete $pids{$pid};
+      }
+    }
+
+    return if scalar keys %pids == 0;
+
+    mtr_debug("Sleeping $timeout second(s) waiting for processes to die...");
+
+    sleep($timeout);
+  }
+
+  mtr_debug("Process(es) " .
+            join(' ', keys %pids) .
+            " is still alive after $total_retries " .
+            "of sending signal $signal.");
+}
+
+###########################################################################
+
+sub mtr_im_load_pids($) {
+  my $im= shift;
+
+  mtr_debug("Loading PID files...");
+
+  # Obtain mysqld-process pids.
+
+  my $instances = $im->{'instances'};
+
+  for ( my $idx= 0; $idx < 2; ++$idx )
+  {
+    mtr_debug("IM-guarded mysqld[$idx] PID file: '" .
+              $instances->[$idx]->{'path_pid'} . "'.");
+
+    my $mysqld_pid;
+
+    if ( -r $instances->[$idx]->{'path_pid'} )
+    {
+      $mysqld_pid= mtr_get_pid_from_file($instances->[$idx]->{'path_pid'});
+      mtr_debug("IM-guarded mysqld[$idx] PID: $mysqld_pid.");
+    }
+    else
+    {
+      $mysqld_pid= undef;
+      mtr_debug("IM-guarded mysqld[$idx]: no PID file.");
+    }
+
+    $instances->[$idx]->{'pid'}= $mysqld_pid;
+  }
+
+  # Re-read Instance Manager PIDs from the file, since during tests Instance
+  # Manager could have been restarted, so its PIDs could have been changed.
+
+  #   - IM-main
+
+  mtr_debug("IM-main PID file: '$im->{path_pid}'.");
+
+  if ( -f $im->{'path_pid'} )
+  {
+    $im->{'pid'} =
+      mtr_get_pid_from_file($im->{'path_pid'});
+
+    mtr_debug("IM-main PID: $im->{pid}.");
+  }
+  else
+  {
+    mtr_debug("IM-main: no PID file.");
+    $im->{'pid'}= undef;
+  }
+
+  #   - IM-angel
+
+  mtr_debug("IM-angel PID file: '$im->{path_angel_pid}'.");
+
+  if ( -f $im->{'path_angel_pid'} )
+  {
+    $im->{'angel_pid'} =
+      mtr_get_pid_from_file($im->{'path_angel_pid'});
+
+    mtr_debug("IM-angel PID: $im->{'angel_pid'}.");
+  }
+  else
+  {
+    mtr_debug("IM-angel: no PID file.");
+    $im->{'angel_pid'} = undef;
+  }
+}
+
+###########################################################################
+
+sub mtr_im_terminate($) {
+  my $im= shift;
+
+  # Load pids from pid-files. We should do it first of all, because IM deletes
+  # them on shutdown.
+
+  mtr_im_load_pids($im);
+
+  mtr_debug("Shutting Instance Manager down...");
+
+  # Ignoring SIGCHLD so that all children could rest in peace.
+
+  start_reap_all();
+
+  # Send SIGTERM to IM-main.
+
+  if ( defined $im->{'pid'} )
+  {
+    mtr_debug("IM-main pid: $im->{pid}.");
+    mtr_debug("Stopping IM-main...");
+
+    mtr_im_kill_process([ $im->{'pid'} ], 'TERM', 10, 1);
+  }
+  else
+  {
+    mtr_debug("IM-main pid: n/a.");
+  }
+
+  # If IM-angel was alive, wait for it to die.
+
+  if ( defined $im->{'angel_pid'} )
+  {
+    mtr_debug("IM-angel pid: $im->{'angel_pid'}.");
+    mtr_debug("Waiting for IM-angel to die...");
+
+    my $total_attempts= 10;
+
+    for ( my $cur_attempt=1; $cur_attempt <= $total_attempts; ++$cur_attempt )
+    {
+      unless ( kill (0, $im->{'angel_pid'}) )
+      {
+        mtr_debug("IM-angel died.");
+        last;
+      }
+
+      sleep(1);
+    }
+  }
+  else
+  {
+    mtr_debug("IM-angel pid: n/a.");
+  }
+
+  stop_reap_all();
+
+  # Re-load PIDs.
+
+  mtr_im_load_pids($im);
+}
+
+###########################################################################
+
+sub mtr_im_check_alive($) {
+  my $im= shift;
+
+  mtr_debug("Checking whether IM-components are alive...");
+
+  return 1 if mtr_im_check_main_alive($im);
+
+  return 1 if mtr_im_check_angel_alive($im);
+
+  return 1 if mtr_im_check_mysqlds_alive($im);
+
+  return 0;
+}
+
+###########################################################################
+
+sub mtr_im_check_main_alive($) {
+  my $im= shift;
+
+  # Check that the process, that we know to be IM's, is dead.
+
+  if ( defined $im->{'pid'} )
+  {
+    if ( kill (0, $im->{'pid'}) )
+    {
+      mtr_debug("IM-main (PID: $im->{pid}) is alive.");
+      return 1;
+    }
+    else
+    {
+      mtr_debug("IM-main (PID: $im->{pid}) is dead.");
+    }
+  }
+  else
+  {
+    mtr_debug("No PID file for IM-main.");
+  }
+
+  # Check that IM does not accept client connections.
+
+  if ( mtr_ping_port($im->{'port'}) )
+  {
+    mtr_debug("IM-main (port: $im->{port}) " .
+              "is accepting connections.");
+
+    mtr_im_errlog("IM-main is accepting connections on port " .
+                  "$im->{port}, but there is no " .
+                  "process information.");
+    return 1;
+  }
+  else
+  {
+    mtr_debug("IM-main (port: $im->{port}) " .
+              "does not accept connections.");
+    return 0;
+  }
+}
+
+###########################################################################
+
+sub mtr_im_check_angel_alive($) {
+  my $im= shift;
+
+  # Check that the process, that we know to be the Angel, is dead.
+
+  if ( defined $im->{'angel_pid'} )
+  {
+    if ( kill (0, $im->{'angel_pid'}) )
+    {
+      mtr_debug("IM-angel (PID: $im->{angel_pid}) is alive.");
+      return 1;
+    }
+    else
+    {
+      mtr_debug("IM-angel (PID: $im->{angel_pid}) is dead.");
+      return 0;
+    }
+  }
+  else
+  {
+    mtr_debug("No PID file for IM-angel.");
+    return 0;
+  }
+}
+
+###########################################################################
+
+sub mtr_im_check_mysqlds_alive($) {
+  my $im= shift;
+
+  mtr_debug("Checking for IM-guarded mysqld instances...");
+
+  my $instances = $im->{'instances'};
+
+  for ( my $idx= 0; $idx < 2; ++$idx )
+  {
+    mtr_debug("Checking mysqld[$idx]...");
+
+    return 1
+      if mtr_im_check_mysqld_alive($instances->[$idx]);
+  }
+}
+
+###########################################################################
+
+sub mtr_im_check_mysqld_alive($) {
+  my $mysqld_instance= shift;
+
+  # Check that the process is dead.
+
+  if ( defined $mysqld_instance->{'pid'} )
+  {
+    if ( kill (0, $mysqld_instance->{'pid'}) )
+    {
+      mtr_debug("Mysqld instance (PID: $mysqld_instance->{pid}) is alive.");
+      return 1;
+    }
+    else
+    {
+      mtr_debug("Mysqld instance (PID: $mysqld_instance->{pid}) is dead.");
+    }
+  }
+  else
+  {
+    mtr_debug("No PID file for mysqld instance.");
+  }
+
+  # Check that mysqld does not accept client connections.
+
+  if ( mtr_ping_port($mysqld_instance->{'port'}) )
+  {
+    mtr_debug("Mysqld instance (port: $mysqld_instance->{port}) " .
+              "is accepting connections.");
+
+    mtr_im_errlog("Mysqld is accepting connections on port " .
+                  "$mysqld_instance->{port}, but there is no " .
+                  "process information.");
+    return 1;
+  }
+  else
+  {
+    mtr_debug("Mysqld instance (port: $mysqld_instance->{port}) " .
+              "does not accept connections.");
+    return 0;
+  }
+}
+
+###########################################################################
+
+sub mtr_im_cleanup($) {
+  my $im= shift;
+
+  mtr_im_rm_file($im->{'path_pid'});
+  mtr_im_rm_file($im->{'path_sock'});
+
+  mtr_im_rm_file($im->{'path_angel_pid'});
+
+  for ( my $idx= 0; $idx < 2; ++$idx )
+  {
+    mtr_im_rm_file($im->{'instances'}->[$idx]->{'path_pid'});
+    mtr_im_rm_file($im->{'instances'}->[$idx]->{'path_sock'});
+  }
+}
+
+###########################################################################
+
+sub mtr_im_rm_file($)
+{
+  my $file_path= shift;
+
+  if ( -f $file_path )
+  {
+    mtr_debug("Removing '$file_path'...");
+
+    unless ( unlink($file_path) )
+    {
+      mtr_warning("Can not remove '$file_path'.")
+    }
+  }
+  else
+  {
+    mtr_debug("File '$file_path' does not exist already.");
+  }
+}
+
+###########################################################################
+
+sub mtr_im_errlog($) {
+  my $msg= shift;
+
+  # Complain in error log so that a warning will be shown.
+  # 
+  # TODO: unless BUG#20761 is fixed, we will print the warning to stdout, so
+  # that it can be seen on console and does not produce pushbuild error.
+
+  # my $errlog= "$opt_vardir/log/mysql-test-run.pl.err";
+  # 
+  # open (ERRLOG, ">>$errlog") ||
+  #   mtr_error("Can not open error log ($errlog)");
+  # 
+  # my $ts= localtime();
+  # print ERRLOG
+  #   "Warning: [$ts] $msg\n";
+  # 
+  # close ERRLOG;
+
+  my $ts= localtime();
+  print "Warning: [$ts] $msg\n";
+}
+
+###########################################################################
+
+sub mtr_im_kill($) {
+  my $im= shift;
+
+  # Re-load PIDs. That can be useful because some processes could have been
+  # restarted.
+
+  mtr_im_load_pids($im);
+
+  # Ignoring SIGCHLD so that all children could rest in peace.
+
+  start_reap_all();
+
+  # Kill IM-angel first of all.
+
+  if ( defined $im->{'angel_pid'} )
+  {
+    mtr_debug("Killing IM-angel (PID: $im->{angel_pid})...");
+    mtr_im_kill_process([ $im->{'angel_pid'} ], 'KILL', 10, 1)
+  }
+  else
+  {
+    mtr_debug("IM-angel is dead.");
+  }
+
+  # Re-load PIDs again.
+
+  mtr_im_load_pids($im);
+
+  # Kill IM-main.
+  
+  if ( defined $im->{'pid'} )
+  {
+    mtr_debug("Killing IM-main (PID: $im->pid})...");
+    mtr_im_kill_process([ $im->{'pid'} ], 'KILL', 10, 1);
+  }
+  else
+  {
+    mtr_debug("IM-main is dead.");
+  }
+
+  # Re-load PIDs again.
+
+  mtr_im_load_pids($im);
+
+  # Kill guarded mysqld instances.
+
+  my @mysqld_pids;
+
+  mtr_debug("Collecting PIDs of mysqld instances to kill...");
+
+  for ( my $idx= 0; $idx < 2; ++$idx )
+  {
+    my $pid= $im->{'instances'}->[$idx]->{'pid'};
+
+    unless ( defined $pid )
+    {
+      next;
+    }
+
+    mtr_debug("  - IM-guarded mysqld[$idx] PID: $pid.");
+
+    push (@mysqld_pids, $pid);
+  }
+
+  if ( scalar @mysqld_pids > 0 )
+  {
+    mtr_debug("Killing IM-guarded mysqld instances...");
+    mtr_im_kill_process(\@mysqld_pids, 'KILL', 10, 1);
+  }
+
+  # That's all.
+
+  stop_reap_all();
+}
+
+##############################################################################
+
+sub mtr_im_wait_for_connection($$$) {
+  my $im= shift;
+  my $total_attempts= shift;
+  my $connect_timeout= shift;
+
+  mtr_debug("Waiting for IM on port $im->{port} " .
+            "to start accepting connections...");
+
+  for ( my $cur_attempt= 1; $cur_attempt <= $total_attempts; ++$cur_attempt )
+  {
+    mtr_debug("Trying to connect to IM ($cur_attempt of $total_attempts)...");
+
+    if ( mtr_ping_port($im->{'port'}) )
+    {
+      mtr_debug("IM is accepting connections " .
+                "on port $im->{port}.");
+      return 1;
+    }
+
+    mtr_debug("Sleeping $connect_timeout...");
+    sleep($connect_timeout);
+  }
+
+  mtr_debug("IM does not accept connections " .
+            "on port $im->{port} after " .
+            ($total_attempts * $connect_timeout) . " seconds.");
+
+  return 0;
+}
+
+##############################################################################
+
+sub mtr_im_wait_for_mysqld($$$) {
+  my $mysqld= shift;
+  my $total_attempts= shift;
+  my $connect_timeout= shift;
+
+  mtr_debug("Waiting for IM-guarded mysqld on port $mysqld->{port} " .
+            "to start accepting connections...");
+
+  for ( my $cur_attempt= 1; $cur_attempt <= $total_attempts; ++$cur_attempt )
+  {
+    mtr_debug("Trying to connect to mysqld " .
+              "($cur_attempt of $total_attempts)...");
+
+    if ( mtr_ping_port($mysqld->{'port'}) )
+    {
+      mtr_debug("Mysqld is accepting connections " .
+                "on port $mysqld->{port}.");
+      return 1;
+    }
+
+    mtr_debug("Sleeping $connect_timeout...");
+    sleep($connect_timeout);
+  }
+
+  mtr_debug("Mysqld does not accept connections " .
+            "on port $mysqld->{port} after " .
+            ($total_attempts * $connect_timeout) . " seconds.");
+
+  return 0;
+}
+
+##############################################################################
+#
+#  Public operations.
+#
+##############################################################################
+
+sub mtr_im_start($$) {
+  my $im = shift;
+  my $opts = shift;
+
+  mtr_debug("Starting Instance Manager...");
+
+  my $args;
+  mtr_init_args(\$args);
+  mtr_add_arg($args, "--defaults-file=%s", $im->{'defaults_file'});
+
+  foreach my $opt ( @{$opts} )
+  {
+    mtr_add_arg($args, $opt);
+  }
+
+  $im->{'spawner_pid'} =
+    mtr_spawn(
+      $::exe_im,                        # path to the executable
+      $args,                            # cmd-line args
+      '',                               # stdin
+      $im->{'path_log'},                # stdout
+      $im->{'path_err'},                # stderr
+      '',                               # pid file path (not used)
+      { append_log_file => 1 }          # append log files
+      );
+
+  unless ( $im->{'spawner_pid'} )
+  {
+    mtr_error('Could not start Instance Manager.')
+  }
+
+  # Instance Manager can be run in daemon mode. In this case, it creates
+  # several processes and the parent process, created by mtr_spawn(), exits just
+  # after start. So, we have to obtain Instance Manager PID from the PID file.
+
+  mtr_debug("Waiting for IM to create PID file (" .
+            "path: '$im->{path_pid}'; " .
+            "timeout: $im->{start_timeout})...");
+
+  unless ( sleep_until_file_created($im->{'path_pid'},
+                                    $im->{'start_timeout'},
+                                    -1) ) # real PID is still unknown
+  {
+    mtr_debug("IM has not created PID file in $im->{start_timeout} secs.");
+    mtr_debug("Aborting test suite...");
+
+    mtr_kill_leftovers();
+
+    mtr_report("IM has not created PID file in $im->{start_timeout} secs.");
+    return 0;
+  }
+
+  $im->{'pid'}= mtr_get_pid_from_file($im->{'path_pid'});
+
+  mtr_debug("Instance Manager started. PID: $im->{pid}.");
+
+  # Wait until we can connect to IM.
+
+  my $IM_CONNECT_TIMEOUT= 30;
+
+  unless ( mtr_im_wait_for_connection($im,
+                                      $IM_CONNECT_TIMEOUT, 1) )
+  {
+    mtr_debug("Can not connect to Instance Manager " .
+              "in $IM_CONNECT_TIMEOUT seconds after start.");
+    mtr_debug("Aborting test suite...");
+
+    mtr_kill_leftovers();
+
+    mtr_report("Can not connect to Instance Manager " .
+               "in $IM_CONNECT_TIMEOUT seconds after start.");
+    return 0;
+  }
+
+  # Wait for IM to start guarded instances:
+  #   - wait for PID files;
+
+  mtr_debug("Waiting for guarded mysqlds instances to create PID files...");
+
+  for ( my $idx= 0; $idx < 2; ++$idx )
+  {
+    my $mysqld= $im->{'instances'}->[$idx];
+
+    if ( exists $mysqld->{'nonguarded'} )
+    {
+      next;
+    }
+
+    mtr_debug("Waiting for mysqld[$idx] to create PID file (" .
+              "path: '$mysqld->{path_pid}'; " .
+              "timeout: $mysqld->{start_timeout})...");
+
+    unless ( sleep_until_file_created($mysqld->{'path_pid'},
+                                      $mysqld->{'start_timeout'},
+                                      -1) ) # real PID is still unknown
+    {
+      mtr_debug("mysqld[$idx] has not created PID file in " .
+                 "$mysqld->{start_timeout} secs.");
+      mtr_debug("Aborting test suite...");
+
+      mtr_kill_leftovers();
+
+      mtr_report("mysqld[$idx] has not created PID file in " .
+                 "$mysqld->{start_timeout} secs.");
+      return 0;
+    }
+
+    mtr_debug("PID file for mysqld[$idx] ($mysqld->{path_pid} created.");
+  }
+
+  # Wait until we can connect to guarded mysqld-instances
+  # (in other words -- wait for IM to start guarded instances).
+
+  mtr_debug("Waiting for guarded mysqlds to start accepting connections...");
+
+  for ( my $idx= 0; $idx < 2; ++$idx )
+  {
+    my $mysqld= $im->{'instances'}->[$idx];
+
+    if ( exists $mysqld->{'nonguarded'} )
+    {
+      next;
+    }
+
+    mtr_debug("Waiting for mysqld[$idx] to accept connection...");
+
+    unless ( mtr_im_wait_for_mysqld($mysqld, 30, 1) )
+    {
+      mtr_debug("Can not connect to mysqld[$idx] " .
+                "in $IM_CONNECT_TIMEOUT seconds after start.");
+      mtr_debug("Aborting test suite...");
+
+      mtr_kill_leftovers();
+
+      mtr_report("Can not connect to mysqld[$idx] " .
+                 "in $IM_CONNECT_TIMEOUT seconds after start.");
+      return 0;
+    }
+
+    mtr_debug("mysqld[$idx] started.");
+  }
+
+  mtr_debug("Instance Manager and its components are up and running.");
+
+  return 1;
+}
+
+##############################################################################
+
+sub mtr_im_stop($) {
+  my $im= shift;
+
+  mtr_debug("Stopping Instance Manager...");
+
+  # Try graceful shutdown.
+
+  mtr_im_terminate($im);
+
+  # Check that all processes died.
+
+  unless ( mtr_im_check_alive($im) )
+  {
+    mtr_debug("Instance Manager has been stopped successfully.");
+    mtr_im_cleanup($im);
+    return 1;
+  }
+
+  # Instance Manager don't want to die. We should kill it.
+
+  mtr_im_errlog("Instance Manager did not shutdown gracefully.");
+
+  mtr_im_kill($im);
+
+  # Check again that all IM-related processes have been killed.
+
+  my $im_is_alive= mtr_im_check_alive($im);
+
+  mtr_im_cleanup($im);
+
+  if ( $im_is_alive )
+  {
+    mtr_debug("Can not kill Instance Manager or its children.");
+    return 0;
+  }
+
+  mtr_debug("Instance Manager has been killed successfully.");
+  return 1;
+}
+
+###########################################################################
+
+1;

mysql-test/lib/v1/mtr_io.pl

+# -*- cperl -*-
+# Copyright (C) 2004-2006 MySQL AB
+# 
+# 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;
+
+sub mtr_get_pid_from_file ($);
+sub mtr_get_opts_from_file ($);
+sub mtr_fromfile ($);
+sub mtr_tofile ($@);
+sub mtr_tonewfile($@);
+sub mtr_lastlinefromfile($);
+sub mtr_appendfile_to_file ($$);
+sub mtr_grab_file($);
+
+
+##############################################################################
+#
+#  
+#
+##############################################################################
+
+sub mtr_get_pid_from_file ($) {
+  my $pid_file_path=  shift;
+  my $TOTAL_ATTEMPTS= 30;
+  my $timeout= 1;
+
+  # We should read from the file until we get correct pid. As it is
+  # stated in BUG#21884, pid file can be empty at some moment. So, we should
+  # read it until we get valid data.
+
+  for (my $cur_attempt= 1; $cur_attempt <= $TOTAL_ATTEMPTS; ++$cur_attempt)
+  {
+    mtr_debug("Reading pid file '$pid_file_path' " .
+              "($cur_attempt of $TOTAL_ATTEMPTS)...");
+
+    open(FILE, '<', $pid_file_path)
+      or mtr_error("can't open file \"$pid_file_path\": $!");
+
+    # Read pid number from file
+    my $pid= <FILE>;
+    chomp $pid;
+    close FILE;
+
+    return $pid if $pid=~ /^(\d+)/;
+
+    mtr_debug("Pid file '$pid_file_path' does not yet contain pid number.\n" .
+              "Sleeping $timeout second(s) more...");
+
+    sleep($timeout);
+  }
+
+  mtr_error("Pid file '$pid_file_path' is corrupted. " .
+            "Can not retrieve PID in " .
+            ($timeout * $TOTAL_ATTEMPTS) . " seconds.");
+}
+
+sub mtr_get_opts_from_file ($) {
+  my $file=  shift;
+
+  open(FILE,"<",$file) or mtr_error("can't open file \"$file\": $!");
+  my @args;
+  while ( <FILE> )
+  {
+    chomp;
+
+    #    --set-variable=init_connect=set @a='a\\0c'
+    s/^\s+//;                           # Remove leading space
+    s/\s+$//;                           # Remove ending space
+
+    # This is strange, but we need to fill whitespace inside
+    # quotes with something, to remove later. We do this to
+    # be able to split on space. Else, we have trouble with
+    # options like 
+    #
+    #   --someopt="--insideopt1 --insideopt2"
+    #
+    # But still with this, we are not 100% sure it is right,
+    # we need a shell to do it right.
+
+#    print STDERR "\n";
+#    print STDERR "AAA: $_\n";
+
+    s/\'([^\'\"]*)\'/unspace($1,"\x0a")/ge;
+    s/\"([^\'\"]*)\"/unspace($1,"\x0b")/ge;
+    s/\'([^\'\"]*)\'/unspace($1,"\x0a")/ge;
+    s/\"([^\'\"]*)\"/unspace($1,"\x0b")/ge;
+
+#    print STDERR "BBB: $_\n";
+
+#    foreach my $arg (/(--?\w.*?)(?=\s+--?\w|$)/)
+
+    # FIXME ENV vars should be expanded!!!!
+
+    foreach my $arg (split(/[ \t]+/))
+    {
+      $arg =~ tr/\x11\x0a\x0b/ \'\"/;     # Put back real chars
+      # The outermost quotes has to go
+      $arg =~ s/^([^\'\"]*)\'(.*)\'([^\'\"]*)$/$1$2$3/
+        or $arg =~ s/^([^\'\"]*)\"(.*)\"([^\'\"]*)$/$1$2$3/;
+      $arg =~ s/\\\\/\\/g;
+
+      $arg =~ s/\$\{(\w+)\}/envsubst($1)/ge;
+      $arg =~ s/\$(\w+)/envsubst($1)/ge;
+
+#      print STDERR "ARG: $arg\n";
+      # Do not pass empty string since my_getopt is not capable to handle it.
+      if (length($arg))
+      {
+        push(@args, $arg)
+      }
+    }
+  }
+  close FILE;
+  return \@args;
+}
+
+sub envsubst {
+  my $string= shift;
+
+  if ( ! defined $ENV{$string} )
+  {
+    mtr_error("opt file referense \$$string that is unknown");
+  }
+
+  return $ENV{$string};
+}
+
+sub unspace {
+  my $string= shift;
+  my $quote=  shift;
+  $string =~ s/[ \t]/\x11/g;
+  return "$quote$string$quote";
+}
+
+# Read a whole file, stripping leading and trailing whitespace.
+sub mtr_fromfile ($) {
+  my $file=  shift;
+
+  open(FILE,"<",$file) or mtr_error("can't open file \"$file\": $!");
+  my $text= join('', <FILE>);
+  close FILE;
+  $text =~ s/^\s+//;                    # Remove starting space, incl newlines
+  $text =~ s/\s+$//;                    # Remove ending space, incl newlines
+  return $text;
+}
+
+sub mtr_lastlinefromfile ($) {
+  my $file=  shift;
+  my $text;
+
+  open(FILE,"<",$file) or mtr_error("can't open file \"$file\": $!");
+  while (my $line= <FILE>)
+  {
+    $text= $line;
+  }
+  close FILE;
+  return $text;
+}
+
+
+sub mtr_tofile ($@) {
+  my $file=  shift;
+
+  open(FILE,">>",$file) or mtr_error("can't open file \"$file\": $!");
+  print FILE join("", @_);
+  close FILE;
+}
+
+sub mtr_tonewfile ($@) {
+  my $file=  shift;
+
+  open(FILE,">",$file) or mtr_error("can't open file \"$file\": $!");
+  print FILE join("", @_);
+  close FILE;
+}
+
+sub mtr_appendfile_to_file ($$) {
+  my $from_file=  shift;
+  my $to_file=  shift;
+
+  open(TOFILE,">>",$to_file) or mtr_error("can't open file \"$to_file\": $!");
+  open(FROMFILE,"<",$from_file)
+    or mtr_error("can't open file \"$from_file\": $!");
+  print TOFILE while (<FROMFILE>);
+  close FROMFILE;
+  close TOFILE;
+}
+
+# Read a whole file verbatim.
+sub mtr_grab_file($) {
+  my $file= shift;
+  open(FILE, '<', $file)
+    or return undef;
+  local $/= undef;
+  my $data= scalar(<FILE>);
+  close FILE;
+  return $data;
+}
+
+
+1;

mysql-test/lib/v1/mtr_match.pl

+# -*- cperl -*-
+# Copyright (C) 2004-2006 MySQL AB
+# 
+# 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;
+
+sub mtr_match_prefix ($$);
+sub mtr_match_extension ($$);
+sub mtr_match_any_exact ($$);
+
+##############################################################################
+#
+#  
+#
+##############################################################################
+
+# Match a prefix and return what is after the prefix
+
+sub mtr_match_prefix ($$) {
+  my $string= shift;
+  my $prefix= shift;
+
+  if ( $string =~ /^\Q$prefix\E(.*)$/ ) # strncmp
+  {
+    return $1;
+  }
+  else
+  {
+    return undef;		# NULL
+  }
+}
+
+
+# Match extension and return the name without extension
+
+sub mtr_match_extension ($$) {
+  my $file= shift;
+  my $ext=  shift;
+
+  if ( $file =~ /^(.*)\.\Q$ext\E$/ ) # strchr+strcmp or something
+  {
+    return $1;
+  }
+  else
+  {
+    return undef;                       # NULL
+  }
+}
+
+
+# Match a substring anywere in a string
+
+sub mtr_match_substring ($$) {
+  my $string= shift;
+  my $substring= shift;
+
+  if ( $string =~ /(.*)\Q$substring\E(.*)$/ ) # strncmp
+  {
+    return $1;
+  }
+  else
+  {
+    return undef;		# NULL
+  }
+}
+
+
+sub mtr_match_any_exact ($$) {
+  my $string= shift;
+  my $mlist=  shift;
+
+  foreach my $m (@$mlist)
+  {
+    if ( $string eq $m )
+    {
+      return 1;
+    }
+  }
+  return 0;
+}
+
+1;

mysql-test/lib/v1/mtr_misc.pl

+# -*- cperl -*-
+# Copyright (C) 2004-2006 MySQL AB
+# 
+# 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;
+  map {$_.= ".nlm"} @path if $::glob_netware;
+  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;

mysql-test/lib/v1/mtr_process.pl

+# -*- cperl -*-
+# Copyright (C) 2004-2006 MySQL AB
+# 
+# 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
+            # FIXME we should only give up the suite, not all of the run?
+            print STDERR "\n";
+            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;

mysql-test/lib/v1/mtr_report.pl

+# -*- cperl -*-
+# Copyright (C) 2004-2006 MySQL AB
+# 
+# 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;
+          }
+          my $leak_reports_expected= undef;
+          while ( <ERR> )
+          {
+            # There is a test case that purposely provokes a
+            # SAFEMALLOC leak report, even though there is no actual
+            # leak. We need to detect this, and ignore the warning in
+            # that case.
+            if (/Begin safemalloc memory dump:/) {
+              $leak_reports_expected= 1;
+            } elsif (/End safemalloc memory dump./) {
+              $leak_reports_expected= undef;
+            }
+
+            # 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
+                /Cannot find or 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
+
+		# 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).
+                /Cannot find or 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/ )
+            {
+              if ($leak_reports_expected) {
+                next;
+              }
+              $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;

mysql-test/lib/v1/mtr_stress.pl

+# -*- cperl -*-
+# Copyright (C) 2006 MySQL AB
+# 
+# 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");
+
+  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;

mysql-test/lib/v1/mtr_timer.pl

+# -*- cperl -*-
+# Copyright (C) 2005-2006 MySQL AB
+# 
+# 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;

mysql-test/lib/v1/mtr_unique.pl

+# -*- cperl -*-
+# Copyright (C) 2006 MySQL AB
+# 
+# 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;
+

mysql-test/lib/v1/ndb_config_1_node.ini

+[ndbd default]
+NoOfReplicas= 1
+MaxNoOfConcurrentTransactions= 64
+MaxNoOfConcurrentOperations= CHOOSE_MaxNoOfConcurrentOperations
+DataMemory= CHOOSE_DataMemory
+IndexMemory= CHOOSE_IndexMemory
+Diskless= CHOOSE_Diskless
+TimeBetweenWatchDogCheck= 30000
+DataDir= CHOOSE_FILESYSTEM
+MaxNoOfOrderedIndexes= CHOOSE_MaxNoOfOrderedIndexes
+MaxNoOfAttributes= CHOOSE_MaxNoOfAttributes
+TimeBetweenGlobalCheckpoints= 500
+NoOfFragmentLogFiles= 8
+FragmentLogFileSize= 6M
+DiskPageBufferMemory= CHOOSE_DiskPageBufferMemory 
+
+#
+# Increase timeouts to cater for slow test-machines
+#   (possibly running several tests in parallell)
+#
+HeartbeatIntervalDbDb= 30000
+HeartbeatIntervalDbApi= 30000
+#TransactionDeadlockDetectionTimeout= 7500
+
+[ndbd]
+HostName= CHOOSE_HOSTNAME_1   # hostname is a valid network adress
+
+[ndb_mgmd]
+HostName= CHOOSE_HOSTNAME_1   # hostname is a valid network adress
+DataDir= CHOOSE_FILESYSTEM    #
+PortNumber= CHOOSE_PORT_MGM
+
+[mysqld]
+
+[mysqld]
+
+[mysqld]
+
+[mysqld]
+
+[mysqld]
+
+[mysqld]
+
+[mysqld]
+
+[mysqld]

mysql-test/lib/v1/ndb_config_2_node.ini

+[ndbd default]
+NoOfReplicas= 2
+MaxNoOfConcurrentTransactions= 64
+MaxNoOfConcurrentOperations= CHOOSE_MaxNoOfConcurrentOperations
+DataMemory= CHOOSE_DataMemory
+IndexMemory= CHOOSE_IndexMemory
+Diskless= CHOOSE_Diskless
+TimeBetweenWatchDogCheck= 30000
+DataDir= CHOOSE_FILESYSTEM
+MaxNoOfOrderedIndexes= CHOOSE_MaxNoOfOrderedIndexes
+MaxNoOfAttributes= CHOOSE_MaxNoOfAttributes
+TimeBetweenGlobalCheckpoints= 500
+NoOfFragmentLogFiles= 4
+FragmentLogFileSize=12M
+DiskPageBufferMemory= CHOOSE_DiskPageBufferMemory
+# O_DIRECT has issues on 2.4 whach have not been handled, Bug #29612
+#ODirect= 1
+# the following parametes just function as a small regression
+# test that the parameter exists
+InitialNoOfOpenFiles= 27
+
+#
+# Increase timeouts to cater for slow test-machines
+#   (possibly running several tests in parallell)
+#
+HeartbeatIntervalDbDb= 30000
+HeartbeatIntervalDbApi= 30000
+#TransactionDeadlockDetectionTimeout= 7500
+
+[ndbd]
+HostName= CHOOSE_HOSTNAME_1   # hostname is a valid network adress
+
+[ndbd]
+HostName= CHOOSE_HOSTNAME_2   # hostname is a valid network adress
+
+[ndb_mgmd]
+HostName= CHOOSE_HOSTNAME_1   # hostname is a valid network adress
+DataDir= CHOOSE_FILESYSTEM    #
+PortNumber= CHOOSE_PORT_MGM
+
+[mysqld]
+
+[mysqld]
+
+[mysqld]
+
+[mysqld]
+
+[mysqld]
+
+[mysqld]
+
+[mysqld]
+
+[mysqld]

mysql-test/mysql-test-run.pl

@@ -34,8 +34,34 @@ BEGIN {
   }
 }
 
+BEGIN {
+  # Check backward compatibility support
+  # By setting the environment variable MTR_VERSION
+  # it's possible to use a previous version of
+  # mysql-test-run.pl
+  my $version= $ENV{MTR_VERSION} || 2;
+  if ( $version == 1 )
+  {
+    print "=======================================================\n";
+    print "  WARNING: Using mysql-test-run.pl version 1!  \n";
+    print "=======================================================\n";
+    require "lib/v1/mysql-test-run.pl";
+    exit(1);
+  }
+  elsif ( $version == 2 )
+  {
+    # This is the current version, just continue
+    ;
+  }
+  else
+  {
+    print "ERROR: Version $version of mysql-test-run does not exist!\n";
+    exit(1);
+  }
+}
 
 use lib "lib";
+
 use Cwd;
 use Getopt::Long;
 use My::File::Path; # Patched version of File::Path