Getopt-Long-Descriptive

 view release on metacpan or  search on metacpan

t/descriptive.t  view on Meta::CPAN

# test constraints:
# (look at P::V for names, too)
# required => 1
# depends => [...]
# precludes => [...]
# sugar for only_one_of and all_or_none

sub is_opt {
  my ($argv, $specs, $expect, $desc) = @_;
  local @ARGV = @$argv;
  local $Test::Builder::Level = $Test::Builder::Level + 1;
  my $ok = eval {
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    my ($opt, $usage) = describe_options(
      "test %o",
      @$specs,
    );
    is_deeply(
      $opt,
      $expect,

t/descriptive.t  view on Meta::CPAN

    } else {
      # auto-fail
      is($error, "", "$desc: $error");
    }
  }
}

sub is_hidden {
  my ($specs, $cmd, $text) = @_;
  eval {
    local @ARGV;
    my ($opt, $usage) = describe_options(
      "test %o",
      @$specs,
    );
    like(
      $usage->text,
      $cmd,
      "hidden option in usage command",
    );
    unlike(

t/descriptive.t  view on Meta::CPAN

  [
    [ unreq => 'an unrequired option' => {
      required => 0
    } ],
  ],
  {},
  "an unrequired option"
);

{
  local @ARGV;
  my ($opt, $usage) = describe_options(
    "%c %o",
    [ foo => "a foo option" ],
    [],
    ['bar options:'],
    [ bar => "a bar option" ],
  );

  like(
    $usage->text,

t/descriptive.t  view on Meta::CPAN

  local $SIG{__WARN__} = sub {}; # we know that this will warn; don't care
  like(
    $usage->(1),
    qr/foo option\n[\t\x20]*\n    bar options:\n\s+--bar/,
    "CODEISH: spacer and non-option description found",
  );
}

{
  local @ARGV;
  my ($opt, $usage) = describe_options(
    "%c %o",
    [ foo => "a foo option" ],
    [],
    [\"bar options:\n -> they are cool"],
    [ bar => "a bar option" ],
  );

  like(
    $usage->text,

t/descriptive.t  view on Meta::CPAN

  local $SIG{__WARN__} = sub {}; # we know that this will warn; don't care
  like(
    $usage->(1),
    qr/foo option\n[\t\x20]*\nbar options:\n -> they are cool\n\s+--bar/,
    "CODEISH: spacer and non-option description found",
  );
}

{
  local @ARGV;
  my ($opt, $usage) = describe_options(
    "%c %o",
    [ 'foo'          => "foo option" ],
    [ 'bar|b'        => "bar option" ],
    [ 'string|s=s'   => "string value" ],
    [ 'ostring|S:s'  => "optional string value" ],
    [ 'list|l=s@'    => "list of strings" ],
    [ 'hash|h=s%'    => "hash values" ],
    [ 'optional|o!'  => "optional" ],
    [ 'increment|i+' => "incremental option" ],
  );

  like(
    $usage->text,
    qr/\[-bhiloSs\]/,
    "short options",
  );
}

{
  local @ARGV;
  my ($opt, $usage) = describe_options(
    "%c %o",
    [ 'string|s=s'   => "string value" ],
    [ 'ostring|S:s'  => "optional string value" ],
    [ 'list|l=s@'    => "list of strings" ],
    [ 'hash|h=s%'    => "hash values" ],
    [ 'optional|o!'  => "optional boolean" ],
    [ 'increment|i+' => "incremental option" ],
  );
  my $usage_text = $usage->text;

t/descriptive.t  view on Meta::CPAN

  );

  like(
    $usage_text,
    qr/--\[no-\]optional \(or -o\)\s+optional boolean/,
    "Spec ! gets a [no-] in usage output",
  );
}

{
  local @ARGV = qw(--foo FOO --baz BAZ);
  my ($c_opt, $usage) = describe_options(
    "%c %o",
    [ "foo=s", '' ],
    [ "bar=s", '', { default => 'BAR' } ],
    [ "baz=s", '', { default => 'BAZ' } ],
  );

  my $s_opt = $c_opt->_specified_opts;
  my $C_opt = $s_opt->_complete_opts;

t/descriptive.t  view on Meta::CPAN

  is($c_opt->bar, 'BAR', 'c_opt->foo is BAR');
  is($C_opt->bar, 'BAR', 'C_opt->foo is BAR');
  is($s_opt->bar, undef, 's_opt->foo is undef');

  is($c_opt->baz, 'BAZ', 'c_opt->foo is BAZ');
  is($C_opt->baz, 'BAZ', 'C_opt->foo is BAZ');
  is($s_opt->baz, 'BAZ', 's_opt->foo is BAZ');
}

{
  local @ARGV = qw(--foo);
  my ($opt, $usage) = describe_options(
    "%c %o",
    [ "foo", '' ],
    [ "bar", '' ],
  );
  is( $opt->{foo}, 1, "empty-but-present description is ok" );
  is( $opt->foo,   1, "empty-but-present description is ok" );

  is( $opt->{bar}, undef, "entry not given is undef (exists? no guarantee)" );
  is( $opt->bar,   undef, "entry not given is undef (as method)");
}

{
  local @ARGV = qw(--get);
  my ($opt, $usage) = describe_options(
    "%c %o",
    [ "mode" => hidden => { one_of => [
      [ "get" => "get the value"  ],
      [ "set" => "set the value" ],
    ] } ],
  );
  is( $opt->{get}, 1, "one_of provided value (as hash key)" );
  is( $opt->get,   1, "one_of provided value (as method)" );

  is( $opt->{set}, undef, "one_of entry not given is undef (as hash key)" );
  is( $opt->set,   undef, "one_of entry not given is undef (as method)");
}

{
  local @ARGV = qw(--foo-bar);
  my ($opt) = describe_options(
    "%c %o",
    [ "foo:s", "foo option" ],
    [ "foo-bar", "foo-bar option", { implies => 'foo' } ],
  );
  is_deeply($opt, { foo => 1, foo_bar => 1 },
    "ok to imply option with optional argument");

  is($opt->foo_bar, 1, 'given value (checked with method)');
  is($opt->foo,     1, 'implied value (checked with method)');
}

{
  local @ARGV;
  local $Getopt::Long::Descriptive::TERM_WIDTH = 80;

  my ($opt, $usage) = describe_options(
    "test %o",
    [ foo => "a foo option" ],
    [ bar => "a bar option" ],
    [ baz => "a baz option with a very long description."
             . " It just goes on for a really long time."
             . " This allows us to test line wrapping and"
             . " make sure the output always looks spiffy" ],

t/descriptive.t  view on Meta::CPAN

    spacer and it will be longer than the 78 column line that we use by
    default.

    --xyz  an xyz option
EOO

  is($usage->text, $expect, 'long option description is wrapped cleanly');
}

{
  local @ARGV;
  local $Getopt::Long::Descriptive::TERM_WIDTH = 80;

  # We're testing, here, that if we "forget" the usual "%c %o" style format,
  # its assumed.
  my ($opt, $usage) = describe_options(
    [ foo => "a foo option" ],
  );

  my $expect = <<"EOO";
test-program [long options...]

t/descriptive.t  view on Meta::CPAN

  my @test = (
    # (expected $opt->exit) then (@ARGV)
    [ undef,              ],
    [ 1,      '--exit'    ],
    [ 0,      '--no-exit' ],
  );

  for my $test (@test) {
    my $want = shift @$test;
    local @ARGV = @$test;

    my ($opt, $usage) = describe_options(@gld_args);

    is(scalar $opt->exit, $want, "(@$test) for exit!");
  }
}

{
  local @ARGV;
  my ($opt, $usage) = describe_options(
    "%c %o",
    [ foo => "x" x 80 ],
  );
  local $@;
  local $SIG{ALRM} = sub { die "ALRM\n" };
  eval {
    alarm(2);
    like($usage->text, qr/@{["x" x 80]}/, "handled unwrappable description");
    alarm(0);

t/shortcircuit.t  view on Meta::CPAN

}

like(
  exception { describe_options( _args() ) },
  qr/required/,
  'no req: error',
);

like(
  warning {
    local @ARGV = @reqs;
    describe_options( _args( default => 1 ) );
  },
  qr/'default' does not make sense for shortcircuit/,
  'shortcircuit + default'
);

SKIP: {
  my $opt;

  is(
    exception {
      local @ARGV = @reqs;
      ( $opt ) = describe_options( _args() );
    },
    undef,
    'req: no error'
  ) or skip( 'no object due to failure', 1 );

  ok( defined $opt->req1 && $opt->req1 == 1, 'req: req1 specified' );
}

SKIP: {
  my $opt;

  is(
    exception {
      local @ARGV = qw[ --help ];
      ( $opt ) = describe_options( _args() );
    },
    undef,
    'help: no error'
  ) or skip( 'no object due to failure', 2 );

  is( $opt->help,          1, 'help: help flag' );
  is( scalar keys %{$opt}, 1, 'help: only help' );
}

SKIP: {
  my ( $w, $opt );

  is(
    exception {
      local @ARGV = qw[ --help ];
      ( $opt ) = describe_options( _args( @reqs ) );
    },
    undef,
    'help + req: no error'
  ) or skip( 'no object due to failure', 2 );

  is( $opt->help,          1, 'help + req: help flag' );
  is( scalar keys %{$opt}, 1, 'help + req: only help' );
}