view release on metacpan or  search on metacpan

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

my $json_config = "$file_prefix.json";

my $app = {
   aliases     => ['parent'],
   help        => 'example command',
   options     => [
      {
         getopt => 'config=s',
         help => 'path to configuration file',
      },
      map {;
         {
            getopt      => "$_=s",
            environment => 1,
            default     => $_,
            transmit    => 1, #  let children support this option too
         };
      } qw< one two three four five >,
   ],
   default_child => '-self',
   execute => \&parent_execute,
   children        => [
      {
         aliases     => ['child'],
         help        => 'sub-command bar',
         options     => [
            '+parent',
            {
               getopt => 'six=s',
               environment => 1,
               default => 'six',
            },
         ],
         execute => \&child_execute,
      }
   ],
   sources =>
      [
         qw< +CmdLine +Environment +Parent=70 +Default=100 >, # defaults 
         '+JsonFileFromConfig=40',
      ],
};

# All tests should now apply to both the parent and the child
for my $who (qw< parent child >) {
   my %conf = map { $_ => $_ } qw< one two three four five >;
   my (@args, %env);

   if ($who eq 'child') { # add stuff for child command
      @args = 'child';
      $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 {
      test_run($app, \@args, \%env, $who)->no_exceptions->conf_is(\%conf);
   };

   # will read from JSON file and stuff will be added. one and two are
   # left unchanged because it's how precedence works
   %conf = (
      one => 'cmdline-one',                # cmdline wins over all
      two => 'environment-two',            # then environment
      three => 'jsonconf-three',           # then config file
      four => 'four',                      # then default
      five => 'five',                      # ditto
      six => 'jsonconf-six',               # additional stuff from file
      additional => 'jsonconf-additional', # cmdline
      config => $json_config,
   );

   # **NOTE** the "--config" option is **not** transmitted and must appear
   # at the beginning of @args (at least for the child command)
   unshift @args, '--config', $json_config;
   subtest "$who, cmdline<ONE>, env<ONE,TWO>, json<ONE,TWO,THREE>" => sub {
      test_run($app, \@args, \%env, $who)->no_exceptions->conf_is(\%conf);
   };
}

subtest 'child wins over stuff from parent' => sub {
   my @args = (
      qw< --one parent-one --four parent-four >,
      '--config' => $json_config,
      qw< child --one child-one --five child-five --six child-six >
   );
   my %env = ( TWO => 'environment-two', FIVE => 'environment-five' );
   my %conf = (
      one => 'child-one',                  # child cmdline wins over all
      two => 'environment-two',            # then environment
      three => 'jsonconf-three',           # then config file
      four => 'parent-four',               # then parent
      five => 'child-five',                # child cmdline again
      six => 'child-six',                  # child cmdline again
      additional => 'jsonconf-additional', # cmdline
      config => $json_config,
   );
   test_run($app, \@args, \%env, 'child')->no_exceptions->conf_is(\%conf);
};

# subvert precedence in the child, make the parent win over all
subtest 'child getting stuff from parent' => sub {
   my @args = (
      qw< --one parent-one --four parent-four >,
      '--config' => $json_config,
      qw< child --one child-one --five child-five >