File Coverage

lib/Getopt/Type/Tiny.pm

Criterion	Covered	Total	%
statement	113	118	95.7
branch	70	82	85.3
condition	18	27	66.6
subroutine	10	10	100.0
pod	1	1	100.0
total	212	238	89.0

package Getopt::Type::Tiny;

# ABSTRACT: Clean Getopt::Long wrapper with Type::Tiny support

use v5.20.0;
use warnings;
use experimental 'signatures';

use Type::Library -extends => [
    qw(
      Types::Standard
      Types::Common::Numeric
      Types::Common::String
    )
];

use Getopt::Long 'GetOptionsFromArray';
use Pod::Usage qw(pod2usage);
use Carp       qw(croak);

our $VERSION = '0.03';

push our @EXPORT_OK, qw(get_opts);

sub _infer_getopt_modifier ( $type, $coerce = 0 ) {

    # Use display_name since parameterized types have __ANON__ as name
    my $name = $type->display_name;

    # Check if it's ArrayRef or HashRef
    return unless $name =~ /^(ArrayRef|HashRef)/;

    my $container = $1;
    my $suffix    = $container eq 'ArrayRef' ? '@' : '%';

    # Get inner type parameter
    my $param = $type->type_parameter;
    return unless $param;    # Bare ArrayRef/HashRef - will error later

    # Check ancestry (order matters: Int before Num since Int is subtype of Num)
    my $sigil
      = $param->is_a_type_of(Int)       ? 'i'
      : $param->is_a_type_of(Num)       ? 'f'
      : $param->is_a_type_of(Str)       ? 's'
      : $param->equals(Any)             ? 's'
      : $coerce && $param->has_coercion ? 's'
      :                                   undef;

    return unless $sigil;
    return "=$sigil$suffix";
}

sub _validate_multi_value_type ( $name, $type, $coerce = 0 ) {

    # Use display_name since parameterized types have __ANON__ as name
    my $type_name = $type->display_name;

    # Only validate ArrayRef and HashRef
    return unless $type_name =~ /^(ArrayRef|HashRef)/;

    my $container = $1;
    my $param     = $type->type_parameter;

    unless ($param) {
        my $suffix = $container eq 'ArrayRef' ? '@' : '%';
        croak <<"END_ERROR";
Unsupported type '$type_name' for option '$name'.

ArrayRef and HashRef require a type parameter (e.g., ArrayRef[Str]).

To fix this, either:
  1. Use explicit GetOpt::Long syntax: '$name=s$suffix' => { isa => $type_name }
  2. Specify the inner type: ArrayRef[Str], ArrayRef[Int], or ArrayRef[Num]
END_ERROR
    }

    my $is_supported
      = $param->is_a_type_of(Int)
      || $param->is_a_type_of(Num)
      || $param->is_a_type_of(Str)
      || $param->equals(Any)
      || $coerce && $param->has_coercion;

    unless ($is_supported) {
        my $suffix = $container eq 'ArrayRef' ? '@' : '%';
        croak <<"END_ERROR";
Unsupported type '$type_name' for option '$name'.

GetOpt::Long only supports ArrayRef and HashRef with inner types that are
subtypes of Str, Int, or Num.

To fix this, either:
  1. Use explicit GetOpt::Long syntax: '$name=s$suffix' => { isa => $type_name }
  2. Simplify your type to ArrayRef[Str], ArrayRef[Int], or ArrayRef[Num]
END_ERROR
    }
}

