Many files:

  Perl version of mysql-test-run
  new file

mysql-test/lib/mtr_gcov.pl

+# -*- cperl -*-
+
+# 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`;
+}
+
+sub gcov_collect () {
+
+  print "Collecting source coverage info...\n";
+  -f $::opt_gcov_msg and unlink($::opt_gcov_msg);
+  -f $::opt_gcov_err and unlink($::opt_gcov_err);
+  foreach my $d ( @::mysqld_src_dirs )
+  {
+    chdir("$::glob_basedir/$d");
+    foreach my $f ( (glob("*.h"), glob("*.cc"), glob("*.c")) )
+    {
+      `$::opt_gcov $f 2>>$::opt_gcov_err  >>$::opt_gcov_msg`;
+    }
+    chdir($::glob_mysql_test_dir);
+  }
+  print "gcov info in $::opt_gcov_msg, errors in $::opt_gcov_err\n";
+}
+
+
+1;

mysql-test/lib/mtr_gprof.pl

+# -*- cperl -*-
+
+# This is a library file used by the Perl version of mysql-test-run,
+# and is part of the translation of the Bourne shell script with the
+# same name.
+
+use strict;
+
+# These are not to be prefixed with "mtr_"
+
+sub gprof_prepare ();
+sub gprof_collect ();
+
+##############################################################################
+#
+#  
+#
+##############################################################################
+
+sub gprof_prepare () {
+
+  rmtree($::opt_gprof_dir);
+  mkdir($::opt_gprof_dir);
+}
+
+# FIXME what about master1 and slave1?!
+sub gprof_collect () {
+
+  if ( -f "$::master->[0]->{'path_myddir'}/gmon.out" )
+  {
+    # FIXME check result code?!
+    mtr_run("gprof",
+            [$::exe_master_mysqld,
+             "$::master->[0]->{'path_myddir'}/gmon.out"],
+            $::opt_gprof_master, "", "", "");
+    print "Master execution profile has been saved in $::opt_gprof_master\n";
+  }
+  if ( -f "$::slave->[0]->{'path_myddir'}/gmon.out" )
+  {
+    # FIXME check result code?!
+    mtr_run("gprof",
+            [$::exe_slave_mysqld,
+             "$::slave->[0]->{'path_myddir'}/gmon.out"],
+            $::opt_gprof_slave, "", "", "");
+    print "Slave execution profile has been saved in $::opt_gprof_slave\n";
+  }
+}
+
+
+1;

mysql-test/lib/mtr_io.pl

+# -*- cperl -*-
+
+# 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_tofile ($@);
+sub mtr_tonewfile($@);
+
+##############################################################################
+#
+#  
+#
+##############################################################################
+
+sub mtr_get_pid_from_file ($) {
+  my $file=  shift;
+
+  open(FILE,"<",$file) or mtr_error("can't open file \"$file\": $!");
+  my $pid=  <FILE>;
+  chomp($pid);
+  close FILE;
+  return $pid;
+}
+
+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;
+    s/\$MYSQL_TEST_DIR/$::glob_mysql_test_dir/g;
+    push(@args, split(' ', $_));
+  }
+  close FILE;
+  return \@args;
+}
+
+sub mtr_fromfile ($) {
+  my $file=  shift;
+
+  open(FILE,"<",$file) or mtr_error("can't open file \"$file\": $!");
+  my $text= join('', <FILE>);
+  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;
+}
+
+
+1;

mysql-test/lib/mtr_match.pl

+# -*- cperl -*-
+
+# 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
+  }
+}
+
+
+sub mtr_match_any_exact ($$) {
+  my $string= shift;
+  my $mlist=  shift;
+
+  foreach my $m (@$mlist)
+  {
+    if ( $string eq $m )
+    {
+      return 1;
+    }
+  }
+  return 0;
+}
+
+1;

mysql-test/lib/mtr_misc.pl

