File Coverage

blib/lib/Getopt/Long/Spec/Parser.pm

Criterion	Covered	Total	%
statement	97	98	98.9
branch	60	76	78.9
condition	18	23	78.2
subroutine	10	10	100.0
pod	2	2	100.0
total	187	209	89.4

use strict;
use warnings;

package Getopt::Long::Spec::Parser;
{
  $Getopt::Long::Spec::Parser::VERSION = '0.002';
}

# ABSTRACT: Parse a Getopt::Long option spec into a set of attributes
use Carp;
use Data::Dumper;

# holds the current opt spec, used for error and debugging code...
my $CUR_OPT_SPEC;

# holds the parameters for the current parse
my $CUR_OPTS;

sub new {
    my ( $class, %params ) = @_;
    my $self = bless {%params}, $class;
    return $self;
}

sub parse {
    my ( $self, $spec, $params ) = @_;

    # temporary globals...
    $CUR_OPT_SPEC = $spec;
    $CUR_OPTS = { %{ $params || {} }, %{ ref( $self ) ? $self : {} } };

    print "DEBUG: spec: [$spec]\n" if $CUR_OPTS->{debug};
    print "DEBUG: params: " . Dumper $CUR_OPTS if $CUR_OPTS->{debug};

    croak "Invalid option specification: [$spec]"
        if $spec !~ /^ ([|a-zA-Z_-]+) ([=:!+]?) (.*) /x;

    my $name_spec = $1;
    my $opt_type  = $2 ? $2 : '';
    my $arg_spec  = $3 ? $3 : '';

    my %name_params = $self->_process_name_spec( $name_spec );
    my %arg_params = $self->_process_arg_spec( $opt_type, $arg_spec );

    ### It is necessary to compute these here for compat. with GoL
    ### I feel that this block should be relocated... but WHERE?
    if ( $arg_params{negatable} ) {
        my @neg_names = $self->_generate_negation_names(
            $name_params{long},
            $name_params{short},
            @{ $name_params{aliases} },
        );
        push @{ $name_params{negations} }, @neg_names;
    }

    undef $CUR_OPT_SPEC;  # done with global var.
    undef $CUR_OPTS;      # ditto

    my %result = ( %name_params, %arg_params );

    return wantarray ? %result : \%result;
}

our $NAME_SPEC_QR = qr{
    ( [a-zA-Z_-]+ )            # option name as $1
    (
      (?: [|] [a-zA-Z?_-]+ )*  # aliases as $2 (split on |)
    )
}x;

sub _process_name_spec {
    my ( $self, $spec ) = @_;

    croak "Could not parse the name part of the option spec [$CUR_OPT_SPEC]."
        if $spec !~ $NAME_SPEC_QR;

    my %params;

    $params{long}    = $1;
    $params{aliases} = [
        grep { defined $_ }
            map {
                  ( length( $_ ) == 1 and !$params{short} )
                ? ( $params{short} = $_ and undef )
                : $_
            }
            grep { $_ }
            split( '[|]', $2 )
    ];

    return %params;
}

our $ARG_SPEC_QR = qr{
    (?:
        ( [siof] )    # value_type as $1
      | ( \d+ )       # default_num as $2 (not always valid)
      | ( [+] )       # increment type as $3    (not always valid)
    )
    ( [@%] )?         # destination data type as $4
    (?:
        [{]
        (\d+)?        # min_vals as $5
        (?:
            [,]
            (\d*)?    # max_vals as $6
        )?
        [}]
    )?
}x;

sub _process_arg_spec {
    my ( $self, $opt_type, $arg_spec ) = @_;

    # do some validation and set some params based on the option type
    my %params = $self->_process_opt_type( $opt_type, $arg_spec );

    return %params unless $arg_spec;

    # parse the arg spec...
    croak "Could not parse the argument part of the option spec [$CUR_OPT_SPEC]\n"
        if $arg_spec !~ $ARG_SPEC_QR;
    my $val_type      = $1;                # [siof]
    my $default_num   = $2;                # \d+
    my $incr_type     = $3;                # \+
    my $dest_type     = $4;                # [@%]
    $params{min_vals} = $5 if defined $5;  # \d+
    $params{max_vals} = $6 if defined $6;  # \d+

    croak "can't use an + here unless opt_type is ':'\n"
        if defined $incr_type and $opt_type ne ':';
    if ( defined $incr_type ) {
        $params{opt_type} = 'incr';
    }

    croak "can't use a default number unless opt_type is ':'\n"
        if defined $default_num and $opt_type ne ':';
    if ( defined $default_num ) {
        $params{default_num} = $default_num;
    }

    croak "can't specify a val_type unless opt_type is ':' or '='\n"
        if defined $val_type and $opt_type !~ /[:=]/;

    croak "repeat can only be used with a required value\n"
        if ( exists $params{min_vals} or exists $params{max_vals} )
        and $opt_type ne '=';

    # one repetition value, no comma...
    if ( exists $params{min_vals} and !exists $params{max_vals} ) {
        $params{num_vals} = delete $params{min_vals};
    }

    if ( $val_type ) {
        $params{val_type} =
              $val_type eq 's' ? 'string'
            : $val_type eq 'i' ? 'integer'
            : $val_type eq 'o' ? 'extint'
            : $val_type eq 'f' ? 'real'
            : die "This should never happen. Ever.";
        $params{opt_type} = 'simple';
    }

    if ( defined $dest_type ) {
        $params{dest_type} =
              $dest_type eq '%' ? 'hash'
            : $dest_type eq '@' ? 'array'
            : croak "Invalid destination type [$dest_type]\n";
    }

    return %params;
}

