use strict;

# Extract coverage option
#
# Arguments:
#  $option       coverage option
#  $delim        delimiter for splitting the string
#  $option_error error to be printed in case of failure
sub coverage_extract_option {
  my ($option, $delim, $option_error) = @_;
  # check for sanity of option which should be of the format --option=value
  if (length($option) == 0) {
      print "**** ERROR **** ",
            "Invalid coverage option specified for $option_error\n";
      exit(1);
  }

  # split the string on delimiter '='
  my @option_arr = split(/$delim/, $option);
  $option=$option_arr[$#option_arr];

  return $option;
}

# Prepare to generate coverage data
#
# Arguments:
#   $build_dir  build directory
#   $base_dir   basedir, normally the home directory
#   $scope      coverage option which is of the form:
#                 * full : complete code coverage
#                 * diff : coverage of the git diff HEAD
#                 * diff:<commit_hash> : coverage of git diff commit_hash
#   $src_path   directory path for coverage source files
#   $llvm_path  directory for llvm coverage binaries
#   $format     format for coverage report which is of the form:
#                 * text : text format
#                 * html : html format
#   $src_filter src filter directories
sub coverage_prepare($$$) {
  my ($build_dir, $base_dir, $scope, $src_path, $llvm_path, $format,
      $src_filter) = @_;

  print "Purging coverage information from '$base_dir'...\n";
  system("find $base_dir -name \"code\*.profraw\" | xargs rm");

  my $scope = coverage_extract_option($scope, "=", "coverage-scope");

  my $commit_hash = "HEAD"; # default commit hash is 'HEAD'
  # if the coverage scope is "--full" then extract the git commithash
  if ($scope =~ m/^diff/) {
      my $invalid_commit_hash = 0; # is this commit hash valid?
      # if the coverage scope is of the form 'diff:<commit_hash>'
      if ($scope =~ /^diff:/) {
          $commit_hash = coverage_extract_option($scope, ":",
                                                 "coverage-scope");
          # sanity check for commit hash
          if (length($commit_hash) == 0) {
              $invalid_commit_hash = 1;
          }
      }
      # if the coverage scope is of the form '--diff'
      elsif ($scope ne "diff") {
          $invalid_commit_hash = 1;
      }

      if ($invalid_commit_hash) {
          print "**** ERROR **** ",
                "Invalid coverage scope diff option: $scope\n";
          exit(1);
      }
  }
  # make sure that the coverage scope is "--full"
  elsif ($scope ne "full") {
    print "**** ERROR **** ", "Invalid coverage scope: $scope\n";
    exit(1);
  }

  # Update the scope of the coverage
  if ($scope eq "full") {
    $_[2] = $scope;
  }
  else {
    $_[2] = $commit_hash;
  }

  # extract directory for coverage source files
  $src_path = coverage_extract_option($src_path, "=", "coverage-src-path")."/";

  # Update the coverage src path
  $_[3] = $src_path;

  $llvm_path = coverage_extract_option($llvm_path, "=", "coverage-llvm-path");

  # append "/" at the end of the llvm_path
  if (length($llvm_path) > 0 && ! ($llvm_path =~ m/\/$/) ) {
    $llvm_path .= "/";
  }

  # Update the coverage llvm path
  $_[4] = $llvm_path;

  # extract format for coverage report
  $format = coverage_extract_option($format, "=", "coverage-format");

  # sanity check for coverage format
  if ( ! ( ($format eq "text") || ($format eq "html")) ) {
      print "**** ERROR **** ", "Invalid coverage-format option: $format\n";
      exit(1);
  }

  $_[5] = $format;

  # process "--coverage-src-filter" arguments
  $src_filter =~ s/^\s+//g;
  my @filter_arr = split(/ /, $src_filter);
  my $final_src_filter="";
  my $f;
  foreach $f (@filter_arr) {
    my $filter_path = coverage_extract_option($f, "=", "coverage-src-filter");
    if (length($final_src_filter) > 0) {
        $final_src_filter .= ",";
    }
    $final_src_filter .= $filter_path;
  }

  # Update the coverage src filter
  $_[6] = $final_src_filter;

  # create the directory to store the generated coverage files
  my $mkdir_cmd = "$build_dir/coverage_files";
  mkpath($mkdir_cmd);
}

# Get the files modified by a git diff
#
# Arguments:
#  $src_dir      directory for coverage source files
#  $commit_hash  git commit hash
sub coverage_get_diff_files ($$) {
  my ($src_dir, $commit_hash) = @_;

  # command to extract files modified by a git commit hash
  my $cmd = "git diff --name-only $commit_hash"."^ $commit_hash";
  open(PIPE, "$cmd|");

  my $commit_hash_files; # concatenated list of files

  while(<PIPE>) {
      chomp;
      if (/\.h$/ or /\.cc$/) {
          $commit_hash_files .= $src_dir.$_." ";
      }
  }
  return $commit_hash_files;
}

# Merge coverage profile files
#
# Arguments:
#   $merge_com   command for merging the coverage profile files
#   $results_dir directory that contains coverage results
sub coverage_merge_prof_files($$) {
  my ($merge_com, $result_dir) = @_;

  my $err_file = "$result_dir/err";
  my $merge_com_err = "$merge_com 2>$err_file";
  # If the merge command fails due to corrupted profile files
  # then repeat merging the files by deleting the corrupt files
  while (1) {
    system($merge_com_err);
    open(FP, "<", $err_file) or dir $!;
    my $got_error = 0; # did we see an error
    my $line;
    while($line = <FP>) {
      $got_error = 1;
      chomp($line);
      my @files_list = split(":", $line);
      my $corrupt_file = $files_list[1];
      $corrupt_file =~ s/ //g;
      # delete the corrupt file
      rmtree("$corrupt_file");
    }
    # there is no error, bail out
    if ($got_error == 0) {
      last;
    }
  }
}

# Collect coverage information
#
# Arguments:
#  $build_dir   build directory
#  $base_dir    basedir, normally the home directory
#  $binary_path path to mysqld binary
#  $scope       coverage option which is of the form:
#                 * full : complete code coverage
#                 * HEAD : coverage of the git diff HEAD
#                 * <commit_hash> : coverage of git diff commit_hash
#  $src_path    directory path for coverage source files
#  $llvm_path   directory for llvm coverage binaries
#  $format      format for coverage report which is of the form:
#                 * text : text format
#                 * html : html format
#  $src_filter  src filter directories
#  $cov_comand  coverage command issued (used for logging)
sub coverage_collect ($$$) {
  my ($build_dir, $base_dir, $binary_path, $scope, $src_path, $llvm_path,
      $format, $src_filter, $cov_command) = @_;

  my $files_modified=""; # list of files modified concatenated into one string

  if ($scope ne "full") {
    $files_modified = coverage_get_diff_files($src_path, $scope);
  }

  print "Generating coverage information ";
  if (length($files_modified) > 0) {
    print "for git commit hash $scope";
    if ($scope eq "HEAD") {
      # command to extract git commit hash of 'HEAD'
      my $cmd = "git rev-parse $scope";
      open(PIPE, "$cmd|");
      my $head_commit_hash = <PIPE>;
      chomp($head_commit_hash);
      print " ($head_commit_hash)";
    }
  }
  elsif (length($src_filter) > 0) {
    my @dir_paths = $src_filter =~ /,/g;
    my $num_dirs = @dir_paths+1;
    my $dir_str = "directory";
    if ($num_dirs > 1) {
        $dir_str = "directories";
    }
    print "for source files in $dir_str: $src_filter";
  }
  else {
    print "for complete source code ";
  }
  print " ...\n";

  # Create directory to store the coverage results
  my $result_dir = "$build_dir/reports/".time();
  mkpath($result_dir);

  # Recreate the 'last' directory to point to the latest coverage
  # results directory
  my $last_dir = "$build_dir/reports/last";
  rmtree($last_dir);
  symlink($result_dir, $last_dir);

  # Log the command used for generating coverage in command.log
  open(FP, ">$result_dir/command.log");
  print FP "$cov_command\n";
  close(FP);

  # Merge coverage reports using command
  # llvm-prof merge --output=file.profdata <list of code*.profraw>
  my $merge_cov = $llvm_path."llvm-profdata merge --output=";
  $merge_cov .= $result_dir."/combined.profdata ";
  $merge_cov .= "`find $build_dir -name \"code*.profraw\"`";
  coverage_merge_prof_files($merge_cov, $result_dir);

  # Generate coverage report using command
  # llvm-cov show <binary_path> --instr-profile=file.profdata \
  #      --format <text|html> --output-dir=<output_dir>
  my $generate_cov
      = $llvm_path."llvm-cov show $binary_path -instr-profile=";
  $generate_cov .= $result_dir."/combined.profdata ";

  # Add the list of files modified if the coverage report is for
  # a specific git diff
  if (length($files_modified) > 0) {
      $generate_cov .= $files_modified;
  } elsif (length($src_filter) > 0) {
    # if files modified is empty then apply the coverage-src-filter
    my @filter_paths = split(/,/, $src_filter);
    my $single_filter;
    foreach $single_filter (@filter_paths) {
      my $find_cmd
          = "`find $src_path/$single_filter -name \"*.cc\" -o -name \"*.h\"";
      $find_cmd .= " -o -name \"*.c\" -o -name \"*.ic\"`";
      $generate_cov .= " $find_cmd ";
    }
  }

  $generate_cov .= "--format $format"; # coverage report format
  $generate_cov .= " --output-dir=$result_dir 2>/dev/null";
  system($generate_cov);

  # Delete profdata file
  print "Purging coverage related files...\n";
  my $rm_profdata = $result_dir."/combined.profdata";
  rmtree($rm_profdata);
  my $rm_coverage_files = "$build_dir/coverage_files";
  rmtree($rm_coverage_files);
  system("find $base_dir -name \"code\*.profraw\" | xargs rm");

  print "Completed generating coverage information in ",
        "$format format.\n";
  print "Coverage results directory: $build_dir/reports/last\n";
}

1;


# -*- cperl -*-
# Copyright (c) 2004, 2011, Oracle and/or its affiliates. All rights reserved.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA

# This is a library file used by the Perl version of mysql-test-run,
# and is part of the translation of the Bourne shell script with the
# same name.

use strict;

sub gcov_prepare ($) {
  my ($dir)= @_;
  print "Purging gcov information from '$dir'...\n";

  system("find $dir -name \*.gcov -o -name \*.da"
             . " -o -name \*.gcda | grep -v 'README.gcov\$' | xargs rm");
}

#
# Collect gcov statistics.
# Arguments:
#   $dir       basedir, normally build directory
#   $gcov      gcov utility program [path] name
#   $gcov_msg  message file name
#   $gcov_err  error file name
#
sub gcov_collect ($$$) {
  my ($dir, $gcov, $gcov_msg, $gcov_err)= @_;

  # Get current directory to return to later.
  my $start_dir= cwd();

  print "Collecting source coverage info using '$gcov'...\n";
  -f "$dir/$gcov_msg" and unlink("$dir/$gcov_msg");
  -f "$dir/$gcov_err" and unlink("$dir/$gcov_err");

  my @dirs= `find "$dir" -type d -print | sort`;
  #print "List of directories:\n@dirs\n";

  foreach my $d ( @dirs ) {
    chomp($d);
    chdir($d) or next;

    my @flist= glob("*.*.gcno");
    print ("Collecting in '$d'...\n") if @flist;

    foreach my $f (@flist) {
      system("$gcov $f 2>>$dir/$gcov_err >>$dir/$gcov_msg");
    }
    chdir($start_dir);
  }
  print "gcov info in $dir/$gcov_msg, errors in $dir/$gcov_err\n";
}

1;


# -*- cperl -*-
# Copyright (c) 2004, 2011, Oracle and/or its affiliates. All rights reserved.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA

# This is a library file used by the Perl version of mysql-test-run,
# and is part of the translation of the Bourne shell script with the
# same name.

use strict;

sub gprof_collect ($@) {
  my ($exe_mysqld, @gprof_dirs)= @_;

  print ("Collecting gprof reports.....\n");

  foreach my $datadir (@gprof_dirs)
  {
    my $gprof_msg= "$datadir/gprof.msg";
    my $gprof_err= "$datadir/gprof.err";
    if ( -f "$datadir/gmon.out" )
    {
      system("gprof $exe_mysqld $datadir/gmon.out 2>$gprof_err >$gprof_msg");
      print ("GPROF output in $gprof_msg, errors in $gprof_err\n");
    }
  }
}

1;


# -*- cperl -*-
# Copyright (c) 2004-2008 MySQL AB, 2008 Sun Microsystems, Inc.
# Use is subject to license terms.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA

# This is a library file used by the Perl version of mysql-test-run,
# and is part of the translation of the Bourne shell script with the
# same name.

use strict;
use Carp;

sub mtr_fromfile ($);
sub mtr_tofile ($@);
sub mtr_tonewfile($@);
sub mtr_appendfile_to_file ($$);
sub mtr_grab_file($);
sub mtr_printfile($);
sub mtr_lastlinesfromfile ($$);

# 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_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;
}

