App-Easer

 view release on metacpan or  search on metacpan

docs/docs/10-tutorial-base.md  view on Meta::CPAN

use v5.24;
use warnings;
use experimental 'signatures';
no warnings 'experimental::signatures';
use App::Easer 'run';
 
my $application = {
   factory       => {prefixes => {'#' => 'TuDu#'}},
   configuration => {
      'auto-leaves'    => 1,
      'help-on-stderr' => 1,
   },
   commands => {
      MAIN   => { ... },
      dump   => { ... },
      list   => { ... },
      show   => { ... },
      cat    => { ... },
      add    => { ... },
      edit   => { ... },
      done   => { ... },

docs/docs/10-tutorial-base.md  view on Meta::CPAN

  `foobar` inside package `TuDu`.

As a result, we have a shortcut to point towards functions inside the
`TuDu` package for our implementations.

We are setting a couple of high-level configurations:

- `auto-leaves`: every command without explicit children will be treated
  as a leaf command, so it will not get a `help` and a `commands`
  sub-commands;
- `help-on-stderr`: help messages (from `help` and `commands`) will be
  printed on standard error instead of standard output. This makes it
  more difficult to pipe them through a pager (like `more` or `less`),
  but avoids that the help messages might be accidentally considered
  part of the "real" output of the command.

The rest of the `$application` hash reference is initialized with a
skeleton of all the sub-commands that we aim to support. The structure
is pretty flat - all "real" sub-commands are in fact children to the
`MAIN` entry point.

docs/docs/10-tutorial-base.md  view on Meta::CPAN

use v5.24;
use warnings;
use experimental 'signatures';
no warnings 'experimental::signatures';
use App::Easer 'run';

my $application = {
   factory       => {prefixes => {'#' => 'TuDu#'}},
   configuration => {
      'auto-leaves'    => 1,
      'help-on-stderr' => 1,
   },
   commands => {
      MAIN => {
         help        => 'to-do application',
         description => 'A simple to-do application',
         options     => [
            {
               help        => 'path to the configuration file',
               getopt      => 'config|c=s',
               environment => 'TUDU_CONFIG',

docs/templates/getting-started.pl  view on Meta::CPAN

      # the name of the application, set it above in $APPNAME
      name               => $APPNAME,

      # figure out names of environment variables automatically
      'auto-environment' => 1,

      # sub-commands without children are leaves (no sub help/commands)
      # 'auto-leaves'    => 1,

      # help goes to standard error by default, override to stdout
      # 'help-on-stderr' => 0,

      # Where to get the specifications for commands
      # specfetch => '+SpecFromHash',         # default
      # specfetch => '+SpecFromHashOrModule', # possible alternative
   },
   commands => {
      MAIN => {
         help        => 'An application to do X',
         description => 'An application to do X, easily',

eg/tudu  view on Meta::CPAN

use v5.24;
use warnings;
use experimental 'signatures';
no warnings 'experimental::signatures';
use App::Easer 'run';

my $application = {
   factory       => {prefixes => {'#' => 'TuDu#'}},
   configuration => {
      'auto-leaves'    => 1,
      'help-on-stderr' => 1,
   },
   commands => {
      MAIN => {
         help        => 'to-do application',
         description => 'A simple to-do application',
         options     => [
            {
               help        => 'path to the configuration file',
               getopt      => 'config|c=s',
               environment => 'TUDU_CONFIG',

lib/App/Easer/V1.pm  view on Meta::CPAN

sub params_validate ($self, $spec, $args) {
   my $validator = $spec->{validate}
     // $self->{application}{configuration}{validate} // return;
   require Params::Validate;
   Params::Validate::validate($self->{configs}[-1]->%*, $validator);
} ## end sub params_validate

sub print_commands ($self, $target) {
   my $command = fetch_spec_for($self, $target);
   my $fh =
     $self->{application}{configuration}{'help-on-stderr'}
     ? \*STDERR
     : \*STDOUT;
   if (my @children = get_children($self, $command)) {
      print {$fh} list_commands($self, \@children);
   }
   else {
      print {$fh} "no sub-commands\n";
   }
}

sub print_help ($self, $target) {
   my $command = fetch_spec_for($self, $target);
   my $enamr   = env_namer($self, $command);
   my $fh =
     $self->{application}{configuration}{'help-on-stderr'}
     ? \*STDERR
     : \*STDOUT;

   print {$fh} $command->{help}, "\n\n";

   if (defined(my $description = $command->{description})) {
      $description =~ s{\A\s+|\s+\z}{}gmxs;    # trim
      $description =~ s{^}{    }gmxs;          # add some indentation
      print {$fh} "Description:\n$description\n\n";
   }

lib/App/Easer/V1.pod  view on Meta::CPAN

   factory:
      create: «executable»
      prefixes: «hash or array of hashes»
   configuration:
      collect:   «executable»
      merge:     «executable»
      specfetch: «executable»
      validate:  «executable»
      sources:   «array»
      'auto-children':    «false or array»
      'help-on-stderr':   «boolean»
      'auto-leaves':      «boolean»
      'auto-environment': «boolean»
   commands:
      cmd-1:
         «command definition»
      cmd-2:
         «command definition»
      MAIN:
         «command definition»

lib/App/Easer/V1.pod  view on Meta::CPAN

   configuration:
      name:      «string»
      collect:   «executable»
      merge:     «executable»
      namenv:    «executable»
      specfetch: «executable»
      validate:  «executable»
      sources:   «array»
      'auto-children':    «false or array»
      'help-on-stderr':   «boolean»
      'auto-leaves':      «boolean»
      'auto-environment': «boolean»

The C<name> configuration allows setting a name for the application,
which can e.g. be used to generate automatic names for environment
variables to be associated to command options.

One of the central services provided by C<App::Easer::V1> is the automatic
gathering of options values from several sources (command line,
environment, commands upper in the hierarchy, defaults). Another service

lib/App/Easer/V1.pod  view on Meta::CPAN

or less). If this is not the desired behaviour, it is possible to either
disable the addition of the C<auto-children> completely (by setting a
false value), or provide an array of children names that will be added
automatically to each command (again, more or less).

It should be noted that both C<validate> and C<sources> are also part of
the specific setup for each command. As such, they will be rarely set at
the higher C<configuration> level and the whole C<configuration> section
can normally be left out of an application's definition.

Option C<help-on-stderr> allows printing the two stock helper
commands C<help> and C<commands> on standard error instead of standard
output (which is the default).

Option C<auto-leaves> allows setting any command that has no I<explicit>
sub-command as a leaf, which prevents it from getting a C<help> and a
C<commands> sub-command (or whatever has been put to override them). As
of version 0.007002 this is set to a I<true> value by default, but can
still be set to a I<false> value if the automatic sub-commands above are
deemed necessary for commands that have no explicit children in the
hierarchy.

lib/App/Easer/V2.pm  view on Meta::CPAN

      open $fh, '>', $channel or die "open(): $!\n";
   }
   elsif ($refch) {
      die 'invalid channel';
   }
   else {
      ($channel, my $binmode) = split m{:}mxs, $channel, 2;
      if ($channel eq '-' || lc($channel) eq '-stdout') {
         $fh = \*STDOUT;
      }
      elsif (lc($channel) eq '-stderr') {
         $fh = \*STDERR;
      }
      else {
         open $fh, '>', $channel or die "open('$channel'): $!\n";
      }
      binmode $fh, $binmode if length($binmode // '');
   }

   return sub ($cmd, @stuff) {
      print {$fh} @stuff;

lib/App/Easer/V2.pod  view on Meta::CPAN

a reference to a scalar, where the output will be placed

=item *

a string of the form C<filename[:binmode]>, where C<filename> can B<NOT>
contain the character C<:>. The file will be opened and if the
C<binmode> part is provided, C<binmode()> will be called on the
resulting filehandle with the provided value.

If the C<filename> part is C<-> or C<-stdout> (case insensitive), then
C<STDOUT> will be used. If C<filename> is C<-stderr> (case insensitive),
then C<STDERR> will be used.

=back

=item C<name>

String.

Name of the command. If absent, the first item in the C<alias> array is
used.

t/V1/02-single-with-lib.t  view on Meta::CPAN

            return 42;
         },
         'default-child' => '',
      }
   },
};

subtest 'no input, just defaults' => sub {
   test_run($app, [], {}, 'MAIN')->no_exceptions->conf_is({bar => 'buzz'})
     ->args_are([])->result_is(42)->stdout_like(qr{(?mxs:\A galook! \z)})
     ->stderr_like(qr{(?mxs:\A gaaaah! \z)});
};

subtest 'env + cmdline, both parameters' => sub {
   test_run($app, [qw< --bar BAAZ >], {GALOOK_FOO => 1}, 'MAIN')
     ->no_exceptions->conf_is({foo => 1, bar => 'BAAZ'})->args_are([])
     ->result_is(42)->stdout_like(qr{(?mxs:\A galook! \z)})
     ->stderr_like(qr{(?mxs:\A gaaaah! \z)});
};

test_run($app, ['help'], {}, 'MAIN')->no_exceptions->stdout_like(
   qr{(?mxs:
      example \s+ command .*?
      An \s+ example \s+ command .*?
      --foo .*
      GALOOK_BAR .*?
      help .*?
      commands .*?

t/V1/03-multilevel.t  view on Meta::CPAN

         sub-sub-command \s+ baz .*?
         second-level \s+ sub-command \s+ baz .*?
         --last .*
      )}, 'output of help command'
   )->stdout_like(qr{sub-sub-command baz});
};

subtest 'foo baz' => sub {
   test_run($app, ['foo', 'baz'], {}, 'baz')
     ->no_exceptions->result_is('BAZ')->stdout_like(qr{baz on out})
     ->stderr_like(qr{baz on err});
};

subtest 'foo baz' => sub {
   test_run($app, [qw< --foo foo --hey you baz --last 12 FP >], {}, 'baz')
     ->no_exceptions->result_is('BAZ')
     ->conf_is({foo => 1, bar => 'buzz', hey => 'you', last => 12})
     ->args_are(['FP'])->stdout_like(qr{baz on out})
     ->stderr_like(qr{baz on err});
};

subtest 'foo (leveraging default sub-child)' => sub {
   test_run($app, ['foo'], {}, 'baz')->no_exceptions->result_is('BAZ')
     ->stdout_like(qr{baz on out})->stderr_like(qr{baz on err});
};

subtest 'Foo (uppercase, leveraging default sub-child)' => sub {
   test_run($app, ['Foo'], {}, 'baz')->no_exceptions->result_is('BAZ')
     ->stdout_like(qr{baz on out})->stderr_like(qr{baz on err});
};

subtest 'Foo commands (note uppercase)' => sub {
   test_run($app, [qw< Foo commands >], {}, undef)
     ->no_exceptions->stdout_like(qr{(?mxs:help: .*? commands:)});
};

subtest 'bar' => sub {
   test_run($app, ['bar'], {}, 'bar')->no_exceptions->result_is('Bar')
     ->stdout_like(qr{bar on out})->stderr_like(qr{bar on err});
};

subtest 'help bar' => sub {
   test_run($app, ['help', 'bar'], {}, undef)->no_exceptions->stdout_like(
      qr{(?mxs:
         sub-command \s+ bar .*?
         first-level \s+ sub-command \s+ bar .*?
         has \s+ no \s+ options
      )}, 'output of help command'
   );
};

subtest 'bar help (help is ignored)' => sub {
   test_run($app, [qw< bar help >], {}, undef)
     ->no_exceptions->stdout_like(qr{bar on out})
     ->stderr_like(qr{bar on err});
};

done_testing();

t/V1/04-multilevel-jsons.t  view on Meta::CPAN

         },
      },
   },
};

subtest 'foo baz' => sub {
   test_run($app, [qw< --foo foo --hey you baz --last 12 FP >], {}, 'baz')
     ->no_exceptions->result_is('BAZ')
     ->conf_is({foo => 1, bar => 'buzz', hey => 'you', last => 12})
     ->args_are(['FP'])->stdout_like(qr{baz on out})
     ->stderr_like(qr{baz on err});
};

subtest 'foo baz, with config file' => sub {
   test_run(
      $app,
      [
         qw< --foo --config >,
         tpath('example.json'),
         qw< foo --hey you baz --last 12 FP >
      ],

t/V1/04-multilevel-jsons.t  view on Meta::CPAN

   )->no_exceptions->result_is('BAZ')->conf_is(
      {
         foo    => 1,
         bar    => 'buzz',
         hey    => 'you',
         last   => 12,
         what   => 'ever',
         config => tpath('example.json')
      }
   )->args_are(['FP'])->stdout_like(qr{baz on out})
     ->stderr_like(qr{baz on err});
};

$app->{commands}{MAIN}{'config-files'} =
  [qw< /etcxn/not/existent >, tpath('example.json')];

subtest 'foo baz, with config file' => sub {
   test_run($app, [qw< --foo foo --hey you baz --last 12 FP >], {}, 'baz')
     ->no_exceptions->result_is('BAZ')->conf_is(
      {
         foo  => 1,
         bar  => 'buzz',
         hey  => 'you',
         last => 12,
         what => 'ever',
      }
   )->args_are(['FP'])->stdout_like(qr{baz on out})
     ->stderr_like(qr{baz on err});
};

done_testing();

t/V1/05-single-leaf.t  view on Meta::CPAN

            return 42;
         },
         leaf => 1,
      }
   },
};

subtest 'no options, just defaults' => sub {
   test_run($app, [], {}, 'MAIN')->no_exceptions->conf_is({bar => 'buzz'})
     ->args_are([])->result_is(42)->stdout_like(qr{(?mxs:\A galook! \z)})
     ->stderr_like(qr{(?mxs:\A gaaaah! \z)});
};

subtest 'option --help' => sub {
   test_run($app, ['--help'], {}, 'MAIN')
     ->no_exceptions->conf_is({bar => 'buzz', help => 1})
     ->args_are([])
     ->result_is(0)
     ->stdout_like(qr{(?mxs: Description: .*? Options:)});
};

t/V1/15-spec-from-hash-or-mod.t  view on Meta::CPAN

         sub-sub-command \s+ baz .*?
         second-level \s+ sub-command \s+ baz .*?
         --last .*
      )}, 'output of help command'
   )->stdout_like(qr{sub-sub-command baz});
};

