Getopt::Chain::Context - Per-command context

    perldoc -m Getopt::Chain::Context 

    The name of the current command (or undef if at the "root")
    Every option parsed so far
    Options local to the current command
    The arguments as they were BEFORE parsing options for this command
    The arguments remaining AFTER parsing options for this command

    ./script --verbose edit --file xyzzy.c 
    # The command name is "edit" in the edit subroutine

    ./script --help
    # The command name is undef in the root subroutine

    ./script --exclude apple --exclude banana --exclude --cherry
    ...
    my @exclude = $context->option( exclude )

    ./script --verbose
    ...
    if ( $context->options->{verbose} ) { ... }

    ./script --verbose edit --file xyzzy.c
    $context->local_option( file ) # Returns 'xyzzy.c'
    $context->local_option( verbose ) # Doesn't return anything
    $context->option( verbose ) # Returns 1

    ./script --verbose edit --file xyzzy.c

    # At the very beginning: 
    $context->arguments # Returns ( --verbose edit --file xyzzy.c )

    # In the "edit" subroutine:
    $context->arguments # Returns ( edit --file xyzzy.c )

    ./script --verbose edit --file xyzzy.c

    # At the very beginning: 
    $context->remaining_arguments # Returns ( edit --file xyzzy.c )

    # In the "edit" subroutine:
    $context->remaining_arguments # Returns ( )

package Getopt::Chain::Context;

use strict;
use warnings;

use Moose;
use MooseX::AttributeHelpers;
use Getopt::Chain::Carp;

use Getopt::Chain;

use Getopt::Long qw/GetOptionsFromArray/;
use Hash::Param;

use constant DEBUG => Getopt::Chain->DEBUG;
our $DEBUG = DEBUG;

# Should probably move these into Getopt::Chain
# ...or even... Getopt::Longer :)
sub is_option_like($) {
    return $_[0] =~ m/^-/;
}

sub consume_arguments($$) { # Will modify arguments, reflecting consumption
    my $argument_schema = shift;
    my $arguments = shift;

    my %options;
    eval {
        if ($argument_schema && @$argument_schema) {
            Getopt::Long::Configure(qw/pass_through/);
            GetOptionsFromArray($arguments, \%options, @$argument_schema);
        }
    };
    croak "There was an error option-processing arguments: $@" if $@;

    return ( \%options );
}

has dispatcher => qw/is ro required 1/;

has _options => qw/is ro isa Hash::Param lazy_build 1/, handles => {qw/option param options params/};
sub _build__options {
    my $self = shift;
    return Hash::Param->new(params => {});
}

has _stash => qw/is ro isa HashRef/, default => sub { {} };
sub stash {
    my $self = shift;
    return $self->_stash unless @_;
    my $stash = $self->_stash;
    while ( @_ ) { my ($k, $v) = (shift @_, shift @_); $stash->{$k} = $v }
    return $stash;
}

# The original arguments from the commandline (or wherever)... read only!
has starting_arguments => qw/metaclass Collection::Array reader _arguments init_arg arguments required 1 lazy 1 isa ArrayRef/, default => sub { [] }, provides => {qw/
    elements    starting_arguments
/};

# The arguments remaining after each step does argument consuming... written by the step!
has parsing_arguments => qw/metaclass Collection::Array accessor _parsing_arguments isa ArrayRef/, provides => {qw/
    elements    parsing_arguments
    shift       shift_parsing_argument
    first       first_parsing_argument
/};

has steps => qw/metaclass Collection::Array reader _steps required 1 lazy 1 isa ArrayRef/, default => sub { [] }, provides => {qw/
    elements    steps   
    first       first_step
    last        last_step
    push        push_step
    pop         pop_step
/};

has _path => qw/metaclass Collection::Array is ro required 1 lazy 1 isa ArrayRef/, default => sub { [] }, provides => {qw/
    elements    path
    push        push_path
/};

sub initialize_run {
    my $self = shift;
    $self->_parsing_arguments( [ $self->starting_arguments ] );
}

sub run {
    my $self = shift;

    $self->initialize_run;
    1 while $self->next;
}

sub next {
    my $self = shift;

    unless (defined $self->_parsing_arguments) { # Haven't been run yet
        $self->initialize_run;
    }

    my $run_path = join ' ', $self->path;
    warn "Context::next ", $self->path_as_string, " ($run_path)\n"  if $DEBUG;

    {
        # $self->dispatcher->run( $run_path, $self ); # This will (indirectly) call ->run_step( ... ) below
        my $dispatch = $self->dispatcher->dispatch( $run_path );
        if ( my @matches = $dispatch->matches ) {
            for my $match ($dispatch->matches) {
                my $result = $match->result;
                last if $match->run( $self ); # ->run_step returned true
            }
        }
    }

    my $next;
    $self->push_path( $next ) if $next = $self->next_path_part;
    return $next;
}

sub next_path_part {
    my $self = shift;

    return unless defined (my $argument = $self->first_parsing_argument);
    croak "Have option-like element at head of parsing arguments: ", $argument, " @ ", $self->path_as_string, " [", join ' ', $self->parsing_arguments, "]" if is_option_like $argument;
    return $self->shift_parsing_argument; # Same as $argument, really
}

