#============================================================= -*-Perl-*-
#
# Template::Stash::Context
#
# DESCRIPTION
#   This is an alternate stash object which includes a patch from
#   Craig Barratt to implement various new virtual methods to allow
#   dotted template variable to denote if object methods and subroutines
#   should be called in scalar or list context.  It adds a little overhead
#   to each stash call and I'm a little wary of doing that.  So for now,
#   it's implemented as a separate stash module which will allow us to
#   test it out, benchmark it and switch it in or out as we require.
#
#   This is what Craig has to say about it:
#
#   Here's a better set of features for the core.  Attached is a new version
#   of Stash.pm (based on TT2.02) that:
#
#     - supports the special op "scalar" that forces scalar context on
#       function calls, eg:
#
#           cgi.param("foo").scalar
#
#       calls cgi.param("foo") in scalar context (unlike my wimpy
#       scalar op from last night).  Array context is the default.
#
#       With non-function operands, scalar behaves like the perl
#       version (eg: no-op for scalar, size for arrays, etc).
#
#     - supports the special op "ref" that behaves like the perl ref.
#       If applied to a function the function is not called.  Eg:
#
#           cgi.param("foo").ref
#
#       does *not* call cgi.param and evaluates to "CODE".  Similarly,
#       HASH.ref, ARRAY.ref return what you expect.
#
#     - adds a new scalar and list op called "array" that is a no-op for
#       arrays and promotes scalars to one-element arrays.
#
#     - allows scalar ops to be applied to arrays and hashes in place,
#       eg: ARRAY.repeat(3) repeats each element in place.
#
#     - allows list ops to be applied to scalars by promoting the scalars
#       to one-element arrays (like an implicit "array").  So you can
#       do things like SCALAR.size, SCALAR.join and get a useful result.
#
#       This also means you can now use x.0 to safely get the first element
#       whether x is an array or scalar.
#
#   The new Stash.pm passes the TT2.02 test suite.  But I haven't tested the
#   new features very much.  One nagging implementation problem is that the
#   "scalar" and "ref" ops have higher precedence than user variable names.
#
# AUTHORS
#   Andy Wardley  <abw@kfs.org>
#   Craig Barratt <craig@arraycomm.com>
#
# COPYRIGHT
#   Copyright (C) 1996-2022 Andy Wardley.  All Rights Reserved.
#   Copyright (C) 1998-2001 Canon Research Centre Europe Ltd.
#
#   This module is free software; you can redistribute it and/or
#   modify it under the same terms as Perl itself.
#
#============================================================================

package Template::Stash::Context;

use strict;
use warnings;
use base 'Template::Stash';

our $VERSION = '3.100';
our $DEBUG   = 0 unless defined $DEBUG;


#========================================================================
#                    -- PACKAGE VARIABLES AND SUBS --
#========================================================================

#------------------------------------------------------------------------
# copy virtual methods from those in the regular Template::Stash
#------------------------------------------------------------------------

our $ROOT_OPS = {
    %$Template::Stash::ROOT_OPS,
    defined $ROOT_OPS ? %$ROOT_OPS : (),
};

our $SCALAR_OPS = {
    %$Template::Stash::SCALAR_OPS,
    'array' => sub { return [$_[0]] },
    defined $SCALAR_OPS ? %$SCALAR_OPS : (),
};

our $LIST_OPS = {
    %$Template::Stash::LIST_OPS,
    'array' => sub { return $_[0] },
    defined $LIST_OPS ? %$LIST_OPS : (),
};

our $HASH_OPS = {
    %$Template::Stash::HASH_OPS,
    defined $HASH_OPS ? %$HASH_OPS : (),
};



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

#------------------------------------------------------------------------
# new(\%params)
#
# Constructor method which creates a new Template::Stash object.
# An optional hash reference may be passed containing variable
# definitions that will be used to initialise the stash.
#
# Returns a reference to a newly created Template::Stash.
#------------------------------------------------------------------------

sub new {
    my $class  = shift;
    my $params = ref $_[0] eq 'HASH' ? shift(@_) : { @_ };

    my $self   = {
        global  => { },
        %$params,
        %$ROOT_OPS,
        '_PARENT' => undef,
        '_CLASS'  => $class,
    };

    bless $self, $class;
}


#========================================================================
#                   -----  PUBLIC OBJECT METHODS -----
#========================================================================

#------------------------------------------------------------------------
# clone(\%params)
#
# Creates a copy of the current stash object to effect localisation
# of variables.  The new stash is blessed into the same class as the
# parent (which may be a derived class) and has a '_PARENT' member added
# which contains a reference to the parent stash that created it
# ($self).  This member is used in a successive declone() method call to
# return the reference to the parent.
#
# A parameter may be provided which should reference a hash of
# variable/values which should be defined in the new stash.  The
# update() method is called to define these new variables in the cloned
# stash.
#
# Returns a reference to a cloned Template::Stash.
#------------------------------------------------------------------------

sub clone {
    my ($self, $params) = @_;
    $params ||= { };

    # look out for magical 'import' argument which imports another hash
    my $import = $params->{ import };
    if (defined $import && UNIVERSAL::isa($import, 'HASH')) {
        delete $params->{ import };
    }
    else {
        undef $import;
    }

    my $clone = bless {
        %$self,                 # copy all parent members
        %$params,               # copy all new data
        '_PARENT' => $self,     # link to parent
    }, ref $self;

    # perform hash import if defined
    &{ $HASH_OPS->{ import }}($clone, $import)
        if defined $import;

    return $clone;
}


#------------------------------------------------------------------------
# declone($export)
#
# Returns a reference to the PARENT stash.  When called in the following
# manner:
#    $stash = $stash->declone();
# the reference count on the current stash will drop to 0 and be "freed"
# and the caller will be left with a reference to the parent.  This
# contains the state of the stash before it was cloned.
#------------------------------------------------------------------------

sub declone {
    my $self = shift;
    $self->{ _PARENT } || $self;
}


#------------------------------------------------------------------------
# get($ident)
#
# Returns the value for an variable stored in the stash.  The variable
# may be specified as a simple string, e.g. 'foo', or as an array
# reference representing compound variables.  In the latter case, each
# pair of successive elements in the list represent a node in the
# compound variable.  The first is the variable name, the second a
# list reference of arguments or 0 if undefined.  So, the compound
# variable [% foo.bar('foo').baz %] would be represented as the list
# [ 'foo', 0, 'bar', ['foo'], 'baz', 0 ].  Returns the value of the
# identifier or an empty string if undefined.  Errors are thrown via
# die().
#------------------------------------------------------------------------