subtest 'foo baz 1' => sub {
   test_run($app, ['foo', 'baz'], {}, 'baz')
     ->no_exceptions->result_is('BAZ')->stdout_like(qr{baz on out})
     ->stderr_like(qr{baz on err});
};

subtest 'foo baz 2' => sub {
   test_run($app, [qw< --foo foo --hey you baz --last 12 FP >], {}, 'baz')
     ->no_exceptions->result_is('BAZ')
     ->conf_is({foo => 1, bar => 'buzz', hey => 'you', last => 12})
     ->args_are(['FP'])->stdout_like(qr{baz on out})
     ->stderr_like(qr{baz on err});
};

subtest 'foo (leveraging default sub-child)' => sub {
   test_run($app, ['foo'], {}, 'baz')->no_exceptions->result_is('BAZ')
     ->stdout_like(qr{baz on out})->stderr_like(qr{baz on err});
};

subtest 'Foo (uppercase, leveraging default sub-child)' => sub {
   test_run($app, ['Foo'], {}, 'baz')->no_exceptions->result_is('BAZ')
     ->stdout_like(qr{baz on out})->stderr_like(qr{baz on err});
};

subtest 'Foo commands (note uppercase)' => sub {
   test_run($app, [qw< Foo commands >], {}, undef)
     ->no_exceptions->stdout_like(qr{(?mxs:help: .*? commands:)});
};

