File Coverage

blib/lib/Getopt/Lucid.pm

Criterion	Covered	Total	%
statement	480	483	99.3
branch	301	322	93.4
condition	42	50	84.0
subroutine	53	53	100.0
pod	16	16	100.0
total	892	924	96.5

use 5.008001;
use strict;
use warnings;
package Getopt::Lucid;
# ABSTRACT: Clear, readable syntax for command line processing

our $VERSION = '1.10';

our @EXPORT_OK = qw(Switch Counter Param List Keypair);
our %EXPORT_TAGS = ( all => [ @EXPORT_OK ] );
our @ISA = qw( Exporter );

use Carp;
use Exporter ();
use File::Basename ();
use List::Util ();
use Getopt::Lucid::Exception;
use Storable 2.16 qw(dclone);

# Definitions
my $VALID_STARTCHAR = "a-zA-Z0-9";
my $VALID_CHAR      = "a-zA-Z0-9_-";
my $VALID_LONG      = qr/--[$VALID_STARTCHAR][$VALID_CHAR]*/;
my $VALID_SHORT     = qr/-[$VALID_STARTCHAR]/;
my $VALID_BARE      = qr/[$VALID_STARTCHAR][$VALID_CHAR]*/;
my $VALID_NAME      = qr/$VALID_LONG|$VALID_SHORT|$VALID_BARE/;
my $SHORT_BUNDLE    = qr/-[$VALID_STARTCHAR]{2,}/;
my $NEGATIVE        = qr/(?:--)?no-/;

my @valid_keys = qw( name type default nocase valid needs canon doc );
my @valid_types = qw( switch counter parameter list keypair);

sub Switch  {
    return bless { name => shift, type => 'switch' },
                 "Getopt::Lucid::Spec";
}
sub Counter {
    return bless { name => shift, type => 'counter' },
                 "Getopt::Lucid::Spec";
}
sub Param   {
    my $self = { name => shift, type => 'parameter' };
    $self->{valid} = shift if @_;
    return bless $self, "Getopt::Lucid::Spec";
}
sub List    {
    my $self = { name => shift, type => 'list' };
    $self->{valid} = shift if @_;
    return bless $self, "Getopt::Lucid::Spec";
}
sub Keypair {
    my $self = { name => shift, type => 'keypair' };
    $self->{valid} = [ @_ ] if scalar @_;
    return bless $self, "Getopt::Lucid::Spec";
}

package
  Getopt::Lucid::Spec;
$Getopt::Lucid::Spec::VERSION = $Getopt::Lucid::VERSION;

# alternate way to specify validation
sub valid {
    my $self = shift;
    Getopt::Lucid::throw_spec("valid() is not supported for '$self->{type}' options")
      unless grep { $self->{type} eq $_ } qw/parameter list keypair/;
    $self->{valid} = $self->{type} eq 'keypair' ? [ @_ ] : shift;
    return $self;
}

sub default {
    my $self = shift;
    my $type = $self->{type};
    if ($self->{type} eq 'keypair') {
        if (ref($_[0]) eq 'HASH') {
            $self->{default} = shift;
        }
        elsif ( @_ % 2 == 0 ) {
            $self->{default} = { @_ };
        }
        else {
            $self->{default} = []; # will cause an exception later
        }
    }
    elsif ( $self->{type} eq 'list' ) {
        $self->{default} = [ @_ ];
    }
    else {
        $self->{default} = shift;
    }
    return $self
};

sub anycase { my $self = shift; $self->{nocase}=1; return $self };

sub needs { my $self = shift; $self->{needs}=[@_]; return $self };

sub doc { my $self = shift; $self->{doc}=shift; return $self };

sub _clone { my $self = shift; bless { %$self }, ref $self }

package Getopt::Lucid;

#--------------------------------------------------------------------------#
# new()
#--------------------------------------------------------------------------#

my @params = qw/strict target/;

sub new {
    my ($class, $spec, $target) = @_;
    my $args = ref($_[-1]) eq 'HASH' ? pop(@_) : {};
    $args->{target} = ref($target) eq 'ARRAY' ? $target : \@ARGV;
    my $self = {};
    $self->{$_} = $args->{$_} for @params;
    $self->{raw_spec} = $spec;
    bless ($self, ref($class) ? ref($class) : $class);
    throw_usage("Getopt::Lucid->new() requires an option specification array reference")
        unless ref($self->{raw_spec}) eq 'ARRAY';
    _parse_spec($self);
    _set_defaults($self);
    $self->{options} = {};
    $self->{parsed} = [];
    $self->{seen}{$_} = 0 for keys %{$self->{spec}};
    return $self;
}

