File Coverage

blib/lib/Filter/Arguments.pm

Criterion	Covered	Total	%
statement	150	153	98.0
branch	69	76	90.7
condition	31	36	86.1
subroutine	9	9	100.0
pod	1	5	20.0
total	260	279	93.1

package Filter::Arguments;

our $VERSION = '0.14';

use 5.0071;
use strict;
use warnings FATAL => 'all';
use Filter::Simple;

my @Identifiers;
my %Default_For;
my %Alias_For;

my $Retro_Arguments_Regex = qr{
    : \s* Arguments? \s*
    (?: [\(] .*? [\)] \s* )?
    ( = \s* [^;]+ )? ;
}msx;

my $Arguments_Regex = qr{
    ( [\@\$\%] \S+ \s* =  \s* )?
    Arguments? \s*
    ( [\(] .*? [\)] \s* )?
    (?= [,;\)\}\]] )
}msx;

my $Arguments_Usage_Regex = qr{
    Arguments?::verify_usage \s* (?: [\(] [\)] )?
}msx;

sub verify_usage {
    my $argv_ra = shift @_;
    my %arguments = @_;

    my $usage = "$0\n";
    my @errors;

    while ( my ($arg,$val) = each %arguments) {

        my $alias   = $Alias_For{$arg};
        my $default = $Default_For{$arg};

        $val ||= $default;

        if ( !defined $val ) {
            push @errors, "no value supplied for $arg";
        }

        $usage .= "  $alias";
        if ( defined $default ) {
            if ( length $default ) {
                $usage .= "\t(default is '$default')";
            }
            else {
                $usage .= "\t(default is empty string)";
            }
        }
        $usage .= "\n";
    }

    my %valid_alias = map { ( $Alias_For{$_} => 1 ) } keys %Alias_For;

    ARG:
    for my $arg (@{ $argv_ra }) {

        next ARG
            if $arg !~ m/\A --? /xms;

        if ( !defined $valid_alias{$arg} ) {

            if ( $arg =~ m{\A --? (?: help|usage|[?] ) \z}xms ) {
                push @errors, "Usage:";
            }
            else {
                push @errors, "unexpected argument $arg";
            }
        }
    }

    if ( @errors ) {

        for my $error (@errors) {
            warn "$error\n";
        }
        die "$usage\n";
    }
    return 1;
}