# Print the file to STDOUT
sub mtr_printfile($) {
  my $file= shift;
  open(FILE, '<', $file)
    or warn $!;
  print while(<FILE>);
  close FILE;
  return;
}

sub mtr_lastlinesfromfile ($$) {
  croak "usage: mtr_lastlinesfromfile(file,numlines)" unless (@_ == 2);
  my ($file, $num_lines)= @_;
  my $text;
  open(FILE,"<",$file) or mtr_error("can't open file \"$file\": $!");
  my @lines= reverse <FILE>;
  close FILE;
  my $size= scalar(@lines);
  $num_lines= $size unless ($size >= $num_lines);
  return join("", reverse(splice(@lines, 0, $num_lines)));
}

1;


# -*- cperl -*-
# Copyright (c) 2004, 2011, Oracle and/or its affiliates. All rights reserved.
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library 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
# Library 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 My::Platform;

sub mtr_init_args ($);
sub mtr_add_arg ($$@);
sub mtr_args2str($@);
sub mtr_path_exists(@);
sub mtr_script_exists(@);
sub mtr_file_exists(@);
sub mtr_exe_exists(@);
sub mtr_exe_maybe_exists(@);
sub mtr_compress_file($);
sub mtr_milli_sleep($);
sub start_timer($);
sub has_expired($);
sub init_timers();
sub mark_time_used($);
sub mark_time_idle();
sub add_total_times($);
sub print_times_used($$);
sub print_total_times($);

