Getopt::LL

# $Id: LL.pm,v 1.17 2007/07/13 00:00:13 ask Exp $
# $Source: /opt/CVS/Getopt-LL/lib/Getopt/LL.pm,v $
# $Author: ask $
# $HeadURL$
# $Revision: 1.17 $
# $Date: 2007/07/13 00:00:13 $
package Getopt::LL;
use strict;
use warnings;
use Carp qw(croak);
use Getopt::LL::DLList;
use English qw($PROGRAM_NAME);
use version qw(qv); our $VERSION = qv('1.0.0');
use 5.006_001;
{


    use Getopt::LL::SimpleExporter qw(getoptions opt_String opt_Digit opt_Flag);

    use Class::Dot 1.0 qw( property isa_Hash isa_Array isa_Object );

    #========================================================================
    #                           - CLASS PROPERTIES -
    #========================================================================
    property    rules       => isa_Hash;
    property    aliases     => isa_Hash;
    property    options     => isa_Hash;
    property    help        => isa_Hash;
    property    result      => isa_Hash;
    property    leftovers   => isa_Array;
    property    dll         => isa_Object('Getopt::LL::DLList');

    my $RE_SHORT_ARGUMENT = qr{
                        \A          # starts with...
                        -           # single dash.
                        (?!-)       # with no dash after that.
                        .
        }xms;

    my $RE_LONG_ARGUMENT = qr{
                        \A          # starts with...
                        -- [^-]?    # two dashes.
                        (?!-)       # with no dash after that.
                        .
        }xms;

    my $RE_ASSIGNMENT = qr{
                        (?<! \\ )   # equal sign that does not have backslash 
                        =           # in front of it.
        }xms;

    my %TYPE_CHECK = (
        digit       => \&is_digit,
        string      => \&is_string,
    );

    my %RULE_ACTION = (
        digit       => \&get_next_arg,
        string      => \&get_next_arg,
        flag        => sub {
            return 1;
        },
    );

    my %DEFAULT_OPTIONS = (
        allow_unspecified    => 0,
        die_on_type_mismatch => 0,
        silent               => 0,
        end_on_dashdash      => 0,
        split_multiple_shorts => 0,
        style                => 'default',
        long_option          => 'flag',
        short_option         => 'string',
    );

    my %DEFAULT_OPTIONS_GNU = (

        # GNU-style arguments ends argument processing on empty '--'
        end_on_dashdash      => 1,
        split_multiple_shorts => 1,
    );

    my $EXIT_FAILURE = 1;

    # When set to true, parseopts stop processing options.
    my $end_processing;

    #========================================================================
    #                            - CONSTRUCTOR -
    #========================================================================
    sub new {
        my ($class, $rules_ref, $options_ref, $argv_ref) = @_;
        $argv_ref         ||= \@ARGV;

        my $self = {};
        bless $self, $class;

        # If there are no rules, we must allowed unspecified
        # arguments. (also check if we a have a reference to an empty hash).
        if (!$rules_ref  || (ref $rules_ref && !scalar keys %{$rules_ref})) {
            $options_ref->{allow_unspecified} = 1;
        }

        while (my ($option, $default_value) = each %DEFAULT_OPTIONS) {
            if (!defined $options_ref->{$option}) {
                $options_ref->{$option} = $default_value;
            }
        }
        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';
        }

        # return nothing if this is not a special argument/option.
        return;
    }

    sub is_string {

        # we have no limits for what a string can be.
        return 1;
    }

    sub is_digit  {
        my ($self, $value, $option_name, $value_ref) = @_;
        return 0 if $value eq q{};
        my $is_digit = 0;

        my $first_two_chars = substr $value, 0, 2;
        if ($first_two_chars eq '0x') {

            # starts with 0x: is hexadecimal number
            $value = substr $value, 2, length $value;
            if ($value =~ m/\A [\dA-Fa-f]+ \z/xms) {

                # We get a reference to the value as argument #4.
                # convert the value to hex.
                ${$value_ref} = hex $value;
                $is_digit = 1;
            }
        }
        elsif ($value =~ m/\A [-+]? \d+ \z/xms) {
            $is_digit = 1;
        }

        if (!$is_digit) {
            return $self->type_mismatch_error('digit',
                "$option_name must be a digit (0-9).");
        }

        return 1;
    }

    sub type_mismatch_error {
        my ($self, $type, $message) = @_;
        my $options_ref = $self->options;

        $options_ref->{die_on_type_mismatch}
            ? croak  $message, "\n"
            : warn $message, "\n"
        ;

        return 0;
    }

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

        croak "Unknown argument: $argument.\n";
    }

    sub handle_rule {
        my ($self, $arg_name, $rule_ref, $node, $arg_value) = @_;
        my $rule_data;

        my $rule_type = $rule_ref->{type};

        if (ref $rule_type eq 'CODE') {
            return $rule_type->($self, $node, $arg_name, $arg_value);
        }
        elsif (ref $rule_type eq 'Regexp') {
            no warnings 'uninitialized'; ## no critic
            my $next_arg = $self->get_next_arg($node);
            if ($next_arg !~ $rule_type) {
                if (! defined $next_arg) {
                    $next_arg = '<no-value>';
                }
                croak sprintf('Argument %s [%s] does not match %s', ## no critic
                    $arg_name, $next_arg, _regex_as_text($rule_type)
                );
            }
            return $next_arg;

        }


        if ($RULE_ACTION{$rule_type}) {

            $arg_value ||= $RULE_ACTION{$rule_type}->($self, $node);

            if ($TYPE_CHECK{$rule_type}) {
                $TYPE_CHECK{$rule_type}
                    ->($self,$arg_value, $arg_name, \$arg_value);
            }
        }
        else {
            $Carp::CarpLevel = 2; ## no critic;
            croak "Unknown rule type [$rule_type] for argument [$arg_name]";
        }

        return $arg_value;
    }

    sub get_next_arg {
        my ($self, $node) = @_;

        return $self->delete_arg( $node->next );
    }

    sub get_prev_arg {
        my ($self, $node) = @_;

        return $self->delete_arg( $node->prev );
    }

    sub peek_next_arg {
        my ($self, $node) = @_;
        if ($node->next) {
            return $node->next->data;
        }
        return;
    }

    sub peek_prev_arg {
        my ($self, $node) = @_;
        if ($node->prev) {
            return $node->prev->data;
        }
        return;
    }

    sub delete_arg {
        my ($self, $node) = @_;
        my $dll = $self->dll;

        return $dll->delete_node($node);
    }

    # XXX this is not very complete.
    sub show_help {
        my ($self) = @_;

        while (my ($arg, $help) = each %{ $self->help }) {
            my $ret = print {*STDERR} "$arg\t\t\t$help\n";
            croak 'I/O Error. Cannot print to terminal' if !$ret;
        }

        return;
    }

    # XXX this is not very complete.
    sub show_usage {
        my ($self) = @_;

        my $program_name = $self->options->{program_name};

        if (! $program_name) {
            $program_name = $PROGRAM_NAME;
        }

        require File::Basename;
        $program_name = File::Basename::basename($program_name);

        my @arguments;
        while (my ($arg, $spec) = each %{ $self->rules }) {
            if ($spec->{type} eq 'string' || $spec->{type} eq 'digit') {
                push @arguments, "$arg <n>";
            }
            else {
                push @arguments, $arg;
            }
        }

        my $arguments = join q{|}, @arguments;

        my $ret = print {*STDERR} "Usage: $program_name [$arguments]\n";
        croak 'I/O Error. Cannot print to terminal' if !$ret;

        return;
    }

    #========================================================================
    #                           - CLASS METHODS -
    #========================================================================

    #------------------------------------------------------------------------
    # getoptions(\%rules, \%options, \@opt_argv)
    #
    #------------------------------------------------------------------------
    sub getoptions {
        my ($rules_ref, $options_ref, $argv_ref) = @_;

        my $getopts =
            __PACKAGE__->new($rules_ref, $options_ref, $argv_ref); ## no critic;
        my $result  = $getopts->result();

        # ARGV should be set to what is left of the argument vector.
        @ARGV = @{ $getopts->leftovers };

        return $result;
    }

    sub opt_String { ## no critic
        my ($help) = @_;
        return {
            type => 'string',
            help => $help,
        };
    }

    sub opt_Digit { ## no critic
        my ($help) = @_;
        return {
            type => 'digit',
            help => $help,
        };
    }

    sub opt_Flag { ## no critic
        my ($help) = @_;
        return {
            type => 'flag',
            help => $help,
        };
    }

    sub _regex_as_text {
        my $regex_as_text = scalar shift;
        my $regex_modifiers;

        # The quoted regex (?xmsi:hello) should look something like this
        #   /hello/xmsi
        # The job is to remove the (?: and capture xmsi into $1.
        my $ret = $regex_as_text =~ s{
                        \A              # beginning of string.
                                \(\?        # a paren start and a question mark.
                                        ([\w-]+)?   # none or more word characters captured to $1
                                :           # ends with a colon.
                }{}xms;

        if ($ret) {
            $regex_modifiers = $1;
        }

        # remove the closing paren at the end.
        $regex_as_text =~ s/\) \z//xms;

        # The final text we return should be:
        #   /hello/xmsi
        # if the regex we got was:
        #   (?xmsi:hello)
        $regex_as_text = "/$regex_as_text/";
        if ($regex_modifiers) {
            $regex_as_text .= $regex_modifiers;
        }

        return $regex_as_text;
    }
}

1;

__END__