sub parse {
    my ( $identifier, $params_rh, $argv_ra ) = @_;

    $identifier =~ s{ (?: \A [\(]? \s* | \s* [\)]? ) }{}xmsg;

    if ( $identifier =~ m{,} ) {

        my @idents = split /\s*,\s*/, $identifier;
        my @results;
        for my $i ( 0 .. $#idents ) {

            my $ident  = $idents[$i];
            my %params = %{ $params_rh };

            if ( defined $params{default} && ref $params{default} eq 'ARRAY' ) {

                if ( $i <= $#{ $params{default} } ) {

                    $params{default} = $params{default}->[$i];
                }
                else {

                    delete $params{default};
                }
            }

            push @results, parse( $ident, \%params, $argv_ra );
        }
        return @results;
    }

    my ($sigil,$ident) = $identifier =~ m/\A ( \W+ ) ( \w+ ) \z/xms;
    $sigil ||= "";
    $ident ||= "";

    my $type
        = $sigil eq '@'            ? 'ARRAY'
        : $sigil eq '%'            ? 'HASH'
        : $ident =~ m/ _ra \z/xmsi ? 'ARRAY'
        : $ident =~ m/ _rh \z/xmsi ? 'HASH'
        :                            'SCALAR';

    my ($default,$alias);

    if ( $params_rh ) {

        if ( ref $params_rh eq 'HASH' ) {

            if ( defined $params_rh->{alias} ) {
                $alias = $params_rh->{alias};
            }

            if ( defined $params_rh->{default} ) {
                $default = $params_rh->{default};
            }

            if ( !$alias && !$default ) {

                ALIAS_DEFAULT:
                while ( my ($a,$d) = each %{ $params_rh } ) {

                    # Don't allow certain reserved words in this mode
                    # use: alias => 'default' when option --default is needed
                    # use: alias => 'alias' when option --alias is needed
                    next ALIAS_DEFAULT
                        if $a eq 'default' || $a eq 'alias';

                    ($alias,$default) = ($a,$d);
                }
            }
        }
    }

    $alias ||= $ident;
    $alias =~ s{ _r[ah] \z}{}xmsi;
    $alias = "--$alias";
    $alias =~ s{\A -{3,} }{--}xms;

    $Alias_For{$ident}   = $alias;
    $Default_For{$ident} = $default;

    if ( $type eq 'HASH' ) {

        my $key;
        my %arguments;

        ARG:
        for my $arg_index ( 0 .. $#{ $argv_ra } ) {

            my $arg = $argv_ra->[$arg_index];

            if ( $arg =~ m/\A --? /xms ) {

                $key = $arg;
                $key =~ s{\A [-]+ }{}xms;

                $arguments{$key} = [];
                next ARG;
            }
            else {

                if ( !$key ) {
                    $key = $alias;
                    $key =~ s{\A [-]+ }{}xms;
                }

                push @{ $arguments{$key} }, $arg;
            }
        }

        if ( !keys %arguments && $default ) {
            $key = $alias;
            $key =~ s{\A [-]+ }{}xms;
            $arguments{$key} = [ $default ];
        }

        for my $option (keys %arguments) {

            if ( @{ $arguments{$option} } == 0 ) {
                $arguments{$option} = 1;
            }
            elsif ( @{ $arguments{$option} } == 1 ) {
                $arguments{$option} = $arguments{$option}->[0];
            }
        }

        return %arguments
            if wantarray;

        return \%arguments;
    }

    ARG:
    for my $arg_index ( 0 .. $#{ $argv_ra } ) {

        my $next_index
            = $arg_index < $#{ $argv_ra }
            ? $arg_index + 1
            : undef;

        my $arg = $argv_ra->[$arg_index];

        next ARG
            if $arg ne $alias;

        if ( $type eq 'SCALAR' ) {

            my $value
                = defined $next_index
                ? $argv_ra->[$next_index]
                : 1;

            if ( $value =~ m/\A --? /xms ) {
                $value = $default || 1;
            }

            return $value;
        }
        elsif ( $type eq 'ARRAY' ) {

            my @values;

            VAL:
            for my $next_index ( $arg_index + 1 .. $#{ $argv_ra } ) {

                my $value = $argv_ra->[$next_index];

                last VAL
                    if $value =~ m/\A --? /xms;

                push @values, $value;
            }

            return @values
                if wantarray;

            return \@values;
        }
    }

    return @{ $default }
        if wantarray && $default && ref $default eq 'ARRAY';

    return $default;
}

sub retro_transform {
    my ($default) = @_;

    $default ||= "";

    if ( $default ) {

        $default =~ s{(?: \A [=\s]* | \s* \z )}{}xmsg;

        if ( $default =~ m{\A [\(] }xms ) {

            $default =~ s{(?: \A [\(] | \W \z )}{}xmsg;

            $default = "( default => [ $default ] )";
        }
        else {

            $default = "( default => '$default' )";
        }
    }

    return "= Arguments$default;";
}

sub transform {
    my ($assignment,$parameters) = @_;

    $assignment ||= "";
    $parameters ||= "";

    my $identifiers = $assignment;
    $identifiers =~ s{(?: \A \s* [^\@\$\%\(]* | \W* \z )}{}xmsg;
    $identifiers =~ s{\s*}{}xmsg;

    push @Identifiers, split /\s*,\s*/, $identifiers;

    return "${assignment}Filter::Arguments::parse(q{$identifiers},{$parameters},\\\@ARGV)";
}

sub usage {

    my $arg_string = "";

    for my $identifier (@Identifiers) {

        my $key = $identifier;
        my $val = $identifier;

        $key =~ s{\A \W }{}xmsg;

        $arg_string .= " $key => $val,";
    }

    return "Filter::Arguments::verify_usage(\\\@ARGV,$arg_string)";
}

FILTER_ONLY
	code_no_comments => sub {

        # for backward compatibility
        $_ =~ s{$Retro_Arguments_Regex}{retro_transform($1)}xmsge;

        $_ =~ s{$Arguments_Regex}{transform($1,$2)}xmsge;

        $_ =~ s{$Arguments_Usage_Regex}{usage()}xmsge;
	};

1;

__END__