The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package Solution::Context;
{
    use strict;
    use warnings;
    use lib '../';
    our $VERSION = '0.9.1';
    use Solution::Utility;
    use Solution::Error;
    sub scopes    { return $_[0]->{'scopes'} }
    sub scope     { return $_[0]->{'scopes'}->[-1] }
    sub filters   { return $_[0]->{'filters'} }
    sub registers { return $_[0]->{'registers'} }

    sub new {
        my ($class, $assigns, $args) = @_;
        return bless {
            filters   => ($args->{'filters'}   ? $args->{'filters'}   : []),
            registers => ($args->{'registers'} ? $args->{'registers'} : {}),
            scopes    => [$assigns             ? $assigns             : {}],
            template => $args->{'template'},    # Required
            errors   => []
        }, $class;
    }

    sub push {
        my ($self, $context) = @_;
        return raise Solution::ContextError 'Cannot push new scope!'
            if scalar @{$self->{'scopes'}} == 100;
        return push @{$self->{'scopes'}}, (defined $context ? $context : {});
    }

    sub pop {
        my ($self) = @_;
        return raise Solution::ContextError 'Cannot pop scope!'
            if scalar @{$self->{'scopes'}} == 1;
        return pop @{$self->{'scopes'}};
    }

    sub stack {
        my ($self, $block) = @_;
        my $old_scope = $self->scope;
        $self->push();
        $self->merge($old_scope);
        my $result = $block->($self);
        $self->pop;
        return $result;
    }

    sub merge {
        my ($self, $new) = @_;
        return $self->{'scopes'}->[0] = __merge(reverse $self->scope, $new);
    }

    sub _merge {    # Deeply merges data structures
        my ($source, $target) = @_;
        my $return = $target;
        for (keys %$source) {
            if ('ARRAY' eq ref $target->{$_}
                && ('ARRAY' eq ref $source->{$_}
                    || !ref $source->{$_})
                )
            {   @{$return->{$_}} = [@{$target->{$_}}, @{$source->{$_}}];
            }
            elsif ('HASH' eq ref $target->{$_}
                   && ('HASH' eq ref $source->{$_}
                       || !ref $source->{$_})
                )
            {   $return->{$_} = _merge($source->{$_}, $target->{$_});
            }
            else { $return->{$_} = $source->{$_}; }
        }
        return $return;
    }
    my $merge_precedent;

    sub __merge {    # unless right is more interesting, this is a left-
        my $return = $_[1];    # precedent merge function
        $merge_precedent ||= {
            SCALAR => {SCALAR => sub { defined $_[0] ? $_[0] : $_[1] },
                       ARRAY  => sub { $_[1] },
                       HASH   => sub { $_[1] },
            },
            ARRAY => {
                SCALAR => sub {
                    [@{$_[0]}, defined $_[1] ? $_[1] : ()];
                },
                ARRAY => sub { [@{$_[0]}] },
                HASH  => sub { [@{$_[0]}, values %{$_[1]}] },
            },
            HASH => {SCALAR => sub { $_[0] },
                     ARRAY  => sub { $_[0] },
                     HASH   => sub { _merge($_[0], $_[1], $_[2]) },
            }
        };
        for my $key (keys %{$_[0]}) {
            my ($left_ref, $right_ref)
                = map { ref($_->{$key}) =~ m[^(HASH|ARRAY)$] ? $1 : 'SCALAR' }
                ($_[0], $_[1]);

            #warn sprintf '%-12s [%6s|%-6s]', $key, $left_ref, $right_ref;
            $return->{$key} = $merge_precedent->{$left_ref}{$right_ref}
                ->($_[0]->{$key}, $_[1]->{$key});
        }
        return $return;
    }

    sub resolve {
        my ($self, $path, $val) = @_;
        return if !defined $path;
        return if $path eq '';
        return if $path eq 'null';
        return if $path eq 'nil';
        return if $path eq 'blank';
        return if $path eq 'empty';
        return !1  if $path eq 'false';
        return !!1 if $path eq 'true';
        return $2 if $path =~ m[^(['"])(.+)\1$];
        return [int $self->resolve($1) .. int $self->resolve($2)]
            if $path =~ m[^\((\S+)\.\.(\S+)\)$];    # range
        return $1 if $path =~ m[^(\d+(?:[\d\.]+)?)$];    # int or bad float
        return $self->resolve($1)->[$2] if $path =~ m'^(.+)\[(.+)\]$';
        my @path = split $Solution::Utility::VariableAttributeSeparator,
            $path;
        my $cursor = \$self->scope;

        while (local $_ = shift @path) {
            my $type = ref $$cursor;
            if ($type eq 'ARRAY') {
                if (scalar @path == 1) {
                    return scalar @{$$cursor}    if $path->[0] eq 'size';
                    return scalar $$cursor->[0]  if $path->[0] eq 'first';
                    return scalar $$cursor->[-1] if $path->[0] eq 'last';
                }
                return unless /^(?:0|[0-9]\d*)\z/;
                if (scalar @path) { $cursor = \$$cursor->[$_]; next; }
                return defined $val ?
                    $$cursor->[$_]
                    = $val
                    : $$cursor->[$_];
            }
            if (@path && $type) { $cursor = \$$cursor->{$_}; next; }

            #warn $$cursor->{$_} if ref  $$cursor->{$_};
            return defined $val ?
                $$cursor->{$_}
                = $val
                : $type ?
                $type eq 'HASH' ?
                $$cursor->{$_}
                : $type eq 'ARRAY' ?
                    $$cursor->[$_]
                : $$cursor->can($_) ?
                    $$cursor->$_()
                : do { warn 'Cannot call ' . $_; () }
                : defined $$cursor ?
                $$cursor    # die $path . ' is not a hash/array reference'
                : '';
            return $$cursor->{$_};
        }
    }
}
1;

=pod

=cut