1# ============================================================================
2package MooseX::App::Meta::Role::Class::Base;
3# ============================================================================
4
5use utf8;
6use 5.010;
7
8use List::Util qw(max);
9
10use namespace::autoclean;
11use Moose::Role;
12
13use MooseX::App::Utils;
14use Module::Pluggable::Object;
15use File::Basename qw();
16no if $] >= 5.018000, warnings => qw(experimental::smartmatch);
17
18has 'app_messageclass' => (
19    is          => 'rw',
20    isa         => 'ClassName',
21    lazy        => 1,
22    builder     => '_build_app_messageclass',
23);
24
25has 'app_namespace' => (
26    is          => 'rw',
27    isa         => 'MooseX::App::Types::List',
28    coerce      => 1,
29    lazy        => 1,
30    builder     => '_build_app_namespace',
31);
32
33has 'app_exclude' => (
34    is          => 'rw',
35    isa         => 'MooseX::App::Types::List',
36    coerce      => 1,
37    default     => sub { [] },
38);
39
40has 'app_base' => (
41    is          => 'rw',
42    isa         => 'Str',
43    lazy        => 1,
44    default     => sub {
45        return File::Basename::basename($0);
46    },
47);
48
49has 'app_strict' => (
50    is          => 'rw',
51    isa         => 'Bool',
52    default     => sub {0},
53);
54
55has 'app_fuzzy' => (
56    is          => 'rw',
57    isa         => 'Bool',
58    default     => sub {1},
59);
60
61has 'app_command_name' => (
62    is          => 'rw',
63    isa         => 'CodeRef',
64    default     => sub { \&MooseX::App::Utils::class_to_command },
65);
66
67has 'app_prefer_commandline' => (
68    is          => 'rw',
69    isa         => 'Bool',
70    default     => sub {0},
71);
72
73has 'app_permute' => (
74    is          => 'rw',
75    isa         => 'Bool',
76    default     => sub {0},
77);
78
79has 'app_commands' => (
80    is          => 'rw',
81    isa         => 'HashRef[Str]',
82    traits      => ['Hash'],
83    handles     => {
84        command_register    => 'set',
85        command_get         => 'get',
86        command_classes     => 'values',
87        command_list        => 'shallow_clone',
88    },
89    lazy        => 1,
90    builder     => '_build_app_commands',
91);
92
93sub _build_app_messageclass {
94    my ($self) = @_;
95    return 'MooseX::App::Message::Block'
96}
97
98sub _build_app_namespace {
99    my ($self) = @_;
100    return [ $self->name ];
101}
102
103sub _build_app_commands {
104    my ($self) = @_;
105
106    my (@list);
107    # Process namespace list
108    foreach my $namespace ( @{ $self->app_namespace } ) {
109        push(@list,$self->command_scan_namespace($namespace));
110    }
111    my $commands = { @list };
112
113    # Process excludes
114    foreach my $exclude ( @{ $self->app_exclude } ) {
115        foreach my $command (keys %{$commands}) {
116            delete $commands->{$command}
117                if $commands->{$command} =~ m/^\Q$exclude\E(::|$)/;
118        }
119    }
120
121    return $commands;
122}
123
124sub command_check {
125    my ($self) = @_;
126
127    foreach my $attribute ($self->command_usage_attributes($self,'all')) {
128        $attribute->cmd_check();
129    }
130    return;
131}
132
133sub command_scan_namespace {
134    my ($self,$namespace) = @_;
135
136    # Find all packages in namespace
137    my $mpo = Module::Pluggable::Object->new(
138        search_path => [ $namespace ],
139    );
140
141    my $commandsub = $self->app_command_name;
142
143    my %return;
144    # Loop all packages
145    foreach my $command_class ($mpo->plugins) {
146        my $command_class_name =  substr($command_class,length($namespace)+2);
147
148        # subcommands support
149        $command_class_name =~ s/::/ /g;
150
151        # Extract command name
152        $command_class_name =~ s/^\Q$namespace\E:://;
153        $command_class_name =~ s/^.+::([^:]+)$/$1/;
154        my $command = $commandsub->($command_class_name,$command_class);
155
156        # Check if command was loaded
157        $return{$command} = $command_class
158            if defined $command;
159    }
160
161    return %return;
162}
163
164sub command_args {
165    my ($self,$metaclass) = @_;
166
167    $metaclass ||= $self;
168    my $parsed_argv = MooseX::App::ParsedArgv->instance;
169
170    unless ($metaclass->does_role('MooseX::App::Role::Common')) {
171        Moose->throw_error('Class '.$metaclass->name.' is not a proper MooseX::App::Command class. You either need to use MooseX::App::Command or exclude this class via app_exclude')
172    }
173
174    # Process options
175    my @attributes_option = $self->command_usage_attributes($metaclass,'option');
176
177    my ($return,$errors) = $self->command_parse_options(\@attributes_option);
178
179    my %raw_error;
180    # Loop all left over options
181    foreach my $option ($parsed_argv->available('option')) {
182        my $key = $option->key;
183        my $raw = $option->original;
184        my $message;
185        next
186            if defined $raw_error{$raw};
187
188        # Get possible options with double dash - might be missing
189        if (length $key == 1
190            && $raw =~ m/^-(\w+)$/) {
191            POSSIBLE_ATTRIBUTES:
192            foreach my $attribute ($self->command_usage_attributes($metaclass,[qw(option proto)])) {
193                foreach my $name ($attribute->cmd_name_possible) {
194                    # TODO fuzzy match
195                    if ($name eq $1) {
196                        $raw_error{$raw} = 1;
197                        $message = "Did you mean '--$name'?";
198                        last POSSIBLE_ATTRIBUTES;
199                    }
200                }
201            }
202        }
203
204        # Handle error messages
205        my $error;
206        if (defined $message) {
207            $error = $self->command_message(
208                header          => "Unknown option '".$raw."'", # LOCALIZE
209                body            => $message,
210                type            => "error",
211            );
212        } else {
213            $error = $self->command_message(
214                header          => "Unknown option '".$option->key."'", # LOCALIZE
215                type            => "error",
216            );
217        }
218        unshift(@{$errors},$error);
219    }
220
221    # Process positional parameters
222    my @attributes_parameter  = $self->command_usage_attributes($metaclass,'parameter');
223
224    foreach my $attribute (@attributes_parameter) {
225        my $element = $parsed_argv->consume('parameter');
226        last
227            unless defined $element;
228
229        my ($parameter_value,$parameter_errors) = $self->command_process_attribute($attribute, [ $element->key ] );
230        push(@{$errors},@{$parameter_errors});
231        $return->{$attribute->name} = $parameter_value;
232    }
233
234    # Handle all unconsumed parameters and options
235    if ($self->app_strict || $metaclass->command_strict) {
236        foreach my $parameter ($parsed_argv->available('parameter')) {
237            unshift(@{$errors},
238                $self->command_message(
239                    header          => "Unknown parameter '".$parameter->key."'", # LOCALIZE
240                    type            => "error",
241                )
242            );
243        }
244    }
245
246    # Handle ENV
247    foreach my $attribute ($self->command_usage_attributes($metaclass,'all')) {
248        next
249            unless $attribute->can('has_cmd_env')
250            && $attribute->has_cmd_env;
251
252        my $cmd_env = $attribute->cmd_env;
253
254        if (exists $ENV{$cmd_env}
255            && ! defined $return->{$attribute->name}) {
256
257            my $value = $ENV{$cmd_env};
258
259            if ($attribute->has_type_constraint) {
260                my $type_constraint = $attribute->type_constraint;
261                if ($attribute->should_coerce
262                    && $type_constraint->has_coercion) {
263                    my $coercion = $type_constraint->coercion;
264                    $value = $coercion->coerce($value) // $value;
265                }
266            }
267
268            $return->{$attribute->name} = $value;
269            my $error = $attribute->cmd_type_constraint_check($value);
270            if ($error) {
271                push(@{$errors},
272                    $self->command_message(
273                        header          => "Invalid environment value for '".$cmd_env."'", # LOCALIZE
274                        type            => "error",
275                        body            => $error,
276                    )
277                );
278            }
279        }
280    }
281
282    return ($return,$errors);
283}
284
285sub command_proto {
286    my ($self,$metaclass) = @_;
287
288    $metaclass   ||= $self;
289
290    my @attributes;
291    foreach my $attribute ($self->command_usage_attributes($metaclass,'proto')) {
292        next
293            unless $attribute->does('MooseX::App::Meta::Role::Attribute::Option')
294            && $attribute->has_cmd_type;
295        push(@attributes,$attribute);
296    }
297
298    return $self->command_parse_options(\@attributes);
299}
300
301sub command_parse_options {
302    my ($self,$attributes) = @_;
303
304    # Build attribute lookup hash
305    my %option_to_attribute;
306    foreach my $attribute (@{$attributes}) {
307        foreach my $name ($attribute->cmd_name_possible) {
308            if (defined $option_to_attribute{$name}
309                && $option_to_attribute{$name} != $attribute) {
310                Moose->throw_error('Command line option conflict: '.$name);
311            }
312            $option_to_attribute{$name} = $attribute;
313        }
314    }
315
316    my $match = {};
317    my $return = {};
318    my @errors;
319
320    # Get ARGV
321    my $parsed_argv = MooseX::App::ParsedArgv->instance;
322
323    # Loop all exact matches
324    foreach my $option ($parsed_argv->available('option')) {
325        if (my $attribute = $option_to_attribute{$option->key}) {
326            $option->consume($attribute);
327            $match->{$attribute->name} = [ $option ];
328        }
329    }
330
331    # Process fuzzy matches
332    if ($self->app_fuzzy) {
333        # Loop all options (sorted by length)
334        foreach my $option (sort { length($b->key) <=> length($a->key) } $parsed_argv->available('option')) {
335
336            # No fuzzy matching for one-letter flags
337            my $option_length = length($option->key);
338            next
339                if $option_length == 1;
340
341            my ($match_attributes) = [];
342
343            # Try to match attributes
344            foreach my $name (keys %option_to_attribute) {
345                next
346                    if ($option_length >= length($name));
347
348                my $name_short = lc(substr($name,0,$option_length));
349
350                # Partial match
351                if (lc($option->key) eq $name_short) {
352                    my $attribute = $option_to_attribute{$name};
353                    unless (grep { $attribute == $_ } @{$match_attributes}) {
354                        push(@{$match_attributes},$attribute);
355                    }
356                }
357            }
358
359            # Process matches
360            given (scalar @{$match_attributes}) {
361                # No match
362                when(0) {}
363                # One match
364                when(1) {
365                    my $attribute = $match_attributes->[0];
366                    $option->consume();
367                    $match->{$attribute->name} ||= [];
368                    push(@{$match->{$attribute->name}},$option);
369                }
370                # Multiple matches
371                default {
372                    $option->consume();
373                    push(@errors,
374                        $self->command_message(
375                            header          => "Ambiguous option '".$option->key."'", # LOCALIZE
376                            type            => "error",
377                            body            => "Could be\n".MooseX::App::Utils::format_list( # LOCALIZE
378                                map { [ $_ ] }
379                                sort
380                                map { $_->cmd_name_primary }
381                                @{$match_attributes}
382                            ),
383                        )
384                    );
385                }
386            }
387        }
388    }
389
390    # Check all attributes
391    foreach my $attribute (@{$attributes}) {
392
393        next
394            unless exists $match->{$attribute->name};
395
396        my @mapped_values;
397        foreach my $element (@{$match->{$attribute->name}}) {
398            push(@mapped_values,$element->all_values);
399        }
400
401        my $values = [
402            map { $_->value }
403            sort { $a->position <=> $b->position }
404            @mapped_values
405        ];
406
407        #warn Data::Dumper::Dumper($raw);
408        my ($value,$errors) = $self->command_process_attribute( $attribute, $values );
409        push(@errors,@{$errors});
410
411        $return->{$attribute->name} = $value;
412    }
413
414    return ($return,\@errors);
415}
416
417sub command_process_attribute {
418    my ($self,$attribute,$raw) = @_;
419
420    $raw = [ $raw ]
421        unless ref($raw) eq 'ARRAY';
422
423    my @errors;
424    my $value;
425
426    # Attribute with split
427    if ($attribute->has_cmd_split) {
428        my @raw_unfolded;
429        foreach (@{$raw}) {
430            push(@raw_unfolded,split($attribute->cmd_split,$_));
431        }
432        $raw = \@raw_unfolded;
433    }
434
435    # Attribute with counter - transform value count into value
436    if ($attribute->cmd_count) {
437        $value = $raw = [ scalar(@$raw) ];
438    }
439
440    # Attribute with type constraint
441    if ($attribute->has_type_constraint) {
442        my $type_constraint = $attribute->type_constraint;
443
444        if ($type_constraint->is_a_type_of('ArrayRef')) {
445            $value = $raw;
446        } elsif ($type_constraint->is_a_type_of('HashRef')) {
447            $value = {};
448            foreach my $element (@{$raw}) {
449                if ($element =~ m/^([^=]+)=(.+?)$/) {
450                    $value->{$1} ||= $2;
451                } else {
452                    push(@errors,
453                        $self->command_message(
454                            header          => "Invalid value for '".$attribute->cmd_name_primary."'", # LOCALIZE
455                            type            => "error",
456                            body            => "Value must be supplied as 'key=value' (not '$element')", # LOCALIZE
457                        )
458                    );
459                }
460            }
461        } elsif ($type_constraint->is_a_type_of('Bool')) {
462            $value = $raw->[-1];
463
464#            if ($self->has_default
465#                && ! $self->is_default_a_coderef
466#                && $self->default == 1) {
467
468        } else {
469            $value = $raw->[-1];
470        }
471
472        unless(defined $value) {
473            push(@errors,
474                $self->command_message(
475                    header          => "Missing value for '".$attribute->cmd_name_primary."'", # LOCALIZE
476                    type            => "error",
477                )
478            );
479        } else {
480            if ($attribute->should_coerce
481                && $type_constraint->has_coercion) {
482                my $coercion = $type_constraint->coercion;
483                $value = $coercion->coerce($value) // $value;
484            }
485            my $error = $attribute->cmd_type_constraint_check($value);
486            if (defined $error) {
487                push(@errors,
488                    $self->command_message(
489                        header          => "Invalid value for '".$attribute->cmd_name_primary."'", # LOCALIZE
490                        type            => "error",
491                        body            => $error,
492                    )
493                );
494            }
495        }
496
497    } else {
498         $value = $raw->[-1];
499    }
500
501    return ($value,\@errors);
502}
503
504sub command_candidates {
505    my ($self,$command) = @_;
506
507    my $lc_command = lc($command);
508    my $commands = $self->app_commands;
509
510    my @candidates;
511    my $candidate_length = length($command);
512
513    # Compare all commands to find matching candidates
514    foreach my $command_name (keys %$commands) {
515        if ($command_name eq $lc_command) {
516            return $command_name;
517        } elsif ($lc_command eq substr($command_name,0,$candidate_length)) {
518            push(@candidates,$command_name);
519        }
520    }
521
522    return [ sort @candidates ];
523}
524
525sub command_find {
526    my ($self,$commands) = @_;
527
528    my $parsed_argv     = MooseX::App::ParsedArgv->instance;
529    my $all_commands    = $self->app_commands;
530
531    # Get parts
532    my (@parts,@command_parts);
533    if (defined $commands) {
534        if (ref($commands) eq 'ARRAY') {
535            @parts = map { lc } @{$commands};
536        } else {
537            @parts = ( lc($commands) );
538        }
539    } else {
540        @parts = $parsed_argv->elements_argv;
541    }
542
543    # Extract possible parts
544    foreach my $part (@parts) {
545        # Anyting staring with a dash cannot be a command
546        last
547            if $part =~ m/^-/;
548        push(@command_parts,lc($part));
549    }
550
551    # Shortcut
552    return
553        unless scalar @command_parts;
554
555    # basically do a longest-match search
556    for my $index (reverse(0..$#command_parts)) {
557        my $command = join ' ', @command_parts[0..$index];
558        if( $all_commands->{$command} ) {
559            $parsed_argv->shift_argv for 0..$index;
560            return $command;
561        }
562    }
563
564    # didn't find an exact match, let's go to plan B
565    foreach my $index (reverse(0..$#command_parts)) {
566        my $command     = join ' ', @command_parts[0..$index];
567        my $candidate   = $self->command_candidates($command);
568        if (ref $candidate eq '') {
569            $parsed_argv->shift_argv;
570            return $candidate;
571        }
572        given (scalar @{$candidate}) {
573            when (0) {
574                next;
575            }
576            when (1) {
577                if ($self->app_fuzzy) {
578                    $parsed_argv->shift_argv;
579                    return $candidate->[0];
580                } else {
581                    return $self->command_message(
582                        header          => "Unknown command '$command'", # LOCALIZE
583                        type            => "error",
584                        body            => "Did you mean '".$candidate->[0]."'?", # LOCALIZE
585                    );
586                }
587            }
588            default {
589                return $self->command_message(
590                    header          => "Ambiguous command '$command'", # LOCALIZE
591                    type            => "error",
592                    body            => "Which command did you mean?\n". # LOCALIZE
593                        MooseX::App::Utils::format_list(map { [ $_ ] } sort @{$candidate}),
594                );
595            }
596        }
597    }
598
599    my $command = $command_parts[0];
600    return $self->command_message(
601        header          => "Unknown command '$command'", # LOCALIZE
602        type            => "error",
603    );
604}
605
606sub command_parser_hints {
607    my ($self,$metaclass) = @_;
608
609    $metaclass ||= $self;
610
611    my %hints;
612    my %names;
613    my $return = { permute => [], novalue => [], fixedvalue => {} };
614    foreach my $attribute ($self->command_usage_attributes($metaclass,[qw(option proto)])) {
615        my $permute = 0;
616        my $bool = 0;
617        my $type_constraint = $attribute->type_constraint;
618        if ($type_constraint) {
619            $permute = 1
620                if $type_constraint->is_a_type_of('ArrayRef')
621                || $type_constraint->is_a_type_of('HashRef');
622
623            $bool = 1
624                if $type_constraint->is_a_type_of('Bool');
625        }
626
627        my $hint = {
628            name    => $attribute->name,
629            bool    => $bool,
630            novalue => $bool || $attribute->cmd_count,
631            permute => $permute,
632        };
633
634        foreach my $name ($attribute->cmd_name_list) {
635             $names{$name} = $hints{$name} = $hint;
636        }
637
638        # Negated values
639        if ($bool) {
640            $hint->{fixedvalue} = 1;
641            if ($attribute->has_cmd_negate) {
642                my $hint_neg = { %{$hint} }; # shallow copy
643                $hint_neg->{fixedvalue} = 0;
644                foreach my $name (@{$attribute->cmd_negate}) {
645                    $names{$name} = $hints{$name} = $hint_neg;
646                }
647            }
648        } elsif ($attribute->cmd_count) {
649            $hint->{fixedvalue} = 1;
650        }
651    }
652
653    if ($self->app_fuzzy) {
654        my $length = max(map { length($_) } keys %names) // 0;
655        foreach my $l (reverse(2..$length)) {
656            my %tmp;
657            foreach my $name (keys %names) {
658                next
659                    if length($name) < $l;
660                my $short_name = substr($name,0,$l);
661                next
662                    if defined $hints{$short_name};
663                $tmp{$short_name} ||= [];
664                next
665                    if defined $tmp{$short_name}->[0]
666                    && $tmp{$short_name}->[0]->{name} eq $names{$name}->{name};
667                push(@{$tmp{$short_name}},$names{$name})
668            }
669            foreach my $short_name (keys %tmp) {
670                next
671                    if scalar @{$tmp{$short_name}} > 1;
672                $hints{$short_name} = $tmp{$short_name}->[0];
673            }
674        }
675    }
676
677    foreach my $name (keys %hints) {
678        if ($hints{$name}->{novalue}) {
679            push(@{$return->{novalue}},$name);
680        }
681        if ($hints{$name}->{permute}) {
682            push(@{$return->{permute}},$name);
683        }
684        if (defined $hints{$name}->{fixedvalue}) {
685            $return->{fixedvalue}{$name} = $hints{$name}->{fixedvalue};
686        }
687    }
688
689
690        #warn Data::Dumper::Dumper($return);
691    return $return;
692}
693
694sub command_message {
695    my ($self,@args) = @_;
696    my $messageclass = $self->app_messageclass;
697    Class::Load::load_class($messageclass);
698    return $messageclass->new(@args);
699}
700
701sub command_check_attributes {
702    my ($self,$command_meta,$errors,$params) = @_;
703
704    $command_meta ||= $self;
705
706    # Check required values
707    foreach my $attribute ($self->command_usage_attributes($command_meta,[qw(option proto parameter)])) {
708        if ($attribute->is_required
709            && ! exists $params->{$attribute->name}
710            && ! $attribute->has_default) {
711            push(@{$errors},
712                $self->command_message(
713                    header          => "Required ".($attribute->cmd_type eq 'parameter' ? 'parameter':'option')." '".$attribute->cmd_name_primary."' missing", # LOCALIZE
714                    type            => "error",
715                )
716            );
717        }
718    }
719
720    return $errors;
721}
722
723sub command_usage_attributes {
724    my ($self,$metaclass,$types) = @_;
725
726    $metaclass ||= $self;
727    $types ||= [qw(option proto)];
728
729    unless ($metaclass->does_role('MooseX::App::Role::Common')) {
730        Moose->throw_error('Class '.$metaclass->name.' is not a proper MooseX::App::Command class. You either need to use MooseX::App::Command or exclude this class via app_exclude')
731    }
732
733    my @return;
734    foreach my $attribute ($metaclass->get_all_attributes) {
735        next
736            unless $attribute->does('MooseX::App::Meta::Role::Attribute::Option')
737            && $attribute->has_cmd_type;
738
739        next
740            unless $types eq 'all'
741            || $attribute->cmd_type ~~ $types;
742
743        push(@return,$attribute);
744    }
745
746    return (sort {
747        $a->cmd_position <=> $b->cmd_position ||
748        $a->cmd_usage_name cmp $b->cmd_usage_name
749    } @return);
750}
751
752sub command_usage_options {
753    my ($self,$metaclass,$headline) = @_;
754
755    $headline ||= 'options:'; # LOCALIZE
756    $metaclass ||= $self;
757
758    my @options;
759    foreach my $attribute ($self->command_usage_attributes($metaclass,[qw(option proto)])) {
760        push(@options,[
761            $attribute->cmd_usage_name(),
762            $attribute->cmd_usage_description()
763        ]);
764    }
765
766    return
767        unless scalar @options > 0;
768
769    return $self->command_message(
770        header  => $headline,
771        body    => MooseX::App::Utils::format_list(@options),
772    );
773}
774
775sub command_usage_parameters {
776    my ($self,$metaclass,$headline) = @_;
777
778    $headline ||= 'parameter:'; # LOCALIZE
779    $metaclass ||= $self;
780
781    my @parameters;
782    foreach my $attribute (
783        sort { $a->cmd_position <=> $b->cmd_position }
784             $self->command_usage_attributes($metaclass,'parameter')
785    ) {
786        push(@parameters,[
787            $attribute->cmd_usage_name(),
788            $attribute->cmd_usage_description()
789        ]);
790    }
791
792    return
793        unless scalar @parameters > 0;
794
795    return $self->command_message(
796        header  => $headline,
797        body    => MooseX::App::Utils::format_list(@parameters),
798    );
799}
800
801sub command_usage_header {
802    my ($self,$command_meta_class) = @_;
803
804    my $caller = $self->app_base;
805
806    my ($command_name,$usage);
807    if ($command_meta_class) {
808        $command_name = $self->command_class_to_command($command_meta_class->name);
809    } else {
810        $command_name = '<command>';
811    }
812
813    $command_meta_class ||= $self;
814    if ($command_meta_class->can('command_usage')
815        && $command_meta_class->command_usage_predicate) {
816        $usage = MooseX::App::Utils::format_text($command_meta_class->command_usage);
817    }
818
819    unless (defined $usage) {
820        # LOCALIZE
821        $usage = "$caller $command_name ";
822        my @parameter= $self->command_usage_attributes($command_meta_class,'parameter');
823        foreach my $attribute (@parameter) {
824            if ($attribute->is_required) {
825                $usage .= "<".$attribute->cmd_usage_name.'> ';
826            } else {
827                $usage .= '['.$attribute->cmd_usage_name.'] ';
828            }
829        }
830        $usage .= "[long options...]
831$caller help
832$caller $command_name --help";
833        $usage = MooseX::App::Utils::format_text($usage);
834    }
835
836    return $self->command_message(
837        header  => 'usage:', # LOCALIZE
838        body    => $usage,
839    );
840}
841
842sub command_usage_description {
843    my ($self,$command_meta_class) = @_;
844
845    $command_meta_class ||= $self;
846    if ($command_meta_class->can('command_long_description')
847        && $command_meta_class->command_long_description_predicate) {
848        return $self->command_message(
849            header  => 'description:', # LOCALIZE
850            body    => MooseX::App::Utils::format_text($command_meta_class->command_long_description),
851        );
852    } elsif ($command_meta_class->can('command_short_description')
853        && $command_meta_class->command_short_description_predicate) {
854        return $self->command_message(
855            header  => 'short description:', # LOCALIZE
856            body    => MooseX::App::Utils::format_text($command_meta_class->command_short_description),
857        );
858    }
859    return;
860}
861
862sub command_class_to_command {
863    my ($self,$command_class) = @_;
864
865    my $commands = $self->app_commands;
866    foreach my $element (keys %$commands) {
867        if ($command_class eq $commands->{$element}) {
868            return $element;
869        }
870    }
871
872    return;
873}
874
875sub command_subcommands {
876    my ($self,$command_meta_class) = @_;
877
878    $command_meta_class ||= $self;
879    my $command_class = $command_meta_class->name;
880    my $command_name = $self->command_class_to_command($command_class);
881
882    my $commands    = $self->app_commands;
883    my $subcommands = {};
884    foreach my $command (keys %{$commands}) {
885        next
886            if $command eq $command_name
887            || $command !~ m/^\Q$command_name\E\s(.+)/;
888        $subcommands->{$1} = $commands->{$command};
889    }
890
891    return $subcommands;
892}
893
894sub command_usage_command {
895    my ($self,$command_meta_class) = @_;
896
897    $command_meta_class ||= $self;
898
899    my @usage;
900    push(@usage,$self->command_usage_header($command_meta_class));
901    push(@usage,$self->command_usage_description($command_meta_class));
902    push(@usage,$self->command_usage_parameters($command_meta_class,'parameters:')); # LOCALIZE
903    push(@usage,$self->command_usage_options($command_meta_class,'options:')); # LOCALIZE
904    push(@usage,$self->command_usage_subcommands('available subcommands:',$self->command_subcommands($command_meta_class))); # LOCALIZE
905
906    return @usage;
907}
908
909sub command_usage_global {
910    my ($self) = @_;
911
912    my @usage;
913    push(@usage,$self->command_usage_header());
914
915    my $description = $self->command_usage_description($self);
916    push(@usage,$description)
917        if $description;
918    push(@usage,$self->command_usage_parameters($self,'global parameters:')); # LOCALIZE
919    push(@usage,$self->command_usage_options($self,'global options:')); # LOCALIZE
920    push(@usage,$self->command_usage_subcommands('available commands:',$self->app_commands)); # LOCALIZE
921
922    return @usage;
923}
924
925sub command_usage_subcommands {
926    my ($self,$headline,$commands) = @_;
927
928    my @commands;
929
930    foreach my $command (keys %$commands) {
931        my $class = $commands->{$command};
932        Class::Load::load_class($class);
933    }
934
935    foreach my $command (keys %$commands) {
936        my $class = $commands->{$command};
937
938        unless ($class->can('meta')
939            && $class->DOES('MooseX::App::Role::Common')) {
940            Moose->throw_error('Class '.$class.' is not a proper MooseX::App::Command class. You either need to use MooseX::App::Command or exclude this class via app_exclude')
941        }
942
943        my $command_description;
944        $command_description = $class->meta->command_short_description
945            if $class->meta->can('command_short_description');
946
947        $command_description ||= '';
948        push(@commands,[$command,$command_description]);
949    }
950
951    @commands = sort { $a->[0] cmp $b->[0] } @commands;
952    push(@commands,['help','Prints this usage information']); # LOCALIZE
953
954    return $self->command_message(
955        header  => $headline,
956        body    => MooseX::App::Utils::format_list(@commands),
957    );
958}
959
9601;
961
962__END__
963
964=pod
965
966=encoding utf8
967
968=head1 NAME
969
970MooseX::App::Meta::Role::Class::Base - Meta class role for application base class
971
972=head1 DESCRIPTION
973
974This meta class role will automatically be applied to the application base
975class. This documentation is only of interest if you intend to write
976plugins for MooseX-App.
977
978=head1 ACCESSORS
979
980=head2 app_messageclass
981
982Message class for generating error messages. Defaults to
983MooseX::App::Message::Block. The default can be overwritten by altering
984the C<_build_app_messageclass> method. Defaults to MooseX::App::Message::Block
985
986=head2 app_namespace
987
988Usually MooseX::App will take the package name of the base class as the
989namespace for commands. This namespace can be changed.
990
991=head2 app_exclude
992
993Exclude namespaces included in app_namespace
994
995=head2 app_base
996
997Usually MooseX::App will take the name of the calling wrapper script to
998construct the program name in various help messages. This name can
999be changed via the app_base accessor. Defaults to the base name of $0
1000
1001=head2 app_fuzzy
1002
1003Boolean flag that controls if command names and attributes should be
1004matched exactly or fuzzy. Defaults to true.
1005
1006=head2 app_command_name
1007
1008Coderef attribute that controls how package names are translated to command
1009names and attributes. Defaults to &MooseX::App::Utils::class_to_command
1010
1011=head2 app_commands
1012
1013Hashref with command to command class map.
1014
1015=head2 app_strict
1016
1017Boolean flag that controls if an application with superfluous/unknown
1018positional parameters should terminate with an error message or not.
1019If disabled all extra parameters will be copied to the L<extra_argv>
1020command class attribute.
1021
1022=head2 app_prefer_commandline
1023
1024By default, arguments passed to new_with_command and new_with_options have a
1025higher priority than the command line options. This boolean flag will give
1026the command line an higher priority.
1027
1028=head2 app_permute
1029
1030Boolean flag that controls if command line arguments that take multiple values
1031(ie ArrayRef or HashRef type constraints) can be permuted.
1032
1033=head1 METHODS
1034
1035=head2 command_check
1036
1037Runs sanity checks on options and parameters. Will usually only be executed if
1038either HARNESS_ACTIVE or APP_DEVELOPER environment are set.
1039
1040=head2 command_register
1041
1042 $self->command_register($command_moniker,$command_class);
1043
1044Registers an additional command
1045
1046=head2 command_get
1047
1048 my $command_class = $self->command_register($command_moniker);
1049
1050Returns a command class for the given command moniker
1051
1052=head2 command_class_to_command
1053
1054 my $command_moniker = $meta->command_class_to_command($command_class);
1055
1056Returns the command moniker for the given command class.
1057
1058=head2 command_message
1059
1060 my $message = $meta->command_message(
1061    header  => $header,
1062    type    => 'error',
1063    body    => $message
1064 );
1065
1066Generates a message object (using the class from L<app_messageclass>)
1067
1068=head2 command_usage_attributes
1069
1070 my @attributes = $meta->command_usage_attributes($metaclass);
1071
1072Returns a list of attributes/command options for the given meta class.
1073
1074=head2 command_usage_command
1075
1076 my @messages = $meta->command_usage_command($command_metaclass);
1077
1078Returns a list of messages containing the documentation for a given
1079command meta class.
1080
1081=head2 command_usage_description
1082
1083 my $message = $meta->command_usage_description($command_metaclass);
1084
1085Returns a messages with the basic command description.
1086
1087=head2 command_usage_global
1088
1089 my @messages = $meta->command_usage_global();
1090
1091Returns a list of messages containing the documentation for the application.
1092
1093=head2 command_usage_header
1094
1095 my $message = $meta->command_usage_header();
1096 my $message = $meta->command_usage_header($command_meta_class);
1097
1098Returns a message containing the basic usage documentation
1099
1100=head2 command_find
1101
1102 my @commands = $meta->command_find($commands_arrayref);
1103
1104Returns a list of command names matching the user input
1105
1106=head2 command_candidates
1107
1108 my $commands = $meta->command_candidates($user_command_input);
1109
1110Returns either a single command or an arrayref of possibly matching commands.
1111
1112=head2 command_proto
1113
1114 my ($result,$errors) = $meta->command_proto($command_meta_class);
1115
1116Returns all parsed options (as hashref) and erros (as arrayref) for the proto
1117command. Is a wrapper around L<command_parse_options>.
1118
1119=head2 command_args
1120
1121 my ($options,$errors) = $self->command_args($command_meta_class);
1122
1123Returns all parsed options (as hashref) and erros (as arrayref) for the main
1124command. Is a wrapper around L<command_parse_options>.
1125
1126=head2 command_parse_options
1127
1128 my ($options,$errors) = $self->command_parse_options(\@attribute_metaclasses);
1129
1130Tries to parse the selected attributes from @ARGV.
1131
1132=head2 command_scan_namespace
1133
1134 my %namespaces = $self->command_scan_namespace($namespace);
1135
1136Scans a namespace for command classes. Returns a hash with command names
1137as keys and package names as values.
1138
1139=head2 command_process_attribute
1140
1141 my @attributes = $self->command_process_attribute($attribute_metaclass,$matches);
1142
1143TODO
1144###Returns a list of all attributes with the given type
1145
1146=head2 command_usage_options
1147
1148 my $usage = $self->command_usage_options($metaclass,$headline);
1149
1150Returns the options usage as a message object
1151
1152=head2 command_usage_parameters
1153
1154 my $usage = $self->command_usage_parameters($metaclass,$headline);
1155
1156Returns the positional parameters usage as a message object
1157
1158=head2 command_check_attributes
1159
1160 $errors = $self->command_check_attributes($command_metaclass,$errors,$params)
1161
1162Checks all attributes. Returns/alters the $errors arrayref
1163
1164=head2 command_parser_hints
1165
1166 $self->command_parser_hints($self,$metaclass)
1167
1168Generates parser hints as required by L<MooseX::App::ParsedArgv>
1169
1170=cut
1171