<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">#
#                         ScriptTester.pm
#                         ---------------
#
# Description:
#   Run script tests inside a set of directories.
# $Id$
#
# This file is part of the Pencil Code and licensed under the GNU Public
# License version 3 or later; see $PENCIL_HOME/license/GNU_public_license.txt.
#

package Test::ScriptTester;

use warnings;
use strict;
use Cwd qw/getcwd abs_path/;
use Carp;
use File::Basename;
use File::Copy 'move';
use File::Find;
use Test::NumericFileComparator;
use vars qw($VERSION $DEBUG);

##use critic

$VERSION = '0.1';

$DEBUG = 0;

=head1 NAME

Test::ScriptTester - Run script tests in a set of directories

=head1 SYNOPSIS

  use Test::ScriptTests;

  $tester = Test::ScriptTester-&gt;new(
      [dir1, dir2, ...],
      {'python' =&gt; 'python', 'idl' =&gt; '/usr/bin/gdl'}
      );

  $tester-&gt;run();

  my @tests = $tester-&gt;list_tests();

  $tester-&gt;run_tests(@tests[0..2);

  my %default_interpreters = Test::ScriptTests::get_default_interpreters();

  my $default_idl_interpreter = $default_interpreters{'idl'};

  my $idl_interpreter = $test-&gt;find_interpreter_for('idl');


=head1 DESCRIPTION

Scan the given directories for subdirectories named 'tests/'; in each
tests directory run all script tests.

A I&lt;script test&gt; consists of a test file that

=over 4

=item *

is named &lt;test_name&gt;.&lt;suff&gt;, where &lt;suff&gt; is a known suffix &lt;suff&gt;
(currently supported: py, pro),

=item *

is executable and can be run from the tests directory (thus, many of the
test scripts read data from '../data/'),

=item *

when run, writes a file &lt;test_name&gt;.out in the same directory.

=item *

There exist a file &lt;test_name&gt;.ref in the same directory that defines the
reference data and possibly accuracy.

=back

Each test script is run (if we find an appropriate interpreter)
and the &lt;test_name&gt;.out file is compared to the reference data
&lt;test_name&gt;.ref .


=head2 Methods

=over 4

=cut


our (@default_types, @types, %type_map);


=item B&lt;Test::ScriptTester-E&lt;gt&gt;new&gt;($dirs, $interpreters)
      B&lt;Test::ScriptTester-E&lt;gt&gt;new&gt;($dirs)

Create a new object that searches the given directories

  $dirs = [dir1, dir2, ...]

and uses the given interpreters, e.g.

  {'python' =&gt; 'python', 'idl' =&gt; '/usr/bin/gdl'} )

If no interpreter map ref is given, use the default map as returned by
I&lt;Test::ScriptTests::get_default_interpreters&gt;().

Only test types listed in the interpreters map are run.

=cut

sub new {
#
#   Test::ScriptTester-&gt;new($dirs_ref [, $interpreters_ref]);
#   $tester-&gt;new($dirs_ref [, $interpreters_ref]);
#
    my $proto = shift;          # either classref or object ref or string
    my ($dirs_ref, $interpreters_ref)  = @_;

    my $self = {};
    my $class;
    my $parent = {};
    if (ref($proto)) {
        $class = ref($proto);
    } else {
        $class = $proto;
    }

    $self-&gt;{DIRS} = $dirs_ref;

    if (defined $interpreters_ref) {
        $self-&gt;{INTERPRETERS} = $interpreters_ref;
    } else {
        my %interpreters = get_default_interpreters();
        $self-&gt;{INTERPRETERS} = \%interpreters;
    }

    my %full_type_map = (       # all known suffixes and types
        '.py'  =&gt; 'python',
        '.pro' =&gt; 'idl',
        );
    my %type_map = ();
    while (my ($suffix, $type) = each %full_type_map) {
        if (exists $self-&gt;{INTERPRETERS}-&gt;{$type}) {
            $type_map{$suffix} = $type;
        }
    }
    $self-&gt;{TYPE_MAP} = \%type_map;

    $self-&gt;{SUFFIXES} = [ keys %{$self-&gt;{TYPE_MAP}} ];

    bless $self, $class;
    return $self;
}


=item B&lt;$tester-E&lt;gt&gt;run&gt;()

Run all tests supported by this $tester.

Return counts ($good_count, $bad_count) of successful and failed tests.