subtest 'bar' => sub {
   test_run($app, ['bar'], {}, 'bar')->no_exceptions->result_is('Bar')
     ->stdout_like(qr{bar on out})->stderr_like(qr{bar on err});
};

subtest 'help bar' => sub {
   test_run($app, ['help', 'bar'], {}, undef)->no_exceptions->stdout_like(
      qr{(?mxs:
         sub-command \s+ bar .*?
         first-level \s+ sub-command \s+ bar .*?
         has \s+ no \s+ options
      )}, 'output of help command'
   );
};

subtest 'bar help (help is ignored)' => sub {
   test_run($app, [qw< bar help >], {}, undef)
     ->no_exceptions->stdout_like(qr{bar on out})
     ->stderr_like(qr{bar on err});
};

done_testing();


package Foo;
sub spec {
   return {
      help        => 'sub-command foo',
      description => 'first-level sub-command foo',

t/V1/30-custom-collect.t  view on Meta::CPAN

   },
};

subtest 'no input, just defaults, custom collect' => sub {
   test_run($app, [], {}, 'MAIN')
     ->no_exceptions
     ->conf_is({this => 'that'})
     ->args_are(['hey'])
     ->result_is(42)
     ->stdout_like(qr{(?mxs:\A galook! \z)})
     ->stderr_like(qr{(?mxs:\A gaaaah! \z)});
};

delete $app->{configuration}{collect};

subtest 'no input, just defaults, standard collect' => sub {
   test_run($app, [], {}, 'MAIN')->no_exceptions->conf_is({bar => 'buzz'})
     ->args_are([])->result_is(42)->stdout_like(qr{(?mxs:\A galook! \z)})
     ->stderr_like(qr{(?mxs:\A gaaaah! \z)});
};

done_testing();

t/V1/31-custom-sources.t  view on Meta::CPAN

            return 42;
         },
         leaf => 1,
      }
   },
};

subtest 'no input, just defaults' => sub {
   test_run($app, [], {}, 'MAIN')->no_exceptions->conf_is({bar => 'buzz'})
     ->args_are([])->result_is(42)->stdout_like(qr{(?mxs:\A galook! \z)})
     ->stderr_like(qr{(?mxs:\A gaaaah! \z)});
};

# Avoid defaults
$app->{configuration}{sources} = [qw< +CmdLine +Environment >];

subtest 'defaults no more in effect, env set' => sub {
   test_run($app, [], {GALOOK_FOO => 'BU!'}, 'MAIN')
      ->no_exceptions
      ->conf_is({foo => 'BU!'})
      ->args_are([])->result_is(42)->stdout_like(qr{(?mxs:\A galook! \z)})
      ->stderr_like(qr{(?mxs:\A gaaaah! \z)});
};

subtest 'defaults no more in effect, cmdline set' => sub {
   test_run($app, ['--foo'], {}, 'MAIN')
      ->no_exceptions
      ->conf_is({foo => 1})
      ->args_are([])->result_is(42)->stdout_like(qr{(?mxs:\A galook! \z)})
      ->stderr_like(qr{(?mxs:\A gaaaah! \z)});
};

done_testing();

t/V1/60-children-naming.t  view on Meta::CPAN

            print {*STDOUT} 'bar on out';
            print {*STDERR} 'bar on err';
            return 'Bar';
         },
      },
   },
};

subtest 'bar' => sub {
   test_run($app, ['bar'], {}, 'bar')->no_exceptions->result_is('Bar')
     ->stdout_like(qr{bar on out})->stderr_like(qr{bar on err});
};

subtest 'help bar' => sub {
   test_run($app, ['help', 'bar'], {}, undef)->no_exceptions->stdout_like(
      qr{(?mxs:
         sub-command \s+ bar .*?
         first-level \s+ sub-command \s+ bar .*?
         has \s+ no \s+ options
      )}, 'output of help command'
   );
};

subtest 'bar help (help is ignored)' => sub {
   test_run($app, [qw< bar help >], {}, undef)
     ->no_exceptions->stdout_like(qr{bar on out})
     ->stderr_like(qr{bar on err});
};

subtest 'bar as default' => sub {
   test_run($app, [], {}, 'bar')->no_exceptions->result_is('Bar')
     ->stdout_like(qr{bar on out})->stderr_like(qr{bar on err});
};

done_testing();

t/V1/70-nested-children.t  view on Meta::CPAN

            print {*STDOUT} 'bar on out';
            print {*STDERR} 'bar on err';
            return 'Bar';
         },
      },
   },
};

subtest 'foo' => sub {
   test_run($app, ['foo'], {}, 'foo')->no_exceptions->result_is('Foo')
      ->stdout_like(qr{foo on out})->stderr_like(qr{foo on err});
};

subtest 'help foo' => sub {
   test_run($app, ['help', 'foo'], {}, undef)->no_exceptions->stdout_like(
      qr{(?mxs:
         sub-command \s+ foo .*?
         first-level \s+ sub-command \s+ foo .*?
         hey
      )}, 'output of help command'
   );
};

subtest 'bar' => sub {
   test_run($app, ['bar'], {}, 'bar')->no_exceptions->result_is('Bar')
     ->stdout_like(qr{bar on out})->stderr_like(qr{bar on err});
};

subtest 'help bar' => sub {
   test_run($app, ['help', 'bar'], {}, undef)->no_exceptions->stdout_like(
      qr{(?mxs:
         sub-command \s+ bar .*?
         first-level \s+ sub-command \s+ bar .*?
         has \s+ no \s+ options
      )}, 'output of help command'
   );
};

subtest 'bar help (help is ignored)' => sub {
   test_run($app, [qw< bar help >], {}, undef)
     ->no_exceptions->stdout_like(qr{bar on out})
     ->stderr_like(qr{bar on err});
};

subtest 'bar as default' => sub {
   test_run($app, [], {}, 'bar')->no_exceptions->result_is('Bar')
     ->stdout_like(qr{bar on out})->stderr_like(qr{bar on err});
};

$app->{commands}{MAIN}{'default-child'}{index} = 0;

subtest 'foo as default' => sub {
   test_run($app, [], {}, 'foo')->no_exceptions->result_is('Foo')
     ->stdout_like(qr{foo on out})->stderr_like(qr{foo on err});
};

done_testing();

t/V1/75-childrenbyprefix.t  view on Meta::CPAN

            },
         ],
         'default-child' => 'Sampler::CmdBar',
         children => [ [ '+ChildrenByPrefix', 'Sampler::Cmd' ] ],
      },
   },
};

subtest 'foo' => sub {
   test_run($app, ['foo'], {}, 'foo')->no_exceptions->result_is('Foo')
      ->stdout_like(qr{foo on out})->stderr_like(qr{foo on err});
};

subtest 'help foo' => sub {
   test_run($app, ['help', 'foo'], {}, undef)->no_exceptions->stdout_like(
      qr{(?mxs:
         sampler \s+ foo .*?
         called \s+ as: \s+ foo .*?
      )}, 'output of help command'
   );
};

subtest 'bar' => sub {
   test_run($app, ['bar'], {}, 'bar')->no_exceptions->result_is('Bar')
     ->stdout_like(qr{bar on out})->stderr_like(qr{bar on err});
};

subtest 'help bar' => sub {
   test_run($app, ['help', 'bar'], {}, undef)->no_exceptions->stdout_like(
      qr{(?mxs:
         sub-command \s+ bar .*?
         first-level \s+ sub-command \s+ bar .*?
         has \s+ no \s+ options
      )}, 'output of help command'
   );
};

subtest 'bar help (help is ignored)' => sub {
   test_run($app, [qw< bar help >], {}, undef)
     ->no_exceptions->stdout_like(qr{bar on out})
     ->stderr_like(qr{bar on err});
};

subtest 'bar as default' => sub {
   test_run($app, [], {}, 'bar')->no_exceptions->result_is('Bar')
     ->stdout_like(qr{bar on out})->stderr_like(qr{bar on err});
};

subtest 'foo baz' => sub {
   test_run($app, ['foo', 'baz'], {}, 'baz')->no_exceptions->result_is('Baz')
      ->stdout_like(qr{foo baz on out})->stderr_like(qr{foo baz on err});
};

done_testing();

t/V1/LocalTester.pm  view on Meta::CPAN

use v5.24;
use experimental 'signatures';
use Capture::Tiny 'capture';
use App::Easer V1 => 'run';
use Test::More;
use Exporter 'import';

our @EXPORT = ('test_run');

sub test_run ($app, $args, $env, $command = 'MAIN') {
   my ($stdout, $stderr, @result, $clean_run, $exception);
   my $self = bless {}, __PACKAGE__;
   local *LocalTester::command_execute = sub ($cmd, $main, $conf, $args) {
      return unless $cmd eq ($command // '');
      $self->{conf} = $conf;
      $self->{args} = $args;
   };
   eval {
      local @ENV{keys $env->%*};
      while (my ($k, $v) = each $env->%*) {
         if (defined $v) { $ENV{$k} = $v }
         else { delete $ENV{$k} }
      }
      $self->@{qw< stdout stderr result >} = capture {
         scalar run($app, $args)
      };
      1;
   } or do { $self->{exception} = $@ };
   return $self;
} ## end sub test_run

sub stdout_like ($self, $regex, $name = 'stdout') {
   like $self->{stdout} // '', $regex, $name;
   return $self;
}

sub diag_stdout ($self) {
   diag $self->{stdout};
   return $self;
}

sub diag_stderr ($self) {
   diag $self->{stderr};
   return $self;
}

sub stderr_like ($self, $regex, $name = 'stderr') {
   like $self->{stderr} // '', $regex, $name;
   return $self;
}

sub conf_is ($self, $expected, $name = 'configuration') {
   is_deeply $self->{conf}, $expected, $name;
   return $self;
}

sub args_are ($self, $expected, $name = 'residual arguments') {
   is_deeply $self->{args}, $expected, $name;

t/V2/02-single-with-lib.t  view on Meta::CPAN

      LocalTester::command_execute(@_);
      print {*STDOUT} 'galook!';
      print {*STDERR} 'gaaaah!';
      return 42;
   },
};

subtest 'no input, just defaults' => sub {
   test_run($app, [], {}, 'MAIN')->no_exceptions->conf_is({bar => 'buzz'})
     ->args_are([])->result_is(42)->stdout_like(qr{(?mxs:\A galook! \z)})
     ->stderr_like(qr{(?mxs:\A gaaaah! \z)});
};

subtest 'env + cmdline, both parameters' => sub {
   test_run($app, [qw< --bar BAAZ >], {GALOOK_FOO => 1}, 'MAIN')
     ->no_exceptions->conf_is({foo => 1, bar => 'BAAZ'})->args_are([])
     ->result_is(42)->stdout_like(qr{(?mxs:\A galook! \z)})
     ->stderr_like(qr{(?mxs:\A gaaaah! \z)});
};

test_run($app, ['help'], {}, 'MAIN')->no_exceptions->stdout_like(
   qr{(?mxs:
      example \s+ command .*?
      An \s+ example \s+ command .*?
      --foo .*
      GALOOK_BAR .*?
      help .*?
      commands .*?

t/V2/03-multilevel.t  view on Meta::CPAN

         sub-sub-command \s+ baz .*?
         second-level \s+ sub-command \s+ baz .*?
         --last .*
      )}, 'output of help command'
   )->stdout_like(qr{sub-sub-command baz});
};

