view release on metacpan or  search on metacpan

lib/Zoidberg/Utils/GetOpt.pm  view on Meta::CPAN

		unless ($opt =~ s/\*$//) {
			$conf{$opt} = $arg;
			$conf{_alias}{$_} = $opt for @al;
		}
		else {
			error 'config syntax error' if @al || ! length $_;
			$conf{$opt} = $arg;
			$conf{_glob} ||= [];
			push @{$conf{_glob}}, $opt;
		}
	}
	$conf{_glob} = '^('.join('|', map {s/^\+/\\+/; $_} @{$conf{_glob}}).')(?!-)' if $conf{_glob};
	#use Data::Dumper; print STDERR 'conf: ', Dumper \%conf;

	PARSE_OPTS:
	for ( # set default options
		[qw/h help/,    \&help   ],
		[qw/u usage/,   \&usage  ],
		[qw/v version/, \&version]
	) {
		next if exists $conf{$$_[1]};
		$conf{$$_[1]} = $$_[2];
		$conf{_alias}{'-'.$$_[0]} = $$_[1]
			unless exists $conf{_alias}{'-'.$$_[0]} or exists $conf{_alias}{$$_[0]};
	}

	my $delim = 0;
	while (@args) { # parse opts
		last unless $args[0] =~ /^(-|\+.)/;
		$_ = shift @args;
		/^(--|-|\+)(.*)/;
		++$delim and last unless length $2;
		my ($pre, $opt, $arg) = ($1, split '=', $2, 2);

		my (@chars, $type);
		my $raw = $pre.$opt;
		if (exists $conf{_alias}{$raw} or exists $conf{$raw}) { $opt = $raw }
		elsif (exists $conf{_glob} and $raw =~ /$conf{_glob}/) {
			$opt = $raw;
			$type = $conf{$1};
		}
		elsif ($pre ne '--' and length $opt > 1) { # try short options
			@chars = split '', $opt;
		}

		PARSE_OPT:
		$opt = shift @chars if @chars;
		$opt = $conf{_alias}{$opt} if exists $conf{_alias}{$opt};
	
		unless (defined $type) { # type is set if glob
			if (exists $conf{$opt}) { $type = $conf{$opt} }
			else { error "unrecognized option '$opt'" }
		}

		push @opts, $opt;
		if (! $type) { # no arg
			error "option '$opt' doesn't take an argument" if defined $arg;
			$opts{$opt} = ($pre eq '+') ? 0 : 1;
		}
		elsif (ref $type) { # CODE ... for default opts
			output $type->( (caller(1))[3], (caller)[0] ); # subroutine, package
			error {silent => 1, exit_status => 0}, 'getopt needed to pop stack';
		}
		else {
			$arg = defined($arg) ? $arg : shift(@args);
			error "option '$opt' requires an argument" unless defined $arg;
			if    ($type eq '$') { $opts{$opt} = $arg }
			elsif ($type eq '@') {
				if (ref $arg) {
					error 'argument is not a ARRAY reference'
						if ref($arg) ne 'ARRAY';
					if ($opts{$opt}) { push @{$opts{$opt}}, @$arg }
					else { $opts{$opt} = $arg }
				}
				else {
					$opts{$opt} ||= [];
					push @{$opts{$opt}}, $arg;
				}
			}
		}
		$arg = $type = undef;
		goto PARSE_OPT if @chars;
	};
	error @opts 
		? "option '$opts[-1]' doesn't take an argument" 
		: 'options found after first argument'          if !$delim and grep /^-/, @args;
	$opts{_opts} = \@opts if @opts; # keep %opts empty unless there are opts

	PARSE_ARGS: # parse args
	unless ($conf{_args}) { $args = [@args] }
	elsif  ($conf{_args} eq '@') {
		error "argument should be a ARRAY reference"
			if grep {ref($_) and ref($_) ne 'ARRAY'} @args;
		if (ref $args[0] and @args == 1) { $args = $args[0] }
		else { $args = [ map {ref($_) ? @$_ : $_} @args] }
	}
	elsif  ($conf{_args} eq '%') {
		error "argument should be a HASH reference"
			if grep {ref($_) and ref($_) ne 'HASH'} @args;
		if (ref $args[0] and @args == 1) { $args = $args[0] }
		else {
			my $error;
			$args = { map {
				if (ref $_) { (%$_) }
				else {
					m/(.*?)=(.*)/ or $error++; 
					($1 => $2)
				}
	       		} @args };
			error 'syntax error, should be \'key=value\'' if $error;
		}
	}
	elsif ($conf{_args} eq '*') {
		my (@keys, %vals);
		for (@args) {
			if (ref $_) {
				my $t = ref $_;
				if ($t eq 'ARRAY') { push @keys, @$_ }
				elsif ($t eq 'HASH') {
					push @keys, keys %$_;
					%vals = (%vals, %$_);