package Class::Usul::Options; use strict; use warnings; use Class::Usul::Constants qw( TRUE ); use Class::Usul::Functions qw( throw ); use Sub::Install qw( install_sub ); my @OPTIONS_ATTRIBUTES = qw( autosplit doc format json negateable order repeatable short ); # Private functions my $_filter_attributes = sub { my %attributes = @_; my %filter_key = map { $_ => 1 } @OPTIONS_ATTRIBUTES; return map { ( $_ => $attributes{ $_ } ) } grep { not exists $filter_key{ $_ } } keys %attributes; }; my $_validate_and_filter_options = sub { my (%options) = @_; defined $options{doc } or $options{doc } = $options{documentation}; defined $options{order} or $options{order} = 0; if ($options{json}) { delete $options{repeatable}; delete $options{autosplit}; delete $options{negateable}; $options{format} = 's'; } my %cmdline_options = map { ( $_ => $options{ $_ } ) } grep { exists $options{ $_ } } @OPTIONS_ATTRIBUTES, 'required'; $cmdline_options{autosplit} and $cmdline_options{repeatable} = TRUE; $cmdline_options{repeatable} and defined $cmdline_options{format} and (substr $cmdline_options{format}, -1) ne '@' and $cmdline_options{format} .= '@'; $cmdline_options{negateable} and defined $cmdline_options{format} and throw 'Negateable parameters are not usable with a non boolean values'; return %cmdline_options; }; # Public methods sub import { my ($class, @args) = @_; my $target = caller; my $options_config = { protect_argv => TRUE, flavour => [], skip_options => [], prefer_commandline => TRUE, @args, }; for my $want (grep { not $target->can( $_ ) } qw( around has with )) { throw 'Method [_1] not found in class [_2]', [ $want, $target ]; } my $around = $target->can( 'around' ); my $has = $target->can( 'has' ); my $with = $target->can( 'with' ); my @target_isa; { no strict 'refs'; @target_isa = @{ "${target}::ISA" } }; if (@target_isa) { # Don't add this to a role. The ISA of a role is always empty! install_sub { as => '_options_config', into => $target, code => sub { return shift->maybe::next::method( @_ ); }, }; install_sub { as => '_options_data', into => $target, code => sub { return shift->maybe::next::method( @_ ); }, }; $around->( '_options_config' => sub { my ($orig, $self, @args) = @_; return $orig->( $self, @args ), %{ $options_config }; } ); } my $options_data = {}; my $apply_modifiers = sub { $target->can( 'new_with_options' ) and return; $with->( 'Class::Usul::TraitFor::UntaintedGetopts' ); $around->( '_options_data' => sub { my ($orig, $self, @args) = @_; return $orig->( $self, @args ), %{ $options_data }; } ); }; my $option = sub { my ($name, %attributes) = @_; my @banish_keywords = qw( extra_argv new_with_options next_argv option _options_data _options_config options_usage _parse_options unshift_argv ); for my $ban (grep { $_ eq $name } @banish_keywords) { throw 'Method [_1] used by class [_2] as an attribute', [ $ban, $target ]; } $has->( $name => $_filter_attributes->( %attributes ) ); $options_data->{ $name } = { $_validate_and_filter_options->( %attributes ) }; $apply_modifiers->(); # TODO: I think this can go return; }; my $info; $info = $Role::Tiny::INFO{ $target } and $info->{not_methods}{ $option } = $option; install_sub { as => 'option', into => $target, code => $option, }; $apply_modifiers->(); return; } 1; __END__ =pod =encoding utf8 =head1 Name Class::Usul::Options - Command line processing =head1 Synopsis use Moo; use Class::Usul::Options; =head1 Description This is a clone of L<MooX::Options> but is closer to L<MooseX::Getopt::Dashes> =head1 Configuration and Environment Format of the parameters, same as L<Getopt::Long::Descriptive> i : integer i@: array of integer s : string s@: array of string s%: hash of string f : float value By default, it's a boolean value. Defines no attributes =head1 Subroutines/Methods =head2 import Inject the C<option> method into the caller =head1 Diagnostics None =head1 Dependencies =over 3 =item L<Sub::Install> =back =head1 Incompatibilities There are no known incompatibilities in this module =head1 Bugs and Limitations There are no known bugs in this module. Please report problems to http://rt.cpan.org/NoAuth/Bugs.html?Dist=Class-Usul. Patches are welcome =head1 Acknowledgements Larry Wall - For the Perl programming language =head1 Author Peter Flanigan, C<< <pjfl@cpan.org> >> =head1 License and Copyright Copyright (c) 2015 Peter Flanigan. All rights reserved This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L<perlartistic> This program is distributed in the hope that it will be useful, but WITHOUT WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE =cut # Local Variables: # mode: perl # tab-width: 3 # End: