1# ============================================================================ 2package MooseX::App::Meta::Role::Attribute::Option; 3# ============================================================================ 4 5use utf8; 6use 5.010; 7 8use namespace::autoclean; 9use Moose::Role; 10 11use List::Util qw(uniq first); 12 13has 'cmd_type' => ( 14 is => 'rw', 15 isa => 'MooseX::App::Types::CmdTypes', 16 predicate => 'has_cmd_type', 17); 18 19has 'cmd_tags' => ( 20 is => 'rw', 21 isa => 'MooseX::App::Types::List', 22 coerce => 1, 23 predicate => 'has_cmd_tags', 24); 25 26has 'cmd_flag' => ( 27 is => 'rw', 28 isa => 'MooseX::App::Types::Identifier', 29 predicate => 'has_cmd_flag', 30); 31 32has 'cmd_aliases' => ( 33 is => 'rw', 34 isa => 'MooseX::App::Types::IdentifierList', 35 predicate => 'has_cmd_aliases', 36 coerce => 1, 37); 38 39has 'cmd_split' => ( 40 is => 'rw', 41 isa => Moose::Util::TypeConstraints::union([qw(Str RegexpRef)]), 42 predicate => 'has_cmd_split', 43); 44 45has 'cmd_count' => ( 46 is => 'rw', 47 isa => 'Bool', 48 default => sub { 0 }, 49); 50 51has 'cmd_negate' => ( 52 is => 'rw', 53 isa => 'MooseX::App::Types::IdentifierList', 54 coerce => 1, 55 predicate => 'has_cmd_negate', 56); 57 58has 'cmd_env' => ( 59 is => 'rw', 60 isa => 'MooseX::App::Types::Env', 61 predicate => 'has_cmd_env', 62); 63 64has 'cmd_position' => ( 65 is => 'rw', 66 isa => 'Int', 67 default => sub { 0 }, 68); 69 70my $GLOBAL_COUNTER = 1; 71 72around 'new' => sub { 73 my $orig = shift; 74 my $class = shift; 75 76 my $self = $class->$orig(@_); 77 78 if ($self->has_cmd_type) { 79 if ($self->cmd_position == 0) { 80 $GLOBAL_COUNTER++; 81 $self->cmd_position($GLOBAL_COUNTER); 82 } 83 } 84 85 return $self; 86}; 87 88sub cmd_check { 89 my ($self) = @_; 90 91 my $name = $self->name; 92 my $from_constraint; 93 my $type_constraint = $self->type_constraint; 94 $from_constraint = $type_constraint->parameterized_from 95 if $type_constraint && $type_constraint->isa('Moose::Meta::TypeConstraint::Parameterized'); 96 97 my $cmd_type = ucfirst($self->cmd_type); 98 99 # Check for useless flags 100 if ($self->cmd_type eq 'parameter') { 101 if ($self->cmd_count) { 102 Moose->throw_error("Parameter $name has 'cmd_count'. This attribute only works with options"); 103 } 104 if ($self->has_cmd_negate) { 105 Moose->throw_error("Parameter $name has 'cmd_negate'. This attribute only works with options"); 106 } 107 if ($self->has_cmd_negate) { 108 Moose->throw_error("Parameter $name has 'cmd_negate'. This attribute only works with options"); 109 } 110 if (defined $type_constraint 111 && $type_constraint->is_a_type_of('Bool')) { 112 Moose->throw_error("Parameter $name has 'cmd_negate'. This attribute only works with options"); 113 } 114 if (($from_constraint && $from_constraint->is_a_type_of('Ref')) 115 || ($type_constraint && $type_constraint->is_a_type_of('Ref'))) { 116 Moose->throw_error("Parameter $name may not have Ref type constraints"); 117 } 118 } else { 119 if ((!$type_constraint || ! $type_constraint->is_a_type_of('Bool')) 120 && first { length($_) == 1 } $self->cmd_name_list) { 121 Moose->throw_error("Option $name has a single letter flag but no Bool type constraint"); 122 } 123 124 # Check negate 125 if ($self->has_cmd_negate 126 && (!$type_constraint || ! $type_constraint->is_a_type_of('Bool'))) { 127 Moose->throw_error("Option $name has 'cmd_negate' but has no Bool type constraint"); 128 } 129 } 130 131 # Check type constraints 132 if (defined $type_constraint) { 133 if ($self->cmd_count 134 && ! $type_constraint->is_a_type_of('Num')) { 135 Moose->throw_error("$cmd_type $name has 'cmd_count' but has no Num/Int type constraint"); 136 } 137 if ($self->has_cmd_split 138 && ! ( 139 ($from_constraint && $from_constraint->is_a_type_of('ArrayRef')) 140 || $type_constraint->is_a_type_of('ArrayRef')) 141 ) { 142 Moose->throw_error("$cmd_type $name has 'cmd_split' but has no ArrayRef type constraint"); 143 } 144 } 145 146 # Check for uniqness 147 my @names = $self->cmd_name_possible; 148 if (scalar(uniq(@names)) != scalar(@names)) { 149 Moose->throw_error("$cmd_type $name has duplicate names/aliases"); 150 } 151 152 return; 153} 154 155sub cmd_type_constraint_description { 156 my ($self,$type_constraint,$singular) = @_; 157 158 $type_constraint //= $self->type_constraint; 159 $singular //= 1; 160 161 if ($type_constraint->isa('Moose::Meta::TypeConstraint::Enum')) { 162 return 'one of these values: '.join(', ',@{$type_constraint->values}); 163 } elsif ($type_constraint->isa('Moose::Meta::TypeConstraint::Parameterized')) { 164 my $from = $type_constraint->parameterized_from; 165 if ($from->is_a_type_of('ArrayRef')) { 166 return $self->cmd_type_constraint_description($type_constraint->type_parameter); 167 } elsif ($from->is_a_type_of('HashRef')) { 168 return 'key-value pairs of '.$self->cmd_type_constraint_description($type_constraint->type_parameter,0); 169 } 170 # TODO union 171 } elsif ($type_constraint->equals('Int')) { 172 return $singular ? 'an integer':'integers'; # LOCALIZE 173 } elsif ($type_constraint->equals('Num')) { 174 return $singular ? 'a number':'numbers'; # LOCALIZE 175 } elsif ($type_constraint->equals('Str')) { 176 return $singular ? 'a string':'strings'; 177 } elsif ($type_constraint->equals('HashRef')) { 178 return 'key-value pairs'; # LOCALIZE 179 } 180 181 if ($type_constraint->has_parent) { 182 return $self->cmd_type_constraint_description($type_constraint->parent); 183 } 184 185 return; 186} 187 188sub cmd_type_constraint_check { 189 my ($self,$value) = @_; 190 191 return 192 unless ($self->has_type_constraint); 193 my $type_constraint = $self->type_constraint; 194 195 if ($type_constraint->has_coercion) { 196 $value = $type_constraint->coerce($value) 197 } 198 199 # Check type constraints 200 unless ($type_constraint->check($value)) { 201 if (ref($value) eq 'ARRAY') { 202 $value = join(', ',grep { defined } @$value); 203 } elsif (ref($value) eq 'HASH') { 204 $value = join(', ',map { $_.'='.$value->{$_} } keys %$value) 205 } 206 207 # We have a custom message 208 if ($type_constraint->has_message) { 209 return $type_constraint->get_message($value); 210 # No message 211 } else { 212 my $message_human = $self->cmd_type_constraint_description($type_constraint); 213 if (defined $message_human) { 214 return "Value must be ". $message_human ." (not '$value')"; 215 } else { 216 return $type_constraint->get_message($value); 217 } 218 } 219 } 220 221 return; 222} 223 224sub cmd_usage_description { 225 my ($self) = @_; 226 227 my $description = ($self->has_documentation) ? $self->documentation : ''; 228 my @tags = $self->cmd_tags_list(); 229 if (scalar @tags) { 230 $description .= ' ' 231 if $description; 232 $description .= '['.join('; ',@tags).']'; 233 } 234 return $description 235} 236 237sub cmd_usage_name { 238 my ($self) = @_; 239 240 if ($self->cmd_type eq 'parameter') { 241 return $self->cmd_name_primary; 242 } else { 243 return join(' ', 244 map { (length($_) == 1) ? "-$_":"--$_" } 245 $self->cmd_name_possible 246 ); 247 } 248} 249 250sub cmd_name_primary { 251 my ($self) = @_; 252 253 if ($self->has_cmd_flag) { 254 return $self->cmd_flag; 255 } else { 256 return $self->name; 257 } 258} 259 260sub cmd_name_list { 261 my ($self) = @_; 262 263 my @names = ($self->cmd_name_primary); 264 265 if ($self->has_cmd_aliases) { 266 push(@names, @{$self->cmd_aliases}); 267 } 268 269 return @names; 270} 271 272sub cmd_name_possible { 273 my ($self) = @_; 274 275 if ($self->cmd_type eq 'parameter') { 276 return $self->cmd_name_primary; 277 } 278 279 my @names = $self->cmd_name_list(); 280 281 # TODO check boolean type constraint 282 if ($self->has_cmd_negate) { 283 push(@names, @{$self->cmd_negate}); 284 } 285 286 return @names; 287} 288 289sub cmd_tags_list { 290 my ($self) = @_; 291 292 my @tags; 293 294 if ($self->is_required 295 && ! $self->is_lazy_build 296 && ! $self->has_default) { 297 push(@tags,'Required') 298 } 299 300 if ($self->has_default && ! $self->is_default_a_coderef) { 301 if ($self->has_type_constraint 302 && $self->type_constraint->is_a_type_of('Bool')) { 303# if ($attribute->default) { 304# push(@tags,'Default:Enabled'); 305# } else { 306# push(@tags,'Default:Disabled'); 307# } 308 } else { 309 push(@tags,'Default:"'.$self->default.'"'); 310 } 311 } 312 313 if ($self->has_cmd_split) { 314 my $split = $self->cmd_split; 315 if (ref($split) eq 'Regexp') { 316 $split = "$split"; 317 $split =~ s/^\(\?\^\w*:(.+)\)$/$1/x; 318 } 319 push(@tags,'Multiple','Split by "'.$split.'"'); 320 } 321 322 if ($self->has_type_constraint) { 323 my $type_constraint = $self->type_constraint; 324 if ($type_constraint->is_a_type_of('ArrayRef')) { 325 if (! $self->has_cmd_split) { 326 push(@tags,'Multiple'); 327 } 328 } elsif ($type_constraint->is_a_type_of('HashRef')) { 329 push(@tags,'Key-Value'); 330 } 331 unless ($self->should_coerce) { 332 if ($type_constraint->is_a_type_of('Int')) { 333 push(@tags,'Integer'); 334 } elsif ($type_constraint->is_a_type_of('Num')) { 335 push(@tags ,'Number'); 336 } elsif ($type_constraint->is_a_type_of('Bool')) { 337 push(@tags ,'Flag'); 338 } elsif ($type_constraint->isa('Moose::Meta::TypeConstraint::Enum')) { 339 push(@tags ,'Possible values: '.join(', ',@{$type_constraint->values})); 340 } 341 } 342 } 343 344 if ($self->can('has_cmd_env') 345 && $self->has_cmd_env) { 346 push(@tags,'Env: '.$self->cmd_env) 347 } 348 349 if ($self->can('cmd_tags') 350 && $self->can('cmd_tags') 351 && $self->has_cmd_tags) { 352 push(@tags,@{$self->cmd_tags}); 353 } 354 355 return @tags; 356} 357 358{ 359 package Moose::Meta::Attribute::Custom::Trait::AppOption; 360 361 use strict; 362 use warnings; 363 364 sub register_implementation { return 'MooseX::App::Meta::Role::Attribute::Option' } 365} 366 3671; 368 369=pod 370 371=encoding utf8 372 373=head1 NAME 374 375MooseX::App::Meta::Role::Attribute::Option - Meta attribute role for options 376 377=head1 DESCRIPTION 378 379This meta attribute role will automatically be applied to all attributes 380that should be used as options. 381 382=head1 ACCESSORS 383 384In your app and command classes you can 385use the following attributes in option or parameter definitions. 386 387 option 'myoption' => ( 388 is => 'rw', 389 isa => 'ArrayRef[Str]', 390 documentation => 'My special option', 391 cmd_flag => 'myopt', 392 cmd_aliases => [qw(mopt localopt)], 393 cmd_tags => [qw(Important!)], 394 cmd_env => 'MY_OPTION', 395 cmd_position => 1, 396 cmd_split => qr/,/, 397 cmd_negate => 'notoption' 398 ); 399 400=head2 cmd_flag 401 402Use this name instead of the attribute name as the option name 403 404=head2 cmd_type 405 406Option to mark if this attribute should be used as an option or parameter value. 407 408Allowed values are: 409 410=over 411 412=item * option - Command line option 413 414=item * proto - Command line option that should be processed prior to other 415options (eg. a config-file option that sets other attribues) Usually only 416used for plugin developmemt 417 418=item * parameter - Positional parameter command line value 419 420=back 421 422=head2 cmd_env 423 424Environment variable name (only uppercase letters, numeric and underscores 425allowed). If variable was not specified otherwise the value will be 426taken from %ENV. 427 428=head2 cmd_aliases 429 430Arrayref of alternative option names 431 432=head2 cmd_tags 433 434Extra option tags displayed in the usage information (in brackets) 435 436=head2 cmd_position 437 438Override the order of the parameters in the usage message. 439 440=head2 cmd_split 441 442Splits multiple values at the given separator string or regular expression. 443Only works in conjunction with an 'ArrayRef[*]' type constraint. 444ie. '--myattr value1,value2' with cmd_split set to ',' would produce an 445arrayref with to elements. 446 447=head2 cmd_count 448 449Similar to the Getopt::Long '+' modifier, cmd_count turns the attribute into 450a counter. Every occurrence of the attribute in @ARGV (without any value) 451would increment the resulting value by one 452 453=head2 cmd_negate 454 455Sets names for the negated variant of a boolean field. Only works in conjunction 456with a 'Bool' type constraint. 457 458=head1 METHODS 459 460These methods are only of interest to plugin authors. 461 462=head2 cmd_check 463 464Runs sanity checks on options and parameters. Will usually only be executed if 465either HARNESS_ACTIVE or APP_DEVELOPER environment are set. 466 467=head2 cmd_name_possible 468 469 my @names = $attribute->cmd_name_possible(); 470 471Returns a list of all possible option names. 472 473=head2 cmd_name_list 474 475 my @names = $attribute->cmd_name_list(); 476 477Similar to cmd_name_possible this method returns a list of option names, 478except for names set via cmd_negate. 479 480=head2 cmd_name_primary 481 482 my $name = $attribute->cmd_name_primary(); 483 484Returns the primary option name 485 486=head2 cmd_usage_name 487 488 my $name = $attribute->cmd_usage_name(); 489 490Returns the name as used by the usage text 491 492=head2 cmd_usage_description 493 494 my $name = $attribute->cmd_usage_description(); 495 496Returns the description as used by the usage text 497 498=head2 cmd_tags_list 499 500 my @tags = $attribute->cmd_tags_list(); 501 502Returns a list of tags 503 504=head2 cmd_type_constraint_check 505 506 $attribute->cmd_type_constraint_check($value) 507 508Checks the type constraint. Returns an error message if the check fails 509 510=head2 cmd_type_constraint_description 511 512 $attribute->cmd_type_constraint_description($type_constraint,$singular) 513 514Creates a description of the selected type constraint. 515 516=cut 517 518