lib/Getopt/Dakkar/Role/Command.pm


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111

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 
 
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) {
    $stash = $self->_parse($args,$stash);
    if (my $op = $self->op) {
        return $stash->$op();
    }
    return $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 $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_value = $option->parse($args,$stash);
                $argpack->options->{$option_value->name} = $option_value;
            }
            else {
                Getopt::Dakkar::X::BadOption->throw({
                    input => $this,
                });
            }
        }
        elsif (my $subcommand = $self->_match_subcommand($this)) {
            shift $args->@*;
            $subcommand->parse($args,$stash);
        }
        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);
                $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,
                });
            }
        }
        else {
            my $next_parameter = shift @parameters
                or last;
            my $argument = $next_parameter->parse($args,$stash);
            $argpack->arguments->{$argument->name} = $argument;
        }
    }
    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{--} }
sub _looks_like_option($self,$arg) { return $arg =~ /^-/ }
sub _match_option($self,$arg) {
    for my $option ($self->options->@*) {
        return $option if $option->match($arg);
    }
    return undef;
}
sub _match_subcommand($self,$arg) {
    for my $subcommand ($self->subcommands->@*) {
        return $subcommand if $subcommand->match($arg);
    }
    return undef;
}
 
sub match($self,$arg) {
    return !! grep { $_ eq $arg } $self->matching_strings->@*;
}