=cut

sub run {
    my ($self) = @_;

    return $self-&gt;run_tests($self-&gt;list_tests());
}


=item B&lt;$tester-E&lt;gt&gt;list_tests&gt;()

List all tests supported by this $tester.
Returns a list of list refs

  ([$tests_dir1, $script1], ...)

=cut

sub list_tests {
    my ($self) = @_;

    my @test_dirs;
    foreach my $dir (@{$self-&gt;{DIRS}}) {
        push @test_dirs, $self-&gt;_find_test_dirs($dir);
    }

    my @tests;
    foreach my $testdir (@test_dirs) {
        foreach my $test_script ($self-&gt;_find_test_scripts($testdir)) {
            push @tests, [$testdir, $test_script];
        }
    }

    return @tests;
}


=item B&lt;$tester-E&lt;gt&gt;run_tests&gt;(@tests)

Run the given tests.

Each test is a list ref [$tests_dir, $script], where $script is the path
to an executable script file, either relative to $tests_dir, or absolute.

Return counts ($good_count, $bad_count) of successful and failed tests.

=cut

sub run_tests {
    my ($self, @tests) = @_;

    my ($good_count, $bad_count) = (0, 0);
    foreach my $test (@tests) {
        my $good = $self-&gt;_run_test($test);
        if ($good) {
            $good_count++;
        } else {
            $bad_count++;
        }
    }
    return ($good_count, $bad_count);
}


sub _run_test {
    my ($self, $test_ref) = @_;

    my ($tests_dir, $test) = @$test_ref;
    my ($file, $type) = @$test;
    my ($base, $dir, $suffix) = fileparse($file, @{$self-&gt;{SUFFIXES}});
    my $script = $base . $suffix;
    my $outfile = "${base}.out";
    my $reffile = "${base}.ref";

    $self-&gt;debug("Running $type script $script from $tests_dir / $dir");
    my $workdir = getcwd();
    chdir $tests_dir;

    backup($outfile);
    my $ok = 1;

    my $interpreter = $self-&gt;{INTERPRETERS}-&gt;{$type};
    my @cmd = split(/\s+/, $interpreter);
    $ok &amp;= (system(@cmd, $file) == 0);

    if (-e $reffile) {
        if (-e $outfile) {
            $ok &amp;= compare_files($reffile, $outfile);
        } else {
            warn "Script $script did not write expected file $outfile\n";
            $ok = 0;
        }
    } else {
        # The documentation of this module says the file must exist.
        warn "No reference file for $script\n";
        $ok = 0;
    }

    chdir $workdir;
    return $ok;
}


sub debug {
    my ($self, @args) = @_;

    if ($DEBUG) {
        my $string = join(' ', @args);
        chomp($string);
        print STDERR "$string\n";
    }
}


=item B&lt;$tester-E&lt;gt&gt;find_interpreter_for&gt;($test_type)

Return the interpreter (path of an executable) for the given
$test_type, or undef.

=cut

sub find_interpreter_for {
    my ($self, $test_type) = @_;

    return $self-&gt;{INTERPRETERS}-&gt;{$test_type};
}


=item B&lt;Test::ScriptTester::@default_types&gt;

All supported test types.

=cut
my %interpreters = get_default_interpreters();
@default_types = keys %interpreters;


=item B&lt;Test::ScriptTester::get_default_interpreters&gt;()

Return a hash

  ( type1 =&gt; interpreter1,
    type2 =&gt; interpreter1, ...
  )

representing the default interpreters (values) for all known test
types (keys).

=cut

sub get_default_interpreters {
    # Python
    my %interpreters = (
        'python' =&gt; 'python',
        );

    # Idl/Gdl
    my $idl_interpreter;
    if (_in_PATH('idl')) {
        $idl_interpreter = 'idl';
    } elsif (_in_PATH('gdl')) {
        $idl_interpreter = 'gdl';
    } elsif (_in_PATH('gnudl')) {
        $idl_interpreter = 'gnudl';
    }
    if (defined $idl_interpreter) {
        $interpreters{'idl'} = $idl_interpreter;
    }

    return %interpreters;
}


sub compare_files {
    my ($reference, $actual) = @_;

    my $comparator = Test::NumericFileComparator-&gt;new($reference);

    # Compare file to reference data
    my @message = $comparator-&gt;compare($actual);
    if (@message) {
        print "File $actual differs: @message\n";
        return 0;
    } else {
        return 1;
    }
}


