[Bps-public-commit] Prophet - A disconnected, replicated p2p database branch, master, updated. 2085145865b59ba5eca002ffbb014dd353171832
sunnavy at bestpractical.com
sunnavy at bestpractical.com
Tue Feb 17 09:53:07 EST 2009
The branch, master has been updated
via 2085145865b59ba5eca002ffbb014dd353171832 (commit)
from b69a5bfa5d50ebbe5aa311adad999f45675f09d3 (commit)
Summary of changes:
Makefile.PL | 1 +
lib/Prophet/Test.pm | 262 +--------------------------------------------------
2 files changed, 2 insertions(+), 261 deletions(-)
- Log -----------------------------------------------------------------
commit 2085145865b59ba5eca002ffbb014dd353171832
Author: sunnavy <sunnavy at gmail.com>
Date: Tue Feb 17 22:52:20 2009 +0800
use Test::Script::Run
diff --git a/Makefile.PL b/Makefile.PL
index c86476d..4b8178f 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -24,6 +24,7 @@ requires( 'Path::Dispatcher' => '0.09' ); # Path::Dispatcher::Declarative
requires('Time::Progress');
build_requires( 'Test::Exception' => '0.26' );
+build_requires( 'Test::Script::Run' );
use Term::ReadLine; # if we don't do this, ::Perl fails
feature 'Improved interactive shell' => -default => 1,
diff --git a/lib/Prophet/Test.pm b/lib/Prophet/Test.pm
index 677fa75..124bc15 100644
--- a/lib/Prophet/Test.pm
+++ b/lib/Prophet/Test.pm
@@ -3,6 +3,7 @@ use warnings;
package Prophet::Test;
use base qw/Test::More Exporter/;
+use Test::Script::Run ':all';
our @EXPORT = qw/as_alice as_bob as_charlie as_david as_user run_ok repo_uri_for run_script run_output_matches run_output_matches_unordered replica_last_rev replica_uuid_for ok_added_revisions replica_uuid database_uuid database_uuid_for
serialize_conflict serialize_changeset in_gladiator diag is_script_output run_command set_editor load_record
/;
@@ -11,7 +12,6 @@ use File::Path 'rmtree';
use File::Spec;
use File::Temp qw/tempdir tempfile/;
use Test::Exception;
-use IPC::Run3 'run3';
use Params::Validate ':all';
use Scalar::Defer qw/lazy defer force/;
use Prophet::Util;
@@ -101,266 +101,6 @@ sub in_gladiator (&) {
}
-=head2 run_script($script, $args, $stdout, $stderr)
-
-Runs the script $script as a perl script, setting the @INC to the same as
-our caller.
-
-$script is the name of the script to be run (such as 'prophet'). $args is a
-reference to an array of arguments to pass to the script. $stdout and $stderr
-are both optional; if passed in, they will be passed to L<IPC::Run3>'s run3
-subroutine as its $stdout and $stderr args. Otherwise, this subroutine will
-create scalar references to pass to run3 instead (which are treated as strings
-for STDOUT/STDERR to be written to).
-
-Returns run3's return value and, if no $stdout and $stderr were passed in, the
-STDOUT and STDERR of the script that was run.
-
-=cut
-
-sub run_script {
- my $script = shift;
- my $args = shift || [];
- my ( $stdout, $stderr ) = @_;
- my ( $new_stdout, $new_stderr, $return_stdouterr );
- if (!ref($stdout) && !ref($stderr)) {
- ($stdout, $stderr, $return_stdouterr) = (\$new_stdout, \$new_stderr, 1);
- }
- my @cmd = _get_perl_cmd($script);
-
- local $ENV{IN_PROPHET_TEST_COMMAND} = 1;
-
- # diag(join(' ', @cmd, @$args));
- my $ret = run3 [ @cmd, @$args ], undef, $stdout, $stderr;
- # we don't actually want to die if the run command returned an error code
- # Carp::croak $stderr if $?;
- #diag( "STDOUT: " . $stdout ) if ($stdout);
- #diag( "STDERR: " . $stderr ) if ($stderr);
-
- #Test::More::diag $stderr;
- return $return_stdouterr ? ( $ret, $$stdout, $$stderr ) : $ret;
-}
-
-our $RUNCNT;
-
-sub _get_perl_cmd {
- my ($tmp, $i) = (Prophet::Util->updir($0), 0);
- while ( ! -d File::Spec->catdir($tmp, 'bin') && $i++ < 10 ) {
- $tmp = Prophet::Util->updir($tmp);
- }
-
- my $base_dir = File::Spec->catdir($tmp, 'bin');
- die "couldn't find bin dir" unless -d $base_dir;
-
- my $script = shift;
- my @cmd = ( $^X, ( map {"-I$_"} @INC ) );
- push @cmd, '-MDevel::Cover' if $INC{'Devel/Cover.pm'};
- if ( $INC{'Devel/DProf.pm'} ) {
- push @cmd, '-d:DProf';
- $ENV{'PERL_DPROF_OUT_FILE_NAME'} = 'tmon.out.' . $$ . '.' . $RUNCNT++;
- }
- push @cmd, File::Spec->catdir($base_dir => $script);
- return @cmd;
-}
-
-=head2 run_ok($script, $args, $msg)
-
-Runs the script, checking that it didn't error out.
-
-$script is the name of the script to be run (e.g. 'prophet'). $args
-is an optional reference to an array of arguments to pass to the
-script when it is run. $msg is an optional message to print with
-the test. If $args is not specified, you can still pass in
-a $msg.
-
-Returns nothing of interest.
-
-=cut
-
-sub run_ok {
- my $script = shift;
- my $args = shift if ( ref $_[0] eq 'ARRAY' );
- my $msg = (@_) ? shift : '';
-
- local $Test::Builder::Level = $Test::Builder::Level + 1;
-
- lives_and {
- local $Test::Builder::Level = $Test::Builder::Level + 1;
- my ( $ret, $stdout, $stderr ) = run_script( $script, $args );
- # diag("STDOUT: " . $stdout) if ($stdout);
- # diag("STDERR: " . $stderr) if ($stderr);
- ok($ret, $msg);
- };
-}
-
-=head2 is_script_output($scriptname \@args, \@stdout_match, \@stderr_match, $msg)
-
-Runs $scriptname, checking to see that its output matches.
-
-$args is an array reference of args to pass to the script. $stdout_match and
-$stderr_match are references to arrays of expected lines. $msg is a string
-message to display with the test. $stderr_match and $msg are optional. (As is
-$stdout_match if for some reason you expect your script to have no output at
-all. But that would be silly, wouldn't it?)
-
-Allows regex matches as well as string equality (lines in $stdout_match and
-$stderr_match may be Regexp objects).
-
-=cut
-
-sub is_script_output {
- my ( $script, $args, $exp_stdout, $exp_stderr, $msg ) = @_;
- local $Test::Builder::Level = $Test::Builder::Level + 1;
-
- my $stdout_err = [];
- $exp_stderr ||= [];
-
- my $ret = run_script($script, $args,
- _mk_cmp_closure( $exp_stdout, $stdout_err ), # stdout
- _mk_cmp_closure( $exp_stderr, $stdout_err ), # stderr
- );
-
- _check_cmp_closure_output($script, $msg, $args, $exp_stdout, $stdout_err);
-}
-
-=head2 _mk_cmp_closure($expected, $error)
-
-$expected is a reference to an array of expected output lines, and
-$error is an array reference for storing error messages.
-
-Returns a subroutine that takes a line of output and compares it
-to the next line in $expected. You can, for example, pass this
-subroutine to L<IPC::Run3>::run3 and it will compare the output
-of the script being run to the expected output. After the script
-is done running, errors will be in $error.
-
-If a line in $expected is a Regexp reference (made with e.g.
-qr/foo/), the subroutine will check for a regexp match rather
-than string equality.
-
-=cut
-
-sub _mk_cmp_closure {
- my ( $exp, $err ) = @_;
- my $line = 0;
-
- $exp = [$exp] if ref($exp) ne 'ARRAY';
-
- sub {
- my $output = shift;
- chomp $output;
- ++$line;
- unless (@$exp) {
- push @$err, "$line: got $output";
- return;
- }
- my $item = shift @$exp;
- push @$err, "$line: got ($output), expect ($item)\n"
- unless ref($item) eq 'Regexp'
- ? ( $output =~ m/$item/ )
- : ( $output eq $item );
- }
-}
-
-# XXX note that this sub doesn't check to make sure we got
-# all the errors we were expecting (there can be more lines
-# in the expected stderr than the received stderr as long
-# as they match up until the end of the received stderr --
-# the same isn't true of stdout)
-sub _check_cmp_closure_output {
- my ($script, $msg, $args, $exp_stdout, $stdout_err) = @_;
-
- for my $line (@$exp_stdout) {
- next if !defined $line;
- push @$stdout_err, "got nothing, expected: $line";
- }
-
- my $test_name = join( ' ', $msg ? "$msg:" : '', $script, @$args );
- is(scalar(@$stdout_err), 0, $test_name);
-
- if (@$stdout_err) {
- diag( "Different in line: " . join( "\n", @$stdout_err ) );
- }
-}
-
-=head2 run_output_matches($script, $args, $exp_stdout, $exp_stderr, $msg)
-
-A wrapper around L<is_script_output> that also checks to make sure
-the test runs without throwing an exception.
-
-=cut
-
-sub run_output_matches {
- my ( $script, $args, $expected, $stderr, $msg ) = @_;
- local $Test::Builder::Level = $Test::Builder::Level + 1;
- lives_and {
- local $Test::Builder::Level = $Test::Builder::Level + 3;
- is_script_output($script, $args, $expected, $stderr, $msg);
- };
-}
-
-=head2 run_output_matches_unordered($script, $args, $exp_stdout, $exp_stderr, $msg)
-
-This subroutine has exactly the same functionality as run_output_matches, but
-doesn't impose a line ordering when comparing the expected and received
-outputs.
-
-=cut
-
-sub run_output_matches_unordered {
- my ($cmd, $args, $stdout, $stderr, $msg) = @_;
- $stderr ||= [];
-
- my ($val, $out, $err) = run_script( $cmd, $args );
-
- local $Test::Builder::Level = $Test::Builder::Level + 1;
-
- # Check if each line matches a line in the expected output and
- # delete that line if we have a match. If no match is found,
- # add an error.
- my $errors = [];
- my @lines = split /\n/, $out;
- OUTPUT: while (my $line = shift @lines) {
- for my $exp_line (@$stdout) {
- if ((ref($exp_line) eq 'Regexp' ? ( $line =~ m/$exp_line/ ) :
- ( $line eq $exp_line ))) {
- # remove the found element from the array of expected output
- $stdout = [grep { $_ ne $exp_line } @$stdout];
- next OUTPUT;
- }
- }
- # we didn't find a match
- push @$errors, "couldn't find match for ($line)\n";
- }
-
- # do the same for STDERR
- @lines = split /\n/, $err;
- ERROR: while (my $line = shift @lines) {
- for my $exp_line (@$stderr) {
- if ((ref($exp_line) eq 'Regexp' ? ( $line =~ m/$exp_line/ ) :
- ( $line eq $exp_line ))) {
- # remove the found element from the array of expected output
- $stderr = [grep { $_ ne $exp_line } @$stderr];
- next ERROR;
- }
- }
- # we didn't find a match
- push @$errors, "couldn't find match for ($line)\n";
- }
-
- # add any expected lines that we didn't find to the errors
- for my $exp_line (@$stdout, @$stderr) {
- push @$errors, "got nothing, expected: $exp_line";
- }
-
- my $test_name = join( ' ', $msg ? "$msg:" : '', $cmd, @$args );
- is(scalar(@$errors), 0, $test_name);
-
- if (@$errors) {
- diag( "Errors: " . join( "\n", @$errors ) );
- }
-}
-
=head2 repo_path_for($username)
Returns a path on disk for where $username's replica is stored.
-----------------------------------------------------------------------
More information about the Bps-public-commit
mailing list