From 9c7b213f58fe533953953e90b5bc77087ca4d45d Mon Sep 17 00:00:00 2001 From: dakkar Date: Fri, 13 Jul 2018 18:52:08 +0100 Subject: we can now parse boolean options --- lib/Getopt/Dakkar.pm | 15 ++++-- lib/Getopt/Dakkar/ArgPack.pm | 4 +- lib/Getopt/Dakkar/Argument.pm | 5 ++ lib/Getopt/Dakkar/Option.pm | 17 ++++-- lib/Getopt/Dakkar/OptionValue.pm | 5 ++ lib/Getopt/Dakkar/Parameter.pm | 31 +++++++++++ lib/Getopt/Dakkar/Role/Command.pm | 53 +++++++++++++----- lib/Getopt/Dakkar/Role/Piece.pm | 16 ------ lib/Getopt/Dakkar/Role/Value.pm | 7 +++ lib/Getopt/Dakkar/Subcommand.pm | 5 ++ lib/Getopt/Dakkar/X.pm | 12 +++++ t/tests/parsing.t | 110 ++++++++++++++++++++++++++++++++++++++ 12 files changed, 243 insertions(+), 37 deletions(-) create mode 100644 lib/Getopt/Dakkar/Argument.pm create mode 100644 lib/Getopt/Dakkar/OptionValue.pm create mode 100644 lib/Getopt/Dakkar/Parameter.pm create mode 100644 lib/Getopt/Dakkar/Role/Value.pm create mode 100644 lib/Getopt/Dakkar/Subcommand.pm create mode 100644 t/tests/parsing.t diff --git a/lib/Getopt/Dakkar.pm b/lib/Getopt/Dakkar.pm index 1432987..739985b 100644 --- a/lib/Getopt/Dakkar.pm +++ b/lib/Getopt/Dakkar.pm @@ -1,13 +1,22 @@ package Getopt::Dakkar; use Getopt::Dakkar::Style qw(class); -use Module::Runtime qw(use_module); # VERSION # ABSTRACT: the best command line parser ever with 'Getopt::Dakkar::Role::Command'; has '+name' => ( default => $0 ); +has '+class' => ( default => 'Getopt::Dakkar::Stash' ); -sub go($self,$args=\@ARGV) { - return $self->parse($args,undef); +sub parse($self,$args=\@ARGV,$=) { + my $stash = $self->_parse($args,undef) // + $self->make_stash(Getopt::Dakkar::ArgPack->new()); + # we're top-level, we should really have used all the command line + # elements + if ($args->@*) { + Getopt::Dakkar::X::ExtraArgs->throw({ + args => $args, + }); + } + return $stash; } diff --git a/lib/Getopt/Dakkar/ArgPack.pm b/lib/Getopt/Dakkar/ArgPack.pm index ee710e0..4337ce4 100644 --- a/lib/Getopt/Dakkar/ArgPack.pm +++ b/lib/Getopt/Dakkar/ArgPack.pm @@ -7,5 +7,5 @@ use Getopt::Dakkar::Style qw(class); has getopt => ( is => 'ro', required => 1, weak_ref => 1 ); -has options => ( is => 'ro' ); -has arguments => ( is => 'ro' ); +has options => ( is => 'ro', isa => HashRef, default => sub { +{} } ); +has arguments => ( is => 'ro', isa => HashRef, default => sub { +{} } ); diff --git a/lib/Getopt/Dakkar/Argument.pm b/lib/Getopt/Dakkar/Argument.pm new file mode 100644 index 0000000..1ee721c --- /dev/null +++ b/lib/Getopt/Dakkar/Argument.pm @@ -0,0 +1,5 @@ +package Getopt::Dakkar::Argument; +use Getopt::Dakkar::Style qw(class); +with 'Getopt::Dakkar::Role::Value'; +# VERSION +# ABSTRACT: the value of a parameter diff --git a/lib/Getopt/Dakkar/Option.pm b/lib/Getopt/Dakkar/Option.pm index 0dfd882..077f7be 100644 --- a/lib/Getopt/Dakkar/Option.pm +++ b/lib/Getopt/Dakkar/Option.pm @@ -1,5 +1,6 @@ package Getopt::Dakkar::Option; use Getopt::Dakkar::Style qw(class); +use Getopt::Dakkar::OptionValue; with 'Getopt::Dakkar::Role::Piece'; # VERSION # ABSTRACT: an option @@ -23,16 +24,26 @@ sub match($self,$arg) { sub parse($self,$args,$stash) { my $my_option = shift $args->@*; + # this will need to be extracted and made dependent on the type! + + my %arguments; # first, get arguments if needed for my $parameter ($self->parameters->@*) { my $argument = $parameter->parse($args,$stash); - # aaarg, + $arguments{$argument->name} = $argument; } # then, remove the option and put the bundle back, if needed - if ($my_option =~ /^-[^-]+/) { # we're in a bundle + if ($my_option =~ /^-[^-]{2,}/) { # we're in a bundle $my_option =~ s{^-.}{-}; unshift $args->@*, $my_option; } - return $the_option_argument; + + my $value = Getopt::Dakkar::OptionValue->new({ + name => $self->name, + # needs a way to negate a boolean! + value => %arguments ? \%arguments : 1, + }); + + return $value; } diff --git a/lib/Getopt/Dakkar/OptionValue.pm b/lib/Getopt/Dakkar/OptionValue.pm new file mode 100644 index 0000000..d19cf61 --- /dev/null +++ b/lib/Getopt/Dakkar/OptionValue.pm @@ -0,0 +1,5 @@ +package Getopt::Dakkar::OptionValue; +use Getopt::Dakkar::Style qw(class); +with 'Getopt::Dakkar::Role::Value'; +# VERSION +# ABSTRACT: the value of an option diff --git a/lib/Getopt/Dakkar/Parameter.pm b/lib/Getopt/Dakkar/Parameter.pm new file mode 100644 index 0000000..d544c74 --- /dev/null +++ b/lib/Getopt/Dakkar/Parameter.pm @@ -0,0 +1,31 @@ +package Getopt::Dakkar::Parameter; +use Getopt::Dakkar::Style qw(class); +use Getopt::Dakkar::Argument; +with 'Getopt::Dakkar::Role::Piece'; +# VERSION +# ABSTRACT: a (positional) parameter + +# this will need to be generalised and depend on the type +has is_slurpy => ( is => 'ro', isa => Bool, default => 0 ); + +sub match($self,$arg) { + # this may need to throw if the type is wrong? + return 1; +} + +sub parse($self,$args,$stash) { + if ($self->is_slurpy) { + my $value = [ $args->@* ]; + $args->@* = (); + return Getopt::Dakkar::Argument->new({ + name => $self->name, + value => $value, + }); + } + else { + return Getopt::Dakkar::Argument->new({ + name => $self->name, + value => (shift $args->@*), + }); + } +} diff --git a/lib/Getopt/Dakkar/Role/Command.pm b/lib/Getopt/Dakkar/Role/Command.pm index 444a9a4..2a3186b 100644 --- a/lib/Getopt/Dakkar/Role/Command.pm +++ b/lib/Getopt/Dakkar/Role/Command.pm @@ -1,5 +1,7 @@ package Getopt::Dakkar::Role::Command; use Getopt::Dakkar::Style qw(role); +use Getopt::Dakkar::ArgPack; +use Module::Runtime qw(use_module); with 'Getopt::Dakkar::Role::Piece'; # VERSION # ABSTRACT: a command @@ -8,8 +10,26 @@ has options => ( is => 'ro', isa => ArrayRef, default => sub { [] } ); has parameters => ( is => 'ro', isa => ArrayRef, default => sub { [] } ); has subcommands => ( is => 'ro', isa => ArrayRef, default => sub { [] } ); +has class => ( is => 'ro', isa => Str ); +has object => ( is => 'ro', isa => Object ); +has op => ( is => 'ro', isa => Str|CodeRef, default => 'merge_with_argpack' ); + +sub make_stash($self,$argpack) { + if (my $o = $self->object) { return $o } + + return unless $self->class; + + my $class = use_module($self->class); + if (my $from_argpack = $class->can('new_from_argpack')) { + return $class->$from_argpack($argpack); + } + else { + return $class->new(); + } +} + sub parse($self,$args,$stash) { - my $stash = $self->_parse($args,$stash); + $stash = $self->_parse($args,$stash); if (my $op = $self->op) { return $stash->$op(); } @@ -18,17 +38,18 @@ sub parse($self,$args,$stash) { sub _parse($self,$args,$stash) { my $argpack = Getopt::Dakkar::ArgPack->new({getopt=>$self}); + my @parameters = $self->parameters->@*; while ($args->@*) { my $this = $args->[0]; if ($self->_looks_like_option($this) and not $self->_is_terminator($this)) { - if (my $match = $self->_match_option($this)) { + if (my $option = $self->_match_option($this)) { # ->parse will remove $this (or parts of # it, if it's a bundle) and shift its own arguments # out of $args - my $option = $match->parse($args,$stash); - $argpack->options->{$match->name} = $option; + my $option_value = $option->parse($args,$stash); + $argpack->options->{$option_value->name} = $option_value; } else { Getopt::Dakkar::X::BadOption->throw({ @@ -36,15 +57,12 @@ sub _parse($self,$args,$stash) { }); } } - elsif (my $match = $self->_match_subcommand($this)) { + elsif (my $subcommand = $self->_match_subcommand($this)) { shift $args->@*; - $stash //= $self->_make_stash($argpack); - my $op = $self->op; - $stash->$op($argpack); - $match->parse($args,$stash); + $subcommand->parse($args,$stash); } - else { - shift $args->@* if $self->_is_terminator($this); + elsif ($self->_is_terminator($this)) { + shift $args->@*; for my $parameter ($self->parameters->@*) { # ->parse will remove the argument(s) from $args my $argument = $parameter->parse($args,$stash); @@ -58,10 +76,19 @@ sub _parse($self,$args,$stash) { args => $args, }); } - # hmmm. what about 'ls foo -l' ? + } + else { + my $next_parameter = shift @parameters + or last; + my $argument = $next_parameter->parse($args,$stash); + $argpack->arguments->{$argument->name} = $argument; } } - return $stash; + my $new_stash = $self->make_stash($argpack) // $stash; + my $op = $self->op; + $new_stash->$op($argpack); + + return $new_stash; } sub _is_terminator($self,$arg) { return $arg eq q{--} } diff --git a/lib/Getopt/Dakkar/Role/Piece.pm b/lib/Getopt/Dakkar/Role/Piece.pm index 81c89e7..5b7609d 100644 --- a/lib/Getopt/Dakkar/Role/Piece.pm +++ b/lib/Getopt/Dakkar/Role/Piece.pm @@ -12,20 +12,4 @@ has matching_strings => ( ); sub _build_matching_strings($self) { [ $self->name, $self->aliases->@* ] } -has class => ( is => 'ro', isa => ClassName, default => 'Getopt::Dakkar::Stash' ); -has object => ( is => 'ro', isa => Object ); -has op => ( is => 'ro', isa => Str|CodeRef ); - -sub make_stash($self,$argpack) { - if (my $o = $self->object) { return $o } - - my $class = use_module($self->class); - if (my $from_argpack = $class->can('new_from_argpack')) { - return $class->$from_argpack($argpack); - } - else { - return $class->new(); - } -} - requires qw(parse match); diff --git a/lib/Getopt/Dakkar/Role/Value.pm b/lib/Getopt/Dakkar/Role/Value.pm new file mode 100644 index 0000000..ef4d4de --- /dev/null +++ b/lib/Getopt/Dakkar/Role/Value.pm @@ -0,0 +1,7 @@ +package Getopt::Dakkar::Role::Value; +use Getopt::Dakkar::Style qw(role); +# VERSION +# ABSTRACT: a value + +has name => ( is => 'ro', isa => Str, required => 1 ); +has value => ( is => 'ro', required => 1 ); diff --git a/lib/Getopt/Dakkar/Subcommand.pm b/lib/Getopt/Dakkar/Subcommand.pm new file mode 100644 index 0000000..92438c3 --- /dev/null +++ b/lib/Getopt/Dakkar/Subcommand.pm @@ -0,0 +1,5 @@ +package Getopt::Dakkar::Subcommand; +use Getopt::Dakkar::Style qw(class); +with 'Getopt::Dakkar::Role::Command'; +# VERSION +# ABSTRACT: a sub command diff --git a/lib/Getopt/Dakkar/X.pm b/lib/Getopt/Dakkar/X.pm index e595b71..f705ed5 100644 --- a/lib/Getopt/Dakkar/X.pm +++ b/lib/Getopt/Dakkar/X.pm @@ -2,3 +2,15 @@ package Getopt::Dakkar::X; use Getopt::Dakkar::Style; # VERSION # ABSTRACT: exceptions + +package Getopt::Dakkar::X::ExtraArgs { + use Getopt::Dakkar::Style qw(class); + with 'Throwable'; + has args => ( is => 'ro', isa => ArrayRef, required => 1 ); +}; + +package Getopt::Dakkar::X::BadOption { + use Getopt::Dakkar::Style qw(class); + with 'Throwable'; + has input => ( is => 'ro', isa => Str, required => 1 ); +}; diff --git a/t/tests/parsing.t b/t/tests/parsing.t new file mode 100644 index 0000000..2ac394e --- /dev/null +++ b/t/tests/parsing.t @@ -0,0 +1,110 @@ +use Getopt::Dakkar::Style qw(test); +use Getopt::Dakkar; +use Getopt::Dakkar::Option; +use Getopt::Dakkar::Parameter; +use Getopt::Dakkar::Subcommand; + +subtest 'nothing' => sub { + my $getopt = Getopt::Dakkar->new(); + + my $stash; + lives_ok { $stash = $getopt->parse([]) } + 'nothing parsing nothing should live'; + cmp_deeply( + $stash, + methods( + options => {}, + arguments => {}, + ), + 'the stash should be empty', + ) or explain $stash; + + throws_ok { $stash = $getopt->parse([1]) } + 'Getopt::Dakkar::X::ExtraArgs', + 'too many elements will throw'; +}; + +subtest 'simple option' => sub { + my $getopt = Getopt::Dakkar->new({ + options => [ + Getopt::Dakkar::Option->new({ + name => 'foo', + aliases => ['f'], + }), + ], + }); + + # we don't yet have the concept of "required option value / + # argument", so we can't test the corresponding behaviour + + my $stash; + + for my $form (qw(-f --foo)) { + lives_ok { $stash = $getopt->parse([$form]) } + "parsing $form should live"; + cmp_deeply( + $stash, + methods( + options => { foo => methods(name=>'foo',value=>1) }, + arguments => {}, + ), + 'the stash should contain the option value', + ) or explain $stash; + } + + for my $form (qw(-x -fx --xx)) { + throws_ok { $stash = $getopt->parse([$form]) } + 'Getopt::Dakkar::X::BadOption', + "parsing $form should throw"; + } +}; + +subtest 'option bundling' => sub { + my $getopt = Getopt::Dakkar->new({ + options => [ + Getopt::Dakkar::Option->new({ + name => 'foo', + aliases => ['f'], + can_bundle => 1, + }), + Getopt::Dakkar::Option->new({ + name => 'bar', + aliases => ['b'], + can_bundle => 1, + }), + ], + }); + + my $stash; + + for my $form ( + [qw(-fb)], [qw(-bf)], + [qw(-f -b)], [qw(-b -f)], + [qw(--foo -b)], [qw(--bar -f)], + [qw(--foo --bar)], + ) { + lives_ok { $stash = $getopt->parse($form) } + "parsing $form->@* should live"; + cmp_deeply( + $stash, + methods( + options => { + foo => methods(name=>'foo',value=>1), + bar => methods(name=>'bar',value=>1), + }, + arguments => {}, + ), + 'the stash should contain the option value', + ) or explain $stash; + } + + for my $form ( + [qw(--foobar)], [qw(-foo)], + ) { + throws_ok { $stash = $getopt->parse($form) } + 'Getopt::Dakkar::X::BadOption', + "parsing $form->@* should throw"; + } +}; + +done_testing; -- cgit v1.2.3