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


line stmt bran cond sub pod time code
1             package Data::Xslate;
2 4     4   851850 use 5.008001;
  4         29  
3 4     4   21 use strict;
  4         8  
  4         72  
4 4     4   20 use warnings;
  4         4  
  4         169  
5             our $VERSION = '0.07';
6              
7 4     4   2432 use Text::Xslate;
  4         50448  
  4         214  
8 4     4   33 use Carp qw( croak );
  4         8  
  4         199  
9 4     4   2852 use Storable qw( freeze thaw );
  4         12696  
  4         369  
10              
11             # A tied-hash class used to expose the data as the Xslate
12             # vars when processing the data.
13             {
14             package # NO INDEX
15             Data::Xslate::Vars;
16              
17 4     4   35 use base 'Tie::Hash';
  4         12  
  4         6472  
18              
19             sub TIEHASH {
20 458     458   904 my ($class, $sub) = @_;
21 458         1558 return bless {sub=>$sub}, $class;
22             }
23              
24             sub FETCH {
25 7     7   8348 my ($self, $key) = @_;
26              
27 7         41 return $self->{sub}->( $key );
28             }
29             }
30              
31             sub new {
32 153     153 0 371007 my $class = shift;
33              
34 153 50       591 die if @_ % 2 != 0;
35 153         510 my $args = { @_ };
36              
37 153         521 my $defaults = {
38             substitution_tag => '=',
39             nested_key_tag => '=',
40             key_separator => '.',
41             };
42              
43 153         585 my $self = bless { %$defaults }, $class;
44 153         479 foreach my $key (keys %$defaults) {
45 459 100       853 next if ! exists $args->{$key};
46 450         848 $self->{$key} = delete $args->{$key};
47             }
48              
49 153   50     709 my $function = delete( $args->{function} ) || {};
50 153   50     743 $function->{node} ||= \&_find_node_for_xslate;
51 153         730 $self->{_xslate} = Text::Xslate->new(
52             type => 'text',
53             function => $function,
54             %$args,
55             );
56              
57 153         43695 return $self;
58             }
59              
60             # Arguments.
61 458     458 1 845 sub substitution_tag { $_[0]->{substitution_tag} }
62 458     458 1 859 sub nested_key_tag { $_[0]->{nested_key_tag} }
63 458     458 1 736 sub key_separator { $_[0]->{key_separator} }
64              
65             # Attributes.
66 458     458   1113 sub _xslate { $_[0]->{_xslate} }
67              
68             # State variables, only used during local() calls to maintain
69             # state in recursive function calls.
70             our $XSLATE;
71             our $VARS;
72             our $ROOT;
73             our $NODES;
74             our $SUBSTITUTION_TAG;
75             our $NESTED_KEY_TAG;
76             our $KEY_SEPARATOR;
77             our $PATH_FOR_XSLATE;
78              
79             sub render {
80 458     458 1 277837 my ($self, $data) = @_;
81              
82 458         1390 $data = thaw( freeze( $data ) );
83              
84 458         26230 local $Carp::Internal{ (__PACKAGE__) } = 1;
85              
86 458         1044 local $XSLATE = $self->_xslate();
87              
88 458         728 my %vars;
89 458         1755 tie %vars, 'Data::Xslate::Vars', \&_find_node_for_xslate;
90 458         809 local $VARS = \%vars;
91              
92 458         684 local $ROOT = $data;
93 458         713 local $NODES = {};
94 458         829 local $SUBSTITUTION_TAG = $self->substitution_tag();
95 458         851 local $NESTED_KEY_TAG = $self->nested_key_tag();
96 458         803 local $KEY_SEPARATOR = $self->key_separator();
97              
98 458         800 return _evaluate_node( 'root' => $data );
99             }
100              
101             sub _evaluate_node {
102 2632     2632   4899 my ($path, $node) = @_;
103              
104 2632 100       6772 return $NODES->{$path} if exists $NODES->{$path};
105              
106 1847 100       4071 if (!ref $node) {
    100          
    50          
107 931 50       1737 if (defined $node) {
108 931 100       5808 if ($node =~ m{^\Q$SUBSTITUTION_TAG\E\s*(.+?)\s*$}) {
109 157         366 $node = _find_node( $1, $path );
110             }
111             else {
112 774         1396 local $PATH_FOR_XSLATE = $path;
113 774         3347 $node = $XSLATE->render_string( $node, $VARS );
114             }
115             }
116 931         1373169 $NODES->{$path} = $node;
117             }
118             elsif (ref($node) eq 'HASH') {
119 915         1789 $NODES->{$path} = $node;
120 915         3096 foreach my $key (sort keys %$node) {
121 1386 100       6473 if ($key =~ m{^(.*)\Q$NESTED_KEY_TAG\E$}) {
122 152         537 my $sub_path = "$path$KEY_SEPARATOR$1";
123 152         324 my $value = delete $node->{$key};
124 152         357 _set_node( $sub_path, $value );
125             }
126             else {
127 1234         2715 my $sub_path = "$path$KEY_SEPARATOR$key";
128 1234         2393 $node->{$key} = _evaluate_node( $sub_path, $node->{$key} );
129             }
130             }
131             }
132             elsif (ref($node) eq 'ARRAY') {
133 1         4 $NODES->{$path} = $node;
134             @$node = (
135 1         5 map { _evaluate_node( "$path$KEY_SEPARATOR$_" => $node->[$_] ) }
  3         20  
136             (0..$#$node)
137             );
138             }
139             else {
140 0         0 croak "The config node at $path is neither a hash, array, or scalar";
141             }
142              
143 1847         6862 return $node;
144             }
145              
146             sub _load_node {
147 324     324   590 my ($path) = @_;
148              
149 324         882 my @parts = split(/\Q$KEY_SEPARATOR\E/, $path);
150 324         619 my $built_path = shift( @parts ); # root
151              
152 324         544 my $node = $ROOT;
153 324         669 while (@parts) {
154 640         963 my $key = shift( @parts );
155 640         1196 $built_path .= "$KEY_SEPARATOR$key";
156              
157 640 50       1342 if (ref($node) eq 'HASH') {
    0          
158 640 100       1370 return undef if !exists $node->{$key};
159 633         1131 $node = _evaluate_node( $built_path => $node->{$key} );
160             }
161             elsif (ref($node) eq 'ARRAY') {
162 0 0       0 return undef if $key > $#$node;
163 0         0 $node = _evaluate_node( $built_path => $node->[$key] );
164             }
165             else {
166 0         0 croak "The config node at $path is neither a hash or array";
167             }
168             }
169              
170 317         676 return $node;
171             }
172              
173             sub _find_node {
174 317     317   841 my ($path, $from_path) = @_;
175              
176 317 100       1395 if ($path =~ m{^\Q$KEY_SEPARATOR\E(.+)}) {
177 1         4 $path = $1;
178 1         4 $from_path = "root${KEY_SEPARATOR}root_sub_key_that_is_not_used_for_absolute_keys";
179             }
180              
181 317         1250 my @parts = split(/\Q$KEY_SEPARATOR\E/, $from_path);
182 317         553 pop( @parts );
183              
184 317         814 while (@parts) {
185 324         738 my $sub_path = join($KEY_SEPARATOR, @parts);
186              
187 324         876 my $node = _load_node( "$sub_path$KEY_SEPARATOR$path" );
188 324 100       1532 return $node if $node;
189              
190 7         16 pop( @parts );
191             }
192              
193 0         0 return _load_node( $path );
194             }
195              
196             sub _find_node_for_xslate {
197 160     160   255680 my ($path) = @_;
198 160         433 return _find_node( $path, $PATH_FOR_XSLATE );
199             }
200              
201             sub _set_node {
202 152     152   384 my ($path, $value) = @_;
203              
204 152         691 my @parts = split(/\Q$KEY_SEPARATOR\E/, $path);
205 152         341 my $built_path = shift( @parts ); # root
206 152         299 my $last_part = pop( @parts );
207              
208 152         240 my $node = $ROOT;
209 152         377 while (@parts) {
210 152         283 my $key = shift( @parts );
211 152         345 $built_path .= "$KEY_SEPARATOR$key";
212              
213 152 50       387 if (ref($node) eq 'HASH') {
    0          
214 152 50       402 return 0 if !exists $node->{$key};
215 152         331 $node = _evaluate_node( $built_path => $node->{$key} );
216             }
217             elsif (ref($node) eq 'ARRAY') {
218 0 0       0 return 0 if $key > $#$node;
219 0         0 $node = _evaluate_node( $built_path => $node->[$key] );
220             }
221             else {
222 0         0 croak "The config node at $path is neither a hash or array";
223             }
224             }
225              
226 152         322 delete $NODES->{$path};
227 152         299 $value = _evaluate_node( $path => $value );
228              
229 152 50       427 if (ref($node) eq 'HASH') {
    0          
230 152         327 $node->{$last_part} = $value;
231             }
232             elsif (ref($node) eq 'ARRAY') {
233 0         0 $node->[$last_part] = $value;
234             }
235              
236 152         455 return 1;
237             }
238              
239             1;
240             __END__