+# -*- cperl -*-
+
+# 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_full_hostname ();
+sub mtr_init_args ($);
+sub mtr_add_arg ($$);
+
+##############################################################################
+#
+#  Misc
+#
+##############################################################################
+
+# We want the fully qualified host name and hostname() may have returned
+# only the short name. So we use the resolver to find out.
+
+sub mtr_full_hostname () {
+
+  my $hostname=  hostname();
+  if ( $hostname !~ /\./ )
+  {
+    my $address=   gethostbyname($hostname)
+      or die "Couldn't resolve $hostname : $!";
+    my $fullname=  gethostbyaddr($address, AF_INET);
+    $hostname= $fullname if $fullname; 
+  }
+  return $hostname;
+}
+
+# FIXME move to own lib
+
+sub mtr_init_args ($) {
+  my $args = shift;
+  $$args = [];                            # Empty list
+}
+
+sub mtr_add_arg ($$) {
+  my $args=   shift;
+  my $format= shift;
+  my @fargs = @_;
+
+  push(@$args, sprintf($format, @fargs));
+}
+
+1;

mysql-test/lib/mtr_report.pl

+# -*- cperl -*-
+
+# 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_report_test_name($);
+sub mtr_report_test_passed($);
+sub mtr_report_test_failed($);
+sub mtr_report_test_skipped($);
+
+sub mtr_show_failed_diff ($);
+sub mtr_report_stats ($);
+sub mtr_print_line ();
+sub mtr_print_header ();
+sub mtr_report (@);
+sub mtr_warning (@);
+sub mtr_error (@);
+sub mtr_debug (@);
+
+
+##############################################################################
+#
+#  
+#
+##############################################################################
+
+# We can't use diff -u or diff -a as these are not portable
+
+sub mtr_show_failed_diff ($) {
+  my $tname=  shift;
+
+  my $reject_file=  "r/$tname.reject";
+  my $result_file=  "r/$tname.result";
+  my $eval_file=    "r/$tname.eval";
+
+  if ( -f $eval_file )
+  { 
+    $result_file=  $eval_file;
+  }
+  elsif ( $::opt_result_ext and
+          ( $::opt_record or -f "$result_file$::opt_result_ext" ))
+  {
+    # If we have an special externsion for result files we use it if we are
+    # recording or a result file with that extension exists.
+    $result_file=  "$result_file$::opt_result_ext";
+  }
+
+  if ( -f $reject_file )
+  {
+    print "Below are the diffs between actual and expected results:\n";
+    print "-------------------------------------------------------\n";
+    # FIXME check result code?!
+    mtr_run("diff",["-c",$result_file,$reject_file], "", "", "", "");
+    print "-------------------------------------------------------\n";
+    print "Please follow the instructions outlined at\n";
+    print "http://www.mysql.com/doc/en/Reporting_mysqltest_bugs.html\n";
+    print "to find the reason to this problem and how to report this.\n\n";
+  }
+}
+
+sub mtr_report_test_name ($) {
+  my $tinfo= shift;
+
+  printf "%-31s ", $tinfo->{'name'};
+}
+
+sub mtr_report_test_skipped ($) {
+  my $tinfo= shift;
+
+  $tinfo->{'result'}= 'MTR_RES_SKIPPED';
+  print "[ skipped ]\n";
+}
+
+sub mtr_report_test_passed ($) {
+  my $tinfo= shift;
+
+  my $timer=  "";
+# FIXME
+#  if ( $::opt_timer and -f "$::glob_mysql_test_dir/var/log/timer" )
+#  {
+#    $timer=  `cat var/log/timer`;
+#    $timer=  sprintf "%13s", $timer;
+#  }
+  $tinfo->{'result'}= 'MTR_RES_PASSED';
+  print "[ pass ]   $timer\n";
+}
+
+sub mtr_report_test_failed ($) {
+  my $tinfo= shift;
+
+  $tinfo->{'result'}= 'MTR_RES_FAILED';
+  print "[ fail ]\n";
+
+  print "Errors are (from $::path_timefile) :\n";
+  print mtr_fromfile($::path_timefile); # FIXME print_file() instead
+  print "\n(the last lines may be the most important ones)\n";
+}
+
+sub mtr_report_stats ($) {
+  my $tests= shift;
+
+  # ----------------------------------------------------------------------
+  # Find out how we where doing
+  # ----------------------------------------------------------------------
+
+  my $tot_skiped= 0;
+  my $tot_passed= 0;
+  my $tot_failed= 0;
+  my $tot_tests=  0;
+
+  foreach my $tinfo (@$tests)
+  {
+    if ( $tinfo->{'result'} eq 'MTR_RES_SKIPPED' )
+    {
+      $tot_skiped++;
+    }
+    elsif ( $tinfo->{'result'} eq 'MTR_RES_PASSED' )
+    {
+      $tot_tests++;
+      $tot_passed++;
+    }
+    elsif ( $tinfo->{'result'} eq 'MTR_RES_FAILED' )
+    {
+      $tot_tests++;
+      $tot_failed++;
+    }
+  }
+
+  # ----------------------------------------------------------------------
+  # Print out a summary report to screen
+  # ----------------------------------------------------------------------
+
+  if ( ! $tot_failed )
+  {
+    print "All $tot_tests tests were successful.\n";
+  }
+  else
+  {
+    my $ratio=  $tot_passed * 100 / $tot_tests;
+    printf "Failed $tot_failed/$tot_tests tests, " .
+      "%.2f\% successful.\n\n", $ratio;
+    print
+      "The log files in var/log may give you some hint\n",
+      "of what when wrong.\n",
+      "If you want to report this error, please read first ",
+      "the documentation at\n",
+      "http://www.mysql.com/doc/en/MySQL_test_suite.html\n";
+  }
+
+  # ----------------------------------------------------------------------
+  # ----------------------------------------------------------------------
+
+  if ( ! $::glob_use_running_server )
+  {
+
+    # Report if there was any fatal warnings/errors in the log files
+    #
+    unlink("$::glob_mysql_test_dir/var/log/warnings");
+    unlink("$::glob_mysql_test_dir/var/log/warnings.tmp");
+    # Remove some non fatal warnings from the log files
+
+# FIXME what is going on ????? ;-)
+#    sed -e 's!Warning:  Table:.* on delete!!g' -e 's!Warning: Setting lower_case_table_names=2!!g' -e 's!Warning: One can only use the --user.*root!!g' \
+#        var/log/*.err \
+#        | sed -e 's!Warning:  Table:.* on rename!!g' \
+#        > var/log/warnings.tmp;
+#
+#    found_error=0;
+#    # Find errors
+#    for i in "^Warning:" "^Error:" "^==.* at 0x"
+#    do
+#      if ( $GREP "$i" var/log/warnings.tmp >> var/log/warnings )
+#    {
+#        found_error=1
+#      }
+#    done
+#    unlink("$::glob_mysql_test_dir/var/log/warnings.tmp");
+#    if ( $found_error=  "1" )
+#      {
+#      print "WARNING: Got errors/warnings while running tests. Please examine\n"
+#      print "$::glob_mysql_test_dir/var/log/warnings for details.\n"
+#    }
+#  }
+  }
+
+  print "\n";
+
+  if ( $tot_failed != 0 )
+  {
+    print "mysql-test-run: *** Failing the test(s):";
+
+    foreach my $tinfo (@$tests)
+    {
+      if ( $tinfo->{'result'} eq 'MTR_RES_FAILED' )
+      {
+        print " $tinfo->{'name'}";
+      }
+    }
+    print "\n";
+    mtr_error("there where failing test cases");
+  }
+}
+
+##############################################################################
+#
+#  Text formatting
+#
+##############################################################################
+
+sub mtr_print_line () {
+  print '-' x 55, "\n";
+}
+
+sub mtr_print_header () {
+  print "\n";
+  if ( $::opt_timer )
+  {
+    print "TEST                            RESULT        TIME (ms)\n";
+  }
+  else
+  {
+    print "TEST                            RESULT\n";
+  }
+  mtr_print_line();
+  print "\n";
+}
+
+
+##############################################################################
+#
+#  Misc
+#
+##############################################################################
+
+sub mtr_report (@) {
+  print join(" ", @_),"\n";
+}
+
+sub mtr_warning (@) {
+  print STDERR "mysql-test-run: WARNING: ",join(" ", @_),"\n";
+}
+
+sub mtr_error (@) {
+  die "mysql-test-run: *** ERROR: ",join(" ", @_),"\n";
+}
+
+sub mtr_debug (@) {
+  if ( $::opt_script_debug )
+  {
+    print "mysql-test-run: DEBUG: ",join(" ", @_),"\n";
+  }
+}
+
+1;