File Coverage

blib/lib/Getopt/Again.pm

Criterion	Covered	Total	%
statement	212	217	97.7
branch	68	80	85.0
condition	36	54	66.6
subroutine	35	37	94.5
pod	6	9	66.6
total	357	397	89.9

package Getopt::Again;
use strict;
use warnings;

use Carp qw/croak/;
use Scalar::Util qw/reftype/;

our $VERSION = '0.000003';

my %DEFAULTS = (
    ALL => {default => undef, list => 0, example => '', required => 0, process => undef},

    bool   => {default => 0},
    string => {example => ' "foo"'},
    path   => {example => ' "/foo/bar/"'},
    file   => {example => ' "/foo/bar.txt"'},
    regex  => {},
);

my %VALID_FIELDS = (
    type        => 1,
    list        => 1,
    default     => 1,
    example     => 1,
    process     => 1,
    description => 1,
    split_on    => 1,
    name        => 1,
    regex       => 1,
);

sub import {
    my $class  = shift;
    my $caller = caller;

    my $meta = $class->new(@_);

    my %exports = (
        opt_meta => sub { $meta },

        opt_bools => sub { $meta->add($_, type => 'bool',   default => 0) for @_ },
        opt_lists => sub { $meta->add($_, type => 'string', list    => 1) for @_ },

        opt_params => sub { $meta->add($_, type => 'string') for @_ },
        opt_paths  => sub { $meta->add($_, type => 'path')   for @_ },
        opt_files  => sub { $meta->add($_, type => 'file')   for @_ },

        opt_add   => sub { $meta->add(@_) },
        opt_usage => sub { $meta->usage_string(@_) },
        opt_help  => sub { $meta->help_string(@_) },
        opt_parse => sub { $meta->parse(@_) },

        opt_use_help => sub { $meta->help(@_) },
    );

    for my $name (keys %exports) {
        no strict 'refs';
        *{"$caller\::$name"} = $exports{$name};
    }
}

sub new {
    my $class  = shift;
    my %params = @_;

    my $self = bless {}, $class;

    for my $i (keys %params) {
        croak "Not an option '$i'" unless $self->can($i);
        $self->$i($params{$i});
    }

    return $self;
}

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

sub _pattern_params {
    my $self = shift;
    $self->{_pattern_params} ||= [];
    return $self->{_pattern_params};
}

sub _all_params {
    my $self = shift;
    $self->{_all_params} ||= [];
    return $self->{_all_params};
}

sub _clear_opt_cache {
    my $self = shift;
    delete $self->{opt_cache};
    return;
}

sub _gen_opt_cache {
    my $self = shift;

    my %seen;
    my %opts;
    for my $config (@{$self->_all_params}) {
        my ($f) = split '', $config->{name};
        if ($seen{$f}++) {
            delete $opts{$f}; # More than 1
        }
        else {
            $opts{$f} = $config;
        }
    }

    return {%opts, %{$self->_named_params}};
}

sub _reversed_opt_cache {
    my $self = shift;

    my $out = {};
    my $cache = $self->{opt_cache} ||= $self->_gen_opt_cache;
    for my $key (keys %$cache) {
        my $opt = $cache->{$key};
        if ($key eq $opt->{name}) {
            unshift @{$out->{$opt->{name}}} => $key;
        }
        else {
            push @{$out->{$opt->{name}}} => $key;
        }
    }

    return $out;
}

sub opt_spec {
    my $self = shift;
    my ($opt) = @_;

    $self->{opt_cache} ||= $self->_gen_opt_cache;

    my $config = $self->{opt_cache}->{$opt};
    return $config if $config;

    for my $config (@{$self->_pattern_params}) {
        next unless $opt =~ $config->{regex};
        return $config;
    }

    return;
}

sub add {
    my $self = shift;
    my ($name, @params) = @_;

    croak "name is required, and must not be a ref (got: " . ($name || '(UNDEF)') . ")"
        unless defined $name && !ref $name;

    $self->_clear_opt_cache;

    my %params = @params > 1 ? (@params) : (process => $params[0]);
    my $config = $self->process_opt(%params, name => $name);
    my $alias = $config->{alias};

    croak "Alias must be a string, or an array of strings"
        unless reftype $alias eq 'ARRAY';

    push @{$self->_all_params} => $config;

    if($config->{regex}) {
        push @{$self->_pattern_params} => $config;
    }

    for my $name (@$alias) {
        croak "Conflict, option '$name' was already defined by " . $self->_named_params->{$name}->{name}
            if $self->_named_params->{$name} && $self->_named_params->{$name} != $config;

        $self->_named_params->{$name} = $config;
    }
}

