view release on metacpan or  search on metacpan

lib/Getopt/Mixed/Help.pm  view on Meta::CPAN

use constant DEFAULT_USAGE => 'usage';
use constant DEFAULT_OPTIONS => 'options';
use constant DEFAULT_DEFAULT => ' (defaults to %s)';

#########################################################################

=head2 B<import> - main and only function

see above in the main documentation how to use it

One confession about the internals, this function doesn't use a real
hash; it just uses the same syntax as it really expects an array of
pairs (as most of you might have guessed already ;-).

=cut

# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub import
{
    local $_;
    my $this = shift;
    croak 'bad usage of ', __PACKAGE__ unless $this eq __PACKAGE__;
    croak 'no parameter passed to ', __PACKAGE__ unless 0 < @_;
    croak 'unbalanced parameter list passed to ', __PACKAGE__
	unless @_ % 2 == 0;
    my %env = %ENV;

    my $usage_text = DEFAULT_USAGE;
    my $options_text = DEFAULT_OPTIONS;
    my $indent_opt1 = $options_text.':  ';
    my $indent_opt2 = ' ' x (length($options_text) + 3);
    my $indent_help = ' ' x (length($options_text) + 7);
    my $default_template = DEFAULT_DEFAULT;

    $optUsage = '';
    # check/support commandline parameters that are NOT options:
    my $has_only_options = 1;
    if ($_[0] =~ m/^.[^>].*$/ and $_[0] ne 'ENV' and $_[0] ne 'ENV_')
    {
	$optUsage .= ' '.(shift)."\n\n".(shift);
	$has_only_options = 0;
    }
    $optUsage .= "\n\n";

    my $help_long = 'help';
    my $help_opt_name = 'opt_help';
    my $help_options = 'help|h|?+';
    my $debug_opt_name = 'opt_debug';

    my @options = ();
    my @option_vars = ();
    my %default_value = ();
    my %option_type = ();
    my %optional_integers = ();
    my %optional_floats = ();
    my $max_length = 0;
    my $env_prefix = undef;
    my $use_multiple = 0;
    my $multiple = undef;
    my %multiple_options = ();
    my $package = (caller)[0];

    # preparation loop (module parameters):
    while (@_ > 0)
    {
	my $option = shift;
	if ($option =~
	    m/^(?:(\w)?>(>)?)?([-a-z0-9]{2,})(?:([:=][isf])\s*(.*))?$/)
	{
	    my ($short_option, $is_multiple, $long_option, $specifier,
		$opt_valtext) = ($1, $2, $3, $4, $5);
	    my $var = 'opt_'.$long_option;
	    $var =~ s/\W/_/g;
	    my $default_text = '';
	    {
		my $default_constant = 'DEFAULT_'.uc($long_option);
		$default_constant =~ s/\W/_/g;
		no strict 'refs';
		no warnings 'once';
		my $default_cref = *{$package.'::'.$default_constant}{CODE};
		if ( ref($default_cref) eq 'CODE')
		{
		    if (ref(&$default_cref) eq '')
		    {
			$default_text =
			    sprintf($default_template, &$default_cref);
		    }
		    elsif (ref(&$default_cref) eq 'ARRAY')
		    {
			$default_text =
			    sprintf($default_template,
				    join(', ', @{&$default_cref}));
		    }
		    else
		    {
			croak(ref(&$default_cref), ' constants as ',
			      'default values are not yet supported in ',
			      __PACKAGE__);
		    }
		    $default_value{$var} = &$default_cref;
		}
	    }
	    $specifier = '' unless defined $specifier;
	    if ($opt_valtext  and  $specifier =~ m/^=/)
	    {
		if ($opt_valtext =~ m/^{.*}$/)
		{
		    $opt_valtext = ' '.$opt_valtext;
		}
		else
		{
		    $opt_valtext = ' <'.$opt_valtext.'>';
		}
	    }
	    elsif ($opt_valtext  and  $specifier =~ m/^:/)
	    {
		$opt_valtext = ' [<'.$opt_valtext.'>]';
	    }
	    elsif ($specifier =~ m/^=/)
	    {
		$opt_valtext = ($specifier =~ m/i$/ ? ' <integer>' :