#!/usr/bin/perl
use warnings;
use strict;
use utf8;
use open qw(:std :utf8);
use lib qw(lib ../lib);
use lib qw(blib/lib blib/arch ../blib/lib ../blib/arch);
use lib qw(st);
use Coro;
use DR::Tarantool::StartTest;
use DR::Tarantool;
use Carp;
use File::Spec::Functions 'catfile', 'rel2abs';
use File::Basename 'dirname', 'basename';
use POSIX;
use UUID;
use Scalar::Util;
use FindBin;
use Coro::AnyEvent;
use AnyEvent;
use Encode qw(decode_utf8);
use feature 'state';
use Data::Dumper;
use Getopt::Long;
use Pod::Usage;
our $tarantool;
our $errors = 0;
my $verbose;
sub cfg($) {
state $cfg;
state %cache;
unless ($cfg) {
my $name = rel2abs catfile $FindBin::Bin, 'stress.cfg';
die "File $name is not found\n" unless -r $name;
$cfg = do $name;
die if $@;
}
my $path = shift;
return $cache{$path} if exists $cache{$path};
my @spath = split /\./, $path;
my $o = $cfg;
for (@spath) {
croak "Path $path is not found in config file" unless exists $o->{ $_ };
$o = $o->{ $_ };
}
return $cache{$path} = $o;
}
sub df($;@) {
return unless $verbose;
my ($fmt, @args) = @_;
$fmt =~ s/\s*$/\n/;
unshift @args => $$;
unshift @args => POSIX::strftime '%d/%m %H:%M:%S' => localtime;
return printf '%s (%s) ' . $fmt, @args;
}
sub uuid() {
UUID::generate my $uuid;
$uuid =~ s/./sprintf '%02x', ord $&/ge;
return $uuid;
}
sub tnt() {
state (@process, $tnt);
unless($tnt) {
if (@process) {
push @process => $Coro::current;
Coro::schedule;
} else {
push @process => $Coro::current;
$tnt = coro_tarantool
host => '127.0.0.1',
port => $tarantool->primary_port,
spaces => {
0 => {
name => 'one_hash',
default_type => 'STR',
fields => [
'id',
'value',
],
indexes => {
0 => {
name => 'id',
fields => [ 'id' ],
}
}
},
1 => {
name => 'one_tree',
default_type => 'STR',
fields => [
'id',
'value',
],
indexes => {
0 => {
name => 'id',
fields => [ 'id' ],
}
}
},
5 => {
name => 'orders',
default_type => 'UTF8STR',
fields => [
'oid',
'pid',
'oid_in_pid',
'time',
'status',
'sid',
'did',
'rating',
'feedback',
'driver_xml',
'xml',
],
indexes => {
0 => {
name => 'oid',
fields => 'oid',
},
1 => {
name => 'parent',
fields => [ 'pid', 'oid_in_pid' ],
},
2 => {
name => 'time',
fields => 'time'
},
3 => {
name => 'status',
fields => [ 'status', 'sid' ]
},
4 => {
name => 'driver',
fields => [ 'did', 'status' ]
},
}
},
}
;
while(my $coro = shift @process) {
next if $coro == $Coro::current;
$coro->ready;
}
}
}
return $tnt;
}
sub error($$;@) {
my ($cond, $name, @args) = @_;
return $cond unless $cond;
$errors++;
df 'Error ' . $name, @args;
return $cond;
}
pod2usage() unless GetOptions
'help|h' => \my $help,
'verbose|v' => \$verbose,
'timeout|t=i' => \my $timeout,
'forks|f=i' => \my $forks,
;
pod2usage(-verbose => 2) if $help;
$timeout ||= 120;
my $primary_pid = $$;
{
my $cfg = rel2abs catfile $FindBin::Bin, 'stress.tarantool.cfg';
$tarantool = DR::Tarantool::StartTest->run(
cfg => $cfg,
script_dir => rel2abs $FindBin::Bin,
);
unless ($tarantool->started) {
df "Can't start tarantool\n%s", $tarantool->log;
exit -1;
}
}
my @child;
df 'Started main process %s', $primary_pid;
$SIG{CHLD} = 'none';
for (1 .. $forks // cfg 'forks') {
my $pid = fork;
unless ($pid) {
@child = ();
last;
}
push @child => $pid;
}
my $coro = $Coro::current;
$SIG{INT} = $SIG{TERM} = $SIG{__DIE__} = sub {
if ($$ == $primary_pid) {
$tarantool->kill('KILL') if $tarantool;
df 'Exit loop';
df '%s', $tarantool->log if $tarantool;
kill TERM => $_ for @child;
}
error 1, 'Signal or exception was caught';
$coro->ready;
$coro->cede_to;
};
my @checks = glob catfile 'st', 'Check', '*.pm';
die "Can't find any check in st/Check" unless @checks;
for (@checks) {
my $cname = basename $_ => '.pm';
my $name = "Check::$cname";
df 'try to init module %s', $name;
unless (cfg sprintf 'check.%s.enabled', lc $cname) {
df ' -- %s is disabled by config, skipping...', $cname;
next;
}
{
no strict 'refs';
if (cfg sprintf 'check.%s.verbose', lc $cname) {
*{ $name . '::df' } = sub ($;@) {
my $fmt = shift;
$fmt = "$cname: $fmt";
unshift @_ => $fmt;
goto \&df;
};
} else {
*{ $name . '::df' } = sub { };
}
*{ $name . '::error' } = sub {
my ($cond, $name, @args) = @_;
return error $cond, "%s $name", $cname, @args;
};
*{ $name . '::uuid' } = \&uuid;
*{ $name . '::tnt' } = \&tnt;
*{ $name . '::cfg' } = \&cfg;
*{ $name . '::now' } = \&AnyEvent::now;
}
eval "require $name;";
die if $@;
die "There is no finction $name\->start" unless $name->can('start');
df "starting check process $name\->start";
async {
eval { $name->start($tarantool, $primary_pid) };
df 'Unexpected process "%s" shutdown: %s',
$name, decode_utf8($@ // 'no errors');
kill INT => $$;
};
}
async {
Coro::AnyEvent::sleep $timeout;
$coro->ready;
};
Coro::schedule;
for (@child) {
waitpid $_, 0;
error $?, 'Child %s returns non-zero code: %s', $_, $?;
}
$tarantool->kill('KILL') if $$ ~~ $primary_pid;
df 'There were %s errors total', $errors;
exit($errors && 1);
=head1 NAME
stress.pl - stress test for L<tarantool|http://tarantool.org>
=head1 SYNOPSIS
perl stress.pl [ OPTIONS ]
=head2 OPTIONS
=over
=item -h | --help
Display helpscreen
=item -v | --verbose
Enable verbose while running
=item -t | --timeout SECONDS
How long the test must be started. Default: 120 seconds.
=back
=cut