#--------------------------------------------------------------------------#
# append_defaults()
#--------------------------------------------------------------------------#

sub append_defaults {
    my $self = shift;
    my %append =
        ref $_[0] eq 'HASH' ? %{+shift} :
        (@_ % 2 == 0) ? @_ :
        throw_usage("Argument to append_defaults() must be a hash or hash reference");
    for my $name ( keys %{$self->{spec}} ) {
        my $spec = $self->{spec}{$name};
        my $strip = $self->{strip}{$name};
        next unless exists $append{$strip};
        for ( $spec->{type} ) {
            /switch|parameter/ && do {
                $self->{default}{$strip} = $append{$strip};
                last;
            };
            /counter/ && do {
                $self->{default}{$strip} += $append{$strip};
                last;
            };
            /list/ && do {
                throw_usage("Option '$strip' in append_defaults() must be scalar or array reference")
                    if ref($append{$strip}) && ref($append{$strip}) ne 'ARRAY';
                $append{$strip} = ref($append{$strip}) eq 'ARRAY'
                    ? dclone( $append{$strip} )
                    : [ $append{$strip} ] ;
                push @{$self->{default}{$strip}}, @{$append{$strip}};
                last;
            };
            /keypair/ && do {
                throw_usage("Option '$strip' in append_defaults() must be scalar or hash reference")
                    if ref($append{$strip}) && ref($append{$strip}) ne 'HASH';
                $self->{default}{$strip} = {
                    %{$self->{default}{$strip}},
                    %{$append{$strip}},
                };
                last;
            };
        }
        throw_spec("Default '$spec->{canon}' = '$self->{default}{$strip}' fails to validate")
          unless _validate_value($self, $self->{default}{$strip}, $spec->{valid} );
    }
    _recalculate_options($self);
    return $self->options;
}

#--------------------------------------------------------------------------#
# defaults()
#--------------------------------------------------------------------------#

sub defaults {
    my ($self) = @_;
    return %{dclone($self->{default})};
}


#--------------------------------------------------------------------------#
# getopt()
#--------------------------------------------------------------------------#

sub getopt {
    my ($self,$spec,$target) = @_;
    if ( $self eq 'Getopt::Lucid' ) {
        throw_usage("Getopt::Lucid->getopt() requires an option specification array reference")
            unless ref($spec) eq 'ARRAY';
        $self = new(@_)
    }
    my (@passthrough);
    while (@{$self->{target}}) {
        my $raw = shift @{$self->{target}};
        last if $raw =~ /^--$/;
        my ($orig, $val) = _split_equals($self, $raw);
        next if _unbundle($self, $orig, $val);
        my $neg = $orig =~ s/^$NEGATIVE(.*)$/$1/ ? 1 : 0;
        my $arg = _find_arg($self, $orig);
        if ( $arg ) {
            $neg ?
                $self->{seen}{$arg} = 0 :
                $self->{seen}{$arg}++;
            for ($self->{spec}{$arg}{type}) {
                /switch/    ? _switch   ($self, $arg, $val, $neg) :
                /counter/   ? _counter  ($self, $arg, $val, $neg) :
                /parameter/ ? _parameter($self, $arg, $val, $neg) :
                /list/      ? _list     ($self, $arg, $val, $neg) :
                /keypair/   ? _keypair  ($self, $arg, $val, $neg) :
                              throw_usage("can't handle type '$_'");
            }
        } else {
            throw_argv("Invalid argument: $orig")
                if $orig =~ /^-./; # invalid if looks like it could be an arg;
            push @passthrough, $orig;
        }
    }
    _recalculate_options($self);
    @{$self->{target}} = (@passthrough, @{$self->{target}});
    return $self;
}

BEGIN { *getopts = \&getopt }; # handy alias

#--------------------------------------------------------------------------#
# validate
#--------------------------------------------------------------------------#

