Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

[GH #892] Implement our capture and use it

No need to ship a IO::CaptureOutput.
Use the new capture function in t/configure/033-step.t and
t/configure/034-step.t.
t/configure/034-step.t tests now the new replace_stash option correctly. See [GH #891].
  • Loading branch information...
commit 3741ae29fdc355c0fbe2fd90f786a43a8627e82a 1 parent 36b9d41
@rurban rurban authored
View
51 lib/Parrot/Configure/Utils.pm
@@ -1,4 +1,4 @@
-# Copyright (C) 2001-2008, Parrot Foundation.
+# Copyright (C) 2001-2012, Parrot Foundation.
=head1 NAME
@@ -14,6 +14,8 @@ object as an argument. Those subroutines formerly found in this module which
B<do> require the Parrot::Configure object as an argument have been moved into
Parrot::Configure::Compiler.
+Beware that Parrot::Config is not available at configure time.
+
=head2 Functions
=over 4
@@ -36,7 +38,7 @@ use Parrot::BuildUtil ();
our @EXPORT = ();
our @EXPORT_OK = qw(
prompt copy_if_diff move_if_diff integrate
- capture_output check_progs _slurp
+ capture capture_output check_progs _slurp
_run_command _build_compile_command
print_to_cache read_from_cache
);
@@ -246,6 +248,49 @@ sub move_if_diff { ## no critic Subroutines::RequireFinalReturn
unlink $from;
}
+=item C<capture($coderef)>
+
+Evals the given function without argument. The function return value,
+the captured stdout and stderr value, and its return status is returned as
+a 4-tuple.
+B<STDOUT> is redirected to F<test.out> during the execution, and deleted
+after the command's run.
+B<STDERR> is redirected to F<test.err> during the execution, and deleted
+after the command's run.
+
+=cut
+
+sub capture {
+ my $command = shift;
+
+ # disable STDOUT/STDERR
+ open my $OLDOUT, '>&', \*STDOUT;
+ open STDOUT, '>', "test_$$.out";
+ open my $OLDERR, '>&', \*STDERR;
+ open STDERR, '>', "test_$$.err";
+
+ my $output = eval { &$command; };
+ my $retval = $@;
+ $@ = '';
+
+ # reenable STDOUT/STDERR
+ close STDOUT;
+ open STDOUT, '>&', $OLDOUT;
+ close STDERR;
+ open STDERR, '>&', $OLDERR;
+
+ # slurp stderr
+ my $out = _slurp("./test_$$.out");
+ my $out_err = _slurp("./test_$$.err");
+
+ # cleanup
+ unlink "test_$$.out";
+ unlink "test_$$.err";
+
+ return ( $output, $out, $out_err, $retval ) if wantarray;
+ return $output;
+}
+
=item C<capture_output($command)>
Executes the given command. The command's output (both stdout and stderr), and
@@ -255,7 +300,7 @@ F<test.err> during the execution, and deleted after the command's run.
=cut
sub capture_output {
- my $command = join ' ', @_;
+ my $command = join(' ', @_);
# disable STDERR
open my $OLDERR, '>&', \*STDERR;
View
28 t/configure/033-step.t
@@ -11,8 +11,8 @@ use File::Basename qw(basename dirname);
use File::Temp 0.13 qw/ tempfile /;
use File::Spec;
use lib qw( lib t/configure/testlib );
-use IO::CaptureOutput qw | capture |;
use Tie::Filehandle::Preempt::Stdin;
+use Parrot::Configure::Utils qw(_slurp capture);
BEGIN { use Parrot::Configure::Utils; }
@@ -40,10 +40,8 @@ can_ok( 'Tie::Filehandle::Preempt::Stdin', ('READLINE') );
isa_ok( $object, 'Tie::Filehandle::Preempt::Stdin' );
$cc = q{gcc-3.3};
{
- my $rv;
- my $stdout;
- capture ( sub { $rv = prompt( "What C compiler do you want to use?", $cc ) },
- \$stdout );
+ my ($rv, $stdout) =
+ capture ( sub { prompt( "What C compiler do you want to use?", $cc ) } );
ok( $stdout, "prompts were captured" );
is( $rv, $cc, "Empty response to prompt led to expected return value" );
}
@@ -189,18 +187,18 @@ like(
my $prog = basename($fname);
my $verbose = 1;
- my $stdout;
- capture ( sub { is( check_progs( $prog, $verbose ),
- $prog, "check_progs() returns the proper program" ) }, \$stdout );
+ my ($rv, $stdout) =
+ capture ( sub { is( check_progs( $prog, $verbose ),
+ $prog, "check_progs() returns the proper program" ) } );
like( $stdout, qr/checking for program/, "Got expected verbose output" );
}
{
my $verbose = 1;
- my $stdout;
- my $prog ;
- capture ( sub { $prog = check_progs(
- [ 'gmake', 'mingw32-make', 'nmake', 'make' ], $verbose) }, \$stdout );
+ my ($prog, $stdout) =
+ capture ( sub { check_progs
+ ( [ 'gmake', 'mingw32-make', 'nmake', 'dmake', 'make' ],
+ $verbose) } );
ok( defined($prog), "check_progs() returned a 'make' program" );
like( $stdout, qr/checking for program/s, "Got expected verbose output" );
like( $stdout, qr/$prog(\.EXE)? is executable/s,
@@ -214,7 +212,7 @@ like(
my $value = 'foobar';
ok( print_to_cache( $file, $value ),
"print_to_cache() returned true value" );
- is( Parrot::Configure::Utils::_slurp($file),
+ is( _slurp($file),
"$value\n",
"Correct value printed to cachefile"
);
@@ -223,13 +221,11 @@ like(
);
}
-# _slurp(), not exported
-
{
my ( $tmpfile, $fname ) = tempfile( UNLINK => 1 );
print $tmpfile "foo" x 1000;
$tmpfile->flush;
- is( Parrot::Configure::Utils::_slurp($fname), "foo" x 1000, "_slurp() slurped the file" );
+ is( _slurp($fname), "foo" x 1000, "_slurp() slurped the file" );
}
################### DOCUMENTATION ###################
View
41 t/configure/034-step.t
@@ -1,16 +1,16 @@
#!perl
-# Copyright (C) 2001-2009, Parrot Foundation.
+# Copyright (C) 2001-2012, Parrot Foundation.
use strict;
use warnings;
-use Test::More tests => 15;
+use Test::More tests => 17;
use Carp;
use Cwd;
use File::Temp 0.13 qw/ tempdir /;
use lib qw( lib t/configure/testlib );
use Parrot::Configure;
-use IO::CaptureOutput qw | capture |;
+use Parrot::Configure::Utils qw(_slurp capture);
my $cwd = cwd();
my $conf = Parrot::Configure->new;
@@ -88,13 +88,11 @@ like(
if (@verbose@) { sprint "Hello world\n"; }
END_DUMMY
close $IN or croak "Unable to close temp file";
- my ($stdout, $stderr);
- capture ( sub { eval { $conf->genfile( $dummy => 'CFLAGS', feature_file => 1, ) } },
- \$stdout, \$stderr );
+ my ($retval, $stdout, $stderr, $evalerr) =
+ capture ( sub {$conf->genfile( $dummy => 'CFLAGS', feature_file => 1 )} );
ok( $stderr, "Error message caught" );
like( $stderr, qr/sprint/, "Error message had expected content" );
- ok( $@, "Bad Perl code caught by genfile()" );
-
+ ok( $evalerr, "Bad Perl code caught by genfile()" );
unlink $dummy or croak "Unable to delete file after testing";
chdir $cwd or croak "Unable to change back to starting directory";
}
@@ -106,12 +104,9 @@ END_DUMMY
open my $IN, '>', $dummy or croak "Unable to open temp file for writing";
print $IN q{@foobar@\n};
close $IN or croak "Unable to close temp file";
- my ($rv, $stdout, $stderr) ;
- capture (
- sub { $rv = $conf->genfile( $dummy => 'CFLAGS' ) },
- \$stdout,
- \$stderr
- );
+ my $rv;
+ my ($result, $stdout, $stderr) =
+ capture ( sub { $rv = $conf->genfile( $dummy => 'CFLAGS' ) } );
ok($rv, "genfile() returned true when warning expected" );
like( $stderr, qr/value for '\@foobar\@'/, "got expected warning" );
@@ -124,12 +119,20 @@ END_DUMMY
chdir $tdir or croak "Unable to change to temporary directory";
my $dummy = 'dummy';
open my $IN, '>', $dummy or croak "Unable to open temp file for writing";
- print $IN q{This line ends in a slash/}, qq{\n};
+ if ($^O eq 'MSWin32') {
+ print $IN q{This c:\path\to\some\file ends in a backslash \\}, "\n";
+ } else {
+ print $IN q{This /path/to/some/file ends in a backslash \\}, "\n";
+ }
close $IN or croak "Unable to close temp file";
- eval { $conf->genfile( $dummy => 'CFLAGS', replace_slashes => 1, ); };
- like( $@, qr//,
- "genfile() died as expected with replace_slashes option and line ending in trailing slash"
- );
+ ok( $conf->genfile( $dummy => 'CFLAGS', replace_slashes => 1), "genfile replace_slashes" );
+ is( $@, '', "No error" );
+ # Test that replace_slashes works and ignores ending \
+ my $expected = $^O eq 'MSWin32'
+ ? q{This c:\path\to\some\file ends in a backslash \\}."\n"
+ : q{This /path/to/some/file ends in a backslash \\}."\n";
+ my $output = _slurp($dummy);
+ is( $output, $expected, "genfile replace_slashes content" );
unlink $dummy or croak "Unable to delete file after testing";
chdir $cwd or croak "Unable to change back to starting directory";

0 comments on commit 3741ae2

Please sign in to comment.
Something went wrong with that request. Please try again.