File Coverage

blib/lib/Getopt/EX/Hashed.pm

Criterion	Covered	Total	%
statement	221	237	93.2
branch	90	102	88.2
condition	25	30	83.3
subroutine	43	46	93.4
pod	7	7	100.0
total	386	422	91.4

package Getopt::EX::Hashed;

our $VERSION = '1.0701';

=encoding utf-8

=head1 NAME

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

=head1 VERSION

Version 1.0701

=head1 SYNOPSIS

  # script/foo
  use App::foo;
  App::foo->new->run();

  # lib/App/foo.pm
  package App::foo;

  use Getopt::EX::Hashed; {
      Getopt::EX::Hashed->configure( DEFAULT => [ is => 'rw' ] );
      has start    => ' =i  s begin ' , default => 1;
      has end      => ' =i  e       ' ;
      has file     => ' =s@ f       ' , 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->answer == 42) {
          $app->question //= 'life';
          ...

=cut

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

#
# Store metadata in caller context
#
my  %__DB__;

#
# Track objects created by new() to distinguish from Clone copies.
# Only "master" objects (created by new) are allowed to remove accessors
# on destruction, preventing clone objects from destroying shared class-level
# accessors that the original object still needs.
#
my %_masters;

#
# Get or create package-specific metadata storage namespace
# Returns a hash reference for storing member and config data
#
sub  __DB__ {
    my $caller = shift;
    state $pkg = __PACKAGE__ =~ s/::/_/gr;
    no strict 'refs';
    $__DB__{$caller} //= \%{"$caller\::$pkg\::__DB__"};
}

#
# Get or create member/configuration metadata array for a package
#
sub __Member__ { __DB__($_[0])->{Member} //= [] }
sub __Config__ { __DB__($_[0])->{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,
    REMOVE_ACCESSOR    => 1,
    DEFAULT            => [],
    INVALID_MSG        => \&_invalid_msg,
    );
lock_keys %DefaultConfig;

our @EXPORT = qw(has);

#
# Module import: set up inheritance, export functions, and initialize config
#
sub import {
    my $pkg = shift;
    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 "Failed to initialize config";
	lock_keys %$config;
    }
}

#
# Remove exported functions from caller's namespace
#
sub unimport {
    my $caller = caller;
    no strict 'refs';
    delete ${"$caller\::"}{$_} for @EXPORT;
}

#
# Configure package or object settings
# Can be called as class method or instance method
#
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 has wrong members";
	}
	$config->{$key} = $value;
    }
    return $class;
}

#
# Reset class to original state, clearing all members and config
#
sub reset {
    my $caller = caller;
    my $member = __Member__($caller);
    my $config = __Config__($caller);
    @$member = ();
    %$config = %DefaultConfig;
    return $_[0];
}

#
# Declare option parameters using DSL syntax
# Supports single or multiple option names and incremental updates with '+'
#
sub has {
    my($key, @param) = @_;
    if (@param % 2) {
	my $default = ref $param[0] eq 'CODE' ? 'action' : 'spec';
	unshift @param, $default;
    }
    my %param = @param;
    if (defined $param{spec} and $param{spec} =~ s/\s*#\s*(.*)//) {
	push @param, help => $1;
    }
    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 } keys @$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 ];
	}
    }
}

#
# Constructor: create hash object with initialized members and accessors
#
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 ];
	next if $name eq '<>';
	if (my $is = $param{is}) {
	    no strict 'refs';
	    my $sub = "$class\::" . $config->{ACCESSOR_PREFIX} . $name;
	    if (defined &$sub) {
		croak "&$sub already exists.\n";
	    }
	    $is = 'lv' if $is eq 'rw' && $config->{ACCESSOR_LVALUE};
	    *$sub = _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};
    $_masters{refaddr($obj)} = 1;
    $obj;
}

#
# Destructor: remove accessor methods from package namespace
#
sub DESTROY {
    my $obj = shift;
    return unless delete $_masters{refaddr($obj)};
    return unless $obj->_conf->{REMOVE_ACCESSOR};
    my $pkg = ref $obj;
    my $hash = do { no strict 'refs'; \%{"$pkg\::"} };
    my $prefix = $obj->_conf->{ACCESSOR_PREFIX};
    for (@{ $obj->_member }) {
	next unless $_->[1]->{is};
	my $name = $prefix . $_->[0];
	delete $hash->{$name} if exists $hash->{$name};
    }
}

#
# Generate option specification list for Getopt::Long
#
sub optspec {
    my $obj = shift;
    map $obj->_opt_pair($_), @{$obj->_member};
}

#
# Call GetOptions or GetOptionsFromArray with generated option specs
#
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.";
    }
}

#
# Add new keys to locked hash object
#
sub use_keys {
    my $obj = shift;
    unlock_keys %$obj;
    lock_keys_plus %$obj, @_;
}

#
# Get object's configuration hash
#
sub _conf   { $_[0]->{__Config__} }

#
# Get object's member metadata array
#
sub _member { $_[0]->{__Member__} }

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

#
# Generate option spec and destination pair for a member
#
sub _opt_pair {
    my $obj = shift;
    my $member = shift;
    my $spec_str = $obj->_opt_str($member) // return ();
    ( $spec_str => $obj->_opt_dest($member) );
}

#
# Generate option spec string from member definition
#
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);
}

#
# Compile option spec into Getopt::Long format
# Handles aliases and underscore conversion
#
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 "Multiple option specs found: @spec" }
    };
    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;
}

#
# Generate option destination (reference or coderef) with optional validation
#
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 };
	} elsif (ref $obj->{$name} eq 'SCALAR') {
	    $obj->{$name};
	} else {
	    \$obj->{$name};
	}
    }
}

#
# Validation test functions for min, max, must, and any parameters
#
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;
    },
    );

#
# Get applicable tester functions for a member
#
sub _tester {
    my $m = shift;
    map $tester{$_}, grep { defined $m->{$_} } keys %tester;
}

#
# Create validator coderef that combines multiple test functions
#
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;
    }
}

#
# Generic setter for array, hash, and scalar values
#
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] };
}

#
# Generate error message for option validation failures
#
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__