Bivio::Test::Util
# Copyright (c) 2001-2010 bivio Software, Inc. All Rights reserved.
# $Id$
package Bivio::Test::Util;
use strict;
use Bivio::Base 'Bivio.ShellUtil';
use File::Find ();
use File::Spec ();
use File::Basename ();
# C<Bivio::Test::Util> runs acceptance and unit tests. A unit test is defined
# using L<Bivio::Test|Bivio::Test>. An acceptance test has its own language,
# which is a subclass of L<Bivio::Test::Language|Bivio::Test::Language>.
our($_TRACE);
b_use('IO.Trace');
my($_DT) = b_use('Type.DateTime');
my($_D) = b_use('Bivio.Die');
my($_PERL_DIR) = '/perl';
my($_WN) = b_use('Type.WikiName');
b_use('IO.Config')->register(my $_CFG = {
nightly_output_dir => '/tmp/test-run',
nightly_cvs_dir => 'perl/Bivio',
unit_log_dir => 'log',
});
my($_F) = b_use('IO.File');
sub USAGE {
# Returns usage.
return <<'EOF';
usage: b-test [options] command [args...]
commands:
acceptance tests/dirs... - runs the tests (*.btest) under Bivio::Test::Language
mock_sendmail -ffrom@email.com recipient1,recipient2,... -- bypasses MTA for acceptance tests
nightly -- runs all acceptance tests with current tests from VC
remote_trace [named_filters] -- turn on tracing on a server
task name query path_info facade -- executes task in context supplied returns output
unit tests/dirs... -- runs the tests (*.t) and print cummulative results
EOF
}
sub acceptance {
my($self, $tests) = _find_files(\@_, qr{\.btest$});
# Executes I<test>(s) under L<Bivio::Test::Language|Bivio::Test::Language>.
# I<test> may be a directory or file name. If it is a directory, all tests
# (C<*.btest>) files will be executed. All tests must end in C<*.btest>.
#
# When only one test is run, shows the output of the test.
return _run($self, $tests, sub {
my($self, $test, $out) = @_;
my($ok) = 0;
_piped_exec($self, '-', <<"EOF", $out,
use strict;
use Bivio::IO::ClassLoader;
print "1..1\n";
my(\$die) = Bivio::IO::ClassLoader->map_require('Test.Language')->test_run(qw{$test});
print(\$die ? "1 not ok: " . \$die->as_string . "\n" : "1 ok\n");
EOF
sub {
my($line) = @_;
$ok++ if $line eq "1 ok";
},
);
return $ok;
});
}
sub handle_config {
my(undef, $cfg) = @_;
# nightly_output_dir : string ['/tmp/test-run'],
#
# Root directory of the run. A subdirectory will be created with the timestamp
# of the run. Assumes "perl" subdirectory is PERLLIB (see code, sorry for the
# hack).
#
# nightly_cvs_dir : string ['perl/Bivio'],
#
# The directory to checkout of cvs, which contains the source and the code.
$_CFG = $cfg;
return;
}
sub mock_sendmail {
my($self, $from, $recipients, $recursing) = @_;
# You need to create the directory:
#
# ~/btest-mail
#
# (default for Bivio::Test::Language::HTTP.mail_dir) and
# have a ~/.procmailrc:
#
# EXTENSION="$1"
# :0
# * EXTENSION ?? btest
# btest-mail/.
my($in) = $self->read_input;
unless ($recursing) {
my($pid) = fork;
die("fork: $!")
unless defined($pid);
return if $pid;
}
my($req) = $self->initialize_fully;
unless ($from =~ s/^-f//) {
$recipients = $from;
$from = undef;
}
_trace($in) if $_TRACE;
my($msg) = b_use('Mail.Outgoing')
->new(b_use('Mail.Incoming')->new($in))
->add_missing_headers($req, $from);
$msg->set_header('Return-Path', $from)
if $from;
foreach my $r (split(/,/, lc($recipients))) {
(my $email = $r) =~ s/\+([^\@]+)//;
my($extension) = $1 || '';
$msg->set_recipients($r, $req);
my($die);
return b_warn($r, ': ', $die)
unless my $http = $_D->catch_quietly(
sub {_uri_for_task($self, 'MAIL_RECEIVE_DISPATCH', $r)},
\$die,
);
$http =~ s{^https?://}{};
$http .= '/%s';
my($res) = $self->piped_exec(
"b-sendmail-http 127.0.0.1 '$r' '$http'"
. " /usr/bin/procmail -t -Y -a '$extension' -d '$email' 2>&1",
$msg->as_string,
1,
);
chomp($$res);
next
unless $$res;
b_warn(
$msg->unsafe_get_header('from'),
' -> ',
$r,
': DELIVERY FAILED: ',
$res,
);
_trace($msg) if $_TRACE;
next
if $recursing;
$r = (b_use('Mail.Address')->parse(
$msg->unsafe_get_header('errors-to')
|| $msg->unsafe_get_header('return-path')
|| $from
|| $msg->unsafe_get('From')
|| next
))[0];
$self->put(
input => $msg->format_as_bounce($$res, undef, undef, $r, $req),
);
$self->mock_sendmail('-f' . $req->format_email('mailer-daemon'), $r, 1);
}
CORE::exit(0)
unless $recursing;
return;
}
sub nightly {
# accepts first argument (name of test), but ignores
my($self) = @_;
# Creates test directory, calls cvs update to get latest test files. Runs all
# acceptance tests. Output is to STDERR.
my($f) = b_use('IO.File');
my($old_pwd) = $f->pwd;
_expunge($self);
_make_nightly_dir($self);
$ENV{PERLLIB} = $f->pwd . $_PERL_DIR
. ($ENV{PERLLIB} ? ":$ENV{PERLLIB}" : '');
my($die) = $_D->catch(sub {
# VC checkout
(my $bop = $_CFG->{nightly_cvs_dir}) =~ s{\w+$}{Bivio};
# Bivio/PetShop special case
#TODO: Move Bivio/PetShop to PetShop
my($is_petshop) = $bop =~ s{Bivio/Bivio}{Bivio};
system('bivio', 'vc', 'checkout', $_CFG->{nightly_cvs_dir});
system('bivio', 'vc', 'checkout', $bop);
$self->print("Completed VC checkout of test files\n");
$f->chdir($_CFG->{nightly_cvs_dir});
$self->print("cd " . $f->pwd . "\n");
$self->print("export PERLLIB=$ENV{PERLLIB}\n");
$self->print("export BCONF=$ENV{BCONF}\n");
$self->print("bivio test acceptance .\n");
my($acc_die) = $_D->catch(sub {
$self->print($self->acceptance('.'));
return;
});
if ($is_petshop) {
$f->chdir('..');
}
my($bconf) = $ENV{BCONF};
$ENV{BCONF} =~ s|\.bconf$|-bunit\.bconf|;
$self->print("bivio test unit .\n");
my($unit_die) = $_D->catch(sub {
$self->print($self->unit('.'));
return;
});
$ENV{BCONF} = $bconf;
$acc_die->throw
if $acc_die;
$unit_die->throw
if $unit_die;
return;
});
# restore state before die is rethrown
$f->chdir($old_pwd);
$die->throw
if $die;
return;
}
sub nightly_output_to_wiki {
my($self, $msg) = @_;
$self->initialize_fully;
$msg ||= $self->read_input;
my($q) = {path => $_WN->to_absolute('NightlyTestOutput')};
my($rf) = $self->model('RealmFile');
my($curr) = "\@h1 NightlyTestOutput\n";
my($method) = 'create_with_content';
if ($rf->unsafe_load($q)) {
$curr = ${$rf->get_content};
$method = 'update_with_content';
}
my($which, $date);
my($result) = {};
my($file) = {};
foreach my $line (split(/\n/, ref($msg) ? $$msg : $msg)) {
if ($line =~ m{^Created .*/([^/]+)/(\d+)$}is) {
($which, $date) = ($1, $self->convert_literal(DateTime => $2));
}
elsif (!$which) {
next;
}
elsif ($line =~ m{^\s*(\S+): (PASSED|FAILED)$}is) {
my($t, $r) = ($1, $2);
$file->{$t} = 'MISSING'
if ($result->{$t} = $r) =~ /FAILED/i;
}
elsif ($line =~ m{^\s*(.*/t/([^/]+\..+))$}is) {
$file->{$2} = $1;
}
}
$date = $_DT->to_string($date);
$curr = join(
'@h3.',
grep(
$_ !~ /^\w+ \w+ \Q$which\E /s,
split(/\@h3\./, $curr),
),
);
my($class) = %$file ? 'FAILED' : 'passed';
$curr =~ s{(?<=\n)}{
join("\n",
"\@h3.$class $class $which $date",
!%$file ? () : (
'@dl.failed',
map(("\@dt $_", "\@dd $file->{$_}"),
sort(keys(%$file))),
'@/dl',
),
'',
);
}esx;
$rf->$method($q, \$curr);
return;
}
sub remote_trace {
my($self, $named) = shift->name_args(['?PerlName'], \@_);
$self->initialize_fully;
my($ua) = b_use('Ext.LWPUserAgent')->new
->bivio_ssl_no_check_certificate
->bivio_redirect_automatically;
$ua->agent('bivio test remote_trace');
$ua->timeout(5);
my($resp) = $ua->request(
HTTP::Request->new(
'GET',
_uri_for_task($self, 'TEST_TRACE', undef, {path_info => $named}),
),
);
b_die($resp)
unless $resp->is_success;
return;
}
sub task {
my($self, $task, $query, $path_info, $facade) = @_;
# Executes the task, and returns the result. See
# L<Bivio::Test::Request->execute_task|Bivio::Test::Request->execute_task>
# for output details.
my($req) = b_use('Test.Request')->get_instance;
# Forces type check, and probably good thing anyway.
$query = ref($query) ? {%$query}
: $query
? b_use('AgentHTTP.Query')->parse($query)
: undef;
return $self->get_request->execute_task($task, {
query => $query,
path_info => $path_info,
}, $facade || ());
}
sub unit {
my($self, $tests) = _find_files(\@_, qr{\.(?:t|bunit)$});
# Executes I<test>(s). I<test> may be a directory or file name. If it is a
# directory, all tests (C<*.t>) files will be executed. All tests must end in
# C<*.t>.
#
# When only one test is run, shows the output of the test.
return _run($self, $tests, sub {
my($self, $test, $out) = @_;
my($max, $ok) = (-1, 0);
_piped_exec($self, _unit($test), $out, sub {
my($line) = @_;
if ($max >= 0) {
$ok++ if $line =~ /^ok\s*(\d+)/;
}
elsif ($line =~ /^1\.\.(\d+)/) {
$max = $1;
}
});
my($d) = $_CFG->{unit_log_dir};
if ($d) {
$_F->mkdir_p($d);
my($x) = File::Basename::basename($test);
$x =~ s{\.[^\.]+$}{};
$_F->write("$d/$x.out", $$out);
}
return $ok == $max;
});
}
sub weekly_build_output_to_wiki {
my($self, $msg) = @_;
$self->initialize_fully;
$msg ||= $self->read_input;
$msg = $$msg
if ref($msg);
my($q) = {path => $_WN->to_absolute('WeeklyBuildOutput')};
my($rf) = $self->model('RealmFile');
my($curr) = "\@h1 WeeklyBuildOutput\n";
my($method) = 'create_with_content';
if ($rf->unsafe_load($q)) {
my($content) = ${$rf->get_content};
my($previous_date);
foreach my $line (split(/\n/, $content)) {
if ($line =~ m{(\d{4}/\d{2}/\d{2}\s\d{2}:\d{2}:\d{2}).*starting}is) {
$previous_date = $self->convert_literal(DateTime => $1);
last;
}
}
$curr = $content
if defined($previous_date)
&& $_DT->delta_days($previous_date, $_DT->now) < 1;
$method = 'update_with_content';
}
$curr .= "\@pre\n${msg}\n\@\\pre\n";
$rf->$method($q, \$curr);
return;
}
sub _expunge {
my($self) = @_;
# Deletes old test directories.
# this automatically loops through files in ascending order of timestamp
# only works for this millenium
my(@dirs) = glob("$_CFG->{nightly_output_dir}/2?????????????");
while (@dirs > 7) {
my($dir) = shift(@dirs);
$self->piped_exec("chmod -R a+rwx $dir");
$self->print("Deleting old test directory: $dir\n");
b_use('IO.File')->rm_rf($dir);
}
return;
}
sub _find_files {
my($args, $pattern) = @_;
# Returns self, and hash of tests to run (dir, tests).
my($self) = shift(@$args);
$self->usage_error('must supply test files or directories')
unless @$args;
my($tests) = {};
my($pwd) = b_use('IO.File')->pwd;
my($vc_re) = b_use('Util.VC')->CONTROL_DIR_RE;
foreach my $arg (@$args) {
$arg = "t/$arg"
if !-e $arg && $arg =~ $pattern && -e "t/$arg";
my($is_file) = -f $arg;
File::Find::find({
no_chdir => 1,
wanted => sub {
my(undef, $d, $f) = File::Spec->splitpath($File::Find::name);
if (-d $File::Find::name) {
$File::Find::prune = 1
if $f =~ $vc_re
|| $f =~ /(?:^old|-|\.old|^realm-data|.*\.tmp)$/;
return;
}
return
unless $is_file
|| $File::Find::name =~ $pattern
&& -r _;
$d = File::Spec->rel2abs($d, $pwd);
push(@{$tests->{$d} ||= []}, $f);
return;
}},
$arg,
);
}
return ($self, $tests);
}
sub _make_nightly_dir {
my($self) = @_;
# Makes the directory in which nightly() executes and leaves testsuite
# log files.
my($dir) = $_CFG->{nightly_output_dir} . '/' . $_DT->local_now_as_file_name;
b_die($dir, ': dir exists; move out of the way')
if -d $dir;
$_F->mkdir_p($dir);
$_F->chdir($dir);
$self->print("Created $dir\n");
my($latest_link) = $_CFG->{nightly_output_dir} . '/latest';
unlink($latest_link)
if -l $latest_link;
b_die($!, ': could not create symbolic link')
unless symlink($dir, $latest_link);
return $dir;
}
sub _piped_exec {
my($self, $command, $input, $out, $do) = @_;
# Call $do for each line.
foreach my $line (split(/\n/,
$$out = ${$self->piped_exec(
join(' ',
$^X,
'-w',
$command,
map({
# this regex is hairy to accommodate shell string escaping rules
s/'/'\\''/g;
"'$_'";
} @{b_use('IO.Config')->command_line_args}),
'2>&1',
),
$input, 1)})
) {
chomp($line);
$do->($line);
}
return;
}
sub _run {
my($self, $tests, $action) = @_;
# Runs the tests with action.
my($ok, $max) = (0, 0);
my($failed) = [];
my($one_dir) = keys(%$tests) == 1;
foreach my $t (values(%$tests)) {
$max += @$t;
}
$self->usage_error('no tests found') unless $max;
foreach my $d (sort(keys(%$tests))) {
$self->print("*** Entering: $d\n") unless $one_dir;
b_use('IO.File')->do_in_dir($d => sub {
foreach my $t (sort(@{$tests->{$d}})) {
my($res) = 'FAILED';
my($out);
if ($action->($self, $t, \$out)) {
$res = 'PASSED';
$ok++;
}
else {
push(@$failed, File::Spec->catfile($d, $t));
}
$self->print(sprintf('%20s: ', $t), $res, "\n");
$out ||= '';
$out =~ s/^/ /mg;
if ($max == 1 || $self->get('verbose') && $res eq 'FAILED') {
$self->print("Output:\n", $out);
}
}
});
$self->print("*** Leaving: $d\n\n") unless $one_dir;
}
$self->print(
(@$failed ? join("\n ", 'Failed tests: ', @$failed) . "\n"
: ''),
b_use('Bivio.Test')->format_results($ok, $max));
$_D->throw_quietly('DIE')
unless $max == $ok;
return;
}
sub _unit {
my($test) = @_;
# If test ends in bunit, need to construct '.t'
my($unit) = b_use('TestUnit.Unit');
return $test =~ /bunit$/ ? ('-', <<"EOF") : ($test, undef);
use strict;
use $unit;
${unit}->run(q{$test});
EOF
}
sub _uri_for_task {
my($self, $task, $email_or_facade, $uri_args) = @_;
my($f) = b_use('UI.Facade');
my($facade) = $f->setup_request(
$email_or_facade ? ($email_or_facade =~ /@(.+)/)[0] || $email_or_facade
: $f->get_default->get('uri'),
$self->req,
);
my($http) = $self->use('TestLanguage.HTTP')->home_page_uri(
$facade->get('uri'));
b_die($http, ': TestLanguage.HTTP->home_page_uri missing http:')
unless $http =~ m{https?://[^/]+};
return $http . $self->req->format_uri({
realm => undef,
task_id => $task,
query => undef,
path_info => undef,
%{$uri_args || {}},
});
}
1;