view release on metacpan or  search on metacpan

Getopt.pm  view on Meta::CPAN

	# check if first argument is hash reference
	if (ref $optionlist[0] eq 'HASH') {
	    $self->{'options'} = shift @optionlist;
	}
	while (@optionlist > 0) {
	    my $opt = shift @optionlist;
	    # Strip leading prefix so people can specify "--foo=i"
	    # if they like.
	    $opt = $2 if $opt =~ /^($genprefix)+(.*)$/;

	    if ($opt !~ /^(\w+[-\w|]*)?(!|[=:][infse][@%]?)?$/) {
		warn "Error in option spec: \"", $opt, "\"\n";
		next;
	    }
	    my($o, $c) = ($1, $2);
	    $c = '' unless defined $c;
	    my @aliases;
	    if ($o =~ /\|/) {
		# Handle alias names
		@aliases = split(/\|/, $o);
		$o = shift @aliases;
	    }
	    my $varref;
	    # If no linkage is supplied in the @optionlist, copy it from
	    # the userlinkage ($self->{'options'}) if available.
	    if (defined $self->{'options'} && !ref $optionlist[0]) {
		$varref = (exists $self->{'options'}{$o} ?
			   $self->{'options'}{$o} :
			   \$self->{'options'}{$o});
	    } elsif (ref $optionlist[0]) {
		# link to global variable
		$varref = shift @optionlist;
	    }
	    my %a;
	    if (defined $varref) {
		if (ref $varref eq 'CODE') {
		    my $code = $varref;
		    $a{'callback'} = sub {
			if ($self->{'options'}{$o}) {
			    &$code;
			}
		    };
		    $varref = \$self->{'options'}{$o};
		}
		if (ref($varref) =~ /^(SCALAR|HASH|ARRAY)$/) {
		    $a{'var'} = $varref;
		} else {
		    die "Can't handle variable reference of type "
		      . ref $varref;
		}
	    }
	    if (@aliases) {
		$a{'alias'} = \@aliases;
	    }
	    push(@{$self->{'opttable'}}, [$o, $c, undef, \%a]);
	}
    } else {
	die "No opttable array ref or getopt hash ref";
    }

    $self->{'caller'}         = (caller)[0];
    $self->{'filename'}       = delete $a{'-filename'};
    $self->{'nosafe'}         = delete $a{'-nosafe'};
    $self->{'useerrordialog'} = delete $a{'-useerrordialog'};

    die "Unrecognized arguments: " . join(" ", %a) if %a;

    bless $self, $pkg;
}

# Return a list with all option names, that is, section labels and
# descriptions are ignored.
sub _opt_array {
    my $self = shift;
    my @res;
    foreach (@{$self->{'opttable'}}) {
	push @res, $_
	    if ref $_ eq 'ARRAY' and
	       $_->[OPTNAME] ne '';
    }
    @res;
}

# Return a reference to the option variable given by $opt
sub varref {
    my($self, $opt) = @_;
    if($opt->[OPTEXTRA]{'var'}) {
	$opt->[OPTEXTRA]{'var'};
    } elsif ($self->{'options'}) {
	\$self->{'options'}{$opt->[OPTNAME]};
    } else {
	# Link to global $opt_XXX variable.
	# Make sure a valid perl identifier results.
	my $v;
	($v = $opt->[OPTNAME]) =~ s/\W/_/g;
	eval q{\$} . $self->{'caller'} . q{::opt_} . $v; # XXX @, %
    }
}
# Formerly the varref method was private:
sub _varref { shift->varref(@_) }

sub optextra {
    my($self, $opt, $arg) = @_;
    $opt->[OPTEXTRA]{$arg};
}

sub _is_separator {
    my $opt = shift;
    defined $opt->[OPTNAME] && $opt->[OPTNAME] eq '' &&
    defined $opt->[DEFVAL]  && $opt->[DEFVAL] eq '-';
}

sub set_defaults {
    my $self = shift;
    my $opt;
    foreach $opt ($self->_opt_array) {
	if (defined $opt->[DEFVAL]) {
	    my $ref = ref $self->varref($opt);
	    if      ($ref eq 'ARRAY') {
		@ {$self->varref($opt)} = @{ $opt->[DEFVAL] };
	    } elsif ($ref eq 'HASH') {