File Coverage

blib/lib/Data/Xslate.pm

Criterion	Covered	Total	%
statement	114	123	92.6
branch	25	42	59.5
condition	2	4	50.0
subroutine	20	20	100.0
pod	4	5	80.0
total	165	194	85.0

package Data::Xslate;
use 5.008001;
use strict;
use warnings;
our $VERSION = '0.09';

use Text::Xslate;
use Carp qw( croak );
use Storable qw( freeze thaw );

# A tied-hash class used to expose the data as the Xslate
# vars when processing the data.
{
    package # NO INDEX
        Data::Xslate::Vars;

    use base 'Tie::Hash';

    sub TIEHASH {
        my ($class, $sub) = @_;
        return bless {sub=>$sub}, $class;
    }

    sub FETCH {
        my ($self, $key) = @_;

        return $self->{sub}->( $key );
    }
}

sub new {
    my $class = shift;

    die if @_ % 2 != 0;
    my $args = { @_ };

    my $defaults = {
        substitution_tag => '=',
        nested_key_tag   => '=',
        key_separator    => '.',
    };

    my $self = bless { %$defaults }, $class;
    foreach my $key (keys %$defaults) {
        next if ! exists $args->{$key};
        $self->{$key} = delete $args->{$key};
    }

    my $function = delete( $args->{function} ) || {};
    $function->{node} ||= \&_find_node_for_xslate;
    $self->{_xslate} = Text::Xslate->new(
        type     => 'text',
        function => $function,
        %$args,
    );

    return $self;
}

# Arguments.
sub substitution_tag { $_[0]->{substitution_tag} }
sub nested_key_tag { $_[0]->{nested_key_tag} }
sub key_separator { $_[0]->{key_separator} }

# Attributes.
sub _xslate { $_[0]->{_xslate} }

# State variables, only used during local() calls to maintain
# state in recursive function calls.
our $XSLATE;
our $VARS;
our $ROOT;
our $NODES;
our $SUBSTITUTION_TAG;
our $NESTED_KEY_TAG;
our $KEY_SEPARATOR;
our $PATH_FOR_XSLATE;

sub render {
    my ($self, $data) = @_;

    $data = thaw( freeze( $data ) );

    local $Carp::Internal{ (__PACKAGE__) } = 1;

    local $XSLATE = $self->_xslate();

    my %vars;
    tie %vars, 'Data::Xslate::Vars', \&_find_node_for_xslate;
    local $VARS = \%vars;

    local $ROOT = $data;
    local $NODES = {};
    local $SUBSTITUTION_TAG = $self->substitution_tag();
    local $NESTED_KEY_TAG = $self->nested_key_tag();
    local $KEY_SEPARATOR = $self->key_separator();

    return _evaluate_node( 'root' => $data );
}

sub _evaluate_node {
    my ($path, $node) = @_;

    return $NODES->{$path} if exists $NODES->{$path};

    if (!ref $node) {
        if (defined $node) {
            if ($node =~ m{^\Q$SUBSTITUTION_TAG\E\s*(.+?)\s*$}) {
                $node = _find_node( $1, $path );
            }
            else {
                local $PATH_FOR_XSLATE = $path;
                $node = $XSLATE->render_string( $node, $VARS );
            }
        }
        $NODES->{$path} = $node;
    }
    elsif (ref($node) eq 'HASH') {
        $NODES->{$path} = $node;
        foreach my $key (sort keys %$node) {
            if ($key =~ m{^(.*)\Q$NESTED_KEY_TAG\E$}) {
                my $sub_path = "$path$KEY_SEPARATOR$1";
                my $value = delete $node->{$key};
                _set_node( $sub_path, $value );
            }
            else {
                my $sub_path = "$path$KEY_SEPARATOR$key";
                $node->{$key} = _evaluate_node( $sub_path, $node->{$key} );
            }
        }
    }
    elsif (ref($node) eq 'ARRAY') {
        $NODES->{$path} = $node;
        @$node = (
            map { _evaluate_node( "$path$KEY_SEPARATOR$_" => $node->[$_] ) }
            (0..$#$node)
        );
    }
    else {
        croak "The config node at $path is neither a hash, array, or scalar";
    }

    return $node;
}

sub _load_node {
    my ($path) = @_;

    my @parts = split(/\Q$KEY_SEPARATOR\E/, $path);
    my $built_path = shift( @parts ); # root

    my $node = $ROOT;
    while (@parts) {
        my $key = shift( @parts );
        $built_path .= "$KEY_SEPARATOR$key";

        if (ref($node) eq 'HASH') {
            return undef if !exists $node->{$key};
            $node = _evaluate_node( $built_path => $node->{$key} );
        }
        elsif (ref($node) eq 'ARRAY') {
            return undef if $key > $#$node;
            $node = _evaluate_node( $built_path => $node->[$key] );
        }
        else {
            croak "The config node at $path is neither a hash or array";
        }
    }

    return $node;
}

sub _find_node {
    my ($path, $from_path) = @_;

    if ($path =~ m{^\Q$KEY_SEPARATOR\E(.+)}) {
        $path = $1;
        $from_path = "root${KEY_SEPARATOR}root_sub_key_that_is_not_used_for_absolute_keys";
    }

    my @parts = split(/\Q$KEY_SEPARATOR\E/, $from_path);
    pop( @parts );

    while (@parts) {
        my $sub_path = join($KEY_SEPARATOR, @parts);

        my $node = _load_node( "$sub_path$KEY_SEPARATOR$path" );
        return $node if $node;

        pop( @parts );
    }

    return _load_node( $path );
}

sub _find_node_for_xslate {
    my ($path) = @_;
    return _find_node( $path, $PATH_FOR_XSLATE );
}

sub _set_node {
    my ($path, $value) = @_;

    my @parts = split(/\Q$KEY_SEPARATOR\E/, $path);
    my $built_path = shift( @parts ); # root
    my $last_part = pop( @parts );

    my $node = $ROOT;
    while (@parts) {
        my $key = shift( @parts );
        $built_path .= "$KEY_SEPARATOR$key";

        if (ref($node) eq 'HASH') {
            return 0 if !exists $node->{$key};
            $node = _evaluate_node( $built_path => $node->{$key} );
        }
        elsif (ref($node) eq 'ARRAY') {
            return 0 if $key > $#$node;
            $node = _evaluate_node( $built_path => $node->[$key] );
        }
        else {
            croak "The config node at $path is neither a hash or array";
        }
    }

    delete $NODES->{$path};
    $value = _evaluate_node( $path => $value );

    if (ref($node) eq 'HASH') {
        $node->{$last_part} = $value;
    }
    elsif (ref($node) eq 'ARRAY') {
        $node->[$last_part] = $value;
    }

    return 1;
}

1;
__END__