our $opt_report_times;

##############################################################################
#
#  Args
#
##############################################################################

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

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

  # Quote args if args contain space
  $format= "\"$format\""
    if (IS_WINDOWS and grep(/\s/, @fargs));

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

sub mtr_args2str($@) {
  my $exe=   shift or die;
  return join(" ", native_path($exe), @_);
}

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

#
# 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(IS_WINDOWS)
    {
      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 IS_WINDOWS;
  foreach my $path ( @path )
  {
    if(IS_WINDOWS)
    {
      return $path if -f $path;
    }
    else
    {
      return $path if -x $path;
    }
  }
  return "";
}

#
# NOTE! More specific paths should be given before less specific.
#
sub mtr_pl_maybe_exists (@) {
  my @path= @_;

  map {$_.= ".pl"} @path if IS_WINDOWS;
  foreach my $path ( @path )
  {
    if(IS_WINDOWS)
    {
      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));
  }
}

#
# Try to compress file using tools that might be available.
# If zip/gzip is not available, just silently ignore.
#

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

  mtr_error ("File to compress not found: $filename") unless -f $filename;

  my $did_compress= 0;

  if (IS_WINDOWS)
  {
    # Capture stderr
    my $ziperr= `zip $filename.zip $filename 2>&1`;
    if ($?) {
      print "$ziperr\n" if $ziperr !~ /recognized as an internal or external/;
    } else {
      unlink($filename);
      $did_compress=1;
    }
  }
  else
  {
    my $gzres= system("gzip $filename");
    $did_compress= ! $gzres;
    if ($gzres && $gzres != -1) {
      mtr_error ("Error: have gzip but it fails to compress core file");
    }
  }
  mtr_print("Compressed file $filename") if $did_compress;
}