# About the optiontype...
#   = - option requires an argument
#   : - option argument optional (defaults to '' or 0)
#   ! - option is a flag and may be negated (0 or 1)
#   + - option is an int starting at 0 and incremented each time specified
#     - option is a flag to be turned on when used
sub _process_opt_type {
    my ( $self, $opt_type, $arg_spec ) = @_;

    my %params;

    # set params and do some checking based on what we now know...
    if ( $opt_type =~ /[+!]|^$/ ) {
        if ( $arg_spec ) {
            croak "Invalid option spec [$CUR_OPT_SPEC]: option type "
                . "[$opt_type] does not take an argument spec.";
        }
        if ( $opt_type eq '+' ) {
            $params{opt_type} = 'incr';
        }
        if ( $opt_type eq '!' ) {
            $params{opt_type}  = 'flag';
            $params{negatable} = 1;
        }
        if ( $opt_type eq '' ) {
            $params{opt_type} = 'flag';
        }
        return %params;
    }

    $params{opt_type} = 'simple';

    if ( $opt_type eq '=' ) {
        $params{val_required} = 1;
    }
    elsif ( $opt_type eq ':' ) {
        $params{val_required} = 0;
    }
    else {
        croak "Invalid option spec [$CUR_OPT_SPEC]: option type [$opt_type] is invalid.\n";
    }

    if ( !$arg_spec ) {
        croak "Invalid option spec [$CUR_OPT_SPEC]: option type "
            . "[$opt_type] requires an argument spec.\n";
    }

    return %params;
}

### if the spec shows that negation is allowed,
### generate "no* names" for each name and alias.
sub _generate_negation_names {
    my ( $self, @names ) = @_;
    my @neg_names = map { ( "no-$_", "no$_" ) } grep { length } @names;
    return @neg_names;
}

1 && q{there's nothing like re-inventing the wheel!};  # truth


=pod

=head1 NAME

Getopt::Long::Spec::Parser - Parse a Getopt::Long option spec into a set of attributes

=head1 VERSION

version 0.002

=head1 SYNOPSIS

This module parses an option specification as would normally be used with
Getopt::Long, and produces a hash showing the meaning/parameters the spec
describes... if that makes any sense at all...

Perhaps a little code snippet.

    use Getopt::Long::Spec::Parser;

    my $parser = Getopt::Long::Spec::Parser->new();
    my %spec_info = $parser->parse( 'foo|f=s@{1,5}' );

    # OR...

    my %spec_info =
        Getopt::Long::Spec::Parser->parse( 'foo|f=s@{1,5}' );

%spec_info should be a hash containing info about the parsed Getopt::Long
option specification

=head1 METHODS

=head2 new

construct a new parser.

    my $parser = Getopt::Long::Spec::Parser->new();
    # OR...
    my $parser = Getopt::Long::Spec::Parser->new(
        debug => 1,
    );

=head2 parse

parse an option specification

    my %spec_info = $parser->parse( 'foo' );
    # OR...
    my %spec_info = Getopt::Long::Spec::Parser->parse( 'foo' );

return the info parsed from the spec as a hash, or hashref,
depending on context.

In scalar context, returns a hashref, in list context, returns a hash.

=head1 NOTES on PARSING Getopt::Long OPTION SPECIFICATIONS

Described as a grammar:

  opt_spec  ::=  name_spec (arg_spec)?  # if no arg_spec, option is a flag.

  name_spec ::=  opt_name ("|" opt_alias)*
  opt_alias ::=  /\w+/
  opt_name  ::=  /\w+/

  arg_spec  ::= "="  val_type                (dest_type)? (repeat)?  # simple required
              | ":" (val_type | /\d+/ | "+") (dest_type)?            # simple optional
              | "!"                                                  # flag negatable
              | "+"                                                  # flag incremental

  arg_type  ::=  "s" | "i" | "o" | "f"              # string, integer, extint, float
  dest_type ::=  "@" | "%"                          # array or hash
  repeat    ::=  "{" (min_val)? ("," max_val)? "}"  # multiple-values per use
  min_vals  ::=  /\d+/
  max_vals  ::=  /\d*/

=head1 AUTHOR

Stephen R. Scaffidi

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2012 by Stephen R. Scaffidi.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut


__END__