File Coverage

blib/lib/Getopt/EX/Hashed.pm

Criterion	Covered	Total	%
statement	199	213	93.4
branch	74	86	86.0
condition	23	28	82.1
subroutine	40	43	93.0
pod	7	7	100.0
total	343	377	90.9

package Getopt::EX::Hashed;

our $VERSION = '1.0501';

=head1 NAME

Getopt::EX::Hashed - Hash store object automation for Getopt::Long

=head1 VERSION

Version 1.0501

=head1 SYNOPSIS

  use App::foo;
  App::foo->new->run();

  package App::foo;

  use Getopt::EX::Hashed; {
      has start    => ' =i  s begin ' , default => 1;
      has end      => ' =i  e       ' ;
      has file     => ' =s@ f       ' , is => 'rw', any => qr/^(?!\.)/;
      has score    => ' =i          ' , min => 0, max => 100;
      has answer   => ' =i          ' , must => sub { $_[1] == 42 };
      has mouse    => ' =s          ' , any => [ 'Frankie', 'Benjy' ];
      has question => ' =s          ' , any => qr/^(life|universe|everything)$/i;
  } no Getopt::EX::Hashed;

  sub run {
      my $app = shift;
      use Getopt::Long;
      $app->getopt or pod2usage();
      if ($app->{start}) {
          ...

=cut

use v5.14;
use warnings;
use Hash::Util qw(lock_keys lock_keys_plus unlock_keys);
use Carp;
use Data::Dumper;
use List::Util qw(first);

# store metadata in caller context
my  %__DB__;
sub  __DB__ {
    $__DB__{$_[0]} //= do {
	no strict 'refs';
	state $sub = __PACKAGE__ =~ s/::/_/gr;
	\%{"$_[0]\::$sub\::__DB__"};
    };
}
sub __Member__ { __DB__(@_)->{Member} //= [] }
sub __Config__ { __DB__(@_)->{Config} //= {} }

my %DefaultConfig = (
    DEBUG_PRINT        => 0,
    LOCK_KEYS          => 1,
    REPLACE_UNDERSCORE => 1,
    REMOVE_UNDERSCORE  => 0,
    GETOPT             => 'GetOptions',
    GETOPT_FROM_ARRAY  => 'GetOptionsFromArray',
    ACCESSOR_PREFIX    => '',
    ACCESSOR_LVALUE    => 1,
    DEFAULT            => [],
    INVALID_MSG        => \&_invalid_msg,
    );
lock_keys %DefaultConfig;

our @EXPORT = qw(has);

sub import {
    my $caller = caller;
    no strict 'refs';
    push @{"$caller\::ISA"}, __PACKAGE__;
    *{"$caller\::$_"} = \&$_ for @EXPORT;
    my $config = __Config__($caller);
    unless (%$config) {
	unlock_keys %$config;
	%$config = %DefaultConfig or die "something wrong!";
	lock_keys %$config;
    }
}

sub unimport {
    my $caller = caller;
    no strict 'refs';
    delete ${"$caller\::"}{$_} for @EXPORT;
}

sub configure {
    my $class = shift;
    my $config = do {
	if (ref $class) {
	    $class->_conf;
	} else {
	    my $ctx = $class ne __PACKAGE__ ? $class : caller;
	    __Config__($ctx);
	}
    };
    while (my($key, $value) = splice @_, 0, 2) {
	if ($key eq 'DEFAULT') {
	    ref($value) eq 'ARRAY' or die "DEFAULT must be arrayref";
	    @$value % 2 == 0       or die "DEFAULT have wrong member";
	}
	$config->{$key} = $value;
    }
    return $class;
}

sub reset {
    my $caller = caller;
    my $member = __Member__($caller);
    my $config = __Config__($caller);
    @$member = ();
    %$config = %DefaultConfig;
    return $_[0];
}

sub has {
    my($key, @param) = @_;
    if (@param % 2) {
	my $default = ref $param[0] eq 'CODE' ? 'action' : 'spec';
	unshift @param, $default;
    }
    my @name = ref $key eq 'ARRAY' ? @$key : $key;
    my $caller = caller;
    my $member = __Member__($caller);
    for my $name (@name) {
	my $append = $name =~ s/^\+//;
	my $i = first { $member->[$_][0] eq $name } 0 .. $#{$member};
	if ($append) {
	    defined $i or die "$name: Not found\n";
	    push @{$member->[$i]}, @param;
	} else {
	    defined $i and die "$name: Duplicated\n";
	    my $config = __Config__($caller);
	    push @$member, [ $name, @{$config->{DEFAULT}}, @param ];
	}
    }
}

sub new {
    my $class = shift;
    my $obj = bless {}, $class;
    my $ctx = $class ne __PACKAGE__ ? $class : caller;
    my $master = __Member__($ctx);
    my $member = $obj->{__Member__} = [];
    my $config = $obj->{__Config__} = { %{__Config__($ctx)} }; # make copy
    for my $m (@$master) {
	my($name, %param) = @$m;
	push @$member, [ $name => \%param ];
	if (my $is = $param{is}) {
	    no strict 'refs';
	    my $access = $config->{ACCESSOR_PREFIX} . $name;
	    unless (${"$class\::"}{$access}) {
		$is = 'lv' if $config->{ACCESSOR_LVALUE} && $is eq 'rw';
		*{"$class\::$access"} = _accessor($is, $name);
	    }
	}
	$obj->{$name} = do {
	    local $_ = $param{default};
	    if    (ref eq 'ARRAY') {  [ @$_ ]  }
	    elsif (ref eq 'HASH' ) { ({ %$_ }) }
	    elsif (ref eq 'CODE' ) {  $_->()   }
	    else                   {  $_       }
	};
    }
    lock_keys %$obj if $config->{LOCK_KEYS};
    $obj;
}

sub optspec {
    my $obj = shift;
    map $obj->_opt_pair($_), @{$obj->_member};
}

sub getopt {
    my $obj = shift;
    if (@_ == 0) {
	my $getopt = caller . "::" . $obj->_conf->{GETOPT};
	no strict 'refs';
	$getopt->($obj->optspec());
    }
    elsif (@_ == 1 and ref $_[0] eq 'ARRAY') {
	my $getopt = caller . "::" . $obj->_conf->{GETOPT_FROM_ARRAY};
	no strict 'refs';
	$getopt->($_[0], $obj->optspec());
    }
    else {
	die "getopt: wrong parameter.";
    }
}

sub use_keys {
    my $obj = shift;
    unlock_keys %$obj;
    lock_keys_plus %$obj, @_;
}

sub _conf   { $_[0]->{__Config__} }

sub _member { $_[0]->{__Member__} }

sub _accessor {
    my($is, $name) = @_;
    {
	ro => sub {
	    $#_ and die "$name is readonly\n";
	    $_[0]->{$name};
	},
	rw => sub {
	    $#_ and do { $_[0]->{$name} = $_[1]; return $_[0] };
	    $_[0]->{$name};
	},
	lv => sub :lvalue {
	    $#_ and do { $_[0]->{$name} = $_[1]; return $_[0] };
	    $_[0]->{$name};
	},
    }->{$is} or die "$name has invalid 'is' parameter.\n";
}

sub _opt_pair {
    my $obj = shift;
    my $member = shift;
    my $spec_str = $obj->_opt_str($member) // return ();
    ( $spec_str => $obj->_opt_dest($member) );
}

sub _opt_str {
    my $obj = shift;
    my($name, $m) = @{+shift};

    $name eq '<>' and return $name;
    my $spec = $m->{spec} // return undef;
    if (my $alias = $m->{alias}) {
	$spec .= " $alias";
    }
    $obj->_compile($name, $spec);
}

sub _compile {
    my $obj = shift;
    my($name, $args) = @_;
    my @args  = split ' ', $args;
    my $spec_re = qr/[!+=:]/;
    my @spec  = grep  /$spec_re/, @args;
    my @alias = grep !/$spec_re/, @args;
    my $spec = do {
	if    (@spec == 0) { '' }
	elsif (@spec == 1) { $spec[0] }
	else               { die }
    };
    my @names = ($name, @alias);
    for ($name, @alias) {
	push @names, tr[_][-]r if /_/ && $obj->_conf->{REPLACE_UNDERSCORE};
	push @names, tr[_][]dr if /_/ && $obj->_conf->{REMOVE_UNDERSCORE};
    }
    push @names, '' if @names and $spec !~ /^($spec_re|$)/;
    join('|', @names) . $spec;
}

sub _opt_dest {
    my $obj = shift;
    my($name, $m) = @{+shift};

    my $action = $m->{action};
    if (my $is_valid = _validator($m)) {
	$action ||= \&_generic_setter;
	sub {
	    local $_ = $obj;
	    &$is_valid or die &{$obj->_conf->{INVALID_MSG}};
	    &$action;
	};
    }
    elsif ($action) {
	sub { &$action for $obj };
    }
    else {
	if (ref $obj->{$name} eq 'CODE') {
	    sub { &{$obj->{$name}} for $obj };
	} else {
	    \$obj->{$name};
	}
    }
}

my %tester = (
    min  => sub { $_[-1] >= $_->{min} },
    max  => sub { $_[-1] <= $_->{max} },
    must => sub {
	my $must = $_->{must};
	for $_ (ref($must) eq 'ARRAY' ? @$must : $must) {
	    return 0 if not &$_;
	}
	return 1;
    },
    any => sub {
	my $any = $_->{any};
	for (ref($any) eq 'ARRAY' ? @$any : $any) {
	    if (ref eq 'Regexp') {
		return 1 if $_[-1] =~ $_;
	    } elsif (ref eq 'CODE') {
		return 1 if &$_;
	    } else {
		return 1 if $_[-1] eq $_;
	    }
	}
	return 0;
    },
    );

sub _tester {
    my $m = shift;
    map $tester{$_}, grep { defined $m->{$_} } keys %tester;
}

sub _validator {
    my $m = shift;
    my @test = _tester($m) or return undef;
    sub {
	local $_ = $m;
	for my $test (@test) {
	    return 0 if not &$test;
	}
	return 1;
    }
}

sub _generic_setter {
    my $dest = $_->{$_[0]};
    (ref $dest eq 'ARRAY') ? do { push @$dest, $_[1] } :
    (ref $dest eq 'HASH' ) ? do { $dest->{$_[1]} = $_[2] }
                           : do { $_->{$_[0]} = $_[1] };
}

sub _invalid_msg {
    my $opt = do {
	$_[0] = $_[0] =~ tr[_][-]r;
	if (@_ <= 2) {
	    '--' . join '=', @_;
	} else {
	    sprintf "--%s %s=%s", @_[0..2];
	}
    };
    "$opt: option validation error\n";
}

1;

__END__