sub mtr_milli_sleep ($) {
  die "usage: mtr_milli_sleep(milliseconds)" unless @_ == 1;
  my ($millis)= @_;

  select(undef, undef, undef, ($millis/1000));
}

# Simple functions to start and check timers (have to be actively polled)
# Timer can be "killed" by setting it to 0

sub start_timer ($) { return time + $_[0]; }

sub has_expired ($) { return $_[0] && time gt $_[0]; }

# Below code is for time usage reporting

use Time::HiRes qw(gettimeofday);

my %time_used= (
  'collect' => 0,
  'restart' => 0,
  'check'   => 0,
  'ch-warn' => 0,
  'test'    => 0,
  'init'    => 0,
  'admin'   => 0,
);

my %time_text= (
 'collect' => "Collecting test cases",
 'restart' => "Server stop/start",
 'check'   => "Check-testcase",
 'ch-warn' => "Check for warnings",
 'test'    => "Test execution",
 'init'    => "Initialization/cleanup",
 'admin'   => "Test administration",
);

# Counts number of reports from workers

my $time_totals= 0;

my $last_timer_set;

sub init_timers() {
  $last_timer_set= gettimeofday();
}

sub mark_time_used($) {
  my ($name)= @_;
  return unless $opt_report_times;
  die "Unknown timer $name" unless exists $time_used{$name};

  my $curr_time= gettimeofday();
  $time_used{$name}+= int (($curr_time - $last_timer_set) * 1000 + .5);
  $last_timer_set= $curr_time;
}

sub mark_time_idle() {
  $last_timer_set= gettimeofday() if $opt_report_times;
}

sub add_total_times($) {
  my ($dummy, $num, @line)= split (" ", $_[0]);

  $time_totals++;
  foreach my $elem (@line) {
    my ($name, $spent)= split (":", $elem);
    $time_used{$name}+= $spent;
  }
}

sub print_times_used($$) {
  my ($server, $num)= @_;
  return unless $opt_report_times;

  my $output= "SPENT $num";
  foreach my $name (keys %time_used) {
    my $spent= $time_used{$name};
    $output.= " $name:$spent";
  }
  print $server $output . "\n";
}

sub print_total_times($) {
  # Don't print if we haven't received all worker data
  return if $time_totals != $_[0];

  foreach my $name (keys %time_used)
  {
    my $spent= $time_used{$name}/1000;
    my $text= $time_text{$name};
    print ("Spent $spent seconds on $text\n");
  }
}

1;


# -*- cperl -*-
# Copyright (c) 2004, 2010, Oracle and/or its affiliates. All rights reserved.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA

# This is a library file used by the Perl version of mysql-test-run,
# and is part of the translation of the Bourne shell script with the
# same name.

use strict;
use Socket;
use Errno;
use My::Platform;
use if IS_WINDOWS, "Net::Ping";

# Ancient perl might not have port_number method for Net::Ping.
# Check it and use fallback to connect() if it is not present.
BEGIN
{
  my $use_netping= 0;
  if (IS_WINDOWS)
  {
    my $ping = Net::Ping->new();
    if ($ping->can("port_number"))
    {
      $use_netping= 1;
    }
  }
  eval 'sub USE_NETPING { $use_netping }';
}

sub sleep_until_file_created ($$$);
sub mtr_ping_port ($);

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

  mtr_verbose("mtr_ping_port: $port");

  if (IS_WINDOWS && USE_NETPING)
  {
    # Under Windows, connect to a port that is not open is slow
    # It takes ~1sec. Net::Ping with small timeout is much faster.
    my $ping = Net::Ping->new();
    $ping->port_number($port);
    if ($ping->ping("localhost",0.1))
    {
      mtr_verbose("USED");
      return 1;
    }
    else
    {
      mtr_verbose("FREE");
      return 0;
    }
  }

  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 ( bind(SOCK, $paddr) )
  {
    close(SOCK);                        # FIXME check error?
    mtr_verbose("FREE");
    return 0;
  }
  else
  {
    mtr_verbose("USED");
    return 1;
  }
}

##############################################################################
#
#  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 $proc=     shift;
  my $sleeptime= 100; # Milliseconds
  my $loops= ($timeout * 1000) / $sleeptime;

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

    my $seconds= ($loop * $sleeptime) / 1000;

    # Check if it died after the fork() was successful
    if ( defined $proc and ! $proc->wait_one(0) )
    {
      mtr_warning("Process $proc died after mysql-test-run waited $seconds " .
		  "seconds for $pidfile to be created.");
      return 0;
    }

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

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

    mtr_milli_sleep($sleeptime);

  }

  mtr_warning("Timeout after mysql-test-run waited $timeout seconds " .
	      "for the process $proc to create a pid file.");
  return 0;
}

1;


# -*- cperl -*-
# Copyright (c) 2004-2007 MySQL AB, 2009 Sun Microsystems, Inc.
# Use is subject to license terms.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA

# This is a library file used by the Perl version of mysql-test-run,
# and is part of the translation of the Bourne shell script with the
# same name.

use strict;
use File::Spec;

# These are not to be prefixed with "mtr_"

sub run_stress_test ();

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

sub run_stress_test ()
{

  my $args;
  my $stress_suitedir;

  mtr_report("Starting stress testing\n");

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

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

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

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

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

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

    }
  }

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

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

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

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

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

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

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

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

  #Run stress test
  My::SafeProcess->run
      (
       name           => "stress test",
       path           => $^X,
       args           => \$args,
      );

  if ( ! $::glob_use_embedded_server )
  {
    stop_all_servers();
  }
}

1;


#!/usr/bin/perl
# -*- cperl -*-

# Copyright (c) 2007 MySQL AB
# Use is subject to license terms.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA

use strict;
use Getopt::Long;
use IO::File;

my $vardir;
my $randie= 0;
my $sleep= 0;
GetOptions
  (
   # Directory where to write files
   'vardir=s'     => \$vardir,
   'die-randomly' => \$randie,
   'sleep=i'      => \$sleep,
  );

die("invalid vardir ") unless defined $vardir and -d $vardir;

my $pid= $$;
while(1){
  for my $i (1..64){
    # Write to file
    my $name= "$vardir/$pid.$i.tmp";
    my $F= IO::File->new($name, "w")
      or warn "$$, Could not open $name: $!" and next;
    print $F rand($.) for (1..1000);
    $F->close();
    sleep($sleep);
    die "ooops!" if $randie and rand() < 0.0001
  }
}

exit (0);


#!/usr/bin/perl
# -*- cperl -*-

# Copyright (c) 2007, 2008 MySQL AB
# Use is subject to license terms.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA

use strict;
use FindBin;
use My::SafeProcess;

#
# Test longterm running of SafeProcess
#

my $perl_path= $^X;
my $verbose= 0;
my $loops= 100;

print "kill one and wait for one\n";
for (1...$loops){
  use File::Temp qw / tempdir /;
  my $dir = tempdir( CLEANUP => 1 );

  my @procs;
  for (1..10){

    my $args= [ "$FindBin::Bin/dummyd.pl", "--vardir=$dir" ];
    my $proc= My::SafeProcess->new
      (
       path          => $perl_path,
       args          => \$args,
       verbose       => $verbose,
      );
    push(@procs, $proc);
  }

  foreach my $proc (@procs) {
    $proc->kill();
    # dummyd will always be killed and thus
    # exit_status should have been set to 1
    die "oops, exit_status: ", $proc->exit_status()
      unless $proc->exit_status() == 1;
  }

  print "=" x 60, "\n";
}

print "With 1 second sleep in dummyd\n";
for (1...$loops){
  use File::Temp qw / tempdir /;
  my $dir = tempdir( CLEANUP => 1 );

  my @procs;
  for (1..10){

    my $args= [ "$FindBin::Bin/dummyd.pl",
		"--vardir=$dir",
		"--sleep=1" ];
    my $proc= My::SafeProcess->new
      (
       path          => $perl_path,
       args          => \$args,
       verbose       => $verbose,
      );
    push(@procs, $proc);
  }

  foreach my $proc (@procs) {
    $proc->kill();
  }

  print "=" x 60, "\n";
}

print "kill all and wait for one\n";
for (1...$loops){
  use File::Temp qw / tempdir /;
  my $dir = tempdir( CLEANUP => 1 );

  my @procs;
  for (1..10){

    my $args= [ "$FindBin::Bin/dummyd.pl", "--vardir=$dir" ];
    my $proc= My::SafeProcess->new
      (
       path          => $perl_path,
       args          => \$args,
       verbose       => $verbose,
      );
    push(@procs, $proc);
  }

  foreach my $proc (@procs) {
    $proc->start_kill();
  }

  foreach my $proc (@procs) {
    $proc->wait_one();
  }

  print "=" x 60, "\n";
}

