nik/davical
1
0
Fork 0
mirror of https://gitlab.com/davical-project/davical.git synced 2026-08-27 18:06:06 +00:00
Code Issues Actions Packages Projects Releases Wiki Activity

Add the ability to run Perl snippets

Browse Source 
This allows for more complicated test suites, which I'll use in the next commit...
This commit is contained in:
Andrew Ruthven 2022-12-19 22:57:19 +13:00
parent 016e51b4ac
commit 7898efdfda
1 changed files with 35 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
testing/dav_test
View File

@ -15,13 +15,17 @@ my $debug = 0;
my $dsn = "davical";
my $dbuser = "";
my $dbpass = "";
my $webhost = 'mycaldav';
my $althost = 'myempty';
my $webhost = 'mycaldav';
my $althost = 'myempty';
my $ldaphost = 'mycaldav_ldap';
my $testdef;
my $suite;
my $case;
my $helpmeplease = 0;
# Hash for eval'd Perl code to store long lived variables in
my %evaled;
my $dbadir = $0;
$dbadir =~ s{/[^/]*$}{};
my $patchdir = $dbadir . "/patches";
@ -69,14 +73,17 @@ my $data_binary;
my $sql_variable = "";
my $sql_statement = "";
my $perl_code = "";
my $sql_values = {};
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 replcements we have so far
foreach my $variable ( keys %{$sql_values} ) {
@ -85,6 +92,11 @@ while( <TEST> ) {
}
if ( $state ne "" ) {
$line =~ /^BEGIN(DATA|PERL)/ && 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 );
@ -95,14 +107,24 @@ while( <TEST> ) {
elsif ( $state eq "QUERY" ) {
push @$queries, $sql_statement;
}
elsif ( $state eq "PERL" ) {
eval($perl_code);
if ($@) {
print "Failed to run Perl code: $@\n";
exit 0;
}
}
$state = "";
}
elsif ( $state eq "DATA" ) {
$data_binary .= $line;
}
elsif ( $state eq "SQL" || $state eq "QUERY" || $state eq "DOSQL" ) {
elsif ( $state =~ /^SQL|QUERY|DOSQL$/ ) {
$sql_statement .= $line;
}
elsif ( $state eq "PERL" ) {
$perl_code .= $line;
}
next;
}
@ -156,6 +178,11 @@ while( <TEST> ) {
$state = "DATA";
};
$line =~ /^BEGINPERL\s*$/ && do {
$perl_code = "";
$state = "PERL";
};
$line =~ /^GETSQL\s*=\s*(\S.*)$/ && do {
$sql_variable = $1;
$sql_statement = "";
@ -191,6 +218,7 @@ while( <TEST> ) {
$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;
};
@ -198,21 +226,23 @@ while( <TEST> ) {
$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};
};
$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};
push @scripts, $script;
};
}
if ( !defined($url) && !defined($script) ) {
if ( !defined($url) && !defined($script) && !defined($sql_statement) ) {
print <<EOERROR ;
The .test file must contain either a URL or a SCRIPT.
The .test file must contain either a URL or a SCRIPT, or a QUERY.
EOERROR
exit (2);
}