File Coverage

blib/lib/App/Cmd/Tester.pm

Criterion	Covered	Total	%
statement	48	48	100.0
branch	12	14	85.7
condition	9	11	81.8
subroutine	12	12	100.0
pod	1	2	50.0
total	82	87	94.2

use strict;
use warnings;
package App::Cmd::Tester 0.334;

# ABSTRACT: for capturing the result of running an app

#pod =head1 SYNOPSIS
#pod
#pod   use Test::More tests => 4;
#pod   use App::Cmd::Tester;
#pod
#pod   use YourApp;
#pod
#pod   my $result = test_app(YourApp => [ qw(command --opt value) ]);
#pod
#pod   like($result->stdout, qr/expected output/, 'printed what we expected');
#pod
#pod   is($result->stderr, '', 'nothing sent to sderr');
#pod
#pod   is($result->error, undef, 'threw no exceptions');
#pod
#pod   my $result = test_app(YourApp => [ qw(command --opt value --quiet) ]);
#pod
#pod   is($result->output, '', 'absolutely no output with --quiet');
#pod
#pod =head1 DESCRIPTION
#pod
#pod One of the reasons that user-executed programs are so often poorly tested is
#pod that they are hard to test.  App::Cmd::Tester is one of the tools App-Cmd
#pod provides to help make it easy to test App::Cmd-based programs.
#pod
#pod It provides one routine: test_app.
#pod
#pod =method test_app
#pod
#pod B: while C is a method, it is by default exported as a
#pod subroutine into the namespace that uses App::Cmd::Tester.  In other words: you
#pod probably don't need to think about this as a method unless you want to subclass
#pod App::Cmd::Tester.
#pod
#pod   my $result = test_app($app_class => \@argv_contents);
#pod
#pod This will locally set C<@ARGV> to simulate command line arguments, and will
#pod then call the C method on the given application class (or application).
#pod Output to the standard output and standard error filehandles  will be captured.
#pod
#pod C<$result> is an App::Cmd::Tester::Result object, which has methods to access
#pod the following data:
#pod
#pod   stdout - the output sent to stdout
#pod   stderr - the output sent to stderr
#pod   output - the combined output of stdout and stderr
#pod   error  - the exception thrown by running the application, or undef
#pod   run_rv - the return value of the run method (generally irrelevant)
#pod   exit_code - the numeric exit code that would've been issued (0 is 'okay')
#pod
#pod The output is captured using L, which I ensure that the
#pod ordering is preserved in the combined output, but I capture the output
#pod of external programs.  You can reverse these tradeoffs by using
#pod L instead.
#pod
#pod =cut

use Sub::Exporter::Util qw(curry_method);
use Sub::Exporter -setup => {
  exports => { test_app => curry_method },
  groups  => { default  => [ qw(test_app) ] },
};

our $TEST_IN_PROGRESS;
BEGIN {
  *CORE::GLOBAL::exit = sub {
    my ($rc) = @_;
    return CORE::exit($rc) unless $TEST_IN_PROGRESS;
    App::Cmd::Tester::Exited->throw($rc);
  };
}

#pod =for Pod::Coverage result_class
#pod
#pod =cut

sub result_class { 'App::Cmd::Tester::Result' }

sub test_app {
  my ($class, $app, $argv) = @_;

  local $App::Cmd::_bad = 0;

  $app = $app->new unless ref($app) or $app->isa('App::Cmd::Simple');

  my $result = $class->_run_with_capture($app, $argv);

  my $error = $result->{error};

  my $exit_code = defined $error ? ((0+$!)||-1) : 0;

  if ($error and eval { $error->isa('App::Cmd::Tester::Exited') }) {
    $exit_code = $$error;
  }

  $exit_code =1 if $App::Cmd::_bad && ! $exit_code;

  $class->result_class->new({
    app    => $app,
    exit_code => $exit_code,
    %$result,
  });
}

sub _run_with_capture {
  my ($class, $app, $argv) = @_;

  require IO::TieCombine;
  my $hub = IO::TieCombine->new;

  my $stdout = tie local *STDOUT, $hub, 'stdout';
  my $stderr = tie local *STDERR, $hub, 'stderr';

  my $run_rv;

  my $ok = eval {
    local $TEST_IN_PROGRESS = 1;
    local @ARGV = @$argv;
    $run_rv = $app->run;
    1;
  };

  my $error = $ok ? undef : $@;

  return {
    stdout => $hub->slot_contents('stdout'),
    stderr => $hub->slot_contents('stderr'),
    output => $hub->combined_contents,
    error  => $error,
    run_rv => $run_rv,
  };
}

{
  package App::Cmd::Tester::Result 0.334;

  sub new {
    my ($class, $arg) = @_;
    bless $arg => $class;
  }

  for my $attr (qw(app stdout stderr output error run_rv exit_code)) {
    Sub::Install::install_sub({
      code => sub { $_[0]->{$attr} },
      as   => $attr,
    });
  }
}

{
  package App::Cmd::Tester::Exited 0.334;

  sub throw {
    my ($class, $code) = @_;
    $code = 0 unless defined $code;
    my $self = (bless \$code => $class);
    die $self;
  }
}

1;

__END__