mirror of
https://github.com/MariaDB/server.git
synced 2025-08-01 03:47:19 +03:00
merge of 5.1-main into 5.1-maria. Myisam->Maria change propagation will follow.
There were so many changes into mtr (this is the new mtr coming) that I rather copied mtr from 6.0-main here (at least this one knows how to run Maria tests). I also fixed suite/maria tests to be accepted by the new mtr. mysys/thr_mutex.c: adding DBUG_PRINT here, so that we can locate where the warning is issued.
This commit is contained in:
Guilhem Bichot
@ -4,6 +4,7 @@ package My::Config::Option;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp;
|
||||
|
||||
|
||||
sub new {
|
||||
@ -26,12 +27,22 @@ sub value {
|
||||
return $self->{value};
|
||||
}
|
||||
|
||||
sub option {
|
||||
my ($self)= @_;
|
||||
my $name= $self->{name};
|
||||
my $value= $self->{value};
|
||||
|
||||
my $opt= $name;
|
||||
$opt= "$name=$value" if ($value);
|
||||
$opt= "--$opt" unless ($opt =~ /^--/);
|
||||
return $opt;
|
||||
}
|
||||
|
||||
package My::Config::Group;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Carp;
|
||||
|
||||
sub new {
|
||||
my ($class, $group_name)= @_;
|
||||
@ -68,7 +79,7 @@ sub remove {
|
||||
return undef unless defined $option;
|
||||
|
||||
# Remove from the hash
|
||||
delete($self->{options_by_name}->{$option_name}) or die;
|
||||
delete($self->{options_by_name}->{$option_name}) or croak;
|
||||
|
||||
# Remove from the array
|
||||
@{$self->{options}}= grep { $_->name ne $option_name } @{$self->{options}};
|
||||
@ -88,6 +99,33 @@ sub name {
|
||||
return $self->{name};
|
||||
}
|
||||
|
||||
sub suffix {
|
||||
my ($self)= @_;
|
||||
# Everything in name from the last .
|
||||
my @parts= split(/\./, $self->{name});
|
||||
my $suffix= pop(@parts);
|
||||
return ".$suffix";
|
||||
}
|
||||
|
||||
sub after {
|
||||
my ($self, $prefix)= @_;
|
||||
die unless defined $prefix;
|
||||
|
||||
# everything after $prefix
|
||||
my $name= $self->{name};
|
||||
if ($name =~ /^\Q$prefix\E(.*)$/)
|
||||
{
|
||||
return $1;
|
||||
}
|
||||
die "Failed to extract the value after '$prefix' in $name";
|
||||
}
|
||||
|
||||
|
||||
sub split {
|
||||
my ($self)= @_;
|
||||
# Return an array with name parts
|
||||
return split(/\./, $self->{name});
|
||||
}
|
||||
|
||||
#
|
||||
# Return a specific option in the group
|
||||
@ -100,23 +138,37 @@ sub option {
|
||||
|
||||
|
||||
#
|
||||
# Return a specific value for an option in the group
|
||||
# Return value for an option in the group, fail if it does not exist
|
||||
#
|
||||
sub value {
|
||||
my ($self, $option_name)= @_;
|
||||
my $option= $self->option($option_name);
|
||||
|
||||
die "No option named '$option_name' in this group"
|
||||
croak "No option named '$option_name' in group '$self->{name}'"
|
||||
if ! defined($option);
|
||||
|
||||
return $option->value();
|
||||
}
|
||||
|
||||
|
||||
#
|
||||
# Return value for an option if it exist
|
||||
#
|
||||
sub if_exist {
|
||||
my ($self, $option_name)= @_;
|
||||
my $option= $self->option($option_name);
|
||||
|
||||
return undef if ! defined($option);
|
||||
|
||||
return $option->value();
|
||||
}
|
||||
|
||||
|
||||
package My::Config;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp;
|
||||
use IO::File;
|
||||
use File::Basename;
|
||||
|
||||
@ -132,13 +184,13 @@ sub new {
|
||||
|
||||
my $self= bless { groups => [] }, $class;
|
||||
my $F= IO::File->new($path, "<")
|
||||
or die "Could not open '$path': $!";
|
||||
or croak "Could not open '$path': $!";
|
||||
|
||||
while ( my $line= <$F> ) {
|
||||
chomp($line);
|
||||
|
||||
# [group]
|
||||
if ( $line =~ /\[(.*)\]/ ) {
|
||||
if ( $line =~ /^\[(.*)\]/ ) {
|
||||
# New group found
|
||||
$group_name= $1;
|
||||
#print "group: $group_name\n";
|
||||
@ -149,7 +201,7 @@ sub new {
|
||||
# Magic #! comments
|
||||
elsif ( $line =~ /^#\!/) {
|
||||
my $magic= $line;
|
||||
die "Found magic comment '$magic' outside of group"
|
||||
croak "Found magic comment '$magic' outside of group"
|
||||
unless $group_name;
|
||||
|
||||
#print "$magic\n";
|
||||
@ -171,8 +223,13 @@ sub new {
|
||||
# !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"
|
||||
|
||||
# Check that the file exists relative to path of first config file
|
||||
if (! -f $include_file_name){
|
||||
# Try to include file relativ to current dir
|
||||
$include_file_name= $1;
|
||||
}
|
||||
croak "The include file '$include_file_name' does not exist"
|
||||
unless -f $include_file_name;
|
||||
|
||||
$self->append(My::Config->new($include_file_name));
|
||||
@ -182,7 +239,7 @@ sub new {
|
||||
elsif ( $line =~ /^([\@\w-]+)\s*$/ ) {
|
||||
my $option= $1;
|
||||
|
||||
die "Found option '$option' outside of group"
|
||||
croak "Found option '$option' outside of group"
|
||||
unless $group_name;
|
||||
|
||||
#print "$option\n";
|
||||
@ -194,13 +251,13 @@ sub new {
|
||||
my $option= $1;
|
||||
my $value= $2;
|
||||
|
||||
die "Found option '$option=$value' outside of group"
|
||||
croak "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'";
|
||||
croak "Unexpected line '$line' found in '$path'";
|
||||
}
|
||||
|
||||
}
|
||||
@ -231,6 +288,7 @@ sub insert {
|
||||
# Add the option to the group
|
||||
$group->insert($option, $value, $if_not_exist);
|
||||
}
|
||||
return $group;
|
||||
}
|
||||
|
||||
#
|
||||
@ -240,11 +298,11 @@ sub remove {
|
||||
my ($self, $group_name, $option_name)= @_;
|
||||
my $group= $self->group($group_name);
|
||||
|
||||
die "group '$group_name' does not exist"
|
||||
croak "group '$group_name' does not exist"
|
||||
unless defined($group);
|
||||
|
||||
$group->remove($option_name) or
|
||||
die "option '$option_name' does not exist";
|
||||
croak "option '$option_name' does not exist";
|
||||
}
|
||||
|
||||
|
||||
@ -267,10 +325,10 @@ sub group_exists {
|
||||
#
|
||||
sub _group_insert {
|
||||
my ($self, $group_name)= @_;
|
||||
caller eq __PACKAGE__ or die;
|
||||
caller eq __PACKAGE__ or croak;
|
||||
|
||||
# Check that group does not already exist
|
||||
die "Group already exists" if $self->group_exists($group_name);
|
||||
croak "Group already exists" if $self->group_exists($group_name);
|
||||
|
||||
my $group= My::Config::Group->new($group_name);
|
||||
push(@{$self->{groups}}, $group);
|
||||
@ -354,11 +412,11 @@ sub value {
|
||||
my ($self, $group_name, $option_name)= @_;
|
||||
my $group= $self->group($group_name);
|
||||
|
||||
die "group '$group_name' does not exist"
|
||||
croak "group '$group_name' does not exist"
|
||||
unless defined($group);
|
||||
|
||||
my $option= $group->option($option_name);
|
||||
die "option '$option_name' does not exist"
|
||||
croak "option '$option_name' does not exist"
|
||||
unless defined($option);
|
||||
|
||||
return $option->value();
|
||||
@ -372,7 +430,7 @@ sub exists {
|
||||
my ($self, $group_name, $option_name)= @_;
|
||||
my $group= $self->group($group_name);
|
||||
|
||||
die "group '$group_name' does not exist"
|
||||
croak "group '$group_name' does not exist"
|
||||
unless defined($group);
|
||||
|
||||
my $option= $group->option($option_name);
|
||||
@ -412,11 +470,11 @@ sub stringify {
|
||||
# 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
|
||||
my ($self, $path)= @_;
|
||||
my $F= IO::File->new($path, ">")
|
||||
or croak "Could not open '$path': $!";
|
||||
print $F $self;
|
||||
undef $F; # Close the file
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
655
mysql-test/lib/My/ConfigFactory.pm
Normal file
655
mysql-test/lib/My/ConfigFactory.pm
Normal file
@ -0,0 +1,655 @@
|
||||
# -*- cperl -*-
|
||||
package My::ConfigFactory;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp;
|
||||
|
||||
use My::Config;
|
||||
use My::Find;
|
||||
|
||||
use File::Basename;
|
||||
|
||||
|
||||
#
|
||||
# Rules to run first of all
|
||||
#
|
||||
my @pre_rules=
|
||||
(
|
||||
);
|
||||
|
||||
|
||||
my @share_locations= ("share/mysql", "sql/share", "share");
|
||||
|
||||
|
||||
sub get_basedir {
|
||||
my ($self, $group)= @_;
|
||||
my $basedir= $group->if_exist('basedir') ||
|
||||
$self->{ARGS}->{basedir};
|
||||
return $basedir;
|
||||
}
|
||||
|
||||
|
||||
sub fix_charset_dir {
|
||||
my ($self, $config, $group_name, $group)= @_;
|
||||
return my_find_dir($self->get_basedir($group),
|
||||
\@share_locations, "charsets");
|
||||
}
|
||||
|
||||
sub fix_language {
|
||||
my ($self, $config, $group_name, $group)= @_;
|
||||
return my_find_dir($self->get_basedir($group),
|
||||
\@share_locations, "english");
|
||||
}
|
||||
|
||||
sub fix_datadir {
|
||||
my ($self, $config, $group_name)= @_;
|
||||
my $vardir= $self->{ARGS}->{vardir};
|
||||
return "$vardir/$group_name/data";
|
||||
}
|
||||
|
||||
sub fix_pidfile {
|
||||
my ($self, $config, $group_name, $group)= @_;
|
||||
my $vardir= $self->{ARGS}->{vardir};
|
||||
return "$vardir/run/$group_name.pid";
|
||||
}
|
||||
|
||||
sub fix_port {
|
||||
my ($self, $config, $group_name, $group)= @_;
|
||||
my $hostname= $group->value('#host');
|
||||
return $self->{HOSTS}->{$hostname}++;
|
||||
}
|
||||
|
||||
sub fix_host {
|
||||
my ($self)= @_;
|
||||
# Get next host from HOSTS array
|
||||
my @hosts= keys(%{$self->{HOSTS}});;
|
||||
my $host_no= $self->{NEXT_HOST}++ % @hosts;
|
||||
return $hosts[$host_no];
|
||||
}
|
||||
|
||||
sub is_unique {
|
||||
my ($config, $name, $value)= @_;
|
||||
|
||||
foreach my $group ( $config->groups() ) {
|
||||
if ($group->option($name)) {
|
||||
if ($group->value($name) eq $value){
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub fix_server_id {
|
||||
my ($self, $config, $group_name, $group)= @_;
|
||||
#define in the order that mysqlds are listed in my.cnf
|
||||
|
||||
my $server_id= $group->if_exist('server-id');
|
||||
if (defined $server_id){
|
||||
if (!is_unique($config, 'server-id', $server_id)) {
|
||||
croak "The server-id($server_id) for '$group_name' is not unique";
|
||||
}
|
||||
return $server_id;
|
||||
}
|
||||
|
||||
do {
|
||||
$server_id= $self->{SERVER_ID}++;
|
||||
} while(!is_unique($config, 'server-id', $server_id));
|
||||
|
||||
#print "$group_name: server_id: $server_id\n";
|
||||
return $server_id;
|
||||
}
|
||||
|
||||
sub fix_socket {
|
||||
my ($self, $config, $group_name, $group)= @_;
|
||||
# Put socket file in tmpdir
|
||||
my $dir= $self->{ARGS}->{tmpdir};
|
||||
return "$dir/$group_name.sock";
|
||||
}
|
||||
|
||||
sub fix_tmpdir {
|
||||
my ($self, $config, $group_name, $group)= @_;
|
||||
my $dir= $self->{ARGS}->{tmpdir};
|
||||
return "$dir/$group_name";
|
||||
}
|
||||
|
||||
sub fix_log_error {
|
||||
my ($self, $config, $group_name, $group)= @_;
|
||||
my $dir= dirname($group->value('datadir'));
|
||||
return "$dir/mysqld.err";
|
||||
}
|
||||
|
||||
sub fix_log {
|
||||
my ($self, $config, $group_name, $group)= @_;
|
||||
my $dir= dirname($group->value('datadir'));
|
||||
return "$dir/mysqld.log";
|
||||
}
|
||||
|
||||
sub fix_log_slow_queries {
|
||||
my ($self, $config, $group_name, $group)= @_;
|
||||
my $dir= dirname($group->value('datadir'));
|
||||
return "$dir/mysqld-slow.log";
|
||||
}
|
||||
|
||||
sub fix_secure_file_priv {
|
||||
my ($self)= @_;
|
||||
my $vardir= $self->{ARGS}->{vardir};
|
||||
# By default, prevent the started mysqld to access files outside of vardir
|
||||
return $vardir;
|
||||
}
|
||||
|
||||
sub fix_std_data {
|
||||
my ($self, $config, $group_name, $group)= @_;
|
||||
my $basedir= $self->get_basedir($group);
|
||||
return "$basedir/mysql-test/std_data";
|
||||
}
|
||||
|
||||
sub ssl_supported {
|
||||
my ($self)= @_;
|
||||
return $self->{ARGS}->{ssl};
|
||||
}
|
||||
|
||||
sub fix_skip_ssl {
|
||||
return if !ssl_supported(@_);
|
||||
# Add skip-ssl if ssl is supported to avoid
|
||||
# that mysqltest connects with SSL by default
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub fix_ssl_ca {
|
||||
return if !ssl_supported(@_);
|
||||
my $std_data= fix_std_data(@_);
|
||||
return "$std_data/cacert.pem"
|
||||
}
|
||||
|
||||
sub fix_ssl_server_cert {
|
||||
return if !ssl_supported(@_);
|
||||
my $std_data= fix_std_data(@_);
|
||||
return "$std_data/server-cert.pem"
|
||||
}
|
||||
|
||||
sub fix_ssl_client_cert {
|
||||
return if !ssl_supported(@_);
|
||||
my $std_data= fix_std_data(@_);
|
||||
return "$std_data/client-cert.pem"
|
||||
}
|
||||
|
||||
sub fix_ssl_server_key {
|
||||
return if !ssl_supported(@_);
|
||||
my $std_data= fix_std_data(@_);
|
||||
return "$std_data/server-key.pem"
|
||||
}
|
||||
|
||||
sub fix_ssl_client_key {
|
||||
return if !ssl_supported(@_);
|
||||
my $std_data= fix_std_data(@_);
|
||||
return "$std_data/client-key.pem"
|
||||
}
|
||||
|
||||
|
||||
#
|
||||
# Rules to run for each mysqld in the config
|
||||
# - will be run in order listed here
|
||||
#
|
||||
my @mysqld_rules=
|
||||
(
|
||||
{ 'basedir' => sub { return shift->{ARGS}->{basedir}; } },
|
||||
{ 'tmpdir' => \&fix_tmpdir },
|
||||
{ 'character-sets-dir' => \&fix_charset_dir },
|
||||
{ 'language' => \&fix_language },
|
||||
{ 'datadir' => \&fix_datadir },
|
||||
{ 'pid-file' => \&fix_pidfile },
|
||||
{ '#host' => \&fix_host },
|
||||
{ 'port' => \&fix_port },
|
||||
{ 'socket' => \&fix_socket },
|
||||
{ 'log-error' => \&fix_log_error },
|
||||
{ 'log' => \&fix_log },
|
||||
{ 'log-slow-queries' => \&fix_log_slow_queries },
|
||||
{ '#user' => sub { return shift->{ARGS}->{user} || ""; } },
|
||||
{ '#password' => sub { return shift->{ARGS}->{password} || ""; } },
|
||||
{ 'server-id' => \&fix_server_id, },
|
||||
# By default, prevent the started mysqld to access files outside of vardir
|
||||
{ 'secure-file-priv' => sub { return shift->{ARGS}->{vardir}; } },
|
||||
{ 'ssl-ca' => \&fix_ssl_ca },
|
||||
{ 'ssl-cert' => \&fix_ssl_server_cert },
|
||||
{ 'ssl-key' => \&fix_ssl_server_key },
|
||||
);
|
||||
|
||||
|
||||
sub fix_ndb_mgmd_port {
|
||||
my ($self, $config, $group_name, $group)= @_;
|
||||
my $hostname= $group->value('HostName');
|
||||
return $self->{HOSTS}->{$hostname}++;
|
||||
}
|
||||
|
||||
|
||||
sub fix_cluster_dir {
|
||||
my ($self, $config, $group_name, $group)= @_;
|
||||
my $vardir= $self->{ARGS}->{vardir};
|
||||
my (undef, $process_type, $idx, $suffix)= split(/\./, $group_name);
|
||||
return "$vardir/mysql_cluster.$suffix/$process_type.$idx";
|
||||
}
|
||||
|
||||
|
||||
sub fix_cluster_backup_dir {
|
||||
my ($self, $config, $group_name, $group)= @_;
|
||||
my $vardir= $self->{ARGS}->{vardir};
|
||||
my (undef, $process_type, $idx, $suffix)= split(/\./, $group_name);
|
||||
return "$vardir/mysql_cluster.$suffix/";
|
||||
}
|
||||
|
||||
|
||||
#
|
||||
# Rules to run for each ndb_mgmd in the config
|
||||
# - will be run in order listed here
|
||||
#
|
||||
my @ndb_mgmd_rules=
|
||||
(
|
||||
{ 'PortNumber' => \&fix_ndb_mgmd_port },
|
||||
{ 'DataDir' => \&fix_cluster_dir },
|
||||
);
|
||||
|
||||
|
||||
#
|
||||
# Rules to run for each ndbd in the config
|
||||
# - will be run in order listed here
|
||||
#
|
||||
my @ndbd_rules=
|
||||
(
|
||||
{ 'HostName' => \&fix_host },
|
||||
{ 'DataDir' => \&fix_cluster_dir },
|
||||
{ 'BackupDataDir' => \&fix_cluster_backup_dir },
|
||||
);
|
||||
|
||||
|
||||
#
|
||||
# Rules to run for each cluster_config section
|
||||
# - will be run in order listed here
|
||||
#
|
||||
my @cluster_config_rules=
|
||||
(
|
||||
{ 'ndb_mgmd' => \&fix_host },
|
||||
{ 'ndbd' => \&fix_host },
|
||||
{ 'mysqld' => \&fix_host },
|
||||
{ 'ndbapi' => \&fix_host },
|
||||
);
|
||||
|
||||
|
||||
#
|
||||
# Rules to run for [client] section
|
||||
# - will be run in order listed here
|
||||
#
|
||||
my @client_rules=
|
||||
(
|
||||
);
|
||||
|
||||
|
||||
#
|
||||
# Rules to run for [mysqltest] section
|
||||
# - will be run in order listed here
|
||||
#
|
||||
my @mysqltest_rules=
|
||||
(
|
||||
{ 'ssl-ca' => \&fix_ssl_ca },
|
||||
{ 'ssl-cert' => \&fix_ssl_client_cert },
|
||||
{ 'ssl-key' => \&fix_ssl_client_key },
|
||||
{ 'skip-ssl' => \&fix_skip_ssl },
|
||||
);
|
||||
|
||||
|
||||
#
|
||||
# Rules to run for [mysqlbinlog] section
|
||||
# - will be run in order listed here
|
||||
#
|
||||
my @mysqlbinlog_rules=
|
||||
(
|
||||
{ 'character-sets-dir' => \&fix_charset_dir },
|
||||
);
|
||||
|
||||
|
||||
#
|
||||
# Rules to run for [mysql_upgrade] section
|
||||
# - will be run in order listed here
|
||||
#
|
||||
my @mysql_upgrade_rules=
|
||||
(
|
||||
{ 'tmpdir' => sub { return shift->{ARGS}->{tmpdir}; } },
|
||||
);
|
||||
|
||||
|
||||
#
|
||||
# Generate a [client.<suffix>] group to be
|
||||
# used for connecting to [mysqld.<suffix>]
|
||||
#
|
||||
sub post_check_client_group {
|
||||
my ($self, $config, $client_group_name, $mysqld_group_name)= @_;
|
||||
|
||||
# Settings needed for client, copied from its "mysqld"
|
||||
my %client_needs=
|
||||
(
|
||||
port => 'port',
|
||||
socket => 'socket',
|
||||
host => '#host',
|
||||
user => '#user',
|
||||
password => '#password',
|
||||
);
|
||||
|
||||
my $group_to_copy_from= $config->group($mysqld_group_name);
|
||||
while (my ($name_to, $name_from)= each( %client_needs )) {
|
||||
my $option= $group_to_copy_from->option($name_from);
|
||||
|
||||
if (! defined $option){
|
||||
#print $config;
|
||||
croak "Could not get value for '$name_from'";
|
||||
}
|
||||
$config->insert($client_group_name, $name_to, $option->value())
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub post_check_client_groups {
|
||||
my ($self, $config)= @_;
|
||||
|
||||
my $first_mysqld= $config->first_like('mysqld.');
|
||||
|
||||
return unless $first_mysqld;
|
||||
|
||||
# Always generate [client] pointing to the first
|
||||
# [mysqld.<suffix>]
|
||||
$self->post_check_client_group($config,
|
||||
'client',
|
||||
$first_mysqld->name());
|
||||
|
||||
# Then generate [client.<suffix>] for each [mysqld.<suffix>]
|
||||
foreach my $mysqld ( $config->like('mysqld.') ) {
|
||||
$self->post_check_client_group($config,
|
||||
'client'.$mysqld->after('mysqld'),
|
||||
$mysqld->name())
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
|
||||
#
|
||||
# Generate [embedded] by copying the values
|
||||
# needed from the default [mysqld] section
|
||||
# and from first [mysqld.<suffix>]
|
||||
#
|
||||
sub post_check_embedded_group {
|
||||
my ($self, $config)= @_;
|
||||
|
||||
return unless $self->{ARGS}->{embedded};
|
||||
|
||||
my $mysqld= $config->group('mysqld') or
|
||||
croak "Can't run with embedded, config has no default mysqld section";
|
||||
|
||||
my $first_mysqld= $config->first_like('mysqld.') or
|
||||
croak "Can't run with embedded, config has no mysqld";
|
||||
|
||||
my @no_copy =
|
||||
(
|
||||
'log-error', # Embedded server writes stderr to mysqltest's log file
|
||||
'slave-net-timeout', # Embedded server are not build with replication
|
||||
);
|
||||
|
||||
foreach my $option ( $mysqld->options(), $first_mysqld->options() ) {
|
||||
# Don't copy options whose name is in "no_copy" list
|
||||
next if grep ( $option->name() eq $_, @no_copy);
|
||||
|
||||
$config->insert('embedded', $option->name(), $option->value())
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
|
||||
sub resolve_at_variable {
|
||||
my ($self, $config, $group, $option)= @_;
|
||||
|
||||
# Split the options value on last .
|
||||
my @parts= split(/\./, $option->value());
|
||||
my $option_name= pop(@parts);
|
||||
my $group_name= join('.', @parts);
|
||||
|
||||
$group_name =~ s/^\@//; # Remove at
|
||||
|
||||
my $from_group= $config->group($group_name)
|
||||
or croak "There is no group named '$group_name' that ",
|
||||
"can be used to resolve '$option_name'";
|
||||
|
||||
my $from= $from_group->value($option_name);
|
||||
$config->insert($group->name(), $option->name(), $from)
|
||||
}
|
||||
|
||||
|
||||
sub post_fix_resolve_at_variables {
|
||||
my ($self, $config)= @_;
|
||||
|
||||
foreach my $group ( $config->groups() ) {
|
||||
foreach my $option ( $group->options()) {
|
||||
next unless defined $option->value();
|
||||
|
||||
$self->resolve_at_variable($config, $group, $option)
|
||||
if ($option->value() =~ /^\@/);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub post_fix_mysql_cluster_section {
|
||||
my ($self, $config)= @_;
|
||||
|
||||
# Add a [mysl_cluster.<suffix>] section for each
|
||||
# defined [cluster_config.<suffix>] section
|
||||
foreach my $group ( $config->like('cluster_config\.\w*$') )
|
||||
{
|
||||
my @urls;
|
||||
# Generate ndb_connectstring for this cluster
|
||||
foreach my $ndb_mgmd ( $config->like('cluster_config.ndb_mgmd.')) {
|
||||
if ($ndb_mgmd->suffix() eq $group->suffix()) {
|
||||
my $host= $ndb_mgmd->value('HostName');
|
||||
my $port= $ndb_mgmd->value('PortNumber');
|
||||
push(@urls, "$host:$port");
|
||||
}
|
||||
}
|
||||
croak "Could not generate valid ndb_connectstring for '$group'"
|
||||
unless @urls > 0;
|
||||
my $ndb_connectstring= join(";", @urls);
|
||||
|
||||
# Add ndb_connectstring to [mysql_cluster.<suffix>]
|
||||
$config->insert('mysql_cluster'.$group->suffix(),
|
||||
'ndb_connectstring', $ndb_connectstring);
|
||||
|
||||
# Add ndb_connectstring to each mysqld connected to this
|
||||
# cluster
|
||||
foreach my $mysqld ( $config->like('cluster_config.mysqld.')) {
|
||||
if ($mysqld->suffix() eq $group->suffix()) {
|
||||
my $after= $mysqld->after('cluster_config.mysqld');
|
||||
$config->insert("mysqld$after",
|
||||
'ndb_connectstring', $ndb_connectstring);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
#
|
||||
# Rules to run last of all
|
||||
#
|
||||
my @post_rules=
|
||||
(
|
||||
\&post_check_client_groups,
|
||||
\&post_fix_mysql_cluster_section,
|
||||
\&post_fix_resolve_at_variables,
|
||||
\&post_check_embedded_group,
|
||||
);
|
||||
|
||||
|
||||
sub run_rules_for_group {
|
||||
my ($self, $config, $group, @rules)= @_;
|
||||
foreach my $hash ( @rules ) {
|
||||
while (my ($option, $rule)= each( %{$hash} )) {
|
||||
# Only run this rule if the value is not already defined
|
||||
if (!$config->exists($group->name(), $option)) {
|
||||
my $value;
|
||||
if (ref $rule eq "CODE") {
|
||||
# Call the rule function
|
||||
$value= &$rule($self, $config, $group->name(),
|
||||
$config->group($group->name()));
|
||||
} else {
|
||||
$value= $rule;
|
||||
}
|
||||
if (defined $value) {
|
||||
$config->insert($group->name(), $option, $value, 1);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub run_section_rules {
|
||||
my ($self, $config, $name, @rules)= @_;
|
||||
|
||||
foreach my $group ( $config->like($name) ) {
|
||||
$self->run_rules_for_group($config, $group, @rules);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub run_generate_sections_from_cluster_config {
|
||||
my ($self, $config)= @_;
|
||||
|
||||
my @options= ('ndb_mgmd', 'ndbd',
|
||||
'mysqld', 'ndbapi');
|
||||
|
||||
foreach my $group ( $config->like('cluster_config\.\w*$') ) {
|
||||
|
||||
# Keep track of current index per process type
|
||||
my %idxes;
|
||||
map { $idxes{$_}= 1; } @options;
|
||||
|
||||
foreach my $option_name ( @options ) {
|
||||
my $value= $group->value($option_name);
|
||||
my @hosts= split(/,/, $value, -1); # -1 => return also empty strings
|
||||
|
||||
# Add at least one host
|
||||
push(@hosts, undef) unless scalar(@hosts);
|
||||
|
||||
# Assign hosts unless already fixed
|
||||
@hosts= map { $self->fix_host() unless $_; } @hosts;
|
||||
|
||||
# Write the hosts value back
|
||||
$group->insert($option_name, join(",", @hosts));
|
||||
|
||||
# Generate sections for each host
|
||||
foreach my $host ( @hosts ){
|
||||
my $idx= $idxes{$option_name}++;
|
||||
|
||||
my $suffix= $group->suffix();
|
||||
# Generate a section for ndb_mgmd to read
|
||||
$config->insert("cluster_config.$option_name.$idx$suffix",
|
||||
"HostName", $host);
|
||||
|
||||
if ($option_name eq 'mysqld'){
|
||||
my $datadir=
|
||||
$self->fix_cluster_dir($config,
|
||||
"cluster_config.mysqld.$idx$suffix",
|
||||
$group);
|
||||
$config->insert("mysqld.$idx$suffix",
|
||||
'datadir', "$datadir/data");
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub new_config {
|
||||
my ($class, $args)= @_;
|
||||
|
||||
my @required_args= ('basedir', 'baseport', 'vardir', 'template_path');
|
||||
|
||||
foreach my $required ( @required_args ) {
|
||||
croak "you must pass '$required'" unless defined $args->{$required};
|
||||
}
|
||||
|
||||
# Fill in hosts/port hash
|
||||
my $hosts= {};
|
||||
my $baseport= $args->{baseport};
|
||||
$args->{hosts}= [ 'localhost' ] unless exists($args->{hosts});
|
||||
foreach my $host ( @{$args->{hosts}} ) {
|
||||
$hosts->{$host}= $baseport;
|
||||
}
|
||||
|
||||
# Open the config template
|
||||
my $config= My::Config->new($args->{'template_path'});
|
||||
my $extra_template_path= $args->{'extra_template_path'};
|
||||
if ($extra_template_path){
|
||||
$config->append(My::Config->new($extra_template_path));
|
||||
}
|
||||
my $self= bless {
|
||||
CONFIG => $config,
|
||||
ARGS => $args,
|
||||
HOSTS => $hosts,
|
||||
NEXT_HOST => 0,
|
||||
SERVER_ID => 1,
|
||||
}, $class;
|
||||
|
||||
|
||||
{
|
||||
# Run pre rules
|
||||
foreach my $rule ( @pre_rules ) {
|
||||
&$rule($self, $config);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
$self->run_section_rules($config,
|
||||
'cluster_config\.\w*$',
|
||||
@cluster_config_rules);
|
||||
$self->run_generate_sections_from_cluster_config($config);
|
||||
|
||||
$self->run_section_rules($config,
|
||||
'cluster_config.ndb_mgmd.',
|
||||
@ndb_mgmd_rules);
|
||||
$self->run_section_rules($config,
|
||||
'cluster_config.ndbd',
|
||||
@ndbd_rules);
|
||||
|
||||
$self->run_section_rules($config,
|
||||
'mysqld.',
|
||||
@mysqld_rules);
|
||||
|
||||
# [mysqlbinlog] need additional settings
|
||||
$self->run_rules_for_group($config,
|
||||
$config->insert('mysqlbinlog'),
|
||||
@mysqlbinlog_rules);
|
||||
|
||||
# [mysql_upgrade] need additional settings
|
||||
$self->run_rules_for_group($config,
|
||||
$config->insert('mysql_upgrade'),
|
||||
@mysql_upgrade_rules);
|
||||
|
||||
# Additional rules required for [client]
|
||||
$self->run_rules_for_group($config,
|
||||
$config->insert('client'),
|
||||
@client_rules);
|
||||
|
||||
|
||||
# Additional rules required for [mysqltest]
|
||||
$self->run_rules_for_group($config,
|
||||
$config->insert('mysqltest'),
|
||||
@mysqltest_rules);
|
||||
|
||||
{
|
||||
# Run post rules
|
||||
foreach my $rule ( @post_rules ) {
|
||||
&$rule($self, $config);
|
||||
}
|
||||
}
|
||||
|
||||
return $config;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
131
mysql-test/lib/My/CoreDump.pm
Normal file
131
mysql-test/lib/My/CoreDump.pm
Normal file
@ -0,0 +1,131 @@
|
||||
# -*- 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
|
||||
|
||||
package My::CoreDump;
|
||||
|
||||
use strict;
|
||||
use Carp;
|
||||
use My::Platform;
|
||||
|
||||
use File::Temp qw/ tempfile tempdir /;
|
||||
|
||||
sub _gdb {
|
||||
my ($core_name)= @_;
|
||||
|
||||
print "\nTrying 'gdb' to get a backtrace\n";
|
||||
|
||||
return unless -f $core_name;
|
||||
|
||||
# Find out name of binary that generated core
|
||||
`gdb -c '$core_name' --batch 2>&1` =~
|
||||
/Core was generated by `([^\s\'\`]+)/;
|
||||
my $binary= $1 or return;
|
||||
print "Core generated by '$binary'\n";
|
||||
|
||||
# Create tempfile containing gdb commands
|
||||
my ($tmp, $tmp_name) = tempfile();
|
||||
print $tmp
|
||||
"bt\n",
|
||||
"thread apply all bt\n",
|
||||
"quit\n";
|
||||
close $tmp or die "Error closing $tmp_name: $!";
|
||||
|
||||
# Run gdb
|
||||
my $gdb_output=
|
||||
`gdb '$binary' -c '$core_name' -x '$tmp_name' --batch 2>&1`;
|
||||
|
||||
unlink $tmp_name or die "Error removing $tmp_name: $!";
|
||||
|
||||
return if $? >> 8;
|
||||
return unless $gdb_output;
|
||||
|
||||
print <<EOF, $gdb_output, "\n";
|
||||
Output from gdb follows. The first stack trace is from the failing thread.
|
||||
The following stack traces are from all threads (so the failing one is
|
||||
duplicated).
|
||||
--------------------------
|
||||
EOF
|
||||
return 1;
|
||||
}
|
||||
|
||||
|
||||
sub _dbx {
|
||||
my ($core_name)= @_;
|
||||
|
||||
print "\nTrying 'dbx' to get a backtrace\n";
|
||||
|
||||
return unless -f $core_name;
|
||||
|
||||
# Find out name of binary that generated core
|
||||
`echo | dbx - '$core_name' 2>&1` =~
|
||||
/Corefile specified executable: "([^"]+)"/;
|
||||
my $binary= $1 or return;
|
||||
print "Core generated by '$binary'\n";
|
||||
|
||||
# Find all threads
|
||||
my @thr_ids = `echo threads | dbx '$binary' '$core_name' 2>&1` =~ /t@\d+/g;
|
||||
|
||||
# Create tempfile containing dbx commands
|
||||
my ($tmp, $tmp_name) = tempfile();
|
||||
foreach my $thread (@thr_ids) {
|
||||
print $tmp "where $thread\n";
|
||||
}
|
||||
print $tmp "exit\n";
|
||||
close $tmp or die "Error closing $tmp_name: $!";
|
||||
|
||||
# Run dbx
|
||||
my $dbx_output=
|
||||
`cat '$tmp_name' | dbx '$binary' '$core_name' 2>&1`;
|
||||
|
||||
unlink $tmp_name or die "Error removing $tmp_name: $!";
|
||||
|
||||
return if $? >> 8;
|
||||
return unless $dbx_output;
|
||||
|
||||
print <<EOF, $dbx_output, "\n";
|
||||
Output from dbx follows. Stack trace is printed for all threads in order,
|
||||
above this you should see info about which thread was the failing one.
|
||||
----------------------------
|
||||
EOF
|
||||
return 1;
|
||||
}
|
||||
|
||||
|
||||
sub show {
|
||||
my ($class, $core_name)= @_;
|
||||
|
||||
# We try dbx first; gdb itself may coredump if run on a Sun Studio
|
||||
# compiled binary on Solaris.
|
||||
|
||||
my @debuggers =
|
||||
(
|
||||
\&_dbx,
|
||||
\&_gdb,
|
||||
# TODO...
|
||||
);
|
||||
|
||||
# Try debuggers until one succeeds
|
||||
|
||||
foreach my $debugger (@debuggers){
|
||||
if ($debugger->($core_name)){
|
||||
return;
|
||||
}
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
177
mysql-test/lib/My/File/Path.pm
Normal file
177
mysql-test/lib/My/File/Path.pm
Normal file
@ -0,0 +1,177 @@
|
||||
# -*- cperl -*-
|
||||
package My::File::Path;
|
||||
use strict;
|
||||
|
||||
|
||||
#
|
||||
# File::Path::rmtree has a problem with deleting files
|
||||
# and directories where it hasn't got read permission
|
||||
#
|
||||
# Patch this by installing a 'rmtree' function in local
|
||||
# scope that first chmod all files to 0777 before calling
|
||||
# the original rmtree function.
|
||||
#
|
||||
# This is almost gone in version 1.08 of File::Path -
|
||||
# but unfortunately some hosts still suffers
|
||||
# from this also in 1.08
|
||||
#
|
||||
|
||||
use Exporter;
|
||||
use base "Exporter";
|
||||
our @EXPORT= qw / rmtree mkpath copytree /;
|
||||
|
||||
use File::Find;
|
||||
use File::Copy;
|
||||
use File::Spec;
|
||||
use Carp;
|
||||
use My::Handles;
|
||||
use My::Platform;
|
||||
|
||||
sub rmtree {
|
||||
my ($dir)= @_;
|
||||
find( {
|
||||
bydepth => 1,
|
||||
no_chdir => 1,
|
||||
wanted => sub {
|
||||
my $name= $_;
|
||||
if (!-l $name && -d _){
|
||||
return if (rmdir($name) == 1);
|
||||
|
||||
chmod(0777, $name) or carp("couldn't chmod(0777, $name): $!");
|
||||
|
||||
return if (rmdir($name) == 1);
|
||||
|
||||
# Failed to remove the directory, analyze
|
||||
carp("Couldn't remove directory '$name': $!");
|
||||
My::Handles::show_handles($name);
|
||||
} else {
|
||||
return if (unlink($name) == 1);
|
||||
|
||||
chmod(0777, $name) or carp("couldn't chmod(0777, $name): $!");
|
||||
|
||||
return if (unlink($name) == 1);
|
||||
|
||||
carp("Couldn't delete file '$name': $!");
|
||||
My::Handles::show_handles($name);
|
||||
}
|
||||
}
|
||||
}, $dir );
|
||||
};
|
||||
|
||||
|
||||
use File::Basename;
|
||||
sub _mkpath_debug {
|
||||
my ($message, $path, $dir, $err)= @_;
|
||||
|
||||
print "=" x 40, "\n";
|
||||
print $message, "\n";
|
||||
print "err: '$err'\n";
|
||||
print "path: '$path'\n";
|
||||
print "dir: '$dir'\n";
|
||||
|
||||
print "-" x 40, "\n";
|
||||
my $dirname= dirname($path);
|
||||
print "ls -l $dirname\n";
|
||||
print `ls -l $dirname`, "\n";
|
||||
print "-" x 40, "\n";
|
||||
print "dir $dirname\n";
|
||||
print `dir $dirname`, "\n";
|
||||
print "-" x 40, "\n";
|
||||
my $dirname2= dirname($dirname);
|
||||
print "ls -l $dirname2\n";
|
||||
print `ls -l $dirname2`, "\n";
|
||||
print "-" x 40, "\n";
|
||||
print "dir $dirname2\n";
|
||||
print `dir $dirname2`, "\n";
|
||||
print "-" x 40, "\n";
|
||||
print "file exists\n" if (-e $path);
|
||||
print "file is a plain file\n" if (-f $path);
|
||||
print "file is a directory\n" if (-d $path);
|
||||
print "-" x 40, "\n";
|
||||
print "showing handles for $path\n";
|
||||
My::Handles::show_handles($path);
|
||||
|
||||
print "=" x 40, "\n";
|
||||
|
||||
}
|
||||
|
||||
|
||||
sub mkpath {
|
||||
my $path;
|
||||
|
||||
die "Usage: mkpath(<path>)" unless @_ == 1;
|
||||
|
||||
foreach my $dir ( File::Spec->splitdir( @_ ) ) {
|
||||
#print "dir: $dir\n";
|
||||
if ($dir =~ /^[a-z]:/i){
|
||||
# Found volume ie. C:
|
||||
$path= $dir;
|
||||
next;
|
||||
}
|
||||
|
||||
$path= File::Spec->catdir($path, $dir);
|
||||
#print "path: $path\n";
|
||||
|
||||
next if -d $path; # Path already exists and is a directory
|
||||
croak("File already exists but is not a directory: '$path'") if -e $path;
|
||||
next if mkdir($path);
|
||||
_mkpath_debug("mkdir failed", $path, $dir, $!);
|
||||
|
||||
# mkdir failed, try one more time
|
||||
next if mkdir($path);
|
||||
_mkpath_debug("mkdir failed, second time", $path, $dir, $!);
|
||||
|
||||
# mkdir failed again, try two more time after sleep(s)
|
||||
sleep(1);
|
||||
next if mkdir($path);
|
||||
_mkpath_debug("mkdir failed, third time", $path, $dir, $!);
|
||||
|
||||
sleep(1);
|
||||
next if mkdir($path);
|
||||
_mkpath_debug("mkdir failed, fourth time", $path, $dir, $!);
|
||||
|
||||
# Report failure and die
|
||||
croak("Couldn't create directory '$path' ",
|
||||
" after 4 attempts and 2 sleep(1): $!");
|
||||
}
|
||||
};
|
||||
|
||||
|
||||
sub copytree {
|
||||
my ($from_dir, $to_dir, $use_umask) = @_;
|
||||
|
||||
die "Usage: copytree(<fromdir>, <todir>, [<umask>])"
|
||||
unless @_ == 2 or @_ == 3;
|
||||
|
||||
my $orig_umask;
|
||||
if ($use_umask){
|
||||
# Set new umask and remember the original
|
||||
$orig_umask= umask(oct($use_umask));
|
||||
}
|
||||
|
||||
mkpath("$to_dir");
|
||||
opendir(DIR, "$from_dir")
|
||||
or croak("Can't find $from_dir$!");
|
||||
for(readdir(DIR)) {
|
||||
|
||||
next if "$_" eq "." or "$_" eq "..";
|
||||
|
||||
# Skip SCCS/ directories
|
||||
next if "$_" eq "SCCS";
|
||||
|
||||
if ( -d "$from_dir/$_" )
|
||||
{
|
||||
copytree("$from_dir/$_", "$to_dir/$_");
|
||||
next;
|
||||
}
|
||||
copy("$from_dir/$_", "$to_dir/$_");
|
||||
}
|
||||
closedir(DIR);
|
||||
|
||||
if ($orig_umask){
|
||||
# Set the original umask
|
||||
umask($orig_umask);
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
245
mysql-test/lib/My/Find.pm
Normal file
245
mysql-test/lib/My/Find.pm
Normal file
@ -0,0 +1,245 @@
|
||||
# -*- 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
|
||||
|
||||
|
||||
package My::Find;
|
||||
|
||||
#
|
||||
# Utility functions to find files in a MySQL source or bindist
|
||||
#
|
||||
|
||||
use strict;
|
||||
use Carp;
|
||||
use My::Platform;
|
||||
|
||||
use base qw(Exporter);
|
||||
our @EXPORT= qw(my_find_bin my_find_dir my_find_file NOT_REQUIRED);
|
||||
|
||||
our $vs_config_dir;
|
||||
|
||||
my $bin_extension= ".exe" if IS_WINDOWS;
|
||||
|
||||
# Helper function to be used for fourth parameter to find functions
|
||||
sub NOT_REQUIRED { return 0; }
|
||||
|
||||
#
|
||||
# my_find_bin - find an executable with "name_1...name_n" in
|
||||
# paths "path_1...path_n" and return the full path
|
||||
#
|
||||
# Example:
|
||||
# my $mysqld_exe= my_find_bin($basedir.
|
||||
# ["sql", "bin"],
|
||||
# ["mysqld", "mysqld-debug"]);
|
||||
# my $mysql_exe= my_find_bin($basedir,
|
||||
# ["client", "bin"],
|
||||
# "mysql");
|
||||
#
|
||||
#
|
||||
# To check if something exists, use the required parameter
|
||||
# set to 0, the function will return an empty string if the
|
||||
# binary is not found
|
||||
# my $mysql_exe= my_find_bin($basedir,
|
||||
# ["client", "bin"],
|
||||
# "mysql", NOT_REQUIRED);
|
||||
#
|
||||
# NOTE: The function honours MTR_VS_CONFIG environment variable
|
||||
#
|
||||
#
|
||||
sub my_find_bin {
|
||||
my ($base, $paths, $names, $required)= @_;
|
||||
croak "usage: my_find_bin(<base>, <paths>, <names>, [<required>])"
|
||||
unless @_ == 4 or @_ == 3;
|
||||
|
||||
# -------------------------------------------------------
|
||||
# Find and return the first executable
|
||||
# -------------------------------------------------------
|
||||
foreach my $path (my_find_paths($base, $paths, $names, $bin_extension)) {
|
||||
return $path if ( -x $path or (IS_WINDOWS and -f $path) );
|
||||
}
|
||||
if (defined $required and $required == NOT_REQUIRED){
|
||||
# Return empty string to indicate not found
|
||||
return "";
|
||||
}
|
||||
find_error($base, $paths, $names);
|
||||
}
|
||||
|
||||
|
||||
#
|
||||
# my_find_file - find a file with "name_1...name_n" in
|
||||
# paths "path_1...path_n" and return the full path
|
||||
#
|
||||
# Example:
|
||||
# my $mysqld_exe= my_find_file($basedir.
|
||||
# ["sql", "bin"],
|
||||
# "filename");
|
||||
#
|
||||
#
|
||||
# Also supports NOT_REQUIRED flag
|
||||
#
|
||||
# NOTE: The function honours MTR_VS_CONFIG environment variable
|
||||
#
|
||||
#
|
||||
sub my_find_file {
|
||||
my ($base, $paths, $names, $required)= @_;
|
||||
croak "usage: my_find_file(<base>, <paths>, <names>, [<required>])"
|
||||
unless @_ == 4 or @_ == 3;
|
||||
|
||||
# -------------------------------------------------------
|
||||
# Find and return the first executable
|
||||
# -------------------------------------------------------
|
||||
foreach my $path (my_find_paths($base, $paths, $names, $bin_extension)) {
|
||||
return $path if ( -f $path );
|
||||
}
|
||||
if (defined $required and $required == NOT_REQUIRED){
|
||||
# Return empty string to indicate not found
|
||||
return "";
|
||||
}
|
||||
find_error($base, $paths, $names);
|
||||
}
|
||||
|
||||
|
||||
#
|
||||
# my_find_dir - find the first existing directory in one of
|
||||
# the given paths
|
||||
#
|
||||
# Example:
|
||||
# my $charset_set= my_find_dir($basedir,
|
||||
# ["mysql/share","sql/share", "share"],
|
||||
# ["charset"]);
|
||||
# or
|
||||
# my $charset_set= my_find_dir($basedir,
|
||||
# ['client_release', 'client_debug',
|
||||
# 'client', 'bin']);
|
||||
#
|
||||
# NOTE: The function honours MTR_VS_CONFIG environment variable
|
||||
#
|
||||
#
|
||||
sub my_find_dir {
|
||||
my ($base, $paths, $dirs, $required)= @_;
|
||||
croak "usage: my_find_dir(<base>, <paths>[, <dirs>])"
|
||||
unless (@_ == 3 or @_ == 2);
|
||||
|
||||
# -------------------------------------------------------
|
||||
# Find and return the first directory
|
||||
# -------------------------------------------------------
|
||||
foreach my $path (my_find_paths($base, $paths, $dirs)) {
|
||||
return $path if ( -d $path );
|
||||
}
|
||||
find_error($base, $paths, $dirs);
|
||||
}
|
||||
|
||||
|
||||
sub my_find_paths {
|
||||
my ($base, $paths, $names, $extension)= @_;
|
||||
|
||||
# Convert the arguments into two normal arrays to ease
|
||||
# further mappings
|
||||
my (@names, @paths);
|
||||
push(@names, ref $names eq "ARRAY" ? @$names : $names);
|
||||
push(@paths, ref $paths eq "ARRAY" ? @$paths : $paths);
|
||||
|
||||
#print "base: $base\n";
|
||||
#print "names: @names\n";
|
||||
#print "paths: @paths\n";
|
||||
|
||||
# User can select to look in a special build dir
|
||||
# which is a subdirectory of any of the paths
|
||||
my @extra_dirs;
|
||||
my $build_dir= $vs_config_dir || $ENV{MTR_VS_CONFIG} || $ENV{MTR_BUILD_DIR};
|
||||
push(@extra_dirs, $build_dir) if defined $build_dir;
|
||||
|
||||
if (defined $extension){
|
||||
# Append extension to names, if name does not already have extension
|
||||
map { $_.=$extension unless /\.(.*)+$/ } @names;
|
||||
}
|
||||
|
||||
# -------------------------------------------------------
|
||||
# Windows specific
|
||||
# -------------------------------------------------------
|
||||
if (IS_WINDOWS) {
|
||||
# Add the default extra build dirs unless a specific one has
|
||||
# already been selected
|
||||
push(@extra_dirs,
|
||||
("release",
|
||||
"relwithdebinfo",
|
||||
"debug")) if @extra_dirs == 0;
|
||||
}
|
||||
|
||||
#print "extra_build_dir: @extra_dirs\n";
|
||||
|
||||
# -------------------------------------------------------
|
||||
# Build cross product of "paths * extra_build_dirs"
|
||||
# -------------------------------------------------------
|
||||
push(@paths, map { my $path= $_;
|
||||
map { "$path/$_" } @extra_dirs
|
||||
} @paths);
|
||||
#print "paths: @paths\n";
|
||||
|
||||
# -------------------------------------------------------
|
||||
# Build cross product of "paths * names"
|
||||
# -------------------------------------------------------
|
||||
@paths= map { my $path= $_;
|
||||
map { "$path/$_" } @names
|
||||
} @paths;
|
||||
#print "paths: @paths\n";
|
||||
|
||||
# -------------------------------------------------------
|
||||
# Prepend base to all paths
|
||||
# -------------------------------------------------------
|
||||
@paths= map { "$base/$_" } @paths;
|
||||
#print "paths: @paths\n";
|
||||
|
||||
# -------------------------------------------------------
|
||||
# Glob all paths to expand wildcards
|
||||
# -------------------------------------------------------
|
||||
@paths= map { glob("$_") } @paths;
|
||||
#print "paths: @paths\n";
|
||||
|
||||
# -------------------------------------------------------
|
||||
# Return the list of paths
|
||||
# -------------------------------------------------------
|
||||
return @paths;
|
||||
}
|
||||
|
||||
|
||||
sub commify {
|
||||
return
|
||||
(@_ == 0) ? '' :
|
||||
(@_ == 1) ? $_[0] :
|
||||
(@_ == 2) ? join(" or ", @_) :
|
||||
join(", ", @_[0..($#_-1)], "or $_[-1]");
|
||||
|
||||
}
|
||||
|
||||
|
||||
sub fnuttify {
|
||||
return map('\''.$_.'\'', @_);
|
||||
}
|
||||
|
||||
|
||||
sub find_error {
|
||||
my ($base, $paths, $names)= @_;
|
||||
|
||||
my (@names, @paths);
|
||||
push(@names, ref $names eq "ARRAY" ? @$names : $names);
|
||||
push(@paths, ref $paths eq "ARRAY" ? @$paths : $paths);
|
||||
|
||||
croak "** ERROR: Could not find ",
|
||||
commify(fnuttify(@names)), " in ",
|
||||
commify(fnuttify(my_find_paths($base, $paths, $names))), "\n";
|
||||
}
|
||||
|
||||
1;
|
||||
69
mysql-test/lib/My/Handles.pm
Executable file
69
mysql-test/lib/My/Handles.pm
Executable file
@ -0,0 +1,69 @@
|
||||
# -*- cperl -*-
|
||||
# Copyright (C) 2008 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
|
||||
|
||||
package My::Handles;
|
||||
|
||||
|
||||
use strict;
|
||||
use Carp;
|
||||
|
||||
use My::Platform;
|
||||
|
||||
my $handle_exe;
|
||||
|
||||
|
||||
if (IS_WINDOWS){
|
||||
# Check if handle.exe is available
|
||||
# Pass switch to accept the EULA to avoid hanging
|
||||
# if the program hasn't been run before.
|
||||
my $list= `handle.exe -? -accepteula 2>&1`;
|
||||
foreach my $line (split('\n', $list))
|
||||
{
|
||||
$handle_exe= "$1.$2"
|
||||
if ($line =~ /Handle v([0-9]*)\.([0-9]*)/);
|
||||
}
|
||||
if ($handle_exe){
|
||||
print "Found handle.exe version $handle_exe\n";
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub show_handles
|
||||
{
|
||||
my ($dir)= @_;
|
||||
return unless $handle_exe;
|
||||
return unless $dir;
|
||||
|
||||
$dir= native_path($dir);
|
||||
|
||||
# Get a list of open handles in a particular directory
|
||||
my $list= `handle.exe "$dir" 2>&1` or return;
|
||||
|
||||
foreach my $line (split('\n', $list))
|
||||
{
|
||||
return if ($line =~ /No matching handles found/);
|
||||
}
|
||||
|
||||
print "\n";
|
||||
print "=" x 50, "\n";
|
||||
print "Open handles in '$dir':\n";
|
||||
print "$list\n";
|
||||
print "=" x 50, "\n\n";
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
1;
|
||||
199
mysql-test/lib/My/Options.pm
Normal file
199
mysql-test/lib/My/Options.pm
Normal file
@ -0,0 +1,199 @@
|
||||
# -*- 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
|
||||
|
||||
|
||||
package My::Options;
|
||||
|
||||
#
|
||||
# Utility functions to work with list of options
|
||||
#
|
||||
|
||||
use strict;
|
||||
|
||||
|
||||
sub same($$) {
|
||||
my $l1= shift;
|
||||
my $l2= shift;
|
||||
return compare($l1,$l2) == 0;
|
||||
}
|
||||
|
||||
|
||||
sub compare ($$) {
|
||||
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
|
||||
}
|
||||
|
||||
|
||||
sub _split_option {
|
||||
my ($option)= @_;
|
||||
if ($option=~ /^--(.*)=(.*)$/){
|
||||
return ($1, $2);
|
||||
}
|
||||
elsif ($option=~ /^--(.*)$/){
|
||||
return ($1, undef)
|
||||
}
|
||||
elsif ($option=~ /^\$(.*)$/){ # $VAR
|
||||
return ($1, undef)
|
||||
}
|
||||
elsif ($option=~ /^(.*)=(.*)$/){
|
||||
return ($1, $2)
|
||||
}
|
||||
elsif ($option=~ /^-O$/){
|
||||
return (undef, undef);
|
||||
}
|
||||
die "Unknown option format '$option'";
|
||||
}
|
||||
|
||||
|
||||
sub _build_option {
|
||||
my ($name, $value)= @_;
|
||||
if ($name =~ /^O, /){
|
||||
return "-".$name."=".$value;
|
||||
}
|
||||
elsif ($value){
|
||||
return "--".$name."=".$value;
|
||||
}
|
||||
return "--".$name;
|
||||
}
|
||||
|
||||
|
||||
#
|
||||
# Compare two list of options and return what would need
|
||||
# to be done to get the server running with the new settings
|
||||
#
|
||||
sub diff {
|
||||
my ($from_opts, $to_opts)= @_;
|
||||
|
||||
my %from;
|
||||
foreach my $from (@$from_opts)
|
||||
{
|
||||
my ($opt, $value)= _split_option($from);
|
||||
next unless defined($opt);
|
||||
$from{$opt}= $value;
|
||||
}
|
||||
|
||||
#print "from: ", %from, "\n";
|
||||
|
||||
my %to;
|
||||
foreach my $to (@$to_opts)
|
||||
{
|
||||
my ($opt, $value)= _split_option($to);
|
||||
next unless defined($opt);
|
||||
$to{$opt}= $value;
|
||||
}
|
||||
|
||||
#print "to: ", %to, "\n";
|
||||
|
||||
# Remove the ones that are in both lists
|
||||
foreach my $name (keys %from){
|
||||
if (exists $to{$name} and $to{$name} eq $from{$name}){
|
||||
#print "removing '$name' from both lists\n";
|
||||
delete $to{$name};
|
||||
delete $from{$name};
|
||||
}
|
||||
}
|
||||
|
||||
#print "from: ", %from, "\n";
|
||||
#print "to: ", %to, "\n";
|
||||
|
||||
# Add all keys in "to" to result
|
||||
my @result;
|
||||
foreach my $name (keys %to){
|
||||
push(@result, _build_option($name, $to{$name}));
|
||||
}
|
||||
|
||||
# Add all keys in "from" that are not in "to"
|
||||
# to result as "set to default"
|
||||
foreach my $name (keys %from){
|
||||
if (not exists $to{$name}) {
|
||||
push(@result, _build_option($name, "default"));
|
||||
}
|
||||
}
|
||||
|
||||
return @result;
|
||||
}
|
||||
|
||||
|
||||
sub is_set {
|
||||
my ($opts, $set_opts)= @_;
|
||||
|
||||
foreach my $opt (@$opts){
|
||||
|
||||
my ($opt_name1, $value1)= _split_option($opt);
|
||||
|
||||
foreach my $set_opt (@$set_opts){
|
||||
my ($opt_name2, $value2)= _split_option($set_opt);
|
||||
|
||||
if ($opt_name1 eq $opt_name2){
|
||||
# Option already set
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
||||
sub toSQL {
|
||||
my (@options)= @_;
|
||||
my @sql;
|
||||
|
||||
foreach my $option (@options) {
|
||||
my ($name, $value)= _split_option($option);
|
||||
#print "name: $name\n";
|
||||
#print "value: $value\n";
|
||||
if ($name =~ /^O, (.*)/){
|
||||
push(@sql, "SET GLOBAL $1=$value");
|
||||
}
|
||||
elsif ($name =~ /^set-variable=(.*)/){
|
||||
push(@sql, "SET GLOBAL $1=$value");
|
||||
}
|
||||
else {
|
||||
my $sql_name= $name;
|
||||
$sql_name=~ s/-/_/g;
|
||||
push(@sql, "SET GLOBAL $sql_name=$value");
|
||||
}
|
||||
}
|
||||
return join("; ", @sql);
|
||||
}
|
||||
|
||||
|
||||
sub toStr {
|
||||
my $name= shift;
|
||||
return "$name: ",
|
||||
"['", join("', '", @_), "']\n";
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
156
mysql-test/lib/My/Platform.pm
Normal file
156
mysql-test/lib/My/Platform.pm
Normal file
@ -0,0 +1,156 @@
|
||||
# -*- 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
|
||||
|
||||
package My::Platform;
|
||||
|
||||
use strict;
|
||||
use File::Basename;
|
||||
use File::Path;
|
||||
|
||||
use base qw(Exporter);
|
||||
our @EXPORT= qw(IS_CYGWIN IS_WINDOWS IS_WIN32PERL
|
||||
native_path posix_path mixed_path
|
||||
check_socket_path_length process_alive);
|
||||
|
||||
BEGIN {
|
||||
if ($^O eq "cygwin") {
|
||||
# Make sure cygpath works
|
||||
if ((system("cygpath > /dev/null 2>&1") >> 8) != 1){
|
||||
die "Could not execute 'cygpath': $!";
|
||||
}
|
||||
eval 'sub IS_CYGWIN { 1 }';
|
||||
}
|
||||
else {
|
||||
eval 'sub IS_CYGWIN { 0 }';
|
||||
}
|
||||
if ($^O eq "MSWin32") {
|
||||
eval 'sub IS_WIN32PERL { 1 }';
|
||||
}
|
||||
else {
|
||||
eval 'sub IS_WIN32PERL { 0 }';
|
||||
}
|
||||
}
|
||||
|
||||
BEGIN {
|
||||
if (IS_CYGWIN or IS_WIN32PERL) {
|
||||
eval 'sub IS_WINDOWS { 1 }';
|
||||
}
|
||||
else {
|
||||
eval 'sub IS_WINDOWS { 0 }';
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
#
|
||||
# native_path
|
||||
# Convert from path format used by perl to the underlying
|
||||
# operating systems format
|
||||
#
|
||||
# NOTE
|
||||
# Used when running windows binaries (that expect windows paths)
|
||||
# in cygwin perl (that uses unix paths)
|
||||
#
|
||||
|
||||
use Memoize;
|
||||
if (!IS_WIN32PERL){
|
||||
memoize('mixed_path');
|
||||
memoize('native_path');
|
||||
memoize('posix_path');
|
||||
}
|
||||
|
||||
sub mixed_path {
|
||||
my ($path)= @_;
|
||||
if (IS_CYGWIN){
|
||||
return unless defined $path;
|
||||
my $cmd= "cygpath -m $path";
|
||||
$path= `$cmd` or
|
||||
print "Failed to run: '$cmd', $!\n";
|
||||
chomp $path;
|
||||
}
|
||||
return $path;
|
||||
}
|
||||
|
||||
sub native_path {
|
||||
my ($path)= @_;
|
||||
$path=~ s/\//\\/g
|
||||
if (IS_CYGWIN or IS_WIN32PERL);
|
||||
return $path;
|
||||
}
|
||||
|
||||
sub posix_path {
|
||||
my ($path)= @_;
|
||||
if (IS_CYGWIN){
|
||||
return unless defined $path;
|
||||
$path= `cygpath $path`;
|
||||
chomp $path;
|
||||
}
|
||||
return $path;
|
||||
}
|
||||
|
||||
use File::Temp qw /tempdir/;
|
||||
|
||||
sub check_socket_path_length {
|
||||
my ($path)= @_;
|
||||
|
||||
return 0 if IS_WINDOWS;
|
||||
|
||||
require IO::Socket::UNIX;
|
||||
|
||||
my $truncated= 1; # Be negative
|
||||
|
||||
# Create a tempfile name with same length as "path"
|
||||
my $tmpdir = tempdir( CLEANUP => 0);
|
||||
my $len = length($path) - length($tmpdir);
|
||||
my $testfile = $tmpdir . "x" x ($len > 0 ? $len : 1);
|
||||
my $sock;
|
||||
eval {
|
||||
$sock= new IO::Socket::UNIX
|
||||
(
|
||||
Local => $testfile,
|
||||
Listen => 1,
|
||||
);
|
||||
|
||||
die "Could not create UNIX domain socket: $!"
|
||||
unless defined $sock;
|
||||
|
||||
die "UNIX domain socket patch was truncated"
|
||||
unless ($testfile eq $sock->hostpath());
|
||||
|
||||
$truncated= 0; # Yes, it worked!
|
||||
|
||||
};
|
||||
#print "check_socket_path_length, failed: ", $@, '\n' if ($@);
|
||||
|
||||
$sock= undef; # Close socket
|
||||
unlink($testfile); # Remove the physical file
|
||||
rmdir($tmpdir); # Remove the tempdir
|
||||
return $truncated;
|
||||
}
|
||||
|
||||
|
||||
sub process_alive {
|
||||
my ($pid)= @_;
|
||||
die "usage: process_alive(pid)" unless $pid;
|
||||
|
||||
return kill(0, $pid) unless IS_WINDOWS;
|
||||
|
||||
my @list= split(/,/, `tasklist /FI "PID eq $pid" /NH /FO CSV`);
|
||||
my $ret_pid= eval($list[1]);
|
||||
return ($ret_pid == $pid);
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
580
mysql-test/lib/My/SafeProcess.pm
Normal file
580
mysql-test/lib/My/SafeProcess.pm
Normal file
@ -0,0 +1,580 @@
|
||||
# -*- 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
|
||||
|
||||
package My::SafeProcess;
|
||||
|
||||
#
|
||||
# Class that encapsulates process creation, monitoring and cleanup
|
||||
#
|
||||
# Spawns a monitor process which spawns a new process locally or
|
||||
# remote using subclasses My::Process::Local or My::Process::Remote etc.
|
||||
#
|
||||
# The monitor process runs a simple event loop more or less just
|
||||
# waiting for a reason to zap the process it monitors. Thus the user
|
||||
# of this class does not need to care about process cleanup, it's
|
||||
# handled automatically.
|
||||
#
|
||||
# The monitor process wait for:
|
||||
# - the parent process to close the pipe, in that case it
|
||||
# will zap the "monitored process" and exit
|
||||
# - the "monitored process" to exit, in which case it will exit
|
||||
# itself with same exit code as the "monitored process"
|
||||
# - the parent process to send the "shutdown" signal in wich case
|
||||
# monitor will kill the "monitored process" hard and exit
|
||||
#
|
||||
#
|
||||
# When used it will look something like this:
|
||||
# $> ps
|
||||
# [script.pl]
|
||||
# - [monitor for `mysqld`]
|
||||
# - [mysqld]
|
||||
# - [monitor for `mysqld`]
|
||||
# - [mysqld]
|
||||
# - [monitor for `mysqld`]
|
||||
# - [mysqld]
|
||||
#
|
||||
#
|
||||
|
||||
use strict;
|
||||
use Carp;
|
||||
use POSIX qw(WNOHANG);
|
||||
|
||||
use My::SafeProcess::Base;
|
||||
use base 'My::SafeProcess::Base';
|
||||
|
||||
use My::Find;
|
||||
use My::Platform;
|
||||
|
||||
my %running;
|
||||
my $_verbose= 0;
|
||||
|
||||
END {
|
||||
# Kill any children still running
|
||||
for my $proc (values %running){
|
||||
if ( $proc->is_child($$) ){
|
||||
#print "Killing: $proc\n";
|
||||
if ($proc->wait_one(0)){
|
||||
$proc->kill();
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub is_child {
|
||||
my ($self, $parent_pid)= @_;
|
||||
croak "usage: \$safe_proc->is_child()" unless (@_ == 2 and ref $self);
|
||||
return ($self->{PARENT} == $parent_pid);
|
||||
}
|
||||
|
||||
|
||||
# Find the safe process binary or script
|
||||
my @safe_process_cmd;
|
||||
my $safe_kill;
|
||||
if (IS_WIN32PERL or IS_CYGWIN){
|
||||
# Use my_safe_process.exe
|
||||
my $exe= my_find_bin(".", ["lib/My/SafeProcess", "My/SafeProcess"],
|
||||
"my_safe_process");
|
||||
push(@safe_process_cmd, $exe);
|
||||
|
||||
# Use my_safe_kill.exe
|
||||
$safe_kill= my_find_bin(".", "lib/My/SafeProcess", "my_safe_kill");
|
||||
}
|
||||
else
|
||||
{
|
||||
# Use my_safe_process
|
||||
my $exe= my_find_bin(".", ["lib/My/SafeProcess", "My/SafeProcess"],
|
||||
"my_safe_process");
|
||||
push(@safe_process_cmd, $exe);
|
||||
}
|
||||
|
||||
|
||||
sub new {
|
||||
my $class= shift;
|
||||
|
||||
my %opts=
|
||||
(
|
||||
verbose => 0,
|
||||
@_
|
||||
);
|
||||
|
||||
my $path = delete($opts{'path'}) or croak "path required @_";
|
||||
my $args = delete($opts{'args'}) or croak "args required @_";
|
||||
my $input = delete($opts{'input'});
|
||||
my $output = delete($opts{'output'});
|
||||
my $error = delete($opts{'error'});
|
||||
my $verbose = delete($opts{'verbose'});
|
||||
my $host = delete($opts{'host'});
|
||||
my $shutdown = delete($opts{'shutdown'});
|
||||
my $user_data= delete($opts{'user_data'});
|
||||
|
||||
# if (defined $host) {
|
||||
# $safe_script= "lib/My/SafeProcess/safe_process_cpcd.pl";
|
||||
# }
|
||||
|
||||
if (IS_CYGWIN){
|
||||
$path= mixed_path($path);
|
||||
$input= mixed_path($input);
|
||||
$output= mixed_path($output);
|
||||
$error= mixed_path($error);
|
||||
}
|
||||
|
||||
my @safe_args;
|
||||
my ($safe_path, $safe_script)= @safe_process_cmd;
|
||||
push(@safe_args, $safe_script) if defined $safe_script;
|
||||
|
||||
push(@safe_args, "--verbose") if $verbose > 0;
|
||||
|
||||
# Point the safe_process at the right parent if running on cygwin
|
||||
push(@safe_args, "--parent-pid=".Cygwin::pid_to_winpid($$)) if IS_CYGWIN;
|
||||
|
||||
push(@safe_args, "--");
|
||||
push(@safe_args, $path); # The program safe_process should execute
|
||||
push(@safe_args, @$$args);
|
||||
|
||||
print "### safe_path: ", $safe_path, " ", join(" ", @safe_args), "\n"
|
||||
if $verbose > 1;
|
||||
|
||||
my $pid= create_process(
|
||||
path => $safe_path,
|
||||
input => $input,
|
||||
output => $output,
|
||||
error => $error,
|
||||
append => $opts{append},
|
||||
args => \@safe_args,
|
||||
);
|
||||
|
||||
my $name = delete($opts{'name'}) || "SafeProcess$pid";
|
||||
my $proc= bless
|
||||
({
|
||||
SAFE_PID => $pid,
|
||||
SAFE_WINPID => $pid, # Inidicates this is always a real process
|
||||
SAFE_NAME => $name,
|
||||
SAFE_SHUTDOWN => $shutdown,
|
||||
PARENT => $$,
|
||||
SAFE_USER_DATA => $user_data,
|
||||
}, $class);
|
||||
|
||||
# Put the new process in list of running
|
||||
$running{$pid}= $proc;
|
||||
return $proc;
|
||||
|
||||
}
|
||||
|
||||
|
||||
sub run {
|
||||
my $proc= new(@_);
|
||||
$proc->wait_one();
|
||||
return $proc->exit_status();
|
||||
}
|
||||
|
||||
#
|
||||
# Start a process that returns after "duration" seconds
|
||||
# or when it's parent process does not exist anymore
|
||||
#
|
||||
sub timer {
|
||||
my $class= shift;
|
||||
my $duration= shift or croak "duration required";
|
||||
my $parent_pid= $$;
|
||||
|
||||
my $pid= My::SafeProcess::Base::_safe_fork();
|
||||
if ($pid){
|
||||
# Parent
|
||||
my $proc= bless
|
||||
({
|
||||
SAFE_PID => $pid,
|
||||
SAFE_NAME => "timer",
|
||||
PARENT => $$,
|
||||
}, $class);
|
||||
|
||||
# Put the new process in list of running
|
||||
$running{$pid}= $proc;
|
||||
return $proc;
|
||||
}
|
||||
|
||||
# Child, install signal handlers and sleep for "duration"
|
||||
$SIG{INT}= 'IGNORE';
|
||||
|
||||
$SIG{TERM}= sub {
|
||||
#print STDERR "timer $$: woken up, exiting!\n";
|
||||
exit(0);
|
||||
};
|
||||
|
||||
$0= "safe_timer($duration)";
|
||||
|
||||
if (IS_WIN32PERL){
|
||||
# Just a thread in same process
|
||||
sleep($duration);
|
||||
print STDERR "timer $$: expired after $duration seconds\n";
|
||||
exit(0);
|
||||
}
|
||||
|
||||
my $count_down= $duration;
|
||||
while($count_down--){
|
||||
|
||||
# Check that parent is still alive
|
||||
if (kill(0, $parent_pid) == 0){
|
||||
#print STDERR "timer $$: parent gone, exiting!\n";
|
||||
exit(0);
|
||||
}
|
||||
|
||||
sleep(1);
|
||||
}
|
||||
print STDERR "timer $$: expired after $duration seconds\n";
|
||||
exit(0);
|
||||
}
|
||||
|
||||
|
||||
#
|
||||
# Shutdown process nicely, and wait for shutdown_timeout seconds
|
||||
# If processes hasn't shutdown, kill them hard and wait for return
|
||||
#
|
||||
sub shutdown {
|
||||
my $shutdown_timeout= shift;
|
||||
my @processes= @_;
|
||||
_verbose("shutdown, timeout: $shutdown_timeout, @processes");
|
||||
|
||||
return if (@processes == 0);
|
||||
|
||||
# Call shutdown function if process has one, else
|
||||
# use kill
|
||||
foreach my $proc (@processes){
|
||||
_verbose(" proc: $proc");
|
||||
my $shutdown= $proc->{SAFE_SHUTDOWN};
|
||||
if ($shutdown_timeout > 0 and defined $shutdown){
|
||||
$shutdown->();
|
||||
$proc->{WAS_SHUTDOWN}= 1;
|
||||
}
|
||||
else {
|
||||
$proc->start_kill();
|
||||
}
|
||||
}
|
||||
|
||||
my @kill_processes= ();
|
||||
|
||||
# Wait max shutdown_timeout seconds for those process
|
||||
# that has been shutdown
|
||||
foreach my $proc (@processes){
|
||||
next unless $proc->{WAS_SHUTDOWN};
|
||||
my $ret= $proc->wait_one($shutdown_timeout);
|
||||
if ($ret != 0) {
|
||||
push(@kill_processes, $proc);
|
||||
}
|
||||
# Only wait for the first process with shutdown timeout
|
||||
$shutdown_timeout= 0;
|
||||
}
|
||||
|
||||
# Wait infinitely for those process
|
||||
# that has been killed
|
||||
foreach my $proc (@processes){
|
||||
next if $proc->{WAS_SHUTDOWN};
|
||||
my $ret= $proc->wait_one(undef);
|
||||
if ($ret != 0) {
|
||||
warn "Wait for killed process failed!";
|
||||
push(@kill_processes, $proc);
|
||||
# Try one more time, best option...
|
||||
}
|
||||
}
|
||||
|
||||
# Return if all servers has exited
|
||||
return if (@kill_processes == 0);
|
||||
|
||||
foreach my $proc (@kill_processes){
|
||||
$proc->start_kill();
|
||||
}
|
||||
|
||||
foreach my $proc (@kill_processes){
|
||||
$proc->wait_one(undef);
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
|
||||
sub _winpid ($) {
|
||||
my ($pid)= @_;
|
||||
|
||||
# In win32 perl, the pid is already the winpid
|
||||
return $pid unless IS_CYGWIN;
|
||||
|
||||
# In cygwin, the pid is the pseudo process ->
|
||||
# get the real winpid of my_safe_process
|
||||
return Cygwin::pid_to_winpid($pid);
|
||||
}
|
||||
|
||||
|
||||
#
|
||||
# Tell the process to die as fast as possible
|
||||
#
|
||||
sub start_kill {
|
||||
my ($self)= @_;
|
||||
croak "usage: \$safe_proc->start_kill()" unless (@_ == 1 and ref $self);
|
||||
_verbose("start_kill: $self");
|
||||
my $ret= 1;
|
||||
|
||||
my $pid= $self->{SAFE_PID};
|
||||
die "INTERNAL ERROR: no pid" unless defined $pid;
|
||||
|
||||
if (IS_WINDOWS and defined $self->{SAFE_WINPID})
|
||||
{
|
||||
die "INTERNAL ERROR: no safe_kill" unless defined $safe_kill;
|
||||
|
||||
my $winpid= _winpid($pid);
|
||||
$ret= system($safe_kill, $winpid) >> 8;
|
||||
|
||||
if ($ret == 3){
|
||||
print "Couldn't open the winpid: $winpid ",
|
||||
"for pid: $pid, try one more time\n";
|
||||
sleep(1);
|
||||
$winpid= _winpid($pid);
|
||||
$ret= system($safe_kill, $winpid) >> 8;
|
||||
print "Couldn't open the winpid: $winpid ",
|
||||
"for pid: $pid, continue and see what happens...\n";
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
$pid= $self->{SAFE_PID};
|
||||
die "Can't kill not started process" unless defined $pid;
|
||||
$ret= kill("TERM", $pid);
|
||||
}
|
||||
|
||||
return $ret;
|
||||
}
|
||||
|
||||
|
||||
sub dump_core {
|
||||
my ($self)= @_;
|
||||
return if IS_WINDOWS;
|
||||
my $pid= $self->{SAFE_PID};
|
||||
die "Can't cet core from not started process" unless defined $pid;
|
||||
_verbose("Sending ABRT to $self");
|
||||
kill ("ABRT", $pid);
|
||||
return 1;
|
||||
}
|
||||
|
||||
|
||||
#
|
||||
# Kill the process as fast as possible
|
||||
# and wait for it to return
|
||||
#
|
||||
sub kill {
|
||||
my ($self)= @_;
|
||||
croak "usage: \$safe_proc->kill()" unless (@_ == 1 and ref $self);
|
||||
|
||||
$self->start_kill();
|
||||
$self->wait_one();
|
||||
return 1;
|
||||
}
|
||||
|
||||
|
||||
sub _collect {
|
||||
my ($self)= @_;
|
||||
|
||||
$self->{EXIT_STATUS}= $?;
|
||||
_verbose("_collect: $self");
|
||||
|
||||
# Take the process out of running list
|
||||
my $pid= $self->{SAFE_PID};
|
||||
die unless delete($running{$pid});
|
||||
}
|
||||
|
||||
|
||||
# Wait for process to exit
|
||||
# optionally with a timeout
|
||||
#
|
||||
# timeout
|
||||
# undef -> wait blocking infinitely
|
||||
# 0 -> just poll with WNOHANG
|
||||
# >0 -> wait blocking for max timeout seconds
|
||||
#
|
||||
# RETURN VALUES
|
||||
# 0 Not running
|
||||
# 1 Still running
|
||||
#
|
||||
sub wait_one {
|
||||
my ($self, $timeout)= @_;
|
||||
croak "usage: \$safe_proc->wait_one([timeout])" unless ref $self;
|
||||
|
||||
_verbose("wait_one $self, $timeout");
|
||||
|
||||
if ( ! defined($self->{SAFE_PID}) ) {
|
||||
# No pid => not running
|
||||
_verbose("No pid => not running");
|
||||
return 0;
|
||||
}
|
||||
|
||||
if ( defined $self->{EXIT_STATUS} ) {
|
||||
# Exit status already set => not running
|
||||
_verbose("Exit status already set => not running");
|
||||
return 0;
|
||||
}
|
||||
|
||||
my $pid= $self->{SAFE_PID};
|
||||
|
||||
my $use_alarm;
|
||||
my $blocking;
|
||||
if (defined $timeout)
|
||||
{
|
||||
if ($timeout == 0)
|
||||
{
|
||||
# 0 -> just poll with WNOHANG
|
||||
$blocking= 0;
|
||||
$use_alarm= 0;
|
||||
}
|
||||
else
|
||||
{
|
||||
# >0 -> wait blocking for max timeout seconds
|
||||
$blocking= 1;
|
||||
$use_alarm= 1;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
# undef -> wait blocking infinitely
|
||||
$blocking= 1;
|
||||
$use_alarm= 0;
|
||||
}
|
||||
#_verbose("blocking: $blocking, use_alarm: $use_alarm");
|
||||
|
||||
my $retpid;
|
||||
eval
|
||||
{
|
||||
# alarm should break the wait
|
||||
local $SIG{ALRM}= sub { die "waitpid timeout"; };
|
||||
|
||||
alarm($timeout) if $use_alarm;
|
||||
|
||||
$retpid= waitpid($pid, $blocking ? 0 : &WNOHANG);
|
||||
|
||||
alarm(0) if $use_alarm;
|
||||
};
|
||||
|
||||
if ($@)
|
||||
{
|
||||
die "Got unexpected: $@" if ($@ !~ /waitpid timeout/);
|
||||
if (!defined $retpid) {
|
||||
# Got timeout
|
||||
_verbose("Got timeout");
|
||||
return 1;
|
||||
}
|
||||
# Got pid _and_ alarm, continue
|
||||
_verbose("Got pid and alarm, continue");
|
||||
}
|
||||
|
||||
if ( $retpid == 0 ) {
|
||||
# 0 => still running
|
||||
_verbose("0 => still running");
|
||||
return 1;
|
||||
}
|
||||
|
||||
if ( not $blocking and $retpid == -1 ) {
|
||||
# still running
|
||||
_verbose("still running");
|
||||
return 1;
|
||||
}
|
||||
|
||||
#warn "wait_one: expected pid $pid but got $retpid"
|
||||
# unless( $retpid == $pid );
|
||||
|
||||
$self->_collect();
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
||||
#
|
||||
# Wait for any process to exit
|
||||
#
|
||||
# Returns a reference to the SafeProcess that
|
||||
# exited or undefined
|
||||
#
|
||||
sub wait_any {
|
||||
my $ret_pid;
|
||||
if (IS_WIN32PERL) {
|
||||
# Can't wait for -1 => use a polling loop
|
||||
do {
|
||||
Win32::Sleep(10); # 10 milli seconds
|
||||
foreach my $pid (keys %running){
|
||||
$ret_pid= waitpid($pid, &WNOHANG);
|
||||
last if $pid == $ret_pid;
|
||||
}
|
||||
} while ($ret_pid == 0);
|
||||
}
|
||||
else
|
||||
{
|
||||
$ret_pid= waitpid(-1, 0);
|
||||
if ($ret_pid <= 0){
|
||||
# No more processes to wait for
|
||||
print STDERR "wait_any, got invalid pid: $ret_pid\n";
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
|
||||
# Look it up in "running" table
|
||||
my $proc= $running{$ret_pid};
|
||||
unless (defined $proc){
|
||||
print STDERR "Could not find pid: $ret_pid in running list\n";
|
||||
print STDERR "running: ". join(", ", keys(%running)). "\n";
|
||||
return undef;
|
||||
}
|
||||
$proc->_collect;
|
||||
return $proc;
|
||||
}
|
||||
|
||||
#
|
||||
# Overload string operator
|
||||
# and fallback to default functions if no
|
||||
# overloaded function is found
|
||||
#
|
||||
use overload
|
||||
'""' => \&self2str,
|
||||
fallback => 1;
|
||||
|
||||
|
||||
#
|
||||
# Return the process as a nicely formatted string
|
||||
#
|
||||
sub self2str {
|
||||
my ($self)= @_;
|
||||
my $pid= $self->{SAFE_PID};
|
||||
my $winpid= $self->{SAFE_WINPID};
|
||||
my $name= $self->{SAFE_NAME};
|
||||
my $exit_status= $self->{EXIT_STATUS};
|
||||
|
||||
my $str= "[$name - pid: $pid";
|
||||
$str.= ", winpid: $winpid" if defined $winpid;
|
||||
$str.= ", exit: $exit_status" if defined $exit_status;
|
||||
$str.= "]";
|
||||
}
|
||||
|
||||
sub _verbose {
|
||||
return unless $_verbose;
|
||||
print STDERR " ## ", @_, "\n";
|
||||
}
|
||||
|
||||
|
||||
sub pid {
|
||||
my ($self)= @_;
|
||||
return $self->{SAFE_PID};
|
||||
}
|
||||
|
||||
sub user_data {
|
||||
my ($self)= @_;
|
||||
return $self->{SAFE_USER_DATA};
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
212
mysql-test/lib/My/SafeProcess/Base.pm
Normal file
212
mysql-test/lib/My/SafeProcess/Base.pm
Normal file
@ -0,0 +1,212 @@
|
||||
# -*- 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;
|
||||
|
||||
package My::SafeProcess::Base;
|
||||
|
||||
#
|
||||
# Utility functions for Process management
|
||||
#
|
||||
|
||||
use Carp;
|
||||
use IO::Pipe;
|
||||
|
||||
use base qw(Exporter);
|
||||
our @EXPORT= qw(create_process);
|
||||
|
||||
|
||||
|
||||
#
|
||||
# safe_fork
|
||||
# Retry a couple of times if fork returns EAGAIN
|
||||
#
|
||||
sub _safe_fork {
|
||||
my $retries= 5;
|
||||
my $pid;
|
||||
|
||||
FORK:
|
||||
{
|
||||
$pid= fork;
|
||||
if ( not defined($pid)) {
|
||||
|
||||
croak("fork failed after: $!") if (!$retries--);
|
||||
|
||||
warn("fork failed sleep 1 second and redo: $!");
|
||||
sleep(1);
|
||||
redo FORK;
|
||||
}
|
||||
}
|
||||
|
||||
return $pid;
|
||||
};
|
||||
|
||||
|
||||
#
|
||||
# Decode exit status
|
||||
#
|
||||
sub exit_status {
|
||||
my $self= shift;
|
||||
my $raw= $self->{EXIT_STATUS};
|
||||
|
||||
croak("Can't call exit_status before process has died")
|
||||
unless defined $raw;
|
||||
|
||||
if ($raw & 127)
|
||||
{
|
||||
# Killed by signal
|
||||
my $signal_num= $raw & 127;
|
||||
my $dumped_core= $raw & 128;
|
||||
return 1; # Return error code
|
||||
}
|
||||
else
|
||||
{
|
||||
# Normal process exit
|
||||
return $raw >> 8;
|
||||
};
|
||||
}
|
||||
|
||||
|
||||
#
|
||||
# Create a new process
|
||||
# Return pid of the new process
|
||||
#
|
||||
sub create_process {
|
||||
my %opts=
|
||||
(
|
||||
@_
|
||||
);
|
||||
|
||||
my $path = delete($opts{'path'}) or die "path required";
|
||||
my $args = delete($opts{'args'}) or die "args required";
|
||||
my $input = delete($opts{'input'});
|
||||
my $output = delete($opts{'output'});
|
||||
my $error = delete($opts{'error'});
|
||||
|
||||
my $open_mode= $opts{append} ? ">>" : ">";
|
||||
|
||||
if ($^O eq "MSWin32"){
|
||||
|
||||
#printf STDERR "stdin %d, stdout %d, stderr %d\n",
|
||||
# fileno STDIN, fileno STDOUT, fileno STDERR;
|
||||
|
||||
# input output redirect
|
||||
my ($oldin, $oldout, $olderr);
|
||||
open $oldin, '<&', \*STDIN or die "Failed to save old stdin: $!";
|
||||
open $oldout, '>&', \*STDOUT or die "Failed to save old stdout: $!";
|
||||
open $olderr, '>&', \*STDERR or die "Failed to save old stderr: $!";
|
||||
|
||||
if ( $input ) {
|
||||
if ( ! open(STDIN, "<", $input) ) {
|
||||
croak("can't redirect STDIN to '$input': $!");
|
||||
}
|
||||
}
|
||||
|
||||
if ( $output ) {
|
||||
if ( ! open(STDOUT, $open_mode, $output) ) {
|
||||
croak("can't redirect STDOUT to '$output': $!");
|
||||
}
|
||||
}
|
||||
|
||||
if ( $error ) {
|
||||
if ( $output eq $error ) {
|
||||
if ( ! open(STDERR, ">&STDOUT") ) {
|
||||
croak("can't dup STDOUT: $!");
|
||||
}
|
||||
}
|
||||
elsif ( ! open(STDERR, $open_mode, $error) ) {
|
||||
croak("can't redirect STDERR to '$error': $!");
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
# Magic use of 'system(1, @args)' to spawn a process
|
||||
# and get a proper Win32 pid
|
||||
unshift (@$args, $path);
|
||||
my $pid= system(1, @$args);
|
||||
if ( $pid == 0 ){
|
||||
print $olderr "create_process failed: $^E\n";
|
||||
die "create_process failed: $^E";
|
||||
}
|
||||
|
||||
# Retore IO redirects
|
||||
open STDERR, '>&', $olderr
|
||||
or croak("unable to reestablish STDERR");
|
||||
open STDOUT, '>&', $oldout
|
||||
or croak("unable to reestablish STDOUT");
|
||||
open STDIN, '<&', $oldin
|
||||
or croak("unable to reestablish STDIN");
|
||||
#printf STDERR "stdin %d, stdout %d, stderr %d\n",
|
||||
# fileno STDIN, fileno STDOUT, fileno STDERR;
|
||||
return $pid;
|
||||
|
||||
}
|
||||
|
||||
local $SIG{PIPE}= sub { print STDERR "Got signal $@\n"; };
|
||||
my $pipe= IO::Pipe->new();
|
||||
my $pid= _safe_fork();
|
||||
if ($pid){
|
||||
# Parent
|
||||
$pipe->reader();
|
||||
my $line= <$pipe>; # Wait for child to say it's ready
|
||||
return $pid;
|
||||
}
|
||||
|
||||
$SIG{INT}= 'DEFAULT';
|
||||
|
||||
# Make this process it's own process group to be able to kill
|
||||
# it and any childs(that hasn't changed group themself)
|
||||
setpgrp(0,0) if $opts{setpgrp};
|
||||
|
||||
if ( $output and !open(STDOUT, $open_mode, $output) ) {
|
||||
croak("can't redirect STDOUT to '$output': $!");
|
||||
}
|
||||
|
||||
if ( $error ) {
|
||||
if ( defined $output and $output eq $error ) {
|
||||
if ( ! open(STDERR, ">&STDOUT") ) {
|
||||
croak("can't dup STDOUT: $!");
|
||||
}
|
||||
}
|
||||
elsif ( ! open(STDERR, $open_mode, $error) ) {
|
||||
croak("can't redirect STDERR to '$error': $!");
|
||||
}
|
||||
}
|
||||
|
||||
if ( $input ) {
|
||||
if ( ! open(STDIN, "<", $input) ) {
|
||||
croak("can't redirect STDIN to '$input': $!");
|
||||
}
|
||||
}
|
||||
|
||||
# Tell parent to continue
|
||||
$pipe->writer();
|
||||
print $pipe "ready\n";
|
||||
|
||||
if ( !exec($path, @$args) ){
|
||||
croak("Failed to exec '$path': $!");
|
||||
}
|
||||
|
||||
croak("Should never come here");
|
||||
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
17
mysql-test/lib/My/SafeProcess/CMakeLists.txt
Normal file
17
mysql-test/lib/My/SafeProcess/CMakeLists.txt
Normal file
@ -0,0 +1,17 @@
|
||||
# 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
|
||||
|
||||
ADD_EXECUTABLE(my_safe_process safe_process_win.cc)
|
||||
ADD_EXECUTABLE(my_safe_kill safe_kill_win.cc)
|
||||
28
mysql-test/lib/My/SafeProcess/Makefile.am
Normal file
28
mysql-test/lib/My/SafeProcess/Makefile.am
Normal file
@ -0,0 +1,28 @@
|
||||
# Copyright (C) 2000-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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
safedir = $(prefix)/mysql-test/lib/My/SafeProcess
|
||||
#nobase_bin_PROGRAMS = ...
|
||||
safe_PROGRAMS = my_safe_process
|
||||
|
||||
my_safe_process_SOURCES = safe_process.cc
|
||||
|
||||
EXTRA_DIST = safe_kill_win.cc \
|
||||
safe_process_win.cc \
|
||||
CMakeLists.txt
|
||||
|
||||
|
||||
# Don't update the files from bitkeeper
|
||||
%::SCCS/s.%
|
||||
85
mysql-test/lib/My/SafeProcess/safe_kill_win.cc
Executable file
85
mysql-test/lib/My/SafeProcess/safe_kill_win.cc
Executable file
@ -0,0 +1,85 @@
|
||||
/* 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA */
|
||||
|
||||
|
||||
/*
|
||||
Utility program used to signal a safe_process it's time to shutdown
|
||||
|
||||
Usage:
|
||||
safe_kill <pid>
|
||||
*/
|
||||
|
||||
#include <windows.h>
|
||||
#include <stdio.h>
|
||||
#include <signal.h>
|
||||
|
||||
int main(int argc, const char** argv )
|
||||
{
|
||||
DWORD pid= -1;
|
||||
HANDLE shutdown_event;
|
||||
char safe_process_name[32]= {0};
|
||||
int retry_open_event= 100;
|
||||
/* Ignore any signals */
|
||||
signal(SIGINT, SIG_IGN);
|
||||
signal(SIGBREAK, SIG_IGN);
|
||||
signal(SIGTERM, SIG_IGN);
|
||||
|
||||
if (argc != 2) {
|
||||
fprintf(stderr, "safe_kill <pid>\n");
|
||||
exit(2);
|
||||
}
|
||||
pid= atoi(argv[1]);
|
||||
|
||||
_snprintf(safe_process_name, sizeof(safe_process_name),
|
||||
"safe_process[%d]", pid);
|
||||
|
||||
/* Open the event to signal */
|
||||
while ((shutdown_event=
|
||||
OpenEvent(EVENT_MODIFY_STATE, FALSE, safe_process_name)) == NULL)
|
||||
{
|
||||
/*
|
||||
Check if the process is alive, otherwise there is really
|
||||
no idea to retry the open of the event
|
||||
*/
|
||||
HANDLE process;
|
||||
if ((process= OpenProcess(SYNCHRONIZE, FALSE, pid)) == NULL)
|
||||
{
|
||||
fprintf(stderr, "Could not open event or process %d, error: %d\n",
|
||||
pid, GetLastError());
|
||||
exit(3);
|
||||
}
|
||||
CloseHandle(process);
|
||||
|
||||
if (retry_open_event--)
|
||||
Sleep(100);
|
||||
else
|
||||
{
|
||||
fprintf(stderr, "Failed to open shutdown_event '%s', error: %d\n",
|
||||
safe_process_name, GetLastError());
|
||||
exit(3);
|
||||
}
|
||||
}
|
||||
|
||||
if(SetEvent(shutdown_event) == 0)
|
||||
{
|
||||
fprintf(stderr, "Failed to signal shutdown_event '%s', error: %d\n",
|
||||
safe_process_name, GetLastError());
|
||||
CloseHandle(shutdown_event);
|
||||
exit(4);
|
||||
}
|
||||
CloseHandle(shutdown_event);
|
||||
exit(0);
|
||||
}
|
||||
|
||||
277
mysql-test/lib/My/SafeProcess/safe_process.cc
Normal file
277
mysql-test/lib/My/SafeProcess/safe_process.cc
Normal file
@ -0,0 +1,277 @@
|
||||
/* Copyright (C) 2008 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA */
|
||||
|
||||
|
||||
/*
|
||||
Utility program that encapsulates process creation, monitoring
|
||||
and bulletproof process cleanup
|
||||
|
||||
Usage:
|
||||
safe_process [options to safe_process] -- progname arg1 ... argn
|
||||
|
||||
To safeguard mysqld you would invoke safe_process with a few options
|
||||
for safe_process itself followed by a double dash to indicate start
|
||||
of the command line for the program you really want to start
|
||||
|
||||
$> safe_process --output=output.log -- mysqld --datadir=var/data1 ...
|
||||
|
||||
This would redirect output to output.log and then start mysqld,
|
||||
once it has done that it will continue to monitor the child as well
|
||||
as the parent.
|
||||
|
||||
The safe_process then checks the follwing things:
|
||||
1. Child exits, propagate the childs return code to the parent
|
||||
by exiting with the same return code as the child.
|
||||
|
||||
2. Parent dies, immediately kill the child and exit, thus the
|
||||
parent does not need to properly cleanup any child, it is handled
|
||||
automatically.
|
||||
|
||||
3. Signal's recieced by the process will trigger same action as 2)
|
||||
|
||||
*/
|
||||
|
||||
#include <sys/types.h>
|
||||
#include <sys/wait.h>
|
||||
#include <unistd.h>
|
||||
#include <stdarg.h>
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <signal.h>
|
||||
#include <string.h>
|
||||
#include <errno.h>
|
||||
|
||||
int verbose= 0;
|
||||
int terminated= 0;
|
||||
pid_t child_pid= -1;
|
||||
char safe_process_name[32]= {0};
|
||||
|
||||
|
||||
static void message(const char* fmt, ...)
|
||||
{
|
||||
if (!verbose)
|
||||
return;
|
||||
va_list args;
|
||||
fprintf(stderr, "%s: ", safe_process_name);
|
||||
va_start(args, fmt);
|
||||
vfprintf(stderr, fmt, args);
|
||||
fprintf(stderr, "\n");
|
||||
va_end(args);
|
||||
fflush(stderr);
|
||||
}
|
||||
|
||||
|
||||
static void die(const char* fmt, ...)
|
||||
{
|
||||
va_list args;
|
||||
fprintf(stderr, "%s: FATAL ERROR, ", safe_process_name);
|
||||
va_start(args, fmt);
|
||||
vfprintf(stderr, fmt, args);
|
||||
fprintf(stderr, "\n");
|
||||
va_end(args);
|
||||
if (int last_err= errno)
|
||||
fprintf(stderr, "error: %d, %s\n", last_err, strerror(last_err));
|
||||
exit(1);
|
||||
}
|
||||
|
||||
|
||||
static void kill_child (void)
|
||||
{
|
||||
int status= 0;
|
||||
|
||||
message("Killing child: %d", child_pid);
|
||||
// Terminate whole process group
|
||||
kill(-child_pid, SIGKILL);
|
||||
|
||||
pid_t ret_pid= waitpid(child_pid, &status, 0);
|
||||
if (ret_pid == child_pid)
|
||||
{
|
||||
int exit_code= 1;
|
||||
if (WIFEXITED(status))
|
||||
{
|
||||
// Process has exited, collect return status
|
||||
exit_code= WEXITSTATUS(status);
|
||||
message("Child exit: %d", exit_code);
|
||||
// Exit with exit status of the child
|
||||
exit(exit_code);
|
||||
}
|
||||
|
||||
if (WIFSIGNALED(status))
|
||||
message("Child killed by signal: %d", WTERMSIG(status));
|
||||
|
||||
exit(exit_code);
|
||||
}
|
||||
exit(1);
|
||||
}
|
||||
|
||||
|
||||
static void handle_abort (int sig)
|
||||
{
|
||||
message("Got signal %d, child_pid: %d, sending ABRT", sig, child_pid);
|
||||
|
||||
if (child_pid > 0) {
|
||||
kill (-child_pid, SIGABRT); // Don't wait for it to terminate
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
static void handle_signal (int sig)
|
||||
{
|
||||
message("Got signal %d, child_pid: %d", sig, child_pid);
|
||||
terminated= 1;
|
||||
|
||||
if (child_pid > 0)
|
||||
kill_child();
|
||||
|
||||
// Ignore further signals
|
||||
signal(SIGTERM, SIG_IGN);
|
||||
signal(SIGINT, SIG_IGN);
|
||||
|
||||
// Continune execution, allow the child to be started and
|
||||
// finally terminated by monitor loop
|
||||
}
|
||||
|
||||
|
||||
int main(int argc, char* const argv[] )
|
||||
{
|
||||
char* const* child_argv= 0;
|
||||
pid_t own_pid= getpid();
|
||||
pid_t parent_pid= getppid();
|
||||
|
||||
/* Install signal handlers */
|
||||
signal(SIGTERM, handle_signal);
|
||||
signal(SIGINT, handle_signal);
|
||||
signal(SIGCHLD, handle_signal);
|
||||
signal(SIGABRT, handle_abort);
|
||||
|
||||
sprintf(safe_process_name, "safe_process[%d]", own_pid);
|
||||
|
||||
message("Started");
|
||||
|
||||
/* Parse arguments */
|
||||
for (int i= 1; i < argc; i++) {
|
||||
const char* arg= argv[i];
|
||||
if (strcmp(arg, "--") == 0 && strlen(arg) == 2) {
|
||||
/* Got the "--" delimiter */
|
||||
if (i >= argc)
|
||||
die("No real args -> nothing to do");
|
||||
child_argv= &argv[i+1];
|
||||
break;
|
||||
} else {
|
||||
if ( strcmp(arg, "--verbose") == 0 )
|
||||
verbose++;
|
||||
else if ( strncmp(arg, "--parent-pid", 10) == 0 )
|
||||
{
|
||||
/* Override parent_pid with a value provided by user */
|
||||
const char* start;
|
||||
if ((start= strstr(arg, "=")) == NULL)
|
||||
die("Could not find start of option value in '%s'", arg);
|
||||
start++; /* Step past = */
|
||||
if ((parent_pid= atoi(start)) == 0)
|
||||
die("Invalid value '%s' passed to --parent-id", start);
|
||||
}
|
||||
else
|
||||
die("Unknown option: %s", arg);
|
||||
}
|
||||
}
|
||||
if (!child_argv || *child_argv == 0)
|
||||
die("nothing to do");
|
||||
|
||||
message("parent_pid: %d", parent_pid);
|
||||
if (parent_pid == own_pid)
|
||||
die("parent_pid is equal to own pid!");
|
||||
|
||||
char buf;
|
||||
int pfd[2];
|
||||
if (pipe(pfd) == -1)
|
||||
die("Failed to create pipe");
|
||||
|
||||
/* Create the child process */
|
||||
while((child_pid= fork()) == -1)
|
||||
{
|
||||
message("fork failed");
|
||||
sleep(1);
|
||||
}
|
||||
|
||||
if (child_pid == 0)
|
||||
{
|
||||
close(pfd[0]); // Close unused read end
|
||||
|
||||
// Use default signal handlers in child
|
||||
signal(SIGTERM, SIG_DFL);
|
||||
signal(SIGINT, SIG_DFL);
|
||||
signal(SIGCHLD, SIG_DFL);
|
||||
|
||||
// Make this process it's own process group to be able to kill
|
||||
// it and any childs(that hasn't changed group themself)
|
||||
setpgid(0, 0);
|
||||
|
||||
// Signal that child is ready
|
||||
buf= 37;
|
||||
write(pfd[1], &buf, 1);
|
||||
// Close write end
|
||||
close(pfd[1]);
|
||||
|
||||
if (execvp(child_argv[0], child_argv) < 0)
|
||||
die("Failed to exec child");
|
||||
}
|
||||
|
||||
close(pfd[1]); // Close unused write end
|
||||
|
||||
// Wait for child to signal it's ready
|
||||
read(pfd[0], &buf, 1);
|
||||
if(buf != 37)
|
||||
die("Didn't get 37 from pipe");
|
||||
close(pfd[0]); // Close read end
|
||||
|
||||
/* Monitor loop */
|
||||
message("Started child %d, terminated: %d", child_pid, terminated);
|
||||
|
||||
while(!terminated)
|
||||
{
|
||||
// Check if parent is still alive
|
||||
if (kill(parent_pid, 0) != 0){
|
||||
message("Parent is not alive anymore");
|
||||
break;
|
||||
}
|
||||
|
||||
// Check if child has exited, normally this will be
|
||||
// detected immediately with SIGCHLD handler
|
||||
int status= 0;
|
||||
pid_t ret_pid= waitpid(child_pid, &status, WNOHANG);
|
||||
if (ret_pid == child_pid)
|
||||
{
|
||||
int ret_code= 2;
|
||||
if (WIFEXITED(status))
|
||||
{
|
||||
// Process has exited, collect return status
|
||||
int ret_code= WEXITSTATUS(status);
|
||||
message("Child exit: %d", ret_code);
|
||||
// Exit with exit status of the child
|
||||
exit(ret_code);
|
||||
}
|
||||
|
||||
if (WIFSIGNALED(status))
|
||||
message("Child killed by signal: %d", WTERMSIG(status));
|
||||
|
||||
exit(ret_code);
|
||||
}
|
||||
sleep(1);
|
||||
}
|
||||
kill_child();
|
||||
|
||||
exit(1);
|
||||
}
|
||||
|
||||
151
mysql-test/lib/My/SafeProcess/safe_process.pl
Normal file
151
mysql-test/lib/My/SafeProcess/safe_process.pl
Normal file
@ -0,0 +1,151 @@
|
||||
#!/usr/bin/perl
|
||||
# -*- cperl -*-
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use lib 'lib';
|
||||
use My::SafeProcess::Base;
|
||||
use POSIX qw(WNOHANG);
|
||||
|
||||
###########################################################################
|
||||
# Util functions
|
||||
###########################################################################
|
||||
|
||||
#
|
||||
#Print message to stderr
|
||||
#
|
||||
my $verbose= 0;
|
||||
sub message {
|
||||
if ($verbose > 0){
|
||||
use Time::localtime;
|
||||
my $tm= localtime();
|
||||
my $timestamp= sprintf("%02d%02d%02d %2d:%02d:%02d",
|
||||
$tm->year % 100, $tm->mon+1, $tm->mday,
|
||||
$tm->hour, $tm->min, $tm->sec);
|
||||
print STDERR $timestamp, " monitor[$$]: ", @_, "\n";
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
###########################################################################
|
||||
# Main program
|
||||
###########################################################################
|
||||
|
||||
my $terminated= 0;
|
||||
|
||||
# Protect against being killed in the middle
|
||||
# of child creation, just set the terminated flag
|
||||
# to make sure the child will be killed off
|
||||
# when program is ready to do that
|
||||
$SIG{TERM}= sub { message("!Got signal @_"); $terminated= 1; };
|
||||
$SIG{INT}= sub { message("!Got signal @_"); $terminated= 1; };
|
||||
|
||||
my $parent_pid= getppid();
|
||||
|
||||
my $found_double_dash= 0;
|
||||
while (my $arg= shift(@ARGV)){
|
||||
|
||||
if ($arg =~ /^--$/){
|
||||
$found_double_dash= 1;
|
||||
last;
|
||||
}
|
||||
elsif ($arg =~ /^--verbose$/){
|
||||
$verbose= 1;
|
||||
}
|
||||
else {
|
||||
die "Unknown option: $arg";
|
||||
}
|
||||
}
|
||||
|
||||
my $path= shift(@ARGV); # Executable
|
||||
|
||||
die "usage:\n" .
|
||||
" safe_process.pl [opts] -- <path> [<args> [...<args_n>]]"
|
||||
unless defined $path || $found_double_dash;
|
||||
|
||||
|
||||
message("started");
|
||||
#message("path: '$path'");
|
||||
message("parent: $parent_pid");
|
||||
|
||||
# Start process to monitor
|
||||
my $child_pid=
|
||||
create_process(
|
||||
path => $path,
|
||||
args => \@ARGV,
|
||||
setpgrp => 1,
|
||||
);
|
||||
message("Started child $child_pid");
|
||||
|
||||
eval {
|
||||
sub handle_signal {
|
||||
$terminated= 1;
|
||||
message("Got signal @_");
|
||||
|
||||
# Ignore all signals
|
||||
foreach my $name (keys %SIG){
|
||||
$SIG{$name}= 'IGNORE';
|
||||
}
|
||||
|
||||
die "signaled\n";
|
||||
};
|
||||
local $SIG{TERM}= \&handle_signal;
|
||||
local $SIG{INT}= \&handle_signal;
|
||||
local $SIG{CHLD}= sub {
|
||||
message("Got signal @_");
|
||||
kill(9, -$child_pid);
|
||||
my $ret= waitpid($child_pid, 0);
|
||||
if ($? & 127){
|
||||
exit(65); # Killed by signal
|
||||
}
|
||||
exit($? >> 8);
|
||||
};
|
||||
|
||||
# Monitoring loop
|
||||
while(!$terminated) {
|
||||
|
||||
# Check if parent is still alive
|
||||
if (kill(0, $parent_pid) < 1){
|
||||
message("Parent is not alive anymore");
|
||||
last;
|
||||
}
|
||||
|
||||
# Wait for child to terminate but wakeup every
|
||||
# second to also check that parent is still alive
|
||||
my $ret_pid;
|
||||
$ret_pid= waitpid($child_pid, &WNOHANG);
|
||||
if ($ret_pid == $child_pid) {
|
||||
# Process has exited, collect return status
|
||||
my $ret_code= $? >> 8;
|
||||
message("Child exit: $ret_code");
|
||||
# Exit with exit status of the child
|
||||
exit ($ret_code);
|
||||
}
|
||||
sleep(1);
|
||||
}
|
||||
};
|
||||
if ( $@ ) {
|
||||
# The monitoring loop should have been
|
||||
# broken by handle_signal
|
||||
warn "Unexpected: $@" unless ( $@ =~ /signaled/ );
|
||||
}
|
||||
|
||||
# Use negative pid in order to kill the whole
|
||||
# process group
|
||||
#
|
||||
my $ret= kill(9, -$child_pid);
|
||||
message("Killed child: $child_pid, ret: $ret");
|
||||
if ($ret > 0) {
|
||||
message("Killed child: $child_pid");
|
||||
# Wait blocking for the child to return
|
||||
my $ret_pid= waitpid($child_pid, 0);
|
||||
if ($ret_pid != $child_pid){
|
||||
message("unexpected pid $ret_pid returned from waitpid($child_pid)");
|
||||
}
|
||||
}
|
||||
|
||||
message("DONE!");
|
||||
exit (1);
|
||||
|
||||
|
||||
316
mysql-test/lib/My/SafeProcess/safe_process_win.cc
Executable file
316
mysql-test/lib/My/SafeProcess/safe_process_win.cc
Executable file
@ -0,0 +1,316 @@
|
||||
/* 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA */
|
||||
|
||||
|
||||
/*
|
||||
Utility program that encapsulates process creation, monitoring
|
||||
and bulletproof process cleanup
|
||||
|
||||
Usage:
|
||||
safe_process [options to safe_process] -- progname arg1 ... argn
|
||||
|
||||
To safeguard mysqld you would invoke safe_process with a few options
|
||||
for safe_process itself followed by a double dash to indicate start
|
||||
of the command line for the program you really want to start
|
||||
|
||||
$> safe_process --output=output.log -- mysqld --datadir=var/data1 ...
|
||||
|
||||
This would redirect output to output.log and then start mysqld,
|
||||
once it has done that it will continue to monitor the child as well
|
||||
as the parent.
|
||||
|
||||
The safe_process then checks the follwing things:
|
||||
1. Child exits, propagate the childs return code to the parent
|
||||
by exiting with the same return code as the child.
|
||||
|
||||
2. Parent dies, immediately kill the child and exit, thus the
|
||||
parent does not need to properly cleanup any child, it is handled
|
||||
automatically.
|
||||
|
||||
3. Signal's recieced by the process will trigger same action as 2)
|
||||
|
||||
4. The named event "safe_process[pid]" can be signaled and will
|
||||
trigger same action as 2)
|
||||
|
||||
WARNING! Be careful when using ProcessExplorer, since it will open
|
||||
a handle to each process(and maybe also the Job), the process
|
||||
spawned by safe_process will not be closed off when safe_process
|
||||
is killed.
|
||||
*/
|
||||
|
||||
/* Requires Windows 2000 or higher */
|
||||
#define _WIN32_WINNT 0x0500
|
||||
|
||||
#include <windows.h>
|
||||
#include <stdio.h>
|
||||
#include <tlhelp32.h>
|
||||
#include <signal.h>
|
||||
|
||||
static int verbose= 0;
|
||||
static char safe_process_name[32]= {0};
|
||||
|
||||
static void message(const char* fmt, ...)
|
||||
{
|
||||
if (!verbose)
|
||||
return;
|
||||
va_list args;
|
||||
fprintf(stderr, "%s: ", safe_process_name);
|
||||
va_start(args, fmt);
|
||||
vfprintf(stderr, fmt, args);
|
||||
fprintf(stderr, "\n");
|
||||
va_end(args);
|
||||
fflush(stderr);
|
||||
}
|
||||
|
||||
|
||||
static void die(const char* fmt, ...)
|
||||
{
|
||||
va_list args;
|
||||
fprintf(stderr, "%s: FATAL ERROR, ", safe_process_name);
|
||||
va_start(args, fmt);
|
||||
vfprintf(stderr, fmt, args);
|
||||
fprintf(stderr, "\n");
|
||||
va_end(args);
|
||||
if (int last_err= GetLastError())
|
||||
fprintf(stderr, "error: %d, %s\n", last_err, strerror(last_err));
|
||||
fflush(stderr);
|
||||
exit(1);
|
||||
}
|
||||
|
||||
|
||||
DWORD get_parent_pid(DWORD pid)
|
||||
{
|
||||
HANDLE snapshot;
|
||||
DWORD parent_pid= -1;
|
||||
PROCESSENTRY32 pe32;
|
||||
pe32.dwSize= sizeof(PROCESSENTRY32);
|
||||
|
||||
snapshot= CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
|
||||
if (snapshot == INVALID_HANDLE_VALUE)
|
||||
die("CreateToolhelp32Snapshot failed");
|
||||
|
||||
if (!Process32First(snapshot, &pe32))
|
||||
{
|
||||
CloseHandle(snapshot);
|
||||
die("Process32First failed");
|
||||
}
|
||||
|
||||
do
|
||||
{
|
||||
if (pe32.th32ProcessID == pid)
|
||||
parent_pid= pe32.th32ParentProcessID;
|
||||
} while(Process32Next( snapshot, &pe32));
|
||||
CloseHandle(snapshot);
|
||||
|
||||
if (parent_pid == -1)
|
||||
die("Could not find parent pid");
|
||||
|
||||
return parent_pid;
|
||||
}
|
||||
|
||||
|
||||
enum {
|
||||
PARENT,
|
||||
CHILD,
|
||||
EVENT,
|
||||
NUM_HANDLES
|
||||
};
|
||||
|
||||
|
||||
HANDLE shutdown_event;
|
||||
void handle_signal (int signal)
|
||||
{
|
||||
message("Got signal: %d", signal);
|
||||
if(SetEvent(shutdown_event) == 0) {
|
||||
/* exit safe_process and (hopefully) kill off the child */
|
||||
die("Failed to SetEvent");
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
int main(int argc, const char** argv )
|
||||
{
|
||||
char child_args[4096]= {0};
|
||||
DWORD pid= GetCurrentProcessId();
|
||||
DWORD parent_pid= get_parent_pid(pid);
|
||||
HANDLE job_handle;
|
||||
HANDLE wait_handles[NUM_HANDLES]= {0};
|
||||
PROCESS_INFORMATION process_info= {0};
|
||||
|
||||
sprintf(safe_process_name, "safe_process[%d]", pid);
|
||||
|
||||
/* Create an event for the signal handler */
|
||||
if ((shutdown_event=
|
||||
CreateEvent(NULL, TRUE, FALSE, safe_process_name)) == NULL)
|
||||
die("Failed to create shutdown_event");
|
||||
wait_handles[EVENT]= shutdown_event;
|
||||
|
||||
signal(SIGINT, handle_signal);
|
||||
signal(SIGBREAK, handle_signal);
|
||||
signal(SIGTERM, handle_signal);
|
||||
|
||||
message("Started");
|
||||
|
||||
/* Parse arguments */
|
||||
for (int i= 1; i < argc; i++) {
|
||||
const char* arg= argv[i];
|
||||
char* to= child_args;
|
||||
if (strcmp(arg, "--") == 0 && strlen(arg) == 2) {
|
||||
/* Got the "--" delimiter */
|
||||
if (i >= argc)
|
||||
die("No real args -> nothing to do");
|
||||
/* Copy the remaining args to child_arg */
|
||||
for (int j= i+1; j < argc; j++) {
|
||||
to+= _snprintf(to, child_args + sizeof(child_args) - to, "%s ", argv[j]);
|
||||
}
|
||||
break;
|
||||
} else {
|
||||
if ( strcmp(arg, "--verbose") == 0 )
|
||||
verbose++;
|
||||
else if ( strncmp(arg, "--parent-pid", 10) == 0 )
|
||||
{
|
||||
/* Override parent_pid with a value provided by user */
|
||||
const char* start;
|
||||
if ((start= strstr(arg, "=")) == NULL)
|
||||
die("Could not find start of option value in '%s'", arg);
|
||||
start++; /* Step past = */
|
||||
if ((parent_pid= atoi(start)) == 0)
|
||||
die("Invalid value '%s' passed to --parent-id", start);
|
||||
}
|
||||
else
|
||||
die("Unknown option: %s", arg);
|
||||
}
|
||||
}
|
||||
if (*child_args == '\0')
|
||||
die("nothing to do");
|
||||
|
||||
/* Open a handle to the parent process */
|
||||
message("parent_pid: %d", parent_pid);
|
||||
if (parent_pid == pid)
|
||||
die("parent_pid is equal to own pid!");
|
||||
|
||||
if ((wait_handles[PARENT]=
|
||||
OpenProcess(SYNCHRONIZE, FALSE, parent_pid)) == NULL)
|
||||
die("Failed to open parent process with pid: %d", parent_pid);
|
||||
|
||||
/* Create the child process in a job */
|
||||
JOBOBJECT_EXTENDED_LIMIT_INFORMATION jeli = { 0 };
|
||||
STARTUPINFO si = { 0 };
|
||||
si.cb = sizeof(si);
|
||||
|
||||
/*
|
||||
Create the job object to make it possible to kill the process
|
||||
and all of it's children in one go
|
||||
*/
|
||||
if ((job_handle= CreateJobObject(NULL, NULL)) == NULL)
|
||||
die("CreateJobObject failed");
|
||||
|
||||
/*
|
||||
Make all processes associated with the job terminate when the
|
||||
last handle to the job is closed.
|
||||
*/
|
||||
jeli.BasicLimitInformation.LimitFlags = JOB_OBJECT_LIMIT_KILL_ON_JOB_CLOSE;
|
||||
if (SetInformationJobObject(job_handle, JobObjectExtendedLimitInformation,
|
||||
&jeli, sizeof(jeli)) == 0)
|
||||
message("SetInformationJobObject failed, continue anyway...");
|
||||
|
||||
#if 0
|
||||
/* Setup stdin, stdout and stderr redirect */
|
||||
si.dwFlags= STARTF_USESTDHANDLES;
|
||||
si.hStdInput= GetStdHandle(STD_INPUT_HANDLE);
|
||||
si.hStdOutput= GetStdHandle(STD_OUTPUT_HANDLE);
|
||||
si.hStdError= GetStdHandle(STD_ERROR_HANDLE);
|
||||
#endif
|
||||
|
||||
/*
|
||||
Create the process suspended to make sure it's assigned to the
|
||||
Job before it creates any process of it's own
|
||||
*/
|
||||
if (CreateProcess(NULL, (LPSTR)child_args,
|
||||
NULL,
|
||||
NULL,
|
||||
TRUE, /* inherit handles */
|
||||
CREATE_SUSPENDED,
|
||||
NULL,
|
||||
NULL,
|
||||
&si,
|
||||
&process_info) == 0)
|
||||
die("CreateProcess failed");
|
||||
|
||||
if (AssignProcessToJobObject(job_handle, process_info.hProcess) == 0)
|
||||
{
|
||||
TerminateProcess(process_info.hProcess, 200);
|
||||
die("AssignProcessToJobObject failed");
|
||||
}
|
||||
ResumeThread(process_info.hThread);
|
||||
CloseHandle(process_info.hThread);
|
||||
|
||||
wait_handles[CHILD]= process_info.hProcess;
|
||||
|
||||
message("Started child %d", process_info.dwProcessId);
|
||||
|
||||
/* Monitor loop */
|
||||
DWORD child_exit_code= 1;
|
||||
DWORD wait_res= WaitForMultipleObjects(NUM_HANDLES, wait_handles,
|
||||
FALSE, INFINITE);
|
||||
switch (wait_res)
|
||||
{
|
||||
case WAIT_OBJECT_0 + PARENT:
|
||||
message("Parent exit");
|
||||
break;
|
||||
case WAIT_OBJECT_0 + CHILD:
|
||||
if (GetExitCodeProcess(wait_handles[CHILD], &child_exit_code) == 0)
|
||||
message("Child exit: could not get exit_code");
|
||||
else
|
||||
message("Child exit: exit_code: %d", child_exit_code);
|
||||
break;
|
||||
case WAIT_OBJECT_0 + EVENT:
|
||||
message("Wake up from shutdown_event");
|
||||
break;
|
||||
|
||||
default:
|
||||
message("Unexpected result %d from WaitForMultipleObjects", wait_res);
|
||||
break;
|
||||
}
|
||||
message("Exiting, child: %d", process_info.dwProcessId);
|
||||
|
||||
if (TerminateJobObject(job_handle, 201) == 0)
|
||||
message("TerminateJobObject failed");
|
||||
CloseHandle(job_handle);
|
||||
message("Job terminated and closed");
|
||||
if (wait_res != WAIT_OBJECT_0 + CHILD)
|
||||
{
|
||||
/* The child has not yet returned, wait for it */
|
||||
message("waiting for child to exit");
|
||||
if ((wait_res= WaitForSingleObject(wait_handles[CHILD], INFINITE))
|
||||
!= WAIT_OBJECT_0)
|
||||
{
|
||||
message("child wait failed: %d", wait_res);
|
||||
}
|
||||
else
|
||||
{
|
||||
message("child wait succeeded");
|
||||
}
|
||||
/* Child's exit code should now be 201, no need to get it */
|
||||
}
|
||||
|
||||
message("Closing handles");
|
||||
for (int i= 0; i < NUM_HANDLES; i++)
|
||||
CloseHandle(wait_handles[i]);
|
||||
|
||||
message("Exiting, exit_code: %d", child_exit_code);
|
||||
exit(child_exit_code);
|
||||
}
|
||||
|
||||
211
mysql-test/lib/My/SysInfo.pm
Normal file
211
mysql-test/lib/My/SysInfo.pm
Normal file
@ -0,0 +1,211 @@
|
||||
# -*- 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
|
||||
|
||||
|
||||
package My::SysInfo;
|
||||
|
||||
use strict;
|
||||
use Carp;
|
||||
use My::Platform;
|
||||
|
||||
use constant DEFAULT_BOGO_MIPS => 2000;
|
||||
|
||||
sub _cpuinfo {
|
||||
my ($self)= @_;
|
||||
|
||||
my $info_file= "/proc/cpuinfo";
|
||||
if ( !( -e $info_file and -f $info_file) ) {
|
||||
return undef;
|
||||
}
|
||||
|
||||
my $F= IO::File->new($info_file) or return undef;
|
||||
|
||||
# Set input separator to blank line
|
||||
local $/ = '';
|
||||
|
||||
while ( my $cpu_chunk= <$F>) {
|
||||
chomp($cpu_chunk);
|
||||
|
||||
my $cpuinfo = {};
|
||||
|
||||
foreach my $cpuline ( split(/\n/, $cpu_chunk) ) {
|
||||
my ( $attribute, $value ) = split(/\s*:\s*/, $cpuline);
|
||||
|
||||
$attribute =~ s/\s+/_/;
|
||||
$attribute = lc($attribute);
|
||||
|
||||
if ( $value =~ /^(no|not available|yes)$/ ) {
|
||||
$value = $value eq 'yes' ? 1 : 0;
|
||||
}
|
||||
|
||||
if ( $attribute eq 'flags' ) {
|
||||
@{ $cpuinfo->{flags} } = split / /, $value;
|
||||
} else {
|
||||
$cpuinfo->{$attribute} = $value;
|
||||
}
|
||||
}
|
||||
|
||||
# Make sure bogomips is set to some value
|
||||
$cpuinfo->{bogomips} |= DEFAULT_BOGO_MIPS;
|
||||
|
||||
# Cpus reported once, but with 'cpu_count' set to the actual number
|
||||
my $cpu_count= $cpuinfo->{cpu_count} || 1;
|
||||
for(1..$cpu_count){
|
||||
push(@{$self->{cpus}}, $cpuinfo);
|
||||
}
|
||||
}
|
||||
$F= undef; # Close file
|
||||
return $self;
|
||||
}
|
||||
|
||||
|
||||
sub _kstat {
|
||||
my ($self)= @_;
|
||||
while (1){
|
||||
my $instance_num= $self->{cpus} ? @{$self->{cpus}} : 0;
|
||||
my $list= `kstat -p -m cpu_info -i $instance_num 2> /dev/null`;
|
||||
my @lines= split('\n', $list) or last; # Break loop
|
||||
|
||||
my $cpuinfo= {};
|
||||
foreach my $line (@lines)
|
||||
{
|
||||
my ($module, $instance, $name, $statistic, $value)=
|
||||
$line=~ /(\w*):(\w*):(\w*):(\w*)\t(.*)/;
|
||||
|
||||
$cpuinfo->{$statistic}= $value;
|
||||
}
|
||||
|
||||
# Default value, the actual cpu values can be used to decrease this
|
||||
# on slower cpus
|
||||
$cpuinfo->{bogomips}= DEFAULT_BOGO_MIPS;
|
||||
|
||||
push(@{$self->{cpus}}, $cpuinfo);
|
||||
}
|
||||
|
||||
# At least one cpu should have been found
|
||||
# if this method worked
|
||||
if ( $self->{cpus} ) {
|
||||
return $self;
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
|
||||
|
||||
sub _unamex {
|
||||
my ($self)= @_;
|
||||
# TODO
|
||||
return undef;
|
||||
}
|
||||
|
||||
|
||||
sub new {
|
||||
my ($class)= @_;
|
||||
|
||||
|
||||
my $self= bless {
|
||||
cpus => (),
|
||||
}, $class;
|
||||
|
||||
my @info_methods =
|
||||
(
|
||||
\&_cpuinfo,
|
||||
\&_kstat,
|
||||
\&_unamex,
|
||||
);
|
||||
|
||||
# Detect virtual machines
|
||||
my $isvm= 0;
|
||||
|
||||
if (IS_WINDOWS) {
|
||||
# Detect vmware service
|
||||
$isvm= `tasklist` =~ /vmwareservice/i;
|
||||
}
|
||||
$self->{isvm}= $isvm;
|
||||
|
||||
foreach my $method (@info_methods){
|
||||
if ($method->($self)){
|
||||
return $self;
|
||||
}
|
||||
}
|
||||
|
||||
# Push a dummy cpu
|
||||
push(@{$self->{cpus}},
|
||||
{
|
||||
bogomips => DEFAULT_BOGO_MIPS,
|
||||
model_name => "unknown",
|
||||
});
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
|
||||
# Return the list of cpus found
|
||||
sub cpus {
|
||||
my ($self)= @_;
|
||||
return @{$self->{cpus}} or
|
||||
confess "INTERNAL ERROR: No cpus in list";
|
||||
}
|
||||
|
||||
|
||||
# Return the number of cpus found
|
||||
sub num_cpus {
|
||||
my ($self)= @_;
|
||||
return int(@{$self->{cpus}}) or
|
||||
confess "INTERNAL ERROR: No cpus in list";
|
||||
}
|
||||
|
||||
|
||||
# Return the smallest bogomips value amongst the processors
|
||||
sub min_bogomips {
|
||||
my ($self)= @_;
|
||||
|
||||
my $bogomips;
|
||||
|
||||
foreach my $cpu (@{$self->{cpus}}) {
|
||||
if (!defined $bogomips or $bogomips > $cpu->{bogomips}) {
|
||||
$bogomips= $cpu->{bogomips};
|
||||
}
|
||||
}
|
||||
|
||||
return $bogomips;
|
||||
}
|
||||
|
||||
sub isvm {
|
||||
my ($self)= @_;
|
||||
|
||||
return $self->{isvm};
|
||||
}
|
||||
|
||||
|
||||
# Prit the cpuinfo
|
||||
sub print_info {
|
||||
my ($self)= @_;
|
||||
|
||||
foreach my $cpu (@{$self->{cpus}}) {
|
||||
while ((my ($key, $value)) = each(%$cpu)) {
|
||||
print " ", $key, "= ";
|
||||
if (ref $value eq "ARRAY") {
|
||||
print "[", join(", ", @$value), "]";
|
||||
} else {
|
||||
print $value;
|
||||
}
|
||||
print "\n";
|
||||
}
|
||||
print "\n";
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
123
mysql-test/lib/My/Test.pm
Normal file
123
mysql-test/lib/My/Test.pm
Normal file
@ -0,0 +1,123 @@
|
||||
# -*- cperl -*-
|
||||
|
||||
|
||||
#
|
||||
# One test
|
||||
#
|
||||
package My::Test;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp;
|
||||
|
||||
|
||||
sub new {
|
||||
my $class= shift;
|
||||
my $self= bless {
|
||||
@_,
|
||||
}, $class;
|
||||
return $self;
|
||||
}
|
||||
|
||||
|
||||
#
|
||||
# Return a unique key that can be used to
|
||||
# identify this test in a hash
|
||||
#
|
||||
sub key {
|
||||
my ($self)= @_;
|
||||
return $self->{key};
|
||||
}
|
||||
|
||||
|
||||
sub _encode {
|
||||
my ($value)= @_;
|
||||
$value =~ s/([|\\\x{0a}\x{0d}])/sprintf('\%02X', ord($1))/eg;
|
||||
return $value;
|
||||
}
|
||||
|
||||
sub _decode {
|
||||
my ($value)= @_;
|
||||
$value =~ s/\\([0-9a-fA-F]{2})/chr(hex($1))/ge;
|
||||
return $value;
|
||||
}
|
||||
|
||||
sub is_failed {
|
||||
my ($self)= @_;
|
||||
my $result= $self->{result};
|
||||
croak "'is_failed' can't be called until test has been run!"
|
||||
unless defined $result;
|
||||
|
||||
return ($result eq 'MTR_RES_FAILED');
|
||||
}
|
||||
|
||||
|
||||
sub write_test {
|
||||
my ($test, $sock, $header)= @_;
|
||||
|
||||
# Give the test a unique key before serializing it
|
||||
$test->{key}= "$test" unless defined $test->{key};
|
||||
|
||||
print $sock $header, "\n";
|
||||
while ((my ($key, $value)) = each(%$test)) {
|
||||
print $sock $key, "= ";
|
||||
if (ref $value eq "ARRAY") {
|
||||
print $sock "[", _encode(join(", ", @$value)), "]";
|
||||
} else {
|
||||
print $sock _encode($value);
|
||||
}
|
||||
print $sock "\n";
|
||||
}
|
||||
print $sock "\n";
|
||||
}
|
||||
|
||||
|
||||
sub read_test {
|
||||
my ($sock)= @_;
|
||||
my $test= My::Test->new();
|
||||
# Read the : separated key value pairs until a
|
||||
# single newline on it's own line
|
||||
my $line;
|
||||
while (defined($line= <$sock>)) {
|
||||
# List is terminated by newline on it's own
|
||||
if ($line eq "\n") {
|
||||
# Correctly terminated reply
|
||||
# print "Got newline\n";
|
||||
last;
|
||||
}
|
||||
chomp($line);
|
||||
|
||||
# Split key/value on the first "="
|
||||
my ($key, $value)= split("= ", $line, 2);
|
||||
|
||||
if ($value =~ /^\[(.*)\]/){
|
||||
my @values= split(", ", _decode($1));
|
||||
push(@{$test->{$key}}, @values);
|
||||
}
|
||||
else
|
||||
{
|
||||
$test->{$key}= _decode($value);
|
||||
}
|
||||
}
|
||||
return $test;
|
||||
}
|
||||
|
||||
|
||||
sub print_test {
|
||||
my ($self)= @_;
|
||||
|
||||
print "[", $self->{name}, "]", "\n";
|
||||
while ((my ($key, $value)) = each(%$self)) {
|
||||
print " ", $key, "= ";
|
||||
if (ref $value eq "ARRAY") {
|
||||
print "[", join(", ", @$value), "]";
|
||||
} else {
|
||||
print $value;
|
||||
}
|
||||
print "\n";
|
||||
}
|
||||
print "\n";
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
1177
mysql-test/lib/mtr_cases.pm
Normal file
1177
mysql-test/lib/mtr_cases.pm
Normal file
File diff suppressed because it is too large
Load Diff
@ -1,297 +0,0 @@
|
||||
# -*- cperl -*-
|
||||
# Copyright (C) 2005 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 Data::Dumper;
|
||||
use strict;
|
||||
|
||||
# $Data::Dumper::Indent= 1;
|
||||
|
||||
sub mtr_diff($$);
|
||||
|
||||
##############################################################################
|
||||
#
|
||||
# This is a simplified unified diff, with some special handling
|
||||
# of unsorted result sets
|
||||
#
|
||||
##############################################################################
|
||||
|
||||
# FIXME replace die with mtr_error
|
||||
|
||||
#require "mtr_report.pl";
|
||||
#mtr_diff("a.txt","b.txt");
|
||||
|
||||
sub mtr_diff ($$) {
|
||||
my $file1 = shift;
|
||||
my $file2 = shift;
|
||||
|
||||
# ----------------------------------------------------------------------
|
||||
# We read in all of the files at once
|
||||
# ----------------------------------------------------------------------
|
||||
|
||||
unless ( open(FILE1, $file1) )
|
||||
{
|
||||
mtr_warning("can't open \"$file1\": $!");
|
||||
return;
|
||||
}
|
||||
|
||||
unless ( open(FILE2, $file2) )
|
||||
{
|
||||
mtr_warning("can't open \"$file2\": $!");
|
||||
return;
|
||||
}
|
||||
|
||||
my $lines1= collect_lines(<FILE1>);
|
||||
my $lines2= collect_lines(<FILE2>);
|
||||
close FILE1;
|
||||
close FILE2;
|
||||
|
||||
# print Dumper($lines1);
|
||||
# print Dumper($lines2);
|
||||
|
||||
# ----------------------------------------------------------------------
|
||||
# We compare line by line, but don't shift off elements until we know
|
||||
# what to do. This way we use the "restart" method, do simple change
|
||||
# and restart by entering the diff loop from the beginning again.
|
||||
# ----------------------------------------------------------------------
|
||||
|
||||
my @context;
|
||||
my @info; # Collect information, and output later
|
||||
my $lno1= 1;
|
||||
my $lno2= 1;
|
||||
|
||||
while ( @$lines1 or @$lines2 )
|
||||
{
|
||||
unless ( @$lines1 )
|
||||
{
|
||||
push(@info, map {['+',$lno1,$lno2++,$_]} @$lines2);
|
||||
last;
|
||||
}
|
||||
unless ( @$lines2 )
|
||||
{
|
||||
push(@info, map {['-',$lno1++,$lno2,$_]} @$lines1);
|
||||
last;
|
||||
}
|
||||
|
||||
# ----------------------------------------------------------------------
|
||||
# We know both have lines
|
||||
# ----------------------------------------------------------------------
|
||||
|
||||
if ( $lines1->[0] eq $lines2->[0] )
|
||||
{
|
||||
# Simple case, first line match and all is well
|
||||
push(@info, ['',$lno1++,$lno2++,$lines1->[0]]);
|
||||
shift @$lines1;
|
||||
shift @$lines2;
|
||||
next;
|
||||
}
|
||||
|
||||
# ----------------------------------------------------------------------
|
||||
# Now, we know they differ
|
||||
# ----------------------------------------------------------------------
|
||||
|
||||
# How far in the other one, is there a match?
|
||||
|
||||
my $idx2= find_next_match($lines1->[0], $lines2);
|
||||
my $idx1= find_next_match($lines2->[0], $lines1);
|
||||
|
||||
# Here we could test "if ( !defined $idx2 or !defined $idx1 )" and
|
||||
# use a more complicated diff algorithm in the case both contains
|
||||
# each others lines, just dislocated. But for this application, there
|
||||
# should be no need.
|
||||
|
||||
if ( !defined $idx2 )
|
||||
{
|
||||
push(@info, ['-',$lno1++,$lno2,$lines1->[0]]);
|
||||
shift @$lines1;
|
||||
}
|
||||
else
|
||||
{
|
||||
push(@info, ['+',$lno1,$lno2++,$lines2->[0]]);
|
||||
shift @$lines2;
|
||||
}
|
||||
}
|
||||
|
||||
# ----------------------------------------------------------------------
|
||||
# Try to output nicely
|
||||
# ----------------------------------------------------------------------
|
||||
|
||||
# print Dumper(\@info);
|
||||
|
||||
# We divide into "chunks" to output
|
||||
# We want at least three lines of context
|
||||
|
||||
my @chunks;
|
||||
my @chunk;
|
||||
my $state= 'pre'; # 'pre', 'in' and 'post' difference
|
||||
my $post_count= 0;
|
||||
|
||||
foreach my $info ( @info )
|
||||
{
|
||||
if ( $info->[0] eq '' and $state eq 'pre' )
|
||||
{
|
||||
# Collect no more than three lines of context before diff
|
||||
push(@chunk, $info);
|
||||
shift(@chunk) if @chunk > 3;
|
||||
next;
|
||||
}
|
||||
|
||||
if ( $info->[0] =~ /(\+|\-)/ and $state =~ /(pre|in)/ )
|
||||
{
|
||||
# Start/continue collecting diff
|
||||
$state= 'in';
|
||||
push(@chunk, $info);
|
||||
next;
|
||||
}
|
||||
|
||||
if ( $info->[0] eq '' and $state eq 'in' )
|
||||
{
|
||||
# Stop collecting diff, and collect context after diff
|
||||
$state= 'post';
|
||||
$post_count= 1;
|
||||
push(@chunk, $info);
|
||||
next;
|
||||
}
|
||||
|
||||
if ( $info->[0] eq '' and $state eq 'post' and $post_count < 6 )
|
||||
{
|
||||
# We might find a new diff sequence soon, continue to collect
|
||||
# non diffs but five up on 6.
|
||||
$post_count++;
|
||||
push(@chunk, $info);
|
||||
next;
|
||||
}
|
||||
|
||||
if ( $info->[0] eq '' and $state eq 'post' )
|
||||
{
|
||||
# We put an end to this, giving three non diff lines to
|
||||
# the old chunk, and three to the new one.
|
||||
my @left= splice(@chunk, -3, 3);
|
||||
push(@chunks, [@chunk]);
|
||||
$state= 'pre';
|
||||
$post_count= 0;
|
||||
@chunk= @left;
|
||||
next;
|
||||
}
|
||||
|
||||
if ( $info->[0] =~ /(\+|\-)/ and $state eq 'post' )
|
||||
{
|
||||
# We didn't split, continue collect diff
|
||||
$state= 'in';
|
||||
push(@chunk, $info);
|
||||
next;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
if ( $post_count > 3 )
|
||||
{
|
||||
$post_count -= 3;
|
||||
splice(@chunk, -$post_count, $post_count);
|
||||
}
|
||||
push(@chunks, [@chunk]) if @chunk and $state ne 'pre';
|
||||
|
||||
foreach my $chunk ( @chunks )
|
||||
{
|
||||
my $from_file_start= $chunk->[0]->[1];
|
||||
my $to_file_start= $chunk->[0]->[2];
|
||||
my $from_file_offset= $chunk->[$#$chunk]->[1] - $from_file_start;
|
||||
my $to_file_offset= $chunk->[$#$chunk]->[2] - $to_file_start;
|
||||
print "\@\@ -$from_file_start,$from_file_offset ",
|
||||
"+$to_file_start,$to_file_offset \@\@\n";
|
||||
|
||||
foreach my $info ( @$chunk )
|
||||
{
|
||||
if ( $info->[0] eq '' )
|
||||
{
|
||||
print " $info->[3]\n";
|
||||
}
|
||||
elsif ( $info->[0] eq '-' )
|
||||
{
|
||||
print "- $info->[3]\n";
|
||||
}
|
||||
elsif ( $info->[0] eq '+' )
|
||||
{
|
||||
print "+ $info->[3]\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# print Dumper(\@chunks);
|
||||
|
||||
}
|
||||
|
||||
|
||||
##############################################################################
|
||||
# Find if the string is found in the array, return the index if found,
|
||||
# if not found, return "undef"
|
||||
##############################################################################
|
||||
|
||||
sub find_next_match {
|
||||
my $line= shift;
|
||||
my $lines= shift;
|
||||
|
||||
for ( my $idx= 0; $idx < @$lines; $idx++ )
|
||||
{
|
||||
return $idx if $lines->[$idx] eq $line;
|
||||
}
|
||||
|
||||
return undef; # No match found
|
||||
}
|
||||
|
||||
|
||||
##############################################################################
|
||||
# Just read the lines, but handle "sets" of lines that are unordered
|
||||
##############################################################################
|
||||
|
||||
sub collect_lines {
|
||||
|
||||
my @recordset;
|
||||
my @lines;
|
||||
|
||||
while (@_)
|
||||
{
|
||||
my $line= shift @_;
|
||||
chomp($line);
|
||||
|
||||
if ( $line =~ /^\Q%unordered%\E\t/ )
|
||||
{
|
||||
push(@recordset, $line);
|
||||
}
|
||||
elsif ( @recordset )
|
||||
{
|
||||
push(@lines, sort @recordset);
|
||||
@recordset= (); # Clear it
|
||||
}
|
||||
else
|
||||
{
|
||||
push(@lines, $line);
|
||||
}
|
||||
}
|
||||
|
||||
if ( @recordset )
|
||||
{
|
||||
push(@lines, sort @recordset);
|
||||
@recordset= (); # Clear it
|
||||
}
|
||||
|
||||
return \@lines;
|
||||
}
|
||||
|
||||
1;
|
||||
@ -20,25 +20,14 @@
|
||||
|
||||
use strict;
|
||||
|
||||
# These are not to be prefixed with "mtr_"
|
||||
sub gcov_prepare ($) {
|
||||
my ($dir)= @_;
|
||||
|
||||
sub gcov_prepare ();
|
||||
sub gcov_collect ();
|
||||
|
||||
##############################################################################
|
||||
#
|
||||
#
|
||||
#
|
||||
##############################################################################
|
||||
|
||||
sub gcov_prepare () {
|
||||
|
||||
`find $::glob_basedir -name \*.gcov \
|
||||
`find $dir -name \*.gcov \
|
||||
-or -name \*.da | xargs rm`;
|
||||
}
|
||||
|
||||
# Used by gcov
|
||||
our @mysqld_src_dirs=
|
||||
my @mysqld_src_dirs=
|
||||
(
|
||||
"strings",
|
||||
"mysys",
|
||||
@ -53,21 +42,24 @@ our @mysqld_src_dirs=
|
||||
"sql",
|
||||
);
|
||||
|
||||
sub gcov_collect () {
|
||||
sub gcov_collect ($$$) {
|
||||
my ($dir, $gcov, $gcov_msg, $gcov_err)= @_;
|
||||
|
||||
my $start_dir= cwd();
|
||||
|
||||
print "Collecting source coverage info...\n";
|
||||
-f $::opt_gcov_msg and unlink($::opt_gcov_msg);
|
||||
-f $::opt_gcov_err and unlink($::opt_gcov_err);
|
||||
-f $gcov_msg and unlink($gcov_msg);
|
||||
-f $gcov_err and unlink($gcov_err);
|
||||
foreach my $d ( @mysqld_src_dirs )
|
||||
{
|
||||
chdir("$::glob_basedir/$d");
|
||||
chdir("$dir/$d");
|
||||
foreach my $f ( (glob("*.h"), glob("*.cc"), glob("*.c")) )
|
||||
{
|
||||
`$::opt_gcov $f 2>>$::opt_gcov_err >>$::opt_gcov_msg`;
|
||||
`$gcov $f 2>>$gcov_err >>$gcov_msg`;
|
||||
}
|
||||
chdir($::glob_mysql_test_dir);
|
||||
chdir($start_dir);
|
||||
}
|
||||
print "gcov info in $::opt_gcov_msg, errors in $::opt_gcov_err\n";
|
||||
print "gcov info in $gcov_msg, errors in $gcov_err\n";
|
||||
}
|
||||
|
||||
|
||||
|
||||
@ -19,135 +19,15 @@
|
||||
# same name.
|
||||
|
||||
use strict;
|
||||
use Carp;
|
||||
|
||||
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";
|
||||
}
|
||||
sub mtr_printfile($);
|
||||
sub mtr_lastlinesfromfile ($$);
|
||||
|
||||
# Read a whole file, stripping leading and trailing whitespace.
|
||||
sub mtr_fromfile ($) {
|
||||
@ -161,19 +41,6 @@ sub mtr_fromfile ($) {
|
||||
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;
|
||||
@ -183,6 +50,7 @@ sub mtr_tofile ($@) {
|
||||
close FILE;
|
||||
}
|
||||
|
||||
|
||||
sub mtr_tonewfile ($@) {
|
||||
my $file= shift;
|
||||
|
||||
@ -191,6 +59,7 @@ sub mtr_tonewfile ($@) {
|
||||
close FILE;
|
||||
}
|
||||
|
||||
|
||||
sub mtr_appendfile_to_file ($$) {
|
||||
my $from_file= shift;
|
||||
my $to_file= shift;
|
||||
@ -203,6 +72,7 @@ sub mtr_appendfile_to_file ($$) {
|
||||
close TOFILE;
|
||||
}
|
||||
|
||||
|
||||
# Read a whole file verbatim.
|
||||
sub mtr_grab_file($) {
|
||||
my $file= shift;
|
||||
@ -215,4 +85,26 @@ sub mtr_grab_file($) {
|
||||
}
|
||||
|
||||
|
||||
# Print the file to STDOUT
|
||||
sub mtr_printfile($) {
|
||||
my $file= shift;
|
||||
open(FILE, '<', $file)
|
||||
or warn $!;
|
||||
print while(<FILE>);
|
||||
close FILE;
|
||||
return;
|
||||
}
|
||||
|
||||
sub mtr_lastlinesfromfile ($$) {
|
||||
croak "usage: mtr_lastlinesfromfile(file,numlines)" unless (@_ == 2);
|
||||
my ($file, $num_lines)= @_;
|
||||
my $text;
|
||||
open(FILE,"<",$file) or mtr_error("can't open file \"$file\": $!");
|
||||
my @lines= reverse <FILE>;
|
||||
close FILE;
|
||||
my $size= scalar(@lines);
|
||||
$num_lines= $size unless ($size >= $num_lines);
|
||||
return join("", reverse(splice(@lines, 0, $num_lines)));
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
97
mysql-test/lib/mtr_match.pm
Normal file
97
mysql-test/lib/mtr_match.pm
Normal file
@ -0,0 +1,97 @@
|
||||
# -*- 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.
|
||||
|
||||
package mtr_match;
|
||||
use strict;
|
||||
|
||||
use base qw(Exporter);
|
||||
our @EXPORT= qw(mtr_match_prefix
|
||||
mtr_match_extension
|
||||
mtr_match_substring);
|
||||
|
||||
#
|
||||
# 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;
|
||||
@ -19,45 +19,25 @@
|
||||
# same name.
|
||||
|
||||
use strict;
|
||||
use File::Find;
|
||||
|
||||
sub mtr_native_path($);
|
||||
use My::Platform;
|
||||
|
||||
sub mtr_init_args ($);
|
||||
sub mtr_add_arg ($$@);
|
||||
sub mtr_args2str($@);
|
||||
sub mtr_path_exists(@);
|
||||
sub mtr_script_exists(@);
|
||||
sub mtr_file_exists(@);
|
||||
sub mtr_exe_exists(@);
|
||||
sub mtr_exe_maybe_exists(@);
|
||||
sub mtr_copy_dir($$);
|
||||
sub mtr_rmtree($);
|
||||
sub mtr_same_opts($$);
|
||||
sub mtr_cmp_opts($$);
|
||||
|
||||
|
||||
##############################################################################
|
||||
#
|
||||
# Misc
|
||||
# Args
|
||||
#
|
||||
##############################################################################
|
||||
|
||||
# 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
|
||||
@ -68,9 +48,18 @@ sub mtr_add_arg ($$@) {
|
||||
my $format= shift;
|
||||
my @fargs = @_;
|
||||
|
||||
# Quote args if args contain space
|
||||
$format= "\"$format\""
|
||||
if (IS_WINDOWS and grep(/\s/, @fargs));
|
||||
|
||||
push(@$args, sprintf($format, @fargs));
|
||||
}
|
||||
|
||||
sub mtr_args2str($@) {
|
||||
my $exe= shift or die;
|
||||
return join(" ", native_path($exe), @_);
|
||||
}
|
||||
|
||||
##############################################################################
|
||||
|
||||
#
|
||||
@ -100,7 +89,7 @@ sub mtr_path_exists (@) {
|
||||
sub mtr_script_exists (@) {
|
||||
foreach my $path ( @_ )
|
||||
{
|
||||
if($::glob_win32)
|
||||
if(IS_WINDOWS)
|
||||
{
|
||||
return $path if -f $path;
|
||||
}
|
||||
@ -140,11 +129,10 @@ sub mtr_file_exists (@) {
|
||||
sub mtr_exe_maybe_exists (@) {
|
||||
my @path= @_;
|
||||
|
||||
map {$_.= ".exe"} @path if $::glob_win32;
|
||||
map {$_.= ".nlm"} @path if $::glob_netware;
|
||||
map {$_.= ".exe"} @path if IS_WINDOWS;
|
||||
foreach my $path ( @path )
|
||||
{
|
||||
if($::glob_win32)
|
||||
if(IS_WINDOWS)
|
||||
{
|
||||
return $path if -f $path;
|
||||
}
|
||||
@ -179,134 +167,11 @@ sub mtr_exe_exists (@) {
|
||||
}
|
||||
|
||||
|
||||
sub mtr_copy_dir($$) {
|
||||
my $from_dir= shift;
|
||||
my $to_dir= shift;
|
||||
sub mtr_milli_sleep {
|
||||
die "usage: mtr_milli_sleep(milliseconds)" unless @_ == 1;
|
||||
my ($millis)= @_;
|
||||
|
||||
# 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;
|
||||
select(undef, undef, undef, ($millis/1000));
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
464
mysql-test/lib/mtr_report.pm
Normal file
464
mysql-test/lib/mtr_report.pm
Normal file
@ -0,0 +1,464 @@
|
||||
# -*- cperl -*-
|
||||
# Copyright 2004-2008 MySQL AB, 2008 Sun Microsystems, Inc.
|
||||
#
|
||||
# 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.
|
||||
|
||||
package mtr_report;
|
||||
use strict;
|
||||
|
||||
use base qw(Exporter);
|
||||
our @EXPORT= qw(report_option mtr_print_line mtr_print_thick_line
|
||||
mtr_print_header mtr_report mtr_report_stats
|
||||
mtr_warning mtr_error mtr_debug mtr_verbose
|
||||
mtr_verbose_restart mtr_report_test_passed
|
||||
mtr_report_test_skipped mtr_print
|
||||
mtr_report_test);
|
||||
|
||||
use mtr_match;
|
||||
require "mtr_io.pl";
|
||||
|
||||
my $tot_real_time= 0;
|
||||
|
||||
our $timestamp= 0;
|
||||
our $timediff= 0;
|
||||
our $name;
|
||||
our $verbose;
|
||||
our $verbose_restart= 0;
|
||||
our $timer= 1;
|
||||
|
||||
sub report_option {
|
||||
my ($opt, $value)= @_;
|
||||
|
||||
# Evaluate $opt as string to use "Getopt::Long::Callback legacy API"
|
||||
my $opt_name = "$opt";
|
||||
|
||||
# Convert - to _ in option name
|
||||
$opt_name =~ s/-/_/g;
|
||||
no strict 'refs';
|
||||
${$opt_name}= $value;
|
||||
}
|
||||
|
||||
sub _name {
|
||||
return $name ? $name." " : undef;
|
||||
}
|
||||
|
||||
sub _mtr_report_test_name ($) {
|
||||
my $tinfo= shift;
|
||||
my $tname= $tinfo->{name};
|
||||
|
||||
return unless defined $verbose;
|
||||
|
||||
# Add combination name if any
|
||||
$tname.= " '$tinfo->{combination}'"
|
||||
if defined $tinfo->{combination};
|
||||
|
||||
print _name(), _timestamp();
|
||||
printf "%-40s ", $tname;
|
||||
}
|
||||
|
||||
|
||||
sub mtr_report_test_skipped ($) {
|
||||
my ($tinfo)= @_;
|
||||
$tinfo->{'result'}= 'MTR_RES_SKIPPED';
|
||||
|
||||
mtr_report_test($tinfo);
|
||||
}
|
||||
|
||||
|
||||
sub mtr_report_test_passed ($) {
|
||||
my ($tinfo)= @_;
|
||||
|
||||
# Save the timer value
|
||||
my $timer_str= "";
|
||||
if ( $timer and -f "$::opt_vardir/log/timer" )
|
||||
{
|
||||
$timer_str= mtr_fromfile("$::opt_vardir/log/timer");
|
||||
$tinfo->{timer}= $timer_str;
|
||||
}
|
||||
|
||||
# Big warning if status already set
|
||||
if ( $tinfo->{'result'} ){
|
||||
mtr_warning("mtr_report_test_passed: Test result",
|
||||
"already set to '", $tinfo->{'result'}, ",");
|
||||
}
|
||||
|
||||
$tinfo->{'result'}= 'MTR_RES_PASSED';
|
||||
|
||||
mtr_report_test($tinfo);
|
||||
}
|
||||
|
||||
|
||||
sub mtr_report_test ($) {
|
||||
my ($tinfo)= @_;
|
||||
_mtr_report_test_name($tinfo);
|
||||
|
||||
my $comment= $tinfo->{'comment'};
|
||||
my $logfile= $tinfo->{'logfile'};
|
||||
my $warnings= $tinfo->{'warnings'};
|
||||
my $result= $tinfo->{'result'};
|
||||
|
||||
if ($result eq 'MTR_RES_FAILED'){
|
||||
|
||||
my $timest = format_time();
|
||||
|
||||
if ( $warnings )
|
||||
{
|
||||
mtr_report("[ fail ] Found warnings/errors in server log file!");
|
||||
mtr_report(" Test ended at $timest");
|
||||
mtr_report($warnings);
|
||||
return;
|
||||
}
|
||||
my $timeout= $tinfo->{'timeout'};
|
||||
if ( $timeout )
|
||||
{
|
||||
mtr_report("[ fail ] timeout after $timeout seconds");
|
||||
mtr_report(" Test ended at $timest");
|
||||
mtr_report("\n$tinfo->{'comment'}");
|
||||
return;
|
||||
}
|
||||
else
|
||||
{
|
||||
mtr_report("[ fail ]\n Test ended at $timest");
|
||||
}
|
||||
|
||||
if ( $logfile )
|
||||
{
|
||||
# Test failure was detected by test tool and its report
|
||||
# about what failed has been saved to file. Display the report.
|
||||
mtr_report("\n$logfile\n");
|
||||
}
|
||||
if ( $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("\n$comment\n");
|
||||
}
|
||||
|
||||
if ( !$logfile and !$comment )
|
||||
{
|
||||
# Neither this script or the test tool has recorded info
|
||||
# about why the test has failed. Should be debugged.
|
||||
mtr_report("\nUnknown result, neither 'comment' or 'logfile' set");
|
||||
}
|
||||
}
|
||||
elsif ($result eq 'MTR_RES_SKIPPED')
|
||||
{
|
||||
if ( $tinfo->{'disable'} )
|
||||
{
|
||||
mtr_report("[ disabled ] $comment");
|
||||
}
|
||||
elsif ( $comment )
|
||||
{
|
||||
mtr_report("[ skipped ] $comment");
|
||||
}
|
||||
else
|
||||
{
|
||||
mtr_report("[ skipped ]");
|
||||
}
|
||||
}
|
||||
elsif ($result eq 'MTR_RES_PASSED')
|
||||
{
|
||||
my $timer_str= $tinfo->{timer} || "";
|
||||
$tot_real_time += ($timer_str/1000);
|
||||
mtr_report("[ pass ] ", sprintf("%5s", $timer_str));
|
||||
|
||||
# Show any problems check-testcase found
|
||||
if ( defined $tinfo->{'check'} )
|
||||
{
|
||||
mtr_report($tinfo->{'check'});
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
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;
|
||||
|
||||
foreach my $tinfo (@$tests)
|
||||
{
|
||||
if ( $tinfo->{failures} )
|
||||
{
|
||||
# Test has failed at least one time
|
||||
$tot_tests++;
|
||||
$tot_failed++;
|
||||
}
|
||||
elsif ( $tinfo->{'result'} eq 'MTR_RES_SKIPPED' )
|
||||
{
|
||||
# Test was skipped
|
||||
$tot_skiped++;
|
||||
}
|
||||
elsif ( $tinfo->{'result'} eq 'MTR_RES_PASSED' )
|
||||
{
|
||||
# Test passed
|
||||
$tot_tests++;
|
||||
$tot_passed++;
|
||||
}
|
||||
|
||||
if ( $tinfo->{'restarted'} )
|
||||
{
|
||||
# Servers was restarted
|
||||
$tot_restarts++;
|
||||
}
|
||||
|
||||
# Look for warnings produced by mysqltest
|
||||
my $base_file= mtr_match_extension($tinfo->{'result_file'},
|
||||
"result"); # Trim extension
|
||||
my $warning_file= "$base_file.warnings";
|
||||
if ( -f $warning_file )
|
||||
{
|
||||
$found_problems= 1;
|
||||
mtr_warning("Check myqltest warnings in '$warning_file'");
|
||||
}
|
||||
}
|
||||
|
||||
# ----------------------------------------------------------------------
|
||||
# Print out a summary report to screen
|
||||
# ----------------------------------------------------------------------
|
||||
print "The servers were restarted $tot_restarts times\n";
|
||||
|
||||
if ( $timer )
|
||||
{
|
||||
use English;
|
||||
|
||||
mtr_report("Spent", sprintf("%.3f", $tot_real_time),"of",
|
||||
time - $BASETIME, "seconds executing testcases");
|
||||
}
|
||||
|
||||
|
||||
my $warnlog= "$::opt_vardir/log/warnings";
|
||||
if ( -f $warnlog )
|
||||
{
|
||||
mtr_warning("Got errors/warnings while running tests, please examine",
|
||||
"'$warnlog' for details.");
|
||||
}
|
||||
|
||||
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'} )
|
||||
{
|
||||
$check_testcases{$tinfo->{'name'}}= 1;
|
||||
}
|
||||
}
|
||||
|
||||
if ( keys %check_testcases )
|
||||
{
|
||||
print "Check of testcase failed for: ";
|
||||
print join(" ", keys %check_testcases);
|
||||
print "\n\n";
|
||||
}
|
||||
}
|
||||
|
||||
# Print a list of testcases that failed
|
||||
if ( $tot_failed != 0 )
|
||||
{
|
||||
|
||||
# Print each failed test, again
|
||||
#foreach my $test ( @$tests ){
|
||||
# if ( $test->{failures} ) {
|
||||
# mtr_report_test($test);
|
||||
# }
|
||||
#}
|
||||
|
||||
my $ratio= $tot_passed * 100 / $tot_tests;
|
||||
print "Failed $tot_failed/$tot_tests tests, ";
|
||||
printf("%.2f", $ratio);
|
||||
print "\% were successful.\n\n";
|
||||
|
||||
# Print the list of test that failed in a format
|
||||
# that can be copy pasted to rerun only failing tests
|
||||
print "Failing test(s):";
|
||||
|
||||
my %seen= ();
|
||||
foreach my $tinfo (@$tests)
|
||||
{
|
||||
my $tname= $tinfo->{'name'};
|
||||
if ( $tinfo->{failures} and ! $seen{$tname})
|
||||
{
|
||||
print " $tname";
|
||||
$seen{$tname}= 1;
|
||||
}
|
||||
}
|
||||
print "\n\n";
|
||||
|
||||
# Print info about reporting the error
|
||||
print
|
||||
"The log files in var/log may give you some hint of what went wrong.\n\n",
|
||||
"If you want to report this error, please read first ",
|
||||
"the documentation\n",
|
||||
"at http://dev.mysql.com/doc/mysql/en/mysql-test-suite.html\n\n";
|
||||
|
||||
}
|
||||
else
|
||||
{
|
||||
print "All $tot_tests tests were successful.\n\n";
|
||||
}
|
||||
|
||||
if ( $tot_failed != 0 || $found_problems)
|
||||
{
|
||||
mtr_error("there were failing test cases");
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
##############################################################################
|
||||
#
|
||||
# Text formatting
|
||||
#
|
||||
##############################################################################
|
||||
|
||||
sub mtr_print_line () {
|
||||
print '-' x 60, "\n";
|
||||
}
|
||||
|
||||
|
||||
sub mtr_print_thick_line {
|
||||
my $char= shift || '=';
|
||||
print $char x 78, "\n";
|
||||
}
|
||||
|
||||
|
||||
sub mtr_print_header () {
|
||||
print "\n";
|
||||
printf "TEST";
|
||||
print " " x 38;
|
||||
print "RESULT ";
|
||||
print "TIME (ms)" if $timer;
|
||||
print "\n";
|
||||
mtr_print_line();
|
||||
print "\n";
|
||||
}
|
||||
|
||||
|
||||
##############################################################################
|
||||
#
|
||||
# Log and reporting functions
|
||||
#
|
||||
##############################################################################
|
||||
|
||||
use Time::localtime;
|
||||
|
||||
use Time::HiRes qw(gettimeofday);
|
||||
|
||||
sub format_time {
|
||||
my $tm= localtime();
|
||||
return sprintf("%4d-%02d-%02d %02d:%02d:%02d",
|
||||
$tm->year + 1900, $tm->mon+1, $tm->mday,
|
||||
$tm->hour, $tm->min, $tm->sec);
|
||||
}
|
||||
|
||||
my $t0= gettimeofday();
|
||||
|
||||
sub _timestamp {
|
||||
return "" unless $timestamp;
|
||||
|
||||
my $diff;
|
||||
if ($timediff){
|
||||
my $t1= gettimeofday();
|
||||
my $elapsed= $t1 - $t0;
|
||||
|
||||
$diff= sprintf(" +%02.3f", $elapsed);
|
||||
|
||||
# Save current time for next lap
|
||||
$t0= $t1;
|
||||
|
||||
}
|
||||
|
||||
my $tm= localtime();
|
||||
return sprintf("%02d%02d%02d %2d:%02d:%02d%s ",
|
||||
$tm->year % 100, $tm->mon+1, $tm->mday,
|
||||
$tm->hour, $tm->min, $tm->sec, $diff);
|
||||
}
|
||||
|
||||
# Always print message to screen
|
||||
sub mtr_print (@) {
|
||||
print _name(), join(" ", @_), "\n";
|
||||
}
|
||||
|
||||
|
||||
# Print message to screen if verbose is defined
|
||||
sub mtr_report (@) {
|
||||
if (defined $verbose)
|
||||
{
|
||||
print _name(), join(" ", @_), "\n";
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
# Print warning to screen
|
||||
sub mtr_warning (@) {
|
||||
print STDERR _name(), _timestamp(),
|
||||
"mysql-test-run: WARNING: ", join(" ", @_), "\n";
|
||||
}
|
||||
|
||||
|
||||
# Print error to screen and then exit
|
||||
sub mtr_error (@) {
|
||||
print STDERR _name(), _timestamp(),
|
||||
"mysql-test-run: *** ERROR: ", join(" ", @_), "\n";
|
||||
exit(1);
|
||||
}
|
||||
|
||||
|
||||
sub mtr_debug (@) {
|
||||
if ( $verbose > 2 )
|
||||
{
|
||||
print STDERR _name(),
|
||||
_timestamp(), "####: ", join(" ", @_), "\n";
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub mtr_verbose (@) {
|
||||
if ( $verbose )
|
||||
{
|
||||
print STDERR _name(), _timestamp(),
|
||||
"> ",join(" ", @_),"\n";
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub mtr_verbose_restart (@) {
|
||||
my ($server, @args)= @_;
|
||||
my $proc= $server->{proc};
|
||||
if ( $verbose_restart )
|
||||
{
|
||||
print STDERR _name(),_timestamp(),
|
||||
"> Restart $proc - ",join(" ", @args),"\n";
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
@ -135,7 +135,7 @@ sub run_stress_test ()
|
||||
}
|
||||
|
||||
mtr_init_args(\$args);
|
||||
|
||||
mtr_add_args($args, "$::glob_mysql_test_dir/mysql-stress-test.pl");
|
||||
mtr_add_arg($args, "--server-socket=%s", $::master->[0]->{'path_sock'});
|
||||
mtr_add_arg($args, "--server-user=%s", $::opt_user);
|
||||
mtr_add_arg($args, "--server-database=%s", "test");
|
||||
@ -181,7 +181,13 @@ sub run_stress_test ()
|
||||
}
|
||||
|
||||
#Run stress test
|
||||
mtr_run("$::glob_mysql_test_dir/mysql-stress-test.pl", $args, "", "", "", "");
|
||||
My::SafeProcess->run
|
||||
(
|
||||
name => "stress test",
|
||||
path => $^X,
|
||||
args => \$args,
|
||||
);
|
||||
|
||||
if ( ! $::glob_use_embedded_server )
|
||||
{
|
||||
stop_all_servers();
|
||||
|
||||
185
mysql-test/lib/mtr_unique.pm
Normal file
185
mysql-test/lib/mtr_unique.pm
Normal file
@ -0,0 +1,185 @@
|
||||
# -*- 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
|
||||
|
||||
package mtr_unique;
|
||||
|
||||
use strict;
|
||||
use Fcntl ':flock';
|
||||
|
||||
use base qw(Exporter);
|
||||
our @EXPORT= qw(mtr_get_unique_id mtr_release_unique_id);
|
||||
|
||||
use My::Platform;
|
||||
|
||||
sub msg {
|
||||
# print "### unique($$) - ", join(" ", @_), "\n";
|
||||
}
|
||||
|
||||
my $file= "/tmp/mysql-test-ports";
|
||||
|
||||
my %mtr_unique_ids;
|
||||
|
||||
END {
|
||||
my $allocated_id= $mtr_unique_ids{$$};
|
||||
if (defined $allocated_id)
|
||||
{
|
||||
mtr_release_unique_id($allocated_id);
|
||||
}
|
||||
delete $mtr_unique_ids{$$};
|
||||
}
|
||||
|
||||
#
|
||||
# Get a unique, numerical ID, given a file name (where all
|
||||
# requested IDs are stored), a minimum and a maximum value.
|
||||
#
|
||||
# If no unique ID within the specified parameters can be
|
||||
# obtained, return undef.
|
||||
#
|
||||
sub mtr_get_unique_id($$) {
|
||||
my ($min, $max)= @_;;
|
||||
|
||||
msg("get, '$file', $min-$max");
|
||||
|
||||
die "Can only get one unique id per process!" if $mtr_unique_ids{$$};
|
||||
|
||||
my $ret = undef;
|
||||
my $changed = 0;
|
||||
|
||||
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;
|
||||
}
|
||||
|
||||
msg("HAVE THE LOCK");
|
||||
|
||||
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;
|
||||
msg("taken: $id, $pid");
|
||||
# Check if process with given pid is alive
|
||||
if(!process_alive($pid)) {
|
||||
print "Removing slot $id used by missing process $pid\n";
|
||||
msg("Removing slot $id used by missing process $pid");
|
||||
delete $taken{$id};
|
||||
$changed++;
|
||||
}
|
||||
}
|
||||
for(my $i=$min; $i<=$max; ++$i) {
|
||||
if(! exists $taken{$i}) {
|
||||
$ret = $i;
|
||||
$taken{$i} = $$;
|
||||
$changed++;
|
||||
# Remember the id this process got
|
||||
$mtr_unique_ids{$$}= $i;
|
||||
msg(" got $i");
|
||||
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;
|
||||
|
||||
msg("RELEASING THE LOCK");
|
||||
flock SEM, LOCK_UN or warn "can't unlock $file.sem";
|
||||
close SEM;
|
||||
|
||||
return $ret;
|
||||
}
|
||||
|
||||
|
||||
#
|
||||
# Release a unique ID.
|
||||
#
|
||||
sub mtr_release_unique_id($) {
|
||||
my ($myid)= @_;
|
||||
|
||||
msg("release, $myid");
|
||||
|
||||
|
||||
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";
|
||||
|
||||
msg("HAVE THE LOCK");
|
||||
|
||||
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 / /;
|
||||
msg(" taken, $id $pid");
|
||||
$taken{$id} = $pid;
|
||||
}
|
||||
|
||||
if ($taken{$myid} != $$)
|
||||
{
|
||||
msg(" The unique id for this process does not match pid");
|
||||
}
|
||||
|
||||
|
||||
msg(" removing $myid");
|
||||
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;
|
||||
|
||||
msg("RELEASE THE LOCK");
|
||||
|
||||
flock SEM, LOCK_UN or warn "can't unlock $file.sem";
|
||||
close SEM;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
27
mysql-test/lib/t/Base.t
Normal file
27
mysql-test/lib/t/Base.t
Normal file
@ -0,0 +1,27 @@
|
||||
# -*- cperl -*-
|
||||
use Test::More qw(no_plan);
|
||||
use strict;
|
||||
|
||||
use_ok ("My::SafeProcess::Base");
|
||||
|
||||
|
||||
my $count= 0;
|
||||
for (1..100){
|
||||
my $pid= My::SafeProcess::Base::_safe_fork();
|
||||
exit unless $pid;
|
||||
(waitpid($pid, 0) == $pid) and $count++;
|
||||
}
|
||||
ok($count == 100, "safe_fork");
|
||||
|
||||
# A nice little forkbomb
|
||||
SKIP: {
|
||||
skip("forkbomb", 1);
|
||||
eval {
|
||||
while(1){
|
||||
my $pid= My::SafeProcess::Base::_safe_fork();
|
||||
exit unless $pid;
|
||||
}
|
||||
};
|
||||
ok($@, "forkbomb");
|
||||
}
|
||||
|
||||
33
mysql-test/lib/t/Find.t
Normal file
33
mysql-test/lib/t/Find.t
Normal file
@ -0,0 +1,33 @@
|
||||
# -*- cperl -*-
|
||||
use Test::More qw(no_plan);
|
||||
use strict;
|
||||
|
||||
use_ok ("My::Find");
|
||||
my $basedir= "../..";
|
||||
|
||||
print "=" x 40, "\n";
|
||||
my $mysqld_exe= my_find_bin($basedir,
|
||||
["sql", "bin"],
|
||||
["mysqld", "mysqld-debug"]);
|
||||
print "mysqld_exe: $mysqld_exe\n";
|
||||
print "=" x 40, "\n";
|
||||
my $mysql_exe= my_find_bin($basedir,
|
||||
["client", "bin"],
|
||||
"mysql");
|
||||
print "mysql_exe: $mysql_exe\n";
|
||||
print "=" x 40, "\n";
|
||||
|
||||
my $mtr_build_dir= $ENV{MTR_BUILD_DIR};
|
||||
$ENV{MTR_BUILD_DIR}= "debug";
|
||||
my $mysql_exe= my_find_bin($basedir,
|
||||
["client", "bin"],
|
||||
"mysql");
|
||||
print "mysql_exe: $mysql_exe\n";
|
||||
$ENV{MTR_BUILD_DIR}= $mtr_build_dir;
|
||||
print "=" x 40, "\n";
|
||||
|
||||
my $charset_dir= my_find_dir($basedir,
|
||||
["share/mysql", "sql/share", "share"],
|
||||
"charsets");
|
||||
print "charset_dir: $charset_dir\n";
|
||||
print "=" x 40, "\n";
|
||||
127
mysql-test/lib/t/Options.t
Normal file
127
mysql-test/lib/t/Options.t
Normal file
@ -0,0 +1,127 @@
|
||||
|
||||
# -*- cperl -*-
|
||||
use Test::More qw(no_plan);
|
||||
use strict;
|
||||
|
||||
use_ok("My::Options");
|
||||
|
||||
my @tests=
|
||||
(
|
||||
[
|
||||
['--binlog-format=row', '--loose-skip-innodb', '--binlog-format=ms'],
|
||||
['--binlog-format=row', '--loose-skip-innodb', '--binlog-format=statement'],
|
||||
['--binlog-format=statement']
|
||||
],
|
||||
|
||||
[
|
||||
['--binlog-format=row', '--loose-skip-innodb', '--binlog-format=statement'],
|
||||
['--binlog-format=row', '--loose-skip-innodb', '--binlog-format=mixed'],
|
||||
['--binlog-format=mixed']
|
||||
],
|
||||
|
||||
[
|
||||
['--binlog-format=row', '--loose-skip-innodb', '--binlog-format=mixed'],
|
||||
['--binlog-format=row', '--loose-skip-innodb', '--binlog-format=statement'],
|
||||
['--binlog-format=statement']
|
||||
],
|
||||
|
||||
[
|
||||
['--binlog-format=mixed', '--loose-skip-innodb', '--binlog-format=row'],
|
||||
['--binlog-format=statement', '--loose-skip-innodb', '--binlog-format=row'],
|
||||
[ ]
|
||||
],
|
||||
|
||||
[
|
||||
['--binlog-format=row'],
|
||||
[ ],
|
||||
['--binlog-format=default']
|
||||
],
|
||||
|
||||
[
|
||||
[ ],
|
||||
['--binlog-format=row'],
|
||||
['--binlog-format=row']
|
||||
],
|
||||
|
||||
[
|
||||
[ ],
|
||||
['-O', 'max_binlog_size=1' ],
|
||||
['--max_binlog_size=1' ]
|
||||
],
|
||||
|
||||
[
|
||||
['-O', 'max_binlog_size=1' ],
|
||||
['-O', 'max_binlog_size=1' ],
|
||||
[ ],
|
||||
],
|
||||
|
||||
[
|
||||
['-O', 'max_binlog_size=1' ],
|
||||
[ ],
|
||||
['--max_binlog_size=default' ]
|
||||
],
|
||||
|
||||
[
|
||||
[ ],
|
||||
['-O', 'max_binlog_size=1', '--binlog-format=row' ],
|
||||
['--max_binlog_size=1', '--binlog-format=row' ]
|
||||
],
|
||||
[
|
||||
['--binlog-format=statement' ],
|
||||
['-O', 'max_binlog_size=1', '--binlog-format=row' ],
|
||||
['--max_binlog_size=1', '--binlog-format=row']
|
||||
],
|
||||
|
||||
[
|
||||
[ '--binlog-format=statement' ],
|
||||
['-O', 'max_binlog_size=1', '--binlog-format=statement' ],
|
||||
['--max_binlog_size=1' ]
|
||||
],
|
||||
|
||||
[
|
||||
[ '--binlog-format=statement' ],
|
||||
['-O', 'max_binlog_size=1', '--binlog-format=statement' ],
|
||||
['--max_binlog_size=1' ]
|
||||
],
|
||||
|
||||
[
|
||||
[ '--binlog-format=statement' ],
|
||||
['--relay-log=/path/to/a/relay-log', '--binlog-format=row'],
|
||||
['--relay-log=/path/to/a/relay-log', '--binlog-format=row' ]
|
||||
],
|
||||
|
||||
|
||||
[
|
||||
[ '--binlog-format=statement' ],
|
||||
['--relay-log=/path/to/a/relay-log', '-O', 'max_binlog_size=1'],
|
||||
['--max_binlog_size=1', '--relay-log=/path/to/a/relay-log', '--binlog-format=default' ]
|
||||
],
|
||||
|
||||
[
|
||||
[ '--slow-query-log=0' ],
|
||||
[ '--slow-query-log' ],
|
||||
[ '--slow-query-log' ]
|
||||
],
|
||||
|
||||
|
||||
);
|
||||
|
||||
|
||||
my $test_no= 0;
|
||||
foreach my $test (@tests){
|
||||
print "test", $test_no++, "\n";
|
||||
foreach my $opts (@$test){
|
||||
print My::Options::toStr("", @$opts);
|
||||
}
|
||||
my $from= $test->[0];
|
||||
my $to= $test->[1];
|
||||
my @result= My::Options::diff($from, $to);
|
||||
ok(My::Options::same(\@result, $test->[2]));
|
||||
if (!My::Options::same(\@result, $test->[2])){
|
||||
print "failed\n";
|
||||
print My::Options::toStr("result", @result);
|
||||
print My::Options::toStr("expect", @{$test->[2]});
|
||||
}
|
||||
print My::Options::toSQL(@result), "\n";
|
||||
print "\n";
|
||||
}
|
||||
18
mysql-test/lib/t/Platform.t
Normal file
18
mysql-test/lib/t/Platform.t
Normal file
@ -0,0 +1,18 @@
|
||||
# -*- cperl -*-
|
||||
use Test::More qw(no_plan);
|
||||
use strict;
|
||||
|
||||
use_ok ("My::Platform");
|
||||
use My::Platform;
|
||||
|
||||
use File::Temp qw / tempdir /;
|
||||
my $dir = tempdir( CLEANUP => 1 );
|
||||
|
||||
print "Running on Windows\n" if (IS_WINDOWS);
|
||||
print "Using ActiveState perl\n" if (IS_WIN32PERL);
|
||||
print "Using cygwin perl\n" if (IS_CYGWIN);
|
||||
|
||||
print "dir: '$dir'\n";
|
||||
print "native: '".native_path($dir)."'\n";
|
||||
print "mixed: '".mixed_path($dir)."'\n";
|
||||
print "posix: '".posix_path($dir)."'\n";
|
||||
102
mysql-test/lib/t/SafeProcess.t
Normal file
102
mysql-test/lib/t/SafeProcess.t
Normal file
@ -0,0 +1,102 @@
|
||||
# -*- cperl -*-
|
||||
|
||||
use strict;
|
||||
use FindBin;
|
||||
use IO::File;
|
||||
|
||||
use Test::More qw(no_plan);
|
||||
use_ok ("My::SafeProcess");
|
||||
|
||||
|
||||
my $perl_path= $^X;
|
||||
|
||||
{
|
||||
# Test exit codes
|
||||
my $count= 32;
|
||||
my $ok_count= 0;
|
||||
for my $code (0..$count-1) {
|
||||
|
||||
my $args= [ "$FindBin::Bin/test_child.pl", "--exit-code=$code" ];
|
||||
my $proc= My::SafeProcess->new
|
||||
(
|
||||
path => $perl_path,
|
||||
args => \$args,
|
||||
output => "/dev/null",
|
||||
error => "/dev/null",
|
||||
);
|
||||
# Wait max 10 seconds for the process to finish
|
||||
$ok_count++ if ($proc->wait_one(10) == 0 and
|
||||
$proc->exit_status() == $code);
|
||||
}
|
||||
ok($count == $ok_count, "check exit_status, $ok_count");
|
||||
}
|
||||
|
||||
|
||||
{
|
||||
# spawn a number of concurrent processes
|
||||
my $count= 16;
|
||||
my $ok_count= 0;
|
||||
my %procs;
|
||||
for my $code (0..$count-1) {
|
||||
|
||||
my $args= [ "$FindBin::Bin/test_child.pl", "--exit-code=$code" ];
|
||||
$procs{$code}= My::SafeProcess->new
|
||||
(
|
||||
path => $perl_path,
|
||||
args => \$args,
|
||||
output => "/dev/null",
|
||||
error => "/dev/null",
|
||||
);
|
||||
}
|
||||
|
||||
for my $code (0..$count-1) {
|
||||
$ok_count++ if ($procs{$code}->wait_one(10) == 0 and
|
||||
$procs{$code}->exit_status() == $code);
|
||||
}
|
||||
ok($count == $ok_count, "concurrent, $ok_count");
|
||||
}
|
||||
|
||||
|
||||
#
|
||||
# Test stdout, stderr
|
||||
#
|
||||
{
|
||||
use File::Temp qw / tempdir /;
|
||||
my $dir = tempdir( CLEANUP => 1 );
|
||||
|
||||
my $args= [ "$FindBin::Bin/test_child.pl" ];
|
||||
my $proc= My::SafeProcess->new
|
||||
(
|
||||
path => $perl_path,
|
||||
args => \$args,
|
||||
output => "$dir/output.txt",
|
||||
error => "$dir/error.txt",
|
||||
);
|
||||
|
||||
$proc->wait_one(2); # Wait max 2 seconds for the process to finish
|
||||
|
||||
my $fh= IO::File->new("$dir/output.txt");
|
||||
my @text= <$fh>;
|
||||
ok(grep(/Hello stdout/, @text), "check stdout");
|
||||
$fh= IO::File->new("$dir/error.txt");
|
||||
my @text= <$fh>;
|
||||
ok(grep(/Hello stderr/, @text), "check stderr");
|
||||
|
||||
# To same file
|
||||
$proc= My::SafeProcess->new
|
||||
(
|
||||
path => $perl_path,
|
||||
args => \$args,
|
||||
output => "$dir/output.txt",
|
||||
error => "$dir/output.txt",
|
||||
debug => 1,
|
||||
);
|
||||
|
||||
$proc->wait_one(2); # Wait max 2 seconds for the process to finish
|
||||
|
||||
my $fh= IO::File->new("$dir/output.txt");
|
||||
my @text= <$fh>;
|
||||
ok((grep(/Hello stdout/, @text) and grep(/Hello stderr/, @text)),
|
||||
"check stdout and stderr");
|
||||
|
||||
}
|
||||
149
mysql-test/lib/t/SafeProcessStress.pl
Executable file
149
mysql-test/lib/t/SafeProcessStress.pl
Executable file
@ -0,0 +1,149 @@
|
||||
#!/usr/bin/perl
|
||||
# -*- cperl -*-
|
||||
|
||||
use strict;
|
||||
use FindBin;
|
||||
use My::SafeProcess;
|
||||
|
||||
#
|
||||
# Test longterm running of SafeProcess
|
||||
#
|
||||
|
||||
my $perl_path= $^X;
|
||||
my $verbose= 0;
|
||||
my $loops= 100;
|
||||
|
||||
print "kill one and wait for one\n";
|
||||
for (1...$loops){
|
||||
use File::Temp qw / tempdir /;
|
||||
my $dir = tempdir( CLEANUP => 1 );
|
||||
|
||||
my @procs;
|
||||
for (1..10){
|
||||
|
||||
my $args= [ "$FindBin::Bin/dummyd.pl", "--vardir=$dir" ];
|
||||
my $proc= My::SafeProcess->new
|
||||
(
|
||||
path => $perl_path,
|
||||
args => \$args,
|
||||
verbose => $verbose,
|
||||
);
|
||||
push(@procs, $proc);
|
||||
}
|
||||
|
||||
foreach my $proc (@procs) {
|
||||
$proc->kill();
|
||||
# dummyd will always be killed and thus
|
||||
# exit_status should have been set to 1
|
||||
die "oops, exit_status: ", $proc->exit_status()
|
||||
unless $proc->exit_status() == 1;
|
||||
}
|
||||
|
||||
print "=" x 60, "\n";
|
||||
}
|
||||
|
||||
|
||||
print "With 1 second sleep in dummyd\n";
|
||||
for (1...$loops){
|
||||
use File::Temp qw / tempdir /;
|
||||
my $dir = tempdir( CLEANUP => 1 );
|
||||
|
||||
my @procs;
|
||||
for (1..10){
|
||||
|
||||
my $args= [ "$FindBin::Bin/dummyd.pl",
|
||||
"--vardir=$dir",
|
||||
"--sleep=1" ];
|
||||
my $proc= My::SafeProcess->new
|
||||
(
|
||||
path => $perl_path,
|
||||
args => \$args,
|
||||
verbose => $verbose,
|
||||
);
|
||||
push(@procs, $proc);
|
||||
}
|
||||
|
||||
foreach my $proc (@procs) {
|
||||
$proc->kill();
|
||||
}
|
||||
|
||||
print "=" x 60, "\n";
|
||||
}
|
||||
|
||||
print "kill all and wait for one\n";
|
||||
for (1...$loops){
|
||||
use File::Temp qw / tempdir /;
|
||||
my $dir = tempdir( CLEANUP => 1 );
|
||||
|
||||
my @procs;
|
||||
for (1..10){
|
||||
|
||||
my $args= [ "$FindBin::Bin/dummyd.pl", "--vardir=$dir" ];
|
||||
my $proc= My::SafeProcess->new
|
||||
(
|
||||
path => $perl_path,
|
||||
args => \$args,
|
||||
verbose => $verbose,
|
||||
);
|
||||
push(@procs, $proc);
|
||||
}
|
||||
|
||||
foreach my $proc (@procs) {
|
||||
$proc->start_kill();
|
||||
}
|
||||
|
||||
foreach my $proc (@procs) {
|
||||
$proc->wait_one();
|
||||
}
|
||||
|
||||
print "=" x 60, "\n";
|
||||
}
|
||||
|
||||
print "kill all using shutdown without callback\n";
|
||||
for (1...$loops){
|
||||
use File::Temp qw / tempdir /;
|
||||
my $dir = tempdir( CLEANUP => 1 );
|
||||
|
||||
my @procs;
|
||||
for (1..10){
|
||||
|
||||
my $args= [ "$FindBin::Bin/dummyd.pl", "--vardir=$dir" ];
|
||||
my $proc= My::SafeProcess->new
|
||||
(
|
||||
path => $perl_path,
|
||||
args => \$args,
|
||||
verbose => $verbose,
|
||||
);
|
||||
push(@procs, $proc);
|
||||
}
|
||||
|
||||
My::SafeProcess::shutdown(2, @procs);
|
||||
|
||||
print "=" x 60, "\n";
|
||||
}
|
||||
|
||||
print "kill all using shutdown\n";
|
||||
for (1...$loops){
|
||||
use File::Temp qw / tempdir /;
|
||||
my $dir = tempdir( CLEANUP => 1 );
|
||||
|
||||
my @procs;
|
||||
for (1..10){
|
||||
|
||||
my $args= [ "$FindBin::Bin/dummyd.pl", "--vardir=$dir" ];
|
||||
my $proc= My::SafeProcess->new
|
||||
(
|
||||
path => $perl_path,
|
||||
args => \$args,
|
||||
verbose => $verbose,
|
||||
shutdown => sub { }, # Does nothing
|
||||
);
|
||||
push(@procs, $proc);
|
||||
}
|
||||
|
||||
My::SafeProcess::shutdown(2, @procs);
|
||||
|
||||
print "=" x 60, "\n";
|
||||
}
|
||||
|
||||
exit(0);
|
||||
34
mysql-test/lib/t/copytree.t
Normal file
34
mysql-test/lib/t/copytree.t
Normal file
@ -0,0 +1,34 @@
|
||||
#!/usr/bin/perl
|
||||
# -*- cperl -*-
|
||||
|
||||
use strict;
|
||||
|
||||
use My::File::Path;
|
||||
|
||||
use Test::Simple tests => 7;
|
||||
use File::Temp qw / tempdir /;
|
||||
my $dir = tempdir( CLEANUP => 1 );
|
||||
my $testdir="$dir/test";
|
||||
my $test_todir="$dir/to";
|
||||
|
||||
my $subdir= "$testdir/test1/test2/test3";
|
||||
|
||||
#
|
||||
# 1. Create, copy and remove a directory structure
|
||||
#
|
||||
mkpath($subdir);
|
||||
ok( -d $subdir, "Check '$subdir' is created");
|
||||
|
||||
copytree($testdir, $test_todir);
|
||||
ok( -d $test_todir, "Check '$test_todir' is created");
|
||||
ok( -d "$test_todir/test1", "Check 'test1' is created");
|
||||
ok( -d "$test_todir/test1/test2", "Check 'test2' is created");
|
||||
ok( -d "$test_todir/test1/test2/test3", "Check 'test3' is created");
|
||||
|
||||
|
||||
rmtree($testdir);
|
||||
ok( ! -d $testdir, "Check '$testdir' is gone");
|
||||
|
||||
rmtree($test_todir);
|
||||
ok( ! -d $test_todir, "Check '$test_todir' is gone");
|
||||
|
||||
38
mysql-test/lib/t/dummyd.pl
Normal file
38
mysql-test/lib/t/dummyd.pl
Normal file
@ -0,0 +1,38 @@
|
||||
#!/usr/bin/perl
|
||||
# -*- cperl -*-
|
||||
|
||||
use strict;
|
||||
use Getopt::Long;
|
||||
use IO::File;
|
||||
|
||||
my $vardir;
|
||||
my $randie= 0;
|
||||
my $sleep= 0;
|
||||
GetOptions
|
||||
(
|
||||
# Directory where to write files
|
||||
'vardir=s' => \$vardir,
|
||||
'die-randomly' => \$randie,
|
||||
'sleep=i' => \$sleep,
|
||||
);
|
||||
|
||||
die("invalid vardir ") unless defined $vardir and -d $vardir;
|
||||
|
||||
my $pid= $$;
|
||||
while(1){
|
||||
for my $i (1..64){
|
||||
# Write to file
|
||||
my $name= "$vardir/$pid.$i.tmp";
|
||||
my $F= IO::File->new($name, "w")
|
||||
or warn "$$, Could not open $name: $!" and next;
|
||||
print $F rand($.) for (1..1000);
|
||||
$F->close();
|
||||
sleep($sleep);
|
||||
die "ooops!" if $randie and rand() < 0.0001
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
exit (0);
|
||||
|
||||
|
||||
52
mysql-test/lib/t/rmtree.t
Normal file
52
mysql-test/lib/t/rmtree.t
Normal file
@ -0,0 +1,52 @@
|
||||
#!/usr/bin/perl
|
||||
# -*- cperl -*-
|
||||
|
||||
use strict;
|
||||
|
||||
use My::File::Path;
|
||||
|
||||
use Test::Simple tests => 8;
|
||||
use File::Temp qw / tempdir /;
|
||||
my $dir = tempdir( CLEANUP => 1 );
|
||||
my $testdir="$dir/test";
|
||||
|
||||
my $subdir= "$testdir/test1/test2/test3";
|
||||
|
||||
#
|
||||
# 1. Create and remove a directory structure
|
||||
#
|
||||
mkpath($subdir);
|
||||
ok( -d $subdir, "Check '$subdir' is created");
|
||||
|
||||
rmtree($testdir);
|
||||
ok( ! -d $testdir, "Check '$testdir' is gone");
|
||||
|
||||
#
|
||||
# 2. Create and remove a directory structure
|
||||
# where one directory is chmod to 0000
|
||||
#
|
||||
mkpath($subdir);
|
||||
ok( -d $subdir, "Check '$subdir' is created");
|
||||
|
||||
ok( chmod(0000, $subdir) == 1 , "Check one dir was chmoded");
|
||||
|
||||
rmtree($testdir);
|
||||
ok( ! -d $testdir, "Check '$testdir' is gone");
|
||||
|
||||
#
|
||||
# 3. Create and remove a directory structure
|
||||
# where one file is chmod to 0000
|
||||
#
|
||||
mkpath($subdir);
|
||||
ok( -d $subdir, "Check '$subdir' is created");
|
||||
|
||||
my $testfile= "$subdir/test.file";
|
||||
open(F, ">", $testfile) or die;
|
||||
print F "hello\n";
|
||||
close(F);
|
||||
|
||||
ok( chmod(0000, $testfile) == 1 , "Check one file was chmoded");
|
||||
|
||||
rmtree($testdir);
|
||||
ok( ! -d $testdir, "Check '$testdir' is gone");
|
||||
|
||||
131
mysql-test/lib/t/testMyConfig.t
Executable file
131
mysql-test/lib/t/testMyConfig.t
Executable file
@ -0,0 +1,131 @@
|
||||
#!/usr/bin/perl
|
||||
# -*- cperl -*-
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use File::Temp qw / tempdir /;
|
||||
my $dir = tempdir( CLEANUP => 1 );
|
||||
|
||||
use Test::More qw(no_plan);
|
||||
|
||||
BEGIN { use_ok ( "My::Config" ) };
|
||||
|
||||
my $test_cnf= "$dir/test.cnf";
|
||||
|
||||
# Write test config file
|
||||
open(OUT, ">", $test_cnf) or die;
|
||||
print $test_cnf, "\n";
|
||||
|
||||
print OUT <<EOF
|
||||
[mysqld]
|
||||
# Comment
|
||||
option1=values2
|
||||
option2= value4
|
||||
option4
|
||||
basedir=thebasedir
|
||||
[mysqld_1]
|
||||
[mysqld_2]
|
||||
[mysqld.9]
|
||||
[client]
|
||||
socket =\tasocketpath
|
||||
EOF
|
||||
;
|
||||
close OUT;
|
||||
|
||||
my $config= My::Config->new($test_cnf);
|
||||
isa_ok( $config, "My::Config" );
|
||||
|
||||
print $config;
|
||||
|
||||
ok ( $config->group("mysqld_2"), "group mysqld_2 exists");
|
||||
ok ( $config->group("mysqld_1"), "group mysqld_1 exists");
|
||||
ok ( $config->group("mysqld.9"), "group mysqld.9 exists");
|
||||
ok ( $config->group("mysqld.9")->suffix() eq ".9", "group mysqld.9 has suffix .9");
|
||||
|
||||
ok ( $config->group("mysqld"), "group mysqld exists");
|
||||
ok ( $config->group("client"), "group client exists");
|
||||
ok ( !$config->group("mysqld_3"), "group mysqld_3 does not exist");
|
||||
|
||||
ok ( $config->options_in_group("mysqld") == 4, "options in [mysqld] is 4");
|
||||
ok ( $config->options_in_group("nonexist") == 0, "options in [nonexist] is 0");
|
||||
|
||||
{
|
||||
my @groups= $config->groups();
|
||||
ok(@groups == 5, "5 groups");
|
||||
my $idx= 0;
|
||||
foreach my $name ('mysqld', 'mysqld_1', 'mysqld_2', 'mysqld.9', 'client') {
|
||||
is($groups[$idx++]->name(), $name, "checking groups $idx");
|
||||
}
|
||||
}
|
||||
|
||||
{
|
||||
my @groups= $config->like("mysqld");
|
||||
ok(@groups == 4, "4 groups like mysqld");
|
||||
my $idx= 0;
|
||||
foreach my $name ('mysqld', 'mysqld_1', 'mysqld_2', 'mysqld.9') {
|
||||
is($groups[$idx++]->name(), $name, "checking like(\"mysqld\") $idx");
|
||||
}
|
||||
}
|
||||
|
||||
{
|
||||
my @groups= $config->like("not");
|
||||
ok(@groups == 0, "checking like(\"not\")");
|
||||
}
|
||||
|
||||
is($config->first_like("mysqld_")->name(), "mysqld_1", "first_like");
|
||||
|
||||
is( $config->value('mysqld', 'option4'), undef,
|
||||
"mysqld_option4 exists, does not have a value");
|
||||
|
||||
ok( $config->exists('mysqld', 'option4'),
|
||||
"mysqld_option4 exists");
|
||||
ok( $config->exists('mysqld', 'option2'),
|
||||
"mysqld_option2 exists");
|
||||
ok( !$config->exists('mysqld', 'option5'),
|
||||
"mysqld_option5 does not exists");
|
||||
|
||||
# Save the config to file
|
||||
my $test2_cnf= "$dir/test2.cnf";
|
||||
$config->save($test2_cnf);
|
||||
|
||||
# read it back and check it's the same
|
||||
my $config2= My::Config->new($test2_cnf);
|
||||
isa_ok( $config2, "My::Config" );
|
||||
is_deeply( \$config, \$config2, "test.cnf is equal to test2.cnf");
|
||||
|
||||
|
||||
my $test_include_cnf= "$dir/test_include.cnf";
|
||||
# Write test config file that includes test.cnf
|
||||
open(OUT, ">", $test_include_cnf) or die;
|
||||
|
||||
print OUT <<EOF
|
||||
[mysqld]
|
||||
!include test.cnf
|
||||
# Comment
|
||||
option1=values3
|
||||
basedir=anotherbasedir
|
||||
EOF
|
||||
;
|
||||
close OUT;
|
||||
|
||||
# Read the config file
|
||||
my $config3= My::Config->new($test_include_cnf);
|
||||
isa_ok( $config3, "My::Config" );
|
||||
print $config3;
|
||||
is( $config3->value('mysqld', 'basedir'), 'anotherbasedir',
|
||||
"mysqld_basedir has been overriden by value in test_include.cnf");
|
||||
|
||||
is( $config3->value('mysqld', 'option1'), 'values3',
|
||||
"mysqld_option1 has been overriden by value in test_include.cnf");
|
||||
|
||||
is( $config3->value('mysqld', 'option2'), 'value4',
|
||||
"mysqld_option2 is from included file");
|
||||
|
||||
is( $config3->value('client', 'socket'), 'asocketpath',
|
||||
"client.socket is from included file");
|
||||
|
||||
is( $config3->value('mysqld', 'option4'), undef,
|
||||
"mysqld_option4 exists, does not have a value");
|
||||
|
||||
print "$config3\n";
|
||||
|
||||
98
mysql-test/lib/t/testMyConfigFactory.t
Executable file
98
mysql-test/lib/t/testMyConfigFactory.t
Executable file
@ -0,0 +1,98 @@
|
||||
#!/usr/bin/perl
|
||||
# -*- cperl -*-
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use File::Temp qw / tempdir /;
|
||||
my $dir = tempdir( CLEANUP => 1 );
|
||||
|
||||
use Test::More qw(no_plan);
|
||||
|
||||
BEGIN { use_ok ( "My::ConfigFactory" ) };
|
||||
|
||||
my $gen1_cnf= "$dir/gen1.cnf";
|
||||
open(OUT, ">", $gen1_cnf) or die;
|
||||
|
||||
print OUT <<EOF
|
||||
[mysqld.master]
|
||||
# Comment
|
||||
option1=value1
|
||||
basedir=abasedir
|
||||
|
||||
[mysqld.1]
|
||||
# Comment
|
||||
option1=value1
|
||||
option2=value2
|
||||
|
||||
[ENV]
|
||||
MASTER_MY_PORT=\@mysqld.master.port
|
||||
|
||||
EOF
|
||||
;
|
||||
close OUT;
|
||||
|
||||
my $basedir= "../..";
|
||||
|
||||
my $config= My::ConfigFactory->new_config
|
||||
(
|
||||
{
|
||||
basedir => $basedir,
|
||||
template_path => $gen1_cnf,
|
||||
vardir => "/path/to/var",
|
||||
baseport => 10987,
|
||||
#hosts => [ 'host1', 'host2' ],
|
||||
}
|
||||
);
|
||||
|
||||
print $config;
|
||||
|
||||
ok ( $config->group("mysqld.master"), "group mysqld.master exists");
|
||||
ok ( $config->group("mysqld.1"), "group mysqld.1 exists");
|
||||
ok ( $config->group("client"), "group client exists");
|
||||
ok ( !$config->group("mysqld.3"), "group mysqld.3 does not exist");
|
||||
|
||||
ok ( $config->first_like("mysqld"), "group like 'mysqld' exists");
|
||||
|
||||
is( $config->value('mysqld.1', '#host'), 'localhost',
|
||||
"mysqld.1.#host has been generated");
|
||||
|
||||
is( $config->value('client', 'host'), 'localhost',
|
||||
"client.host has been generated");
|
||||
|
||||
is( $config->value('client', 'host'),
|
||||
$config->value('mysqld.master', '#host'),
|
||||
"client.host is same as mysqld.master.host");
|
||||
|
||||
ok ( $config->value("mysqld.1", 'character-sets-dir') =~ /$basedir.*charsets$/,
|
||||
"'character-sets-dir' generated");
|
||||
|
||||
ok ( $config->value("mysqld.1", 'language') =~ /$basedir.*english$/,
|
||||
"'language' generated");
|
||||
|
||||
ok ( $config->value("ENV", 'MASTER_MY_PORT') =~ /\d/,
|
||||
"'language' generated");
|
||||
|
||||
my $gen2_cnf= "$dir/gen2.cnf";
|
||||
open(OUT, ">", $gen2_cnf) or die;
|
||||
|
||||
print OUT <<EOF
|
||||
[mysqld.master]
|
||||
EOF
|
||||
;
|
||||
close OUT;
|
||||
|
||||
my $config2= My::ConfigFactory->new_config
|
||||
(
|
||||
{
|
||||
basedir => $basedir,
|
||||
template_path => $gen2_cnf,
|
||||
vardir => "/path/to/var",
|
||||
baseport => 10987,
|
||||
#hosts => [ 'host1', 'host2' ],
|
||||
}
|
||||
);
|
||||
|
||||
print $config2;
|
||||
|
||||
ok ( $config2->first_like("mysqld"), "group like 'mysqld' exists");
|
||||
21
mysql-test/lib/t/test_child.pl
Executable file
21
mysql-test/lib/t/test_child.pl
Executable file
@ -0,0 +1,21 @@
|
||||
#!/usr/bin/perl
|
||||
# -*- cperl -*-
|
||||
|
||||
use strict;
|
||||
use Getopt::Long;
|
||||
|
||||
my $opt_exit_code= 0;
|
||||
|
||||
GetOptions
|
||||
(
|
||||
# Exit with the specified exit code
|
||||
'exit-code=i' => \$opt_exit_code
|
||||
);
|
||||
|
||||
|
||||
print "Hello stdout\n";
|
||||
print STDERR "Hello stderr\n";
|
||||
|
||||
exit ($opt_exit_code);
|
||||
|
||||
|
||||
422
mysql-test/lib/v1/My/Config.pm
Normal file
422
mysql-test/lib/v1/My/Config.pm
Normal file
@ -0,0 +1,422 @@
|
||||
# -*- 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;
|
||||
@ -369,7 +369,7 @@ sub collect_one_suite($)
|
||||
my $comb= {};
|
||||
$comb->{name}= $group->name();
|
||||
foreach my $option ( $group->options() ) {
|
||||
push(@{$comb->{comb_opt}}, $option->name()."=".$option->value());
|
||||
push(@{$comb->{comb_opt}}, "--".$option->name()."=".$option->value());
|
||||
}
|
||||
push(@combinations, $comb);
|
||||
}
|
||||
@ -511,10 +511,19 @@ sub collect_one_test_case($$$$$$$$$) {
|
||||
my $suite_opts= shift;
|
||||
|
||||
my $path= "$testdir/$elem";
|
||||
my $name= basename($suite) . ".$tname";
|
||||
|
||||
# ----------------------------------------------------------------------
|
||||
# Skip some tests silently
|
||||
# ----------------------------------------------------------------------
|
||||
|
||||
if ( $::opt_start_from and $tname lt $::opt_start_from )
|
||||
{
|
||||
return;
|
||||
}
|
||||
|
||||
|
||||
my $tinfo= {};
|
||||
$tinfo->{'name'}= $name;
|
||||
$tinfo->{'name'}= basename($suite) . ".$tname";
|
||||
$tinfo->{'result_file'}= "$resdir/$tname.result";
|
||||
$tinfo->{'component_id'} = $component_id;
|
||||
push(@$cases, $tinfo);
|
||||
@ -523,7 +532,7 @@ sub collect_one_test_case($$$$$$$$$) {
|
||||
# Skip some tests but include in list, just mark them to skip
|
||||
# ----------------------------------------------------------------------
|
||||
|
||||
if ( $skip_test and ($tname =~ /$skip_test/o || $name =~ /$skip_test/o))
|
||||
if ( $skip_test and $tname =~ /$skip_test/o )
|
||||
{
|
||||
$tinfo->{'skip'}= 1;
|
||||
return;
|
||||
74
mysql-test/lib/v1/mtr_gcov.pl
Normal file
74
mysql-test/lib/v1/mtr_gcov.pl
Normal file
@ -0,0 +1,74 @@
|
||||
# -*- 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;
|
||||
64
mysql-test/lib/v1/mtr_gprof.pl
Normal file
64
mysql-test/lib/v1/mtr_gprof.pl
Normal file
@ -0,0 +1,64 @@
|
||||
# -*- 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;
|
||||
218
mysql-test/lib/v1/mtr_io.pl
Normal file
218
mysql-test/lib/v1/mtr_io.pl
Normal file
@ -0,0 +1,218 @@
|
||||
# -*- 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;
|
||||
312
mysql-test/lib/v1/mtr_misc.pl
Normal file
312
mysql-test/lib/v1/mtr_misc.pl
Normal file
@ -0,0 +1,312 @@
|
||||
# -*- 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;
|
||||
1142
mysql-test/lib/v1/mtr_process.pl
Normal file
1142
mysql-test/lib/v1/mtr_process.pl
Normal file
File diff suppressed because it is too large
Load Diff
@ -220,7 +220,7 @@ sub mtr_report_stats ($) {
|
||||
# the "var/log/*.err" files. We save this info in "var/log/warnings"
|
||||
# ----------------------------------------------------------------------
|
||||
|
||||
if ( ! $::glob_use_running_server && !$::opt_extern)
|
||||
if ( ! $::glob_use_running_server )
|
||||
{
|
||||
# Save and report if there was any fatal warnings/errors in err logs
|
||||
|
||||
@ -376,29 +376,30 @@ sub mtr_report_stats ($) {
|
||||
/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_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
|
||||
# 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
|
||||
|
||||
@ -411,18 +412,8 @@ sub mtr_report_stats ($) {
|
||||
|
||||
# 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./ or
|
||||
|
||||
# maria-recovery.test has warning about missing log file
|
||||
/File '.*maria_log.000.*' not found \(Errcode: 2\)/ or
|
||||
# and about marked-corrupted table
|
||||
/Table '..mysqltest.t_corrupted1' is crashed, skipping it. Please repair it with maria_chk -r/ or
|
||||
# maria-recover.test corrupts tables on purpose
|
||||
/Checking table: '..mysqltest.t_corrupted2'/ or
|
||||
/Recovering table: '..mysqltest.t_corrupted2'/ or
|
||||
/Table '..mysqltest.t_corrupted2' is marked as crashed and should be repaired/ or
|
||||
/Incorrect key file for table '..mysqltest.t_corrupted2.MAI'; try to repair it/
|
||||
)
|
||||
/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
|
||||
}
|
||||
191
mysql-test/lib/v1/mtr_stress.pl
Normal file
191
mysql-test/lib/v1/mtr_stress.pl
Normal file
@ -0,0 +1,191 @@
|
||||
# -*- 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;
|
||||
5393
mysql-test/lib/v1/mysql-test-run.pl
Executable file
5393
mysql-test/lib/v1/mysql-test-run.pl
Executable file
File diff suppressed because it is too large
Load Diff
47
mysql-test/lib/v1/ndb_config_1_node.ini
Normal file
47
mysql-test/lib/v1/ndb_config_1_node.ini
Normal file
@ -0,0 +1,47 @@
|
||||
[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]
|
||||
55
mysql-test/lib/v1/ndb_config_2_node.ini
Normal file
55
mysql-test/lib/v1/ndb_config_2_node.ini
Normal file
@ -0,0 +1,55 @@
|
||||
[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]
|
||||
Reference in New Issue
Block a user