File Coverage

blib/lib/Zoidberg/Utils/GetOpt.pm

Criterion	Covered	Total	%
statement	118	158	74.6
branch	85	130	65.3
condition	25	48	52.0
subroutine	7	10	70.0
pod	4	5	80.0
total	239	351	68.0

package Zoidberg::Utils::GetOpt;

our $VERSION = '0.981';

use strict;
use Zoidberg::Utils::Error qw/error bug/;
use Zoidberg::Utils::Output qw/output debug/;
use Exporter::Tidy
	default => ['getopt'],
	other   => [qw/help usage version path2hashref/] ;

our $ERROR_CALLER = 1;

sub getopt { # hic sunt leones
	my ($conf, @args) = @_;
	my (%conf, @opts, %opts, $args);
	if (ref $conf) {
		%conf = %$conf;
		goto PARSE_OPTS;
	}

	# parse config
	$conf{_args} = $1 if $conf =~ s/(?
	goto PARSE_ARGS unless $conf and $args[0] =~ /^[+-]/;
	for (split /\s+/, $conf) {
		my $arg = s/([\$\@\%])$// ? $1 : 0;
		my ($opt, @al) = split ',', $_;
		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, %$_);
				}
				else { error "can't handle $t reference argument" }
			}
			elsif (m/(.*?)=(.*)/) {
				push @keys, $1;
				$vals{$1} = $2;
			}
			else { push @keys, $_ }
		}
		return \%opts, \@keys, \%vals;
	}

	return \%opts, $args;
}

sub usage {
	$_[2] = 1;
	goto &help;
}

sub help {
	my ($cmd, $file, $usage) = @_;

	$cmd ||= (caller(1))[3];
	$file = $1 if $cmd =~ s/(.*):://;
	$file =~ s/::/\//g;
	$file =~ s/\.pm$//;
	($file) = grep {-e $_} map {("$_/$file.pod", "$_/$file.pm")} @INC
		unless $file =~ m#^/#;

	open POD, $file || error "Could not read $file";
	my ($help, $p, $o) = ('', 0, 0);
	while () {
		if ($p) {
			if    (/^=over/)  { $o++ }
			elsif (/^=back/)  { $o-- }
			elsif (/^=(item(?!\s+$cmd)|back|cut)/) {
				last unless $o;
			}
			$help .= $_ unless $usage and ! $o and ! /^=item\s+$cmd/;
			# only return 'item' lines if short format
		}
		elsif (/^=item\s+$cmd/) {
			$p = 1;
			$help = $_;
		}
	}
	close POD;

	$help =~ s/^\s+|\s+$//g;
	if ($usage) {
		$help =~ s/^=item\s+/  /gm;
		$help = "usage:\n".$help;
	}
	else { $help =~ s/^=\w+\s+/= /gm }
	$help =~ s/(\w)<<(.*?)>>|\w<(.*?)>/
		($1 eq 'B') ? "\"$2$3\"" :
		($1 eq 'C') ? "`$2$3`"   : "'$2$3'"
	/ge;
	return $help;
}

sub version {
	my (undef, $class) = @_;
	no strict 'refs';
	return ${$class.'::LONG_VERSION'} || $class.' '.${$class.'::VERSION'};
}

sub path2hashref {
	my ($hash, $key) = @_;
	my $path = '/';
	while ($key =~ s#^/*(.+?)/##) {
		$path .= $1 . '/';
		if (! defined $$hash{$1}) { $$hash{$1} = {} }
		elsif (ref($$hash{$1}) ne 'HASH') { return undef, undef, $path } # bail out
		$hash = $$hash{$1};
	}
	return $hash, $key, $path;
}

1;

__END__