view release on metacpan or  search on metacpan

test.pl  view on Meta::CPAN

# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl test.pl'

my $final = 0;

# Automatically generates an ok/nok msg, incrementing the test number.
BEGIN {
   my($next, @msgs);
   sub printok {
      push @msgs, ($_[0] ? '' : 'not ') . "ok @{[++$next]}\n";
      return !$_[0];
   }
   END {
      print "\n1..", scalar @msgs, "\n", @msgs;
   }
}

use Argv;
$final += printok(1);

# Make sure output arrives synchronously.
select(STDERR); $| = 1; select(STDOUT); $| = 1;

print "+ Testing basic construction and execution ...\n";
my $pl = Argv->new($^X, '-v');
$pl->stdout(0);
$pl->system;
$final += printok($? == 0);

print "+ Testing instance cloning ...\n";
$pl->clone->system;
$final += printok($? == 0);

print "+ Testing construction using references ...\n";
$final += printok(Argv->new($^X, [qw(-v)])->stdout(0)->system('') == 0);

print "+ Testing 'noexec' instance-method form ...\n";
$pl->noexec(1)->system;
$final += printok($? == 0);

print "+ Testing 'autofail' exception-handling ...\n";
$pl->argv($^X, ['-BADFLAG']);
$pl->autofail([\&printok, 1]);
$pl->stderr(0)->system;

print "+ Testing 'glob' method ...\n";
my $echo = Argv->new(qw(echo *));
$echo->glob;
print "'echo *' globs to: ";
$echo->system;
$final += printok($? == 0);

print "+ Testing 'dbglevel' instance-method form ...\n";
Argv->dbglevel(1);
my $ld = Argv->new($^X, qw(-bogus flag -V:ld));
$ld->dbglevel(0);
$ld->parse(qw(bogus=s));
$ld->system('-');
$final += printok($? == 0);
$ld->dbglevel(0);

$ld->dfltsets({'-' => 1});
print $ld->qx;
$final += printok($? == 0);

# Expected to return nonzero status and error (suppressed).
$final += printok(Argv->new('no-such-cmd')->stderr(0)->system);

my $e2 = Argv->new(qw(foo -y -x foo -r Next-to-last-test ...));
$e2->optset(qw(ONE TWO THREE));
$e2->parseONE(qw(x=s));
$e2->parseTWO(qw(y z));
$e2->parseTHREE('r');
$e2->prog('echo');
$e2->system;
$final += printok(!$? && ($e2->optsONE + $e2->optsTWO + $e2->optsTHREE) == 4);

exit $final if $final;

my $id2 = Argv->new(qw(id -y -x foo -a -r));
$id2->optset(qw(REMOVED));