New Upstream Release - raku-getopt-long
Ready changes
Summary
Merged new upstream version: 0.4.2 (was: 0.3.5).
Resulting package
Built on 2023-04-25T21:25 (took 8m2s)
The resulting binary packages can be installed (if you have the apt repository enabled) by running one of:
apt install -t fresh-releases raku-getopt-long
Lintian Result
Diff
diff --git a/Changes b/Changes
index 0dfb7ae..354e35d 100644
--- a/Changes
+++ b/Changes
@@ -2,6 +2,22 @@ Revision history for Getopt-Long
{{$NEXT}}
+0.4.2 2023-02-15T16:34:42+01:00
+ - Add basic usage generator to Getopt::Long
+ - Add «Parameter is option(Hash)»
+ - Make converter traits check for definedness
+ - Make options and positionals public methods
+ - Restore :auto-help option
+
+0.4.1 2022-12-12T15:49:16+01:00
+ - Make FormattableException a Getopt::Long::Exception
+ - Add Custom role for argument type customization
+ - Allow Options in get-options{,-from}
+
+0.4.0 2022-12-01T15:26:25+01:00
+ - Add Argument classes
+ - Improve getopt trait on subs
+
0.3.5 2022-09-26T18:25:31+02:00
- Allow enum values to be converted to enums
diff --git a/META6.json b/META6.json
index 275419e..acac6e8 100644
--- a/META6.json
+++ b/META6.json
@@ -11,7 +11,7 @@
"name": "Getopt::Long",
"perl": "6.*",
"provides": {
- "Getopt::Long": "lib/Getopt/Long.pm"
+ "Getopt::Long": "lib/Getopt/Long.rakumod"
},
"resources": [
],
@@ -23,5 +23,5 @@
],
"test-depends": [
],
- "version": "0.3.5"
+ "version": "0.4.2"
}
diff --git a/debian/changelog b/debian/changelog
index c8a2108..d0df34f 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,9 @@
+raku-getopt-long (0.4.2-1) UNRELEASED; urgency=low
+
+ * New upstream release.
+
+ -- Debian Janitor <janitor@jelmer.uk> Tue, 25 Apr 2023 21:17:46 -0000
+
raku-getopt-long (0.3.5-1) unstable; urgency=medium
* new upstream release
diff --git a/lib/Getopt/Long.pm b/lib/Getopt/Long.rakumod
similarity index 58%
rename from lib/Getopt/Long.pm
rename to lib/Getopt/Long.rakumod
index 4d74969..fb324fc 100644
--- a/lib/Getopt/Long.pm
+++ b/lib/Getopt/Long.rakumod
@@ -1,7 +1,7 @@
use v6;
use fatal;
-unit class Getopt::Long:ver<0.3.5>;
+unit class Getopt::Long:ver<0.4.2>;
class Exception is CORE::Exception {
has Str:D $.message is required;
@@ -10,17 +10,15 @@ class Exception is CORE::Exception {
}
}
-role FormattableException is CORE::Exception {
+role FormattableException is Exception {
has Str:D $.format is required;
method new(Str $format) {
- return self.bless(:$format);
+ my $message = $format.sprintf('some');
+ return self.bless(:$format, :$message);
}
method rethrow-with(Str $name) {
die Exception.new($!format.sprintf($name));
}
- method message() {
- $!format.sprintf('some');
- }
}
class ValueInvalid does FormattableException {
@@ -29,7 +27,7 @@ class ValueInvalid does FormattableException {
class ConverterInvalid does FormattableException {
}
-my sub convert(Code:D $converter, Str:D $value) {
+sub convert(Any:D $value, Code:D $converter) {
return $converter($value);
CATCH {
when X::Str::Numeric {
@@ -50,112 +48,227 @@ my sub convert(Code:D $converter, Str:D $value) {
}
}
+sub convert-with(Any:D $value, Code:D $converter, Str:D $name) {
+ CATCH { when ValueInvalid { .rethrow-with($name) } }
+ return convert($value, $converter);
+}
+
my role Store {
has Str:D $.key is required;
has Code:D $.converter = *.self;
has Junction:D $.constraints = all();
+ has Hash $.values is required;
method check-constraints(Any:D $value) {
die ValueInvalid.new(qq{Can't accept %s argument "$value" because it fails its constraints}) unless $value ~~ $!constraints;
}
- method store-convert(Str:D $value, Hash:D $hash) {
- self.store-direct(convert($!converter, $value), $hash);
+ method store-convert(Str:D $value) {
+ self.store-direct(convert($value, $!converter));
}
- method store-direct(Any:D $value, Hash:D $hash) { ... }
+ method store-direct(Any:D $value) { ... }
}
my class ScalarStore does Store {
- method store-direct(Any:D $value, Hash:D $hash) {
+ method store-direct(Any:D $value) {
self.check-constraints($value);
- $hash{$!key} = $value;
+ $!values{$!key} = $value;
}
}
my class CountStore does Store {
- method store-direct(Int:D $value, Hash:D $hash) {
- $hash{$!key} += $value;
+ method store-direct(Int:D $value) {
+ $!values{$!key} += $value;
}
}
my class ArrayStore does Store {
- has Any:U $.type is required;
- method store-direct(Any:D $value, Hash:D $hash) {
+ has Any:U $.type = Str;
+ method store-direct(Any:D $value) {
self.check-constraints($value);
- $hash{$!key} //= $!type === Any ?? Array !! Array[$!type].new;
- $hash{$!key}.push($value);
+ $!values{$!key} //= $!type === Any ?? Array !! Array[$!type].new;
+ $!values{$!key}.push($value);
}
}
my class HashStore does Store {
- has Any:U $.type is required;
- method store-convert(Any:D $pair, Hash:D $hash) {
+ has Any:U $.type = Str;
+ method store-convert(Any:D $pair) {
my ($key, $value) = $pair.split('=', 2);
- my $converted-value = convert($!converter, $value);
+ my $converted-value = convert($value, $!converter);
self.check-constraints($converted-value);
- $hash{$!key} //= $!type === Any ?? Hash !! Hash[$!type].new;
- $hash{$!key}{$key} = $converted-value;
+ $!values{$!key} //= $!type === Any ?? Hash !! Hash[$!type].new;
+ $!values{$!key}{$key} = $converted-value;
}
- method store-direct(Any:D $pair, Hash:D $hash) {
+ method store-direct(Any:D $pair) {
!!!
}
}
-my class Option {
+my class Receiver {
has Range:D $.arity is required;
has Store:D $.store is required;
has Any $.default;
- method store(Any:D $raw, Hash:D $hash) {
- $!store.store-convert($raw, $hash);
+ method store(Any:D $raw) {
+ $!store.store-convert($raw);
}
- method store-default(Hash:D $hash) {
- $!store.store-direct($!default, $hash);
+ method store-default() {
+ $!store.store-direct($!default);
}
}
-has Code:D @!positionals is built;
-has Option:D %!options is built;
+sub get-converter(Any:U $type) {
+ state %converter-for-type{Any:U} = (
+ Pair.new(Int, *.Int),
+ Pair.new(Rat, *.Rat),
+ Pair.new(Num, *.Num),
+ Pair.new(Real, *.Real),
+ Pair.new(Numeric, *.Numeric),
+ Pair.new(Complex, *.Complex),
+ Pair.new(Str, *.Str),
+ Pair.new(IO::Path, *.IO),
+ Pair.new(IO, *.IO),
+ Pair.new(DateTime, *.DateTime),
+ Pair.new(Date, *.Date),
+ Pair.new(Version, *.Version),
+ Pair.new(Any, &val),
+ );
-method !positionals {
- return @!positionals.map(*.returns);
+ state $coercion-how = try ::("Metamodel::CoercionHOW");
+ if %converter-for-type{$type} -> &converter {
+ return &converter;
+ } elsif $type.HOW ~~ $coercion-how {
+ my &primary = get-converter($type.^constraint_type());
+ return %converter-for-type{$type} = sub coercion-converter(Any $input) {
+ my $primary = primary($input);
+ return $primary ~~ $type.^target_type ?? $primary !! $type.^coerce($primary);
+ }
+ } elsif $type.HOW ~~ Metamodel::EnumHOW {
+ sub valid-values() {
+ my @keys = $type.WHO.keys.sort({ $type.WHO{$^value} });
+ my @pairs = @keys.map: { sprintf('%s(%s)', $^key, $type.WHO{$^key}.value) };
+ return @pairs.join(', ');
+ }
+ return %converter-for-type{$type} = sub enum-converter(Any $value) {
+ return $type.WHO{$value} // $type.^enum_from_value($value) // die ValueInvalid.new(qq{Can't convert %s argument "$value" to $type.^name(), valid values are: &valid-values()});
+ }
+ } else {
+ die ConverterInvalid.new("No argument conversion known for %s argument (type {$type.^name})");
+ }
}
-method !options {
- return %!options;
+role Argument {
+ has Junction:D $.constraints = all();
+}
+multi get-transformer(Argument $) {
+ return Nil;
}
-my %store-for = (
- '%' => HashStore,
- '@' => ArrayStore,
- '$' => ScalarStore,
- '' => ScalarStore,
-);
+role Argument::Valued does Argument {
+ has Any:U $.type = Str;
+ has Code:D $.converter = get-converter($!type);
+}
-my sub make-option(@names, Any:U $multi-class, %multi-args, Range $arity, %options-args?, Bool $negatable?) {
- my $store = $multi-class.new(|%multi-args, :key(@names[0]));
- my %options;
- for @names -> $name {
- %options{$name} = Option.new(:$store, :$arity, :default, |%options-args);
- if $negatable {
- %options{"no$name"} = Option.new(:$store, :$arity, |%options-args, :!default);
- %options{"no-$name"} = Option.new(:$store, :$arity, |%options-args, :!default);
+class Argument::Boolean does Argument {
+ has Bool:D $.negatable = False;
+}
+multi make-receivers(Argument::Boolean $arg, Str:D $key, @names, %values) {
+ my $store = ScalarStore.new(:$key, :constraints($arg.constraints), :%values);
+ gather for @names -> $name {
+ take $name => Receiver.new(:$store, :arity(0..0), :default);
+ if $arg.negatable {
+ take "no$name" => Receiver.new(:$store, :arity(0..0), :!default);
+ take "no-$name" => Receiver.new(:$store, :arity(0..0), :!default);
}
}
- return %options;
-}
-
-my %converter-for-type{Any:U} = (
- Pair.new(Int, *.Int),
- Pair.new(Rat, *.Rat),
- Pair.new(Num, *.Num),
- Pair.new(Real, *.Real),
- Pair.new(Numeric, *.Numeric),
- Pair.new(Complex, *.Complex),
- Pair.new(Str, *.Str),
- Pair.new(IO::Path, *.IO),
- Pair.new(IO, *.IO),
- Pair.new(DateTime, *.DateTime),
- Pair.new(Date, *.Date),
- Pair.new(Version, *.Version),
- Pair.new(Any, &val),
+}
+
+class Argument::Scalar does Argument::Valued {
+ has Any $.default;
+}
+multi make-receivers(Argument::Scalar $arg, Str:D $key, @names, %values) {
+ my $store = ScalarStore.new(:$key, :converter($arg.converter), :constraints($arg.constraints), :%values);
+ my $arity = $arg.default.defined ?? 0..1 !! 1..1;
+ return @names.map: { $^name => Receiver.new(:$store, :$arity, :default($arg.default)) }
+}
+
+role Argument::Composite does Argument::Valued {
+ has Code $.transformer;
+}
+multi get-transformer(Argument::Composite $arg) {
+ return $arg.transformer;
+}
+
+class Argument::Array does Argument::Composite {
+ has Range:D $.arity = 1..1;
+}
+multi make-receivers(Argument::Array $arg, Str:D $key, @names, %values) {
+ my $store = ArrayStore.new(:$key, :type($arg.type), :converter($arg.converter), :constraints($arg.constraints), :%values);
+ return @names.map: { $^name => Receiver.new(:$store, :arity($arg.arity)) }
+}
+
+
+class Argument::Hash does Argument::Composite {
+}
+multi make-receivers(Argument::Hash $arg, Str:D $key, @names, %values) {
+ my $store = HashStore.new(:$key, :type($arg.type), :converter($arg.converter), :constraints($arg.constraints), :%values);
+ return @names.map: { $^name => Receiver.new(:$store, :arity(1..1)) }
+}
+
+class Argument::Counter does Argument {
+ has Any:U $.type = Int;
+ has Code:D $.converter = get-converter($!type);
+ has Bool:D $.argumented = False;
+}
+multi make-receivers(Argument::Counter $arg, Str:D $key, @names, %values) {
+ my $store = CountStore.new(:$key, :converter($arg.converter), :constraints($arg.constraints), :%values);
+ my $arity = $arg.argumented ?? 0..1 !! 0..0;
+ return @names.map: { $^name => Receiver.new(:$store, :$arity, :1default) }
+}
+multi get-transformer(Argument::Counter $arg) {
+ return $arg.converter;
+}
+
+my rule name { [\w+]+ % '-' | '?' }
+
+class Option {
+ has Str @.names is required;
+ has Str:D $.key is required;
+ has Argument $.argument;
+ has Str $.why;
+ submethod TWEAK(:@names) {
+ die Exception.new('No name given for option') if @names < 1;
+ die Exception.new("Invalid name(s): @names[]") if any(@names) !~~ &name;
+ }
+ multi method new(:@names!, :$argument!, Str :$key = @names[0], Str :$why) {
+ return self.bless(:@names, :$key, :$argument, :$why);
+ }
+ multi method new(:$name!, :$argument!, Str :$why) {
+ return self.bless(:names[$name], :key($name), :$argument, :$why);
+ }
+}
+
+class Ordered {
+ has Str:D $.name = 'some';
+ has Any:U $.type = Str;
+ has Code:D $.converter = get-converter($!type);
+ has Str $.why;
+ method type-name() {
+ $!type.^name
+ }
+}
+
+has Option:D @.options is required;
+has Ordered:D @.positionals;
+has Str $.slurpy;
+
+method new-from-objects(Getopt::Long:U: @options, @positionals?) {
+ return self.bless(:@options, :@positionals);
+}
+
+my %argument-for = (
+ '%' => Argument::Hash,
+ '@' => Argument::Array,
+ '$' => Argument::Scalar,
+ '' => Argument::Scalar,
);
my sub type-for-format(Str:D $format) {
@@ -174,14 +287,10 @@ my sub type-for-format(Str:D $format) {
return %type-for-format{$format};
};
-my rule name { [\w+]+ % '-' | '?' }
-
-my grammar Argument {
+my grammar Parser {
token TOP {
<names> <argument>
- {
- make make-option($<names>.ast, |$<argument>.ast);
- }
+ { make Option.new(:names($<names>.ast), :argument($<argument>.ast)); }
}
token names {
@@ -196,25 +305,22 @@ my grammar Argument {
token boolean {
$<negatable>=['!'?]
- { make [ ScalarStore, {}, 0..0, {}, ?$<negatable> ] }
+ { make Argument::Boolean.new(:negatable(?$<negatable>)) }
}
token counter {
'+'
- { make [ CountStore, {}, 0..0, { :1default } ] }
+ { make Argument::Counter.new }
}
token type {
<alpha>
- {
- my $type = type-for-format(~$/);
- make { :$type, :converter(%converter-for-type{$type}) }
- }
+ { make type-for-format(~$/) }
}
token equals {
'=' <type> $<repeat>=[<[%@]>?]
- { make [ %store-for{~$<repeat>}, $<type>.ast, 1..1 ] }
+ { make %argument-for{~$<repeat>}.new(:type($<type>.ast)) }
}
rule range {
@@ -223,173 +329,231 @@ my grammar Argument {
}
token equals-more {
'=' <type> '{' <range>'}'
- { make [ ArrayStore, $<type>.ast, $<range>.ast ] }
+ { make Argument::Array.new(:type($<type>.ast), :arity($<range>.ast)) }
}
token colon-type {
':' <type>
- { make [ ScalarStore, $<type>.ast, 0..1, { :default($<type>.ast<type>.new) } ] }
+ { make Argument::Scalar.new(:type($<type>.ast), :default($<type>.ast.new)) }
}
token colon-int {
':' $<num>=[<[0..9]>+]
- { make [ ScalarStore, { :converter(*.Int) }, 0..1, { :default($<num>.Int) } ] }
+ { make Argument::Scalar.new(:type(Int), :default($<num>.Int)) }
}
token colon-count {
':+'
- { make [ CountStore, { :converter(*.Int) }, 0..1, { :default(1) } ] }
+ { make Argument::Counter.new(:argumented) }
}
}
-method new-from-patterns(Getopt::Long:U: @patterns, Str:D :$positionals = "") {
- my %options;
- for @patterns -> $pattern {
- if Argument.parse($pattern) -> $match {
- for $match.ast.kv -> $key, $option {
- %options{$key} = $option;
- }
- } else {
- die Exception.new("Couldn't parse argument specification '$pattern'");
- }
- CATCH { when ConverterInvalid {
- .rethrow-with("pattern $pattern");
- }}
+our sub parse-option(Str $pattern) {
+ CATCH { when ConverterInvalid { .rethrow-with("pattern $pattern") }}
+ with Parser.parse($pattern) -> $match {
+ return $match.ast;
+ } else {
+ die Exception.new("Couldn't parse argument specification '$pattern'");
}
- my @positionals = $positionals.comb.map(&type-for-format).map(&get-converter);
- return self.new(:%options, :@positionals);
}
-my sub get-converter(Any:U $type) {
- state $coercion-how = try ::("Metamodel::CoercionHOW");
- if %converter-for-type{$type} -> &converter {
- return &converter;
- } elsif $type.HOW ~~ $coercion-how {
- my &primary = get-converter($type.^constraint_type());
- return sub coercion-converter(Str $input) {
- return $type.^coerce(primary($input));
- }
- } elsif $type.HOW ~~ Metamodel::EnumHOW {
- my $valid-values = $type.WHO.keys.sort({ $type.WHO{$^value} }).join(", ");
- return sub enum-converter(Str $value) {
- return $type.WHO{$value} // $type.^enum_from_value($value) // die ValueInvalid.new(qq{Can't convert %s argument "$value" to $type.^name(), valid values are: $valid-values});
- }
- } else {
- die ConverterInvalid.new("No argument conversion known for %s argument (type {$type.^name})");
- }
+sub make-positional(Any:U $type, Str $name, Str $why) {
+ CATCH { when ConverterInvalid { .rethrow-with($name); }}
+ my $converter = get-converter($type);
+ return Ordered.new(:$name, :$type, :$converter, :$why);
}
-my role Formatted {
- has Option %.options is required;
+my Str @ordinals = <first second third fourth fifth sixth seventh eighth nineth tenth some some> ... *;
+
+method new-from-patterns(Getopt::Long:U: @patterns, Str:D :$positionals = "") {
+ my @options = @patterns.map(&parse-option);
+ my @positional-types = $positionals.comb.map(&type-for-format);
+ my @positionals = @positional-types Z[&make-positional] @ordinals;
+ return self.bless(:@options, :@positionals);
+}
+
+my role Formatted::Named {
+ has Argument $.argument is required;
+}
+
+multi sub trait_mod:<is>(Parameter $param, Argument :option($argument)!) is export(:DEFAULT, :traits) {
+ return $param does Formatted::Named(:$argument);
}
-multi sub trait_mod:<is>(Parameter $param, Str:D :getopt(:$option)!) is export(:DEFAULT, :traits) {
- CATCH { when ConverterInvalid { .rethrow("parameter {$param.name}") }}
- with Argument.parse($option, :rule('argument')) -> $match {
- my %options = make-option($param.named_names, |$match.ast);
- return $param does Formatted(:%options);
+our sub parse-argument(Str $pattern, Str $name) {
+ CATCH { when ConverterInvalid { .rethrow-with("parameter {$name}") }}
+ with Parser.parse($pattern, :rule('argument')) -> $match {
+ return $match.ast;
} else {
- die Exception.new("Couldn't parse parameter {$param.name}'s argument specification '$option'");
+ die Exception.new("Couldn't parse parameter $name\'s argument specification '$pattern'");
}
}
-multi sub trait_mod:<is>(Parameter $param, Code:D :option($converter)!) is export(:DEFAULT, :traits) {
+multi sub trait_mod:<is>(Parameter $param where $param.named, Str:D :getopt(:$option)!) is export(:DEFAULT, :traits) {
+ my $argument = parse-argument($option, $param.named_names[0]);
+ return $param does Formatted::Named(:$argument);
+}
+
+multi sub trait_mod:<is>(Parameter $param where $param.named, Code:D :$option!) is export(:DEFAULT, :traits) {
my $element-type = $param.sigil eq '@'|'%' ?? $param.type.of !! $param.type;
my $type = $element-type ~~ Any ?? $element-type !! Any;
- my %options = make-option($param.named_names, %store-for{$param.sigil}, { :$type, :$converter }, 1..1);
- return $param does Formatted(:%options);
+ my $converter = sub ($value) { $option($value) orelse die ValueInvalid("Can't convert %s argument") };
+ my $argument = %argument-for{$param.sigil}.new(:$type, :$converter);
+ return $param does Formatted::Named(:$argument);
}
-my role Parsed {
- has Getopt::Long:D $.getopt is required;
+multi sub trait_mod:<is>(Parameter $param where $param.named, :%option!) is export(:DEFAULT, :traits) {
+ %option<type> //= %option<default>.WHAT with %option<default>;
+ my $argument = %argument-for{$param.sigil}.new(|%option);
+ return $param does Formatted::Named(:$argument);
}
-multi sub trait_mod:<is>(Sub $sub, :$getopt!) is export(:DEFAULT, :traits) {
- $sub does Parsed(Getopt::Long.new-from-sub($sub));
+multi get-reason(Pod::Block::Declarator:D $declarator) {
+ return $declarator.trailing // $declarator.leading;
+}
+multi get-reason(Any:U $declarator) {
+ return Str;
+}
+
+my role Formatted::Positional {
+ has Ordered $.argument is required;
}
-my multi get-positionals(&candidate) {
- return &candidate.signature.params.grep(*.positional).map(*.type);
+multi sub trait_mod:<is>(Parameter $param where $param.positional, Ordered:D :$option!) is export(:DEFAULT, :traits) {
+ return $param does Formatted::Positional($option);
+}
+multi sub trait_mod:<is>(Parameter $param where $param.positional, Str:D :$option!) is export(:DEFAULT, :traits) {
+ CATCH { when ConverterInvalid { .rethrow-with("parameter $param.name()") }}
+ my $argument = Ordered.new(:name($param.usage-name), :type(type-for-format($option)), :why(get-reason($param.WHY)));
+ return $param does Formatted::Positional($argument);
+}
+multi sub trait_mod:<is>(Parameter $param where $param.positional, Code:D :$option!) is export(:DEFAULT, :traits) {
+ my $converter = sub ($value) { $option($value) orelse die ValueInvalid("Can't convert %s argument") };
+ my $argument = Ordered.new(:name($param.usage-name), :type($param.type), :$converter, :why(get-reason($param.WHY)));
+ return $param does Formatted::Positional($argument);
}
-my multi get-positionals(&candidate where Parsed) {
- return &candidate.getopt!positionals;
+role Custom {
+ method get-argument-for(Parameter $param) { ... }
}
-my multi get-named(&candidate) {
- my @options;
- for &candidate.signature.params.grep(*.named) -> $param {
- if $param ~~ Formatted {
- @options.append: $param.options;
+multi get-argument(Parameter $param) {
+ if $param.sigil eq '$' {
+ my $type = $param.type;
+ my $constraints = $param.constraints;
+ if $type === Bool {
+ return Argument::Boolean.new(:$constraints, :negatable(?$param.default));
+ } elsif $type ~~ Custom {
+ return $type.get-argument-for($param);
} else {
- my @names = $param.named_names;
- if $param.sigil eq '$' {
- my $type = $param.type;
- my $constraints = $param.constraints;
- if $param.type === Bool {
- @options.append: make-option(@names, ScalarStore, { :$constraints }, 0..0, {}, ?$param.default)
- } else {
- my $converter = get-converter($param.type);
- @options.append: make-option(@names, ScalarStore, { :$converter, :$constraints }, 1..1);
- }
- } else {
- my $type = $param.type.of ~~ Any ?? $param.type.of !! Any;
- my $converter = get-converter($type);
- @options.append: make-option(@names, %store-for{$param.sigil}, { :$type, :$converter }, 1..1);
- }
- CATCH { when ConverterInvalid {
- .rethrow-with("parameter {$param.name}");
- }}
+ return Argument::Scalar.new(:$type, :$constraints);
}
+ } else {
+ my $type = $param.type.of ~~ Any ?? $param.type.of !! Any;
+ return %argument-for{$param.sigil}.new(:$type);
}
- return @options.hash;
+ CATCH { when ConverterInvalid {
+ .rethrow-with("parameter {$param.name}");
+ }}
}
-my multi get-named(&candidate where Parsed) {
- return &candidate.getopt!options;
+multi get-argument(Parameter $param where Formatted::Named) {
+ return $param.argument;
}
-my Str @ordinals = <first second third fourth fifth sixth seventh eighth nineth tenth some some> ... *;
+sub make-option(Parameter $param) {
+ return Option.new(:names($param.named_names), :argument(get-argument($param)), :why(get-reason($param.WHY)));
+}
-method new-from-sub(Getopt::Long:U: Sub $main) {
- my (%options, @positional-types);
- for $main.candidates -> $candidate {
- for get-named($candidate).kv -> $key, $option {
- if %options{$key}:exists and %options{$key} !eqv $option {
- die Exception.new("Can't merge arguments for {$key}");
+multi get-positional-object(Parameter $parameter) {
+ return make-positional($parameter.type, $parameter.usage-name, get-reason($parameter.WHY));
+}
+multi get-positional-object(Parameter $param where Formatted::Positional) {
+ return $param.argument;
+}
+
+my role Parsed {
+ has Getopt::Long:D $.getopt is required;
+}
+
+multi get-from-sub(&candidate) {
+ my @params = &candidate.signature.params;
+ my @options = @params.grep(*.named).map(&make-option);
+ my @positionals = @params.grep(*.positional).map(&get-positional-object);
+ my ($slurpy) = @params.grep({ $^param.slurpy and not $^param.named }).map(*.usage-name)[0] // Str;
+ return Getopt::Long.bless(:@options, :@positionals, :$slurpy);
+}
+multi get-from-sub(&candidate where Parsed) {
+ return &candidate.getopt;
+}
+
+multi sub trait_mod:<is>(Sub $sub, Bool :$getopt!) is export(:DEFAULT, :traits) {
+ return $sub does Parsed(get-from-sub($sub));
+}
+multi sub trait_mod:<is>(Sub $sub, :@getopt!) is export(:DEFAULT, :traits) {
+ return $sub does Parsed(Getopt::Long.new-from-patterns(@getopt));
+}
+multi sub trait_mod:<is>(Sub $sub, Getopt::Long:D :$getopt!) is export(:DEFAULT, :traits) {
+ return $sub does Parsed($getopt);
+}
+
+sub merge-named-objects(@options-for) {
+ my %unique;
+ for @options-for -> @option-set {
+ for @option-set -> $option {
+ for $option.names -> $name {
+ die "Can't merge unequal options for --$name" if %unique{$name}:exists and %unique{$name} !eqv $option;
+ %unique{$name} = $option;
}
- %options{$key} = $option;
}
- @positional-types.push: get-positionals($candidate);
}
- my $elem-max = max(@positional-types».elems);
- my @positionals = (0 ..^ $elem-max).map: -> $index {
- my @types = @positional-types.grep(* > $index)»[$index];
- die Exception.new("Positional arguments are of different types {@types.perl}") unless [===] @types;
- CATCH { when ConverterInvalid {
- .rethrow-with(@ordinals[$index]);
- }}
- get-converter(@types[0]);
- }
- return self.new(:%options, :@positionals);
+ return %unique.values;
+}
+
+sub merge-positional-object(@positionals-for, $elems) {
+ my @positionals = @positionals-for.grep(* > $elems)»[$elems];
+ die Exception.new("@ordinals[$elems].tc() arguments are of different types: { @positionals».type-name.join(', ') }") unless [eqv] @positionals».converter;
+ return @positionals[0];
+}
+
+sub merge-positional-objects(@positionals-for) {
+ my $elem-max = @positionals-for».elems.max;
+ return (^$elem-max).map: { merge-positional-object(@positionals-for, $^elem) };
+}
+
+sub merge-parsers(Getopt::Long @parsers) {
+ my @options = merge-named-objects(@parsers».options);
+ my @positionals = merge-positional-objects(@parsers».positionals);
+ return Getopt::Long.bless(:@options, :@positionals);
+}
+
+method new-from-sub(Getopt::Long:U: Sub $main) {
+ my Getopt::Long @parsers = $main.candidates.map(&get-from-sub);
+ return @parsers > 1 ?? merge-parsers(@parsers) !! @parsers[0];
}
method get-options(Getopt::Long:D: @args is copy, :%hash, :$auto-abbreviate = False, :$compat-builtin = False, :named-anywhere(:$permute) = !$compat-builtin, :$bundling = !$compat-builtin, :$compat-singles = $compat-builtin, :$compat-negation = $compat-builtin, :$compat-positional = $compat-builtin, :$compat-space = $compat-builtin, :$auto-help = $compat-builtin, :$write-args) {
my @list;
+ sub to-receivers(Option $option) {
+ CATCH { when ConverterInvalid { .rethrow-with("--{$option.names[0]}") }}
+ return make-receivers($option.argument, $option.key, $option.names, %hash);
+ }
+ my %receivers = @!options.flatmap(&to-receivers);
+
while @args {
my $head = @args.shift;
my $consumed = 0;
- sub get-option(Str:D $key, Str:D $name) {
- with %!options{$key} -> $option {
+ sub get-receiver(Str:D $key, Str:D $name) {
+ with %receivers{$key} -> $option {
return $option;
} elsif $key eq 'help' && $auto-help {
- return Option.new(:store(ScalarStore.new(:key<help>)), :arity(0..0), :default);
+ return Receiver.new(:store(ScalarStore.new(:key<help>, :values(%hash))), :arity(0..0), :default);
} elsif $auto-abbreviate {
- my @names = %!options.keys.grep(*.starts-with($key));
+ my @names = %receivers.keys.grep(*.starts-with($key));
if @names == 1 {
- return %!options{ @names[0] };
+ return %receivers{ @names[0] };
} elsif @names > 1 {
die Exception.new("Ambiguous partial option $name, possible interpretations: @names[]");
} else {
@@ -400,68 +564,66 @@ method get-options(Getopt::Long:D: @args is copy, :%hash, :$auto-abbreviate = Fa
}
}
- sub take-value(Option:D $option, Str:D $value, Str:D $name) {
+ sub take-value(Receiver:D $receiver, Str:D $value, Str:D $name) {
CATCH { when ValueInvalid { .rethrow-with($name) } }
- $option.store($value, %hash);
+ $receiver.store($value);
$consumed++;
}
- sub take-args(Option:D $option, Str:D $name) {
- while @args && $consumed < $option.arity.min {
- take-value($option, @args.shift, $name);
+ sub take-args(Receiver:D $receiver, Str:D $name) {
+ while @args && $consumed < $receiver.arity.min {
+ take-value($receiver, @args.shift, $name);
}
- while !$compat-space && @args && $consumed < $option.arity.max && !@args[0].starts-with('--') {
- take-value($option, @args.shift, $name);
+ while !$compat-space && @args && $consumed < $receiver.arity.max && !@args[0].starts-with('--') {
+ take-value($receiver, @args.shift, $name);
}
- if $consumed == 0 && $option.arity.min == 0 {
- $option.store-default(%hash);
- } elsif $consumed < $option.arity.min {
- die Exception.new("The argument $name requires a value but none was specified");
+ if $consumed == 0 && $receiver.arity.min == 0 {
+ $receiver.store-default();
+ } elsif $consumed < $receiver.arity.min {
+ die Exception.new("The option $name requires a value but none was specified");
}
}
- my rule name { [\w+]+ % '-' | '?' }
-
if $bundling && $head ~~ / ^ '-' $<values>=[\w .* ] $ / -> $/ {
my @values = $<values>.Str.comb;
for @values.keys -> $index {
my $value = @values[$index];
- my $option = get-option($value, "-$value");
- if $option.arity.max > 0 && $index + 1 < @values.elems {
+ my $receiver = get-receiver($value, "-$value");
+ if $receiver.arity.max > 0 && $index + 1 < @values.elems {
my $offset = $compat-singles && @values[$index + 1] eq '=' ?? 2 !! 1;
- take-value($option, $<values>.substr($index + $offset), "-$value");
+ take-value($receiver, $<values>.substr($index + $offset), "-$value");
}
- take-args($option, "-$value");
+ take-args($receiver, "-$value");
last if $consumed;
}
}
elsif $compat-singles && $head ~~ / ^ '-' <name> '=' $<value>=[.*] / -> $/ {
- my $option = get-option(~$<name>, "-$<name>");
- die Exception.new("-$<name> doesn't take an argument") if $option.arity.max != 1;
- take-value($option, ~$<value>, "-$<name>");
+ my $receiver = get-receiver(~$<name>, "-$<name>");
+ die Exception.new("Option -$<name> doesn't take an argument") if $receiver.arity.max != 1;
+ take-value($receiver, ~$<value>, "-$<name>");
}
elsif $head eq '--' {
@list.append: |@args;
last;
}
elsif $head ~~ / ^ '-' ** 1..2 <name> $ / -> $/ {
- take-args(get-option(~$<name>, ~$/), ~$/);
+ take-args(get-receiver(~$<name>, ~$/), ~$/);
}
elsif $head ~~ / ^ $<full-name>=[ '--' <name> ] '=' $<value>=[.*] / -> $/ {
- my $option = get-option(~$<name>, ~$<full-name>);
- die Exception.new("Option $<full-name> doesn't take arguments") if $option.arity.max == 0;
- take-value($option, ~$<value>, ~$<full-name>);
- take-args($option, ~$<full-name>);
+ my $receiver = get-receiver(~$<name>, ~$<full-name>);
+ die Exception.new("Option $<full-name> doesn't take arguments") if $receiver.arity.max == 0;
+ take-value($receiver, ~$<value>, ~$<full-name>);
+ take-args($receiver, ~$<full-name>);
}
elsif $compat-negation && $head ~~ / ^ $<full-name>=[ '-' ** 1..2 '/' <name> ] ['=' $<value>=[.*]]? $ / {
if $<value> {
- my $option = get-option(~$<name>, ~$<full-name>);
- die Exception.new("Option $<full-name> doesn't take an argument") if $option.arity.max != 1;
- take-value($option, ~$<value> but False, ~$<full-name>);
+ my $receiver = get-receiver(~$<name>, ~$<full-name>);
+ die Exception.new("Option $<full-name> doesn't take an argument") if $receiver.arity.max != 1;
+ take-value($receiver, ~$<value> but False, ~$<full-name>);
} else {
- take-args(get-option('no-' ~ $<name>, ~$<full-name>), ~$<full-name>);
+ take-args(get-receiver('no-' ~ $<name>, ~$<full-name>), ~$<full-name>);
}
} else {
if $permute {
@@ -472,28 +634,39 @@ method get-options(Getopt::Long:D: @args is copy, :%hash, :$auto-abbreviate = Fa
}
}
}
- @$write-args = @list if $write-args;
+
+ for @!options -> $option {
+ with get-transformer($option.argument) -> $transformer {
+ my $key = $option.key;
+ %hash{$key} = convert-with(%hash{$key}, $transformer, "--$key") if %hash{$key}:exists;
+ }
+ }
+
my &fallback-converter = $compat-positional ?? &val !! *.self;
- my @converters = |@!positionals, &fallback-converter, *;
- my @positionals = (@ordinals Z @list Z @converters).map: -> $ [ $name, $value, $converter ] {
- CATCH { when ValueInvalid { .rethrow-with($name) }}
- convert($converter, $value);
+ my @positionals = @list.kv.map: -> $index, $value {
+ with @!positionals[$index] -> $positional {
+ convert-with($value, $positional.converter, $positional.name);
+ } else {
+ convert-with($value, &fallback-converter, @ordinals[$index]);
+ }
};
+
+ @$write-args = @list if $write-args;
return \(|@positionals, |%hash);
}
our sub get-options-from(@args, *@elements, :$overwrite, *%config) is export(:DEFAULT, :functions) {
my %hash := @elements && @elements[0] ~~ Hash ?? @elements.shift !! {};
my @options;
- for @elements -> $element {
- when $element ~~ Str {
- @options.push: $element;
+ for @elements {
+ when Str {
+ @options.push: parse-option($_);
}
- when $element ~~ Pair {
- my $key = $element.key;
- my ($name) = $element.key ~~ / ^ (\w+) /[0];
- %hash{$name} := $element.value;
- given $element.value {
+ when Pair {
+ my $key = .key;
+ my ($name) = .key ~~ / ^ (\w+) /[0];
+ %hash{$name} := .value;
+ given .value {
when Positional {
$key ~= '@' unless $key.ends-with('@'|'}');
}
@@ -501,13 +674,16 @@ our sub get-options-from(@args, *@elements, :$overwrite, *%config) is export(:DE
$key ~= '%' unless $key.ends-with('%');
}
}
- @options.push: $key;
+ @options.push: parse-option($key);
+ }
+ when Option {
+ @options.push: $_;
}
default {
- die Exception.new("Unknown element type: " ~ $element.perl);
+ die Exception.new("Unknown element type: " ~ .perl);
}
}
- my $getopt = Getopt::Long.new-from-patterns(@options);
+ my $getopt = Getopt::Long.new-from-objects(@options);
return $getopt.get-options(@args, |%config, :%hash, :write-args($overwrite ?? @args !! Any));
}
@@ -515,34 +691,101 @@ our sub get-options(|args) is export(:DEFAULT, :functions) {
return get-options-from(@*ARGS, :overwrite, |args);
}
-our sub call-with-getopt(&func, @args, %options?) is export(:DEFAULT, :functions) {
- my $capture = Getopt::Long.new-from-sub(&func).get-options(@args, |%options, :write-args(@args));
+our sub call-with-getopt(&func, @args, %options = %*SUB-MAIN-OPTS // {}) is export(:DEFAULT, :functions) {
+ my $capture = Getopt::Long.new-from-sub(&func).get-options(@args, |%options);
return func(|$capture);
}
-my sub call-main(CallFrame $callframe, Any $retval) {
- my $main = $callframe.my<&MAIN>;
- return $retval unless $main;
- my %options = %*SUB-MAIN-OPTS // {};
- return call-with-getopt($main, @*ARGS, %options);
-}
-
our sub ARGS-TO-CAPTURE(Sub $func, @args) is export(:DEFAULT, :MAIN) {
my %options = %*SUB-MAIN-OPTS // {};
- return Getopt::Long.new-from-sub($func).get-options(@args, |%options, :write-args(@args));
+ return Getopt::Long.new-from-sub($func).get-options(@args, |%options);
CATCH { when Exception { note .message; &*EXIT(2) } };
}
-our sub MAIN_HELPER(Bool $in-is-args, $retval = 0) is export(:DEFAULT, :MAIN) {
- if $in-is-args {
- my $in := $*IN;
- my $*ARGFILES := IO::ArgFiles.new($in, :nl-in($in.nl-in), :chomp($in.chomp), :encoding($in.encoding), :bin(!$in.encoding));
- call-main(callframe(1), $retval);
+sub usage-name(@names) {
+ if @names == 1 and @names[0].chars == 1 {
+ return "-@names[0]";
+ } else {
+ return '--' ~ @names.join('|');
+ }
+}
+
+sub describe-type(Any:U $type) {
+ my $result = $type.^name;
+ if $type.HOW ~~ Metamodel::EnumHOW {
+ my $options = $type.^enum_values.keys.sort.Str;
+ $result ~= $options.chars > 50 ?? ' (' ~ substr($options,0,50) ~ '...' !! " ($options)"
+ }
+ return $result;
+}
+
+multi description-for-argument(Argument::Scalar $argument) {
+ with $argument.default {
+ return "[&describe-type($argument.type)]";
+ } else {
+ return describe-type($argument.type);
+ }
+}
+
+multi description-for-argument(Argument::Boolean $argument) {
+ return Str;
+}
+multi description-for-argument(Argument::Counter $argument) {
+ return Str;
+}
+
+multi description-for-argument(Argument::Array $argument) {
+ return describe-type($argument.type) ~ '...';
+}
+
+multi description-for-argument(Argument::Hash $argument) {
+ return "<key>=" ~ describe-type($argument.type) ~ '...';
+}
+
+sub usage-for-named(Option $option) {
+ my $name = usage-name($option.names.reverse);
+ my $description = description-for-argument($option.argument);
+
+ return $description.defined ?? "$name $description" !! $name;
+}
+
+multi describe-options(@options) {
+ if any(@options).why {
+ my @pairs = gather for @options -> $option {
+ my $lead = usage-for-named($option);
+ my $reason = $option.why // '';
+ take ($lead, $reason);
+ }
+ my $width = max(@pairs.map(*.[0].chars));
+
+ return @pairs.map: -> ($left, $right) { sprintf '%-*s %s', $width + 1, $left, $right };
+ } else {
+ return @options.map(&usage-for-named);
+ }
+}
+
+our sub generate-usage(&main, :$program-name = $*PROGRAM.basename) is export(:usage, :functions) {
+ my $getopt = Getopt::Long.new-from-sub(&main);
+ my @positionals = $getopt.positionals;
+ my @positional-descs = $getopt.positionals.map({ "<$^positional.name()>" });
+ @positional-descs.push: "<$getopt.slurpy()>..." with $getopt.slurpy;
+
+ my @options = $getopt.options;
+ my @option-descs = describe-options($getopt.options);
+
+ if $program-name.chars + @option-descs.join(' ').chars > 72 or any(@options).why {
+ my @lines = flat "Usage:", ('', $program-name, '[options...]', |@positional-descs).join(' '), '', @option-descs.map(*.indent(4));
+ return @lines.join("\n");
} else {
- call-main(callframe(1), $retval);
+ my @main = ('', $program-name, |@option-descs.map({ "[$^option]" }), |@positional-descs);
+ return "Usage:\n" ~ @main.join(' ');
}
}
+our sub GENERATE-USAGE(&main, |capture) is export(:usage) {
+ return generate-usage(&main);
+}
+
=begin pod
=head1 NAME
diff --git a/t/basic.t b/t/basic.rakutest
similarity index 100%
rename from t/basic.t
rename to t/basic.rakutest
Debdiff
[The following lists of changes regard files as different if they have different names, permissions or owners.]
Files in second set of .debs but not in first
-rw-r--r-- root/root /usr/lib/perl6/vendor/dist/783DAF3D86ADC7E2AD63E2369452B61DE49EC123 -rw-r--r-- root/root /usr/lib/perl6/vendor/precomp/AF50A328AB74BE48ACBF2B65E07E64E53E5A7E10/62/62B221A577A8911016E08DEBC918E0AD8FB62D2F -rw-r--r-- root/root /usr/lib/perl6/vendor/precomp/AF50A328AB74BE48ACBF2B65E07E64E53E5A7E10/62/62B221A577A8911016E08DEBC918E0AD8FB62D2F.repo-id -rw-r--r-- root/root /usr/lib/perl6/vendor/short/D3750099056A52CD3D76C09C5969009AAE1B2738/783DAF3D86ADC7E2AD63E2369452B61DE49EC123 -rw-r--r-- root/root /usr/lib/perl6/vendor/sources/62B221A577A8911016E08DEBC918E0AD8FB62D2F
Files in first set of .debs but not in second
-rw-r--r-- root/root /usr/lib/perl6/vendor/dist/549A1995E61D70E3A62E5C86DC35E861230ECC62 -rw-r--r-- root/root /usr/lib/perl6/vendor/precomp/AF50A328AB74BE48ACBF2B65E07E64E53E5A7E10/09/09A0EA333CA118659A0C987D2FB061D539EBB809 -rw-r--r-- root/root /usr/lib/perl6/vendor/precomp/AF50A328AB74BE48ACBF2B65E07E64E53E5A7E10/09/09A0EA333CA118659A0C987D2FB061D539EBB809.repo-id -rw-r--r-- root/root /usr/lib/perl6/vendor/short/D3750099056A52CD3D76C09C5969009AAE1B2738/549A1995E61D70E3A62E5C86DC35E861230ECC62 -rw-r--r-- root/root /usr/lib/perl6/vendor/sources/09A0EA333CA118659A0C987D2FB061D539EBB809
No differences were encountered in the control files