About

• Perl 6

• Getopt

• refactor

Code

use Getopt::Kinoko::Parser;

use Getopt::Kinoko::Option;

use Getopt::Kinoko::OptionSet;

use Getopt::Kinoko::Exception;

class Getopt does Associative {

has OptionSet   %!optionsets handles ;

has Option      $!current;

has Bool        $!generate-method;

has Bool        $!gnu-style;

has             @!args;
method new(:$generate-method,:$gnu-style) {
    self.bless(:generate-method(?$generate-method),:gnu-style(?$gnu-style));
}

submethod BUILD(:$!generate-method,:$!gnu-style) { }

#=[
    push { optionset-name => optionset }s
]
multi method push(*%optionset-list) {
    %!optionsets.push: %optionset-list;
}

multi method push(Str $name,OptionSet $optset) {
    %!optionsets.push: $name => $optset;
}

multi method push(Str $name,Str $optset-string,&callback = Block) {
    %!optionsets.push: $name => OptionSet.new($optset-string,&callback);
}

method parse(@!args = @*ARGS,Str $method-prefix = "",:&parser = &kinoko-parser) returns Array {
    my @noa;

    for %!optionsets -> $current {
        try {
            @noa := $!gnu-style ??
                &parser(@!args,$current,True) !! &parser(@!args,$current);

            $!current := $current;

            $!current.check-force-value();

            $!current.generate-method($method-prefix) if $!generate-method;

            last;

            CATCH {
                when X::Kinoko::Fail {
                    ;
                }
                default {
                    note .message;
                    ...
                }
            }
        }
    }

    @noa;
}

multi method usage(Str $name) {
    return "" unless %!optionsets{$name}:exists;
    return "Usage:\n" ~ $*PROGRAM-NAME ~ %!optionsets{$name}.usage();
}

multi method usage() {
    my Str $usage = "Usage:\n";

    for %!optionsets.values {
        $usage ~= $*PROGRAM-NAME ~ .usage ~ "\n";
    }
    $usage.chomp;
}
}
sub getopt(OptionSet \opset,@args = @*ARGS,:&parser = &kinoko-parser,:$gnu-style,:$generate-method) is export returns Array {

my @noa;
@noa := $gnu-style ?? &parser(@args,opset,True) !! &parser(@args,opset);

opset.check-force-value();

opset.generate-method($method-prefix) if $generate-method;

@noa;
}

class X::Kinoko is Exception {

has $.msg handles ;

method message() {
    $!msg;
}
}
| throw this exception when parse Failed
class X::Kinoko::Fail is Exception { }

Getopt::Kinoko::Option

use Getopt::Kinoko::Exception;

role Option {

has $!sn;       #= option long name

has $!ln;       #= option short name

has &!cb;       #= option callback signature(Option -->)

has $!force;    #= option optional
#=[
    public initialize function
]
method !initialize(:$sn,:$ln,:$force,:&cb) {
    unless $sn.defined || $ln.defined {
        X::Kinoko.new(msg => 'Need option name.').throw();
    }

    my %build;

    %build<sn>      = $sn       if $sn;
    %build<ln>      = $ln       if $ln;
    %build<cb>      = &amp;cb       if &amp;cb;
    %build<force>   = ?$force;

    return self.bless(|%build);
}

submethod BUILD(:$!sn,:$!ln,:&amp;!cb,:$!force) { }

method is-short {
    $!sn.defined;
}

method is-long {
    $!ln.defined;
}

method is-force {
    ?$!force;
}

method is-integer() {
    False;
}

method is-string() {
    False;
}

method is-boolean() {
    False;
}

method is-array() {
    False;
}

method is-hash() {
    False;
}

method has-callback {
    &amp;!cb.defined;
}

method short-name {
    self.is-short ?? $!sn !! "";
}

method long-name {
    self.is-long ?? $!ln !! "";
}

method callback {
    &amp;!cb;
}

method set-callback(&amp;cb) {
    &amp;!cb = &amp;cb;
}

