Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

executable file 380 lines (324 sloc) 8.976 kb
#! /usr/bin/env perl
use strict;
use warnings;
use Time::localtime;
use File::stat;
use Henzell::Cmd;
$ENV{HENZELL_SQL_QUERIES} = 'y';
$ENV{HENZELL_TEST} = 'y';
require 'sqllog.pl';
my $DB_DIRTY;
my $DBNAME = 'henzell_test';
my $DBUSER = 'henzell';
my $DBPASS = '';
$ENV{'HENZELL_DBNAME'} = $DBNAME;
$ENV{'HENZELL_DBUSER'} = $DBUSER;
$ENV{'HENZELL_DBPASS'} = $DBPASS;
new_db_handle($DBNAME, $DBUSER, $DBPASS) && initialize_sqllog();
my $SCHEMAFILE = 'henzell.sql';
my $TESTFILE = 'testcmd.txt';
my $TESTLOG = 'test.log';
my $TESTDIR = 'tests';
my $DATADIR = "$TESTDIR/data";
my @LOGFILES = qw/remote.cdo-logfile-svn remote.cdo-logfile-spr
remote.cdo-logfile-zd/;
my @MILEFILES = qw/remote.cdo-milestones-svn
remote.cdo-milestones-spr
remote.cdo-milestones-zd/;
my @COMMAND_FILES = ('commands/commands-henzell.txt',
'commands/commands-sequell.txt');
my @FAILED_TESTS;
my @OK_TESTS;
my $TESTNICK = 'hyperbolic';
my $TIMESTAMP_QUERY = <<QUERY;
SELECT last_update FROM canary;
QUERY
sub announce($) {
print STDERR "* ", @_, "\n";
}
sub test_ok($) {
my $test = shift;
push @OK_TESTS, $test;
}
sub test_failed($$) {
my ($test, $failure) = @_;
push @FAILED_TESTS, { test => $test, failure => $failure };
}
sub datafile_logs() {
@LOGFILES
}
sub datafile_milestones() {
@MILEFILES
}
sub datafiles() {
(datafile_logs(), datafile_milestones())
}
sub datafile_path($) {
"$DATADIR/" . shift
}
sub datafile_hashrefs(@) {
map({ file => datafile_path($_),
path => datafile_path($_),
src => 'cdo' },
@_)
}
sub check_datafiles_exist() {
for my $file (map(datafile_path($_), datafiles())) {
die "Cannot find data file \"$file\"\n" unless -r $file;
}
}
sub datafiles_newest_time() {
my $newest;
for my $file (map(datafile_path($_), datafiles())) {
my $mtime = stat($file)->mtime;
$newest = $mtime if !$newest || $mtime > $newest;
}
$newest = time_to_dbdate(localtime($newest)) if $newest;
$newest
}
sub with_db(&) {
my $sub = shift;
my $db = new_db_handle($DBNAME, $DBUSER, $DBPASS);
my $result = $sub->($db);
$db->disconnect;
$result
}
sub db_schema_missing() {
my $schema_missing = with_db {
my $dbh = shift;
!$dbh->selectall_arrayref($TIMESTAMP_QUERY);
};
announce "DB schema is missing or incomplete" if $schema_missing;
$schema_missing
}
sub db_canary_time() {
with_db {
my $dbh = shift;
my $ref = $dbh->selectall_arrayref($TIMESTAMP_QUERY);
return $ref && @$ref? $ref->[0][0] : undef;
}
}
sub execute_statement($$@) {
my ($dbh, $text, @values) = @_;
my $st = $dbh->prepare_cached($text)
or die "Malformed statement: $text\n";
$st->execute(@values);
$st
}
sub db_canary_set_time() {
with_db {
my $dbh = shift;
$dbh->do("DELETE FROM canary");
execute_statement($dbh, "INSERT INTO canary (last_update) VALUES (?)",
time_to_dbdate(localtime()));
}
}
sub db_timestamp_stale {
my $canary_time = db_canary_time();
my $datafiles_newest_time = datafiles_newest_time();
if ($canary_time && $datafiles_newest_time &&
$datafiles_newest_time gt $canary_time)
{
announce("DB $DBNAME needs update: last updated: $canary_time, " .
"newest datafile: $datafiles_newest_time")
}
!$canary_time || $datafiles_newest_time gt $canary_time
}
sub db_load_schema() {
announce "Rebuilding schema from $SCHEMAFILE";
with_db {
my $dbh = shift;
my $sql_ddl = do { local (@ARGV, $/) = $SCHEMAFILE; <> };
my @ddl_statements = split(/;/, $sql_ddl);
for my $statement (@ddl_statements) {
$dbh->do($statement)
or die "Failed to load schema: error $! on $statement\n";
}
};
}
sub db_load_data() {
with_db {
my $dbh = shift;
my $timestamp = localtime();
for my $logfile (open_handles(datafile_hashrefs(datafile_logs()))) {
announce "Loading logfile data from $$logfile{file}";
sql_register_logfiles($logfile->{file});
cat_logfile($logfile);
}
for my $milestone (open_handles(datafile_hashrefs(datafile_milestones()))) {
announce "Loading milestone data from $$milestone{file}";
sql_register_milestones($milestone->{file});
cat_stonefile($milestone);
}
};
}
sub time_to_dbdate($) {
my $time = shift;
sprintf("%04d-%02d-%02d %02d:%02d:%02d",
$time->year() + 1900,
$time->mon() + 1,
$time->mday(),
$time->hour(),
$time->min(),
$time->sec())
}
sub dbdate_to_time($) {
my $dbdate = shift;
print "DB date: $dbdate\n";
$dbdate
}
sub build_test_db() {
$DB_DIRTY = db_schema_missing() || db_timestamp_stale();
if ($DB_DIRTY) {
announce "Database needs update";
db_load_schema();
db_load_data();
db_canary_set_time();
}
}
sub trim($) {
my $text = shift;
s/^\s+//, s/\s+$// for $text;
$text
}
sub parse_test($) {
my %test;
my $text = shift;
if ($text =~ /^\$\s*(.*)/) {
$test{shell} = $1;
return \%test;
}
if ($text =~ s/^E\s+(.*)/$1/) {
$test{err} = 1;
}
die "Malformed test line\n" unless $text =~ /\S/;
my ($cmd) = $text =~ /^(\S+)/;
die "Unknown command $cmd in test '$text'\n"
unless Henzell::Cmd::command_exists($cmd);
$test{cmd} = $cmd;
if ($text =~ /::(!?)~(.*)/) {
my $key = $1? 'regex_not_match' : 'regex_match';
$test{$key} = trim($2);
}
if ($text =~ /::(!?)=(.*)/) {
my $key = $1? 'exact_not_match' : 'exact_match';
$test{$key} = trim($2);
}
$text =~ s/\s+::!?[~=].*//;
$test{line} = $text;
\%test
}
sub read_tests() {
my $file = "tests/$TESTFILE";
open my $inf, '<', $file or die "Can't read tests from $file: $!\n";
my @tests;
while (<$inf>) {
chomp;
s/^\s+//, s/\s+$//;
next if /^#/;
next unless /\S/;
push @tests, parse_test($_);
}
@tests
}
sub execute_cmd($) {
Henzell::Cmd::execute_cmd($TESTNICK, shift)
}
sub execute_test($$) {
my ($test, $logf) = @_;
if ($$test{shell}) {
my $output = qx/$$test{shell} 2>&1/;
print $logf <<TESTREPORT;
SHELL EXEC: $$test{shell}
Output:
$output
TESTREPORT
return;
}
my ($exitcode, $output, $cmd) = execute_cmd($$test{line});
chomp $output;
$$test{cmdline} = $cmd;
print $logf <<TESTREPORT;
-----------------------------------------------------------------------
$$test{line}::
Command line: $cmd
Exit code: $exitcode
Output:
$output
TESTREPORT
my $err =
$exitcode && !$$test{err}? "$cmd error:\n$output\n" :
$$test{regex_match} && $output !~ /$$test{regex_match}/m?
("Output '$output' does not contain expected match: " .
"$$test{regex_match}: $output") :
$$test{regex_not_match} && $output =~ /$$test{regex_not_match}/m?
("Output '$output' contains forbidden match: " .
"$$test{regex_not_match}: $output") :
$$test{exact_match} && $output ne $$test{exact_match}?
("Output '$output' does not exactly equal " .
"expected '$$test{exact_match}': $output") :
$$test{exact_not_match} && $output eq $$test{exact_not_match}?
("Output equals forbidden output '$$test{exact_not_match}" .
": $output") :
'';
if ($err) {
print $logf "Error: $err\n";
test_failed($test, $err);
return;
}
print $logf "TEST SUCCESS\n";
test_ok($test);
}
sub test_failure_report($) {
my $failure = shift;
my $test = $failure->{test};
my $err = $failure->{failure};
my $header = "--------------------------------------------------";
return ("$header\nTest: $$test{line}\nCommand line: $$test{cmdline}"
. "\nError: $err\n$header\n");
}
sub test_summary($) {
my $logf = shift;
print $logf <<ENDBANNER;
============================================================================
ENDBANNER
my $ok = @OK_TESTS;
my $fail = @FAILED_TESTS;
my $total = $ok + $fail;
print $logf "$total tests executed, $fail failures, $ok successful.\n";
if ($fail) {
print $logf "Failing tests:\n" . join("\n",
map(test_failure_report($_),
@FAILED_TESTS)) . "\n";
}
print $logf <<ENDBANNER2;
============================================================================
ENDBANNER2
}
sub matches_argv_filter($) {
my $test = shift;
return scalar(grep($$test{line} =~ /^\Q$_/, @ARGV));
}
sub filter_tests(@) {
my @tests = @_;
return @tests unless @ARGV;
grep($$_{shell} || matches_argv_filter($_), @tests)
}
sub run_tests() {
Henzell::Cmd::load_all_commands();
my @tests = filter_tests(read_tests());
announce "Running " . scalar(@tests) . " tests";
open my $logf, '>', $TESTLOG or die "Can't write $TESTLOG: $!\n";
for my $test (@tests) {
execute_test($test, $logf);
}
test_summary($logf);
test_summary(\*STDERR);
}
sub main() {
check_datafiles_exist();
build_test_db();
run_tests();
exit(!!scalar(@FAILED_TESTS));
}
main();
Jump to Line
Something went wrong with that request. Please try again.