The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package Test::Utils;

use strict;
use Exporter;
use Test::More;
use FileHandle;

use vars qw( @EXPORT @ISA $VERSION );

$VERSION = sprintf "%d.%02d%02d", q/0.10.1/ =~ /(\d+)/g;

@ISA = qw( Exporter );
@EXPORT = qw( Run_Script Write_Script Setup_Cache $set_env $single_quote
              $command_separator );

use vars qw( $single_quote $command_separator $set_env );

if ($^O eq 'MSWin32')
{
  $set_env = 'set';
  $single_quote = '"';
  $command_separator = '&';
}
else
{
  $set_env = '';
  $single_quote = "'";
  $command_separator = '';
}

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

# This function executes three tests, one for each of the expected_ variables.
# If any of the expected_ variables are the string "<SKIP>", any value will be
# accepted.

sub Run_Script
{
  my $test_script_name = shift;
  my $script = shift;
  my $expected_stdout = shift;
  my $expected_stderr = shift;
  my $expected_cached = shift;
  my $message = shift;
  my $clear_cache = shift;

  local $Test::Builder::Level = 2;

  Write_Script($test_script_name,$script);
  Setup_Cache($test_script_name,$script,$clear_cache);

  # Save STDERR and redirect temporarily to nothing. This will prevent the
  # test script from emitting output to STDERR
  {
    use vars qw(*OLDSTDERR);
    open OLDSTDERR,">&STDERR" or die "Can't save STDERR: $!\n";
    open STDERR,">STDERR-redirected"
      or die "Can't redirect STDERR to STDERR-redirected: $!\n";

    my $script_results;
    
    {
      my @standard_inc = split /###/, `$^X -e '\$" = "###";print "\@INC"'`;
      my @extra_inc;
      foreach my $inc (@INC)
      {
        push @extra_inc, "$single_quote$inc$single_quote"
          unless grep { /^$inc$/ } @standard_inc;
      }

      if (@extra_inc)
      {
        local $" = ' -I';
        $script_results = `$^X -I@extra_inc $test_script_name`;
      }
      else
      {
        $script_results = `$^X $test_script_name`;
      }
    }
    
    unlink $test_script_name;

    open STDERR,">&OLDSTDERR" or die "Can't restore STDERR: $!\n";

    # Check the answer that the test generated
    if (defined $expected_stdout)
    {
      if ($expected_stdout eq '<SKIP>')
      {
        $script_results = '<UNDEF>' unless defined $script_results;
        ok(1, "$message: Skipping results output check for string \"$script_results\"");
      }
      elsif (ref $expected_stdout eq 'Regexp')
      {
        like($script_results, $expected_stdout, "$message: Computing the right output");
      }
      else
      {
        is($script_results, $expected_stdout, "$message: Computing the right output");
      }
    }
    else
    {
      ok(!defined($script_results), "$message: Undefined results");
    }
  }

  {
    open ERROR, "STDERR-redirected";
    local $/ = undef;
    my $script_errors = <ERROR>;
    close ERROR;
    unlink "STDERR-redirected";

    if (defined $expected_stderr)
    {
      if ($expected_stderr eq '<SKIP>')
      {
        $script_errors = '<UNDEF>' unless defined $script_errors;
        ok(1, "$message: Skipping error output check for string \"$script_errors\"");
      }
      elsif (ref $expected_stderr eq 'Regexp')
      {
        like($script_errors, $expected_stderr, "$message: Computing the right errors");
      }
      else
      {
        is($script_errors, $expected_stderr, "$message: Computing the right errors");
      }
    }
    else
    {
      ok(!defined($script_errors), "$message: Undefined errors");
    }
  }

  {
    my $cached_results = $CGI::Cache::THE_CACHE->get($CGI::Cache::THE_CACHE_KEY);

    if (defined $expected_cached)
    {
      if ($expected_cached eq '<SKIP>')
      {
        $cached_results = '<UNDEF>' unless defined $cached_results;
        ok(1, "$message: Skipping cached output check for string \"$cached_results\"");
      }
      elsif (ref $expected_cached eq 'Regexp')
      {
        like($cached_results, $expected_cached, "$message: Correct cached data");
      }
      else
      {
        is($cached_results, $expected_cached, "$message: Correct cached data");
      }
    }
    else
    {
      ok(!defined($cached_results), "$message: Undefined cached data");
    }
  }

  unlink $test_script_name;
}

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

sub Write_Script
{
  my $test_script_name = shift;
  my $script = shift;

  open(FH,">$test_script_name") || die "Can't open file \"$test_script_name\". $!\n";
  print FH $script;
  close FH;
}

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

sub Setup_Cache
{
  my $test_script_name = shift;
  my $script = shift;
  my $clear_cache = shift;

  # Setup the CGI::Cache the same way the test script does so that we
  # can clear the cache and then look at the cached info after the run.
  my ($cache_options) = $script =~ /setup\((.*?)\)/s;
  my ($cache_key) = $script =~ /set_key\((.*?)\)/s;

  $ENV{SCRIPT_NAME} = $test_script_name;

  eval "CGI::Cache::setup($cache_options)";
  eval "CGI::Cache::set_key($cache_key)";

  # Clear the cache to start the test
  $CGI::Cache::THE_CACHE->clear() if $clear_cache;
}

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

1;