method match-name(Str $name,:$long,:$short) {
    my ($lb,$sb) = ($name eq self.long-name,$name eq self.short-name);

    return ($lb || $sb) if ($long &amp;&amp; $short || !$long &amp;&amp; !$short);

    return $lb if $long;

    return $sb if $short;
}

method usage {
    my $usage = "";

    $usage ~= '-'  ~ self.short-name if self.is-short;
    $usage ~= '|'  if self.is-long &amp;&amp; self.is-short;
    $usage ~= '--' ~ self.long-name  if self.is-long;
    $usage ~= '=<' ~ self.major-type ~ '>' if self.major-type ne "boolean";

    $usage;
}

method perl {
    my $perl = self.^name ~ '.new(';

    $perl ~= "sn => " ~ (self.is-short ?? $!sn !! "Any");
    $perl ~= ',';
    $perl ~= "ln => " ~ (self.is-long  ?? $!ln !! "Any");
    $perl ~= ',';
    $perl ~= "cb => " ~ (self.has-callback ?? &amp;!cb.perl !! "Any");
    $perl ~= ',';
    $perl ~= "force => " ~ $!force.perl;
    $perl ~= ',';
    $perl ~= "value => " ~ (self.has-value ?? self.value.perl !! 'Any');
    $perl ~= ')';

    $perl;
}

method has-value { ... }

method set-value($value) { ... }

method value { ... }

method major-type { ... }
}
=[
inetger option
]

class Option::Integer does Option {

has Int $!value;
method new(:$sn,:&amp;cb,:$value) {
    self!initialize(:$sn,:&amp;cb)!initialize-value($value);
}

method !initialize-value($value,:$use-default = True) {
    my $name = self.is-long ?? '--' ~ self.long-name !! '-' ~ self.short-name;
    my Int $int;

    if $value.defined {
        if $value !~~ Int {
            try {
                $int = $value.Int; # or use subset ?
                CATCH {
                    default {
                        X::Kinoko.new(msg => "$value: Option $name need integer.").throw();
                    }
                }
            }
        }
    }
    elsif $use-default {
        $int = self!default-value;
    }
    else {
        X::Kinoko.new(msg => ": Option $name need a value.").throw();
    }
    $!value = $int;
    self;
}

method !default-value {
    Int
}

method has-value {
    $!value.defined;
}

method set-value($value) {
    self!initialize-value($value,:!use-default);
}

method value {
    $!value;
}

method major-type {
    "integer";
}

method is-integer() {
    True;
}
}
class Option::String does Option {

has Str $!value;
method new(:$sn,:$use-default = True) {
    my $name = self.is-long ?? '--' ~ self.long-name !! '-' ~ self.short-name;
    my Str $string;

    if $value.defined {
        if $value !~~ Str {
            try {
                $string = $value.Str;
                CATCH {
                    default {
                        X::Kinoko.new(msg => "$value: Option $name need string.").throw();
                    }
                }
            }
        }
        else {
            $string = $value;
        }
    }
    elsif $use-default {
        $string = self!default-value;
    }
    else {
        X::Kinoko.new(msg => ": Option $name need a value.").throw();
    }
    $!value = $string;
    self;
}

method !default-value {
    Str
}

method has-value {
    $!value.defined;
}

method set-value($value) {
    self!initialize-value($value,:!use-default);
}

method value {
    $!value;
}

method major-type {
    "string";
}

method is-string() {
    True;
}
}
class Option::Array does Option {

has @!value;
method new(:$sn,:$use-default = True) {
    my $name = self.is-long ?? '--' ~ self.long-name !! '-' ~ self.short-name;
    my @array;

    if $value.defined {
        if $value !~~ Array {
            try {
                @array = $value.Array;
                CATCH {
                    default {
                        X::Kinoko.new(msg => "$value: Option $name need array.").throw();
                    }
                }
            }
        }
        else {
            @array = @$value;
        }
    }
    elsif $use-default {
        @array = self!default-value;
    }
    else {
        X::Kinoko.new(msg => ": Option $name need a value.").throw();
    }
    @!value.append: @array;
    self;
}

method !default-value {
    @[]
}

method has-value {
    @!value.elems > 0;
}

method set-value($value) {
    self!initialize-value($value,:!use-default);
}

method value {
    @!value;
}

method major-type {
    "array";
}

method is-array() {
    True;
}
}
class Option::Hash does Option {

has %!value;
method new(:$sn,:$use-default = True) {
    my $name = self.is-long ?? '--' ~ self.long-name !! '-' ~ self.short-name;
    my %hash;

    if $value.defined {
        if $value !~~ Hash {
            try {
                %hash = $value.Hash;
                CATCH {
                    default {
                        X::Kinoko.new(msg => "$value: Option $name need hash.").throw();
                    }
                }
            }
        }
        else {
            %hash = %$value;
        }
    }
    elsif $use-default {
        %hash = self!default-value;
    }
    else {
        X::Kinoko.new(msg => ": Option $name need a value.").throw();
    }
    %!value.append: %hash;
    self;
}

method !default-value {
    %{};
}

method has-value {
    %!value.defined;
}

method set-value($value) {
    self!initialize-value($value,:!use-default);
}

method value {
    %!value;
}

method major-type {
    "hash";
}

method is-hash() {
    True;
}
}
=[
boolean option
]

