summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--lib/Getopt/Dakkar.pm5
-rw-r--r--lib/Getopt/Dakkar/ArgPack.pm11
-rw-r--r--lib/Getopt/Dakkar/Role/Command.pm76
-rw-r--r--lib/Getopt/Dakkar/Role/Piece.pm22
-rw-r--r--lib/Getopt/Dakkar/Stash.pm23
-rw-r--r--lib/Getopt/Dakkar/Style.pm10
-rw-r--r--lib/Getopt/Dakkar/X.pm4
-rw-r--r--notes.txt (renamed from notes.pl)0
-rw-r--r--perlcritic.rc11
9 files changed, 151 insertions, 11 deletions
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.txt
index d6bff3f..d6bff3f 100644
--- a/notes.pl
+++ b/notes.txt
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]