Test-Script-1.10/0000755000175000017500000000000012524342301013154 5ustar ollisgollisgTest-Script-1.10/lib/0000755000175000017500000000000012524342301013722 5ustar ollisgollisgTest-Script-1.10/lib/Test/0000755000175000017500000000000012524342301014641 5ustar ollisgollisgTest-Script-1.10/lib/Test/Script.pm0000644000175000017500000002705512524342301016454 0ustar ollisgollisgpackage Test::Script; # ABSTRACT: Basic cross-platform tests for scripts our $VERSION = '1.10'; # VERSION use 5.006; use strict; use warnings; use Carp (); use Exporter (); use File::Spec (); use File::Spec::Unix (); use Probe::Perl (); use IPC::Run3 qw( run3 ); use Test::Builder (); our @ISA = 'Exporter'; our @EXPORT = qw{ script_compiles script_compiles_ok 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 }; sub import { my $self = shift; my $pack = caller; my $test = Test::Builder->new; $test->exported_to($pack); $test->plan(@_); foreach ( @EXPORT ) { $self->export_to_level(1, $self, $_); } } my $perl = undef; sub perl () { $perl or $perl = Probe::Perl->find_perl_interpreter; } sub path ($) { my $path = shift; unless ( defined $path ) { Carp::croak("Did not provide a script name"); } if ( File::Spec::Unix->file_name_is_absolute($path) ) { Carp::croak("Script name must be relative"); } File::Spec->catfile( File::Spec->curdir, split /\//, $path ); } ## This can and should be removed if/when IPC::Run3 is fixed on MSWin32 ## See rt94685, rt46333, rt95308 and IPC-Run3/gh#9" sub _borked_ipc_run3 () { $^O eq 'MSWin32' && ! eval { $! = 0; IPC::Run3::run3 [ perl, -e => 'BEGIN {die}' ], \undef, \undef, \undef; 1 } } if(_borked_ipc_run3()) { no warnings 'redefine'; *run3 = sub { $! = 0; my $r = IPC::Run3::run3(@_, { return_if_system_error => 1 }); Carp::croak($!) if $! && $! !~ /Inappropriate I\/O control operation/; $r; }; } ##################################################################### # Test Functions sub script_compiles { my $args = _script(shift); my $unix = shift @$args; my $path = path( $unix ); my @libs = map { "-I$_" } grep {!ref($_)} @INC; my $cmd = [ perl, @libs, '-c', $path, @$args ]; my $stdin = ''; my $stdout = ''; my $stderr = ''; my $rv = eval { run3( $cmd, \$stdin, \$stdout, \$stderr ) }; my $error = $@; my $exit = $? ? ($? >> 8) : 0; my $signal = $? ? ($? & 127) : 0; my $ok = !! ( $error eq '' and $rv and $exit == 0 and $signal == 0 and $stderr =~ /syntax OK\s+\z/si ); my $test = Test::Builder->new; $test->ok( $ok, $_[0] || "Script $unix compiles" ); $test->diag( "$exit - $stderr" ) unless $ok; $test->diag( "exception: $error" ) if $error; $test->diag( "signal: $signal" ) if $signal; return $ok; } my $stdout; my $stderr; sub script_runs { my $args = _script(shift); my $opt = _options(\@_); my $unix = shift @$args; my $path = path( $unix ); my @libs = map { "-I$_" } grep {!ref($_)} @INC; my $cmd = [ perl, @libs, $path, @$args ]; $stdout = ''; $stderr = ''; my $rv = eval { run3( $cmd, $opt->{stdin}, $opt->{stdout}, $opt->{stderr} ) }; my $error = $@; my $exit = $? ? ($? >> 8) : 0; my $signal = $? ? ($? & 127) : 0; my $ok = !! ( $error eq '' and $rv and $exit == $opt->{exit} and $signal == $opt->{signal} ); my $test = Test::Builder->new; $test->ok( $ok, $_[0] || "Script $unix runs" ); $test->diag( "$exit - $stderr" ) unless $ok; $test->diag( "exception: $error" ) if $error; $test->diag( "signal: $signal" ) unless $signal == $opt->{signal}; return $ok; } sub _like { my($text, $pattern, $regex, $not, $name) = @_; my $ok = $regex ? $text =~ $pattern : $text eq $pattern; $ok = !$ok if $not; my $test = Test::Builder->new; $test->ok( $ok, $name ); unless($ok) { $test->diag( "The output" ); $test->diag( " $_") for split /\n/, $text; $test->diag( $not ? "does match" : "does not match" ); if($regex) { $test->diag( " $pattern" ); } else { $test->diag( " $_" ) for split /\n/, $pattern; } } $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; } ###################################################################### # 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; } } Carp::croak("Invalid command parameter"); } # Inline some basic Params::Util functions sub _options { 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} = \$stdout unless defined $options{stdout}; $options{stderr} = \$stderr unless defined $options{stderr}; \%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__ =pod =encoding UTF-8 =head1 NAME Test::Script - Basic cross-platform tests for scripts =head1 VERSION version 1.10 =head1 SYNOPSIS use Test::More tests => 2; use Test::Script; script_compiles('script/awesomescript.pl'); script_runs(['script/awesomescript.pl', '--awesome-argument']); =head1 DESCRIPTION The intent of this module is to provide a series of basic tests for 80% of the testing you will need to do for scripts in the F