class Option::Boolean does Option {

has Bool $!value;
method new(:$sn,:$use-default = True) {
    my $name = self.is-long ?? '--' ~ self.long-name !! '-' ~ self.short-name;
    my Bool $bool;

    if $value.defined {
        if $value !~~ Hash {
            try {
                $bool = $value.Bool;
                CATCH {
                    default {
                        X::Kinoko.new(msg => "$value: Option $name need boolean.").throw();
                    }
                }
            }
        }
        else {
            $bool = $value;
        }
    }
    elsif $use-default {
        $bool = self!default-value;
    }
    else {
        X::Kinoko.new(msg => ": Option $name need a value.").throw();
    }
    $!value = $bool;
    self;
}

method !default-value {
    Bool
}

method has-value {
    $!value.defined;
}

method set-value($value) {
    self!initialize-value($value,:!use-default);
}

method value {
    $!value;
}

method major-type {
    "boolean";
}

method is-boolean() {
    True;
}
}
=[
return a class type according to $major-type
]

multi sub option-class-factory(Str $major-type) {

X::Kinoko.new(msg => "type " ~ $major-type ~ " not recognize").throw();

}
multi sub option-class-factory('i') {

Option::Integer

}
multi sub option-class-factory('a') {

Option::Array

}
multi sub option-class-factory('s') {

Option::String

}
multi sub option-class-factory('b') {

Option::Boolean

}
multi sub option-class-factory('h') {

Option::Hash

}
=[
[short-name] [|] [long-name] = major-type [!];
you must specify at least one of [*-name]
if you specify one name,you can moit [|],then [*-name] will determine by [*-name].length
major-type=[
    s,string,i,integer,b,boolean,h,hash,a,array,]
[!] means a force option
sample:
    "u|username=s!",same as "u|username=string!"
    "p|port=i",same as "p|port=integer"
    "port|p=i",same as above option,[*-name] determine by [*-name].length
    "password=s!",password will be determine as [long-name]
    "p=s!",p(password) will be determine as [short-name]
]

