view release on metacpan or  search on metacpan

t/get_args_from_argv.t  view on Meta::CPAN

$meta = {
    v=>1.1,
    args=>{arg1=>{schema=>'str*', req=>1, pos=>0}},
};

test_getargs(meta=>$meta,
             argv=>[qw//],
             args=>{},
             name=>"missing required args",
             posttest => sub {
                 my $res = shift;
                 is_deeply($res->[3]{'func.missing_args'}, ['arg1']);
             },
         );

$meta = {
    v => 1.1,
    args => {
        foo_bar_baz => {schema=>'int'},
    },
};
test_getargs(name=>"underscore becomes dash (1)",
             meta=>$meta, argv=>[qw/--foo_bar_baz 2/],
             error=>1,
       );
test_getargs(name=>"underscore becomes dash (2)",
             meta=>$meta, argv=>[qw/--foo-bar_baz 2/],
             error=>1,
         );
test_getargs(name=>"underscore becomes dash (3)",
             meta=>$meta, argv=>[qw/--foo-bar-baz 2/],
             args=>{foo_bar_baz=>2},
       );

$meta = {
    v => 1.1,
    args => {
        foo => {schema=>'hash'},
    },
};
subtest "per_arg_yaml" => sub {
    plan skip_all => 'YAML modules not available'
        unless ((eval { require YAML::XS; 1 }) || (eval { require YAML::Old; 1 }));

    test_getargs(meta=>$meta, argv=>[qw/--foo-yaml ~/],
                 error=>1,
                 name=>"per_arg_yaml=0");
    test_getargs(meta=>$meta, argv=>[qw/--foo-yaml ~/], per_arg_yaml=>1,
                 args=>{foo=>undef},
                 name=>"per_arg_yaml=1");
};

test_getargs(meta=>$meta, argv=>[qw/--foo-json null/],
             error=>1,
             name=>"per_arg_json=0");
test_getargs(meta=>$meta, argv=>[qw/--foo-json null/], per_arg_json=>1,
             args=>{foo=>undef},
             name=>"per_arg_json=1");

{
    local @ARGV = (qw/--foo 2/);
    test_getargs(meta=>$meta,
                 args=>{foo=>2},
                 name=>"argv defaults to \@ARGV");
}

# test bool, one-letter arg, cmdline_aliases

$meta = {
    v => 1.1,
    args => {
        b => {schema=>'bool'},
        b2 => {schema=>'bool'},
        s => {schema=>'str'},
        s2 => {schema=>'str',
               cmdline_aliases=>{
                   S=>{},
                   S_foo=>{schema=>[bool=>{is=>1}],
                           code=>sub{$_[0]{s2} = 'foo'}},
               }
           },
    },
};
test_getargs(meta=>$meta, argv=>[qw/-b -s blah/],
             args=>{b=>1, s=>"blah"},
             name=>"one-letter args get -X as well as --X");
test_getargs(meta=>$meta, argv=>[qw/--nob2/],
             args=>{b2=>0},
             name=>"bool args with length > 1 get --XXX as well as --noXXX");
test_getargs(meta=>$meta, argv=>[qw/-S blah/],
             args=>{s2=>"blah"},
             name=>"cmdline_aliases: S");
test_getargs(meta=>$meta, argv=>[qw/--S-foo/], # XXX S-foo not yet provided?
             args=>{s2=>"foo"},
             name=>"cmdline_aliases: S_foo");

subtest "cmdline_aliases: bool alias with code does not get --noX" => sub {
    my $meta = {
        v => 1.1,
        args => {
            true => {
                schema=>'bool',
                cmdline_aliases => {
                    false => {
                        code => sub { ${$_[0]}{true} = 0 },
                    },
                },
            },
        },
    };
    test_getargs(meta=>$meta, argv=>[qw/--true/]);
    test_getargs(meta=>$meta, argv=>[qw/--notrue/]);
    test_getargs(meta=>$meta, argv=>[qw/--false/]);
    test_getargs(meta=>$meta, argv=>[qw/--nofalse/], error=>1);
};

# test handling of array of scalar, --foo 1 --foo 2

$meta = {
    v => 1.1,
    args => {