sub validate {
  my ($self, $arg) = @_;
  throw_usage("Getopt::Lucid->validate() takes a hashref argument")
    if $arg && ref($arg) ne 'HASH';

  if ( $arg && exists $arg->{requires} ) {
    my $requires = $arg->{requires};
    throw_usage("'validate' argument 'requires' must be an array reference")
      if $requires && ref($requires) ne 'ARRAY';
    for my $p ( @$requires ) {
        throw_spec("Requiring an unspecified option ('$p') in validate()")
            unless exists $self->{spec}{$p};
        throw_argv( "Required option '$self->{spec}{$p}{canon}' not found")
            if ( !$self->{seen}{$p} );
    }
  }

  _check_prereqs($self);

  return $self;
}

#--------------------------------------------------------------------------#
# merge_defaults()
#--------------------------------------------------------------------------#

sub merge_defaults {
    my $self = shift;
    my %merge =
        ref $_[0] eq 'HASH' ? %{+shift} :
        (@_ % 2 == 0) ? @_ :
        throw_usage("Argument to merge_defaults() must be a hash or hash reference");
    for my $name ( keys %{$self->{spec}} ) {
        my $spec = $self->{spec}{$name};
        my $strip = $self->{strip}{$name};
        next unless exists $merge{$strip};
        for ( $self->{spec}{$name}{type} ) {
            /switch|counter|parameter/ && do {
                $self->{default}{$strip} = $merge{$strip};
                last;
            };
            /list/ && do {
                throw_usage("Option '$strip' in merge_defaults() must be scalar or array reference")
                    if ref($merge{$strip}) && ref($merge{$strip}) ne 'ARRAY';
                $merge{$strip} = ref($merge{$strip}) eq 'ARRAY'
                    ? dclone( $merge{$strip} )
                    : [ $merge{$strip} ] ;
                $self->{default}{$strip} = $merge{$strip};
                last;
            };
            /keypair/ && do {
                throw_usage("Option '$strip' in merge_defaults() must be scalar or hash reference")
                    if ref($merge{$strip}) && ref($merge{$strip}) ne 'HASH';
                $self->{default}{$strip} = dclone($merge{$strip});
                last;
            };
        }
        throw_spec("Default '$spec->{canon}' = '$self->{default}{$strip}' fails to validate")
          unless _validate_value($self, $self->{default}{$strip}, $spec->{valid} );
    }
    _recalculate_options($self);
    return $self->options;
}

#--------------------------------------------------------------------------#
# names()
#--------------------------------------------------------------------------#

sub names {
    my ($self) = @_;
    return values %{$self->{strip}};
}


#--------------------------------------------------------------------------#
# options()
#--------------------------------------------------------------------------#

sub options {
    my ($self) = @_;
    return %{dclone($self->{options})};
}

#--------------------------------------------------------------------------#
# replace_defaults()
#--------------------------------------------------------------------------#

sub replace_defaults {
    my $self = shift;
    my %replace =
        ref $_[0] eq 'HASH' ? %{+shift} :
        (@_ % 2 == 0) ? @_ :
        throw_usage("Argument to replace_defaults() must be a hash or hash reference");
    for my $name ( keys %{$self->{spec}} ) {
        my $spec = $self->{spec}{$name};
        my $strip = $self->{strip}{$name};
        for ( $self->{spec}{$name}{type} ) {
            /switch|counter/ && do {
                $self->{default}{$strip} = $replace{$strip} || 0;
                last;
            };
            /parameter/ && do {
                $self->{default}{$strip} = $replace{$strip};
                last;
            };
            /list/ && do {
                throw_usage("Option '$strip' in replace_defaults() must be scalar or array reference")
                    if ref($replace{$strip}) && ref($replace{$strip}) ne 'ARRAY';
                if ( exists $replace{$strip} ) {
                    $replace{$strip} = ref($replace{$strip}) eq 'ARRAY' ?
                                       $replace{$strip} : [ $replace{$strip} ];
                } else {
                    $replace{$strip} = [];
                }
                $self->{default}{$strip} = dclone($replace{$strip});
                last;
            };
            /keypair/ && do {
                throw_usage("Option '$strip' in replace_defaults() must be scalar or hash reference")
                    if ref($replace{$strip}) && ref($replace{$strip}) ne 'HASH';
                $replace{$strip} = {} unless exists $replace{$strip};
                $self->{default}{$strip} = dclone($replace{$strip});
                last;
            };
        }
        throw_spec("Default '$spec->{canon}' = '$self->{default}{$strip}' fails to validate")
          unless _validate_value($self, $self->{default}{$strip}, $spec->{valid} );
    }
    _recalculate_options($self);
    return $self->options;
}