subtest 'foo baz' => sub {
   test_run($app, ['foo', 'baz'], {}, 'baz')
     ->no_exceptions->result_is('BAZ')->stdout_like(qr{baz on out})
     ->stderr_like(qr{baz on err});
};

subtest 'foo baz' => sub {
   test_run($app, [qw< --foo foo --hey you baz --last 12 FP >], {}, 'baz')
     ->no_exceptions->result_is('BAZ')
     ->conf_is({foo => 1, bar => 'buzz', hey => 'you', last => 12})
     ->args_are(['FP'])->stdout_like(qr{baz on out})
     ->stderr_like(qr{baz on err});
};

subtest 'foo (leveraging default sub-child)' => sub {
   test_run($app, ['foo'], {}, 'baz')->no_exceptions->result_is('BAZ')
     ->stdout_like(qr{baz on out})->stderr_like(qr{baz on err});
};

subtest 'Foo (uppercase, leveraging default sub-child)' => sub {
   test_run($app, ['Foo'], {}, 'baz')->no_exceptions->result_is('BAZ')
     ->stdout_like(qr{baz on out})->stderr_like(qr{baz on err});
};

subtest 'Foo commands (note uppercase)' => sub {
   test_run($app, [qw< Foo commands >], {}, undef)
     ->no_exceptions->stdout_like(qr{(?mxs:help: .*? commands:)});
};

subtest 'bar' => sub {
   test_run($app, ['bar'], {}, 'bar')->no_exceptions->result_is('Bar')
     ->stdout_like(qr{bar on out})->stderr_like(qr{bar on err});
};

subtest 'help bar' => sub {
   test_run($app, ['help', 'bar'], {}, undef)->no_exceptions->stdout_like(
      qr{(?mxs:
         sub-command \s+ bar .*?
         first-level \s+ sub-command \s+ bar .*?
         has \s+ no \s+ option
      )}, 'output of help command'
   );
};

subtest 'bar help (help is ignored)' => sub {
   test_run($app, [qw< bar help >], {}, undef)
     ->no_exceptions->stdout_like(qr{bar on out})
     ->stderr_like(qr{bar on err});
};

done_testing();

t/V2/05.single-leaf.t  view on Meta::CPAN

      }
      print {*STDOUT} 'galook!';
      print {*STDERR} 'gaaaah!';
      return 42;
   },
};

subtest 'no options, just defaults' => sub {
   test_run($app, [], {}, 'MAIN')->no_exceptions->conf_is({bar => 'buzz'})
     ->args_are([])->result_is(42)->stdout_like(qr{(?mxs:\A galook! \z)})
     ->stderr_like(qr{(?mxs:\A gaaaah! \z)});
};

subtest 'option --help' => sub {
   test_run($app, ['--help'], {}, 'MAIN')
     ->no_exceptions->conf_is({bar => 'buzz', help => 1})
     ->args_are([])
     ->result_is(0)
     ->stdout_like(qr{(?mxs: Description: .*? Options:)});
};

t/V2/15.spec-from-hash-or-mod.t  view on Meta::CPAN

         sub-sub-command \s+ baz .*?
         second-level \s+ sub-command \s+ baz .*?
         --last .*
      )}, 'output of help command'
   )->stdout_like(qr{sub-sub-command baz});
};

subtest 'foo baz 1' => sub {
   test_run($app, ['foo', 'baz'], {}, 'baz')
     ->no_exceptions->result_is('BAZ')->stdout_like(qr{baz on out})
     ->stderr_like(qr{baz on err});
};

subtest 'foo baz 2' => sub {
   test_run($app, [qw< --foo foo --hey you baz --last 12 FP >], {}, 'baz')
     ->no_exceptions->result_is('BAZ')
     ->conf_is({foo => 1, bar => 'buzz', hey => 'you', last => 12})
     ->args_are(['FP'])->stdout_like(qr{baz on out})
     ->stderr_like(qr{baz on err});
};

subtest 'foo (leveraging default sub-child)' => sub {
   test_run($app, ['foo'], {}, 'baz')->no_exceptions->result_is('BAZ')
     ->stdout_like(qr{baz on out})->stderr_like(qr{baz on err});
};

subtest 'Foo (uppercase, leveraging default sub-child)' => sub {
   test_run($app, ['Foo'], {}, 'baz')->no_exceptions->result_is('BAZ')
     ->stdout_like(qr{baz on out})->stderr_like(qr{baz on err});
};

subtest 'Foo commands (note uppercase)' => sub {
   test_run($app, [qw< Foo commands >], {}, undef)
     ->no_exceptions->stdout_like(qr{(?mxs:help: .*? commands:)});
};

subtest 'bar' => sub {
   test_run($app, ['bar'], {}, 'bar')->no_exceptions->result_is('Bar')
     ->stdout_like(qr{bar on out})->stderr_like(qr{bar on err});
};

subtest 'help bar' => sub {
   test_run($app, ['help', 'bar'], {}, undef)->no_exceptions->stdout_like(
      qr{(?mxs:
         sub-command \s+ bar .*?
         first-level \s+ sub-command \s+ bar .*?
         has \s+ no \s+ option
      )}, 'output of help command'
   );
};

subtest 'bar help (help is ignored)' => sub {
   test_run($app, [qw< bar help >], {}, undef)
     ->no_exceptions->stdout_like(qr{bar on out})
     ->stderr_like(qr{bar on err});
};

done_testing();


package Foo;
use App::Easer::V2 -command => -spec => {
   help        => 'sub-command foo',
   description => 'first-level sub-command foo',
   aliases     => ['foo', 'Foo'],

t/V2/20.collect-options.t  view on Meta::CPAN

   sources =>
      [
         qw< +CmdLine +Environment +Parent=70 +Default=100 >, # defaults 
         '+JsonFileFromConfig=40',
      ],
};

subtest 'foo baz 1' => sub {
   test_run($app, ['foo', 'baz'], {}, 'baz')
     ->no_exceptions->result_is('BAZ')->stdout_like(qr{baz on out})
     ->stderr_like(qr{baz on err});
};

subtest 'foo baz 2' => sub {
   test_run(
      $app,
      [
         '--config' => "$file_prefix.1.json",
         qw<
           --foo foo
           --hey you

t/V2/20.collect-options.t  view on Meta::CPAN

      'baz'
   )->no_exceptions->result_is('BAZ')->conf_is(
      {
         config => "$file_prefix.1.json",
         foo    => 1,
         bar    => 'from_general_configuration_file',
         hey    => 'you',
         last   => 12
      }
   )->args_are(['FP'])->stdout_like(qr{baz on out})
     ->stderr_like(qr{baz on err});
};

subtest 'foo baz (tests conf_contains works)' => sub {
   test_run(
      $app,
      [
         '--config' => "$file_prefix.2.json",
         qw<
           --foo foo
           --hey you

t/V2/20.collect-options.t  view on Meta::CPAN

      {},
      'baz'
   )->no_exceptions->result_is('BAZ')->conf_contains(
      {
         foo  => 1,
         bar  => 'from_general_configuration_file',
         hey  => 'you',
         last => 12
      }
   )->args_are(['FP'])->stdout_like(qr{baz on out})
     ->stderr_like(qr{baz on err});
};


$app->{sources} = [
   qw< +CmdLine +Environment +Parent=70 +Default=100 >, # defaults 
   '+JsonFileFromConfig=30', # better than +Parent
   [ '+FromTrail=90', qw< defaults foo baz > ],
];

subtest 'foo baz (source from sub-hash)' => sub {

t/V2/20.collect-options.t  view on Meta::CPAN

      {},
      'baz'
   )->no_exceptions->result_is('BAZ')->conf_contains(
      {
         foo  => 0,
         bar  => 'from_general_configuration_file',
         hey  => 'you',
         last => 42
      }
   )->args_are(['FP'])->stdout_like(qr{baz on out})
     ->stderr_like(qr{baz on err});
};


$app->{sources} = [
   qw< +CmdLine +Environment +Parent=70 +Default=100 >, # defaults 
   '+JsonFileFromConfig=30', # better than +Parent
   [ '+FromTrail', {priority => 90}, qw< defaults foo baz > ],
];

subtest 'foo baz (source from sub-hash, .3.json)' => sub {

t/V2/20.collect-options.t  view on Meta::CPAN

      {},
      'baz'
   )->no_exceptions->result_is('BAZ')->conf_contains(
      {
         foo  => 0,
         bar  => 'from_substuff',
         hey  => 'you',
         last => 42
      }
   )->args_are(['FP'])->stdout_like(qr{baz on out})
     ->stderr_like(qr{baz on err});
};

$app->{sources} = [
   qw< +CmdLine +Environment +Default=100 +JsonFileFromConfig=30 >,
   '+Parent',
   [ '+FromTrail', qw< defaults foo baz > ],
];

subtest 'foo baz (source from sub-hash, not default)' => sub {
   test_run(

t/V2/20.collect-options.t  view on Meta::CPAN

      {},
      'baz'
   )->no_exceptions->result_is('BAZ')->conf_contains(
      {
         foo  => 0,
         bar  => 'from_general_configuration_file',
         hey  => 'you',
         last => 42
      }
   )->args_are(['FP'])->stdout_like(qr{baz on out})
     ->stderr_like(qr{baz on err});
};

done_testing();

