From 7fce4340deb0b6337bbd7ef6071ee42529db222d Mon Sep 17 00:00:00 2001 From: dakkar Date: Fri, 13 Jul 2018 13:09:26 +0100 Subject: vaguely parse commands --- lib/Getopt/Dakkar.pm | 5 ++- lib/Getopt/Dakkar/ArgPack.pm | 11 +++++ lib/Getopt/Dakkar/Role/Command.pm | 76 +++++++++++++++++++++++++++++++++ lib/Getopt/Dakkar/Role/Piece.pm | 22 ++++++++++ lib/Getopt/Dakkar/Stash.pm | 23 ++++++++++ lib/Getopt/Dakkar/Style.pm | 10 ++--- lib/Getopt/Dakkar/X.pm | 4 ++ notes.pl | 88 --------------------------------------- notes.txt | 88 +++++++++++++++++++++++++++++++++++++++ perlcritic.rc | 11 +++-- 10 files changed, 239 insertions(+), 99 deletions(-) create mode 100644 lib/Getopt/Dakkar/ArgPack.pm create mode 100644 lib/Getopt/Dakkar/Role/Command.pm create mode 100644 lib/Getopt/Dakkar/Role/Piece.pm create mode 100644 lib/Getopt/Dakkar/Stash.pm create mode 100644 lib/Getopt/Dakkar/X.pm delete mode 100644 notes.pl create mode 100644 notes.txt diff --git a/lib/Getopt/Dakkar.pm b/lib/Getopt/Dakkar.pm index d8edd0c..b43c24e 100644 --- a/lib/Getopt/Dakkar.pm +++ b/lib/Getopt/Dakkar.pm @@ -1,6 +1,9 @@ package Getopt::Dakkar; -use Getopt::Dakkar::Style; +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'; + 1; diff --git a/lib/Getopt/Dakkar/ArgPack.pm b/lib/Getopt/Dakkar/ArgPack.pm new file mode 100644 index 0000000..ee710e0 --- /dev/null +++ b/lib/Getopt/Dakkar/ArgPack.pm @@ -0,0 +1,11 @@ +package Getopt::Dakkar::ArgPack; +use Getopt::Dakkar::Style qw(class); +# VERSION +# ABSTRACT: pack of arguments + +# this needs work + +has getopt => ( is => 'ro', required => 1, weak_ref => 1 ); + +has options => ( is => 'ro' ); +has arguments => ( is => 'ro' ); diff --git a/lib/Getopt/Dakkar/Role/Command.pm b/lib/Getopt/Dakkar/Role/Command.pm new file mode 100644 index 0000000..b96c410 --- /dev/null +++ b/lib/Getopt/Dakkar/Role/Command.pm @@ -0,0 +1,76 @@ +package Getopt::Dakkar::Role::Command; +use Getopt::Dakkar::Style qw(role); +with 'Getopt::Dakkar::Role::Piece'; +# VERSION +# ABSTRACT: a command + +has options => ( is => 'ro', isa => ArrayRef, default => sub { [] } ); +has parameters => ( is => 'ro', isa => ArrayRef, default => sub { [] } ); +has subcommands => ( is => 'ro', isa => ArrayRef, default => sub { [] } ); + +sub parse($self,$args=undef) { + my $stash = $self->_parse($args); + if (my $op = $self->op) { + $stash->$op(); + } +} + +sub _parse($self,$args,$stash=undef) { + my $argpack = Getopt::Dakkar::ArgPack->new({getopt=>$self}); + 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)) { + # ->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,$self); + $argpack->options->{$match->name} = $option; + } + else { + Getopt::Dakkar::X::BadOption->throw({ + input => $this, + }); + } + } + elsif (my $match = $self->_match_subcommand($this)) { + shift $args->@*; + $stash //= $self->_make_stash($argpack); + my $op = $self->op; + $stash->$op($argpack); + $match->_parse($args,$stash); + } + else { + shift $args->@* if $self->_is_terminator($this); + for my $parameter ($self->parameters->@*) { + # ->parse will remove the argument(s) from $args + my $argument = $parameter->parse($args,$self); + $argpack->arguments->{$argument->name} = $argument; + } + + # if we've parsed all arguments, and there's still stuff + # in the input, something is wrong: complain + if ($args->@*) { + Getopt::Dakkar::X::ExtraArgs->throw({ + args => $args, + }); + } + } + } + return $stash; +} + +sub _is_terminator($self,$arg) { return $arg eq q{--} } +sub _looks_like_option($self,$arg) { return $arg =~ /^-/ } +sub _match_option($self,$arg) { + for my $option ($self->options->@*) { + return $option if $option->match($arg); + } +} +sub _match_subcommand($self,$arg) { + for my $subcommand ($self->subcommands->@*) { + return $subcommand if $subcommand->match($arg); + } +} diff --git a/lib/Getopt/Dakkar/Role/Piece.pm b/lib/Getopt/Dakkar/Role/Piece.pm new file mode 100644 index 0000000..d981095 --- /dev/null +++ b/lib/Getopt/Dakkar/Role/Piece.pm @@ -0,0 +1,22 @@ +package Getopt::Dakkar::Role::Piece; +use Getopt::Dakkar::Style qw(role); +# VERSION +# ABSTRACT: a piece + +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 'parse'; diff --git a/lib/Getopt/Dakkar/Stash.pm b/lib/Getopt/Dakkar/Stash.pm new file mode 100644 index 0000000..2d0d568 --- /dev/null +++ b/lib/Getopt/Dakkar/Stash.pm @@ -0,0 +1,23 @@ +package Getopt::Dakkar::Stash; +use Getopt::Dakkar::Style qw(class); +# VERSION +# ABSTRACT: a stash + +has options => ( is => 'ro' ); +has arguments => ( is => 'ro' ); + +sub new_from_argpack($class,$argpack) { + return $class->new({ + options => $argpack->options, + arguments => $argpack->arguments, + }); +} + +sub merge_with_argpack($self,$argpack) { + for my $f (qw(options arguments)) { + my $this = $self->$f; + my $that = $argpack->$f; + $this->{$_} = $that->{$_} for keys $that->%*; + } + return $self; +} diff --git a/lib/Getopt/Dakkar/Style.pm b/lib/Getopt/Dakkar/Style.pm index e843262..5246a95 100644 --- a/lib/Getopt/Dakkar/Style.pm +++ b/lib/Getopt/Dakkar/Style.pm @@ -1,12 +1,8 @@ package Getopt::Dakkar::Style; use 5.026; -use strictures 2; +use strictures version => 2; use true; use Import::Into; -use Try::Tiny (); -use Carp (); -use feature (); -use experimental (); use Path::Tiny (); # VERSION @@ -57,11 +53,11 @@ sub import { my $caller = caller(); strict->import(); - feature->import(':5.26'); + feature->import::into($caller, ':5.26'); Try::Tiny->import::into($caller); Carp->import::into($caller); - feature->import::into($caller, ':5.26'); true->import({ into => $caller }); + Getopt::Dakkar::X->import::into($caller); my %arg = map { $_ => 1 } @args; if ($arg{class}) { diff --git a/lib/Getopt/Dakkar/X.pm b/lib/Getopt/Dakkar/X.pm new file mode 100644 index 0000000..e595b71 --- /dev/null +++ b/lib/Getopt/Dakkar/X.pm @@ -0,0 +1,4 @@ +package Getopt::Dakkar::X; +use Getopt::Dakkar::Style; +# VERSION +# ABSTRACT: exceptions diff --git a/notes.pl b/notes.pl deleted file mode 100644 index d6bff3f..0000000 --- a/notes.pl +++ /dev/null @@ -1,88 +0,0 @@ -#!perl - -Getopt::Dakkar->new({ - name => basename($0), - title => from_pod('NAME'), - synopsis => from_pod('SYNOPSIS'), - - class => $a_class_name, # - object => $an_object, # at most one of these two is allowed - # maybe object should be passed to the ->run method, not here? - # but I like the idea of different options / parameters / - # subcommands having their own objects - op => $method, # optional - - options => [ - { - name => 'some-opt', - alias => [qw(s O)], # equivalent to switches => [qw(some-opt s O)], - type => Type::Tiny::something, # special cases for path, enum, bool - # 'counter' would be useful - # also, special cases for arrays and hashes - required => 1, - validate => \&foo, # defaults to the type::tiny assertion - complete_shell => \&cs, # auto-generated for path, enum, more? - complete => \&bar, # only if there's no complete_shell - op => $method, # optional - }, - ... - ], - - parameters => [ - { - # like options, but no aliases / switches - }, - ... - ], - # you can't have both parameters and subcommands - subcommands => [ - { - # like top-level - }, - ... - ], -}); - -=head1 LOGIC - -- options and parameters can optionally be mixed (like other getopts) -- short options can optionally be bundled - -normal parsing: at each level: - -- shift @ARGV, match against "-$short_option" or "--$long_option", eat - argument if needed -- if no match, and subcommands - - match against subcommands - - if no match, and we have a default/implied subcommands, assume that and recurse - - error out -- if no match, and parameters - - match parameters positionally - -just before recursing (or at the end): - -- if we don't have a $state, init it with $object, or $class->new($argpack) ($class defaults to a hash-like thing that has a 'merge_with' method) -- call $state->$op($argpack) ($op defaults to 'merge_with') -- $argpack has a weakref to the Getopt::Dakkar object - -which means: - -- if no class/object/op is passed, at the end we have hash-like state - with all the arguments/optios merged in - -- if we only have an op at the last step, it will be invoked with all - the accumulated info - -- ops at different levels can do whatever they want - -shell completion: - -- the various complete_shell are put together into a big function -- if there's a 'complete' (non-shell), the function will - GETOPT_DAKKAR_COMPLETE=1 $name "$@" - (the last word may be empty if we're TAB-ing after a IFS) -- the program will parse normally - - on validation error, warn, ignore the failed argument, and carry on -- then invoke the completion function $state->$complete($argpack) -- and return to the shell everything that was returned - - check App::Spec trick to print more than what's completed diff --git a/notes.txt b/notes.txt new file mode 100644 index 0000000..d6bff3f --- /dev/null +++ b/notes.txt @@ -0,0 +1,88 @@ +#!perl + +Getopt::Dakkar->new({ + name => basename($0), + title => from_pod('NAME'), + synopsis => from_pod('SYNOPSIS'), + + class => $a_class_name, # + object => $an_object, # at most one of these two is allowed + # maybe object should be passed to the ->run method, not here? + # but I like the idea of different options / parameters / + # subcommands having their own objects + op => $method, # optional + + options => [ + { + name => 'some-opt', + alias => [qw(s O)], # equivalent to switches => [qw(some-opt s O)], + type => Type::Tiny::something, # special cases for path, enum, bool + # 'counter' would be useful + # also, special cases for arrays and hashes + required => 1, + validate => \&foo, # defaults to the type::tiny assertion + complete_shell => \&cs, # auto-generated for path, enum, more? + complete => \&bar, # only if there's no complete_shell + op => $method, # optional + }, + ... + ], + + parameters => [ + { + # like options, but no aliases / switches + }, + ... + ], + # you can't have both parameters and subcommands + subcommands => [ + { + # like top-level + }, + ... + ], +}); + +=head1 LOGIC + +- options and parameters can optionally be mixed (like other getopts) +- short options can optionally be bundled + +normal parsing: at each level: + +- shift @ARGV, match against "-$short_option" or "--$long_option", eat + argument if needed +- if no match, and subcommands + - match against subcommands + - if no match, and we have a default/implied subcommands, assume that and recurse + - error out +- if no match, and parameters + - match parameters positionally + +just before recursing (or at the end): + +- if we don't have a $state, init it with $object, or $class->new($argpack) ($class defaults to a hash-like thing that has a 'merge_with' method) +- call $state->$op($argpack) ($op defaults to 'merge_with') +- $argpack has a weakref to the Getopt::Dakkar object + +which means: + +- if no class/object/op is passed, at the end we have hash-like state + with all the arguments/optios merged in + +- if we only have an op at the last step, it will be invoked with all + the accumulated info + +- ops at different levels can do whatever they want + +shell completion: + +- the various complete_shell are put together into a big function +- if there's a 'complete' (non-shell), the function will + GETOPT_DAKKAR_COMPLETE=1 $name "$@" + (the last word may be empty if we're TAB-ing after a IFS) +- the program will parse normally + - on validation error, warn, ignore the failed argument, and carry on +- then invoke the completion function $state->$complete($argpack) +- and return to the shell everything that was returned + - check App::Spec trick to print more than what's completed diff --git a/perlcritic.rc b/perlcritic.rc index 7bfe7a1..82ffecf 100644 --- a/perlcritic.rc +++ b/perlcritic.rc @@ -214,7 +214,8 @@ severity = 2 [Modules::RequireBarewordIncludes] # End each module with an explicitly `1;' instead of some funky expression. -[Modules::RequireEndWithOne] +# we use 'true' +[-Modules::RequireEndWithOne] # Always make the `package' explicit. [Modules::RequireExplicitPackage] @@ -244,7 +245,8 @@ allow_import_of = utf8 strict warnings # forbid = # Write `@{ $array_ref }' instead of `@$array_ref'. -[References::ProhibitDoubleSigils] +# we use postderef, this policy gets confused +[-References::ProhibitDoubleSigils] # Capture variable used outside conditional. [RegularExpressions::ProhibitCaptureWithoutTest] @@ -314,7 +316,8 @@ allow_import_of = utf8 strict warnings [Subroutines::ProhibitReturnSort] # Don't write `sub my_function (@@) {}'. -[Subroutines::ProhibitSubroutinePrototypes] +# we use signatures, and this policy gets confused +[-Subroutines::ProhibitSubroutinePrototypes] severity = 2 # Prevent unused private subroutines. @@ -352,9 +355,11 @@ statements = 10 # Always `use strict'. [TestingAndDebugging::RequireUseStrict] +equivalent_modules = Getopt::Dakkar::Style # Always `use warnings'. [TestingAndDebugging::RequireUseWarnings] +equivalent_modules = Getopt::Dakkar::Style # Don't use the comma operator as a statement separator. [ValuesAndExpressions::ProhibitCommaSeparatedStatements] -- cgit v1.2.3