diff options
Diffstat (limited to 'dist/Test-PerlRun/lib/Test/PerlRun.pm')
| -rw-r--r-- | dist/Test-PerlRun/lib/Test/PerlRun.pm | 242 |
1 files changed, 242 insertions, 0 deletions
diff --git a/dist/Test-PerlRun/lib/Test/PerlRun.pm b/dist/Test-PerlRun/lib/Test/PerlRun.pm new file mode 100644 index 0000000000..7bb234edb7 --- /dev/null +++ b/dist/Test-PerlRun/lib/Test/PerlRun.pm @@ -0,0 +1,242 @@ +package Test::PerlRun; + +use strict; +use warnings; + +use File::Spec; +use IPC::Cmd qw( run ); +use Test::Builder; + +use base 'Exporter'; + +our @EXPORT = qw( + perlrun_exit_status_is + perlrun_stdout_is + perlrun_stdout_like + perlrun_stderr_is + perlrun_stderr_like +); + +my $TB = Test::Builder->new(); + +sub perlrun_exit_status_is { + my $error = ( _run(shift) )[2]; + # This is a hack, but unfortunately IPC::Cmd local-izes $? so we cannot + # check that directly. + my ($status) = $error ? ( $error =~ /exited with value (\d+)/ ) : 0; + + local $Test::Builder::Level = $Test::Builder::Level + 1; + $TB->is_eq( $status, @_ ); +} + +sub perlrun_stdout_is { + my ( $stdout, $stderr ) = _run(shift); + + local $Test::Builder::Level = $Test::Builder::Level + 1; + $TB->is_eq( $stdout, @_ ); +} + +sub perlrun_stdout_like { + my ( $stdout, $stderr ) = _run(shift); + + local $Test::Builder::Level = $Test::Builder::Level + 1; + $TB->like( $stdout, @_ ); +} + +sub perlrun_stderr_is { + my ( $stdout, $stderr ) = _run(shift); + + local $Test::Builder::Level = $Test::Builder::Level + 1; + $TB->is_eq( $stderr, @_ ); +} + +sub perlrun_stderr_like { + my ( $stdout, $stderr ) = _run(shift); + + local $Test::Builder::Level = $Test::Builder::Level + 1; + $TB->like( $stderr, @_ ); +} + +sub _run { + my $p = ref $_[0] ? shift : { code => shift }; + + die "You cannot run a command without some Perl code to execute" + unless grep { defined $p->{$_} && length $p->{$_} } qw( code file ); + + my @args + = defined $p->{switches} && !ref $p->{switches} + ? $p->{switches} + : @{ $p->{switches} || [] }; + + if ( exists $p->{code} ) { + push @args, '-e', $p->{code}; + } + else { + push @args, $p->{file}; + } + my $perl = _which_perl(); + + my ( $ok, $err, undef, $stdout, $stderr ) = run( + command => [ _which_perl(), @args, ], + ); + + return ( + ( join q{}, @{$stdout} ), + ( join q{}, @{$stderr} ), + $err + ); +} + +{ + my $IsVMS = $^O eq 'VMS'; + + my $Perl; + + # Code stolen from t/test.pl - simplified because we can safely load other + # modules. + # + # A somewhat safer version of the sometimes wrong $^X. + sub _which_perl { + return $Perl if defined $Perl; + + $Perl = $^X; + + # VMS should have 'perl' aliased properly + return $Perl if $IsVMS; + + require Config; + + my $exe = defined $Config::Config{_exe} ? $Config::Config{_exe} : q{}; + + # This doesn't absolutize the path: beware of future chdirs(). + # We could do File::Spec->abs2rel() but that does getcwd()s, + # which is a bit heavyweight to do here. + + if ( $Perl =~ /^perl\Q$exe\E$/i ) { + my $perl = "perl$exe"; + $Perl = File::Spec->catfile( File::Spec->curdir(), $perl ); + } + + # Build up the name of the executable file from the name of + # the command. + if ( $Perl !~ /\Q$exe\E$/i ) { + $Perl = $Perl . $exe; + } + + warn "which_perl: cannot find $Perl from $^X" unless -f $Perl; + + # For subcommands to use. + $ENV{PERLEXE} = $Perl; + + return $Perl; + } +} + +1; + +__END__ + +=head1 NAME + +Test::PerlRun - run perl and test the exit status or output + +=head1 SYNOPSIS + + use Test::More; + use Test::PerlRun; + + perlrun_exit_status_is( 'exit 42', 42, 'code exited with status == 42' ); + + perlrun_stdout_is( q[print 'hello'], 'hello', 'code printed hello' ); + + perlrun_stdout_like( + { file => '/path/to/code' }, + 'hello', + 'code printed hello' + ); + + perlrun_stderr_like( + { + code => q[warn 'TAINT' if ${^TAINT}], + switches => '-T', + }, + 'hello', + 'code printed hello' + ); + +=head1 DESCRIPTION + +This module provides a thin test wrapper for testing the execution of some +Perl code in a separate process. It was adapted from code in the Perl core's +F<t/test.pl> file, and is primarily intended for testing modules that are +shipped with the Perl core. + +If you are writing tests for code outside the Perl core, you should first look +at L<Test::Command>, L<Test::Script>, or L<Test::Script::Run>. + +=head1 FUNCTIONS + +All the functions that this module provides accept the same first +argument. This can be either a scalar containing Perl code to run, or a hash +reference. + +If you pass a hash reference, you can use the following keys: + +=over 4 + +=item * code + +This should be a string of code to run. + +=item * file + +A file containing Perl code to execute. You cannot pass both C<code> and +C<file> parameters. + +=item * switches + +This can either be a scalar or an array reference of scalars. Each scalar +should be a switch that will be passed to the F<perl> command, like C<-T> or +C<-C>. + +=back + +This module exports the following functions: + +=head2 perlrun_exit_status_is( $code, $status, $description ) + +This function runs the specified code and checks if the exit status matches +the status you provide. + +=head2 perlrun_stdout_is( $code, $output, $description ) + +This function runs the specified code and checks if the output sent to +C<stdout> matches the output you expect. + +=head2 perlrun_stdout_like( $code, $output_regex, $description ) + +This function runs the specified code and checks if the output sent to +C<stdout> matches the output regex you expect. + +=head2 perlrun_stderr_is( $code, $output, $description ) + +This function runs the specified code and checks if the output sent to +C<stderr> matches the output you expect. + +=head2 perlrun_stderr_like( $code, $output_regex, $description ) + +This function runs the specified code and checks if the output sent to +C<stderr> matches the output regex you expect. + +=head1 AUTHOR + +Dave Rolsky, <autarch@urth.org> + +=head1 LICENSE + +Copyright (c) 2011 Dave Rolsky. All rights reserved. + +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=cut |