package Foo;
use App::Easer::V2 -command => -spec => {
   help        => 'sub-command foo',
   description => 'first-level sub-command foo',
   aliases     => ['foo', 'Foo'],
   options     => [

t/V2/21.options-ordering.t  view on Meta::CPAN

      $conf{six} = 'six';
   }

   subtest "$who, all defaults, baseline" => sub {
      test_run($app, \@args, \%env, $who)
         ->no_exceptions
         ->result_is(ucfirst $who)
         ->conf_is(\%conf)
         ->args_are([])
         ->stdout_like(qr{$who on out})
         ->stderr_like(qr{$who on err});
   };

   push @args, '--one', $conf{one} = 'cmdline-one';
   subtest "$who, cmdline on ONE", => sub {
      test_run($app, \@args, \%env, $who)->no_exceptions->conf_is(\%conf);
   };

   $env{ONE} = 'whatever, this does not go'; # cmdline overrides this
   $env{TWO} = $conf{two} = 'environment-two'; # this goes over default
   subtest "$who, cmdline on ONE, environment on ONE and TWO" => sub {

t/V2/22.custom-sources.t  view on Meta::CPAN

      $conf{six} = 'six';
   }

   subtest "$who, all defaults, baseline" => sub {
      test_run($app, \@args, \%env, $who)
         ->no_exceptions
         ->result_is(ucfirst $who)
         ->conf_is(\%conf)
         ->args_are([])
         ->stdout_like(qr{$who on out})
         ->stderr_like(qr{$who on err});
   };

   push @args, '--one', $conf{one} = 'cmdline-one';
   subtest "$who, cmdline on ONE", => sub {
      test_run($app, \@args, \%env, $who)->no_exceptions->conf_is(\%conf);
   };

   $env{ONE} = 'whatever, this does not go'; # cmdline overrides this
   $env{TWO} = $conf{two} = 'environment-two'; # this goes over default
   subtest "$who, cmdline on ONE, environment on ONE and TWO" => sub {

t/V2/41.missing-help-no-warning.t  view on Meta::CPAN

use experimental 'signatures';
use Test::More;
use File::Basename 'dirname';
use lib dirname(__FILE__);
use LocalTester;

subtest 'run_help' => sub {
   my $t = test_run({execute => sub { shift->run_help }}, [], {}, undef)
     ->no_exceptions
     ->stdout_like(qr{no concise help yet}, 'default help text')
     ->stderr_like(qr{\A\s*\z}, 'no complaints on standard error');
};

subtest 'help' => sub {
   my $t = test_run({force_auto_children => 1}, ['help'], {}, undef)
     ->no_exceptions
     ->stdout_like(qr{no concise help yet}, 'default help text')
     ->stderr_like(qr{\A\s*\z}, 'no complaints on standard error');
};

done_testing();

t/V2/42.help-help.t  view on Meta::CPAN

use experimental 'signatures';
use Test::More;
use File::Basename 'dirname';
use lib dirname(__FILE__);
use LocalTester;

subtest 'help me to help' => sub {
   test_run({force_auto_children => 1}, [qw< help help >], {}, undef)
     ->no_exceptions->stdout_like(qr{Print help for \(sub\)command},
      q{help's help text})
     ->stderr_like(qr{\A\s*\z}, 'no complaints on standard error');
   test_run({force_auto_children => 1}, [qw< help commands >], {}, undef)
     ->no_exceptions->stdout_like(qr{Print list of supported sub-command},
      q{command's help text})
     ->stderr_like(qr{\A\s*\z}, 'no complaints on standard error');
   test_run({force_auto_children => 1}, [qw< help tree >], {}, undef)
     ->no_exceptions->stdout_like(qr{Print tree of supported sub-command},
      q{tree's help text})
     ->stderr_like(qr{\A\s*\z}, 'no complaints on standard error');
};

done_testing();

t/V2/50.lone-dash.t  view on Meta::CPAN

#!/usr/bin/env perl
use v5.24;
use experimental 'signatures';
use Test::More;
use File::Basename 'dirname';
use lib dirname(__FILE__);
use LocalTester;

subtest 'lone dash on leaf node' => sub {
   test_run({ execute => sub { } }, [qw< foo >], {}, undef)
     ->no_exceptions->stderr_like(qr{\A\s*\z},
      'no complaints on standard error');
};

subtest 'lone dash on an intermediate node' => sub {
   # this is how it's done properly when there are children... have to
   # set a fallback_to -self to avoid die-ing because the child is not
   # found.
   test_run(
      {
         execute => sub { },
         fallback_to => '-self',
         force_auto_children => 1,
      }, [qw< foo >], {}, undef)
     ->no_exceptions->stderr_like(qr{\A\s*\z},
      'no complaints on standard error');
};

done_testing();

t/V2/LocalTester.pm  view on Meta::CPAN

sub executor ($cb = undef) {
   return sub ($self) {
      LocalTester::command_execute($self);
      $cb->($self) if $cb;
      return $self->name;
   };
}

sub test_run ($app, $args, $env, $expected_command = 'MAIN') {
   my ($stdout, $stderr, @result, $clean_run, $exception);
   my $self = bless {}, __PACKAGE__;
   local *LocalTester::command_execute = sub ($cmd) {
      my $name = $self->{name} = $cmd->name;
      return unless $name eq ($expected_command // '');
      $self->{conf} = $cmd->config_hash;
      $self->{args} = [$cmd->residual_args];
   };
   eval {
      local @ENV{keys $env->%*};
      while (my ($k, $v) = each $env->%*) {
         if (defined $v) { $ENV{$k} = $v }
         else { delete $ENV{$k} }
      }
      $self->@{qw< stdout stderr result >} = capture {
         scalar run($app, $0, $args->@*)
      };
      1;
   } or do { $self->{exception} = $@ };
   return $self;
} ## end sub test_run

sub stdout_like ($self, $regex, $name = 'stdout') {
   like $self->{stdout} // '', $regex, $name;
   return $self;

t/V2/LocalTester.pm  view on Meta::CPAN

sub stdout_unlike ($self, $regex, $name = 'stdout') {
   unlike $self->{stdout} // '', $regex, $name;
   return $self;
}

sub diag_stdout ($self) {
   diag $self->{stdout};
   return $self;
}

sub diag_stderr ($self) {
   diag $self->{stderr};
   return $self;
}

sub stderr_like ($self, $regex, $name = 'stderr') {
   like $self->{stderr} // '', $regex, $name;
   return $self;
}

sub name_is ($self, $expected, $test_name = undef) {
   $test_name //= "command name is '$expected'";
   is $self->{name}, $expected, $test_name;
   return $self;
}

sub conf_is ($self, $expected, $name = 'configuration') {