first pass at Test::PerlRun

5 files changed, 350 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
diff --git a/dist/Test-PerlRun/t/PerlRun.t b/dist/Test-PerlRun/t/PerlRun.t
new file mode 100644
index 0000000000..317d4a8cc0
--- /dev/null
+++ b/dist/Test-PerlRun/t/PerlRun.t
@@ -0,0 +1,62 @@
+use strict;
+use warnings;
+
+use File::Temp qw( tempfile );
+use Test::Builder::Tester;
+use Test::More;
+
+use Test::PerlRun;
+
+test_out('ok 1');
+perlrun_exit_status_is( 'exit 42', 42 );
+test_test('exit status');
+
+test_out('ok 1');
+perlrun_exit_status_is( { code => 'exit 42' }, 42 );
+test_test('exit status, code in hashref with code key');
+
+my ( $fh, $file ) = tempfile( UNLINK => 1 );
+print {$fh} 'exit 42;' or die "Cannot write to $file: $!";
+close $fh or die "Cannot write to $file: $!";
+
+test_out('ok 1');
+perlrun_exit_status_is( { file => $file }, 42 );
+test_test('exit status, code in temp file');
+
+test_out('ok 1');
+perlrun_stdout_is( q{print 'hello'}, 'hello' );
+test_test('stdout_is');
+
+test_out('ok 1');
+perlrun_stdout_like( q{print 'hello'}, qr/hell/ );
+test_test('stdout_like');
+
+test_out('ok 1');
+perlrun_stderr_is( q{print STDERR 'hello'}, 'hello' );
+test_test('stderr_is');
+
+test_out('ok 1');
+perlrun_stderr_like( q{print STDERR 'hello'}, qr/hell/ );
+test_test('stderr_like');
+
+test_out('ok 1');
+perlrun_stdout_is(
+    {
+        code     => q{print ${^TAINT} ? 'tainting' : 'no taint'},
+        switches => '-T',
+    },
+    'tainting'
+);
+test_test('single scalar passed for switches parameter');
+
+test_out('ok 1');
+perlrun_stdout_is(
+    {
+        code     => q{print ${^TAINT} ? 'tainting' : 'no taint'},
+        switches => ['-T'],
+    },
+    'tainting'
+);
+test_test('array ref passed for switches parameter');
+
+done_testing();
diff --git a/dist/Test-PerlRun/t/pod-coverage.t b/dist/Test-PerlRun/t/pod-coverage.t
new file mode 100644
index 0000000000..c7f97f92f2
--- /dev/null
+++ b/dist/Test-PerlRun/t/pod-coverage.t
@@ -0,0 +1,10 @@
+use strict;
+use warnings;
+
+use Test::More;
+
+eval "use Test::Pod::Coverage 1.04";
+plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage"
+    if $@;
+
+all_pod_coverage_ok();
diff --git a/dist/Test-PerlRun/t/pod-spell.t b/dist/Test-PerlRun/t/pod-spell.t
new file mode 100644
index 0000000000..d1f78b668d
--- /dev/null
+++ b/dist/Test-PerlRun/t/pod-spell.t
@@ -0,0 +1,27 @@
+use strict;
+use warnings;
+
+use Test::More;
+
+eval "use Test::Spelling";
+plan skip_all => "Test::Spelling required for testing POD coverage"
+    if $@;
+
+my @stopwords;
+for (<DATA>) {
+    chomp;
+    push @stopwords, $_
+        unless /\A (?: \# | \s* \z)/msx;    # skip comments, whitespace
+}
+
+add_stopwords(@stopwords);
+set_spell_cmd('aspell list -l en');
+
+# This prevents a weird segfault from the aspell command - see
+# https://bugs.launchpad.net/ubuntu/+source/aspell/+bug/71322
+local $ENV{LC_ALL} = 'C';
+all_pod_files_spelling_ok();
+
+__DATA__
+Rolsky
+
diff --git a/dist/Test-PerlRun/t/pod.t b/dist/Test-PerlRun/t/pod.t
new file mode 100644
index 0000000000..69d8e606bd
--- /dev/null
+++ b/dist/Test-PerlRun/t/pod.t
@@ -0,0 +1,9 @@
+use strict;
+use warnings;
+
+use Test::More;
+
+eval "use Test::Pod 1.14";
+plan skip_all => "Test::Pod 1.14 required for testing POD" if $@;
+
+all_pod_files_ok();