view release on metacpan or  search on metacpan

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

      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 };

   my ($splitters, @options) = $_build_options->( \%data );

   my %gld_conf; my @gld_attr = ('getopt_conf', 'show_defaults');

   my $usage_opt = $config{usage_opt} ? $config{usage_opt} : 'Usage: %c %o';

   @gld_conf{ @gld_attr } = @config{ @gld_attr };
   $config{usage_conf   } and $_set_usage_conf->( $config{usage_conf} );
   $config{protect_argv } and local @ARGV = @ARGV;
   $enc and @ARGV = map { decode( $enc, $_ ) } @ARGV;
   $config{no_untaint   } or  @ARGV = map { untaint_cmdline $_ } @ARGV;
   $Untainted_Argv = [ @ARGV ];
   keys  %{ $splitters  } and @ARGV = $_split_args->( $splitters );
   ($opt, $Usage)  = describe_options( $usage_opt, @options, \%gld_conf );
   $Extra_Argv     = [ @ARGV ];

   my ($params, @missing)
      = $_extract_params->( \%args, \%config, \%data, $opt );

   if ($config{missing_fatal} and @missing) {
      emit_err join( "\n", map { "Option '${_}' is missing" } @missing );
      emit_err $Usage;
      exit FAILED;
   }

   return %{ $params };
};

# Construction
sub new_with_options {
   my $self = shift; return $self->new( $self->$_parse_options( @_ ) );
}

# Public methods
sub extra_argv {
   return defined $_[ 1 ] ? $_extra_argv->( $_[ 0 ] )->[ $_[ 1 ] ]
                          : $_extra_argv->( $_[ 0 ] );
}

sub next_argv {
   return shift @{ $_extra_argv->( $_[ 0 ] ) };
}

sub options_usage {
   return ucfirst $Usage;
}

sub unshift_argv {
   return unshift @{ $_extra_argv->( $_[ 0 ] ) }, $_[ 1 ];
}

sub untainted_argv {
   return defined $_[ 1 ] ? $_untainted_argv->( $_[ 0 ] )->[ $_[ 1 ] ]
                          : $_untainted_argv->( $_[ 0 ] );
}

1;

__END__

=pod

=head1 Name

Class::Usul::TraitFor::UntaintedGetopts - Untaints @ARGV before Getopts processes it

=head1 Synopsis

   use Moo;