view release on metacpan or  search on metacpan

lib/Class/Usul/TraitFor/UntaintedGetopts.pm  view on Meta::CPAN

use Data::Record;
use Encode                 qw( decode );
use JSON::MaybeXS          qw( decode_json );
use Scalar::Util           qw( blessed );
use Moo::Role;

my $Extra_Argv = []; my $Untainted_Argv = [];

my $Usage = "Did we forget new_with_options?\n";

# Private functions
my $_extra_argv = sub {
   return $_[ 0 ]->{_extra_argv} //= [ @{ $Extra_Argv } ];
};

my $_extract_params = sub {
   my ($args, $config, $options_data, $cmdline_opt) = @_;

   my $params = { %{ $args } }; my @missing_required;

   my $prefer = $config->{prefer_commandline};

   for my $name (keys %{ $options_data }) {
      my $option = $options_data->{ $name };

      if ($prefer or not defined $params->{ $name }) {
         my $val; defined ($val = $cmdline_opt->$name()) and
            $params->{ $name } = $option->{json} ? decode_json( $val ) : $val;
      }

      $option->{required} and not defined $params->{ $name }
         and push @missing_required, $name;
   }

   return ($params, @missing_required);
};

my $_option_specification = sub {
   my ($name, $opt) = @_;

   my $dash_name   = $name; $dash_name =~ tr/_/-/; # Dash name support
   my $option_spec = $dash_name;

   defined $opt->{short } and $option_spec .= '|'.$opt->{short};
   $opt->{repeatable} and not defined $opt->{format} and $option_spec .= '+';
   $opt->{negateable} and $option_spec .= '!';
   defined $opt->{format} and $option_spec .= '='.$opt->{format};
   return $option_spec;
};

my $_set_usage_conf = sub { # Should be in describe_options third argument
   return Class::Usul::Getopt::Usage->usage_conf( $_[ 0 ] );
};

my $_split_args = sub {
   my $splitters = shift; my @new_argv;

   for (my $i = 0, my $nargvs = @ARGV; $i < $nargvs; $i++) { # Parse all argv
      my $arg = $ARGV[ $i ];

      my ($name, $value) = split m{ [=] }mx, $arg, 2; $name =~ s{ \A --? }{}mx;

      if (my $splitter = $splitters->{ $name }) {
         $value //= $ARGV[ ++$i ];

         for my $subval (map { s{ \A [\'\"] | [\'\"] \z }{}gmx; $_ }
                         $splitter->records( $value )) {
            push @new_argv, "--${name}", $subval;
         }
      }
      else { push @new_argv, $arg }
   }

   return @new_argv;
};

my $_sort_options = sub {
   my ($opts, $a, $b) = @_; my $max = 999;

   my $oa = $opts->{ $a }{order} || $max; my $ob = $opts->{ $b }{order} || $max;

   return ($oa == $max) && ($ob == $max) ? $a cmp $b : $oa <=> $ob;
};

my $_untainted_argv = sub {
   return $_[ 0 ]->{_untainted_argv} //= [ @{ $Untainted_Argv } ];
};

my $_build_options = sub {
   my $options_data = shift; my $splitters = {}; my @options = ();

   for my $name (sort  { $_sort_options->( $options_data, $a, $b ) }
                 keys %{ $options_data }) {
      my $option = $options_data->{ $name };
      my $cfg    = $option->{config} // {};
      my $doc    = $option->{doc   } // "No help for ${name}";

      push @options, [ $_option_specification->( $name, $option ), $doc, $cfg ];
      defined $option->{autosplit} or next;
      $splitters->{ $name } = Data::Record->new( {
         split => $option->{autosplit}, unless => QUOTED_RE } );
      $option->{short}
         and $splitters->{ $option->{short} } = $splitters->{ $name };
   }

   return ($splitters, @options);
};

# Private methods
my $_parse_options = sub {
   my ($self, %args) = @_; my $opt;

   my $class  = blessed $self || $self;
   my %data   = $class->_options_data;
   my %config = $class->_options_config;
   my $enc    = $config{encoding} // 'UTF-8';

   my @skip_options; defined $config{skip_options}
      and @skip_options = @{ $config{skip_options} };

   @skip_options and delete @data{ @skip_options };