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