multi sub create-option(Str:D $option,:$value,:&cb) is export {

my Str $ln;

my Str $sn;

my Str $mt;

my $r = False;
my regex type { [s|i|h|a|b] };
my regex name { <-[\|\=\s]>* };
my regex force { [\!]? }

my regex option {
    [
        <.ws> $<ln> = (<name>) <.ws> \| <.ws> $<rn> = (<name>) <.ws>
        ||
        <.ws> $<name> = (<name>) <.ws>
    ]
    \= <.ws>
    $<mt> = (<type>) <.ws>
    $<r> = (<force>) <.ws>
    {
        if $<name>.defined {
            if ~$<name>.chars > 1 {
                $ln = ~$<name>;
            }
            else {
                $sn = ~$<name>;
            }
        }
        elsif $<ln>.defined &amp;&amp; $<rn>.defined {
            if ~$<ln>.chars > ~$<rn>.chars {
                $ln = ~$<ln> if ~$<ln>.chars > 0;
                $sn = ~$<rn> if ~$<rn>.chars > 0;
            }
            else {
                $ln = ~$<rn> if ~$<rn>.chars > 0;
                $sn = ~$<ln> if ~$<ln>.chars > 0;
            }
        }
        $mt = ~$<mt>;
        $r  = True if $<r>.defined &amp;&amp; ~$<r> eq '!';
    }
};

my &amp;process = -> $opt-str is copy {
    my %l2s := {
        string  => 's',integer => 'i',hash    => 'h',boolean => 'b',array   => 'a',};

    $opt-str ~~ s/\=(string|integer|hash|boolean|array)/{%l2s{$0}}/;
    $opt-str;
};

my $opt-str = &amp;process($option);

if $opt-str ~~ /<option>/ {
    return option-class-factory($mt).new(:$ln,:$sn,:force($r),:&amp;cb);
}

X::Kinoko.new(msg => "$option: not a valid option string.").throw();
}
=[
*%option
:$ln,:$cb,:$mt,]
multi sub create-option(*%option) is export {

return option-class-factory(%option).new(|%option);

}
multi sub create-option(%option) is export {

return option-class-factory(%option).new(|%option);

}

Getopt::Kinoko::OptionSet

use Getopt::Kinoko::Option;

use Getopt::Kinoko::Exception;

class OptionSet does Positional {

has Option @!options handles ;

has        &!callback;
method new(Str $optionset-str,&noa-callback?) {
    self.bless(callback => &noa-callback).append($optionset-str);
}

submethod BUILD(:@!options,:&!callback) { }

method has(Str $name,:$short) {
    for @!options -> $opt {
        return True if $opt.match-name($name,:$short);
    }
    False
}

method get(Str $name,:$short) {
    for @!options -> $opt {
        return $opt if $opt.match-name($name,:$short);
    }
    Option;
}

method set(Str $name,$value,:&callback,:$short) {
    for @!options -> $opt {
        if $opt.match-name($name,:$short) {
            $opt.set-value($value);
            $opt.set-callback(&callback) if ?&callback;
            last;
        }
    }
}

#| can modify value
method AT-POS(::?CLASS::D: $index) is rw {
    my $option := @!options[$index];

    Proxy.new(
        FETCH => method () { $option; },STORE => method ($value) {
            $option.set-value($value);
        }
    );
}

#| can modify value
method AT-KEY(::?CLASS::D: $name) is rw {
    my $option = Option;

    for @!options -> $opt {
        if $opt.match-name($name) {
            $option := $opt;
            last;
        }
    }

    Proxy.new(
        FETCH => method () { $option; },STORE => method ($value) {
            $option.set-value($value);
        }
    );
}

method EXISTS-KEY($name) {
    return self.has($name);
}

method is-set-noa() {
    &!callback.defined;
}

method process-noa() {
    &!callback;
}

method Numeric() {
    return +@!options;
}

method check-force-value() {
    for @!options -> $opt {
        if $opt.is-force && !$opt.has-value {
            X::Kinoko.new(msg => ($opt.is-short ?? $opt.short-name !! $opt.long-name) ~
                ": Option value is <a href="/tag/required/" target="_blank" class="keywords">required</a>.").throw();
        }
    }
}

method generate-method(Str $prefix = "") {
    for @!options -> $opt {
        if $opt.is-long {
            self.^add_method($prefix ~ $opt.long-name,my method { $opt; });
            self.^compose();
        }
        if $opt.is-short {
            self.^add_method($prefix ~ $opt.short-name,my method { $opt; });
            self.^compose();
        }
    }
    self;
}

#=[ option-string;option-string;... ]
method append(Str $optionset-str) {
    @!options.push(create-option($_)) for $optionset-str.split(';');
    self;
}

multi method push(*%option) {
    @!options.push: create-option(|%option);
    self;
}

multi method push(Str $option,&amp;callback,$value) {
    @!options.push: create-option($option,cb => &amp;callback,:$value);
    self;
}

#=[
    how to convenient forward parameters ?
]
method push-str(Str :$short,Str :$long,Bool :$force,Str :$value) {
    self.add-option(sn => $short,ln => $long,:mt<s>);
}

