view release on metacpan or  search on metacpan

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

      ->conf_is(
         {
            one => 'FIRST',
            two => 'two',
            three => 'BAZ',
            four => 'four',
            five => 'five',
            foo => 'custom_source_foo',
            bar => 'first',
            baz => 'second',
         }
      );
};

done_testing();

sub custom_source_main ($instance, $opts, $args) {
   my @opts = $opts->@*;
   my %retval = (baz => $opts[0]);
   $retval{bar} = $opts[0] unless $instance->config('bar');
   $retval{three} = $opts[1] if @opts > 1;
   return \%retval;
}

sub execute ($self) {
   LocalTester::command_execute($self);
   say 'whatever';
   return 42;
}


package Foo;
use v5.24;
sub custom_source_foo ($instance, $opts, $args) {
   return {
      one => 'FIRST',
      three => 'THIRD',
      foo => 'custom_source_foo',
      baz => 'custom_source_foo',
   };
}

__END__
# 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 >