mirror of
https://gitlab.com/davical-project/davical.git
synced 2026-01-27 00:33:34 +00:00
686 lines
16 KiB
Perl
Executable File
686 lines
16 KiB
Perl
Executable File
#!/usr/bin/perl -w
|
|
#
|
|
# Run a test
|
|
#
|
|
|
|
use strict;
|
|
use warnings;
|
|
use open qw( :encoding(UTF-8) :std );
|
|
use File::Copy;
|
|
use DBI;
|
|
use Getopt::Long qw(:config permute); # allow mixed args.
|
|
use File::pushd;
|
|
use File::Touch;
|
|
use Digest::SHA;
|
|
|
|
# Options variables
|
|
my $debug = 0;
|
|
my $dsn = "davical";
|
|
my $dbuser = "";
|
|
my $dbpass = "";
|
|
my $webhost = 'mycaldav';
|
|
my $althost = 'myempty';
|
|
my $ldaphost = 'mycaldav_ldap';
|
|
my $testdef;
|
|
my $suite;
|
|
my $case;
|
|
my $helpmeplease = 0;
|
|
|
|
|
|
my $testmode = 'DAVICAL';
|
|
my $save_location = "/var/log/davical";
|
|
my $request_id;
|
|
my %conf_file_hashes;
|
|
|
|
# Hash for eval'd Perl code to store long lived variables in
|
|
my %evaled;
|
|
|
|
my $dbadir = $0;
|
|
$dbadir =~ s{/[^/]*$}{};
|
|
my $patchdir = $dbadir . "/patches";
|
|
|
|
|
|
GetOptions ('debug!' => \$debug,
|
|
'dsn=s' => \$dsn,
|
|
'dbuser=s' => \$dbuser,
|
|
'dbpass=s' => \$dbpass,
|
|
'webhost=s' => \$webhost,
|
|
'althost=s' => \$althost,
|
|
'test=s' => \$testdef,
|
|
'suite=s' => \$suite,
|
|
'case=s' => \$case,
|
|
'help' => \$helpmeplease );
|
|
|
|
usage() if ( $helpmeplease || ((!defined($suite) || !defined($case)) && !defined($testdef)));
|
|
|
|
my $dbh;
|
|
|
|
# Allow enabling debugging via an environment variable. Useful for debugging CI.
|
|
$debug = 1 if ($ENV{DEBUG} || 0) == 1;
|
|
|
|
my @arguments = ( "--basic", "--proxy", "", "--insecure" );
|
|
push @arguments, "--silent" unless ( $debug );
|
|
push @arguments, "--verbose" if ( $debug );
|
|
|
|
my $url;
|
|
my $script; # Not neede as global, used as flag.
|
|
my $script_dir;
|
|
my $is_head_request = 0;
|
|
my $sql_count = 1;
|
|
my @auth = ( "--user", "user1:user1" );
|
|
|
|
# Allow easier pasting of tests on the command line.
|
|
$case =~ s/\.test$//;
|
|
|
|
if ( ! defined($testdef) ) {
|
|
$testdef = "tests/$suite/$case.test";
|
|
}
|
|
|
|
die "You need to run this from the testing directory!\n"
|
|
unless -d "tests";
|
|
|
|
# Heuristics to work out if we should make $save_location elsewhere. We want
|
|
# /var/log/davical for the CI rig, but within the test directories for local
|
|
# runs. Do we?
|
|
if ($ENV{USER} ne 'testrunner') {
|
|
$save_location = "tests/$suite/results/";
|
|
} elsif (! -w $save_location) {
|
|
warn "$save_location isn't writable, using local location";
|
|
$save_location = "tests/$suite/results/";
|
|
}
|
|
|
|
# Record the request_ids from the web server.
|
|
my $request_id_file = "$save_location/$case.request_id";
|
|
open(my $REQUEST_ID_FILE, "> $request_id_file")
|
|
|| die "Failed to open $request_id_file for writing";
|
|
|
|
# Allow for application configuration per test file. Ensure the file we
|
|
# manage is empty in case the previous test was aborted.
|
|
my $dynamic_app_conf_file = 'regression-conf.php.dynamic.per-test';
|
|
if (-f $dynamic_app_conf_file) {
|
|
$conf_file_hashes{$dynamic_app_conf_file}{'old'}
|
|
= Digest::SHA->new->addfile($dynamic_app_conf_file)->hexdigest();
|
|
|
|
unlink $dynamic_app_conf_file
|
|
|| die "Failed to remove $dynamic_app_conf_file: $!\n";
|
|
} else {
|
|
$conf_file_hashes{$dynamic_app_conf_file}{'old'} = '';
|
|
}
|
|
|
|
touch $dynamic_app_conf_file;
|
|
|
|
my $datafile = $testdef;
|
|
$datafile =~ s{\.test$}{};
|
|
push @arguments, "--header", 'X-DAViCal-Testcase: '.$datafile;
|
|
$datafile .= '.data';
|
|
|
|
my $state = "";
|
|
my $data_binary;
|
|
|
|
my $sql_variable = "";
|
|
my $sql_statement = "";
|
|
my $sql_values = {};
|
|
my $perl_code = "";
|
|
my $app_conf = "";
|
|
my $queries = ();
|
|
my $replacements = ();
|
|
my $line_number = 0;
|
|
|
|
|
|
open( TEST, '<', $testdef ) or die "Can't open '$testdef'";
|
|
while( <TEST> ) {
|
|
my $line = $_;
|
|
$line_number++;
|
|
|
|
# Do any variable replacements we have so far
|
|
foreach my $variable ( keys %{$sql_values} ) {
|
|
my $value = $sql_values->{$variable};
|
|
$line =~ s/##$variable##/$value/g;
|
|
}
|
|
|
|
if ( $state ne "" ) {
|
|
$line =~ /^BEGIN(?!:)/ && do {
|
|
print "Found a new BEGIN line, while still processing a previous one. Line number: $line_number\n";
|
|
exit 0;
|
|
};
|
|
|
|
if ( /^END$state$/ ) {
|
|
if ( $state eq "SQL" ) {
|
|
get_sql_value( $sql_variable, $sql_values, $sql_statement );
|
|
}
|
|
elsif ( $state eq "DOSQL" ) {
|
|
do_sql( $sql_statement );
|
|
}
|
|
elsif ( $state eq "QUERY" ) {
|
|
run_sql($sql_statement);
|
|
}
|
|
elsif ( $state eq "PERL" ) {
|
|
eval($perl_code);
|
|
if ($@) {
|
|
print "Failed to run Perl code: $@\n";
|
|
exit 0;
|
|
}
|
|
}
|
|
elsif ( $state eq "APPCONF" ) {
|
|
write_app_conf($app_conf);
|
|
}
|
|
$state = "";
|
|
}
|
|
elsif ( $state eq "DATA" ) {
|
|
$data_binary .= $line;
|
|
}
|
|
elsif ( $state =~ /^SQL|QUERY|DOSQL$/ ) {
|
|
$sql_statement .= $line;
|
|
}
|
|
elsif ( $state eq "PERL" ) {
|
|
$perl_code .= $line;
|
|
}
|
|
elsif ( $state eq "APPCONF" ) {
|
|
$app_conf .= $line;
|
|
}
|
|
next;
|
|
}
|
|
|
|
/^\s*(#|$)/ && next;
|
|
|
|
$line =~ /^\s*HEAD\s*(#|$|=)/ && do {
|
|
push @arguments, "--include";
|
|
};
|
|
|
|
$line =~ /^\s*MODE\s*=\s*(\S*)(?:,(\d+))/ && do {
|
|
my $mode = $1;
|
|
my $args = $2;
|
|
|
|
if (uc($mode) =~ /^TAP$/) {
|
|
$testmode = 'TAP';
|
|
use Test::More;
|
|
|
|
if ($args =~ /^\d+$/) {
|
|
plan tests => $args;
|
|
}
|
|
} else {
|
|
die "Unknown test mode: $1";
|
|
}
|
|
};
|
|
|
|
$line =~ /^\s*VERBOSE\s*(#|$|=)/ && do {
|
|
push @arguments, "--verbose";
|
|
};
|
|
|
|
$line =~ /^\s*NOAUTH\s*(#|$|=)/ && do {
|
|
@auth = ();
|
|
};
|
|
|
|
$line =~ /^\s*DIGEST\s*(#|$|=)/ && do {
|
|
push @arguments, "--digest";
|
|
@auth = ( "--user", $1 );
|
|
};
|
|
|
|
$line =~ /^\s*AUTH\s*=\s*(\S.*)$/ && do {
|
|
@auth = ( "--user", $1 );
|
|
};
|
|
|
|
$line =~ /^\s*DATA\s*=\s*(\S.*)$/ && do {
|
|
my $basename = $1;
|
|
if ( defined($suite) ) {
|
|
if ( -e "tests/$suite/$basename.data" ) {
|
|
$datafile="tests/$suite/$basename.data";
|
|
}
|
|
elsif ( -e "tests/$suite/$basename" ) {
|
|
$datafile="tests/$suite/$basename";
|
|
}
|
|
|
|
}
|
|
elsif ( -e "$basename.data" ) {
|
|
$datafile="$basename.data";
|
|
}
|
|
elsif ( -e $basename ) {
|
|
$datafile=$basename;
|
|
}
|
|
else {
|
|
die "Can't find DATA file $basename or $basename.data";
|
|
}
|
|
};
|
|
|
|
$line =~ /^BEGINDATA\s*$/ && do {
|
|
$data_binary = "";
|
|
$state = "DATA";
|
|
};
|
|
|
|
$line =~ /^BEGINPERL\s*$/ && do {
|
|
$perl_code = "";
|
|
$state = "PERL";
|
|
};
|
|
|
|
$line =~ /^BEGINAPPCONF\s*$/ && do {
|
|
$app_conf = "";
|
|
$state = "APPCONF";
|
|
};
|
|
|
|
$line =~ /^(?:BEGIN)?GETSQL\s*=\s*(\S.*)$/ && do {
|
|
$sql_variable = $1;
|
|
$sql_statement = "";
|
|
$state = "SQL";
|
|
};
|
|
|
|
$line =~ /^(?:BEGIN)?DOSQL\s*$/ && do {
|
|
$sql_statement = "";
|
|
$state = "DOSQL";
|
|
};
|
|
|
|
$line =~ /^\s*APPCONF\s*=\s*(\S.*)$/ && do {
|
|
my $basename = $1;
|
|
my $test_app_conf_file;
|
|
|
|
if ( -e "tests/$suite/$basename.appconf" ) {
|
|
$test_app_conf_file="tests/$suite/$basename.appconf";
|
|
}
|
|
elsif ( -e "tests/$suite/$basename" ) {
|
|
$test_app_conf_file="tests/$suite/$basename";
|
|
}
|
|
|
|
if (! defined $test_app_conf_file) {
|
|
die "Can't find app conf file $basename or $basename.appconf";
|
|
}
|
|
|
|
copy $test_app_conf_file, $dynamic_app_conf_file
|
|
|| die "Failed to copy $test_app_conf_file to $dynamic_app_conf_file: $!\n";
|
|
};
|
|
|
|
|
|
$line =~ /^REPLACE\s*=\s*(\S)(.*)$/ && do {
|
|
my $separator = $1;
|
|
$2 =~ /^([^$separator]*)$separator([^$separator]*)$separator$/ && do {
|
|
push @$replacements, { 'pattern' => $1, 'replacement' => $2 };
|
|
};
|
|
};
|
|
|
|
$line =~ /^(?:BEGIN)?QUERY\s*$/ && do {
|
|
$sql_statement = "";
|
|
$state = "QUERY";
|
|
};
|
|
|
|
$line =~ /^\s*TYPE\s*=\s*(\S.*)$/ && do {
|
|
if ( $1 eq "HEAD" ) {
|
|
push @arguments, "--head";
|
|
}
|
|
else {
|
|
push @arguments, "--request", $1;
|
|
}
|
|
};
|
|
|
|
# HTTP headers to send with curl
|
|
$line =~ /^\s*HEADER\s*=\s*(\S.*)$/ && do {
|
|
my $arg = $1;
|
|
$arg =~ s{regression.host}{$webhost};
|
|
$arg =~ s{regression_ldap.host}{$ldaphost};
|
|
$arg =~ s{alternate.host}{$althost};
|
|
push @arguments, "--header", $arg;
|
|
};
|
|
|
|
# URL to use with curl
|
|
$line =~ /^\s*URL\s*=\s*(\S.*)$/ && do {
|
|
$url = $1;
|
|
$url =~ s{regression.host}{$webhost};
|
|
$url =~ s{regression_ldap.host}{$ldaphost};
|
|
$url =~ s{alternate.host}{$althost};
|
|
|
|
run_curl($url);
|
|
};
|
|
|
|
|
|
# The directory to run the next SCRIPT in.
|
|
$line =~ /^\s*SCRIPT_DIR\s*=\s*(\S.*)$/ && do {
|
|
$script_dir = $1;
|
|
};
|
|
|
|
# Run this SCRIPT, collect the output.
|
|
$line =~ /^\s*SCRIPT\s*=\s*(\S.*)$/ && do {
|
|
$script=$1;
|
|
$script =~ s{regression.host}{$webhost};
|
|
$script =~ s{regression_ldap.host}{$ldaphost};
|
|
$script =~ s{alternate.host}{$althost};
|
|
|
|
my $dir = pushd($script_dir)
|
|
if defined $script_dir;
|
|
|
|
open RESULTS, "-|", $script;
|
|
while( <RESULTS> ) {
|
|
my $line = $_;
|
|
foreach my $replacement ( @$replacements ) {
|
|
$line =~ s/$replacement->{'pattern'}/$replacement->{'replacement'}/;
|
|
}
|
|
print $line;
|
|
}
|
|
|
|
$script_dir = undef;
|
|
};
|
|
|
|
$line =~ /^\s*STATIC\s*=\s*(.*?)\s*$/ && do {
|
|
my $source = "tests/$suite/static/$1";
|
|
my $dest = "../htdocs/testfiles";
|
|
|
|
die "Can't find $source to copy into $dest\n"
|
|
unless -f $source;
|
|
|
|
mkdir $dest
|
|
unless -d $dest;
|
|
|
|
copy($source, $dest)
|
|
|| die "Failed to copy $source: $1";
|
|
}
|
|
}
|
|
|
|
if ( ! defined $url && ! defined $script && ! defined $sql_statement
|
|
&& ! defined $perl_code ) {
|
|
print <<EOERROR ;
|
|
The .test file must contain either at least one URL, SCRIPT, PERL, or QUERY.
|
|
EOERROR
|
|
exit (2);
|
|
}
|
|
|
|
if ($testmode eq 'TAP') {
|
|
done_testing();
|
|
}
|
|
|
|
exit(0);
|
|
|
|
sub run_curl {
|
|
my $url = shift;
|
|
|
|
maybe_restart_apache();
|
|
|
|
my @args = @arguments;
|
|
push @args, @auth;
|
|
|
|
if ( -f $datafile ) {
|
|
push @args, "--data-binary", "\@$datafile";
|
|
}
|
|
elsif ( defined($data_binary) ) {
|
|
push @args, "--data-binary", $data_binary;
|
|
}
|
|
else {
|
|
undef($datafile);
|
|
}
|
|
|
|
push @args, $url;
|
|
|
|
warn join " ", "curl", @args, "\n"
|
|
if $debug;
|
|
|
|
open RESULTS, "-|", "curl", @args;
|
|
while ( <RESULTS> ) {
|
|
my $line = $_;
|
|
|
|
# Grab the web server request_id for later reference
|
|
if ($line =~ /^Request-ID: (.*?)\s*$/) {
|
|
$ENV{REQUEST_ID} = $1;
|
|
$request_id = $1;
|
|
print $REQUEST_ID_FILE "$1\n";
|
|
}
|
|
|
|
foreach my $replacement ( @$replacements ) {
|
|
$line =~ s/$replacement->{'pattern'}/$replacement->{'replacement'}/;
|
|
}
|
|
|
|
print $line;
|
|
}
|
|
|
|
print "\n";
|
|
}
|
|
|
|
sub run_sql {
|
|
my $query = shift;
|
|
|
|
print "SQL Query " . $sql_count++ . " Result:\n";
|
|
|
|
opendb() unless defined($dbh);
|
|
|
|
# run SQL statement and dump results, into array of hashes
|
|
my $results = $dbh->selectall_arrayref($sql_statement, { Slice => {} } );
|
|
|
|
if ( $dbh->err ) {
|
|
print $dbh->errstr, "\n";
|
|
return;
|
|
} elsif (! defined $results) {
|
|
print "No results from SQL query\n";
|
|
return;
|
|
}
|
|
|
|
foreach my $row ( @$results ) {
|
|
warn "Query result ================================================\n"
|
|
if $debug;
|
|
my $sep = "";
|
|
foreach my $name ( sort keys %$row ) {
|
|
my $value = $row->{$name};
|
|
$value = 'NULL' unless ( defined($value) );
|
|
printf("%17.17s: >%s<\n", $name, $value );
|
|
}
|
|
print "\n";
|
|
}
|
|
}
|
|
|
|
|
|
|
|
=item do_sql( $sql_statement )
|
|
|
|
Queries the database using the specified statement and
|
|
ignores the result.
|
|
|
|
=cut
|
|
|
|
sub do_sql {
|
|
my $sql = shift;
|
|
|
|
opendb() unless defined($dbh);
|
|
$dbh->do($sql);
|
|
|
|
if ( $dbh->err ) {
|
|
print $dbh->errstr, "\n";
|
|
return;
|
|
}
|
|
|
|
print "SQL executed successfully.\n";
|
|
print $sql, "\n";
|
|
}
|
|
|
|
|
|
=item get_sql_value( $sql_variable, $sql_values, $sql_statement )
|
|
|
|
Queries the database using the specified statement and puts
|
|
the first column of the first row returned into the
|
|
hash referenced $sql_values->{$sql_variable} for replacement
|
|
later in the parsing process.
|
|
|
|
=cut
|
|
|
|
sub get_sql_value {
|
|
my $varname = shift;
|
|
my $values = shift;
|
|
my $sql = shift;
|
|
|
|
opendb() unless defined($dbh);
|
|
my $results = $dbh->selectall_arrayref($sql);
|
|
|
|
if ( $dbh->err ) {
|
|
print $dbh->errstr, "\n";
|
|
return;
|
|
}
|
|
|
|
warn "RESULT for $varname is ", $results->[0][0], "\n"
|
|
if $debug;
|
|
|
|
$values->{$varname} = (defined($results->[0][0]) ? $results->[0][0] : "");
|
|
}
|
|
|
|
=item opendb()
|
|
|
|
Opens the database connection to the global $dbh handle.
|
|
Note that the standard PostgreSQL environment variables will also work
|
|
with DBD::Pg.
|
|
|
|
=cut
|
|
|
|
sub opendb {
|
|
$dsn = "dbi:Pg:dbname=$dsn";
|
|
$dbh = DBI->connect($dsn, $dbuser, $dbpass, { AutoCommit => 1 } ) or die "Can't connect to database $dsn";
|
|
$dbh->do("SET TIMEZONE TO 'Pacific/Auckland'");
|
|
}
|
|
|
|
sub webui_login {
|
|
my %args = (
|
|
username => undef,
|
|
password => undef,
|
|
url => undef,
|
|
failauth => 0,
|
|
@_,
|
|
);
|
|
|
|
use Test::WWW::Mechanize;
|
|
my $mech = Test::WWW::Mechanize->new;
|
|
|
|
$mech->get_ok($args{url}, "Fetch first page");
|
|
$mech->text_contains('Log On Please', "Not logged in");
|
|
$mech->submit_form_ok(
|
|
{
|
|
fields => {
|
|
username => $args{username},
|
|
password => $args{password},
|
|
},
|
|
}, "Login to site"
|
|
);
|
|
|
|
if ($args{failauth}) {
|
|
# We expected failure.
|
|
$mech->text_contains("You must log in to use this system", "Failed to login");
|
|
} else {
|
|
$mech->text_contains("You are logged on as " . $args{username}, "Logged in");
|
|
}
|
|
|
|
return $mech;
|
|
}
|
|
|
|
=item write_app_conf()
|
|
|
|
Write per test configuration entries to the DAViCal regression test server
|
|
configuration.
|
|
|
|
=cut
|
|
|
|
sub write_app_conf {
|
|
my $content = shift;
|
|
|
|
# We may want to append extra content to a common file.
|
|
open(my $FILE, ">> $dynamic_app_conf_file")
|
|
|| die "Failed to open $dynamic_app_conf_file for writing";
|
|
print $FILE $content;
|
|
}
|
|
|
|
=item maybe_restart_apache
|
|
|
|
Check to see if the DAViCal config file snippet has changed, if it has,
|
|
restart Apache to make sure the new config is picked up.
|
|
|
|
=cut
|
|
|
|
sub maybe_restart_apache {
|
|
my $restarted = 0;
|
|
|
|
for my $file (keys %conf_file_hashes) {
|
|
my $curr = (-f $file ? Digest::SHA->new->addfile($file)->hexdigest() : '');
|
|
|
|
if (! $restarted && $curr ne $conf_file_hashes{$file}{old}) {
|
|
system("sudo /usr/sbin/apache2ctl restart\n");
|
|
$restarted = 1;
|
|
}
|
|
|
|
# We've restarted Apache, treat the current hashes as old now, in
|
|
# case we make multiple queries to the server, or modify the config
|
|
# files again within this test file.
|
|
$conf_file_hashes{$file}{old} = $curr
|
|
if $restarted;
|
|
}
|
|
}
|
|
|
|
|
|
sub usage {
|
|
print <<EOERROR ;
|
|
|
|
Usage:
|
|
dav_test [DB opts] [--suite <testsuite> --case <testname>] | [--test <filename>]
|
|
|
|
This program will read the file 'tests/<testsuite>/<testname>.test
|
|
and follow the instructions there.
|
|
|
|
The following options are available for controlling the database, for
|
|
those test cases which might require it:
|
|
--dsn <database>[;port=NNNN][;host=example.com]
|
|
--dbuser <user>
|
|
--dbpass <password>
|
|
|
|
|
|
The test instructions will include lines defining the test like:
|
|
=================================================
|
|
# This is an example
|
|
HEADER=Depth: 0
|
|
HEADER=Content-type: text/xml
|
|
TYPE=PROPFIND
|
|
|
|
HEAD
|
|
|
|
DATA=OTHERTEST
|
|
|
|
URL=http://mycaldav/caldav.php/andrew/
|
|
|
|
# This will let you use ##somename## for this value after this
|
|
GETSQL=somename
|
|
SELECT column FROM table WHERE criteria
|
|
ENDSQL
|
|
|
|
# The data can be included in line
|
|
BEGINDATA
|
|
... data content ...
|
|
ENDDATA
|
|
|
|
# The result could be some SQL output
|
|
QUERY
|
|
SELECT something, or, other FROM table ...
|
|
ENDQUERY
|
|
|
|
# Run some Perl code
|
|
BEGINPERL
|
|
my \$variable = 'foo';
|
|
ENDPERL
|
|
|
|
# Dynamically add content to the DAViCal configuration file for this test.
|
|
# Allows ad-hoc config changes for tests. See also APPCONF. If APPCONF isn't
|
|
# used, then you must start this with "<?php" as below. If APPCONF is used,
|
|
# then it must start with "<?php".
|
|
BEGINAPPCONF
|
|
<?php
|
|
|
|
\$valid_php = "in here";
|
|
ENDAPPCONF
|
|
|
|
REPLACE=/pattern/replacement/
|
|
=================================================
|
|
|
|
URL The URL to request from (request is sent when seen).
|
|
HEADER An additional header for the request
|
|
TYPE The type of request (e.g. GET/PUT/POST/REPORT/...)
|
|
HEAD Whether to include the headers in the recorded response
|
|
VERBOSE Whether to provide the full request / response headers.
|
|
DATA The name of a different test in this suite to use data from.
|
|
REPLACE A perl regex replacement to post-process the result through.
|
|
APPCONF A file that will be insert into the DAViCal config file. This is
|
|
inserted first, before any content in BEGINAPPCONF/ENDAPPCONF to
|
|
allow a common config file for a set of tests, but also to allow
|
|
for individual test overrides.
|
|
|
|
Additionally, if a file 'tests/<testsuite>/<testname>.data' exists
|
|
the contents of that file will be sent in the body of the request.
|
|
|
|
EOERROR
|
|
exit(1);
|
|
}
|