execute it via the "system" call
It's easy to do this non-portably. For example, if you rely on the script being executable and having a shebang line, this won't work on Windows unless .pl file associations have been set up.
I've done a fair amount of script testing and always set up an explicit call to perl, usually with Probe::Perl and relying on IPC::Run3 to execute the program and manage input and output.
For example:
use strict;
use File::Spec;
use IPC::Run3 qw/run3/;
use Probe::Perl;
use Test::More;
plan tests => 2 ;
my $perl = Probe::Perl->find_perl_interpreter;
my $script = File::Spec->catfile(qw/scripts foo.pl/);
my ($got_stdout, $got_stderr);
ok( -r $script,
"foo.pl script readable"
);
# run and capture output
run3 "$perl $script", undef, \$got_stdout, \$got_stderr;
is( $got_stdout, $expected_stdout),
"foo.pl program output"
);
You can see an example like that in my Tee distribution in 02_tee_script.t.
In some cases, I've written an entire test helper class to manage repetitive tests on a script. In Pod::WikiDoc, I have a file called t/CLI.pm and I use it for repeated calls to a script with different command line options, plus it automatically captures output and has tests for whether it ran successfully or not.
use t::CLI;
my $script = File::Spec->catfile( "scripts", "wikidoc" );
my $wikidoc = t::CLI->new($script);
# setup $input_file and $output_file
$wikidoc->runs_ok( "$input_file", "$output_file" );
$wikidoc->stdout_like( qr/Extracting Pod from \Q$input_file\E/,
"'wikidoc file file' status message"
);
Here's is a copy of t::CLI:
package t::CLI;
use strict;
use warnings;
use Test::Builder;
use Probe::Perl;
use Cwd qw( abs_path );
use IPC::Run3;
use File::Basename qw( basename );
use File::Spec;
#use POSIX qw( WEXITSTATUS );
my $Test = Test::Builder->new;
my $pp = Probe::Perl->new;
my $perl = abs_path($pp->find_perl_interpreter);
my $cwd = abs_path( "." );
my $coverdb = File::Spec->catdir($cwd,"cover_db");
my $cover = index( ($ENV{HARNESS_PERL_SWITCHES} || ''), '-MDevel::Cove
+r' ) < 0
? ''
: "-MDevel::Cover=-db,$coverdb"
;
#---------------------------------------------------------------------
+-----#
# Main API
#---------------------------------------------------------------------
+-----#
sub new {
my ($class, $program, @default_args ) = @_;
my $self = bless {}, $class;
$self->program( $program );
$self->default_args( [@default_args] );
return $self;
}
# returns success or failure; exit_code is opposite (0 is good); actua
+l error
# message is in @$
sub run {
my ($self, @args) = @_;
my ($stdout, $stderr);
my $stdin = $self->stdin;
my @cmd = (
$perl,
"-Mblib=$cwd", # must hard code this in case curdir changed
( $cover ? $cover : () ),
$self->{program},
@{ $self->default_args() },
@args,
);
eval {
run3 \@cmd, \$stdin, \$stdout, \$stderr;
$self->exit_code( $? >> 8 || 0 );
};
my $result = $@ eq q{} ? 1 : 0;
$self->stdout($stdout);
$self->stderr($stderr);
$@ .= "(running '@cmd')";
return $result;
}
#---------------------------------------------------------------------
+-----#
# Accessors
#---------------------------------------------------------------------
+-----#
sub program {
my ($self, $filename) = @_;
if (defined $filename) {
die "Can't find $filename" if ! -e $filename;
$self->{program} = abs_path($filename);
}
return basename( $self->{program} );
}
BEGIN {
my $evaltext = << 'CODE';
sub {
$_[0]->{PROP} = $_[1] if @_ > 1;
return $_[0]->{PROP};
}
CODE
for ( qw( exit_code stdin stdout stderr default_args)) {
no strict 'refs';
(my $sub = $evaltext) =~ s/PROP/$_/g;
*{__PACKAGE__ . "::$_"} = eval $sub;
}
}
#---------------------------------------------------------------------
+-----#
# Testing functions
#---------------------------------------------------------------------
+-----#
sub runs_ok {
my ($self, @args) = @_;
my $label = "Ran " . $self->program() . " with "
. (@args && $args[0] ne q{} ? "args '@args'" : "no args"
+ )
. " without error";
my $runs = $self->run(@args);
die $@ if ! $runs;
my $ok = $Test->ok( ! $self->exit_code, $label );
if ( ! $ok ) {
$Test->diag( "Exit code: " . $self->exit_code . "\n");
$Test->diag( "STDERR: " . $self->stderr . "\n") if $self->stde
+rr;
$Test->diag( "STDOUT: " . $self->stdout . "\n") if $self->stdo
+ut;
}
return $ok;
}
sub dies_ok {
my ($self, @args) = @_;
my $label = $self->program . " with "
. (@args && $args[0] ne q{} ? "args '@args'" : "no args"
+ )
. " ended with an error";
my $runs = $self->run(@args);
die $@ if ! $runs;
my $ok = $Test->ok( $self->exit_code, $label );
if ( ! $ok ) {
$Test->diag( "Exit code: " . $self->exit_code . "\n");
}
return $ok;
}
sub exits_with {
my ($self, $expect, @args) = @_;
my $label = $self->program . " with "
. (@args && $args[0] ne q{} ? "args '@args'" : "no args"
+ )
. " ended with exit code $expect";
my $runs = $self->run(@args);
die $@ if ! $runs;
return $Test->is_num( $self->exit_code, $expect, $label );
}
sub stdout_is { my ($self, $expect, $label) = @_; return $Test->is_eq(
$self->stdout, $expect, $label ? "... $label" : "... " . $self
+->program
. " had correct output to STDOUT" ); }
sub stdout_like {
my ($self, $expect, $label) = @_;
return $Test->like( $self->stdout, $expect,
$label
? "... $label"
: "... " . $self->program . " had correct output to STDOUT
+" );
}
sub stderr_is {
my ($self, $expect, $label) = @_;
return $Test->is_eq( $self->stderr, $expect,
$label
? "... $label"
: "... " . $self->program . " had correct output to STDERR
+" );
}
sub stderr_like {
my ($self, $expect, $label) = @_;
return $Test->like( $self->stderr, $expect,
$label
? "... $label"
: "... " . $self->program . " had correct output to STDERR
+" );
}
1; #true
You can see that in use in t/70-wikidoc-script.t.
I hope that gives you some useful ideas.
-xdg
Code written by xdg and posted on PerlMonks is public domain. It is provided as is with no warranties, express or implied, of any kind. Posted code may not have been tested. Use of posted code is at your own risk.