print "kill all using shutdown without callback\n";
for (1...$loops){
  use File::Temp qw / tempdir /;
  my $dir = tempdir( CLEANUP => 1 );

  my @procs;
  for (1..10){

    my $args= [ "$FindBin::Bin/dummyd.pl", "--vardir=$dir" ];
    my $proc= My::SafeProcess->new
      (
       path          => $perl_path,
       args          => \$args,
       verbose       => $verbose,
       );
    push(@procs, $proc);
  }

  My::SafeProcess::shutdown(2, @procs);

  print "=" x 60, "\n";
}

print "kill all using shutdown\n";
for (1...$loops){
  use File::Temp qw / tempdir /;
  my $dir = tempdir( CLEANUP => 1 );

  my @procs;
  for (1..10){

    my $args= [ "$FindBin::Bin/dummyd.pl", "--vardir=$dir" ];
    my $proc= My::SafeProcess->new
      (
       path          => $perl_path,
       args          => \$args,
       verbose       => $verbose,
       shutdown      => sub {  }, # Does nothing
      );
    push(@procs, $proc);
  }

  My::SafeProcess::shutdown(2, @procs);

  print "=" x 60, "\n";
}

exit(0);


#!/usr/bin/perl
# -*- cperl -*-

# Copyright (c) 2007 MySQL AB
# Use is subject to license terms.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA

use strict;
use Getopt::Long;

my $opt_exit_code= 0;

GetOptions
  (
   # Exit with the specified exit code
   'exit-code=i'   => \$opt_exit_code
  );

print "Hello stdout\n";
print STDERR "Hello stderr\n";

exit ($opt_exit_code);


# -*- cperl -*-
# Copyright (c) 2005, 2006 MySQL AB, 2008, 2009 Sun Microsystems, Inc.
# Use is subject to license terms.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA

# This is a library file used by the Perl version of mysql-test-run,
# and is part of the translation of the Bourne shell script with the
# same name.

use 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;
my %incompatible;

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;
}

sub collect_incomp_tests {
  open (INCOMP, "lib/v1/incompatible.tests");
  while (<INCOMP>)
  {
    next unless /^\w/;
    s/\s.*\n//;		      # Ignore anything from first white space
    $incompatible{$_}= 1;
  }
}

##############################################################################
#
#  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");

  collect_incomp_tests();

  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);

  # Remove "combinations" part of test name
  my $test_base_name= $tinfo->{'name'};
  $test_base_name=~ s/\s.*\n//;

  if (exists ($incompatible{$test_base_name}))
  {
    $tinfo->{'skip'}= 1;
    $tinfo->{'comment'}= "Test cannot run in mtr v1";
    return;
  }

  # ----------------------------------------------------------------------
  # 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'} eq "OFF" )
      {
	# 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;


# -*- cperl -*-
# Copyright (c) 2004, 2006 MySQL AB, 2008 Sun Microsystems, Inc.
# Use is subject to license terms.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA

# This is a library file used by the Perl version of mysql-test-run,
# and is part of the translation of the Bourne shell script with the
# same name.

use 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;


# -*- cperl -*-
# Copyright (c) 2004 MySQL AB, 2008 Sun Microsystems, Inc.
# Use is subject to license terms.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA

# This is a library file used by the Perl version of mysql-test-run,
# and is part of the translation of the Bourne shell script with the
# same name.

use 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;


# -*- cperl -*-
# Copyright (c) 2006 MySQL AB, 2008 Sun Microsystems, Inc.
# Use is subject to license terms.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA

# This 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;


# -*- cperl -*-
# Copyright (c) 2004, 2010, Oracle and/or its affiliates. All rights reserved.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA

# This is a library file used by the Perl version of mysql-test-run,
# and is part of the translation of the Bourne shell script with the
# same name.

use strict;

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;

    #    --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;


# -*- cperl -*-
# Copyright (c) 2004-2006 MySQL AB, 2008 Sun Microsystems, Inc.
# Use is subject to license terms.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA

# This is a library file used by the Perl version of mysql-test-run,
# and is part of the translation of the Bourne shell script with the
# same name.

use 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;