sub get_opts (@arg_specs) {

    # forces Carp to ignore this package
    local $Carp::Internal{ +__PACKAGE__ } = 1;
    my %opt_for;         # store the options
    my @getopt_specs;    # the option specs
    my %defaults;        # default values
    my %renames;         # rename option keys
    my %types;           # type constraints
    my %coerce;          # should coerce?
    my %required;        # required options

    while (@arg_specs) {
        my $this_getopt_spec = shift @arg_specs;
        my $options          = is_HashRef( $arg_specs[0] ) ? shift @arg_specs : {};

        my ($name) = $this_getopt_spec =~ /^([\w_]+)/;

        if ( exists $options->{isa} ) {
            $types{$name} = $options->{isa};

            if ( $options->{coerce} && !$types{$name}->has_coercion ) {
                croak("Cannot coerce to a type without a coercion");
            }

            # Validate multi-value types (croaks if unsupported)
            _validate_multi_value_type(
                $name, $types{$name},
                $options->{coerce}
            );

            # Check for multi-value type inference
            my $inferred_modifier
              = _infer_getopt_modifier( $types{$name}, $options->{coerce} );

            if ($inferred_modifier) {

                # Multi-value type detected
                if ( $this_getopt_spec =~ /=[a-z][@%]$/ ) {

                    # Explicit modifier exists - check for mismatch
                    my ($explicit_modifier) = $this_getopt_spec =~ /(=[a-z][@%])$/;
                    if ( $explicit_modifier ne $inferred_modifier
                        && !$options->{nowarn} )
                    {
                        warn "Option '$name' has explicit spec '$explicit_modifier' but type '"
                          . $types{$name}->display_name
                          . "' suggests '$inferred_modifier'.\n"
                          . "Type::Tiny will still validate the values. "
                          . "Use 'nowarn => 1' to suppress this warning.\n";
                    }
                }
                else {
                    # No explicit modifier - append inferred one
                    $this_getopt_spec .= $inferred_modifier;
                }
            }
            elsif ($types{$name}->name ne 'Bool'
                && $this_getopt_spec !~ /=/ )
            {

                # Non-Bool scalar type without modifier
                if ( $this_getopt_spec =~ s/=[a-z]$/=s/ ) {

                    # Replaced explicit type with =s
                }
                else {
                    $this_getopt_spec .= '=s';
                }
            }
        }
        push @getopt_specs, $this_getopt_spec;

        if ( exists $options->{default} && exists $options->{required} ) {
            croak("Option '$name' cannot be both required and have a default value");
        }
        if ( exists $options->{default} ) {
            $defaults{$name} = $options->{default};
        }
        elsif ( exists $options->{isa} ) {

            # Auto-default for ArrayRef and HashRef
            my $type_name = $options->{isa}->display_name;
            if ( $type_name =~ /^ArrayRef/ ) {
                $defaults{$name} = [];
            }
            elsif ( $type_name =~ /^HashRef/ ) {
                $defaults{$name} = {};
            }
        }
        $renames{$name}  = $options->{rename} if exists $options->{rename};
        $required{$name} = $options->{required}
          if exists $options->{required};
        $coerce{$name} = $options->{coerce} if exists $options->{coerce};

        # If no type is specified and the option doesn't have =s or =i,
        # assume Bool
        $types{$name} //= Bool unless $this_getopt_spec =~ /=/;
    }

    # this has proven so incredibly useful that it's now a default,
    # but perhaps it should be optional. Will need to think of the cleanest
    # interface for that.
    push @getopt_specs, 'help|?';
    push @getopt_specs, 'man';

    # Note: this will mutate @ARGV if any options are present
    my $result = GetOptionsFromArray( \@ARGV, \%opt_for, @getopt_specs );

    if ( $opt_for{help} ) {
        pod2usage(1);
    }

    if ( $opt_for{man} ) {
        pod2usage( -exitval => 0, -verbose => 2 );
    }

    unless ($result) {
        croak( pod2usage(2) );
    }

    # Apply defaults
    for my $name ( keys %defaults ) {
        next if exists $opt_for{$name};
        $opt_for{$name}
          = is_CodeRef( $defaults{$name} )
          ? $defaults{$name}->()
          : $defaults{$name};
    }

    # Type checking
    for my $name ( keys %types ) {
        my $type   = $types{$name};
        my $coerce = $coerce{$name};
        if ( exists $opt_for{$name} && !$type->check( $opt_for{$name} ) ) {
            if ($coerce) {
                my $new_val = $type->coerce( $opt_for{$name} );
                if ( $type->check($new_val) ) {
                    $opt_for{$name} = $new_val;
                    next;
                }
            }
            croak( "Invalid value for option '$name': " . $type->get_message( $opt_for{$name} ) );
        }
    }

    # Check required options
    for my $name ( keys %required ) {
        if ( $required{$name} && !exists $opt_for{$name} ) {
            croak("Required option '$name' is missing");
        }
    }

    # Rename keys
    for my $name ( keys %renames ) {
        $opt_for{ $renames{$name} } = delete $opt_for{$name}
          if exists $opt_for{$name};
    }

    return %opt_for;
}
1;

__END__