sub get {
    my ($self, $ident, $args) = @_;
    my ($root, $result);
    $root = $self;

    if (ref $ident eq 'ARRAY'
        || ($ident =~ /\./)
        && ($ident = [ map { s/\(.*$//; ($_, 0) } split(/\./, $ident) ])) {
        my $size = $#$ident;

        # if $ident is a list reference, then we evaluate each item in the
        # identifier against the previous result, using the root stash
        # ($self) as the first implicit 'result'...

        foreach (my $i = 0; $i <= $size; $i += 2) {
            if ( $i + 2 <= $size && ($ident->[$i+2] eq "scalar"
                                    || $ident->[$i+2] eq "ref") ) {
                $result = $self->_dotop($root, @$ident[$i, $i+1], 0,
                                        $ident->[$i+2]);
                $i += 2;
            } else {
                $result = $self->_dotop($root, @$ident[$i, $i+1]);
            }
            last unless defined $result;
            $root = $result;
        }
    }
    else {
        $result = $self->_dotop($root, $ident, $args);
    }

    return defined $result
        ? $result
        : $self->undefined($ident, $args);
}


#------------------------------------------------------------------------
# set($ident, $value, $default)
#
# Updates the value for a variable in the stash.  The first parameter
# should be the variable name or array, as per get().  The second
# parameter should be the intended value for the variable.  The third,
# optional parameter is a flag which may be set to indicate 'default'
# mode.  When set true, the variable will only be updated if it is
# currently undefined or has a false value.  The magical 'IMPORT'
# variable identifier may be used to indicate that $value is a hash
# reference whose values should be imported.  Returns the value set,
# or an empty string if not set (e.g. default mode).  In the case of
# IMPORT, returns the number of items imported from the hash.
#------------------------------------------------------------------------

sub set {
    my ($self, $ident, $value, $default) = @_;
    my ($root, $result, $error);

    $root = $self;

    ELEMENT: {
        if (ref $ident eq 'ARRAY'
            || ($ident =~ /\./)
            && ($ident = [
                map { s/\(.*$//; ($_, 0) }
                split(/\./, $ident)
            ])
        ) {
            # a compound identifier may contain multiple elements (e.g.
            # foo.bar.baz) and we must first resolve all but the last,
            # using _dotop() with the $lvalue flag set which will create
            # intermediate hashes if necessary...
            my $size = $#$ident;
            foreach (my $i = 0; $i < $size - 2; $i += 2) {
                $result = $self->_dotop($root, @$ident[$i, $i+1], 1);
                last ELEMENT unless defined $result;
                $root = $result;
            }

            # then we call _assign() to assign the value to the last element
            $result = $self->_assign(
                $root, @$ident[$size-1, $size],
                $value, $default
            );
        }
        else {
            $result = $self->_assign($root, $ident, 0, $value, $default);
        }
    }

    return defined $result ? $result : '';
}


#------------------------------------------------------------------------
# getref($ident)
#
# Returns a "reference" to a particular item.  This is represented as a
# closure which will return the actual stash item when called.
# WARNING: still experimental!
#------------------------------------------------------------------------

sub getref {
    my ($self, $ident, $args) = @_;
    my ($root, $item, $result);
    $root = $self;

    if (ref $ident eq 'ARRAY') {
        my $size = $#$ident;

        foreach (my $i = 0; $i <= $size; $i += 2) {
            ($item, $args) = @$ident[$i, $i + 1];
            last if $i >= $size - 2;  # don't evaluate last node
            last unless defined
                ($root = $self->_dotop($root, $item, $args));
        }
    }
    else {
        $item = $ident;
    }

    if (defined $root) {
        return sub {
            my @args = (@{$args||[]}, @_);
            $self->_dotop($root, $item, \@args);
        }
    }
    else {
        return sub { '' };
    }
}




#------------------------------------------------------------------------
# update(\%params)
#
# Update multiple variables en masse.  No magic is performed.  Simple
# variable names only.
#------------------------------------------------------------------------

sub update {
    my ($self, $params) = @_;

    # look out for magical 'import' argument to import another hash
    my $import = $params->{ import };
    if (defined $import && UNIVERSAL::isa($import, 'HASH')) {
        @$self{ keys %$import } = values %$import;
        delete $params->{ import };
    }

    @$self{ keys %$params } = values %$params;
}


#========================================================================
#                  -----  PRIVATE OBJECT METHODS -----
#========================================================================

#------------------------------------------------------------------------
# _dotop($root, $item, \@args, $lvalue, $nextItem)
#
# This is the core 'dot' operation method which evaluates elements of
# variables against their root.  All variables have an implicit root
# which is the stash object itself (a hash).  Thus, a non-compound
# variable 'foo' is actually '(stash.)foo', the compound 'foo.bar' is
# '(stash.)foo.bar'.  The first parameter is a reference to the current
# root, initially the stash itself.  The second parameter contains the
# name of the variable element, e.g. 'foo'.  The third optional
# parameter is a reference to a list of any parenthesised arguments
# specified for the variable, which are passed to sub-routines, object
# methods, etc.  The final parameter is an optional flag to indicate
# if this variable is being evaluated on the left side of an assignment
# (e.g. foo.bar.baz = 10).  When set true, intermediated hashes will
# be created (e.g. bar) if necessary.
#
# Returns the result of evaluating the item against the root, having
# performed any variable "magic".  The value returned can then be used
# as the root of the next _dotop() in a compound sequence.  Returns
# undef if the variable is undefined.
#------------------------------------------------------------------------

sub _dotop {
    my ($self, $root, $item, $args, $lvalue, $nextItem) = @_;
    my $rootref = ref $root;
    my ($value, @result, $ret, $retVal);
    $nextItem ||= "";
    my $scalarContext = 1 if ( $nextItem eq "scalar" );
    my $returnRef = 1     if ( $nextItem eq "ref" );

    $args ||= [ ];
    $lvalue ||= 0;

#    print STDERR "_dotop(root=$root, item=$item, args=[@$args])\n"
#       if $DEBUG;

    # return undef without an error if either side of the dot is unviable
    # or if an attempt is made to access a private member, starting _ or .
    return undef
        unless defined($root) and defined($item) and $item !~ /^[\._]/;

    if (ref(\$root) eq "SCALAR" && !$lvalue &&
            (($value = $LIST_OPS->{ $item }) || $item =~ /^-?\d+$/) ) {
        #
        # Promote scalar to one element list, to be processed below.
        #
        $rootref = 'ARRAY';
        $root = [$root];
    }
    if ($rootref eq $self->{_CLASS} || $rootref eq 'HASH') {
        # if $root is a regular HASH or a Template::Stash kinda HASH (the
        # *real* root of everything).  We first lookup the named key
        # in the hash, or create an empty hash in its place if undefined
        # and the $lvalue flag is set.  Otherwise, we check the HASH_OPS
        # pseudo-methods table, calling the code if found, or return undef.

        if (defined($value = $root->{ $item })) {
            ($ret, $retVal, @result) = _dotop_return(
                $value, $args, $returnRef,
                $scalarContext
            );
            return $retVal if ( $ret );                     ## RETURN
        }
        elsif ($lvalue) {
            # we create an intermediate hash if this is an lvalue
            return $root->{ $item } = { };                  ## RETURN
        }
        elsif ($value = $HASH_OPS->{ $item }) {
            @result = &$value($root, @$args);               ## @result
        }
        elsif (ref $item eq 'ARRAY') {
            # hash slice
            return [@$root{@$item}];                       ## RETURN
        }
        elsif ($value = $SCALAR_OPS->{ $item }) {
            #
            # Apply scalar ops to every hash element, in place.
            #
            foreach my $key ( keys %$root ) {
                $root->{$key} = &$value($root->{$key}, @$args);
            }
        }
    }
    elsif ($rootref eq 'ARRAY') {
        # if root is an ARRAY then we check for a LIST_OPS pseudo-method
        # (except for l-values for which it doesn't make any sense)
        # or return the numerical index into the array, or undef

        if (($value = $LIST_OPS->{ $item }) && ! $lvalue) {
            @result = &$value($root, @$args);               ## @result
        }
        elsif (($value = $SCALAR_OPS->{ $item }) && ! $lvalue) {
            #
            # Apply scalar ops to every array element, in place.
            #
            for ( my $i = 0 ; $i < @$root ; $i++ ) {
                $root->[$i] = &$value($root->[$i], @$args); ## @result
            }
        }
        elsif ($item =~ /^-?\d+$/) {
            $value = $root->[$item];
            ($ret, $retVal, @result) = _dotop_return(
                $value, $args, $returnRef,
                $scalarContext
            );
            return $retVal if ( $ret );                     ## RETURN
        }
        elsif (ref $item eq 'ARRAY' ) {
            # array slice
            return [@$root[@$item]];                        ## RETURN
        }
    }

    # NOTE: we do the can-can because UNIVSERAL::isa($something, 'UNIVERSAL')
    # doesn't appear to work with CGI, returning true for the first call
    # and false for all subsequent calls.
    elsif (ref($root) && UNIVERSAL::can($root, 'can')) {
        # if $root is a blessed reference (i.e. inherits from the
        # UNIVERSAL object base class) then we call the item as a method.
        # If that fails then we try to fallback on HASH behaviour if
        # possible.
        return ref $root->can($item) if ( $returnRef );       ## RETURN
        eval {
            @result = $scalarContext
                ? scalar $root->$item(@$args)
                : $root->$item(@$args);  ## @result
        };

        if ($@) {
            # failed to call object method, so try some fallbacks
            if (UNIVERSAL::isa($root, 'HASH')
                    && defined($value = $root->{ $item })) {
                ($ret, $retVal, @result) = _dotop_return(
                    $value, $args,
                    $returnRef, $scalarContext
                );
                return $retVal if ( $ret );                     ## RETURN
            }
            elsif (UNIVERSAL::isa($root, 'ARRAY')
                && ($value = $LIST_OPS->{ $item })) {
                @result = &$value($root, @$args);
            }
            else {
                @result = (undef, $@);
            }
        }
    }
    elsif (($value = $SCALAR_OPS->{ $item }) && ! $lvalue) {
        # at this point, it doesn't look like we've got a reference to
        # anything we know about, so we try the SCALAR_OPS pseudo-methods
        # table (but not for l-values)

        @result = &$value($root, @$args);                   ## @result
    }
    elsif ($self->{ _DEBUG }) {
        die "don't know how to access [ $root ].$item\n";   ## DIE
    }
    else {
        @result = ();
    }

    # fold multiple return items into a list unless first item is undef
    if (defined $result[0]) {
        return ref(@result > 1
            ? [ @result ]
            : $result[0]
        ) if ( $returnRef );                                    ## RETURN
        if ( $scalarContext ) {
            return scalar @result if ( @result > 1 );           ## RETURN
            return scalar(@{$result[0]}) if ( ref $result[0] eq "ARRAY" );
            return scalar(%{$result[0]}) if ( ref $result[0] eq "HASH" );
            return $result[0];                                  ## RETURN
        } else {
            return @result > 1 ? [ @result ] : $result[0];      ## RETURN
        }
    }
    elsif (defined $result[1]) {
        die $result[1];                                     ## DIE
    }
    elsif ($self->{ _DEBUG }) {
        die "$item is undefined\n";                         ## DIE
    }

    return undef;
}

#------------------------------------------------------------------------
# ($ret, $retVal, @result) = _dotop_return($value, $args, $returnRef,
#                                          $scalarContext);
#
# Handle the various return processing for _dotop
#------------------------------------------------------------------------

sub _dotop_return
{
    my($value, $args, $returnRef, $scalarContext) = @_;
    my(@result);

    return (1, ref $value) if ( $returnRef );                     ## RETURN
    if ( $scalarContext ) {
        return (1, scalar(@$value)) if ref $value eq 'ARRAY';     ## RETURN
        return (1, scalar(%$value)) if ref $value eq 'HASH';      ## RETURN
        return (1, scalar($value))  unless ref $value eq 'CODE';  ## RETURN;
        @result = scalar &$value(@$args)                          ## @result;
    } else {
        return (1, $value) unless ref $value eq 'CODE';           ## RETURN
        @result = &$value(@$args);                                ## @result
    }
    return (0, undef, @result);
}


#------------------------------------------------------------------------
# _assign($root, $item, \@args, $value, $default)
#
# Similar to _dotop() above, but assigns a value to the given variable
# instead of simply returning it.  The first three parameters are the
# root item, the item and arguments, as per _dotop(), followed by the
# value to which the variable should be set and an optional $default
# flag.  If set true, the variable will only be set if currently false
# (undefined/zero)
#------------------------------------------------------------------------

sub _assign {
    my ($self, $root, $item, $args, $value, $default) = @_;
    my $rootref = ref $root;
    my $result;
    $args ||= [ ];
    $default ||= 0;

#    print(STDERR "_assign(root=$root, item=$item, args=[@$args], \n",
#                         "value=$value, default=$default)\n")
#       if $DEBUG;

    # return undef without an error if either side of the dot is unviable
    # or if an attempt is made to update a private member, starting _ or .
    return undef                                                ## RETURN
        unless $root and defined $item and $item !~ /^[\._]/;

    if ($rootref eq 'HASH' || $rootref eq $self->{_CLASS}) {
        # if the root is a hash we set the named key
        return ($root->{ $item } = $value)                      ## RETURN
            unless $default && $root->{ $item };
    }
    elsif ($rootref eq 'ARRAY' && $item =~ /^-?\d+$/) {
            # or set a list item by index number
            return ($root->[$item] = $value)                    ## RETURN
                unless $default && $root->{ $item };
    }
    elsif (UNIVERSAL::isa($root, 'UNIVERSAL')) {
        # try to call the item as a method of an object
        return $root->$item(@$args, $value);                    ## RETURN
    }
    else {
        die "don't know how to assign to [$root].[$item]\n";    ## DIE
    }

    return undef;
}

1;

__END__

=head1 NAME

Template::Stash::Context - Experimetal stash allowing list/scalar context definition

=head1 SYNOPSIS

    use Template;
    use Template::Stash::Context;

    my $stash = Template::Stash::Context->new(\%vars);
    my $tt2   = Template->new({ STASH => $stash });

=head1 DESCRIPTION

This is an alternate stash object which includes a patch from
Craig Barratt to implement various new virtual methods to allow
dotted template variable to denote if object methods and subroutines
should be called in scalar or list context.  It adds a little overhead
to each stash call and I'm a little wary of applying that to the core
default stash without investigating the effects first. So for now,
it's implemented as a separate stash module which will allow us to
test it out, benchmark it and switch it in or out as we require.

This is what Craig has to say about it:

Here's a better set of features for the core.  Attached is a new version
of Stash.pm (based on TT2.02) that:

* supports the special op "scalar" that forces scalar context on
function calls, eg:

    cgi.param("foo").scalar

calls cgi.param("foo") in scalar context (unlike my wimpy
scalar op from last night).  Array context is the default.

With non-function operands, scalar behaves like the perl
version (eg: no-op for scalar, size for arrays, etc).

* supports the special op "ref" that behaves like the perl ref.
If applied to a function the function is not called.  Eg:

    cgi.param("foo").ref

does *not* call cgi.param and evaluates to "CODE".  Similarly,
HASH.ref, ARRAY.ref return what you expect.

* adds a new scalar and list op called "array" that is a no-op for
arrays and promotes scalars to one-element arrays.

* allows scalar ops to be applied to arrays and hashes in place,
eg: ARRAY.repeat(3) repeats each element in place.

* allows list ops to be applied to scalars by promoting the scalars
to one-element arrays (like an implicit "array").  So you can
do things like SCALAR.size, SCALAR.join and get a useful result.

This also means you can now use x.0 to safely get the first element
whether x is an array or scalar.

The new Stash.pm passes the TT2.02 test suite.  But I haven't tested the
new features very much.  One nagging implementation problem is that the
"scalar" and "ref" ops have higher precedence than user variable names.

=head1 AUTHOR

Andy Wardley E<lt>abw@wardley.orgE<gt>

L<http://wardley.org/|http://wardley.org/>

=head1 VERSION

1.63, distributed as part of the
Template Toolkit version 3.100, released on 30 March 2020.

=head1 COPYRIGHT

Copyright (C) 1996-2022 Andy Wardley.  All Rights Reserved.

This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=head1 SEE ALSO

L<Template::Stash|Template::Stash>

=cut

# Local Variables:
# mode: perl
# perl-indent-level: 4
# indent-tabs-mode: nil
# End:
#
# vim: expandtab shiftwidth=4: