view release on metacpan or  search on metacpan

lib/Getopt/LL.pm  view on Meta::CPAN

        }
        if ($options_ref->{style} eq 'GNU') {
            while (my ($option, $value) = each %DEFAULT_OPTIONS_GNU) {
                $options_ref->{$option} = $value;
            }
        }

        $self->set_options($options_ref);
        $self->rules_prepare($rules_ref);

        if (scalar @{ $argv_ref }) {
            $self->set_dll( Getopt::LL::DLList->new($argv_ref) );
            $self->_init();
        }

        $self->rules_postactions( );

        return $self;
    }

    #========================================================================
    #                           - INSTANCE METHODS -
    #========================================================================

    sub _init {
        my ($self) = @_;
        my $dll    = $self->dll;

        $end_processing = 0;
        $dll->traverse($self, 'parseoption');

        return $self->result;
    }

    sub rules_prepare {
        my ($self, $rules_ref) = @_;
        my $options_ref        = $self->options;
        my $help_ref           = $self->help;

        my %final_rules = ();
        my %aliases     = ();

    RULE:
        while (my ($rule_name, $rule_spec) = each %{$rules_ref}) {

            # User can type:
            #   '-arg'  => 'string',
            # instead of:
            #   '-arg'  => { type => 'string' }
            # and we will convert it here.
            if (ref $rule_spec ne 'HASH') {
                $rule_spec = {type => $rule_spec};
            }

            # If the rule has a help field; save it into help.
            if ($rule_spec->{help}) {
                $help_ref->{$rule_name} = $rule_spec->{help};
            }
            
            my($rule_name_final, @aliases)
                = split m/\|/xms, $rule_name;

# Split out the aliases (which are delimited by |)

            # Aliases can also be inside the spec, like this:
            #   '-arg' => { alias => '-gra' };
            # or a list of aliases:
            #   '-arg' => { alias => ['-gra', '-rag', '-rga'] };
            #  
            my $aliases_inside_spec   = $rule_spec->{alias};
            if ($aliases_inside_spec) {
                @aliases =
                    ref $aliases_inside_spec eq 'ARRAY'
                        ? (@aliases, @{$aliases_inside_spec})
                        : (@aliases, $aliases_inside_spec);
            }

            # if the name of the rule ends with !, remove the !
            # and set it as required.
            if ($rule_name_final =~ s/!\z//xms) {
                $rule_spec->{required} = 1;
            }

            # a default value can be defined inside parentheses.
            # i.e:
            #       '-arg(defaultValue)' => 'string';
            if ($rule_name_final =~ s/\( (.+?) \)//xms) {
                $rule_spec->{default}  = $1;
            }

            # Remove leading and trailing whitespace.
            $rule_name_final =~ s/\A \s+   //xms;
            $rule_name_final =~ s/   \s+ \z//xms;

            # Save the final version of the rule.
            $final_rules{$rule_name_final} = $rule_spec;

            # Save aliases to this rule.
            for my $alias (@aliases) {
                $aliases{$alias} = $rule_name_final;
            }
            
        }

        $self->set_aliases( \%aliases     );
        $self->set_rules(   \%final_rules );

        return;
    }

    sub rules_postactions {
        my ($self)     = @_;
        my $rules_ref  = $self->rules;
        my $result     = $self->result;

        while (my ($rule_name, $rule_spec) = each %{ $rules_ref }) {

            # Die if this is a required argument that we don't have.
            if ($rule_spec->{required} && !$result->{$rule_name}) {
                die "Missing required argument: $rule_name\n";
            }

            # Set this argument to the default if it doesn't exist
            # and a default value for this rule exists.
            if ($rule_spec->{default}  && !$result->{$rule_name}) {
                $result->{$rule_name}  =   $rule_spec->{default};
            }
        }

        return;
    }
    sub parseoption {
        my ($self, $argument, $node) = @_;
        my $result_argv = $self->result;
        my $leftovers   = $self->leftovers;
        my $rules       = $self->rules;
        my $options_ref = $self->options;
        my $aliases     = $self->aliases;

        my $is_arg_of_type = $self->find_arg_type($argument);

       # We stop processing options if this is a naked long option, ( '^--$' )
       # and the 'end_on_dashdash' option is set.
        if ($argument eq q{--} && $options_ref->{end_on_dashdash}) {
            $end_processing++;
        }

        # if find_arg_type said we have a special argument, start processing
        # it (as long as processing is not stopped).
        elsif ($is_arg_of_type && !$end_processing) {

            my @arguments = ($argument);

            if ($is_arg_of_type eq 'short' && $options_ref->{split_multiple_shorts}) {
                $argument =~ s/^-//xms;
                @arguments = map { "-$_" } split m//xms, $argument;
            };


            for my $argument (@arguments) {
                my $argument_name  = $argument;
                my $argument_value = q{};

                # ###
                # case: --argument_name=value
                # if argument name contains an equal sign, the value is embedded in the
                # argument. an example of inline assignement could be:
                #   --input-filename=/Users/ask/tmplog.txt
                if ($argument =~ $RE_ASSIGNMENT) {
                    my @fields = split $RE_ASSIGNMENT, $argument;
                    ($argument_name, $argument_value) = @fields;
                }

                # Try to find the rule for this argument...
                my $opt_has_rule = $rules->{$argument_name};

                # if we can't find this rule, check if it's an alias.
                if (!$opt_has_rule && $aliases->{$argument_name}) {

                    # set the argument name to the name of the original.
                    # and set the rule to the rule of the original.
                    $argument_name = $aliases->{$argument_name};
                    $opt_has_rule  = $rules->{$argument_name};
                }

                if (!$opt_has_rule && !$options_ref->{allow_unspecified}) {
                    $self->unknown_argument_error($argument);
                }

                $result_argv->{$argument_name} =
                    $opt_has_rule
                    ? $self->handle_rule($argument_name, $opt_has_rule, $node,
                    $argument_value)
                    : (
                    $argument_value || 1
                    );
            }

        }
        else {
            push @{$leftovers}, $argument;
        }

        return;
    }

    sub find_arg_type {
        my ($self, $argument) = @_;

        if ($argument =~ $RE_LONG_ARGUMENT) {
            return 'long';
        }

        if ($argument =~ $RE_SHORT_ARGUMENT) {
            return 'short';
        }