#--------------------------------------------------------------------------#
# reset_defaults()
#--------------------------------------------------------------------------#

sub reset_defaults {
    my ($self) = @_;
    _set_defaults($self);
    _recalculate_options($self);
    return $self->options;
}

#--------------------------------------------------------------------------#
# usage()
#--------------------------------------------------------------------------#

sub usage {
    my ($self) = @_;
    my @short_opts;
    my @doc;
    for my $opt ( sort { $a->{strip} cmp $b->{strip} } values %{$self->{spec}} ) {
        my $names = [ @{ $opt->{names} } ];
        push @doc, [
            _build_usage_left_column( $names, \@short_opts ),
            _build_usage_right_column( $opt->{doc}, $opt->{default}, $opt->{type} ),
        ];
    }

    my $max_width = 3 + List::Util::max( map { length } @doc );

    my $prog = File::Basename::basename($0);

    local $" = '';
    my $usage = "Usage: $prog [-@short_opts] [long options] [arguments]\n"
      . join( "", map { sprintf( "\t%-${max_width}s %s\n", @$_ ) } @doc );
}

sub _build_usage_left_column {
    my ($names, $all_short_opts) = @_;
    my @sorted_names =
      sort { length $a <=> length $b } map { my $s = $_; $s =~ s/^-*//; $s } @$names;

    my @short_opts = grep { length == 1 } @sorted_names;
    my @long_opts  = grep { length > 1 } @sorted_names;

    push @$all_short_opts, @short_opts;

    my $group = sub {
        my $list = shift;
        '-' . ( @$list == 1 ? $list->[0] : '[' . join( '|', @$list ) . ']' );
    };
    my $prepare = sub {
        my $list = shift;
        return ( length $list->[0] > 1 ? '-' : '' ) . $group->($list) if @$list;
        return;
    };

    return join ', ' => map { $prepare->($_) } \@short_opts, \@long_opts;
}

sub _build_usage_right_column {
    my ( $doc, $default, $type ) = @_;
    my $str = defined $doc ? $doc : '';
    return $str unless defined $default;
    $str .= " " if length $str;
    $str .= "(default: ";
    if ($type eq 'list') {
        $str .= join( ", ", @$default );
    }
    elsif ( $type eq 'keypair' ) {
        $str .= join( ", ", map { "$_=$default->{$_}" } sort keys %$default );
    }
    else {
        $str .= $default
    }
    $str .= ')';
    return $str;
}

#--------------------------------------------------------------------------#
# _check_prereqs()
#--------------------------------------------------------------------------#

sub _check_prereqs {
    my ($self) = @_;
    for my $key ( keys %{$self->{seen}} ) {
        next unless $self->{seen}{$key};
        next unless exists $self->{spec}{$key}{needs};
        for (@{$self->{spec}{$key}{needs}}) {
            throw_argv("Option '$self->{spec}{$key}{canon}' ".
                       "requires option '$self->{spec}{$_}{canon}'")
                unless $self->{seen}{$_};
        }
    }
}

#--------------------------------------------------------------------------#
# _counter()
#--------------------------------------------------------------------------#

sub _counter {
    my ($self, $arg, $val, $neg) = @_;
    throw_argv("Counter option can't take a value: $self->{spec}{$arg}{canon}=$val")
        if defined $val;
    push @{$self->{parsed}}, [ $arg, 1, $neg ];
}

#--------------------------------------------------------------------------#
# _find_arg()
#--------------------------------------------------------------------------#

sub _find_arg {
    my ($self, $arg) = @_;

    $arg =~ s/^-*// unless $self->{strict};
    return $self->{alias_hr}{$arg} if exists $self->{alias_hr}{$arg};

    for ( keys %{$self->{alias_nocase}} ) {
        return $self->{alias_nocase}{$_} if $arg =~ /^$_$/i;
    }

    return;
}

#--------------------------------------------------------------------------#
# _keypair()
#--------------------------------------------------------------------------#

sub _keypair {
    my ($self, $arg, $val, $neg) = @_;
    my ($key, $data);
    if ($neg) {
        $key = $val;
    }
    else {
        my $value = defined $val ? $val : shift @{$self->{target}};
        if (! defined $val && ! defined $value) {
            throw_argv("Option '$self->{spec}{$arg}{canon}' requires a value");
        }

        throw_argv("Badly formed keypair for '$self->{spec}{$arg}{canon}'")
            unless $value =~ /[^=]+=.+/;
        ($key, $data) = ( $value =~ /^([^=]*)=(.*)$/ ) ;
        throw_argv("Invalid keypair '$self->{spec}{$arg}{canon}': $key => $data")
            unless _validate_value($self, { $key => $data },
                               $self->{spec}{$arg}{valid});
    }
    push @{$self->{parsed}}, [ $arg, [ $key, $data ], $neg ];
}

#--------------------------------------------------------------------------#
# _list()
#--------------------------------------------------------------------------#

sub _list {
    my ($self, $arg, $val, $neg) = @_;
    my $value;
    if ($neg) {
        $value = $val;
    }
    else {
        $value = defined $val ? $val : shift @{$self->{target}};
        if (! defined $val) {
            if (! defined $value) {
                throw_argv("Option '$self->{spec}{$arg}{canon}' requires a value");
            }
            $value =~ s/^$NEGATIVE(.*)$/$1/;
        }

        throw_argv("Ambiguous value for $self->{spec}{$arg}{canon} could be option: $value")
            if ! defined $val and _find_arg($self, $value);
        throw_argv("Invalid list option $self->{spec}{$arg}{canon} = $value")
            unless _validate_value($self, $value, $self->{spec}{$arg}{valid});
    }
    push @{$self->{parsed}}, [ $arg, $value, $neg ];
}

#--------------------------------------------------------------------------#
# _parameter()
#--------------------------------------------------------------------------#

sub _parameter {
    my ($self, $arg, $val, $neg) = @_;
    my $value;
    if ($neg) {
        throw_argv("Negated parameter option can't take a value: $self->{spec}{$arg}{canon}=$val")
            if defined $val;
    }
    else {
        $value = defined $val ? $val : shift @{$self->{target}};
        if (! defined $val) {
            if (! defined $value) {
                throw_argv("Option '$self->{spec}{$arg}{canon}' requires a value");
            }
            $value =~ s/^$NEGATIVE(.*)$/$1/;
        }
        throw_argv("Ambiguous value for $self->{spec}{$arg}{canon} could be option: $value")
            if ! defined $val and _find_arg($self, $value);
        throw_argv("Invalid parameter $self->{spec}{$arg}{canon} = $value")
            unless _validate_value($self, $value, $self->{spec}{$arg}{valid});
    }
    push @{$self->{parsed}}, [ $arg, $value, $neg ];
}

#--------------------------------------------------------------------------#
# _parse_spec()
#--------------------------------------------------------------------------#

sub _parse_spec {
    my ($self) = @_;
    my $spec = $self->{raw_spec};
    for my $v ( @$spec ) {
        my $type = ref $v;
        throw_spec(
            "'$type' is not a valid option type"
        ) unless $type eq 'Getopt::Lucid::Spec';
    }
    for my $opt ( map { $_->_clone } @$spec ) {
        my $name = $opt->{name};
        my @names = split( /\|/, $name );
        $opt->{canon} = $names[0];
        _validate_spec($self,\@names,$opt);
        $opt->{names} = \@names;
        ($opt->{strip} = $names[0]) =~ s/^-+//;
        @names = map { s/^-*//; $_ } @names unless $self->{strict}; ## no critic
        for (@names) {
            $self->{alias_hr}{$_} = $names[0];
            $self->{alias_nocase}{$_} = $names[0]  if $opt->{nocase};
        }
        $self->{spec}{$names[0]} = $opt;
        $self->{strip}{$names[0]} = $opt->{strip};
    }
    _validate_prereqs($self);
}

#--------------------------------------------------------------------------#
# _recalculate_options()
#--------------------------------------------------------------------------#

sub _recalculate_options {
    my ($self) = @_;
    my %result;
    for my $k ( keys %{$self->{default}} ) {
        my $d = $self->{default}{$k};
        $result{$k} = ref($d) eq 'ARRAY' ? [ @$d ] :
                      ref($d) eq 'HASH'  ? { %$d } : $d;
    }
    for my $opt ( @{$self->{parsed}} ) {
        my ($name, $value, $neg) = @$opt;
        for ($self->{spec}{$name}{type}) {
            my $strip = $self->{strip}{$name};
            /switch/    && do {
                $result{$strip} = $neg ? 0 : $value;
                last;
            };
            /counter/   && do {
                $result{$strip} = $neg ? 0 : $result{$strip} + $value;
                last;
            };
            /parameter/ && do {
                $result{$strip} = $neg ? "" : $value;
                last;
            };
            /list/      && do {
                if ($neg) {
                    $result{$strip} = $value ?
                        [ grep { $_ ne $value } @{$result{$strip}} ] :
                        [];
                }
                else { push @{$result{$strip}}, $value }
                last;
            };
            /keypair/   && do {
                if ($neg) {
                    if ($value->[0]) { delete $result{$strip}{$value->[0]} }
                    else { $result{$strip} = {} }
                }
                else { $result{$strip}{$value->[0]} = $value->[1]};
                last;
            };
        }
    }
    return $self->{options} = \%result;
}

#--------------------------------------------------------------------------#
# _regex_or_code
#--------------------------------------------------------------------------#

sub _regex_or_code {
    my ($value,$valid) = @_;
    return 1 unless defined $valid;
    if ( ref($valid) eq 'CODE' ) {
        local $_ = $value;
        return $valid->($value);
    } else {
        return $value =~ /^$valid$/;
    }
}

#--------------------------------------------------------------------------#
# _set_defaults()
#--------------------------------------------------------------------------#

sub _set_defaults {
    my ($self) = @_;
    my %default;
    for my $k ( keys %{$self->{spec}} ) {
        my $spec = $self->{spec}{$k};
        my $d = exists ($spec->{default}) ? $spec->{default} : undef;
        my $type = $self->{spec}{$k}{type};
        my $strip = $self->{strip}{$k};
        throw_spec("Default for list '$spec->{canon}' must be array reference")
            if ( $type eq "list" && defined $d && ref($d) ne "ARRAY" );
        throw_spec("Default for keypair '$spec->{canon}' must be hash reference")
            if ( $type eq "keypair" && defined $d && ref($d) ne "HASH" );
        if (defined $d) {
          throw_spec("Default '$spec->{canon}' = '$d' fails to validate")
            unless _validate_value($self, $d, $spec->{valid});
        }
        $default{$strip} = do {
            local $_ = $type;
            /switch/    ?   (defined $d ? $d: 0)   :
            /counter/   ?   (defined $d ? $d: 0)   :
            /parameter/ ?   $d :
            /list/      ?   (defined $d ? dclone($d): [])  :
            /keypair/   ?   (defined $d ? dclone($d): {})  :
                            undef;
        };
    }
    $self->{default} = \%default;
}

#--------------------------------------------------------------------------#
# _split_equals()
#--------------------------------------------------------------------------#

sub _split_equals {
    my ($self,$raw) = @_;
    my ($arg,$val);
    if ( $raw =~ /^($NEGATIVE?$VALID_NAME|$SHORT_BUNDLE)=(.*)/ ) {
        $arg = $1;
        $val = $2;
    } else {
        $arg = $raw;
    }
    return ($arg, $val);
}

#--------------------------------------------------------------------------#
# _switch()
#--------------------------------------------------------------------------#

sub _switch {
    my ($self, $arg, $val, $neg) = @_;
    throw_argv("Switch can't take a value: $self->{spec}{$arg}{canon}=$val")
        if defined $val;
    if (! $neg ) {
        throw_argv("Switch used twice: $self->{spec}{$arg}{canon}")
            if $self->{seen}{$arg} > 1;
    }
    push @{$self->{parsed}}, [ $arg, 1, $neg ];
}

#--------------------------------------------------------------------------#
# _unbundle()
#--------------------------------------------------------------------------#

sub _unbundle {
    my ($self,$arg, $val) = @_;
    if ( $arg =~ /^$SHORT_BUNDLE$/ ) {
        my @flags = split(//,substr($arg,1));
        unshift @{$self->{target}}, ("-" . pop(@flags) . "=" . $val)
            if defined $val;
        for ( reverse @flags ) {
            unshift @{$self->{target}}, "-$_";
        }
        return 1;
    }
    return 0;
}

#--------------------------------------------------------------------------#
# _validate_prereqs()
#--------------------------------------------------------------------------#

sub _validate_prereqs {
    my ($self) = @_;
    for my $key ( keys %{$self->{spec}} ) {
        next unless exists $self->{spec}{$key}{needs};
        my $needs = $self->{spec}{$key}{needs};
        my @prereq = ref($needs) eq 'ARRAY' ? @$needs : ( $needs );
        for (@prereq) {
            throw_spec("Prerequisite '$_' for '$self->{spec}{$key}{canon}' is not recognized")
                unless _find_arg($self,$_);
            $_ = _find_arg($self,$_);
        }
        $self->{spec}{$key}{needs} = \@prereq;
    }
}


#--------------------------------------------------------------------------#
# _validate_spec()
#--------------------------------------------------------------------------#

sub _validate_spec {
    my ($self,$names,$details) = @_;
    for my $name ( @$names ) {
        my $alt_name = $name;
        $alt_name =~ s/^-*// unless $self->{strict};
        throw_spec(
            "'$name' is not a valid option name/alias"
        ) unless $name =~ /^$VALID_NAME$/;
        throw_spec(
            "'$name' is not unique"
        ) if exists $self->{alias_hr}{$alt_name};
        my $strip;
        ($strip = $name) =~ s/^-+//;
        throw_spec(
            "'$strip' conflicts with other options"
        ) if grep { $strip eq $_ } values %{$self->{strip}};
    }
    for my $key ( keys %$details ) {
        throw_spec(
            "'$key' is not a valid option specification key"
        ) unless grep { $key eq $_ } @valid_keys;
    }
    my $type = $details->{type};
    throw_spec(
        "'$type' is not a valid option type"
    ) unless grep { $type eq $_ } @valid_types;
}

#--------------------------------------------------------------------------#
# _validate_value()
#--------------------------------------------------------------------------#

sub _validate_value {
    my ($self, $value, $valid) = @_;
    return 1 unless defined $valid;
    if ( ref($value) eq 'HASH' ) {
        my $valid_key = $valid->[0];
        my $valid_val = $valid->[1];
        while (my ($k,$v) = each %$value) {
            _regex_or_code($k, $valid_key) or return 0;
            _regex_or_code($v, $valid_val) or return 0;
        }
        return 1;
    } elsif ( ref($value) eq 'ARRAY' ) {
        for (@$value) {
            _regex_or_code($_, $valid) or return 0;
        }
        return 1;
    } else {
        return _regex_or_code($value, $valid);
    }
}

#--------------------------------------------------------------------------#
# AUTOLOAD()
#--------------------------------------------------------------------------#

sub AUTOLOAD {
    my $self = shift;
    my $name = $Getopt::Lucid::AUTOLOAD;
    $name =~ s/.*:://;   # strip fully-qualified portion
    return if $name eq "DESTROY";
    my ($action, $maybe_opt) = $name =~ /^(get|set)_(.+)/ ;
    if ($action) {
        # look for a match
        my $opt;
        SEARCH:
        for my $known_opt ( values %{ $self->{strip} } ) {
            if ( $maybe_opt eq $known_opt ) {
                $opt = $known_opt;
                last SEARCH;
            }
            # try without dashes
            (my $fuzzy_opt = $known_opt) =~ s/-/_/g;
            if ( $maybe_opt eq $fuzzy_opt ) {
                $opt = $known_opt;
                last SEARCH;
            }
        }

        # throw if no valid option was found
        throw_usage("Can't $action unknown option '$maybe_opt'")
            if ! $opt;

        # handle the accessor if an option was found
        if ($action eq "set") {
            $self->{options}{$opt} =
                ref($self->{options}{$opt}) eq 'ARRAY' ? [@_] :
                ref($self->{options}{$opt}) eq 'HASH'  ? {@_} : shift;

        }
        my $ans = $self->{options}{$opt};
        return ref($ans) eq 'ARRAY' ? @$ans :
               ref($ans) eq 'HASH'  ? %$ans : $ans;
    }
    my $super = "SUPER::$name";
    $self->$super(@_);
}

1; # modules must be true

__END__