sub process_opt {
    my $self = shift;
    my %params = @_;

    my $type = delete $params{type};
    $type ||= ($params{regex} || length($params{name}) > 1)
        ? 'string'
        : 'bool';

    my $process = delete $params{process};
    croak "process must either be a coderef or a regexp (got: $process)"
        if $process && !(ref $process && reftype($process) =~ m/^(REGEXP|CODE)$/);

    my $alias = delete $params{alias} || [];
    $alias = [$alias] unless ref $alias;
    croak "alias must be a string, or an array strings, got: $alias"
        unless reftype $alias eq 'ARRAY';
    unshift @$alias => $params{name};

    for my $field (keys %params) {
        croak "'$field' is not a valid option field"
            unless $VALID_FIELDS{$field};
    }

    return {
        %{$DEFAULTS{ALL}},
        %{$DEFAULTS{$type}},
        %params,
        type  => $type,
        alias => $alias,
        process => $process,
    };
}

sub parse {
    my $self = shift;
    my @in = @_;

    my (%out, @out);

    my $no_parse = 0;
    while(my $item = shift @in) {
        if ($item eq '--') {
            $no_parse = 1;
            next;
        }

        if ($item =~ m/^(-{1,2})([^=]+)(?:=(.*))?$/ && !$no_parse) {
            my ($dash, $arg, $val) = ($1, $2, $3);
            $dash = length($dash);

            if($val) {
                $val =~ s/^'(.+)'$/$1/;
                $val =~ s/^"(.+)"$/$1/;
            }

            my @args;
            if ($dash > 1) {
                @args = ([$arg, $val]);
            }
            else {
                @args = split '', $arg;
                push @args => [ pop(@args), $val ];
            }

            for my $set (@args) {
                $self->_register($set, \@in, \%out);
            }
        }
        else {
            push @out => $item;
        }
    }

    $self->_populate(\%out);
    $self->_process(\%out);

    return (\%out, \@out);
}

sub _register {
    my $self = shift;
    my ($set, $in, $out) = @_;
    my ($name, $val);

    if (ref $set) {
        ($name, $val) = @$set;
    }
    else {
        $name = $set;
    }

    my $spec = $self->opt_spec($name);
    croak "Unknown option: '$name'" unless $spec;

    if ($spec->{type} eq 'bool') {
        $out->{$spec->{name}} = !$spec->{default} ? 1 : 0;
    }
    else {
        if ( $spec->{type} eq 'regex' && $name =~ $spec->{regex}) {
            $val = $1 || $';
        }
        elsif (!defined $val) {
            $val = shift @$in;
        }

        if ($spec->{list}) {
            $out->{$spec->{name}} ||= [];
            push @{$out->{$spec->{name}}} => $val;
        }
        else {
            $out->{$spec->{name}} = $val;
        }
    }
}

sub _populate {
    my $self = shift;
    my ($out) = @_;

    for my $opt (@{$self->_all_params}) {
        next if defined $out->{$opt->{name}};
        $out->{$opt->{name}} = $opt->{default};
        $out->{$opt->{name}} ||= [] if $opt->{list};
    }
}

sub _process {
    my $self = shift;
    my ($out) = @_;

    for my $opt (keys %$out) {
        my $spec = $self->opt_spec($opt);
        next unless defined $out->{$opt};

        # Split if requested
        $out->{$opt} = [ map { split $spec->{split_on}, $_ } @{$out->{$opt}} ]
            if $spec->{list} && defined $spec->{split_on};

        if ($spec->{process}) {
            my $type = reftype $spec->{process};
            if ($type eq 'CODE') {
                local $_ = $out->{$opt};
                $out->{$opt} = $spec->{process}->($out->{$opt});
            }
            else {
                my $items = $spec->{list} ? $out->{$opt} : [ $out->{$opt} ];
                for my $item (@$items) {
                    next if $item =~ $spec->{process};
                    die "Invalid value for '$opt', got: '$item'\n";
                }
            }
        }
    }
}

sub usage_string {
    my $self = shift;
    ($self->{usage_string}) = @_ if @_;
    $self->{usage_string} ||= "[-short_flags] [--long_flag] [--option '...'] [--option=...] arg1, arg2";
    return "$0 $self->{usage_string}";
}

sub opt_help_string {
    my $self = shift;
    my ($name) = @_;

    my $names = $self->_reversed_opt_cache;

    my $opt = $self->opt_spec($name) || die "Invalid option: $name";
    my $out = "  $name ($opt->{type})\n";
    for my $alias (@{$names->{$name}}) {
        $out .= "   " . (length($alias) > 1 ? '--' : '-') . $alias . $opt->{example} . "\n";
    }
    if ($opt->{regex}) {
        $out .= "   --$opt->{regex}\n"
    }
    $out .= $opt->{description} . "\n" if $opt->{description};
    $out .= "\n";

    return $out;
}

sub help_string {
    my $self = shift;
    my $names = $self->_reversed_opt_cache;

    print "Options:\n";

    my $out = "";
    for my $name (sort keys %$names) {
        $out .= $self->opt_help_string($name);
    }

    return $out;
}

# Inject a help parameter that exits 0
sub enable_help {
    my $self = shift;
    my ($bool) = @_;
    return unless $bool;

    $self->add('help' => (
        type => 'bool',
        alias => 'h',
        process => sub {
            return unless $_;
            print $self->usage_string;
            print "\n";
            print $self->help_string;
            print "\n";
            $self->_exit(0);
        },
    ));
}

sub _exit { shift; exit $_[0] };

1;

__END__