sub last {
    my $self = shift;
    return ! defined $self->first_parsing_argument;
}

sub path_as_string {
    my $self = shift;
    return join '/', '^START', $self->path, ($self->last ? '$' : ());
}

sub run_step { # Called from within the Path::Dispatcher rule
    my $self = shift;
    my $argument_schema = shift;
    my $run = shift;
    my $control = shift;

    $argument_schema = [] unless defined $argument_schema;
    
    my $step = $self->add_step( argument_schema => $argument_schema, run => $run, @_ ); 
    return 1 if $step->run( $control ); # We consumed and ran, so we don't need to rollback
    $self->pop_step; # Rollback, since we didn't actually run
    return 0;
}

sub add_step {
    my $self = shift;
    my %given = @_; # Should be: argument_schema, run

    my $parent = $self->last_step; # Could be undef
    my $step = Getopt::Chain::Context::Step->new( context => $self, parent => $parent, path => [ $self->path ], arguments => [ $self->parsing_arguments ], %given );
    $self->push_step( $step );
    return $step;
}

sub command {
    my $self = shift;
    return $self->last_step->last_path_part;
}

sub local_option {
    my $self = shift;
    return $self->last_step->option( @_ );
}

sub local_options {
    my $self = shift;
    return $self->last_step->options( @_ );
}

sub local_path {
    my $self = shift;
    return $self->last_step->path;
}

package Getopt::Chain::Context::Step;

use Moose;
use Getopt::Chain::Carp;

use Hash::Param;

use constant DEBUG => Getopt::Chain->DEBUG;
our $DEBUG = DEBUG;

has context => qw/is ro required 1 isa Getopt::Chain::Context/;

has _options => qw/is ro isa Hash::Param lazy_build 1/, handles => {qw/option param options params/};
sub _build__options {
    my $self = shift;
    return Hash::Param->new( params => {} );
}

has starting_arguments => qw/metaclass Collection::Array init_arg arguments accessor _starting_arguments required 1 isa ArrayRef/, provides => {qw/
    elements starting_arguments
/};

has remaining_arguments => qw/metaclass Collection::Array accessor _remaining_arguments isa ArrayRef lazy 1/, provides => {qw/
    elements remaining_arguments
    elements arguments
/}, default => sub { [] };

has argument_schema => qw/metaclass Collection::Array accessor _argument_schema required 1 isa ArrayRef/, provides => {qw/
    elements argument_schema
/};

has run => qw/is ro reader _run isa Maybe[CodeRef]/;

has _path => qw/metaclass Collection::Array is ro required 1 lazy 1 isa ArrayRef init_arg path/, default => sub { [] }, provides => {qw/
    elements    path
    last        last_path_part
    push        push_path
/};

has parent => qw/is ro isa Maybe[Getopt::Chain::Context::Step]/;

has dollar1 => qw/is ro/;

sub run {
    my $self = shift;
    my $control = shift;

    my $options = {};
    my $arguments = [ $self->starting_arguments ];
    my $argument_schema = [ $self->argument_schema ];
    my ( $last );

    warn "Context::Step::run ", $self->context->path_as_string, " [@$arguments] {@$argument_schema}\n" if $DEBUG;

    eval {
        $options = Getopt::Chain::Context::consume_arguments $argument_schema, $arguments;
        unless ( $control->{terminator} ) {
            if ( @$arguments && Getopt::Chain::Context::is_option_like $arguments->[0] ) {
                die "Unknown option-like argument: $arguments->[0]", "\n";
            }
        }
    };
    die "Exception at \"", join( '/', $self->path ), "\" with arguments [ @$arguments ]: $@" if $@;

    while (my ($key, $value) = each %$options) {
        $self->option( $key => $value );
        $self->context->option( $key => $value ); # TODO Better way to do this...
    }

    $self->_remaining_arguments( $arguments );
    if ( $control->{terminator} ) {
        $self->context->_parsing_arguments( [] );
        $last = 1;
    }
    else {
        $self->context->_parsing_arguments( [ @$arguments ] );
        $last = @$arguments ? 0 : 1; # Same as $ctx->last, really
    }
    
    unless ( $last || $control->{always_run} ) {
        warn "Context::Step::run ", $self->context->path_as_string, " SKIP\n" if DEBUG;
        return;
    }

    {
        # on 'A *'

        # A b -x c (Although this is an error condition)
        # A b -x c      $1 = ''     [ b -x c ]
        # A/b -x c      $1 = 'b'    [ -x c ] # Error, -x wasn't parsed!
        # A/b/c         $1 = 'b c'  [ ]

        # A b c d
        # A b c d       $1 = ''         [ b c d ]
        # A/b c d       $1 = 'b'        [ c d ]
        # A/b/c d       $1 = 'b c'      [ d ]
        # A/b/c/d       $1 = 'b c d'    [ ]

        my @arguments;
        push @arguments, grep { length } split m/\s+/, $self->dollar1 if defined $self->dollar1;
        push @arguments, @$arguments;
        my $run = $self->_run;
        $run->( $self->context, @arguments ) if $run;
    }

    return 1;
}

1;