view release on metacpan or  search on metacpan

lib/Getopt/Long/Spec/Parser.pm  view on Meta::CPAN

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