Commit d2773d34 authored by Magnus Svensson's avatar Magnus Svensson

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

 - Add copy of mtr v1 and make it possible to run it using MTR_VERSION=1
parent 5fd1c976
Branches unavailable
Tags unavailable
No related merge requests found
......@@ -24,7 +24,25 @@ test_SCRIPTS = mtr \
mysql-test-run.pl \
mysql-stress-test.pl
nobase_test_DATA = lib/mtr_cases.pm \
nobase_test_DATA = \
lib/v1/mysql-test-run.pl \
lib/v1/mtr_cases.pl \
lib/v1/mtr_io.pl \
lib/v1/mtr_report.pl \
lib/v1/My/Config.pm \
lib/v1/mtr_gcov.pl \
lib/v1/mtr_match.pl \
lib/v1/mtr_stress.pl \
lib/v1/ndb_config_1_node.ini \
lib/v1/ndb_config_2_node.ini \
lib/v1/mtr_gprof.pl \
lib/v1/mtr_misc.pl \
lib/v1/mtr_timer.pl \
lib/v1/mtr_im.pl \
lib/v1/mtr_process.pl \
lib/v1/mtr_unique.pl \
\
lib/mtr_cases.pm \
lib/mtr_gcov.pl \
lib/mtr_gprof.pl \
lib/mtr_io.pl \
......
# -*- cperl -*-
package My::Config::Option;
use strict;
use warnings;
sub new {
my ($class, $option_name, $option_value)= @_;
my $self= bless { name => $option_name,
value => $option_value
}, $class;
return $self;
}
sub name {
my ($self)= @_;
return $self->{name};
}
sub value {
my ($self)= @_;
return $self->{value};
}
package My::Config::Group;
use strict;
use warnings;
sub new {
my ($class, $group_name)= @_;
my $self= bless { name => $group_name,
options => [],
options_by_name => {},
}, $class;
return $self;
}
sub insert {
my ($self, $option_name, $value, $if_not_exist)= @_;
my $option= $self->option($option_name);
if (defined($option) and !$if_not_exist) {
$option->{value}= $value;
}
else {
my $option= My::Config::Option->new($option_name, $value);
# Insert option in list
push(@{$self->{options}}, $option);
# Insert option in hash
$self->{options_by_name}->{$option_name}= $option;
}
return $option;
}
sub remove {
my ($self, $option_name)= @_;
# Check that option exists
my $option= $self->option($option_name);
return undef unless defined $option;
# Remove from the hash
delete($self->{options_by_name}->{$option_name}) or die;
# Remove from the array
@{$self->{options}}= grep { $_->name ne $option_name } @{$self->{options}};
return $option;
}
sub options {
my ($self)= @_;
return @{$self->{options}};
}
sub name {
my ($self)= @_;
return $self->{name};
}
#
# Return a specific option in the group
#
sub option {
my ($self, $option_name)= @_;
return $self->{options_by_name}->{$option_name};
}
#
# Return a specific value for an option in the group
#
sub value {
my ($self, $option_name)= @_;
my $option= $self->option($option_name);
die "No option named '$option_name' in this group"
if ! defined($option);
return $option->value();
}
package My::Config;
use strict;
use warnings;
use IO::File;
use File::Basename;
#
# Constructor for My::Config
# - represents a my.cnf config file
#
# Array of arrays
#
sub new {
my ($class, $path)= @_;
my $group_name= undef;
my $self= bless { groups => [] }, $class;
my $F= IO::File->new($path, "<")
or die "Could not open '$path': $!";
while ( my $line= <$F> ) {
chomp($line);
# [group]
if ( $line =~ /\[(.*)\]/ ) {
# New group found
$group_name= $1;
#print "group: $group_name\n";
$self->insert($group_name, undef, undef);
}
# Magic #! comments
elsif ( $line =~ /^#\!/) {
my $magic= $line;
die "Found magic comment '$magic' outside of group"
unless $group_name;
#print "$magic\n";
$self->insert($group_name, $magic, undef);
}
# Comments
elsif ( $line =~ /^#/ || $line =~ /^;/) {
# Skip comment
next;
}
# Empty lines
elsif ( $line =~ /^$/ ) {
# Skip empty lines
next;
}
# !include <filename>
elsif ( $line =~ /^\!include\s*(.*?)\s*$/ ) {
my $include_file_name= dirname($path)."/".$1;
# Check that the file exists
die "The include file '$include_file_name' does not exist"
unless -f $include_file_name;
$self->append(My::Config->new($include_file_name));
}
# <option>
elsif ( $line =~ /^([\@\w-]+)\s*$/ ) {
my $option= $1;
die "Found option '$option' outside of group"
unless $group_name;
#print "$option\n";
$self->insert($group_name, $option, undef);
}
# <option>=<value>
elsif ( $line =~ /^([\@\w-]+)\s*=\s*(.*?)\s*$/ ) {
my $option= $1;
my $value= $2;
die "Found option '$option=$value' outside of group"
unless $group_name;
#print "$option=$value\n";
$self->insert($group_name, $option, $value);
} else {
die "Unexpected line '$line' found in '$path'";
}
}
undef $F; # Close the file
return $self;
}
#
# Insert a new group if it does not already exist
# and add option if defined
#
sub insert {
my ($self, $group_name, $option, $value, $if_not_exist)= @_;
my $group;
# Create empty array for the group if it doesn't exist
if ( !$self->group_exists($group_name) ) {
$group= $self->_group_insert($group_name);
}
else {
$group= $self->group($group_name);
}
if ( defined $option ) {
#print "option: $option, value: $value\n";
# Add the option to the group
$group->insert($option, $value, $if_not_exist);
}
}
#
# Remove a option, given group and option name
#
sub remove {
my ($self, $group_name, $option_name)= @_;
my $group= $self->group($group_name);
die "group '$group_name' does not exist"
unless defined($group);
$group->remove($option_name) or
die "option '$option_name' does not exist";
}
#
# Check if group with given name exists in config
#
sub group_exists {
my ($self, $group_name)= @_;
foreach my $group ($self->groups()) {
return 1 if $group->{name} eq $group_name;
}
return 0;
}
#
# Insert a new group into config
#
sub _group_insert {
my ($self, $group_name)= @_;
caller eq __PACKAGE__ or die;
# Check that group does not already exist
die "Group already exists" if $self->group_exists($group_name);
my $group= My::Config::Group->new($group_name);
push(@{$self->{groups}}, $group);
return $group;
}
#
# Append a configuration to current config
#
sub append {
my ($self, $from)= @_;
foreach my $group ($from->groups()) {
foreach my $option ($group->options()) {
$self->insert($group->name(), $option->name(), $option->value());
}
}
}
#
# Return a list with all the groups in config
#
sub groups {
my ($self)= @_;
return ( @{$self->{groups}} );
}
#
# Return a list of all the groups in config
# starting with the given string
#
sub like {
my ($self, $prefix)= @_;
return ( grep ( $_->{name} =~ /^$prefix/, $self->groups()) );
}
#
# Return the first group in config
# starting with the given string
#
sub first_like {
my ($self, $prefix)= @_;
return ($self->like($prefix))[0];
}
#
# Return a specific group in the config
#
sub group {
my ($self, $group_name)= @_;
foreach my $group ( $self->groups() ) {
return $group if $group->{name} eq $group_name;
}
return undef;
}
#
# Return a list of all options in a specific group in the config
#
sub options_in_group {
my ($self, $group_name)= @_;
my $group= $self->group($group_name);
return () unless defined $group;
return $group->options();
}
#
# Return a value given group and option name
#
sub value {
my ($self, $group_name, $option_name)= @_;
my $group= $self->group($group_name);
die "group '$group_name' does not exist"
unless defined($group);
my $option= $group->option($option_name);
die "option '$option_name' does not exist"
unless defined($option);
return $option->value();
}
#
# Check if an option exists
#
sub exists {
my ($self, $group_name, $option_name)= @_;
my $group= $self->group($group_name);
die "group '$group_name' does not exist"
unless defined($group);
my $option= $group->option($option_name);
return defined($option);
}
# Overload "to string"-operator with 'stringify'
use overload
'""' => \&stringify;
#
# Return the config as a string in my.cnf file format
#
sub stringify {
my ($self)= @_;
my $res;
foreach my $group ($self->groups()) {
$res .= "[$group->{name}]\n";
foreach my $option ($group->options()) {
$res .= $option->name();
my $value= $option->value();
if (defined $value) {
$res .= "=$value";
}
$res .= "\n";
}
$res .= "\n";
}
return $res;
}
#
# Save the config to named file
#
sub save {
my ($self, $path)= @_;
my $F= IO::File->new($path, ">")
or die "Could not open '$path': $!";
print $F $self;
undef $F; # Close the file
}
1;
# -*- cperl -*-
# Copyright (C) 2005-2006 MySQL AB
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
# This is a library file used by the Perl version of mysql-test-run,
# and is part of the translation of the Bourne shell script with the
# same name.
use File::Basename;
use IO::File();
use strict;
use My::Config;
sub collect_test_cases ($);
sub collect_one_suite ($);
sub collect_one_test_case ($$$$$$$$$);
sub mtr_options_from_test_file($$);
my $do_test;
my $skip_test;
sub init_pattern {
my ($from, $what)= @_;
if ( $from =~ /^[a-z0-9]$/ ) {
# Does not contain any regex, make the pattern match
# beginning of string
$from= "^$from";
}
# Check that pattern is a valid regex
eval { "" =~/$from/; 1 } or
mtr_error("Invalid regex '$from' passed to $what\nPerl says: $@");
return $from;
}
##############################################################################
#
# Collect information about test cases we are to run
#
##############################################################################
sub collect_test_cases ($) {
$do_test= init_pattern($::opt_do_test, "--do-test");
$skip_test= init_pattern($::opt_skip_test, "--skip-test");
my $suites= shift; # Semicolon separated list of test suites
my $cases = []; # Array of hash
foreach my $suite (split(",", $suites))
{
push(@$cases, collect_one_suite($suite));
}
if ( @::opt_cases )
{
# Check that the tests specified was found
# in at least one suite
foreach my $test_name_spec ( @::opt_cases )
{
my $found= 0;
my ($sname, $tname, $extension)= split_testname($test_name_spec);
foreach my $test ( @$cases )
{
# test->{name} is always in suite.name format
if ( $test->{name} =~ /.*\.$tname/ )
{
$found= 1;
}
}
if ( not $found )
{
mtr_error("Could not find $tname in any suite");
}
}
}
if ( $::opt_reorder )
{
# Reorder the test cases in an order that will make them faster to run
my %sort_criteria;
# Make a mapping of test name to a string that represents how that test
# should be sorted among the other tests. Put the most important criterion
# first, then a sub-criterion, then sub-sub-criterion, et c.
foreach my $tinfo (@$cases)
{
my @criteria = ();
# Look for tests that muct be in run in a defined order
# that is defined by test having the same name except for
# the ending digit
# Put variables into hash
my $test_name= $tinfo->{'name'};
my $depend_on_test_name;
if ( $test_name =~ /^([\D]+)([0-9]{1})$/ )
{
my $base_name= $1;
my $idx= $2;
mtr_verbose("$test_name => $base_name idx=$idx");
if ( $idx > 1 )
{
$idx-= 1;
$base_name= "$base_name$idx";
mtr_verbose("New basename $base_name");
}
foreach my $tinfo2 (@$cases)
{
if ( $tinfo2->{'name'} eq $base_name )
{
mtr_verbose("found dependent test $tinfo2->{'name'}");
$depend_on_test_name=$base_name;
}
}
}
if ( defined $depend_on_test_name )
{
mtr_verbose("Giving $test_name same critera as $depend_on_test_name");
$sort_criteria{$test_name} = $sort_criteria{$depend_on_test_name};
}
else
{
#
# Append the criteria for sorting, in order of importance.
#
push(@criteria, "ndb=" . ($tinfo->{'ndb_test'} ? "1" : "0"));
# Group test with equal options together.
# Ending with "~" makes empty sort later than filled
push(@criteria, join("!", sort @{$tinfo->{'master_opt'}}) . "~");
$sort_criteria{$test_name} = join(" ", @criteria);
}
}
@$cases = sort {
$sort_criteria{$a->{'name'}} . $a->{'name'} cmp
$sort_criteria{$b->{'name'}} . $b->{'name'}; } @$cases;
if ( $::opt_script_debug )
{
# For debugging the sort-order
foreach my $tinfo (@$cases)
{
print("$sort_criteria{$tinfo->{'name'}} -> \t$tinfo->{'name'}\n");
}
}
}
return $cases;
}
# Valid extensions and their corresonding component id
my %exts = ( 'test' => 'mysqld',
'imtest' => 'im'
);
# Returns (suitename, testname, extension)
sub split_testname {
my ($test_name)= @_;
# Get rid of directory part and split name on .'s
my @parts= split(/\./, basename($test_name));
if (@parts == 1){
# Only testname given, ex: alias
return (undef , $parts[0], undef);
} elsif (@parts == 2) {
# Either testname.test or suite.testname given
# Ex. main.alias or alias.test
if (defined $exts{$parts[1]})
{
return (undef , $parts[0], $parts[1]);
}
else
{
return ($parts[0], $parts[1], undef);
}
} elsif (@parts == 3) {
# Fully specified suitename.testname.test
# ex main.alias.test
return ( $parts[0], $parts[1], $parts[2]);
}
mtr_error("Illegal format of test name: $test_name");
}
sub collect_one_suite($)
{
my $suite= shift; # Test suite name
my @cases; # Array of hash
mtr_verbose("Collecting: $suite");
my $suitedir= "$::glob_mysql_test_dir"; # Default
if ( $suite ne "main" )
{
$suitedir= mtr_path_exists("$suitedir/suite/$suite",
"$suitedir/$suite");
mtr_verbose("suitedir: $suitedir");
}
my $testdir= "$suitedir/t";
my $resdir= "$suitedir/r";
# ----------------------------------------------------------------------
# Build a hash of disabled testcases for this suite
# ----------------------------------------------------------------------
my %disabled;
if ( open(DISABLED, "$testdir/disabled.def" ) )
{
while ( <DISABLED> )
{
chomp;
if ( /^\s*(\S+)\s*:\s*(.*?)\s*$/ )
{
$disabled{$1}= $2;
}
}
close DISABLED;
}
# Read suite.opt file
my $suite_opt_file= "$testdir/suite.opt";
my $suite_opts= [];
if ( -f $suite_opt_file )
{
$suite_opts= mtr_get_opts_from_file($suite_opt_file);
}
if ( @::opt_cases )
{
# Collect in specified order
foreach my $test_name_spec ( @::opt_cases )
{
my ($sname, $tname, $extension)= split_testname($test_name_spec);
# The test name parts have now been defined
#print " suite_name: $sname\n";
#print " tname: $tname\n";
#print " extension: $extension\n";
# Check cirrect suite if suitename is defined
next if (defined $sname and $suite ne $sname);
my $component_id;
if ( defined $extension )
{
my $full_name= "$testdir/$tname.$extension";
# Extension was specified, check if the test exists
if ( ! -f $full_name)
{
# This is only an error if suite was specified, otherwise it
# could exist in another suite
mtr_error("Test '$full_name' was not found in suite '$sname'")
if $sname;
next;
}
$component_id= $exts{$extension};
}
else
{
# No extension was specified
my ($ext, $component);
while (($ext, $component)= each %exts) {
my $full_name= "$testdir/$tname.$ext";
if ( ! -f $full_name ) {
next;
}
$component_id= $component;
$extension= $ext;
}
# Test not found here, could exist in other suite
next unless $component_id;
}
collect_one_test_case($testdir,$resdir,$suite,$tname,
"$tname.$extension",\@cases,\%disabled,
$component_id,$suite_opts);
}
}
else
{
opendir(TESTDIR, $testdir) or mtr_error("Can't open dir \"$testdir\": $!");
foreach my $elem ( sort readdir(TESTDIR) )
{
my $component_id= undef;
my $tname= undef;
if ($tname= mtr_match_extension($elem, 'test'))
{
$component_id = 'mysqld';
}
elsif ($tname= mtr_match_extension($elem, 'imtest'))
{
$component_id = 'im';
}
else
{
next;
}
# Skip tests that does not match the --do-test= filter
next if ($do_test and not $tname =~ /$do_test/o);
collect_one_test_case($testdir,$resdir,$suite,$tname,
$elem,\@cases,\%disabled,$component_id,
$suite_opts);
}
closedir TESTDIR;
}
# Return empty list if no testcases found
return if (@cases == 0);
# ----------------------------------------------------------------------
# Read combinations for this suite and build testcases x combinations
# if any combinations exists
# ----------------------------------------------------------------------
if ( ! $::opt_skip_combination )
{
my @combinations;
my $combination_file= "$suitedir/combinations";
#print "combination_file: $combination_file\n";
if (@::opt_combinations)
{
# take the combination from command-line
mtr_verbose("Take the combination from command line");
foreach my $combination (@::opt_combinations) {
my $comb= {};
$comb->{name}= $combination;
push(@{$comb->{comb_opt}}, $combination);
push(@combinations, $comb);
}
}
elsif (-f $combination_file )
{
# Read combinations file in my.cnf format
mtr_verbose("Read combinations file");
my $config= My::Config->new($combination_file);
foreach my $group ($config->groups()) {
my $comb= {};
$comb->{name}= $group->name();
foreach my $option ( $group->options() ) {
push(@{$comb->{comb_opt}}, $option->name()."=".$option->value());
}
push(@combinations, $comb);
}
}
if (@combinations)
{
print " - adding combinations\n";
#print_testcases(@cases);
my @new_cases;
foreach my $comb (@combinations)
{
foreach my $test (@cases)
{
#print $test->{name}, " ", $comb, "\n";
my $new_test= {};
while (my ($key, $value) = each(%$test)) {
if (ref $value eq "ARRAY") {
push(@{$new_test->{$key}}, @$value);
} else {
$new_test->{$key}= $value;
}
}
# Append the combination options to master_opt and slave_opt
push(@{$new_test->{master_opt}}, @{$comb->{comb_opt}});
push(@{$new_test->{slave_opt}}, @{$comb->{comb_opt}});
# Add combination name shrt name
$new_test->{combination}= $comb->{name};
# Add the new test to new test cases list
push(@new_cases, $new_test);
}
}
#print_testcases(@new_cases);
@cases= @new_cases;
#print_testcases(@cases);
}
}
optimize_cases(\@cases);
#print_testcases(@cases);
return @cases;
}
#
# Loop through all test cases
# - optimize which test to run by skipping unnecessary ones
# - update settings if necessary
#
sub optimize_cases {
my ($cases)= @_;
foreach my $tinfo ( @$cases )
{
# Skip processing if already marked as skipped
next if $tinfo->{skip};
# =======================================================
# If a special binlog format was selected with
# --mysqld=--binlog-format=x, skip all test that does not
# support it
# =======================================================
#print "used_binlog_format: $::used_binlog_format\n";
if (defined $::used_binlog_format )
{
# =======================================================
# Fixed --binlog-format=x specified on command line
# =======================================================
if ( defined $tinfo->{'binlog_formats'} )
{
#print "binlog_formats: ". join(", ", @{$tinfo->{binlog_formats}})."\n";
# The test supports different binlog formats
# check if the selected one is ok
my $supported=
grep { $_ eq $::used_binlog_format } @{$tinfo->{'binlog_formats'}};
if ( !$supported )
{
$tinfo->{'skip'}= 1;
$tinfo->{'comment'}=
"Doesn't support --binlog-format='$::used_binlog_format'";
}
}
}
else
{
# =======================================================
# Use dynamic switching of binlog format
# =======================================================
# Get binlog-format used by this test from master_opt
my $test_binlog_format;
foreach my $opt ( @{$tinfo->{master_opt}} ) {
$test_binlog_format=
mtr_match_prefix($opt, "--binlog-format=") || $test_binlog_format;
}
if (defined $test_binlog_format and
defined $tinfo->{binlog_formats} )
{
my $supported=
grep { $_ eq $test_binlog_format } @{$tinfo->{'binlog_formats'}};
if ( !$supported )
{
$tinfo->{'skip'}= 1;
$tinfo->{'comment'}=
"Doesn't support --binlog-format='$test_binlog_format'";
next;
}
}
}
}
}
##############################################################################
#
# Collect information about a single test case
#
##############################################################################
sub collect_one_test_case($$$$$$$$$) {
my $testdir= shift;
my $resdir= shift;
my $suite= shift;
my $tname= shift;
my $elem= shift;
my $cases= shift;
my $disabled=shift;
my $component_id= shift;
my $suite_opts= shift;
my $path= "$testdir/$elem";
# ----------------------------------------------------------------------
# Skip some tests silently
# ----------------------------------------------------------------------
if ( $::opt_start_from and $tname lt $::opt_start_from )
{
return;
}
my $tinfo= {};
$tinfo->{'name'}= basename($suite) . ".$tname";
$tinfo->{'result_file'}= "$resdir/$tname.result";
$tinfo->{'component_id'} = $component_id;
push(@$cases, $tinfo);
# ----------------------------------------------------------------------
# Skip some tests but include in list, just mark them to skip
# ----------------------------------------------------------------------
if ( $skip_test and $tname =~ /$skip_test/o )
{
$tinfo->{'skip'}= 1;
return;
}
# ----------------------------------------------------------------------
# Collect information about test case
# ----------------------------------------------------------------------
$tinfo->{'path'}= $path;
$tinfo->{'timezone'}= "GMT-3"; # for UNIX_TIMESTAMP tests to work
$tinfo->{'slave_num'}= 0; # Default, no slave
$tinfo->{'master_num'}= 1; # Default, 1 master
if ( defined mtr_match_prefix($tname,"rpl") )
{
if ( $::opt_skip_rpl )
{
$tinfo->{'skip'}= 1;
$tinfo->{'comment'}= "No replication tests(--skip-rpl)";
return;
}
$tinfo->{'slave_num'}= 1; # Default for rpl* tests, use one slave
}
if ( defined mtr_match_prefix($tname,"federated") )
{
# Default, federated uses the first slave as it's federated database
$tinfo->{'slave_num'}= 1;
}
my $master_opt_file= "$testdir/$tname-master.opt";
my $slave_opt_file= "$testdir/$tname-slave.opt";
my $slave_mi_file= "$testdir/$tname.slave-mi";
my $master_sh= "$testdir/$tname-master.sh";
my $slave_sh= "$testdir/$tname-slave.sh";
my $disabled_file= "$testdir/$tname.disabled";
my $im_opt_file= "$testdir/$tname-im.opt";
$tinfo->{'master_opt'}= [];
$tinfo->{'slave_opt'}= [];
$tinfo->{'slave_mi'}= [];
# Add suite opts
foreach my $opt ( @$suite_opts )
{
mtr_verbose($opt);
push(@{$tinfo->{'master_opt'}}, $opt);
push(@{$tinfo->{'slave_opt'}}, $opt);
}
# Add master opts
if ( -f $master_opt_file )
{
my $master_opt= mtr_get_opts_from_file($master_opt_file);
foreach my $opt ( @$master_opt )
{
my $value;
# The opt file is used both to send special options to the mysqld
# as well as pass special test case specific options to this
# script
$value= mtr_match_prefix($opt, "--timezone=");
if ( defined $value )
{
$tinfo->{'timezone'}= $value;
next;
}
$value= mtr_match_prefix($opt, "--slave-num=");
if ( defined $value )
{
$tinfo->{'slave_num'}= $value;
next;
}
$value= mtr_match_prefix($opt, "--result-file=");
if ( defined $value )
{
# Specifies the file mysqltest should compare
# output against
$tinfo->{'result_file'}= "r/$value.result";
next;
}
# If we set default time zone, remove the one we have
$value= mtr_match_prefix($opt, "--default-time-zone=");
if ( defined $value )
{
# Set timezone for this test case to something different
$tinfo->{'timezone'}= "GMT-8";
# Fallthrough, add the --default-time-zone option
}
# The --restart option forces a restart even if no special
# option is set. If the options are the same as next testcase
# there is no need to restart after the testcase
# has completed
if ( $opt eq "--force-restart" )
{
$tinfo->{'force_restart'}= 1;
next;
}
# Ok, this was a real option, add it
push(@{$tinfo->{'master_opt'}}, $opt);
}
}
# Add slave opts
if ( -f $slave_opt_file )
{
my $slave_opt= mtr_get_opts_from_file($slave_opt_file);
foreach my $opt ( @$slave_opt )
{
# If we set default time zone, remove the one we have
my $value= mtr_match_prefix($opt, "--default-time-zone=");
$tinfo->{'slave_opt'}= [] if defined $value;
}
push(@{$tinfo->{'slave_opt'}}, @$slave_opt);
}
if ( -f $slave_mi_file )
{
$tinfo->{'slave_mi'}= mtr_get_opts_from_file($slave_mi_file);
}
if ( -f $master_sh )
{
if ( $::glob_win32_perl )
{
$tinfo->{'skip'}= 1;
$tinfo->{'comment'}= "No tests with sh scripts on Windows";
return;
}
else
{
$tinfo->{'master_sh'}= $master_sh;
}
}
if ( -f $slave_sh )
{
if ( $::glob_win32_perl )
{
$tinfo->{'skip'}= 1;
$tinfo->{'comment'}= "No tests with sh scripts on Windows";
return;
}
else
{
$tinfo->{'slave_sh'}= $slave_sh;
}
}
if ( -f $im_opt_file )
{
$tinfo->{'im_opts'} = mtr_get_opts_from_file($im_opt_file);
}
else
{
$tinfo->{'im_opts'} = [];
}
# FIXME why this late?
my $marked_as_disabled= 0;
if ( $disabled->{$tname} )
{
$marked_as_disabled= 1;
$tinfo->{'comment'}= $disabled->{$tname};
}
if ( -f $disabled_file )
{
$marked_as_disabled= 1;
$tinfo->{'comment'}= mtr_fromfile($disabled_file);
}
# If test was marked as disabled, either opt_enable_disabled is off and then
# we skip this test, or it is on and then we run this test but warn
if ( $marked_as_disabled )
{
if ( $::opt_enable_disabled )
{
$tinfo->{'dont_skip_though_disabled'}= 1;
}
else
{
$tinfo->{'skip'}= 1;
$tinfo->{'disable'}= 1; # Sub type of 'skip'
return;
}
}
if ( $component_id eq 'im' )
{
if ( $::glob_use_embedded_server )
{
$tinfo->{'skip'}= 1;
$tinfo->{'comment'}= "No IM with embedded server";
return;
}
elsif ( $::opt_ps_protocol )
{
$tinfo->{'skip'}= 1;
$tinfo->{'comment'}= "No IM with --ps-protocol";
return;
}
elsif ( $::opt_skip_im )
{
$tinfo->{'skip'}= 1;
$tinfo->{'comment'}= "No IM tests(--skip-im)";
return;
}
}
else
{
mtr_options_from_test_file($tinfo,"$testdir/${tname}.test");
if ( defined $::used_default_engine )
{
# Different default engine is used
# tag test to require that engine
$tinfo->{'ndb_test'}= 1
if ( $::used_default_engine =~ /^ndb/i );
$tinfo->{'innodb_test'}= 1
if ( $::used_default_engine =~ /^innodb/i );
}
#enable federated for this test
if ($tinfo->{'federated_test'})
{
push(@{$tinfo->{'master_opt'}}, "--loose-federated");
push(@{$tinfo->{'slave_opt'}}, "--loose-federated");
}
if ( $tinfo->{'big_test'} and ! $::opt_big_test )
{
$tinfo->{'skip'}= 1;
$tinfo->{'comment'}= "Test need 'big-test' option";
return;
}
if ( $tinfo->{'ndb_extra'} and ! $::opt_ndb_extra_test )
{
$tinfo->{'skip'}= 1;
$tinfo->{'comment'}= "Test need 'ndb_extra' option";
return;
}
if ( $tinfo->{'require_manager'} )
{
$tinfo->{'skip'}= 1;
$tinfo->{'comment'}= "Test need the _old_ manager(to be removed)";
return;
}
if ( $tinfo->{'need_debug'} && ! $::debug_compiled_binaries )
{
$tinfo->{'skip'}= 1;
$tinfo->{'comment'}= "Test need debug binaries";
return;
}
if ( $tinfo->{'ndb_test'} )
{
# This is a NDB test
if ( ! $::glob_ndbcluster_supported )
{
# Ndb is not supported, skip it
$tinfo->{'skip'}= 1;
$tinfo->{'comment'}= "No ndbcluster support";
return;
}
elsif ( $::opt_skip_ndbcluster )
{
# All ndb test's should be skipped
$tinfo->{'skip'}= 1;
$tinfo->{'comment'}= "No ndbcluster tests(--skip-ndbcluster)";
return;
}
# Ndb tests run with two mysqld masters
$tinfo->{'master_num'}= 2;
}
else
{
# This is not a ndb test
if ( $::opt_with_ndbcluster_only )
{
# Only the ndb test should be run, all other should be skipped
$tinfo->{'skip'}= 1;
$tinfo->{'comment'}= "Only ndbcluster tests(--with-ndbcluster-only)";
return;
}
}
if ( $tinfo->{'innodb_test'} )
{
# This is a test that need innodb
if ( $::mysqld_variables{'innodb'} ne "TRUE" )
{
# innodb is not supported, skip it
$tinfo->{'skip'}= 1;
$tinfo->{'comment'}= "No innodb support";
return;
}
}
if ( $tinfo->{'need_binlog'} )
{
if (grep(/^--skip-log-bin/, @::opt_extra_mysqld_opt) )
{
$tinfo->{'skip'}= 1;
$tinfo->{'comment'}= "Test need binlog";
return;
}
}
else
{
if ( $::mysql_version_id >= 50100 )
{
# Test does not need binlog, add --skip-binlog to
# the options used when starting it
push(@{$tinfo->{'master_opt'}}, "--skip-log-bin");
}
}
}
}
# List of tags in the .test files that if found should set
# the specified value in "tinfo"
our @tags=
(
["include/have_binlog_format_row.inc", "binlog_formats", ["row"]],
["include/have_binlog_format_statement.inc", "binlog_formats", ["statement"]],
["include/have_binlog_format_mixed.inc", "binlog_formats", ["mixed"]],
["include/have_binlog_format_mixed_or_row.inc",
"binlog_formats", ["mixed", "row"]],
["include/have_binlog_format_mixed_or_statement.inc",
"binlog_formats", ["mixed", "statement"]],
["include/have_binlog_format_row_or_statement.inc",
"binlog_formats", ["row", "statement"]],
["include/have_innodb.inc", "innodb_test", 1],
["include/have_log_bin.inc", "need_binlog", 1],
["include/big_test.inc", "big_test", 1],
["include/have_debug.inc", "need_debug", 1],
["include/have_ndb.inc", "ndb_test", 1],
["include/have_multi_ndb.inc", "ndb_test", 1],
["include/have_ndb_extra.inc", "ndb_extra", 1],
["include/ndb_master-slave.inc", "ndb_test", 1],
["require_manager", "require_manager", 1],
["include/federated.inc", "federated_test", 1],
["include/have_federated_db.inc", "federated_test", 1],
);
sub mtr_options_from_test_file($$) {
my $tinfo= shift;
my $file= shift;
#mtr_verbose("$file");
my $F= IO::File->new($file) or mtr_error("can't open file \"$file\": $!");
while ( my $line= <$F> )
{
# Skip line if it start's with #
next if ( $line =~ /^#/ );
# Match this line against tag in "tags" array
foreach my $tag (@tags)
{
if ( index($line, $tag->[0]) >= 0 )
{
# Tag matched, assign value to "tinfo"
$tinfo->{"$tag->[1]"}= $tag->[2];
}
}
# If test sources another file, open it as well
if ( $line =~ /^\-\-([[:space:]]*)source(.*)$/ or
$line =~ /^([[:space:]]*)source(.*);$/ )
{
my $value= $2;
$value =~ s/^\s+//; # Remove leading space
$value =~ s/[[:space:]]+$//; # Remove ending space
my $sourced_file= "$::glob_mysql_test_dir/$value";
if ( -f $sourced_file )
{
# Only source the file if it exists, we may get
# false positives in the regexes above if someone
# writes "source nnnn;" in a test case(such as mysqltest.test)
mtr_options_from_test_file($tinfo, $sourced_file);
}
}
}
}
sub print_testcases {
my (@cases)= @_;
print "=" x 60, "\n";
foreach my $test (@cases){
print "[", $test->{name}, "]", "\n";
while ((my ($key, $value)) = each(%$test)) {
print " ", $key, "=";
if (ref $value eq "ARRAY") {
print join(", ", @$value);
} else {
print $value;
}
print "\n";
}
print "\n";
}
print "=" x 60, "\n";
}
1;
# -*- cperl -*-
# Copyright (C) 2004, 2006 MySQL AB
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
# This is a library file used by the Perl version of mysql-test-run,
# and is part of the translation of the Bourne shell script with the
# same name.
use strict;
# These are not to be prefixed with "mtr_"
sub gcov_prepare ();
sub gcov_collect ();
##############################################################################
#
#
#
##############################################################################
sub gcov_prepare () {
`find $::glob_basedir -name \*.gcov \
-or -name \*.da | xargs rm`;
}
# Used by gcov
our @mysqld_src_dirs=
(
"strings",
"mysys",
"include",
"extra",
"regex",
"isam",
"merge",
"myisam",
"myisammrg",
"heap",
"sql",
);
sub gcov_collect () {
print "Collecting source coverage info...\n";
-f $::opt_gcov_msg and unlink($::opt_gcov_msg);
-f $::opt_gcov_err and unlink($::opt_gcov_err);
foreach my $d ( @mysqld_src_dirs )
{
chdir("$::glob_basedir/$d");
foreach my $f ( (glob("*.h"), glob("*.cc"), glob("*.c")) )
{
`$::opt_gcov $f 2>>$::opt_gcov_err >>$::opt_gcov_msg`;
}
chdir($::glob_mysql_test_dir);
}
print "gcov info in $::opt_gcov_msg, errors in $::opt_gcov_err\n";
}
1;
# -*- cperl -*-
# Copyright (C) 2004 MySQL AB
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
# This is a library file used by the Perl version of mysql-test-run,
# and is part of the translation of the Bourne shell script with the
# same name.
use strict;
# These are not to be prefixed with "mtr_"
sub gprof_prepare ();
sub gprof_collect ();
##############################################################################
#
#
#
##############################################################################
sub gprof_prepare () {
rmtree($::opt_gprof_dir);
mkdir($::opt_gprof_dir);
}
# FIXME what about master1 and slave1?!
sub gprof_collect () {
if ( -f "$::master->[0]->{'path_myddir'}/gmon.out" )
{
# FIXME check result code?!
mtr_run("gprof",
[$::exe_master_mysqld,
"$::master->[0]->{'path_myddir'}/gmon.out"],
$::opt_gprof_master, "", "", "");
print "Master execution profile has been saved in $::opt_gprof_master\n";
}
if ( -f "$::slave->[0]->{'path_myddir'}/gmon.out" )
{
# FIXME check result code?!
mtr_run("gprof",
[$::exe_slave_mysqld,
"$::slave->[0]->{'path_myddir'}/gmon.out"],
$::opt_gprof_slave, "", "", "");
print "Slave execution profile has been saved in $::opt_gprof_slave\n";
}
}
1;
# -*- cperl -*-
# Copyright (C) 2006 MySQL AB
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
# This is a library file used by the Perl version of mysql-test-run,
# and is part of the translation of the Bourne shell script with the
# same name.
use strict;
# Private IM-related operations.
sub mtr_im_kill_process ($$$$);
sub mtr_im_load_pids ($);
sub mtr_im_terminate ($);
sub mtr_im_check_alive ($);
sub mtr_im_check_main_alive ($);
sub mtr_im_check_angel_alive ($);
sub mtr_im_check_mysqlds_alive ($);
sub mtr_im_check_mysqld_alive ($);
sub mtr_im_cleanup ($);
sub mtr_im_rm_file ($);
sub mtr_im_errlog ($);
sub mtr_im_kill ($);
sub mtr_im_wait_for_connection ($$$);
sub mtr_im_wait_for_mysqld($$$);
# Public IM-related operations.
sub mtr_im_start ($$);
sub mtr_im_stop ($);
##############################################################################
#
# Private operations.
#
##############################################################################
sub mtr_im_kill_process ($$$$) {
my $pid_lst= shift;
my $signal= shift;
my $total_retries= shift;
my $timeout= shift;
my %pids;
foreach my $pid ( @{$pid_lst} )
{
$pids{$pid}= 1;
}
for ( my $cur_attempt= 1; $cur_attempt <= $total_retries; ++$cur_attempt )
{
foreach my $pid ( keys %pids )
{
mtr_debug("Sending $signal to $pid...");
kill($signal, $pid);
unless ( kill (0, $pid) )
{
mtr_debug("Process $pid died.");
delete $pids{$pid};
}
}
return if scalar keys %pids == 0;
mtr_debug("Sleeping $timeout second(s) waiting for processes to die...");
sleep($timeout);
}
mtr_debug("Process(es) " .
join(' ', keys %pids) .
" is still alive after $total_retries " .
"of sending signal $signal.");
}
###########################################################################
sub mtr_im_load_pids($) {
my $im= shift;
mtr_debug("Loading PID files...");
# Obtain mysqld-process pids.
my $instances = $im->{'instances'};
for ( my $idx= 0; $idx < 2; ++$idx )
{
mtr_debug("IM-guarded mysqld[$idx] PID file: '" .
$instances->[$idx]->{'path_pid'} . "'.");
my $mysqld_pid;
if ( -r $instances->[$idx]->{'path_pid'} )
{
$mysqld_pid= mtr_get_pid_from_file($instances->[$idx]->{'path_pid'});
mtr_debug("IM-guarded mysqld[$idx] PID: $mysqld_pid.");
}
else
{
$mysqld_pid= undef;
mtr_debug("IM-guarded mysqld[$idx]: no PID file.");
}
$instances->[$idx]->{'pid'}= $mysqld_pid;
}
# Re-read Instance Manager PIDs from the file, since during tests Instance
# Manager could have been restarted, so its PIDs could have been changed.
# - IM-main
mtr_debug("IM-main PID file: '$im->{path_pid}'.");
if ( -f $im->{'path_pid'} )
{
$im->{'pid'} =
mtr_get_pid_from_file($im->{'path_pid'});
mtr_debug("IM-main PID: $im->{pid}.");
}
else
{
mtr_debug("IM-main: no PID file.");
$im->{'pid'}= undef;
}
# - IM-angel
mtr_debug("IM-angel PID file: '$im->{path_angel_pid}'.");
if ( -f $im->{'path_angel_pid'} )
{
$im->{'angel_pid'} =
mtr_get_pid_from_file($im->{'path_angel_pid'});
mtr_debug("IM-angel PID: $im->{'angel_pid'}.");
}
else
{
mtr_debug("IM-angel: no PID file.");
$im->{'angel_pid'} = undef;
}
}
###########################################################################
sub mtr_im_terminate($) {
my $im= shift;
# Load pids from pid-files. We should do it first of all, because IM deletes
# them on shutdown.
mtr_im_load_pids($im);
mtr_debug("Shutting Instance Manager down...");
# Ignoring SIGCHLD so that all children could rest in peace.
start_reap_all();
# Send SIGTERM to IM-main.
if ( defined $im->{'pid'} )
{
mtr_debug("IM-main pid: $im->{pid}.");
mtr_debug("Stopping IM-main...");
mtr_im_kill_process([ $im->{'pid'} ], 'TERM', 10, 1);
}
else
{
mtr_debug("IM-main pid: n/a.");
}
# If IM-angel was alive, wait for it to die.
if ( defined $im->{'angel_pid'} )
{
mtr_debug("IM-angel pid: $im->{'angel_pid'}.");
mtr_debug("Waiting for IM-angel to die...");
my $total_attempts= 10;
for ( my $cur_attempt=1; $cur_attempt <= $total_attempts; ++$cur_attempt )
{
unless ( kill (0, $im->{'angel_pid'}) )
{
mtr_debug("IM-angel died.");
last;
}
sleep(1);
}
}
else
{
mtr_debug("IM-angel pid: n/a.");
}
stop_reap_all();
# Re-load PIDs.
mtr_im_load_pids($im);
}
###########################################################################
sub mtr_im_check_alive($) {
my $im= shift;
mtr_debug("Checking whether IM-components are alive...");
return 1 if mtr_im_check_main_alive($im);
return 1 if mtr_im_check_angel_alive($im);
return 1 if mtr_im_check_mysqlds_alive($im);
return 0;
}
###########################################################################
sub mtr_im_check_main_alive($) {
my $im= shift;
# Check that the process, that we know to be IM's, is dead.
if ( defined $im->{'pid'} )
{
if ( kill (0, $im->{'pid'}) )
{
mtr_debug("IM-main (PID: $im->{pid}) is alive.");
return 1;
}
else
{
mtr_debug("IM-main (PID: $im->{pid}) is dead.");
}
}
else
{
mtr_debug("No PID file for IM-main.");
}
# Check that IM does not accept client connections.
if ( mtr_ping_port($im->{'port'}) )
{
mtr_debug("IM-main (port: $im->{port}) " .
"is accepting connections.");
mtr_im_errlog("IM-main is accepting connections on port " .
"$im->{port}, but there is no " .
"process information.");
return 1;
}
else
{
mtr_debug("IM-main (port: $im->{port}) " .
"does not accept connections.");
return 0;
}
}
###########################################################################
sub mtr_im_check_angel_alive($) {
my $im= shift;
# Check that the process, that we know to be the Angel, is dead.
if ( defined $im->{'angel_pid'} )
{
if ( kill (0, $im->{'angel_pid'}) )
{
mtr_debug("IM-angel (PID: $im->{angel_pid}) is alive.");
return 1;
}
else
{
mtr_debug("IM-angel (PID: $im->{angel_pid}) is dead.");
return 0;
}
}
else
{
mtr_debug("No PID file for IM-angel.");
return 0;
}
}
###########################################################################
sub mtr_im_check_mysqlds_alive($) {
my $im= shift;
mtr_debug("Checking for IM-guarded mysqld instances...");
my $instances = $im->{'instances'};
for ( my $idx= 0; $idx < 2; ++$idx )
{
mtr_debug("Checking mysqld[$idx]...");
return 1
if mtr_im_check_mysqld_alive($instances->[$idx]);
}
}
###########################################################################
sub mtr_im_check_mysqld_alive($) {
my $mysqld_instance= shift;
# Check that the process is dead.
if ( defined $mysqld_instance->{'pid'} )
{
if ( kill (0, $mysqld_instance->{'pid'}) )
{
mtr_debug("Mysqld instance (PID: $mysqld_instance->{pid}) is alive.");
return 1;
}
else
{
mtr_debug("Mysqld instance (PID: $mysqld_instance->{pid}) is dead.");
}
}
else
{
mtr_debug("No PID file for mysqld instance.");
}
# Check that mysqld does not accept client connections.
if ( mtr_ping_port($mysqld_instance->{'port'}) )
{
mtr_debug("Mysqld instance (port: $mysqld_instance->{port}) " .
"is accepting connections.");
mtr_im_errlog("Mysqld is accepting connections on port " .
"$mysqld_instance->{port}, but there is no " .
"process information.");
return 1;
}
else
{
mtr_debug("Mysqld instance (port: $mysqld_instance->{port}) " .
"does not accept connections.");
return 0;
}
}
###########################################################################
sub mtr_im_cleanup($) {
my $im= shift;
mtr_im_rm_file($im->{'path_pid'});
mtr_im_rm_file($im->{'path_sock'});
mtr_im_rm_file($im->{'path_angel_pid'});
for ( my $idx= 0; $idx < 2; ++$idx )
{
mtr_im_rm_file($im->{'instances'}->[$idx]->{'path_pid'});
mtr_im_rm_file($im->{'instances'}->[$idx]->{'path_sock'});
}
}
###########################################################################
sub mtr_im_rm_file($)
{
my $file_path= shift;
if ( -f $file_path )
{
mtr_debug("Removing '$file_path'...");
unless ( unlink($file_path) )
{
mtr_warning("Can not remove '$file_path'.")
}
}
else
{
mtr_debug("File '$file_path' does not exist already.");
}
}
###########################################################################
sub mtr_im_errlog($) {
my $msg= shift;
# Complain in error log so that a warning will be shown.
#
# TODO: unless BUG#20761 is fixed, we will print the warning to stdout, so
# that it can be seen on console and does not produce pushbuild error.
# my $errlog= "$opt_vardir/log/mysql-test-run.pl.err";
#
# open (ERRLOG, ">>$errlog") ||
# mtr_error("Can not open error log ($errlog)");
#
# my $ts= localtime();
# print ERRLOG
# "Warning: [$ts] $msg\n";
#
# close ERRLOG;
my $ts= localtime();
print "Warning: [$ts] $msg\n";
}
###########################################################################
sub mtr_im_kill($) {
my $im= shift;
# Re-load PIDs. That can be useful because some processes could have been
# restarted.
mtr_im_load_pids($im);
# Ignoring SIGCHLD so that all children could rest in peace.
start_reap_all();
# Kill IM-angel first of all.
if ( defined $im->{'angel_pid'} )
{
mtr_debug("Killing IM-angel (PID: $im->{angel_pid})...");
mtr_im_kill_process([ $im->{'angel_pid'} ], 'KILL', 10, 1)
}
else
{
mtr_debug("IM-angel is dead.");
}
# Re-load PIDs again.
mtr_im_load_pids($im);
# Kill IM-main.
if ( defined $im->{'pid'} )
{
mtr_debug("Killing IM-main (PID: $im->pid})...");
mtr_im_kill_process([ $im->{'pid'} ], 'KILL', 10, 1);
}
else
{
mtr_debug("IM-main is dead.");
}
# Re-load PIDs again.
mtr_im_load_pids($im);
# Kill guarded mysqld instances.
my @mysqld_pids;
mtr_debug("Collecting PIDs of mysqld instances to kill...");
for ( my $idx= 0; $idx < 2; ++$idx )
{
my $pid= $im->{'instances'}->[$idx]->{'pid'};
unless ( defined $pid )
{
next;
}
mtr_debug(" - IM-guarded mysqld[$idx] PID: $pid.");
push (@mysqld_pids, $pid);
}
if ( scalar @mysqld_pids > 0 )
{
mtr_debug("Killing IM-guarded mysqld instances...");
mtr_im_kill_process(\@mysqld_pids, 'KILL', 10, 1);
}
# That's all.
stop_reap_all();
}
##############################################################################
sub mtr_im_wait_for_connection($$$) {
my $im= shift;
my $total_attempts= shift;
my $connect_timeout= shift;
mtr_debug("Waiting for IM on port $im->{port} " .
"to start accepting connections...");
for ( my $cur_attempt= 1; $cur_attempt <= $total_attempts; ++$cur_attempt )
{
mtr_debug("Trying to connect to IM ($cur_attempt of $total_attempts)...");
if ( mtr_ping_port($im->{'port'}) )
{
mtr_debug("IM is accepting connections " .
"on port $im->{port}.");
return 1;
}
mtr_debug("Sleeping $connect_timeout...");
sleep($connect_timeout);
}
mtr_debug("IM does not accept connections " .
"on port $im->{port} after " .
($total_attempts * $connect_timeout) . " seconds.");
return 0;
}
##############################################################################
sub mtr_im_wait_for_mysqld($$$) {
my $mysqld= shift;
my $total_attempts= shift;
my $connect_timeout= shift;
mtr_debug("Waiting for IM-guarded mysqld on port $mysqld->{port} " .
"to start accepting connections...");
for ( my $cur_attempt= 1; $cur_attempt <= $total_attempts; ++$cur_attempt )
{
mtr_debug("Trying to connect to mysqld " .
"($cur_attempt of $total_attempts)...");
if ( mtr_ping_port($mysqld->{'port'}) )
{
mtr_debug("Mysqld is accepting connections " .
"on port $mysqld->{port}.");
return 1;
}
mtr_debug("Sleeping $connect_timeout...");
sleep($connect_timeout);
}
mtr_debug("Mysqld does not accept connections " .
"on port $mysqld->{port} after " .
($total_attempts * $connect_timeout) . " seconds.");
return 0;
}
##############################################################################
#
# Public operations.
#
##############################################################################
sub mtr_im_start($$) {
my $im = shift;
my $opts = shift;
mtr_debug("Starting Instance Manager...");
my $args;
mtr_init_args(\$args);
mtr_add_arg($args, "--defaults-file=%s", $im->{'defaults_file'});
foreach my $opt ( @{$opts} )
{
mtr_add_arg($args, $opt);
}
$im->{'spawner_pid'} =
mtr_spawn(
$::exe_im, # path to the executable
$args, # cmd-line args
'', # stdin
$im->{'path_log'}, # stdout
$im->{'path_err'}, # stderr
'', # pid file path (not used)
{ append_log_file => 1 } # append log files
);
unless ( $im->{'spawner_pid'} )
{
mtr_error('Could not start Instance Manager.')
}
# Instance Manager can be run in daemon mode. In this case, it creates
# several processes and the parent process, created by mtr_spawn(), exits just
# after start. So, we have to obtain Instance Manager PID from the PID file.
mtr_debug("Waiting for IM to create PID file (" .
"path: '$im->{path_pid}'; " .
"timeout: $im->{start_timeout})...");
unless ( sleep_until_file_created($im->{'path_pid'},
$im->{'start_timeout'},
-1) ) # real PID is still unknown
{
mtr_debug("IM has not created PID file in $im->{start_timeout} secs.");
mtr_debug("Aborting test suite...");
mtr_kill_leftovers();
mtr_report("IM has not created PID file in $im->{start_timeout} secs.");
return 0;
}
$im->{'pid'}= mtr_get_pid_from_file($im->{'path_pid'});
mtr_debug("Instance Manager started. PID: $im->{pid}.");
# Wait until we can connect to IM.
my $IM_CONNECT_TIMEOUT= 30;
unless ( mtr_im_wait_for_connection($im,
$IM_CONNECT_TIMEOUT, 1) )
{
mtr_debug("Can not connect to Instance Manager " .
"in $IM_CONNECT_TIMEOUT seconds after start.");
mtr_debug("Aborting test suite...");
mtr_kill_leftovers();
mtr_report("Can not connect to Instance Manager " .
"in $IM_CONNECT_TIMEOUT seconds after start.");
return 0;
}
# Wait for IM to start guarded instances:
# - wait for PID files;
mtr_debug("Waiting for guarded mysqlds instances to create PID files...");
for ( my $idx= 0; $idx < 2; ++$idx )
{
my $mysqld= $im->{'instances'}->[$idx];
if ( exists $mysqld->{'nonguarded'} )
{
next;
}
mtr_debug("Waiting for mysqld[$idx] to create PID file (" .
"path: '$mysqld->{path_pid}'; " .
"timeout: $mysqld->{start_timeout})...");
unless ( sleep_until_file_created($mysqld->{'path_pid'},
$mysqld->{'start_timeout'},
-1) ) # real PID is still unknown
{
mtr_debug("mysqld[$idx] has not created PID file in " .
"$mysqld->{start_timeout} secs.");
mtr_debug("Aborting test suite...");
mtr_kill_leftovers();
mtr_report("mysqld[$idx] has not created PID file in " .
"$mysqld->{start_timeout} secs.");
return 0;
}
mtr_debug("PID file for mysqld[$idx] ($mysqld->{path_pid} created.");
}
# Wait until we can connect to guarded mysqld-instances
# (in other words -- wait for IM to start guarded instances).
mtr_debug("Waiting for guarded mysqlds to start accepting connections...");
for ( my $idx= 0; $idx < 2; ++$idx )
{
my $mysqld= $im->{'instances'}->[$idx];
if ( exists $mysqld->{'nonguarded'} )
{
next;
}
mtr_debug("Waiting for mysqld[$idx] to accept connection...");
unless ( mtr_im_wait_for_mysqld($mysqld, 30, 1) )
{
mtr_debug("Can not connect to mysqld[$idx] " .
"in $IM_CONNECT_TIMEOUT seconds after start.");
mtr_debug("Aborting test suite...");
mtr_kill_leftovers();
mtr_report("Can not connect to mysqld[$idx] " .
"in $IM_CONNECT_TIMEOUT seconds after start.");
return 0;
}
mtr_debug("mysqld[$idx] started.");
}
mtr_debug("Instance Manager and its components are up and running.");
return 1;
}
##############################################################################
sub mtr_im_stop($) {
my $im= shift;
mtr_debug("Stopping Instance Manager...");
# Try graceful shutdown.
mtr_im_terminate($im);
# Check that all processes died.
unless ( mtr_im_check_alive($im) )
{
mtr_debug("Instance Manager has been stopped successfully.");
mtr_im_cleanup($im);
return 1;
}
# Instance Manager don't want to die. We should kill it.
mtr_im_errlog("Instance Manager did not shutdown gracefully.");
mtr_im_kill($im);
# Check again that all IM-related processes have been killed.
my $im_is_alive= mtr_im_check_alive($im);
mtr_im_cleanup($im);
if ( $im_is_alive )
{
mtr_debug("Can not kill Instance Manager or its children.");
return 0;
}
mtr_debug("Instance Manager has been killed successfully.");
return 1;
}
###########################################################################
1;
# -*- cperl -*-
# Copyright (C) 2004-2006 MySQL AB
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
# This is a library file used by the Perl version of mysql-test-run,
# and is part of the translation of the Bourne shell script with the
# same name.
use strict;
sub mtr_get_pid_from_file ($);
sub mtr_get_opts_from_file ($);
sub mtr_fromfile ($);
sub mtr_tofile ($@);
sub mtr_tonewfile($@);
sub mtr_lastlinefromfile($);
sub mtr_appendfile_to_file ($$);
sub mtr_grab_file($);
##############################################################################
#
#
#
##############################################################################
sub mtr_get_pid_from_file ($) {
my $pid_file_path= shift;
my $TOTAL_ATTEMPTS= 30;
my $timeout= 1;
# We should read from the file until we get correct pid. As it is
# stated in BUG#21884, pid file can be empty at some moment. So, we should
# read it until we get valid data.
for (my $cur_attempt= 1; $cur_attempt <= $TOTAL_ATTEMPTS; ++$cur_attempt)
{
mtr_debug("Reading pid file '$pid_file_path' " .
"($cur_attempt of $TOTAL_ATTEMPTS)...");
open(FILE, '<', $pid_file_path)
or mtr_error("can't open file \"$pid_file_path\": $!");
# Read pid number from file
my $pid= <FILE>;
chomp $pid;
close FILE;
return $pid if $pid=~ /^(\d+)/;
mtr_debug("Pid file '$pid_file_path' does not yet contain pid number.\n" .
"Sleeping $timeout second(s) more...");
sleep($timeout);
}
mtr_error("Pid file '$pid_file_path' is corrupted. " .
"Can not retrieve PID in " .
($timeout * $TOTAL_ATTEMPTS) . " seconds.");
}
sub mtr_get_opts_from_file ($) {
my $file= shift;
open(FILE,"<",$file) or mtr_error("can't open file \"$file\": $!");
my @args;
while ( <FILE> )
{
chomp;
# --set-variable=init_connect=set @a='a\\0c'
s/^\s+//; # Remove leading space
s/\s+$//; # Remove ending space
# This is strange, but we need to fill whitespace inside
# quotes with something, to remove later. We do this to
# be able to split on space. Else, we have trouble with
# options like
#
# --someopt="--insideopt1 --insideopt2"
#
# But still with this, we are not 100% sure it is right,
# we need a shell to do it right.
# print STDERR "\n";
# print STDERR "AAA: $_\n";
s/\'([^\'\"]*)\'/unspace($1,"\x0a")/ge;
s/\"([^\'\"]*)\"/unspace($1,"\x0b")/ge;
s/\'([^\'\"]*)\'/unspace($1,"\x0a")/ge;
s/\"([^\'\"]*)\"/unspace($1,"\x0b")/ge;
# print STDERR "BBB: $_\n";
# foreach my $arg (/(--?\w.*?)(?=\s+--?\w|$)/)
# FIXME ENV vars should be expanded!!!!
foreach my $arg (split(/[ \t]+/))
{
$arg =~ tr/\x11\x0a\x0b/ \'\"/; # Put back real chars
# The outermost quotes has to go
$arg =~ s/^([^\'\"]*)\'(.*)\'([^\'\"]*)$/$1$2$3/
or $arg =~ s/^([^\'\"]*)\"(.*)\"([^\'\"]*)$/$1$2$3/;
$arg =~ s/\\\\/\\/g;
$arg =~ s/\$\{(\w+)\}/envsubst($1)/ge;
$arg =~ s/\$(\w+)/envsubst($1)/ge;
# print STDERR "ARG: $arg\n";
# Do not pass empty string since my_getopt is not capable to handle it.
if (length($arg))
{
push(@args, $arg)
}
}
}
close FILE;
return \@args;
}
sub envsubst {
my $string= shift;
if ( ! defined $ENV{$string} )
{
mtr_error("opt file referense \$$string that is unknown");
}
return $ENV{$string};
}
sub unspace {
my $string= shift;
my $quote= shift;
$string =~ s/[ \t]/\x11/g;
return "$quote$string$quote";
}
# Read a whole file, stripping leading and trailing whitespace.
sub mtr_fromfile ($) {
my $file= shift;
open(FILE,"<",$file) or mtr_error("can't open file \"$file\": $!");
my $text= join('', <FILE>);
close FILE;
$text =~ s/^\s+//; # Remove starting space, incl newlines
$text =~ s/\s+$//; # Remove ending space, incl newlines
return $text;
}
sub mtr_lastlinefromfile ($) {
my $file= shift;
my $text;
open(FILE,"<",$file) or mtr_error("can't open file \"$file\": $!");
while (my $line= <FILE>)
{
$text= $line;
}
close FILE;
return $text;
}
sub mtr_tofile ($@) {
my $file= shift;
open(FILE,">>",$file) or mtr_error("can't open file \"$file\": $!");
print FILE join("", @_);
close FILE;
}
sub mtr_tonewfile ($@) {
my $file= shift;
open(FILE,">",$file) or mtr_error("can't open file \"$file\": $!");
print FILE join("", @_);
close FILE;
}
sub mtr_appendfile_to_file ($$) {
my $from_file= shift;
my $to_file= shift;
open(TOFILE,">>",$to_file) or mtr_error("can't open file \"$to_file\": $!");
open(FROMFILE,"<",$from_file)
or mtr_error("can't open file \"$from_file\": $!");
print TOFILE while (<FROMFILE>);
close FROMFILE;
close TOFILE;
}
# Read a whole file verbatim.
sub mtr_grab_file($) {
my $file= shift;
open(FILE, '<', $file)
or return undef;
local $/= undef;
my $data= scalar(<FILE>);
close FILE;
return $data;
}
1;
# -*- cperl -*-
# Copyright (C) 2004-2006 MySQL AB
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
# This is a library file used by the Perl version of mysql-test-run,
# and is part of the translation of the Bourne shell script with the
# same name.
use strict;
sub mtr_match_prefix ($$);
sub mtr_match_extension ($$);
sub mtr_match_any_exact ($$);
##############################################################################
#
#
#
##############################################################################
# Match a prefix and return what is after the prefix
sub mtr_match_prefix ($$) {
my $string= shift;
my $prefix= shift;
if ( $string =~ /^\Q$prefix\E(.*)$/ ) # strncmp
{
return $1;
}
else
{
return undef; # NULL
}
}
# Match extension and return the name without extension
sub mtr_match_extension ($$) {
my $file= shift;
my $ext= shift;
if ( $file =~ /^(.*)\.\Q$ext\E$/ ) # strchr+strcmp or something
{
return $1;
}
else
{
return undef; # NULL
}
}
# Match a substring anywere in a string
sub mtr_match_substring ($$) {
my $string= shift;
my $substring= shift;
if ( $string =~ /(.*)\Q$substring\E(.*)$/ ) # strncmp
{
return $1;
}
else
{
return undef; # NULL
}
}
sub mtr_match_any_exact ($$) {
my $string= shift;
my $mlist= shift;
foreach my $m (@$mlist)
{
if ( $string eq $m )
{
return 1;
}
}
return 0;
}
1;
# -*- cperl -*-
# Copyright (C) 2004-2006 MySQL AB
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
# This is a library file used by the Perl version of mysql-test-run,
# and is part of the translation of the Bourne shell script with the
# same name.
use strict;
use File::Find;
sub mtr_native_path($);
sub mtr_init_args ($);
sub mtr_add_arg ($$@);
sub mtr_path_exists(@);
sub mtr_script_exists(@);
sub mtr_file_exists(@);
sub mtr_exe_exists(@);
sub mtr_exe_maybe_exists(@);
sub mtr_copy_dir($$);
sub mtr_rmtree($);
sub mtr_same_opts($$);
sub mtr_cmp_opts($$);
##############################################################################
#
# Misc
#
##############################################################################
# Convert path to OS native format
sub mtr_native_path($)
{
my $path= shift;
# MySQL version before 5.0 still use cygwin, no need
# to convert path
return $path
if ($::mysql_version_id < 50000);
$path=~ s/\//\\/g
if ($::glob_win32);
return $path;
}
# FIXME move to own lib
sub mtr_init_args ($) {
my $args = shift;
$$args = []; # Empty list
}
sub mtr_add_arg ($$@) {
my $args= shift;
my $format= shift;
my @fargs = @_;
push(@$args, sprintf($format, @fargs));
}
##############################################################################
#
# NOTE! More specific paths should be given before less specific.
# For example /client/debug should be listed before /client
#
sub mtr_path_exists (@) {
foreach my $path ( @_ )
{
return $path if -e $path;
}
if ( @_ == 1 )
{
mtr_error("Could not find $_[0]");
}
else
{
mtr_error("Could not find any of " . join(" ", @_));
}
}
#
# NOTE! More specific paths should be given before less specific.
# For example /client/debug should be listed before /client
#
sub mtr_script_exists (@) {
foreach my $path ( @_ )
{
if($::glob_win32)
{
return $path if -f $path;
}
else
{
return $path if -x $path;
}
}
if ( @_ == 1 )
{
mtr_error("Could not find $_[0]");
}
else
{
mtr_error("Could not find any of " . join(" ", @_));
}
}
#
# NOTE! More specific paths should be given before less specific.
# For example /client/debug should be listed before /client
#
sub mtr_file_exists (@) {
foreach my $path ( @_ )
{
return $path if -e $path;
}
return "";
}
#
# NOTE! More specific paths should be given before less specific.
# For example /client/debug should be listed before /client
#
sub mtr_exe_maybe_exists (@) {
my @path= @_;
map {$_.= ".exe"} @path if $::glob_win32;
map {$_.= ".nlm"} @path if $::glob_netware;
foreach my $path ( @path )
{
if($::glob_win32)
{
return $path if -f $path;
}
else
{
return $path if -x $path;
}
}
return "";
}
#
# NOTE! More specific paths should be given before less specific.
# For example /client/debug should be listed before /client
#
sub mtr_exe_exists (@) {
my @path= @_;
if (my $path= mtr_exe_maybe_exists(@path))
{
return $path;
}
# Could not find exe, show error
if ( @path == 1 )
{
mtr_error("Could not find $path[0]");
}
else
{
mtr_error("Could not find any of " . join(" ", @path));
}
}
sub mtr_copy_dir($$) {
my $from_dir= shift;
my $to_dir= shift;
# mtr_verbose("Copying from $from_dir to $to_dir");
mkpath("$to_dir");
opendir(DIR, "$from_dir")
or mtr_error("Can't find $from_dir$!");
for(readdir(DIR)) {
next if "$_" eq "." or "$_" eq "..";
if ( -d "$from_dir/$_" )
{
mtr_copy_dir("$from_dir/$_", "$to_dir/$_");
next;
}
copy("$from_dir/$_", "$to_dir/$_");
}
closedir(DIR);
}
sub mtr_rmtree($) {
my ($dir)= @_;
mtr_verbose("mtr_rmtree: $dir");
# Try to use File::Path::rmtree. Recent versions
# handles removal of directories and files that don't
# have full permissions, while older versions
# may have a problem with that and we use our own version
eval { rmtree($dir); };
if ( $@ ) {
mtr_warning("rmtree($dir) failed, trying with File::Find...");
my $errors= 0;
# chmod
find( {
no_chdir => 1,
wanted => sub {
chmod(0777, $_)
or mtr_warning("couldn't chmod(0777, $_): $!") and $errors++;
}
},
$dir
);
# rm
finddepth( {
no_chdir => 1,
wanted => sub {
my $file= $_;
# Use special underscore (_) filehandle, caches stat info
if (!-l $file and -d _ ) {
rmdir($file) or
mtr_warning("couldn't rmdir($file): $!") and $errors++;
} else {
unlink($file)
or mtr_warning("couldn't unlink($file): $!") and $errors++;
}
}
},
$dir
);
mtr_error("Failed to remove '$dir'") if $errors;
mtr_report("OK, that worked!");
}
}
sub mtr_same_opts ($$) {
my $l1= shift;
my $l2= shift;
return mtr_cmp_opts($l1,$l2) == 0;
}
sub mtr_cmp_opts ($$) {
my $l1= shift;
my $l2= shift;
my @l1= @$l1;
my @l2= @$l2;
return -1 if @l1 < @l2;
return 1 if @l1 > @l2;
while ( @l1 ) # Same length
{
my $e1= shift @l1;
my $e2= shift @l2;
my $cmp= ($e1 cmp $e2);
return $cmp if $cmp != 0;
}
return 0; # They are the same
}
#
# Compare two arrays and put all unequal elements into a new one
#
sub mtr_diff_opts ($$) {
my $l1= shift;
my $l2= shift;
my $f;
my $l= [];
foreach my $e1 (@$l1)
{
$f= undef;
foreach my $e2 (@$l2)
{
$f= 1 unless ($e1 ne $e2);
}
push(@$l, $e1) unless (defined $f);
}
foreach my $e2 (@$l2)
{
$f= undef;
foreach my $e1 (@$l1)
{
$f= 1 unless ($e1 ne $e2);
}
push(@$l, $e2) unless (defined $f);
}
return $l;
}
1;
# -*- cperl -*-
# Copyright (C) 2004-2006 MySQL AB
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
# This is a library file used by the Perl version of mysql-test-run,
# and is part of the translation of the Bourne shell script with the
# same name.
use Socket;
use Errno;
use strict;
use POSIX qw(WNOHANG SIGHUP);
sub mtr_run ($$$$$$;$);
sub mtr_spawn ($$$$$$;$);
sub mtr_check_stop_servers ($);
sub mtr_kill_leftovers ();
sub mtr_wait_blocking ($);
sub mtr_record_dead_children ();
sub mtr_ndbmgm_start($$);
sub mtr_mysqladmin_start($$$);
sub mtr_exit ($);
sub sleep_until_file_created ($$$);
sub mtr_kill_processes ($);
sub mtr_ping_with_timeout($);
sub mtr_ping_port ($);
# Local function
sub spawn_impl ($$$$$$$);
##############################################################################
#
# Execute an external command
#
##############################################################################
sub mtr_run ($$$$$$;$) {
my $path= shift;
my $arg_list_t= shift;
my $input= shift;
my $output= shift;
my $error= shift;
my $pid_file= shift; # Not used
my $spawn_opts= shift;
return spawn_impl($path,$arg_list_t,'run',$input,$output,$error,
$spawn_opts);
}
sub mtr_run_test ($$$$$$;$) {
my $path= shift;
my $arg_list_t= shift;
my $input= shift;
my $output= shift;
my $error= shift;
my $pid_file= shift; # Not used
my $spawn_opts= shift;
return spawn_impl($path,$arg_list_t,'test',$input,$output,$error,
$spawn_opts);
}
sub mtr_spawn ($$$$$$;$) {
my $path= shift;
my $arg_list_t= shift;
my $input= shift;
my $output= shift;
my $error= shift;
my $pid_file= shift; # Not used
my $spawn_opts= shift;
return spawn_impl($path,$arg_list_t,'spawn',$input,$output,$error,
$spawn_opts);
}
sub spawn_impl ($$$$$$$) {
my $path= shift;
my $arg_list_t= shift;
my $mode= shift;
my $input= shift;
my $output= shift;
my $error= shift;
my $spawn_opts= shift;
if ( $::opt_script_debug )
{
mtr_report("");
mtr_debug("-" x 73);
mtr_debug("STDIN $input") if $input;
mtr_debug("STDOUT $output") if $output;
mtr_debug("STDERR $error") if $error;
mtr_debug("$mode: $path ", join(" ",@$arg_list_t));
mtr_debug("spawn options:");
if ($spawn_opts)
{
foreach my $key (sort keys %{$spawn_opts})
{
mtr_debug(" - $key: $spawn_opts->{$key}");
}
}
else
{
mtr_debug(" none");
}
mtr_debug("-" x 73);
mtr_report("");
}
mtr_error("Can't spawn with empty \"path\"") unless defined $path;
FORK:
{
my $pid= fork();
if ( ! defined $pid )
{
if ( $! == $!{EAGAIN} ) # See "perldoc Errno"
{
mtr_warning("Got EAGAIN from fork(), sleep 1 second and redo");
sleep(1);
redo FORK;
}
mtr_error("$path ($pid) can't be forked, error: $!");
}
if ( $pid )
{
select(STDOUT) if $::glob_win32_perl;
return spawn_parent_impl($pid,$mode,$path);
}
else
{
# Child, redirect output and exec
$SIG{INT}= 'DEFAULT'; # Parent do some stuff, we don't
my $log_file_open_mode = '>';
if ($spawn_opts and $spawn_opts->{'append_log_file'})
{
$log_file_open_mode = '>>';
}
if ( $output )
{
if ( $::glob_win32_perl )
{
# Don't redirect stdout on ActiveState perl since this is
# just another thread in the same process.
}
elsif ( ! open(STDOUT,$log_file_open_mode,$output) )
{
mtr_child_error("can't redirect STDOUT to \"$output\": $!");
}
}
if ( $error )
{
if ( !$::glob_win32_perl and $output eq $error )
{
if ( ! open(STDERR,">&STDOUT") )
{
mtr_child_error("can't dup STDOUT: $!");
}
}
else
{
if ( ! open(STDERR,$log_file_open_mode,$error) )
{
mtr_child_error("can't redirect STDERR to \"$error\": $!");
}
}
}
if ( $input )
{
if ( ! open(STDIN,"<",$input) )
{
mtr_child_error("can't redirect STDIN to \"$input\": $!");
}
}
if ( ! exec($path,@$arg_list_t) )
{
mtr_child_error("failed to execute \"$path\": $!");
}
mtr_error("Should never come here 1!");
}
mtr_error("Should never come here 2!");
}
mtr_error("Should never come here 3!");
}
sub spawn_parent_impl {
my $pid= shift;
my $mode= shift;
my $path= shift;
if ( $mode eq 'run' or $mode eq 'test' )
{
if ( $mode eq 'run' )
{
# Simple run of command, wait blocking for it to return
my $ret_pid= waitpid($pid,0);
if ( $ret_pid != $pid )
{
# The "simple" waitpid has failed, print debug info
# and try to handle the error
mtr_warning("waitpid($pid, 0) returned $ret_pid " .
"when waiting for '$path', error: '$!'");
if ( $ret_pid == -1 )
{
# waitpid returned -1, that would indicate the process
# no longer exist and waitpid couldn't wait for it.
return 1;
}
mtr_error("Error handling failed");
}
return mtr_process_exit_status($?);
}
else
{
# We run mysqltest and wait for it to return. But we try to
# catch dying mysqld processes as well.
#
# We do blocking waitpid() until we get the return from the
# "mysqltest" call. But if a mysqld process dies that we
# started, we take this as an error, and kill mysqltest.
my $exit_value= -1;
my $saved_exit_value;
my $ret_pid; # What waitpid() returns
while ( ($ret_pid= waitpid(-1,0)) != -1 )
{
# Someone terminated, don't know who. Collect
# status info first before $? is lost,
# but not $exit_value, this is flagged from
my $timer_name= mtr_timer_timeout($::glob_timers, $ret_pid);
if ( $timer_name )
{
if ( $timer_name eq "suite" )
{
# We give up here
# FIXME we should only give up the suite, not all of the run?
print STDERR "\n";
mtr_error("Test suite timeout");
}
elsif ( $timer_name eq "testcase" )
{
$saved_exit_value= 63; # Mark as timeout
kill(9, $pid); # Kill mysqltest
next; # Go on and catch the termination
}
}
if ( $ret_pid == $pid )
{
# We got termination of mysqltest, we are done
$exit_value= mtr_process_exit_status($?);
last;
}
# One of the child processes died, unless this was expected
# mysqltest should be killed and test aborted
check_expected_crash_and_restart($ret_pid);
}
if ( $ret_pid != $pid )
{
# We terminated the waiting because a "mysqld" process died.
# Kill the mysqltest process.
mtr_verbose("Kill mysqltest because another process died");
kill(9,$pid);
$ret_pid= waitpid($pid,0);
if ( $ret_pid != $pid )
{
mtr_error("$path ($pid) got lost somehow");
}
}
return $saved_exit_value || $exit_value;
}
}
else
{
# We spawned a process we don't wait for
return $pid;
}
}
# ----------------------------------------------------------------------
# We try to emulate how an Unix shell calculates the exit code
# ----------------------------------------------------------------------
sub mtr_process_exit_status {
my $raw_status= shift;
if ( $raw_status & 127 )
{
return ($raw_status & 127) + 128; # Signal num + 128
}
else
{
return $raw_status >> 8; # Exit code
}
}
##############################################################################
#
# Kill processes left from previous runs
#
##############################################################################
# Kill all processes(mysqld, ndbd, ndb_mgmd and im) that would conflict with
# this run
# Make sure to remove the PID file, if any.
# kill IM manager first, else it will restart the servers
sub mtr_kill_leftovers () {
mtr_report("Killing Possible Leftover Processes");
mtr_debug("mtr_kill_leftovers(): started.");
my @kill_pids;
my %admin_pids;
foreach my $srv (@{$::master}, @{$::slave})
{
mtr_debug(" - mysqld " .
"(pid: $srv->{pid}; " .
"pid file: '$srv->{path_pid}'; " .
"socket: '$srv->{path_sock}'; ".
"port: $srv->{port})");
my $pid= mtr_mysqladmin_start($srv, "shutdown", 20);
# Save the pid of the mysqladmin process
$admin_pids{$pid}= 1;
push(@kill_pids,{
pid => $srv->{'pid'},
pidfile => $srv->{'path_pid'},
sockfile => $srv->{'path_sock'},
port => $srv->{'port'},
});
$srv->{'pid'}= 0; # Assume we are done with it
}
if ( ! $::opt_skip_ndbcluster )
{
foreach my $cluster (@{$::clusters})
{
# Don't shut down a "running" cluster
next if $cluster->{'use_running'};
mtr_debug(" - cluster " .
"(pid: $cluster->{pid}; " .
"pid file: '$cluster->{path_pid})");
my $pid= mtr_ndbmgm_start($cluster, "shutdown");
# Save the pid of the ndb_mgm process
$admin_pids{$pid}= 1;
push(@kill_pids,{
pid => $cluster->{'pid'},
pidfile => $cluster->{'path_pid'}
});
$cluster->{'pid'}= 0; # Assume we are done with it
foreach my $ndbd (@{$cluster->{'ndbds'}})
{
mtr_debug(" - ndbd " .
"(pid: $ndbd->{pid}; " .
"pid file: '$ndbd->{path_pid})");
push(@kill_pids,{
pid => $ndbd->{'pid'},
pidfile => $ndbd->{'path_pid'},
});
$ndbd->{'pid'}= 0; # Assume we are done with it
}
}
}
# Wait for all the admin processes to complete
mtr_wait_blocking(\%admin_pids);
# If we trusted "mysqladmin --shutdown_timeout= ..." we could just
# terminate now, but we don't (FIXME should be debugged).
# So we try again to ping and at least wait the same amount of time
# mysqladmin would for all to die.
mtr_ping_with_timeout(\@kill_pids);
# We now have tried to terminate nice. We have waited for the listen
# port to be free, but can't really tell if the mysqld process died
# or not. We now try to find the process PID from the PID file, and
# send a kill to that process. Note that Perl let kill(0,@pids) be
# a way to just return the numer of processes the kernel can send
# signals to. So this can be used (except on Cygwin) to determine
# if there are processes left running that we cound out might exists.
#
# But still after all this work, all we know is that we have
# the ports free.
# We scan the "var/run/" directory for other process id's to kill
my $rundir= "$::opt_vardir/run";
mtr_debug("Processing PID files in directory '$rundir'...");
if ( -d $rundir )
{
opendir(RUNDIR, $rundir)
or mtr_error("can't open directory \"$rundir\": $!");
my @pids;
while ( my $elem= readdir(RUNDIR) )
{
# Only read pid from files that end with .pid
if ( $elem =~ /.*[.]pid$/)
{
my $pidfile= "$rundir/$elem";
if ( -f $pidfile )
{
mtr_debug("Processing PID file: '$pidfile'...");
my $pid= mtr_get_pid_from_file($pidfile);
mtr_debug("Got pid: $pid from file '$pidfile'");
if ( $::glob_cygwin_perl or kill(0, $pid) )
{
mtr_debug("There is process with pid $pid -- scheduling for kill.");
push(@pids, $pid); # We know (cygwin guess) it exists
}
else
{
mtr_debug("There is no process with pid $pid -- skipping.");
}
}
}
else
{
mtr_warning("Found non pid file $elem in $rundir")
if -f "$rundir/$elem";
next;
}
}
closedir(RUNDIR);
if ( @pids )
{
mtr_debug("Killing the following processes with PID files: " .
join(' ', @pids) . "...");
start_reap_all();
if ( $::glob_cygwin_perl )
{
# We have no (easy) way of knowing the Cygwin controlling
# process, in the PID file we only have the Windows process id.
system("kill -f " . join(" ",@pids)); # Hope for the best....
mtr_debug("Sleep 5 seconds waiting for processes to die");
sleep(5);
}
else
{
my $retries= 10; # 10 seconds
do
{
mtr_debug("Sending SIGKILL to pids: " . join(' ', @pids));
kill(9, @pids);
mtr_report("Sleep 1 second waiting for processes to die");
sleep(1) # Wait one second
} while ( $retries-- and kill(0, @pids) );
if ( kill(0, @pids) ) # Check if some left
{
mtr_warning("can't kill process(es) " . join(" ", @pids));
}
}
stop_reap_all();
}
}
else
{
mtr_debug("Directory for PID files ($rundir) does not exist.");
}
# We may have failed everything, but we now check again if we have
# the listen ports free to use, and if they are free, just go for it.
mtr_debug("Checking known mysqld servers...");
foreach my $srv ( @kill_pids )
{
if ( defined $srv->{'port'} and mtr_ping_port($srv->{'port'}) )
{
mtr_warning("can't kill old process holding port $srv->{'port'}");
}
}
mtr_debug("mtr_kill_leftovers(): finished.");
}
#
# Check that all processes in "spec" are shutdown gracefully
# else kill them off hard
#
sub mtr_check_stop_servers ($) {
my $spec= shift;
# Return if no processes are defined
return if ! @$spec;
mtr_verbose("mtr_check_stop_servers");
# ----------------------------------------------------------------------
# Wait until servers in "spec" has stopped listening
# to their ports or timeout occurs
# ----------------------------------------------------------------------
mtr_ping_with_timeout(\@$spec);
# ----------------------------------------------------------------------
# Use waitpid() nonblocking for a little while, to see how
# many process's will exit sucessfully.
# This is the normal case.
# ----------------------------------------------------------------------
my $wait_counter= 50; # Max number of times to redo the loop
foreach my $srv ( @$spec )
{
my $pid= $srv->{'pid'};
my $ret_pid;
if ( $pid )
{
$ret_pid= waitpid($pid,&WNOHANG);
if ($ret_pid == $pid)
{
mtr_verbose("Caught exit of process $ret_pid");
$srv->{'pid'}= 0;
}
elsif ($ret_pid == 0)
{
mtr_verbose("Process $pid is still alive");
if ($wait_counter-- > 0)
{
# Give the processes more time to exit
select(undef, undef, undef, (0.1));
redo;
}
}
else
{
mtr_warning("caught exit of unknown child $ret_pid");
}
}
}
# ----------------------------------------------------------------------
# The processes that haven't yet exited need to
# be killed hard, put them in "kill_pids" hash
# ----------------------------------------------------------------------
my %kill_pids;
foreach my $srv ( @$spec )
{
my $pid= $srv->{'pid'};
if ( $pid )
{
# Server is still alive, put it in list to be hard killed
if ($::glob_win32_perl)
{
# Kill the real process if it's known
$pid= $srv->{'real_pid'} if ($srv->{'real_pid'});
}
$kill_pids{$pid}= 1;
# Write a message to the process's error log (if it has one)
# that it's being killed hard.
if ( defined $srv->{'errfile'} )
{
mtr_tofile($srv->{'errfile'}, "Note: Forcing kill of process $pid\n");
}
mtr_warning("Forcing kill of process $pid");
}
else
{
# Server is dead, remove the pidfile if it exists
#
# Race, could have been removed between test with -f
# and the unlink() below, so better check again with -f
if ( -f $srv->{'pidfile'} and ! unlink($srv->{'pidfile'}) and
-f $srv->{'pidfile'} )
{
mtr_error("can't remove $srv->{'pidfile'}");
}
}
}
if ( ! keys %kill_pids )
{
# All processes has exited gracefully
return;
}
mtr_kill_processes(\%kill_pids);
# ----------------------------------------------------------------------
# All processes are killed, cleanup leftover files
# ----------------------------------------------------------------------
{
my $errors= 0;
foreach my $srv ( @$spec )
{
if ( $srv->{'pid'} )
{
# Server has been hard killed, clean it's resources
foreach my $file ($srv->{'pidfile'}, $srv->{'sockfile'})
{
# Know it is dead so should be no race, careful anyway
if ( defined $file and -f $file and ! unlink($file) and -f $file )
{
$errors++;
mtr_warning("couldn't delete $file");
}
}
if ($::glob_win32_perl and $srv->{'real_pid'})
{
# Wait for the pseudo pid - if the real_pid was known
# the pseudo pid has not been waited for yet, wai blocking
# since it's "such a simple program"
mtr_verbose("Wait for pseudo process $srv->{'pid'}");
my $ret_pid= waitpid($srv->{'pid'}, 0);
mtr_verbose("Pseudo process $ret_pid died");
}
$srv->{'pid'}= 0;
}
}
if ( $errors )
{
# There where errors killing processes
# do one last attempt to ping the servers
# and if they can't be pinged, assume they are dead
if ( ! mtr_ping_with_timeout( \@$spec ) )
{
mtr_error("we could not kill or clean up all processes");
}
else
{
mtr_verbose("All ports were free, continuing");
}
}
}
}
# Wait for all the process in the list to terminate
sub mtr_wait_blocking($) {
my $admin_pids= shift;
# Return if no processes defined
return if ! %$admin_pids;
mtr_verbose("mtr_wait_blocking");
# Wait for all the started processes to exit
# As mysqladmin is such a simple program, we trust it to terminate itself.
# I.e. we wait blocking, and wait for them all before we go on.
foreach my $pid (keys %{$admin_pids})
{
my $ret_pid= waitpid($pid,0);
}
}
# Start "mysqladmin <command>" for a specific mysqld
sub mtr_mysqladmin_start($$$) {
my $srv= shift;
my $command= shift;
my $adm_shutdown_tmo= shift;
my $args;
mtr_init_args(\$args);
mtr_add_arg($args, "--no-defaults");
mtr_add_arg($args, "--user=%s", $::opt_user);
mtr_add_arg($args, "--password=");
mtr_add_arg($args, "--silent");
if ( -e $srv->{'path_sock'} )
{
mtr_add_arg($args, "--socket=%s", $srv->{'path_sock'});
}
if ( $srv->{'port'} )
{
mtr_add_arg($args, "--port=%s", $srv->{'port'});
}
if ( $srv->{'port'} and ! -e $srv->{'path_sock'} )
{
mtr_add_arg($args, "--protocol=tcp"); # Needed if no --socket
}
mtr_add_arg($args, "--connect_timeout=5");
# Shutdown time must be high as slave may be in reconnect
mtr_add_arg($args, "--shutdown_timeout=$adm_shutdown_tmo");
mtr_add_arg($args, "$command");
my $pid= mtr_spawn($::exe_mysqladmin, $args,
"", "", "", "",
{ append_log_file => 1 });
mtr_verbose("mtr_mysqladmin_start, pid: $pid");
return $pid;
}
# Start "ndb_mgm shutdown" for a specific cluster, it will
# shutdown all data nodes and leave the ndb_mgmd running
sub mtr_ndbmgm_start($$) {
my $cluster= shift;
my $command= shift;
my $args;
mtr_init_args(\$args);
mtr_add_arg($args, "--no-defaults");
mtr_add_arg($args, "--core");
mtr_add_arg($args, "--try-reconnect=1");
mtr_add_arg($args, "--ndb_connectstring=%s", $cluster->{'connect_string'});
mtr_add_arg($args, "-e");
mtr_add_arg($args, "$command");
my $pid= mtr_spawn($::exe_ndb_mgm, $args,
"", "/dev/null", "/dev/null", "",
{});
mtr_verbose("mtr_ndbmgm_start, pid: $pid");
return $pid;
}
# Ping all servers in list, exit when none of them answers
# or when timeout has passed
sub mtr_ping_with_timeout($) {
my $spec= shift;
my $timeout= 200; # 20 seconds max
my $res= 1; # If we just fall through, we are done
# in the sense that the servers don't
# listen to their ports any longer
mtr_debug("Waiting for mysqld servers to stop...");
TIME:
while ( $timeout-- )
{
foreach my $srv ( @$spec )
{
$res= 1; # We are optimistic
if ( $srv->{'pid'} and defined $srv->{'port'} )
{
if ( mtr_ping_port($srv->{'port'}) )
{
mtr_verbose("waiting for process $srv->{'pid'} to stop ".
"using port $srv->{'port'}");
# Millisceond sleep emulated with select
select(undef, undef, undef, (0.1));
$res= 0;
next TIME;
}
else
{
# Process was not using port
}
}
}
last; # If we got here, we are done
}
if ($res)
{
mtr_debug("mtr_ping_with_timeout(): All mysqld instances are down.");
}
else
{
mtr_report("mtr_ping_with_timeout(): At least one server is alive.");
}
return $res;
}
#
# Loop through our list of processes and look for and entry
# with the provided pid
# Set the pid of that process to 0 if found
#
sub mark_process_dead($)
{
my $ret_pid= shift;
foreach my $mysqld (@{$::master}, @{$::slave})
{
if ( $mysqld->{'pid'} eq $ret_pid )
{
mtr_verbose("$mysqld->{'type'} $mysqld->{'idx'} exited, pid: $ret_pid");
$mysqld->{'pid'}= 0;
return;
}
}
foreach my $cluster (@{$::clusters})
{
if ( $cluster->{'pid'} eq $ret_pid )
{
mtr_verbose("$cluster->{'name'} cluster ndb_mgmd exited, pid: $ret_pid");
$cluster->{'pid'}= 0;
return;
}
foreach my $ndbd (@{$cluster->{'ndbds'}})
{
if ( $ndbd->{'pid'} eq $ret_pid )
{
mtr_verbose("$cluster->{'name'} cluster ndbd exited, pid: $ret_pid");
$ndbd->{'pid'}= 0;
return;
}
}
}
mtr_warning("mark_process_dead couldn't find an entry for pid: $ret_pid");
}
#
# Loop through our list of processes and look for and entry
# with the provided pid, if found check for the file indicating
# expected crash and restart it.
#
sub check_expected_crash_and_restart($)
{
my $ret_pid= shift;
foreach my $mysqld (@{$::master}, @{$::slave})
{
if ( $mysqld->{'pid'} eq $ret_pid )
{
mtr_verbose("$mysqld->{'type'} $mysqld->{'idx'} exited, pid: $ret_pid");
$mysqld->{'pid'}= 0;
# Check if crash expected and restart if it was
my $expect_file= "$::opt_vardir/tmp/" . "$mysqld->{'type'}" .
"$mysqld->{'idx'}" . ".expect";
if ( -f $expect_file )
{
mtr_verbose("Crash was expected, file $expect_file exists");
mysqld_start($mysqld, $mysqld->{'start_opts'},
$mysqld->{'start_slave_master_info'});
unlink($expect_file);
}
return;
}
}
foreach my $cluster (@{$::clusters})
{
if ( $cluster->{'pid'} eq $ret_pid )
{
mtr_verbose("$cluster->{'name'} cluster ndb_mgmd exited, pid: $ret_pid");
$cluster->{'pid'}= 0;
# Check if crash expected and restart if it was
my $expect_file= "$::opt_vardir/tmp/ndb_mgmd_" . "$cluster->{'type'}" .
".expect";
if ( -f $expect_file )
{
mtr_verbose("Crash was expected, file $expect_file exists");
ndbmgmd_start($cluster);
unlink($expect_file);
}
return;
}
foreach my $ndbd (@{$cluster->{'ndbds'}})
{
if ( $ndbd->{'pid'} eq $ret_pid )
{
mtr_verbose("$cluster->{'name'} cluster ndbd exited, pid: $ret_pid");
$ndbd->{'pid'}= 0;
# Check if crash expected and restart if it was
my $expect_file= "$::opt_vardir/tmp/ndbd_" . "$cluster->{'type'}" .
"$ndbd->{'idx'}" . ".expect";
if ( -f $expect_file )
{
mtr_verbose("Crash was expected, file $expect_file exists");
ndbd_start($cluster, $ndbd->{'idx'},
$ndbd->{'start_extra_args'});
unlink($expect_file);
}
return;
}
}
}
if ($::instance_manager->{'spawner_pid'} eq $ret_pid)
{
return;
}
mtr_warning("check_expected_crash_and_restart couldn't find an entry for pid: $ret_pid");
}
##############################################################################
#
# The operating system will keep information about dead children,
# we read this information here, and if we have records the process
# is alive, we mark it as dead.
#
##############################################################################
sub mtr_record_dead_children () {
my $process_died= 0;
my $ret_pid;
# Wait without blockinng to see if any processes had died
# -1 or 0 means there are no more procesess to wait for
while ( ($ret_pid= waitpid(-1,&WNOHANG)) != 0 and $ret_pid != -1)
{
mtr_warning("mtr_record_dead_children: $ret_pid");
mark_process_dead($ret_pid);
$process_died= 1;
}
return $process_died;
}
sub start_reap_all {
# This causes terminating processes to not become zombies, avoiding
# the need for (or possibility of) explicit waitpid().
$SIG{CHLD}= 'IGNORE';
# On some platforms (Linux, QNX, OSX, ...) there is potential race
# here. If a process terminated before setting $SIG{CHLD} (but after
# any attempt to waitpid() it), it will still be a zombie. So we
# have to handle any such process here.
my $pid;
while(($pid= waitpid(-1, &WNOHANG)) != 0 and $pid != -1)
{
mtr_warning("start_reap_all pid: $pid");
mark_process_dead($pid);
};
}
sub stop_reap_all {
$SIG{CHLD}= 'DEFAULT';
}
sub mtr_ping_port ($) {
my $port= shift;
mtr_verbose("mtr_ping_port: $port");
my $remote= "localhost";
my $iaddr= inet_aton($remote);
if ( ! $iaddr )
{
mtr_error("can't find IP number for $remote");
}
my $paddr= sockaddr_in($port, $iaddr);
my $proto= getprotobyname('tcp');
if ( ! socket(SOCK, PF_INET, SOCK_STREAM, $proto) )
{
mtr_error("can't create socket: $!");
}
mtr_debug("Pinging server (port: $port)...");
if ( connect(SOCK, $paddr) )
{
close(SOCK); # FIXME check error?
mtr_verbose("USED");
return 1;
}
else
{
mtr_verbose("FREE");
return 0;
}
}
##############################################################################
#
# Wait for a file to be created
#
##############################################################################
# FIXME check that the pidfile contains the expected pid!
sub sleep_until_file_created ($$$) {
my $pidfile= shift;
my $timeout= shift;
my $pid= shift;
my $sleeptime= 100; # Milliseconds
my $loops= ($timeout * 1000) / $sleeptime;
for ( my $loop= 1; $loop <= $loops; $loop++ )
{
if ( -r $pidfile )
{
return 1;
}
# Check if it died after the fork() was successful
if ( $pid != 0 && waitpid($pid,&WNOHANG) == $pid )
{
mtr_warning("Process $pid died");
return 0;
}
mtr_debug("Sleep $sleeptime milliseconds waiting for $pidfile");
# Print extra message every 60 seconds
my $seconds= ($loop * $sleeptime) / 1000;
if ( $seconds > 1 and int($seconds * 10) % 600 == 0 )
{
my $left= $timeout - $seconds;
mtr_warning("Waited $seconds seconds for $pidfile to be created, " .
"still waiting for $left seconds...");
}
# Millisceond sleep emulated with select
select(undef, undef, undef, ($sleeptime/1000));
}
return 0;
}
sub mtr_kill_processes ($) {
my $pids = shift;
mtr_verbose("mtr_kill_processes (" . join(" ", keys %{$pids}) . ")");
foreach my $pid (keys %{$pids})
{
if ($pid <= 0)
{
mtr_warning("Trying to kill illegal pid: $pid");
next;
}
my $signaled_procs= kill(9, $pid);
if ($signaled_procs == 0)
{
# No such process existed, assume it's killed
mtr_verbose("killed $pid(no such process)");
}
else
{
my $ret_pid= waitpid($pid,0);
if ($ret_pid == $pid)
{
mtr_verbose("killed $pid(got the pid)");
}
elsif ($ret_pid == -1)
{
mtr_verbose("killed $pid(got -1)");
}
}
}
mtr_verbose("done killing processes");
}
##############################################################################
#
# When we exit, we kill off all children
#
##############################################################################
sub mtr_exit ($) {
my $code= shift;
mtr_timer_stop_all($::glob_timers);
local $SIG{HUP} = 'IGNORE';
# ToDo: Signalling -$$ will only work if we are the process group
# leader (in fact on QNX it will signal our session group leader,
# which might be Do-compile or Pushbuild, causing tests to be
# aborted). So we only do it if we are the group leader. We might
# set ourselves as the group leader at startup (with
# POSIX::setpgrp(0,0)), but then care must be needed to always do
# proper child process cleanup.
POSIX::kill(SIGHUP, -$$) if !$::glob_win32_perl and $$ == getpgrp();
exit($code);
}
###########################################################################
1;
# -*- cperl -*-
# Copyright (C) 2004-2006 MySQL AB
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
# This is a library file used by the Perl version of mysql-test-run,
# and is part of the translation of the Bourne shell script with the
# same name.
use strict;
use warnings;
sub mtr_report_test_name($);
sub mtr_report_test_passed($);
sub mtr_report_test_failed($);
sub mtr_report_test_skipped($);
sub mtr_report_test_not_skipped_though_disabled($);
sub mtr_report_stats ($);
sub mtr_print_line ();
sub mtr_print_thick_line ();
sub mtr_print_header ();
sub mtr_report (@);
sub mtr_warning (@);
sub mtr_error (@);
sub mtr_child_error (@);
sub mtr_debug (@);
sub mtr_verbose (@);
my $tot_real_time= 0;
##############################################################################
#
#
#
##############################################################################
sub mtr_report_test_name ($) {
my $tinfo= shift;
my $tname= $tinfo->{name};
$tname.= " '$tinfo->{combination}'"
if defined $tinfo->{combination};
_mtr_log($tname);
printf "%-30s ", $tname;
}
sub mtr_report_test_skipped ($) {
my $tinfo= shift;
$tinfo->{'result'}= 'MTR_RES_SKIPPED';
if ( $tinfo->{'disable'} )
{
mtr_report("[ disabled ] $tinfo->{'comment'}");
}
elsif ( $tinfo->{'comment'} )
{
mtr_report("[ skipped ] $tinfo->{'comment'}");
}
else
{
mtr_report("[ skipped ]");
}
}
sub mtr_report_tests_not_skipped_though_disabled ($) {
my $tests= shift;
if ( $::opt_enable_disabled )
{
my @disabled_tests= grep {$_->{'dont_skip_though_disabled'}} @$tests;
if ( @disabled_tests )
{
print "\nTest(s) which will be run though they are marked as disabled:\n";
foreach my $tinfo ( sort {$a->{'name'} cmp $b->{'name'}} @disabled_tests )
{
printf " %-20s : %s\n", $tinfo->{'name'}, $tinfo->{'comment'};
}
}
}
}
sub mtr_report_test_passed ($) {
my $tinfo= shift;
my $timer= "";
if ( $::opt_timer and -f "$::opt_vardir/log/timer" )
{
$timer= mtr_fromfile("$::opt_vardir/log/timer");
$tot_real_time += ($timer/1000);
$timer= sprintf "%12s", $timer;
}
$tinfo->{'result'}= 'MTR_RES_PASSED';
mtr_report("[ pass ] $timer");
}
sub mtr_report_test_failed ($) {
my $tinfo= shift;
$tinfo->{'result'}= 'MTR_RES_FAILED';
if ( defined $tinfo->{'timeout'} )
{
mtr_report("[ fail ] timeout");
return;
}
else
{
mtr_report("[ fail ]");
}
if ( $tinfo->{'comment'} )
{
# The test failure has been detected by mysql-test-run.pl
# when starting the servers or due to other error, the reason for
# failing the test is saved in "comment"
mtr_report("\nERROR: $tinfo->{'comment'}");
}
elsif ( -f $::path_timefile )
{
# Test failure was detected by test tool and it's report
# about what failed has been saved to file. Display the report.
print "\n";
print mtr_fromfile($::path_timefile); # FIXME print_file() instead
print "\n";
}
else
{
# Neither this script or the test tool has recorded info
# about why the test has failed. Should be debugged.
mtr_report("\nUnexpected termination, probably when starting mysqld");;
}
}
sub mtr_report_stats ($) {
my $tests= shift;
# ----------------------------------------------------------------------
# Find out how we where doing
# ----------------------------------------------------------------------
my $tot_skiped= 0;
my $tot_passed= 0;
my $tot_failed= 0;
my $tot_tests= 0;
my $tot_restarts= 0;
my $found_problems= 0; # Some warnings in the logfiles are errors...
foreach my $tinfo (@$tests)
{
if ( $tinfo->{'result'} eq 'MTR_RES_SKIPPED' )
{
$tot_skiped++;
}
elsif ( $tinfo->{'result'} eq 'MTR_RES_PASSED' )
{
$tot_tests++;
$tot_passed++;
}
elsif ( $tinfo->{'result'} eq 'MTR_RES_FAILED' )
{
$tot_tests++;
$tot_failed++;
}
if ( $tinfo->{'restarted'} )
{
$tot_restarts++;
}
}
# ----------------------------------------------------------------------
# Print out a summary report to screen
# ----------------------------------------------------------------------
if ( ! $tot_failed )
{
print "All $tot_tests tests were successful.\n";
}
else
{
my $ratio= $tot_passed * 100 / $tot_tests;
print "Failed $tot_failed/$tot_tests tests, ";
printf("%.2f", $ratio);
print "\% were successful.\n\n";
print
"The log files in var/log may give you some hint\n",
"of what went wrong.\n",
"If you want to report this error, please read first ",
"the documentation at\n",
"http://dev.mysql.com/doc/mysql/en/mysql-test-suite.html\n";
}
if (!$::opt_extern)
{
print "The servers were restarted $tot_restarts times\n";
}
if ( $::opt_timer )
{
use English;
mtr_report("Spent", sprintf("%.3f", $tot_real_time),"of",
time - $BASETIME, "seconds executing testcases");
}
# ----------------------------------------------------------------------
# If a debug run, there might be interesting information inside
# the "var/log/*.err" files. We save this info in "var/log/warnings"
# ----------------------------------------------------------------------
if ( ! $::glob_use_running_server )
{
# Save and report if there was any fatal warnings/errors in err logs
my $warnlog= "$::opt_vardir/log/warnings";
unless ( open(WARN, ">$warnlog") )
{
mtr_warning("can't write to the file \"$warnlog\": $!");
}
else
{
# We report different types of problems in order
foreach my $pattern ( "^Warning:",
"\\[Warning\\]",
"\\[ERROR\\]",
"^Error:", "^==.* at 0x",
"InnoDB: Warning",
"InnoDB: Error",
"^safe_mutex:",
"missing DBUG_RETURN",
"mysqld: Warning",
"allocated at line",
"Attempting backtrace", "Assertion .* failed" )
{
foreach my $errlog ( sort glob("$::opt_vardir/log/*.err") )
{
my $testname= "";
unless ( open(ERR, $errlog) )
{
mtr_warning("can't read $errlog");
next;
}
my $leak_reports_expected= undef;
while ( <ERR> )
{
# There is a test case that purposely provokes a
# SAFEMALLOC leak report, even though there is no actual
# leak. We need to detect this, and ignore the warning in
# that case.
if (/Begin safemalloc memory dump:/) {
$leak_reports_expected= 1;
} elsif (/End safemalloc memory dump./) {
$leak_reports_expected= undef;
}
# Skip some non fatal warnings from the log files
if (
/\"SELECT UNIX_TIMESTAMP\(\)\" failed on master/ or
/Aborted connection/ or
/Client requested master to start replication from impossible position/ or
/Could not find first log file name in binary log/ or
/Enabling keys got errno/ or
/Error reading master configuration/ or
/Error reading packet/ or
/Event Scheduler/ or
/Failed to open log/ or
/Failed to open the existing master info file/ or
/Forcing shutdown of [0-9]* plugins/ or
/Can't open shared library .*\bha_example\b/ or
/Couldn't load plugin .*\bha_example\b/ or
# Due to timing issues, it might be that this warning
# is printed when the server shuts down and the
# computer is loaded.
/Forcing close of thread \d+ user: '.*?'/ or
/Got error [0-9]* when reading table/ or
/Incorrect definition of table/ or
/Incorrect information in file/ or
/InnoDB: Warning: we did not need to do crash recovery/ or
/Invalid \(old\?\) table or database name/ or
/Lock wait timeout exceeded/ or
/Log entry on master is longer than max_allowed_packet/ or
/unknown option '--loose-/ or
/unknown variable 'loose-/ or
/You have forced lower_case_table_names to 0 through a command-line option/ or
/Setting lower_case_table_names=2/ or
/NDB Binlog:/ or
/NDB: failed to setup table/ or
/NDB: only row based binary logging/ or
/Neither --relay-log nor --relay-log-index were used/ or
/Query partially completed/ or
/Slave I.O thread aborted while waiting for relay log/ or
/Slave SQL thread is stopped because UNTIL condition/ or
/Slave SQL thread retried transaction/ or
/Slave \(additional info\)/ or
/Slave: .*Duplicate column name/ or
/Slave: .*master may suffer from/ or
/Slave: According to the master's version/ or
/Slave: Column [0-9]* type mismatch/ or
/Slave: Error .* doesn't exist/ or
/Slave: Deadlock found/ or
/Slave: Error .*Unknown table/ or
/Slave: Error in Write_rows event: / or
/Slave: Field .* of table .* has no default value/ or
/Slave: Field .* doesn't have a default value/ or
/Slave: Query caused different errors on master and slave/ or
/Slave: Table .* doesn't exist/ or
/Slave: Table width mismatch/ or
/Slave: The incident LOST_EVENTS occured on the master/ or
/Slave: Unknown error.* 1105/ or
/Slave: Can't drop database.* database doesn't exist/ or
/Slave SQL:.*(?:Error_code: \d+|Query:.*)/ or
/Sort aborted/ or
/Time-out in NDB/ or
/One can only use the --user.*root/ or
/Table:.* on (delete|rename)/ or
/You have an error in your SQL syntax/ or
/deprecated/ or
/description of time zone/ or
/equal MySQL server ids/ or
/error .*connecting to master/ or
/error reading log entry/ or
/lower_case_table_names is set/ or
/skip-name-resolve mode/ or
/slave SQL thread aborted/ or
/Slave: .*Duplicate entry/ or
# Special case for Bug #26402 in show_check.test
# Question marks are not valid file name parts
# on Windows platforms. Ignore this error message.
/\QCan't find file: '.\test\????????.frm'\E/ or
# Special case, made as specific as possible, for:
# Bug #28436: Incorrect position in SHOW BINLOG EVENTS causes
# server coredump
/\QError in Log_event::read_log_event(): 'Sanity check failed', data_len: 258, event_type: 49\E/ or
/Statement is not safe to log in statement format/ or
# test case for Bug#bug29807 copies a stray frm into database
/InnoDB: Error: table `test`.`bug29807` does not exist in the InnoDB internal/ or
/Cannot find or open table test\/bug29807 from/ or
# innodb foreign key tests that fail in ALTER or RENAME produce this
/InnoDB: Error: in ALTER TABLE `test`.`t[12]`/ or
/InnoDB: Error: in RENAME TABLE table `test`.`t1`/ or
/InnoDB: Error: table `test`.`t[12]` does not exist in the InnoDB internal/ or
# Test case for Bug#14233 produces the following warnings:
/Stored routine 'test'.'bug14233_1': invalid value in column mysql.proc/ or
/Stored routine 'test'.'bug14233_2': invalid value in column mysql.proc/ or
/Stored routine 'test'.'bug14233_3': invalid value in column mysql.proc/ or
# BUG#29839 - lowercase_table3.test: Cannot find table test/T1
# from the internal data dictiona
/Cannot find table test\/BUG29839 from the internal data dictionary/ or
# BUG#32080 - Excessive warnings on Solaris: setrlimit could not
# change the size of core files
/setrlimit could not change the size of core files to 'infinity'/ or
# rpl_extrColmaster_*.test, the slave thread produces warnings
# when it get updates to a table that has more columns on the
# master
/Slave: Unknown column 'c7' in 't15' Error_code: 1054/ or
/Slave: Can't DROP 'c7'.* 1091/ or
/Slave: Key column 'c6'.* 1072/ or
# rpl_idempotency.test produces warnings for the slave.
($testname eq 'rpl.rpl_idempotency' and
(/Slave: Can\'t find record in \'t1\' Error_code: 1032/ or
/Slave: Cannot add or update a child row: a foreign key constraint fails .* Error_code: 1452/
)) or
# These tests does "kill" on queries, causing sporadic errors when writing to logs
(($testname eq 'rpl.rpl_skip_error' or
$testname eq 'rpl.rpl_err_ignoredtable' or
$testname eq 'binlog.binlog_killed_simulate' or
$testname eq 'binlog.binlog_killed') and
(/Failed to write to mysql\.\w+_log/
)) or
# rpl_bug33931 has deliberate failures
($testname eq 'rpl.rpl_bug33931' and
(/Failed during slave.*thread initialization/
)) or
# rpl_temporary has an error on slave that can be ignored
($testname eq 'rpl.rpl_temporary' and
(/Slave: Can\'t find record in \'user\' Error_code: 1032/
)) or
# Test case for Bug#31590 produces the following error:
/Out of sort memory; increase server sort buffer size/ or
# Bug#35161, test of auto repair --myisam-recover
/able.*_will_crash/ or
# lowercase_table3 using case sensitive option on
# case insensitive filesystem (InnoDB error).
/Cannot find or open table test\/BUG29839 from/ or
# When trying to set lower_case_table_names = 2
# on a case sensitive file system. Bug#37402.
/lower_case_table_names was set to 2, even though your the file system '.*' is case sensitive. Now setting lower_case_table_names to 0 to avoid future problems./
)
{
next; # Skip these lines
}
if ( /CURRENT_TEST: (.*)/ )
{
$testname= $1;
}
if ( /$pattern/ )
{
if ($leak_reports_expected) {
next;
}
$found_problems= 1;
print WARN basename($errlog) . ": $testname: $_";
}
}
}
}
if ( $::opt_check_testcases )
{
# Look for warnings produced by mysqltest in testname.warnings
foreach my $test_warning_file
( glob("$::glob_mysql_test_dir/r/*.warnings") )
{
$found_problems= 1;
print WARN "Check myqltest warnings in $test_warning_file\n";
}
}
if ( $found_problems )
{
mtr_warning("Got errors/warnings while running tests, please examine",
"\"$warnlog\" for details.");
}
}
}
print "\n";
# Print a list of testcases that failed
if ( $tot_failed != 0 )
{
my $test_mode= join(" ", @::glob_test_mode) || "default";
print "mysql-test-run in $test_mode mode: *** Failing the test(s):";
foreach my $tinfo (@$tests)
{
if ( $tinfo->{'result'} eq 'MTR_RES_FAILED' )
{
print " $tinfo->{'name'}";
}
}
print "\n";
}
# Print a list of check_testcases that failed(if any)
if ( $::opt_check_testcases )
{
my @check_testcases= ();
foreach my $tinfo (@$tests)
{
if ( defined $tinfo->{'check_testcase_failed'} )
{
push(@check_testcases, $tinfo->{'name'});
}
}
if ( @check_testcases )
{
print "Check of testcase failed for: ";
print join(" ", @check_testcases);
print "\n\n";
}
}
if ( $tot_failed != 0 || $found_problems)
{
mtr_error("there were failing test cases");
}
}
##############################################################################
#
# Text formatting
#
##############################################################################
sub mtr_print_line () {
print '-' x 55, "\n";
}
sub mtr_print_thick_line () {
print '=' x 55, "\n";
}
sub mtr_print_header () {
print "\n";
if ( $::opt_timer )
{
print "TEST RESULT TIME (ms)\n";
}
else
{
print "TEST RESULT\n";
}
mtr_print_line();
print "\n";
}
##############################################################################
#
# Log and reporting functions
#
##############################################################################
use IO::File;
my $log_file_ref= undef;
sub mtr_log_init ($) {
my ($filename)= @_;
mtr_error("Log is already open") if defined $log_file_ref;
$log_file_ref= IO::File->new($filename, "a") or
mtr_warning("Could not create logfile $filename: $!");
}
sub _mtr_log (@) {
print $log_file_ref join(" ", @_),"\n"
if defined $log_file_ref;
}
sub mtr_report (@) {
# Print message to screen and log
_mtr_log(@_);
print join(" ", @_),"\n";
}
sub mtr_warning (@) {
# Print message to screen and log
_mtr_log("WARNING: ", @_);
print STDERR "mysql-test-run: WARNING: ",join(" ", @_),"\n";
}
sub mtr_error (@) {
# Print message to screen and log
_mtr_log("ERROR: ", @_);
print STDERR "mysql-test-run: *** ERROR: ",join(" ", @_),"\n";
mtr_exit(1);
}
sub mtr_child_error (@) {
# Print message to screen and log
_mtr_log("ERROR(child): ", @_);
print STDERR "mysql-test-run: *** ERROR(child): ",join(" ", @_),"\n";
exit(1);
}
sub mtr_debug (@) {
# Only print if --script-debug is used
if ( $::opt_script_debug )
{
_mtr_log("###: ", @_);
print STDERR "####: ",join(" ", @_),"\n";
}
}
sub mtr_verbose (@) {
# Always print to log, print to screen only when --verbose is used
_mtr_log("> ",@_);
if ( $::opt_verbose )
{
print STDERR "> ",join(" ", @_),"\n";
}
}
1;
# -*- cperl -*-
# Copyright (C) 2006 MySQL AB
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
# This is a library file used by the Perl version of mysql-test-run,
# and is part of the translation of the Bourne shell script with the
# same name.
use strict;
use File::Spec;
# These are not to be prefixed with "mtr_"
sub run_stress_test ();
##############################################################################
#
# Run tests in the stress mode
#
##############################################################################
sub run_stress_test ()
{
my $args;
my $stress_suitedir;
mtr_report("Starting stress testing\n");
if ( ! $::glob_use_embedded_server )
{
if ( ! mysqld_start($::master->[0],[],[]) )
{
mtr_error("Can't start the mysqld server");
}
}
my $stress_basedir=File::Spec->catdir($::opt_vardir, "stress");
#Clean up stress dir
if ( -d $stress_basedir )
{
rmtree($stress_basedir);
}
mkpath($stress_basedir);
if ($::opt_stress_suite ne 'main' && $::opt_stress_suite ne 'default' )
{
$stress_suitedir=File::Spec->catdir($::glob_mysql_test_dir, "suite",
$::opt_stress_suite);
}
else
{
$stress_suitedir=$::glob_mysql_test_dir;
}
if ( -d $stress_suitedir )
{
#$stress_suite_t_dir=File::Spec->catdir($stress_suitedir, "t");
#$stress_suite_r_dir=File::Spec->catdir($stress_suitedir, "r");
#FIXME: check dirs above for existence to ensure that test suite
# contains tests and results dirs
}
else
{
mtr_error("Specified test suite $::opt_stress_suite doesn't exist");
}
if ( @::opt_cases )
{
$::opt_stress_test_file=File::Spec->catfile($stress_basedir, "stress_tests.txt");
open(STRESS_FILE, ">$::opt_stress_test_file");
print STRESS_FILE join("\n",@::opt_cases),"\n";
close(STRESS_FILE);
}
elsif ( $::opt_stress_test_file )
{
$::opt_stress_test_file=File::Spec->catfile($stress_suitedir,
$::opt_stress_test_file);
if ( ! -f $::opt_stress_test_file )
{
mtr_error("Specified file $::opt_stress_test_file with list of tests does not exist\n",
"Please ensure that file exists and has proper permissions");
}
}
else
{
$::opt_stress_test_file=File::Spec->catfile($stress_suitedir,
"stress_tests.txt");
if ( ! -f $::opt_stress_test_file )
{
mtr_error("Default file $::opt_stress_test_file with list of tests does not exist\n",
"Please use --stress-test-file option to specify custom one or you can\n",
"just specify name of test for testing as last argument in command line");
}
}
if ( $::opt_stress_init_file )
{
$::opt_stress_init_file=File::Spec->catfile($stress_suitedir,
$::opt_stress_init_file);
if ( ! -f $::opt_stress_init_file )
{
mtr_error("Specified file $::opt_stress_init_file with list of tests does not exist\n",
"Please ensure that file exists and has proper permissions");
}
}
else
{
$::opt_stress_init_file=File::Spec->catfile($stress_suitedir,
"stress_init.txt");
if ( ! -f $::opt_stress_init_file )
{
$::opt_stress_init_file='';
}
}
if ( $::opt_stress_mode ne 'random' && $::opt_stress_mode ne 'seq' )
{
mtr_error("You specified wrong mode $::opt_stress_mode for stress test\n",
"Correct values are 'random' or 'seq'");
}
mtr_init_args(\$args);
mtr_add_arg($args, "--server-socket=%s", $::master->[0]->{'path_sock'});
mtr_add_arg($args, "--server-user=%s", $::opt_user);
mtr_add_arg($args, "--server-database=%s", "test");
mtr_add_arg($args, "--stress-suite-basedir=%s", $::glob_mysql_test_dir);
mtr_add_arg($args, "--suite=%s", $::opt_stress_suite);
mtr_add_arg($args, "--stress-tests-file=%s", $::opt_stress_test_file);
mtr_add_arg($args, "--stress-basedir=%s", $stress_basedir);
mtr_add_arg($args, "--server-logs-dir=%s", $stress_basedir);
mtr_add_arg($args, "--stress-mode=%s", $::opt_stress_mode);
mtr_add_arg($args, "--mysqltest=%s", $::exe_mysqltest);
mtr_add_arg($args, "--threads=%s", $::opt_stress_threads);
mtr_add_arg($args, "--verbose");
mtr_add_arg($args, "--cleanup");
mtr_add_arg($args, "--log-error-details");
mtr_add_arg($args, "--abort-on-error");
if ( $::opt_stress_init_file )
{
mtr_add_arg($args, "--stress-init-file=%s", $::opt_stress_init_file);
}
if ( !$::opt_stress_loop_count && !$::opt_stress_test_count &&
!$::opt_stress_test_duration )
{
#Limit stress testing with 20 loops in case when any limit parameter
#was specified
$::opt_stress_test_count=20;
}
if ( $::opt_stress_loop_count )
{
mtr_add_arg($args, "--loop-count=%s", $::opt_stress_loop_count);
}
if ( $::opt_stress_test_count )
{
mtr_add_arg($args, "--test-count=%s", $::opt_stress_test_count);
}
if ( $::opt_stress_test_duration )
{
mtr_add_arg($args, "--test-duration=%s", $::opt_stress_test_duration);
}
#Run stress test
mtr_run("$::glob_mysql_test_dir/mysql-stress-test.pl", $args, "", "", "", "");
if ( ! $::glob_use_embedded_server )
{
stop_all_servers();
}
}
1;
# -*- cperl -*-
# Copyright (C) 2005-2006 MySQL AB
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
# This is a library file used by the Perl version of mysql-test-run,
# and is part of the translation of the Bourne shell script with the
# same name.
use Errno;
use strict;
sub mtr_init_timers ();
sub mtr_timer_start($$$);
sub mtr_timer_stop($$);
sub mtr_timer_stop_all($);
##############################################################################
#
# Initiate the structure shared by all timers
#
##############################################################################
sub mtr_init_timers () {
my $timers = { timers => {}, pids => {}};
return $timers;
}
##############################################################################
#
# Start, stop and poll a timer
#
# As alarm() isn't portable to Windows, we use separate processes to
# implement timers.
#
##############################################################################
sub mtr_timer_start($$$) {
my ($timers,$name,$duration)= @_;
if ( exists $timers->{'timers'}->{$name} )
{
# We have an old running timer, kill it
mtr_warning("There is an old timer running");
mtr_timer_stop($timers,$name);
}
FORK:
{
my $tpid= fork();
if ( ! defined $tpid )
{
if ( $! == $!{EAGAIN} ) # See "perldoc Errno"
{
mtr_warning("Got EAGAIN from fork(), sleep 1 second and redo");
sleep(1);
redo FORK;
}
else
{
mtr_error("can't fork timer, error: $!");
}
}
if ( $tpid )
{
# Parent, record the information
mtr_verbose("Starting timer for '$name',",
"duration: $duration, pid: $tpid");
$timers->{'timers'}->{$name}->{'pid'}= $tpid;
$timers->{'timers'}->{$name}->{'duration'}= $duration;
$timers->{'pids'}->{$tpid}= $name;
}
else
{
# Child, install signal handlers and sleep for "duration"
# Don't do the ^C cleanup in the timeout child processes!
# There is actually a race here, if we get ^C after fork(), but before
# clearing the signal handler.
$SIG{INT}= 'DEFAULT';
$SIG{TERM}= sub {
mtr_verbose("timer $$ woke up, exiting!");
exit(0);
};
$0= "mtr_timer(timers,$name,$duration)";
sleep($duration);
mtr_verbose("timer $$ expired after $duration seconds");
exit(0);
}
}
}
sub mtr_timer_stop ($$) {
my ($timers,$name)= @_;
if ( exists $timers->{'timers'}->{$name} )
{
my $tpid= $timers->{'timers'}->{$name}->{'pid'};
mtr_verbose("Stopping timer for '$name' with pid $tpid");
# FIXME as Cygwin reuses pids fast, maybe check that is
# the expected process somehow?!
kill(15, $tpid);
# As the timers are so simple programs, we trust them to terminate,
# and use blocking wait for it. We wait just to avoid a zombie.
waitpid($tpid,0);
delete $timers->{'timers'}->{$name}; # Remove the timer information
delete $timers->{'pids'}->{$tpid}; # and PID reference
return 1;
}
mtr_error("Asked to stop timer '$name' not started");
}
sub mtr_timer_stop_all ($) {
my $timers= shift;
foreach my $name ( keys %{$timers->{'timers'}} )
{
mtr_timer_stop($timers, $name);
}
return 1;
}
sub mtr_timer_timeout ($$) {
my ($timers,$pid)= @_;
return "" unless exists $timers->{'pids'}->{$pid};
# Got a timeout(the process with $pid is recorded as being a timer)
# return the name of the timer
return $timers->{'pids'}->{$pid};
}
1;
# -*- cperl -*-
# Copyright (C) 2006 MySQL AB
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
#
# This file is used from mysql-test-run.pl when choosing
# port numbers and directories to use for running mysqld.
#
use strict;
use Fcntl ':flock';
#
# Requested IDs are stored in a hash and released upon END.
#
my %mtr_unique_assigned_ids = ();
my $mtr_unique_pid;
BEGIN {
$mtr_unique_pid = $$ unless defined $mtr_unique_pid;
}
END {
if($mtr_unique_pid == $$) {
while(my ($id,$file) = each(%mtr_unique_assigned_ids)) {
print "Autoreleasing $file:$id\n";
mtr_release_unique_id($file, $id);
}
}
}
#
# Require a unique, numerical ID, given a file name (where all
# requested IDs are stored), a minimum and a maximum value.
#
# We use flock to implement locking for the ID file and ignore
# possible problems arising from lack of support for it on
# some platforms (it should work on most, and the possible
# race condition would occur rarely). The proper solution for
# this is a daemon that manages IDs, of course.
#
# If no unique ID within the specified parameters can be
# obtained, return undef.
#
sub mtr_require_unique_id($$$) {
my $file = shift;
my $min = shift;
my $max = shift;
my $ret = undef;
my $changed = 0;
my $can_use_ps = `ps -e | grep '^[ ]*$$ '`;
if(eval("readlink '$file'") || eval("readlink '$file.sem'")) {
die 'lock file is a symbolic link';
}
chmod 0777, "$file.sem";
open SEM, ">", "$file.sem" or die "can't write to $file.sem";
flock SEM, LOCK_EX or die "can't lock $file.sem";
if(! -e $file) {
open FILE, ">", $file or die "can't create $file";
close FILE;
}
if(eval("readlink '$file'") || eval("readlink '$file.sem'")) {
die 'lock file is a symbolic link';
}
chmod 0777, $file;
open FILE, "+<", $file or die "can't open $file";
select undef,undef,undef,0.2;
seek FILE, 0, 0;
my %taken = ();
while(<FILE>) {
chomp;
my ($id, $pid) = split / /;
$taken{$id} = $pid;
if($can_use_ps) {
my $res = `ps -e | grep '^[ ]*$pid '`;
if(!$res) {
print "Ignoring slot $id used by missing process $pid.\n";
delete $taken{$id};
++$changed;
}
}
}
for(my $i=$min; $i<=$max; ++$i) {
if(! exists $taken{$i}) {
$ret = $i;
$taken{$i} = $$;
++$changed;
last;
}
}
if($changed) {
seek FILE, 0, 0;
truncate FILE, 0 or die "can't truncate $file";
for my $k (keys %taken) {
print FILE $k . ' ' . $taken{$k} . "\n";
}
}
close FILE;
flock SEM, LOCK_UN or warn "can't unlock $file.sem";
close SEM;
$mtr_unique_assigned_ids{$ret} = $file if defined $ret;
return $ret;
}
#
# Require a unique ID like above, but sleep if no ID can be
# obtained immediately.
#
sub mtr_require_unique_id_and_wait($$$) {
my $ret = mtr_require_unique_id($_[0],$_[1],$_[2]);
while(! defined $ret) {
sleep 30;
$ret = mtr_require_unique_id($_[0],$_[1],$_[2]);
print "Waiting for unique id to become available...\n" unless $ret;
}
return $ret;
}
#
# Release a unique ID.
#
sub mtr_release_unique_id($$) {
my $file = shift;
my $myid = shift;
if(eval("readlink '$file'") || eval("readlink '$file.sem'")) {
die 'lock file is a symbolic link';
}
open SEM, ">", "$file.sem" or die "can't write to $file.sem";
flock SEM, LOCK_EX or die "can't lock $file.sem";
if(eval("readlink '$file'") || eval("readlink '$file.sem'")) {
die 'lock file is a symbolic link';
}
if(! -e $file) {
open FILE, ">", $file or die "can't create $file";
close FILE;
}
open FILE, "+<", $file or die "can't open $file";
select undef,undef,undef,0.2;
seek FILE, 0, 0;
my %taken = ();
while(<FILE>) {
chomp;
my ($id, $pid) = split / /;
$taken{$id} = $pid;
}
delete $taken{$myid};
seek FILE, 0, 0;
truncate FILE, 0 or die "can't truncate $file";
for my $k (keys %taken) {
print FILE $k . ' ' . $taken{$k} . "\n";
}
close FILE;
flock SEM, LOCK_UN or warn "can't unlock $file.sem";
close SEM;
delete $mtr_unique_assigned_ids{$myid};
}
1;
This source diff could not be displayed because it is too large. You can view the blob instead.
[ndbd default]
NoOfReplicas= 1
MaxNoOfConcurrentTransactions= 64
MaxNoOfConcurrentOperations= CHOOSE_MaxNoOfConcurrentOperations
DataMemory= CHOOSE_DataMemory
IndexMemory= CHOOSE_IndexMemory
Diskless= CHOOSE_Diskless
TimeBetweenWatchDogCheck= 30000
DataDir= CHOOSE_FILESYSTEM
MaxNoOfOrderedIndexes= CHOOSE_MaxNoOfOrderedIndexes
MaxNoOfAttributes= CHOOSE_MaxNoOfAttributes
TimeBetweenGlobalCheckpoints= 500
NoOfFragmentLogFiles= 8
FragmentLogFileSize= 6M
DiskPageBufferMemory= CHOOSE_DiskPageBufferMemory
#
# Increase timeouts to cater for slow test-machines
# (possibly running several tests in parallell)
#
HeartbeatIntervalDbDb= 30000
HeartbeatIntervalDbApi= 30000
#TransactionDeadlockDetectionTimeout= 7500
[ndbd]
HostName= CHOOSE_HOSTNAME_1 # hostname is a valid network adress
[ndb_mgmd]
HostName= CHOOSE_HOSTNAME_1 # hostname is a valid network adress
DataDir= CHOOSE_FILESYSTEM #
PortNumber= CHOOSE_PORT_MGM
[mysqld]
[mysqld]
[mysqld]
[mysqld]
[mysqld]
[mysqld]
[mysqld]
[mysqld]
[ndbd default]
NoOfReplicas= 2
MaxNoOfConcurrentTransactions= 64
MaxNoOfConcurrentOperations= CHOOSE_MaxNoOfConcurrentOperations
DataMemory= CHOOSE_DataMemory
IndexMemory= CHOOSE_IndexMemory
Diskless= CHOOSE_Diskless
TimeBetweenWatchDogCheck= 30000
DataDir= CHOOSE_FILESYSTEM
MaxNoOfOrderedIndexes= CHOOSE_MaxNoOfOrderedIndexes
MaxNoOfAttributes= CHOOSE_MaxNoOfAttributes
TimeBetweenGlobalCheckpoints= 500
NoOfFragmentLogFiles= 4
FragmentLogFileSize=12M
DiskPageBufferMemory= CHOOSE_DiskPageBufferMemory
# O_DIRECT has issues on 2.4 whach have not been handled, Bug #29612
#ODirect= 1
# the following parametes just function as a small regression
# test that the parameter exists
InitialNoOfOpenFiles= 27
#
# Increase timeouts to cater for slow test-machines
# (possibly running several tests in parallell)
#
HeartbeatIntervalDbDb= 30000
HeartbeatIntervalDbApi= 30000
#TransactionDeadlockDetectionTimeout= 7500
[ndbd]
HostName= CHOOSE_HOSTNAME_1 # hostname is a valid network adress
[ndbd]
HostName= CHOOSE_HOSTNAME_2 # hostname is a valid network adress
[ndb_mgmd]
HostName= CHOOSE_HOSTNAME_1 # hostname is a valid network adress
DataDir= CHOOSE_FILESYSTEM #
PortNumber= CHOOSE_PORT_MGM
[mysqld]
[mysqld]
[mysqld]
[mysqld]
[mysqld]
[mysqld]
[mysqld]
[mysqld]
......@@ -34,8 +34,34 @@ BEGIN {
}
}
BEGIN {
# Check backward compatibility support
# By setting the environment variable MTR_VERSION
# it's possible to use a previous version of
# mysql-test-run.pl
my $version= $ENV{MTR_VERSION} || 2;
if ( $version == 1 )
{
print "=======================================================\n";
print " WARNING: Using mysql-test-run.pl version 1! \n";
print "=======================================================\n";
require "lib/v1/mysql-test-run.pl";
exit(1);
}
elsif ( $version == 2 )
{
# This is the current version, just continue
;
}
else
{
print "ERROR: Version $version of mysql-test-run does not exist!\n";
exit(1);
}
}
use lib "lib";
use Cwd;
use Getopt::Long;
use My::File::Path; # Patched version of File::Path
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment