File Coverage

blib/lib/Test/Script.pm

Criterion	Covered	Total	%
statement	247	252	98.0
branch	89	104	85.5
condition	29	50	58.0
subroutine	47	47	100.0
pod	21	23	91.3
total	433	476	90.9

package Test::Script;

# ABSTRACT: Basic cross-platform tests for scripts
our $VERSION = '1.31'; # VERSION


use 5.008001;
use strict;
use warnings;
use Carp qw( croak );
use Exporter ();
use File::Spec;
use File::Spec::Unix;
use Probe::Perl;
use Capture::Tiny qw( capture );
use Test2::API qw( context );
use File::Temp qw( tempdir );
use IO::Handle;

our @ISA     = 'Exporter';
our @EXPORT  = qw{
  script_compiles
  script_compiles_ok
  script_fails
  script_runs
  script_stdout_is
  script_stdout_isnt
  script_stdout_like
  script_stdout_unlike
  script_stderr_is
  script_stderr_isnt
  script_stderr_like
  script_stderr_unlike
  program_fails
  program_runs
  program_stdout_is
  program_stdout_isnt
  program_stdout_like
  program_stdout_unlike
  program_stderr_is
  program_stderr_isnt
  program_stderr_like
  program_stderr_unlike
};

sub import {
  my $class = shift;
  my $pack = caller;
  if(defined $_[0] && $_[0] =~ /^(?:no_plan|skip_all|tests)$/)
  {
    # icky back compat.
    # do not use.
    my $ctx = context();
    if($_[0] eq 'tests')
    {
      $ctx->plan($_[1]);
    }
    elsif($_[0] eq 'skip_all')
    {
      $ctx->plan(0, 'SKIP', $_[1]);
    }
    else
    {
      $ctx->hub->plan('NO PLAN');
    }
    $ctx->release;
    foreach ( @EXPORT ) {
      $class->export_to_level(1, $class, $_);
    }
  }
  else
  {
    unshift @_, $class;
    goto &Exporter::import;
  }
}

my $perl = undef;

sub perl () {
  $perl or
  $perl = Probe::Perl->find_perl_interpreter;
}

sub path ($) {
  my $path = shift;
  unless ( defined $path ) {
    croak("Did not provide a script name");
  }
  if ( File::Spec::Unix->file_name_is_absolute($path) ) {
    croak("Script name must be relative");
  }
  File::Spec->catfile(
    File::Spec->curdir,
    split /\//, $path
  );
}

#####################################################################
# Test Functions for Scripts


sub script_compiles {
  my $args   = _script(shift);
  my $unix   = shift @$args;
  my $path   = path( $unix );
  my $pargs  = _perl_args($path);
  my $dir    = _preload_module();
  my $cmd    = [ perl, @$pargs, "-I$dir", '-M__TEST_SCRIPT__', '-c', $path, @$args ];
  my ($stdout, $stderr) = capture { system(@$cmd) };
  my $error  = $@;
  my $exit   = $? ? ($? >> 8) : 0;
  my $signal = $? ? ($? & 127) : 0;
  my $ok     = !! (
    $error eq '' and $exit == 0 and $signal == 0 and $stderr =~ /syntax OK\s+\z/si
  );

  my $ctx = context();
  $ctx->ok( $ok, $_[0] || "Script $unix compiles" );
  $ctx->diag( "$exit - $stderr" ) unless $ok;
  $ctx->diag( "exception: $error" ) if $error;
  $ctx->diag( "signal: $signal" ) if $signal;
  $ctx->release;

  return $ok;
}

# this is noticeably slower for long @INC lists (sometimes present in cpantesters
# boxes) than the previous implementation, which added a -I for every element in
# @INC.  (also slower for more reasonable @INCs, but not noticeably).  But it is
# safer as very long argument lists can break calls to system
sub _preload_module
{
  my @opts = ( '.test-script-XXXXXXXX', CLEANUP => 1);
  if(-w File::Spec->curdir)
  { push @opts, DIR => File::Spec->curdir }
  else
  { push @opts, DIR => File::Spec->tmpdir }
  my $dir = tempdir(@opts);
  $dir = File::Spec->rel2abs($dir);
  # this is hopefully a pm file that nobody would use
  my $filename = File::Spec->catfile($dir, '__TEST_SCRIPT__.pm');
  my $fh;
  open($fh, '>', $filename)
    || die "unable to open $filename: $!";
  print($fh 'unshift @INC, ',
    join ',',
    # quotemeta is overkill, but it will make sure that characters
    # like " are quoted
    map { '"' . quotemeta($_) . '"' }
    grep { ! ref } @INC)
      || die "unable to write $filename: $!";
  close($fh) || die "unable to close $filename: $!";;
  $dir;
}


my $stdout;
my $stderr;

sub script_runs {
  my $args   = _script(shift);
  my $opt    = _options(\$stdout, \$stderr, 1, \@_);
  my $unix   = shift @$args;
  my $path   = path( $unix );
  my $pargs  = [ @{ _perl_args($path) }, @{ $opt->{interpreter_options} } ];
  my $dir    = _preload_module();
  my $cmd    = [ perl, @$pargs, "-I$dir", '-M__TEST_SCRIPT__', $path, @$args ];
  $stdout = '';
  $stderr = '';

  unshift @_, "Script $unix runs" unless $_[0];
  unshift @_, $cmd, $opt;
  goto &_run;
}


sub script_fails {
  my $args   = _script(shift);
  my ( $opt, $testname ) = @_;
  $testname = "Script $args->[0] fails" unless defined $testname;
  die "exit is a mandatory option for script_fails"
    unless eval{ defined $opt->{exit} };
  my $ctx = context();
  return release $ctx, script_runs( $args, $opt, $testname );
}

# Run a script or program and provide test events corresponding to the results.
# Call as _run(\@cmd, \%opt, "Test description")
sub _run {
  my ($cmd, $opt, $description) = @_;

  if($opt->{stdin})
  {
    my $filename;

    if(ref($opt->{stdin}) eq 'SCALAR')
    {
      $filename = File::Spec->catfile(
        tempdir(CLEANUP => 1),
        'stdin.txt',
      );
      my $tmp;
      open($tmp, '>', $filename) || die "unable to write to $filename";
      print $tmp ${ $opt->{stdin} };
      close $tmp;
    }
    elsif(ref($opt->{stdin}) eq '')
    {
      $filename = $opt->{stdin};
    }
    else
    {
      croak("stdin MUST be either a scalar reference or a string filename");
    }

    my $fh;
    open($fh, '<', $filename) || die "unable to open $filename $!";
    STDIN->fdopen( $fh, 'r' ) or die "unable to reopen stdin to $filename $!";
  }

  (${$opt->{stdout}}, ${$opt->{stderr}}) = capture { system(@$cmd) };

  my $error  = $@;
  my $exit   = $? ? ($? >> 8) : 0;
  my $signal = $? ? ($? & 127) : 0;
  my $ok     = !! ( $error eq '' and $exit == $opt->{exit} and $signal == $opt->{signal} );

  my $ctx = context();
  $ctx->ok( $ok, $description );
  $ctx->diag( "$exit - " . ${$opt->{stderr}} ) unless $ok;
  $ctx->diag( "exception: $error" ) if $error;
  $ctx->diag( "signal: $signal" ) unless $signal == $opt->{signal};
  $ctx->release;

  return $ok;
}

sub _like
{
  my($text, $pattern, $regex, $not, $name) = @_;

  my $ok = $regex ? $text =~ $pattern : $text eq $pattern;
  $ok = !$ok if $not;

  my $ctx = context;
  $ctx->ok( $ok, $name );
  unless($ok) {
    $ctx->diag( "The output" );
    $ctx->diag( "  $_") for split /\n/, $text;
    $ctx->diag( $not ? "does match" : "does not match" );
    if($regex) {
      $ctx->diag( "  $pattern" );
    } else {
      $ctx->diag( "  $_" ) for split /\n/, $pattern;
    }
  }
  $ctx->release;

  $ok;
}


sub script_stdout_is
{
  my($pattern, $name) = @_;
  @_ = ($stdout, $pattern, 0, 0, $name || 'stdout matches' );
  goto &_like;
}


sub script_stdout_isnt
{
  my($pattern, $name) = @_;
  @_ = ($stdout, $pattern, 0, 1, $name || 'stdout does not match' );
  goto &_like;
}


sub script_stdout_like
{
  my($pattern, $name) = @_;
  @_ = ($stdout, $pattern, 1, 0, $name || 'stdout matches' );
  goto &_like;
}


sub script_stdout_unlike
{
  my($pattern, $name) = @_;
  @_ = ($stdout, $pattern, 1, 1, $name || 'stdout does not match' );
  goto &_like;
}


sub script_stderr_is
{
  my($pattern, $name) = @_;
  @_ = ($stderr, $pattern, 0, 0, $name || 'stderr matches' );
  goto &_like;
}


sub script_stderr_isnt
{
  my($pattern, $name) = @_;
  @_ = ($stderr, $pattern, 0, 1, $name || 'stderr does not match' );
  goto &_like;
}


sub script_stderr_like
{
  my($pattern, $name) = @_;
  @_ = ($stderr, $pattern, 1, 0, $name || 'stderr matches' );
  goto &_like;
}


