ff99aaf60c
- Add sanity tests of line_mark_string - Update TestHelpers::_parseq() to handle HTML section headers as well as query.py section headers - Add tests of web.py - Note: don't look for 200 since web.py doesn't send an HTTP Status-Line. - In web.py, update the shebang to use env(1). The hard-coded path caused test failures on Travis, which runs Python in a virtualenv.
547 lines
13 KiB
Perl
547 lines
13 KiB
Perl
#!/usr/bin/env perl
|
|
# TestHelpers.pm: Common routines for use in tests.
|
|
# See license information at end of file.
|
|
#
|
|
# For a cleaner view of the documentation, run
|
|
# perldoc TestHelpers.pm
|
|
# (on Ubuntu, you may need to install the perl-doc package first.)
|
|
#
|
|
# SPDX-License-Identifier: AGPL-3.0-or-later
|
|
#
|
|
# This file uses core Perl modules only.
|
|
|
|
=head1 NAME
|
|
|
|
TestHelpers - Common routines for use in tests
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
C<use TestHelpers;>, and all the functions below will be exported.
|
|
TestHelpers also turns on L<strict> and L<warnings>.
|
|
|
|
=cut
|
|
|
|
package TestHelpers;
|
|
|
|
use strict;
|
|
use warnings;
|
|
use autodie; # note: still need to check system() calls manually
|
|
|
|
use Cwd qw(abs_path);
|
|
use File::Spec;
|
|
use File::Temp 0.14 qw(tempdir);
|
|
use FindBin;
|
|
use IO::Select;
|
|
use IPC::Open3;
|
|
use Symbol;
|
|
|
|
use Test::More;
|
|
|
|
# Automatically export all the functions listed in @EXPORT. The functions
|
|
# in @EXPORT_OK can be exported on request.
|
|
use parent 'Exporter';
|
|
our (@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
|
|
BEGIN {
|
|
@EXPORT = qw(sibling_abs_path find_program run_program ok_or_die
|
|
run_produces_ok http_request_ok MUST_SUCCEED);
|
|
@EXPORT_OK = qw(line_mark_string);
|
|
%EXPORT_TAGS = (
|
|
all => [@EXPORT, @EXPORT_OK],
|
|
);
|
|
} #BEGIN
|
|
|
|
# Forwards for internal functions
|
|
sub line_mark_string;
|
|
|
|
# ===========================================================================
|
|
|
|
=head1 CONSTANTS
|
|
|
|
=head2 MUST_SUCCEED
|
|
|
|
True. So that calls to L</run_produces_ok> will be more self-explanatory.
|
|
|
|
=cut
|
|
|
|
use constant MUST_SUCCEED => !!1;
|
|
|
|
=head1 FUNCTIONS
|
|
|
|
These are helper routines that generally perform specific tasks.
|
|
|
|
=head2 sibling_abs_path
|
|
|
|
Return the absolute path of a file or directory in the same directory as
|
|
this file. Usage:
|
|
|
|
$path = sibling_abs_path('name');
|
|
|
|
=cut
|
|
|
|
sub sibling_abs_path {
|
|
return File::Spec->rel2abs(File::Spec->catfile($FindBin::Bin, @_));
|
|
} #sibling_abs_path()
|
|
|
|
=head2 find_program
|
|
|
|
Looks for a program in the parent directory of this script.
|
|
Usage:
|
|
|
|
$path = find_program(['subdir', ]'program name')
|
|
|
|
=cut
|
|
|
|
sub find_program {
|
|
my $pgm_file = pop; # Last arg
|
|
my @pgm_dirs = @_; # Any args before the last are additional dirs.
|
|
|
|
my ($my_vol, $my_dirs, undef) = File::Spec->splitpath($FindBin::Bin, 1); # 1 => is a dir
|
|
|
|
# Go up to the parent of the directory holding this file
|
|
my @my_dirs = File::Spec->splitdir($my_dirs);
|
|
die "Cannot run from the root directory" unless @my_dirs >= 2;
|
|
pop @my_dirs;
|
|
my $dest_dirs = File::Spec->catdir(@my_dirs, @pgm_dirs);
|
|
|
|
return File::Spec->catpath($my_vol, $dest_dirs, $pgm_file);
|
|
} #find_program()
|
|
|
|
=head2 run_program
|
|
|
|
Print a command, then run it. Can be used three ways:
|
|
|
|
=over
|
|
|
|
=item In void context
|
|
|
|
Returns if system() and the command succeed, dies otherwise. Usage:
|
|
|
|
run_program('program', 'arg1', ...);
|
|
|
|
=item In scalar context
|
|
|
|
Returns true if system() and the command succeed, false otherwise. Usage:
|
|
|
|
my $ok = run_program('program', 'arg1', ...);
|
|
|
|
=item In list context
|
|
|
|
Returns the exit status, stdout, and stderr. Usage:
|
|
|
|
my ($exit_status, $lrStdout, $lrStderr) = run_program('program', 'arg1', ...);
|
|
# Returns the shell exit status, stdout text, and stderr text.
|
|
|
|
C<$lrStdout> and C<$lrStderr> are references to the lists of output lines
|
|
on the respective handles.
|
|
|
|
C<$exit_status> is C<128+signal> if the process was killed by C<signal>,
|
|
for consistency with bash (L<https://tldp.org/LDP/abs/html/exitcodes.html>).
|
|
|
|
=back
|
|
|
|
=cut
|
|
|
|
sub _run_and_capture; # forward
|
|
sub _check_queries; # forward
|
|
|
|
sub run_program {
|
|
|
|
if(wantarray) {
|
|
goto &_run_and_capture;
|
|
}
|
|
|
|
my $errmsg;
|
|
|
|
diag "Running @_";
|
|
my $status = system(@_);
|
|
|
|
if ($status == -1) {
|
|
$errmsg = "failed to execute $_[0]: $!";
|
|
}
|
|
elsif ($status & 127) {
|
|
$errmsg = sprintf "$_[0] died with signal %d, %s coredump\n",
|
|
($status & 127), ($status & 128) ? 'with' : 'without';
|
|
}
|
|
elsif($status != 0) {
|
|
$errmsg = sprintf "$_[0] exited with value %d\n", $status >> 8;
|
|
}
|
|
else {
|
|
diag "$_[0] reported success";
|
|
}
|
|
|
|
if($errmsg) {
|
|
die $errmsg unless defined wantarray;
|
|
diag $errmsg;
|
|
}
|
|
|
|
return($status == 0);
|
|
} #run_program()
|
|
|
|
=head2 ok_or_die
|
|
|
|
Run a test, but die if it fails. Usage:
|
|
|
|
ok_or_die( <some condition>, 'description', 'what to print if it dies' )
|
|
|
|
=cut
|
|
|
|
sub ok_or_die {
|
|
my ($cond, $msg, $err_msg) = @_;
|
|
my (undef, $filename, $line) = caller;
|
|
my $retval = eval line_mark_string 1, <<EOT; # Make the error message report the caller's line number
|
|
ok(\$cond, \$msg);
|
|
EOT
|
|
die($err_msg) unless $retval;
|
|
return $retval;
|
|
} #ok_or_die()
|
|
|
|
=head2 run_produces_ok
|
|
|
|
Run a program and check whether it produces expected output.
|
|
Usage:
|
|
|
|
run_produces_ok($desc, \@program_and_args, \@conditions,
|
|
<optional> $mustSucceed, <optional> $printOutput)
|
|
|
|
The test passes if each condition in C<@conditions> is true.
|
|
If C<$mustSucceed> is true, also tests for exit status 0 and empty stderr.
|
|
If C<$printOutput> is true, prints the output of C<@program_and_args>.
|
|
|
|
=head3 Conditions that can be used any time
|
|
|
|
=over
|
|
|
|
=item *
|
|
|
|
A regex: true if the regex matches at least one line in the output of
|
|
C<@program_and_args>
|
|
|
|
=item *
|
|
|
|
C<< { not => regex } >>: true if the regex is NOT found in any line of
|
|
the output of C<@program_and_args>.
|
|
|
|
=back
|
|
|
|
=head3 Conditions for the output of C<query.py>
|
|
|
|
=over
|
|
|
|
=item *
|
|
|
|
C<< { def => regex } >>: true if the regex matches at least one line in
|
|
the "Symbol Definitions" section of the output of C<@program_and_args>.
|
|
|
|
=item *
|
|
|
|
C<< { ref => regex } >>: true if the regex matches at least one line in
|
|
the "Symbol References" section of the output of C<@program_and_args>.
|
|
|
|
=item *
|
|
|
|
C<< { doc => regex } >>: true if the regex matches at least one line in
|
|
the "Documented in" section of the output of C<@program_and_args>.
|
|
|
|
=back
|
|
|
|
=cut
|
|
|
|
# _run_and_capture: run a program and return its exit status and output.
|
|
# Usage:
|
|
# my ($exit_status, \@stdout, \@stderr) = run_program('program', 'arg1', ...);
|
|
|
|
sub _run_and_capture {
|
|
my ($in , $out, $err); # Filehandles
|
|
$err = Symbol::gensym;
|
|
|
|
diag "Running @_";
|
|
my $pid = open3($in, $out, $err, @_);
|
|
|
|
my (@outlines, @errlines); # Captured output
|
|
my $s = IO::Select->new;
|
|
$s->add($out);
|
|
$s->add($err);
|
|
|
|
while(my @ready = $s->can_read) {
|
|
for my $fh (@ready) {
|
|
|
|
if(eof($fh)) {
|
|
$s->remove($fh);
|
|
next;
|
|
}
|
|
|
|
if($fh == $out) {
|
|
push @outlines, scalar readline $fh;
|
|
} else {
|
|
push @errlines, scalar readline $fh;
|
|
}
|
|
}
|
|
}
|
|
|
|
waitpid $pid, 0;
|
|
my $exit_status = $?;
|
|
|
|
$exit_status = ($exit_status & 127) + 128 if $exit_status & 127; # Killed by signal
|
|
|
|
return ($exit_status, \@outlines, \@errlines);
|
|
} #_run_and_capture()
|
|
|
|
sub run_produces_ok {
|
|
my ($desc, $lrProgram, $lrConditions, $mustSucceed, $printOutput) = @_;
|
|
|
|
my ($exit_status, $outlines, $errlines) = _run_and_capture(@$lrProgram);
|
|
|
|
_check_queries($desc, $lrConditions, $mustSucceed, $printOutput, $exit_status, $outlines, $errlines);
|
|
} #run_produces_ok()
|
|
|
|
sub _check_queries {
|
|
my ($desc, $lrConditions, $mustSucceed, $printOutput, $exit_status, $lrStdout, $lrStderr) = @_;
|
|
|
|
my @outlines = @$lrStdout;
|
|
my @errlines = @$lrStderr;
|
|
|
|
if ($printOutput) {
|
|
diag "@outlines";
|
|
}
|
|
|
|
# Basic checks
|
|
if($mustSucceed) {
|
|
eval line_mark_string 2, <<'EOT';
|
|
cmp_ok($exit_status, '==', 0, "$desc: exit status 0");
|
|
cmp_ok(@errlines, '==', 0, "$desc: stderr empty");
|
|
EOT
|
|
die $@ if $@;
|
|
}
|
|
|
|
# Check regexes
|
|
my %query_py_output; # filled in only if we see a def/ref/doc
|
|
for my $entry (@$lrConditions) {
|
|
my ($re, $negated, $source) = _parse_condition($entry);
|
|
|
|
# Parse query.py output if we need it and haven't done so
|
|
%query_py_output = _parseq(@outlines)
|
|
if $source ne 'output' && !%query_py_output;
|
|
|
|
# Build a line of test code to run
|
|
my $test = 'ok( ';
|
|
$test .= '!' if $negated;
|
|
$test .= '(grep { m{$re} } ';
|
|
if($source eq 'output') {
|
|
$test .= '@outlines';
|
|
} else {
|
|
$test .= '@{$query_py_output{' . $source . '}}';
|
|
}
|
|
$test .= '), "$desc: ' . $source;
|
|
$test .= ($negated ? ' excludes ' : ' includes ') . "\Q$re\E" . '");';
|
|
|
|
# Run it
|
|
#diag "Running $test";
|
|
eval line_mark_string 2, $test;
|
|
die $@ if $@;
|
|
} #foreach $entry
|
|
|
|
} #run_produces_ok()
|
|
|
|
=head2 http_request_ok
|
|
|
|
Run C<web.py> against a given path and check whether it produces expected
|
|
output. Usage:
|
|
|
|
http_request_ok($desc, $tenv, $path, \@conditions, <optional> $printOutput)
|
|
|
|
The test passes if the HTTP request succeeds, and if each condition in
|
|
C<@conditions> is true of the result (headers and body).
|
|
|
|
C<$tenv> is a L<TestEnvironment>.
|
|
|
|
C<$path> is the path part of the URL, e.g., C</testproj/latest/source>.
|
|
|
|
See L</run_produces_ok> for C<@conditions>.
|
|
|
|
If C<$printOutput> is true, prints the output of C<@program_and_args>.
|
|
|
|
=cut
|
|
|
|
sub http_request_ok {
|
|
my ($desc, $tenv, $path, $lrConditions, $printOutput) = @_;
|
|
die "Invalid args" unless $desc && ref $tenv && eval { @$lrConditions };
|
|
|
|
my ($exit_status, $lrStdout, $lrStderr) = $tenv->make_web_request($path);
|
|
|
|
_check_queries($desc, $lrConditions, MUST_SUCCEED, $printOutput,
|
|
$exit_status, $lrStdout, $lrStderr);
|
|
} #http_request_ok()
|
|
|
|
=head1 INTERNAL FUNCTIONS
|
|
|
|
These are ones you probably won't need to call.
|
|
|
|
=head2 _parseq
|
|
|
|
Parse the output of query.py. Usage:
|
|
|
|
%parsed = _parseq(@lines_of_output);
|
|
|
|
=cut
|
|
|
|
sub _parseq {
|
|
my %retval = ( def => [], ref => [], doc => [] );
|
|
my $list;
|
|
foreach(@_) {
|
|
chomp;
|
|
if(/(?:^Symbol Definitions:$)|\bDefined in \d+/) {
|
|
$list = 'def';
|
|
next;
|
|
} elsif(/(?:^Symbol References:$)|\bReferenced in \d+/) {
|
|
$list = 'ref';
|
|
next;
|
|
} elsif(/(?:^Documented in:$)|\bDocumented in \d+/) {
|
|
$list = 'doc';
|
|
next;
|
|
}
|
|
next unless $list;
|
|
|
|
#diag "Adding `$_' to list $list";
|
|
push @{$retval{$list}}, $_;
|
|
}
|
|
return %retval;
|
|
} #_parseq()
|
|
|
|
=head2 _parse_condition
|
|
|
|
Parse a condition for L</run_produces_ok>. Usage:
|
|
|
|
($regex, $negated, $source) = _parse_condition($entry[, $source]);
|
|
|
|
=cut
|
|
|
|
sub _parse_condition {
|
|
my ($entry, $source_in) = @_;
|
|
my ($regex, $negated, $source); # Return values
|
|
|
|
# Basic cases
|
|
if(ref $entry eq 'Regexp') {
|
|
return ($entry, 0, $source_in || 'output');
|
|
} elsif(ref $entry eq 'HASH' && ref $entry->{not} eq 'Regexp') {
|
|
return ($entry->{not}, 1, $source_in || 'output');
|
|
}
|
|
|
|
# Sub-keys: chain
|
|
if(ref $entry eq 'HASH' && scalar keys %{$entry} == 1) {
|
|
return _parse_condition((values %{$entry})[0], (keys %{$entry})[0]);
|
|
}
|
|
|
|
# If we get here, we don't know how to handle it
|
|
die "Invalid entry $entry";
|
|
} #_parse_condition()
|
|
|
|
|
|
=head2 _croak
|
|
|
|
Lazy invoker for L<Carp/croak>.
|
|
|
|
=cut
|
|
|
|
sub _croak {
|
|
require Carp;
|
|
goto &Carp::croak;
|
|
} #_croak()
|
|
|
|
=head2 line_mark_string
|
|
|
|
Add a C<#line> directive to a string. Usage:
|
|
|
|
To use the caller's filename and line number:
|
|
|
|
my $str = line_mark_string <<EOT ;
|
|
$contents
|
|
EOT
|
|
|
|
To use a filename and line number from higher in the call stack:
|
|
|
|
my $str = line_mark_string $level, <<EOT ;
|
|
$contents
|
|
EOT
|
|
|
|
To use a specified filename and line number:
|
|
|
|
my $str = line_mark_string __FILE__, __LINE__, <<EOT ;
|
|
$contents
|
|
EOT
|
|
|
|
In the first and second forms, information from C<caller> will be used for the
|
|
filename and line number.
|
|
|
|
In the first and third forms, the C<#line> directive will point to the line
|
|
after the C<line_mark_string> invocation, i.e., the first line of <C$contents>.
|
|
Generally, C<$contents> will be source code, although this is not required.
|
|
|
|
C<$contents> must be defined, but can be empty.
|
|
|
|
=cut
|
|
|
|
sub line_mark_string {
|
|
my ($contents, $filename, $line);
|
|
|
|
if(@_ == 1) {
|
|
$contents = $_[0];
|
|
(undef, $filename, $line) = caller;
|
|
++$line;
|
|
} elsif(@_ == 2) {
|
|
(undef, $filename, $line) = caller($_[0]);
|
|
$contents = $_[1];
|
|
} elsif(@_ == 3) {
|
|
($filename, $line, $contents) = @_;
|
|
++$line;
|
|
} else {
|
|
_croak "Invalid invocation";
|
|
}
|
|
|
|
_croak "Need text" unless defined $contents;
|
|
die "Couldn't get location information" unless $filename && $line;
|
|
|
|
$filename =~ s/"/-/g;
|
|
|
|
return <<EOT;
|
|
#line $line "$filename"
|
|
$contents
|
|
EOT
|
|
} #line_mark_string()
|
|
|
|
=head2 import
|
|
|
|
Set up. Called automatically.
|
|
|
|
=cut
|
|
|
|
sub import {
|
|
__PACKAGE__->export_to_level(1, @_);
|
|
strict->import;
|
|
warnings->import;
|
|
} #import()
|
|
|
|
1;
|
|
__END__
|
|
|
|
=head1 AUTHOR
|
|
|
|
Christopher White, C<< <cwhite@d3engineering.com> >>
|
|
|
|
=head1 COPYRIGHT
|
|
|
|
Copyright (c) 2020 D3 Engineering, LLC.
|
|
|
|
Elixir is free software; you can redistribute it and/or modify
|
|
it under the terms of the GNU Affero General Public License as published by
|
|
the Free Software Foundation, either version 3 of the License, or
|
|
(at your option) any later version.
|
|
|
|
Elixir is distributed in the hope that it will be useful,
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
GNU Affero General Public License for more details.
|
|
|
|
You should have received a copy of the GNU Affero General Public License
|
|
along with Elixir. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
=cut
|