sub backup {
# Move $file to $file.old if applicable
# An existing backup file will be overwritten without further ado.
    my ($file) = @_;

    if (-e $file) {
        move $file, "${file}.old";
    }
}


sub _in_PATH {
# Check whether an executable is available in the execution PATH
    my $file = shift;

    foreach my $path (split(/:/,$ENV{PATH})) {
        if (-x "$path/$file") { return 1; }
    }
    return 0;
}


# ---------------------------------------------------------------------- #


sub _find_test_dirs {
# Find all test directories at or below the given @top_dirs.
# We do not recurse further into identified test directories.
    my ($self, @top_dirs) = @_;

    my @dirs;
    for my $dir (@top_dirs) {
        $dir = abs_path($dir);
        if ($self-&gt;_is_test_dir($dir)) {
            push @dirs, $dir;
        } else {
            File::Find::find({
                    wanted =&gt; sub {
                        my $name = $File::Find::name;
                        if ($self-&gt;_is_test_dir($name)) {
                            push @dirs, $name;
                            my $dummy = $File::Find::prune;  # suppress
                                                             # 'used only
                                                             # once'
                                                             # warning
                            $File::Find::prune = 1;
                        }
                    },
                    follow =&gt; 1,       # follow symlinks
                    follow_skip =&gt; 2,  # ignore duplicates
                },
                $dir
            );
        }
    }

    return @dirs;
}


sub _is_test_dir {
# Does the given $path represent a test directory?
    my ($self, $path) = @_;

    my ($name, undef, undef) = fileparse($path);
    return (-d $path) &amp;&amp; ($name =~ '^tests$');
}


sub _find_test_scripts {
# Find all test scripts below directory $dir.
# A test script has a known suffix and is executable.
# Return an array ref [$filename, $type], where
# $filename is the file name of the script relative to the test dir.
    my ($self, $dir) = @_;

    my @scripts;
    File::Find::find({
            wanted =&gt; sub {
                my $name = $File::Find::name;
                my $type = $self-&gt;_is_test_script($name);
                if ($type) {
                    push @scripts, [_make_relative($name, $dir), $type];
                }
            },
            follow =&gt; 1,       # follow symlinks
            follow_skip =&gt; 2,  # ignore duplicates
        },
        $dir
    );

    return @scripts;
}


sub _is_test_script {
# Does the given $path represent a test script?
# Return the test type if it does, '' otherwise
    my ($self, $path) = @_;

    my ($name, $dir, $suffix) = fileparse($path, @{$self-&gt;{SUFFIXES}});

    if ((-x $path) &amp;&amp; $suffix) {
        return $self-&gt;{TYPE_MAP}-&gt;{$suffix};
    } else {
        return '';
    }
}


sub _get_suffixes {
# Map a list of file types to a list of supported suffices.
    my $self = shift;
    my @types = @_;

    my @suffixes;
    for my $type (@types) {
        push @suffixes, $self-&gt;_type_to_suffix($type);
    }
    return @suffixes;
}


sub _type_to_suffix {
# Map test type (e.g. 'idl') to suffix of executable files ('pro' in the
# example)
    my ($self, $type) = @_;

    my $suffix = $self-&gt;{TYPE_MAP}-&gt;{$type};
    if (defined $suffix) {
        return $suffix;
    } else {
        die "Unknown test type &lt;$type&gt;\n";
    }
}


sub _make_relative {
# Return $path relative to $dir.
# This is a dumb version that assumes (and verifies) that $path is a
# subpath of $dir.
# In cases where a good relative path would require leading '..', this
# routine will just cry foul.
    my ($path, $dir) = @_;

    my $abs_path = abs_path($path);
    my $abs_dir = abs_path($dir);
    my ($undef, $rel_path) = ($abs_path =~ m{^($abs_dir)/*(.*)});
    if (defined $rel_path) {
        return $rel_path;
    } else {
        croak("_make_relative() requires that $path is below \$dir");
    }
}


# ---------------------------------------------------------------------- #

=back

=head1 EXAMPLES

  use Test::ScriptTester;

  my $tester = Test::ScriptTester-&gt;new(
      ["$env{PENCIL_HOME}/tests"]
      );
  $tester-&gt;run();  # Run all test scripts under $PENCIL_HOME/tests/

=cut


1;

__END__



# End of file
</pre></body></html>