sub script_stderr_unlike
{
  my($pattern, $name) = @_;
  @_ = ($stderr, $pattern, 1, 1, $name || 'stderr does not match' );
  goto &_like;
}

#####################################################################
# Test Functions for Programs

my $program_stdout;
my $program_stderr;


sub program_runs {
  my $cmd    = _script(shift);
  my $opt    = _options(\$program_stdout, \$program_stderr, 0, \@_);
  $program_stdout = '';
  $program_stderr = '';

  unshift @_, "Program $$cmd[0] runs" unless $_[0];
  unshift @_, $cmd, $opt;
  goto &_run;
}


sub program_fails {
  my $cmd    = _script(shift);
  my ( $opt, $testname ) = @_;
  $testname = 'program_fails' unless defined $testname;
  die "exit is a mandatory option for program_fails"
    unless eval{ defined $opt->{exit} };
  my $ctx = context();
  return release $ctx, program_runs( $cmd, $opt, $testname );
}


sub program_stdout_is
{
  my($pattern, $name) = @_;
  @_ = ($program_stdout, $pattern, 0, 0, $name || 'stdout matches' );
  goto &_like;
}


sub program_stdout_isnt
{
  my($pattern, $name) = @_;
  @_ = ($program_stdout, $pattern, 0, 1, $name || 'stdout does not match' );
  goto &_like;
}


sub program_stdout_like
{
  my($pattern, $name) = @_;
  @_ = ($program_stdout, $pattern, 1, 0, $name || 'stdout matches' );
  goto &_like;
}


sub program_stdout_unlike
{
  my($pattern, $name) = @_;
  @_ = ($program_stdout, $pattern, 1, 1, $name || 'stdout does not match' );
  goto &_like;
}


sub program_stderr_is
{
  my($pattern, $name) = @_;
  @_ = ($program_stderr, $pattern, 0, 0, $name || 'stderr matches' );
  goto &_like;
}


sub program_stderr_isnt
{
  my($pattern, $name) = @_;
  @_ = ($program_stderr, $pattern, 0, 1, $name || 'stderr does not match' );
  goto &_like;
}


sub program_stderr_like
{
  my($pattern, $name) = @_;
  @_ = ($program_stderr, $pattern, 1, 0, $name || 'stderr matches' );
  goto &_like;
}


sub program_stderr_unlike
{
  my($pattern, $name) = @_;
  @_ = ($program_stderr, $pattern, 1, 1, $name || 'stderr does not match' );
  goto &_like;
}


######################################################################
# Support Functions

# Script params must be either a simple non-null string with the script
# name, or an array reference with one or more non-null strings.
sub _script {
  my $in = shift;
  if ( defined _STRING($in) ) {
    return [ $in ];
  }
  if ( _ARRAY($in) ) {
    unless ( scalar grep { not defined _STRING($_) } @$in ) {
      return [ @$in ];
    }
  }
  croak("Invalid command parameter");
}

# Determine any extra arguments that need to be passed into Perl.
# ATM this is just -T.
sub _perl_args {
  my($script) = @_;
  my $fh;
  my $first_line = '';
  if(open($fh, '<', $script))
  {
    $first_line = <$fh>;
    close $fh;
  }
  (grep /^-.*T/, split /\s+/, $first_line) ? ['-T'] : [];
}

# Inline some basic Params::Util functions

sub _options {
  my $ref_stdout = shift;
  my $ref_stderr = shift;
  my $permit_interpreter_options = shift;
  my %options = ref($_[0]->[0]) eq 'HASH' ? %{ shift @{ $_[0] } }: ();

  $options{exit}   = 0        unless defined $options{exit};
  $options{signal} = 0        unless defined $options{signal};
  my $stdin = '';
  #$options{stdin}  = \$stdin  unless defined $options{stdin};
  $options{stdout} = $ref_stdout unless defined $options{stdout};
  $options{stderr} = $ref_stderr unless defined $options{stderr};

  if(defined $options{interpreter_options})
  {
    die "interpreter_options not supported" unless $permit_interpreter_options;
    unless(ref $options{interpreter_options} eq 'ARRAY')
    {
      require Text::ParseWords;
      $options{interpreter_options} = [ Text::ParseWords::shellwords($options{interpreter_options}) ];
    }
  }
  else
  {
    $options{interpreter_options} = [];
  }

  \%options;
}

sub _ARRAY ($) {
  (ref $_[0] eq 'ARRAY' and @{$_[0]}) ? $_[0] : undef;
}

sub _STRING ($) {
  (defined $_[0] and ! ref $_[0] and length($_[0])) ? $_[0] : undef;
}

BEGIN {
  # Alias to old name
  *script_compiles_ok = *script_compiles;
}

1;

__END__