File Coverage

blib/lib/Array/Lookup.pm

Criterion	Covered	Total	%
statement	4	6	66.6
branch			n/a
condition			n/a
subroutine	2	2	100.0
pod			n/a
total	6	8	75.0

# Array::Lookup.pm

package Array::Lookup;

$VERSION = '2.3';

@ISA    = qw(Exporter);
@EXPORT = qw(lookup lookup_error);

sub lookup;
sub lookup_error;

use Carp;
use Array::PrintCols;

sub lookup {
    my $key    = shift;
    length($key)       or croak "Missing lookup key argument.\n";
    my $keytab = shift or croak "Missing keyword table argument\n";
    my $nfsub  = shift;
    my $tmsub  = shift;

    my @keys;
    if (ref($keytab) eq 'HASH') {
	@keys = sort(keys %$keytab);      # get sorted list of keys
    } elsif (ref($keytab) eq 'ARRAY') {
	@keys = sort(@$keytab);           # get the sorted list of array items
    } else {
	croak "lookup: Second argument must be a HASH or ARRAY ref!\n";
    }
    # first check for any *exact* match
    my @matches = grep(/^\Q$key\E$/i, @keys);
    if (@matches or		# any exact matches?
				# if not, try abbreviation search
	((@matches = grep(/^\Q$key\E/i,@keys)) and
	 $#matches == 0)) {	# is there exactly one abbrev?
	$value = $matches[0];	# yes, either an exact or abbrev
	$value = $keytab->{$value} if ref($keytab) eq 'HASH';
	return $value;
    }
    if ($#matches < 0) {	# no matches?
	&$nfsub($key, $keytab, '') if ref($nfsub) eq 'CODE';
    } elsif ($#matches > 0) {	# too many matches
	&$tmsub($key, $keytab, \@matches) if ref($tmsub) eq 'CODE';
    }
    undef;
}

# Standard error handler for "lookup"

sub lookup_error {
    my $key    = shift;
    my $keytab = shift;
    my $err    = shift;
    my $msg    = shift || "lookup failed: '%s' %s; use one of:\n";
    printf STDERR ($msg, $key, ($err ? 'is ambiguous' : 'not found'));
    print_cols $keytab,'','',1;
    undef;
}

1;

__END__