method push-int(Str :$short,Int :$value) {
    self.add-option(sn => $short,:mt<i>);
}

method push-arr(Str :$short,:$value) {
    self.add-option(sn => $short,:mt<a>);
}

method push-hash(Str :$short,:mt<h>);
}

method push-bool(Str :$short,Bool :$value) {
    self.add-option(sn => $short,:mt<b>);
}

method usage() {
    my Str $usage;

    for @!options -> $opt {
        $usage ~= ' [';
        $usage ~= $opt.usage;
        $usage ~= '] ';
    }

    $usage;
}
}

Getopt::Kinoko::Parser

use Getopt::Kinoko::OptionSet;

use Getopt::Kinoko::Exception;

multi sub kinoko-parser(@args is copy,OptionSet \optset) is export returns Array {

my @noa;

my $opt;

my Str $optname;

my $last-is-boolean = False;
my regex lprefix { '--' }
my regex sprefix { '-'  }
my regex optname { .*   { $optname = ~$/; } }

while +@args > 0 {
    my \arg = @args.shift;

    given arg {
        when /^ [<lprefix> || <sprefix>] <.&amp;optname> / {
            if optset.has($optname,long => $<lprefix>.defined,short => $<sprefix>.defined) {
                $opt := optset.get($optname,short => $<sprefix>.defined);
            }
            else {
                X::Kinoko::Fail.new().throw;
            }
        }
        default {
            if optset.is-set-noa {
                optset.process-noa(arg);
            }
            else {
                @noa.push: arg;
            }
        }
    }

    if +@args > 0 || $opt.is-boolean {
        $last-is-boolean = $opt.is-boolean;
        $opt.set-value($opt.is-boolean ?? True !! @args.shift);
    }
    else {
        X::Kinoko.new(msg => $optname ~ ": Need a value.").throw;
    }
}
@noa;
}
multi sub kinoko-parser(@args is copy,OptionSet \optset,$gnu-style) is export returns Array {

my @noa;

my $opt;

my $optname;

my $optvalue;

my $last-is-boolean = True;
my regex lprefix    { '--' }
my regex sprefix    { '-'  }
my regex optname    { <-[\=]>* { $optname = ~$/; } }
my regex optvalue   { .*   }

while +@args > 0 {
    my \arg = @args.shift;

    given arg {
        when /^ [<lprefix> || <sprefix>]  <.&amp;optname> \= <optvalue> / {
            if optset.has($optname,short => $<sprefix>.defined);
                X::Kinoko.new(msg => $optname ~ ": Need a value.").throw if !$<optvalue>.defined &amp;&amp; !$opt.is-boolean;
                $last-is-boolean = $opt.is-boolean;
                $opt.set-value($opt.is-boolean ?? True !! $<optvalue>);
            }
            elsif $<sprefix>.defined {
                @args.unshift: | ( '-' X~ $optname.split("",:skip-empty) );
            }
            else {
                X::Kinoko::Fail.new().throw;
            }
        }
        when /^ [<lprefix> || <sprefix>] <.&amp;optname> / {
            if optset.has($optname,short => $<sprefix>.defined);
                $last-is-boolean = $opt.is-boolean;
                if +@args > 0 || $opt.is-boolean {
                    $opt.set-value($opt.is-boolean ?? True !! @args.shift);
                }
                else {
                    X::Kinoko.new(msg => $optname ~ ": Need a value.").throw;
                }
            }
            else {
                X::Kinoko::Fail.new().throw;
            }
        }
        default {
            W::Kinoko.new("Argument behind boolean option.").warn if $last-is-boolean;

            if optset.is-set-noa {
                optset.process-noa(arg);
            }
            else {
                @noa.push: arg;
            }
        }
    }
}
@noa;
}