File Coverage

blib/lib/Text/Template/Compact.pm
Criterion Covered Total %
statement 901 964 93.4
branch 277 388 71.3
condition 105 151 69.5
subroutine 155 155 100.0
pod 0 33 0.0
total 1438 1691 85.0


line stmt bran cond sub pod time code
1             #!perl --
2             package Text::Template::Compact;
3 4     4   110554 use utf8;
  4         22  
  4         58  
4 4     4   113 use strict;
  4         10  
  4         150  
5 4     4   23 use warnings;
  4         12  
  4         134  
6 4     4   12200 use Encode;
  4         44218  
  4         345  
7 4     4   37 use Carp;
  4         6  
  4         2001  
8             our $VERSION = "0.1.11";
9            
10             sub getDataType($){
11             # return empty string if not reference type.
12 1446 100   1446 0 2887 return '' if not ref $_[0];
13             # use scalar to avoid bless.
14 1444         4594 $_[0]=~/(\w+)\(/;
15 1444         3636 return $1;
16             }
17            
18             # decode "quoted" string to plain.
19             sub decodeQuote{
20 686 50 33 686 0 2320 return if not @_ or not defined $_[0];
21 686 100       2933 return $_[0] if not $_[0] =~ /^"/;
22 226         498 my $r = substr($_[0],1,length($_[0])-2);
23 226         311 $r =~ s/""/"/g;
24 226         914 return $r;
25             }
26            
27             # defined or ...
28             sub dor{
29 866 100   866 0 1433 for(@_){ defined($_) and return $_;}
  1260         3398  
30 1         2 return;
31             }
32            
33             # filter for variable expansion
34             our %filter_map =(
35             raw => sub{
36             return $_[0];
37             },
38             html => sub{
39             my $a = $_[0];
40             $a =~ s/&/&/g;
41             $a =~ s/
42             $a =~ s/>/>/g;
43             $a =~ s/"/"/g;
44             $a =~ s/'/'/g;
45             $a =~ s/\n/
\n/g;
46             return $a;
47             },
48             nobr => sub{
49             my $a = $_[0];
50             $a =~ s/&/&/g;
51             $a =~ s/
52             $a =~ s/>/>/g;
53             $a =~ s/"/"/g;
54             $a =~ s/'/'/g;
55             return $a;
56             },
57             uri => sub{
58             my $a = Encode::encode('utf8',$_[0]);
59             $a =~ s/([^a-zA-Z0-9_.!~*'()-])/'%' . unpack('H2', $1)/eg;
60             return $a;
61             },
62             );
63            
64             {
65             package Text::Template::Compact::ExprParser;
66 4     4   20 use Carp;
  4         16  
  4         8539  
67             our @ExprOperator;
68             our %ExprOperator;
69             our $token_re;
70             our $dataset;
71             our $list_op_prio;
72             {
73             my $prio=0;
74             for(
75             # 優先順序が同じ場合の結合順序: L=左結合((a+b)+c) R=右結合(a=(b=c)) _=非結合
76             # 演算子の見た目:
77             # b (braket) (a) のような外見,
78             # l (left) 左側の単項演算子。 +num
79             # a (array) a[b] のような外見,
80             # r (right) 右側の単項演算子。 num++
81             # m (middle) 二項演算子 a ** b
82             # t (tri) 三項演算子 a?b:c
83             # k (keyword) 二項演算子 a.keyword 演算子の右側に式ではなくキーワードが入る
84             # c (const) 定数
85             # K (const) キーワード
86             # 優先順序の区切り: []
87             ['Lb','(',1,sub{ return $_[0];},')'],
88             ['La','(',1,sub{
89             # find list operator
90             my $key = $dataset->getV($_[0]);
91             my $op = findOp($key,qr/l/);
92             $op or return $dataset->encode("[Error: $op() is not found]");
93             return $op->{_eval}->($_[1]);
94             },')'],
95             [],
96             ['Lk','.',2,sub{ return $dataset->child($_[0],$_[1] ) } ],
97             ['La','[',2,sub{ return $dataset->child($_[0],$dataset->encode($dataset->getV($_[1]))) },']' ],
98             [],
99 4     4   34 ['_l','++',1,sub{ no warnings; my $v= $dataset->getV($_[0]); $dataset->setV($_[0],++$v); return $dataset->encode( $v);} ],
  4         8  
  4         473  
100 4     4   23 ['_l','--',1,sub{ no warnings; my $v= $dataset->getV($_[0]); $dataset->setV($_[0],--$v); return $dataset->encode( $v);} ],
  4         7  
  4         370  
101 4     4   21 ['_r','++',1,sub{ no warnings; my $v= $dataset->getV($_[0]); $dataset->setV($_[0],++$v); return $dataset->encode(--$v);} ],
  4         7  
  4         461  
102 4     4   38 ['_r','--',1,sub{ no warnings; my $v= $dataset->getV($_[0]); $dataset->setV($_[0],--$v); return $dataset->encode(++$v);} ],
  4         6  
  4         396  
103             [],
104 4     4   21 ['Rm','**',2,sub{ no warnings; return $dataset->encode($dataset->getV($_[0])**$dataset->getV($_[1])); } ],
  4         7  
  4         493  
105             [],
106 4     4   25 ['Rl','!',1,sub{ no warnings; return $dataset->encode(!$dataset->getV($_[0]))} ],
  4         7  
  4         263  
107 4     4   19 ['Rl','~',1,sub{ no warnings; return $dataset->encode(~(0+$dataset->getV($_[0])))} ],
  4         7  
  4         281  
108 4     4   33 ['Rl','+',1,sub{ no warnings; return $dataset->encode(+$dataset->getV($_[0]))} ],
  4         6  
  4         257  
109 4     4   19 ['Rl','-',1,sub{ no warnings; return $dataset->encode(-$dataset->getV($_[0]))} ],
  4         7  
  4         302  
110             [],
111 4     4   22 ['Lm','*',2,sub{ no warnings; return $dataset->encode($dataset->getV($_[0]) * $dataset->getV($_[1])) }],
  4         7  
  4         319  
112 4     4   21 ['Lm','/',2,sub{ no warnings; return $dataset->encode($dataset->getV($_[0]) / $dataset->getV($_[1])) }],
  4         7  
  4         287  
113 4     4   29 ['Lm','%',2,sub{ no warnings; return $dataset->encode($dataset->getV($_[0]) % $dataset->getV($_[1])) }],
  4         6  
  4         295  
114 4     4   19 ['Lm','repeat',2,sub{ no warnings; return $dataset->encode($dataset->getV($_[0]) x $dataset->getV($_[1])) }],
  4         7  
  4         417  
115             [],
116 4     4   20 ['Lm','+',2,sub{ no warnings; return $dataset->encode($dataset->getV($_[0]) + $dataset->getV($_[1])) } ],
  4         6  
  4         354  
117 4     4   20 ['Lm','-',2,sub{ no warnings; return $dataset->encode($dataset->getV($_[0]) - $dataset->getV($_[1])) } ],
  4         8  
  4         294  
118 4     4   21 ['Lm','cat',2,sub{ no warnings; return $dataset->encode($dataset->getV($_[0]) . $dataset->getV($_[1])) } ],
  4         13  
  4         426  
119             [],
120 4     4   25 ['Lm','<<',2,sub{ no warnings; return $dataset->encode($dataset->getV($_[0]) << $dataset->getV($_[1])) } ],
  4         7  
  4         409  
121 4     4   21 ['Lm','>>',2,sub{ no warnings; return $dataset->encode($dataset->getV($_[0]) >> $dataset->getV($_[1])) } ],
  4         19  
  4         605  
122             [],
123             ['_l','defined' ,1,sub{ return $dataset->encode( defined($dataset->getV($_[0])) ?1:0); }],
124             ['_l','bool' ,1,sub{ return $dataset->encode($dataset->getV($_[0]) ?1:0); }],
125 4     4   21 ['_l','nz' ,1,sub{ no warnings; return $dataset->encode($dataset->getV($_[0])!=0 ?1:0); }],
  4         7  
  4         330  
126 4     4   21 ['_l','int' ,1,sub{ no warnings; return $dataset->encode(int $dataset->getV($_[0]) ); }],
  4         5  
  4         1400  
127             ['_l','length' ,1,sub{
128             my $v =$dataset->getV($_[0]);
129             defined($v) or return $dataset->encode(undef);
130             ref($v) or return $dataset->encode(length $v);
131             my $type = Text::Template::Compact::getDataType($v);
132             $type =~ /ARRAY/ and return $dataset->encode(scalar @$v);
133             $type =~ /HASH/ and return $dataset->encode(scalar keys %$v);
134             return $dataset->encode(length $v);
135             }],
136             ['l','pop',1,sub{
137             my $ra = $dataset->getV($_[0]);
138             if(Text::Template::Compact::getDataType($ra) =~ /ARRAY/ ){
139             return $dataset->encode( pop @$ra );
140             }
141             return $dataset->encode( undef );
142             }],
143             ['l','shift',1,sub{
144             my $ra = $dataset->getV($_[0]);
145             if(Text::Template::Compact::getDataType($ra) =~ /ARRAY/ ){
146             return $dataset->encode( shift @$ra );
147             }
148             return $dataset->encode( undef );
149             }],
150             [],
151 4     4   23 ['_m','<' ,2,sub{ no warnings; return $dataset->encode($dataset->getV($_[0]) < $dataset->getV($_[1])) }],
  4         7  
  4         310  
152 4     4   19 ['_m','>' ,2,sub{ no warnings; return $dataset->encode($dataset->getV($_[0]) > $dataset->getV($_[1])) }],
  4         7  
  4         320  
153 4     4   20 ['_m','<=' ,2,sub{ no warnings; return $dataset->encode($dataset->getV($_[0]) <= $dataset->getV($_[1])) }],
  4         7  
  4         254  
154 4     4   19 ['_m','>=' ,2,sub{ no warnings; return $dataset->encode($dataset->getV($_[0]) >= $dataset->getV($_[1])) }],
  4         7  
  4         376  
155 4     4   27 ['_m','lt' ,2,sub{ no warnings; return $dataset->encode($dataset->getV($_[0]) lt $dataset->getV($_[1])) }],
  4         43  
  4         297  
156 4     4   19 ['_m','gt' ,2,sub{ no warnings; return $dataset->encode($dataset->getV($_[0]) gt $dataset->getV($_[1])) }],
  4         6  
  4         311  
157 4     4   24 ['_m','le' ,2,sub{ no warnings; return $dataset->encode($dataset->getV($_[0]) le $dataset->getV($_[1])) }],
  4         8  
  4         308  
158 4     4   19 ['_m','ge' ,2,sub{ no warnings; return $dataset->encode($dataset->getV($_[0]) ge $dataset->getV($_[1])) }],
  4         8  
  4         274  
159             [],
160 4     4   19 ['_m','==' ,2,sub{ no warnings; return $dataset->encode($dataset->getV($_[0]) == $dataset->getV($_[1])) }],
  4         25  
  4         313  
161 4     4   18 ['_m','!=' ,2,sub{ no warnings; return $dataset->encode($dataset->getV($_[0]) != $dataset->getV($_[1])) }],
  4         5  
  4         277  
162 4     4   19 ['_m','<=>' ,2,sub{ no warnings; return $dataset->encode($dataset->getV($_[0]) <=> $dataset->getV($_[1])) }],
  4         5  
  4         251  
163 4     4   28 ['_m','eq' ,2,sub{ no warnings; return $dataset->encode($dataset->getV($_[0]) eq $dataset->getV($_[1])) }],
  4         7  
  4         365  
164 4     4   23 ['_m','ne' ,2,sub{ no warnings; return $dataset->encode($dataset->getV($_[0]) ne $dataset->getV($_[1])) }],
  4         8  
  4         296  
165 4     4   20 ['_m','cmp' ,2,sub{ no warnings; return $dataset->encode($dataset->getV($_[0]) cmp $dataset->getV($_[1])) }],
  4         11  
  4         260  
166             [],
167 4     4   18 ['Lm','&' ,2,sub{ no warnings; return $dataset->encode($dataset->getV($_[0])+0 & 0+$dataset->getV($_[1])) }],
  4         5  
  4         277  
168             [],
169 4     4   19 ['Lm','|' ,2,sub{ no warnings; return $dataset->encode($dataset->getV($_[0])+0 | 0+$dataset->getV($_[1])) }],
  4         6  
  4         377  
170 4     4   21 ['Lm','^' ,2,sub{ no warnings; return $dataset->encode($dataset->getV($_[0])+0 ^ 0+$dataset->getV($_[1])) }],
  4         7  
  4         1110  
171             [],
172             ['Lm','&&',2,sub{ return $dataset->getV($_[0]) ?$_[1]:$_[0]; }],
173             [],
174             ['Lm','||',2,sub{ return $dataset->getV($_[0]) ?$_[0]:$_[1]; }],
175             ['Lm','//',2,sub{ return defined($dataset->getV($_[0])) ?$_[0]:$_[1]; }],
176             [],
177             ['Rt','?' ,3,sub{ return $dataset->getV($_[0])? $_[1]:$_[2]; },':'],
178             [],
179             [ 'Rm', '=',2,sub{ $dataset->setV($_[0],$dataset->getV($_[1]) ); return $_[0]; }],
180 4     4   23 [ 'Rm','**=',2,sub{ no warnings; $dataset->setV($_[0],$dataset->getV($_[0]) ** $dataset->getV($_[1]) ); return $_[0]; }],
  4         7  
  4         464  
181 4     4   20 [ 'Rm', '*=',2,sub{ no warnings; $dataset->setV($_[0],$dataset->getV($_[0]) * $dataset->getV($_[1]) ); return $_[0]; }],
  4         7  
  4         303  
182 4     4   19 [ 'Rm', '/=',2,sub{ no warnings; $dataset->setV($_[0],$dataset->getV($_[0]) / $dataset->getV($_[1]) ); return $_[0]; }],
  4         6  
  4         319  
183 4     4   19 [ 'Rm', '%=',2,sub{ no warnings; $dataset->setV($_[0],$dataset->getV($_[0]) % $dataset->getV($_[1]) ); return $_[0]; }],
  4         7  
  4         364  
184 4     4   21 [ 'Rm', '+=',2,sub{ no warnings; $dataset->setV($_[0],$dataset->getV($_[0]) + $dataset->getV($_[1]) ); return $_[0]; }],
  4         6  
  4         344  
185 4     4   18 [ 'Rm', '-=',2,sub{ no warnings; $dataset->setV($_[0],$dataset->getV($_[0]) - $dataset->getV($_[1]) ); return $_[0]; }],
  4         9  
  4         366  
186 4     4   23 [ 'Rm','<<=',2,sub{ no warnings; $dataset->setV($_[0],$dataset->getV($_[0]) << $dataset->getV($_[1]) ); return $_[0]; }],
  4         12  
  4         307  
187 4     4   22 [ 'Rm','>>=',2,sub{ no warnings; $dataset->setV($_[0],$dataset->getV($_[0]) >> $dataset->getV($_[1]) ); return $_[0]; }],
  4         6  
  4         407  
188 4     4   44 [ 'Rm','&=' ,2,sub{ no warnings; $dataset->setV($_[0],$dataset->getV($_[0])+0&0+$dataset->getV($_[1]) ); return $_[0]; }],
  4         9  
  4         338  
189 4     4   20 [ 'Rm','|=' ,2,sub{ no warnings; $dataset->setV($_[0],$dataset->getV($_[0])+0|0+$dataset->getV($_[1]) ); return $_[0]; }],
  4         6  
  4         327  
190 4     4   21 [ 'Rm','^=' ,2,sub{ no warnings; $dataset->setV($_[0],$dataset->getV($_[0])+0^0+$dataset->getV($_[1]) ); return $_[0]; }],
  4         5  
  4         21987  
191             [ 'Rm','&&=',2,sub{ $dataset->getV($_[0]) and $dataset->setV($_[0],$dataset->getV($_[1])); return $_[0]; }],
192             [ 'Rm','||=',2,sub{ $dataset->getV($_[0]) or $dataset->setV($_[0],$dataset->getV($_[1])); return $_[0]; }],
193             [ 'Rm','//=',2,sub{ defined($dataset->getV($_[0])) or $dataset->setV($_[0],$dataset->getV($_[1])); return $_[0]; }],
194            
195             [],
196             ['Lm',',',2,sub{ return $dataset->makepathlist($_[0],$_[1]);}],
197             [],
198             ['l','print',1,sub{
199             my @list;
200             $dataset->getVlist(\@list,$_[0]);
201             $dataset->print( @list);
202             return $dataset->encode('');
203             }],
204             ['l','join',1,sub{
205             my @list;
206             $dataset->getVlist(\@list,$_[0]);
207             @list or return $dataset->encode('');
208             my $delm = shift @list;
209             my $a = join $delm,@list;
210             return $dataset->encode( $a );
211             }],
212             ['l','scalar',1,sub{
213             my @list;
214             $dataset->getVlist(\@list,$_[0]);
215             return $dataset->encode( scalar @list );
216             }],
217             ['l','push',1,sub{
218             my @list;
219             $dataset->getVlist(\@list,$_[0]);
220             if( @list and Text::Template::Compact::getDataType($list[0]) =~ /ARRAY/ ){
221             my $ra = shift @list;
222             push @$ra,@list;
223             }
224             return $dataset->encode( undef );
225             }],
226             ['l','unshift',1,sub{
227             my @list;
228             $dataset->getVlist(\@list,$_[0]);
229             if(@list and Text::Template::Compact::getDataType($list[0]) =~ /ARRAY/ ){
230             my $ra = shift @list;
231             unshift @$ra,@list;
232             }
233             return $dataset->encode( undef );
234             }],
235             ['l','call',1,sub{
236             my @list;
237             $dataset->getVlist(\@list,$_[0]);
238             local $_ = $dataset->{tmpl}{param};
239             if(@list and Text::Template::Compact::getDataType($list[0]) =~ /CODE/ ){
240             my $coderef = shift @list;
241             my $rv = eval{ $coderef->(@list); };
242             $@ and $rv = "[Error: $@]";
243             return $dataset->encode( $rv );
244             }elsif( @list >= 2 ){
245             my $obj = shift @list;
246             my $method = shift @list;
247             my $rv = eval{ $obj->$method(@list); };
248             $@ and $rv = "[Error: $@]";
249             return $dataset->encode( $rv );
250             }
251             return $dataset->encode( undef );
252             }],
253             ['l','makearray',1,sub{
254             my @list;
255             $dataset->getVlist(\@list,$_[0]);
256             return $dataset->encode( \@list );
257             }],
258             ['l','makehash',1,sub{
259             my @list;
260             $dataset->getVlist(\@list,$_[0]);
261             return $dataset->encode( {@list} );
262             }],
263             [],
264             # not and or xor
265             ['Rl','not',1,sub{ return $dataset->encode(not $dataset->getV($_[0]));} ],
266             [],
267             ['Lm','and',2,sub{ return $dataset->encode( $dataset->getV($_[0]) and $dataset->getV($_[1])); }],
268             [],
269             ['Lm','or' ,2,sub{ return $dataset->encode( $dataset->getV($_[0]) or $dataset->getV($_[1])); }],
270             ['Lm','xor',2,sub{ return $dataset->encode( $dataset->getV($_[0]) xor $dataset->getV($_[1])); }],
271             ){
272             if(not @$_){ ++$prio; next; }
273             my $item = {
274             prio => $prio,
275             assoc => $_->[0],
276             key1 => $_->[1],
277             count => $_->[2],
278             _eval => $_->[3],
279             key2 => $_->[4],
280             };
281             ( $item->{key1} eq 'print') and $list_op_prio=$prio;
282            
283             push @ExprOperator,$item;
284             # defined($ExprOperator{ $item->{key1} }) or $ExprOperator{ $item->{key1} }=[];
285             push @{$ExprOperator{ $item->{key1} }},$item;
286             }
287             # make re
288             my %c;
289             for( '#',',',';','-|','$','$$',map {$_->{key1},$_->{key2}} @ExprOperator){
290             next if not defined or not length;
291             next if /^\w+$/;
292             my $text = $_;
293             my $map = \%c;
294             for(my $i=0;$i
295             my $c = substr($text,$i,1);
296             $map->{$c} or $map->{$c}={};
297             $map = $map->{$c};
298             }
299             }
300             sub toRe{
301 163     163   232 my($map)=@_;
302 163         212 my @list;
303 163         484 while(my($k,$v)=each %$map){
304 160         324 my $sub = toRe($v);
305 160 100       254 if($sub){
306 61         249 push @list,quotemeta($k).$sub."?";
307             }else{
308 100         629 push @list,quotemeta($k);
309             }
310             }
311 163 100       377 @list > 1 and return "(?:".join('|',@list).")";
312 136 100       295 @list and return $list[0];
313 100         190 return;
314             }
315             my $a = toRe(\%c);
316             $token_re = qr/$a/;
317             }
318            
319             sub findOp{
320 1522     1522   1989 my($token,$re)=@_;
321 1522 100       4629 my $list = $ExprOperator{ $token } or return;
322 467 100       771 for(@$list){ return $_ if $_->{assoc} =~ $re; }
  520         3453  
323 43         123 return;
324             }
325            
326             {
327             package Text::Template::Compact::ExprNode;
328             sub new{
329 523     523   763 my($class,$op,$text)=@_;
330 523 100       1188 if(not ref $op){
331             # keyword?
332 286 50       549 return $text if $op eq 'k';
333             # root operator?
334             $op = {
335             assoc => '_',
336             key1 => 'root',
337 1283     1283   1909 _eval => sub{ return $_[0]; },
338 286         1877 count => 1,
339             prio => 999,
340             };
341             }
342 523         3293 return bless{ op=>$op, args=>[],},$class;
343             };
344             sub addArg{
345 844     844   972 my $self=shift;
346 844         996 push @{$self->{args}},@_;
  844         2402  
347             }
348             sub toString{
349 1     1   27 my($self,$mark)=@_;
350 1 0       5 defined($mark) or $mark = '';
351 1 0       1 if($self->{op}{key1} eq 'root'){
352 1 0       32 return join(',',map{ ref($_)?$_->toString($mark):$_} @{$self->{args}});
  1         5  
  1         3  
353             }
354             return
355 1 0       6 $self->{op}{key1}
356             .($self->{closed}?$self->{op}{key2}:'')
357             .($mark eq $self ?"<=HERE=>":'')
358             .'{'
359 1 0       41 .join(',',map{ ref($_)?$_->toString($mark):$_ } @{$self->{args}} )
  1 0       1  
360             .'}';
361             }
362             sub _eval{
363 2036     2036   2100 my($self)=@_;
364 2036 100       1887 my @args = map{ ref($_) ? $_->_eval() : $Text::Template::Compact::ExprParser::dataset->token2path($_) } @{$self->{args}};
  2524         6215  
  2036         3864  
365 2036   66     10136 my $r = ($self->{realop} || $self->{op})->{_eval}(@args);
366 2036         6099 return $r;
367             }
368             sub eval{
369 1283     1283   1483 my($self,$dataset)=@_;
370 1283         1470 local $Text::Template::Compact::ExprParser::dataset = $dataset;
371 1283         1266 my $r = CORE::eval{ $self->_eval();};
  1283         2146  
372 1283 50       2343 $@ and return ['i',"[Error: $@ in ".$self->toString." in Text::Template::Compact::ExprNode::eval]"];
373 1283         2818 return $r;
374             }
375             }
376            
377             our $verbose = 0;
378            
379             sub peekToken{
380 2394     2394   2555 my $self = shift;
381 2394 100       2336 @{$self->{token}} and return $self->{token}[0];
  2394         7212  
382 1172         1707 return;
383             }
384             sub reduce{
385 1000     1000   1591 my($self,$where)=@_;
386            
387 1000 100       2573 return if $self->{allow_child};
388            
389 514         884 my $a = $self->peekToken;
390            
391             # スタックが空ならreduceできない
392 514 100       722 return if @{$self->{stack}}==1;
  514         1502  
393            
394 229         384 my $target = $self->{stack}[0];
395            
396             # 注目ノードの種別が () []だった
397 229 100       601 if( $target->{op}{assoc} =~ /[ba]/ ){
398 26 50 33     236 if( defined($a) and $a eq $target->{op}{key2}
  26   33     136  
399             and @{$target->{args}} == $target->{op}->{count}
400             ){
401 26 50       67 $verbose>0 and warn "remove end of braket $target->{op}{key2}. reduce in $where\n";
402 26         50 $target->{closed} = 1;
403 26         66 shift @{$self->{token}};
  26         45  
404 26         39 shift @{$self->{stack}};
  26         81  
405 26         42 $self->{allow_child} = 0;
406 26         99 return 1;
407             }
408             }else{
409 204 100       406 if( @{$target->{args}} == $target->{op}->{count} ){
  204         578  
410 200 50       520 $verbose>0 and warn "end of operator $target->{op}{key1} . reduce in $where\n";
411 200         290 shift @{$self->{stack}};
  200         300  
412 200         243 $self->{allow_child} = 0;
413 200         823 return 1;
414             }
415             # ?:
416 5 50 33     53 if( $target->{op}{assoc} =~ /t/ and $a and $a eq $target->{op}->{key2} ){
      33        
417 5 50       15 $verbose>0 and warn "eating ':' operator . reduce in $where\n";
418 5         41 shift @{$self->{token}};
  5         14  
419 5         10 $self->{allow_child} = 1;
420 5         52 return 1;
421             }
422             }
423 1         6 return;
424             }
425            
426             sub parse{
427 286     286   325 my($list)=@_;
428            
429 286         757 my $self = bless{
430             allow_child => 1,
431             stack=>[new Text::Template::Compact::ExprNode('')],
432             token=>$list,
433             };
434            
435 286         376 my($op,$node);
436            
437 286         324 Loop: for(;;){
438 1152         1699 my $target = $self->{stack}[0];
439 1152         2779 my $token = $self->peekToken;
440 1152 50 0     2771 $verbose>0 and warn "mode=$self->{allow_child} token:",($token||'')," stack:",join(',',map{$_->{op}{key1}} @{$self->{stack}}),"\n";
  1         37  
  1         7  
441            
442            
443             # reduce if possible
444 1152 100 66     4309 if( not defined($token)
445             or not findOp( $token,qr/[armtk]/ )
446             ){
447 970 100       1818 next if $self->reduce('loop');
448             }
449            
450 954 100       2368 last if not defined($token);
451            
452 719 100       1458 if( $self->{allow_child} ){
453 507         1826 my $op = findOp($token,qr/[bl]/);
454 507 100       1214 if($op){
455             # listop(b) ??
456 63 100 66     72 if( @{$self->{token}} >= 2
  63   100     534  
457             and $op->{key1} =~/^\w/
458             and $self->{token}[1] eq '('
459             ){
460 6 50       23 $verbose>0 and warn "start of term $token(?) \n";
461 6         8 shift @{$self->{token}};
  6         45  
462 6         16 shift @{$self->{token}};
  6         12  
463 6         61 $node = new Text::Template::Compact::ExprNode(findOp('(',qr/a/));
464 6         24 $target->addArg($node);
465 6         10 unshift @{$self->{stack}},$node;
  6         47  
466 6         15 $self->{allow_child} = 1;
467 6         13 $node->{realop} = $op;
468 6         47 next;
469             }
470            
471             # unary left or '('
472 58 50       134 $verbose>0 and warn "operator $token start\n";
473 58         64 shift @{$self->{token}};
  58         123  
474 58         159 $node = new Text::Template::Compact::ExprNode($op);
475 58         128 $target->addArg($node);
476 58         109 unshift @{$self->{stack}},$node;
  58         132  
477 58         82 $self->{allow_child} = 1;
478 58         123 next;
479             }
480            
481             # keyword or constant or $,$$
482 445 50       1530 if( $token =~/^["\w\d_\$]/ ){
483 445 50       821 $verbose>0 and warn "constant or keyword $token\n";
484 445         463 $target->addArg(shift @{$self->{token}});
  445         4226  
485 445         718 $self->{allow_child} = 0;
486            
487             # $keyword
488 445         1303 my $old_arg = $target->{args}[-1];
489 445         751 $token = $self->peekToken;
490 445 100 100     2115 if( defined($token) and $token =~/^["\w\d_]/ and $old_arg =~/^\$/ ){
      100        
491 14 50       68 $verbose>0 and warn "merge '$old_arg' and '$token'\n";
492 14         57 $node = new Text::Template::Compact::ExprNode(findOp('.',qr/[armtk]/));
493 14         46 $target->{args}[-1] = $node;
494 14         58 $node->addArg($old_arg,$token);
495 14         22 shift @{$self->{token}};
  14         28  
496             }
497 445         908 next;
498             }
499             }else{
500            
501 213         853 $op = findOp($token,qr/[armtk]/);
502 213 100       536 if($op){
503 163         392 $node = new Text::Template::Compact::ExprNode($op);
504 163         211 my $a;
505 163         172 while(@{$self->{stack}}){
  193         483  
506 193         315 my($left,$right) =($target->{op},$op);
507 193         328 my($left_prio,$right_prio) =($left->{prio},$right->{prio});
508 193         339 my($left_assoc,$right_assoc) =($left->{assoc},$right->{assoc});
509            
510 193 100 66     635 if( $left_assoc =~ /[ba]/ and not $target->{closed} ){
511             # if inside of non closed braket, always right combination
512 22         33 $a=1;
513             }else{
514             # List Operators (Leftward) has very high priority
515 172 50       745 if( $right_prio == $list_op_prio ){
516 1         5 $right_prio = 0;
517             }
518             # compare operator precedence
519 172         189 $a = $left_prio - $right_prio;
520 172 100       331 if(!$a){
521             # if same, check left or right associativity
522 25 50       77 if( $left_assoc =~/L/ ){ $a=-1;}
  25 0       42  
523 1         27 elsif( $left_assoc =~/R/ ){ $a= 1;}
524             else{
525 1         5 die "repeating non-assoc operator. $left->{key1} $right->{key1}\n";
526             }
527             }
528             }
529 193 50       336 $verbose>0 and warn "lr=$a $left->{key1} $right->{key1}\n";
530            
531 193 100       352 if($a>0){ #right a+(b*c)
532 163 50       263 $verbose>0 and warn "appending right combination\n";
533 163         147 shift @{$self->{token}};
  163         279  
534 163         194 my $b = pop @{$target->{args}};
  163         292  
535 163         561 $target->addArg($node);
536 163         198 unshift @{$self->{stack}},$node;
  163         310  
537 163         302 $node->addArg($b);
538 163         270 $target=$self->{stack}[0];
539 163 100       167 if( @{$target->{args}} < $target->{op}{count} ){
  163         474  
540 156         210 $self->{allow_child} =1;
541             }
542 163         408 next Loop;
543             }
544            
545 31 50       151 if( not $self->reduce("left combination $target->{op}->{key1} $op->{key1}") ){
546             # warn "reduce failed: ",Data::Dumper::Dumper($target),"\n";
547 1         4 die "cannot resolve operator precedence between '$target->{op}->{key1}' and '$op->{key1}'\n";
548             }
549 31         73 $target=$self->{stack}[0];
550             }
551             }
552             }
553 51         103 last;
554             }
555 286 50       500 $verbose>0 and warn "end. stack=",join(',',map{$_->{op}->{key1}} @{$self->{stack}}),"\n";
  1         1  
  1         18  
556 285         462 my $token = $self->peekToken;
557 285 0       277 @{$self->{stack}}==1 or die "expression is not completed at '",(defined($token)?"'$token'":"end of statement"),"'\n";
  285 50       635  
558 285 50       286 @{$self->{stack}[0]{args}} or die "expression not found\n";
  285         768  
559 285         985 return $self->{stack}[0];
560             }
561             }
562            
563             {
564             package Text::Template::Compact::Dataset;
565            
566             *getDataType = \&Text::Template::Compact::getDataType;
567             *decodeQuote = \&Text::Template::Compact::decodeQuote;
568            
569             sub new{
570 1282     1283   1584 my($class,$tmpl,$tag)=@_;
571 1282         6523 return bless {
572             tmpl=>$tmpl,
573             tag=>$tag,
574             enc => $tmpl->{paramEncoding},
575             },$class;
576             }
577            
578             sub print{
579 10     11   20 my($self)=shift;
580 10         22 my $printer = $self->{tmpl}{printer};
581 10   33     58 my $filter = ( $self->{tag}{filter} || $self->{tmpl}{filter_default} );
582 10         24 for(@_){ $printer->( $filter->( Text::Template::Compact::dor($_,$self->{tmpl}{undef_supply}))); }
  19         48  
583             }
584            
585             # make path from token
586             sub token2path{
587 1770     1771   2312 my($self,$token)=@_;
588 1770 100 100     8097 if( $token =~ /^"/
589             or $token =~ /^\d/
590             ){
591 439         885 return ['i',decodeQuote($token)];
592             }
593 1331         4532 return ['k',$token];
594             }
595            
596             sub makepathlist{
597 92     93   135 my($self) = shift;
598 92         253 return [ 'l',@_];
599             }
600            
601             sub endoflist{
602 1945     1946   2092 my($self,$path)=@_;
603 1945 100       3902 ( $path->[0] eq 'l' ) and return $self->endoflist($path->[-1]);
604 1942         2911 return $path;
605             }
606            
607             sub getVlist{
608 582     583   758 my($self,$result,$path)=@_;
609 582 100       1095 if( $path->[0] eq 'l' ){
610 88         230 for(my $i=1;$i<@$path;++$i){
611 176         418 $self->getVlist($result,$path->[$i]);
612             }
613             }else{
614 494         925 my $val = $self->getV($path);
615 494         5968 push @$result,$val;
616             }
617             }
618            
619             # make data path from immediate value
620             sub encode{
621 518     519   2592 my($self,$value)=@_;
622 518         1424 return ['i',$value];
623             }
624            
625             # make relative data path
626             sub child{
627 55     56   84 my($self,$path,$rel)=@_;
628 55         122 my $r = ['p',[]];
629            
630             # get right item if arg is list
631 55         146 $path = $self->endoflist($path);
632 55         107 $rel = $self->endoflist($rel);
633            
634             # copy parent
635 55 100       114 if($path->[0] eq 'p'){
636 6         9 push @{$r->[1]} , @{$path->[1]};
  6         10  
  6         15  
637             }else{
638 49         55 push @{$r->[1]} , $path->[1];
  49         118  
639             }
640            
641             # copy child
642 55 100       101 if($rel->[0] eq 'p'){
643 2         5 push @{$r->[1]} , @{$rel->[1]};
  2         4  
  2         6  
644             }else{
645 53         55 push @{$r->[1]} , $rel->[1];
  53         171  
646             }
647            
648             # make
649 55         104 return $r;
650             }
651            
652             # get value in data path
653             sub getV{
654 1830     1831   5012 my($self,$path)=@_;
655 1830 50       3575 ref($path) or die "incorrect path\n";
656            
657             # get right item if arg is list
658 1830         6997 $path = $self->endoflist($path);
659            
660             # immidiate value
661 1830 100       5072 return $path->[1] if $path->[0] eq 'i';
662            
663 987         943 my @path;
664 987 100       1544 if( $path->[0] eq 'p' ){
665 42         53 push @path,@{$path->[1]};
  42         99  
666             }else{
667 945         1685 push @path,$path->[1];
668             }
669            
670 987         1801 my $param = $self->{tmpl}{param};
671 987         1099 my $path_str = '$';
672 987 100       2283 if( $path[0] eq '$' ){
    100          
673 10         20 shift @path;
674             }elsif( $path[0] eq '$$' ){
675 2         3 shift @path;
676 2         5 $param = $self->{tmpl};
677             }
678            
679 987         1916 while(@path){
680 1025         1594 my $key = shift @path;
681 1025         1895 my $type = getDataType($param);
682 1025 100       2485 if( $type eq 'ARRAY' ){
    50          
683 4     4   56 no warnings;
  4         19  
  4         357  
684 27         56 $param = $param->[$key];
685             }elsif($type eq 'HASH' ){
686 4     4   38 no warnings;
  4         10  
  4         33124  
687 998         1786 $param = $param->{$key};
688             }else{
689 0         0 die "incorrect data path $path_str\n";
690             }
691 1025 50       1942 $path_str .= (length($path_str)?'.':'').$key;
692 1025 50 66     3844 (@path and not ref $param) and die "incorrect data path $path_str\n";
693             }
694 987 100 100     7300 if( defined $param
      100        
      66        
695             and not ref($param)
696             and not utf8::is_utf8($param)
697             and defined $self->{enc}
698             ){
699 701         1888 return Encode::decode($self->{enc},$param);
700             }
701 286         982 return $param;
702             }
703             # set value to data path
704             sub setV{
705 405     406   563 my($self,$path,$newval)=@_;
706            
707             # get right item if arg is list
708 405 50       844 ($path->[0] eq 'l') and $path = $self->endoflist($path);
709            
710 405 50       892 if( $path->[0] eq 'i' ){
711 0         0 die "L-Value required\n";
712             }
713            
714 405         399 my @path;
715 405 100       653 if( $path->[0] eq 'p' ){
716 5         9 push @path,@{$path->[1]};
  5         13  
717             }else{
718 400         689 push @path,$path->[1];
719             }
720            
721 405         615 my $param = $self->{tmpl}{param};
722 405         441 my $path_str = '$';
723 405 100       899 if( $path[0] eq '$' ){
    50          
724 5         8 shift @path;
725             }elsif( $path[0] eq '$$' ){
726 0         0 shift @path;
727 0         0 $param = $self->{tmpl};
728             }
729            
730 405         909 while(@path){
731 405         755 my $key = shift @path;
732 405         686 my $type = getDataType($param);
733 405 50       1003 if( $type eq 'ARRAY' ){
    50          
734 0 0       0 if(not @path){
735 0         0 my $old = $param->[$key];
736 0         0 $param->[$key] = $newval;
737 0         0 return \$old;
738             }else{
739 0         0 $param = $param->[$key];
740             }
741             }elsif($type eq 'HASH' ){
742 405 50       654 if(not @path){
743 405         654 my $old = $param->{$key};
744 405         577 $param->{$key} = $newval;
745 405         1064 return \$old;
746             }else{
747 0         0 $param = $param->{$key};
748             }
749             }else{
750 0         0 die "incorrect data path $path_str\n";
751             }
752 0         0 $path_str .= '.'.$key;
753 0 0 0     0 (@path and not ref $param) and die "incorrect data path $path_str\n";
754             }
755             }
756             }
757            
758             # record parse error and die (should be catch in parser)
759             sub parseError{
760 0     1 0 0 my($self)=shift;
761 0         0 my $msg = join('',"$self->{source_name} $self->{lno}: ",@_);
762 0         0 $msg =~ s/[\x0d\x0a]+//g;
763 0         0 push @{$self->{error}},$msg;
  0         0  
764 0         0 croak $msg,"\n";
765             }
766            
767             sub parseExpr{
768 285     286 0 360 my($self,$list)=@_;
769 285         311 my $r = eval{ Text::Template::Compact::ExprParser::parse($list);};
  285         493  
770 285 50       587 $@ and $self->parseError($@);
771 285         697 return $r;
772             }
773            
774             sub evalExpr{
775 535     536 0 706 my($tmpl,$tag,$expr)=@_;
776 535         1112 my $dataset = new Text::Template::Compact::Dataset($tmpl,$tag);
777 535         720 my $r = eval{ $dataset->getV( $expr->eval($dataset) );};
  535         957  
778 535 50       3705 if($@){
779 0         0 $r = "[Error: $@ in evalExpr]";
780 0         0 $r =~s/[\x0d\x0a]+//g;
781             }
782 535         1688 return $r;
783             }
784             sub evalExprList{
785 389     390 0 540 my($tmpl,$tag,$expr)=@_;
786 389         886 my $dataset = new Text::Template::Compact::Dataset($tmpl,$tag);
787 389         486 my @list;
788 389         427 eval{ $dataset->getVlist( \@list,$expr->eval($dataset) ); };
  389         879  
789 389 50       961 if($@){
790 0         0 my $r = "[Error: $@ in evalExprList]";
791 0         0 $r =~s/[\x0d\x0a]+//g;
792 0         0 return $r;
793             }
794 389         1440 return @list;
795             }
796             sub evalExprKw{
797 2     3 0 6 my($tmpl,$tag,$expr)=@_;
798 2         7 my $dataset = new Text::Template::Compact::Dataset($tmpl,$tag);
799 2         4 my $path = eval{ $expr->eval($dataset); };
  2         6  
800 2 50       6 if($@){
801 0         0 my $r = "[Error: $@ in evalExprKw]";
802 0         0 $r =~s/[\x0d\x0a]+//g;
803 0         0 return $r;
804             }
805 2         6 $path = $dataset->endoflist($path);
806 2 50       21 return $path->[1] if $path->[0] =~/[ki]/;
807            
808 0         0 my $v = eval{ $dataset->getV( $path );};
  0         0  
809 0 0       0 if($@){
810 0         0 my $r = "[Error: $@ in evalExprKw]";
811 0         0 $r =~s/[\x0d\x0a]+//g;
812 0         0 return $r;
813             }
814 0         0 return $v;
815             }
816            
817            
818            
819             sub setExprValue{
820 356     357 0 541 my($tmpl,$tag,$expr,$newval)=@_;
821 356         810 my $dataset = new Text::Template::Compact::Dataset($tmpl,$tag);
822 356         789 my $path = $expr->eval($dataset);
823 356         406 my $r = eval{ $dataset->setV($path,$newval);};
  356         679  
824 356 50       657 if($@){
825 0         0 $r = "[Error: $@ in setExprValue]";
826 0         0 $r =~s/[\x0d\x0a]+//g;
827             }
828 356         1087 return $r;
829             }
830            
831             # eat specified token at head of the list. otherwise return undef.
832             sub eatType{
833 20     21 0 53 my($list,$type)=@_;
834 20 50 33     162 if( @$list and ref($list->[0]) and $list->[0]->{$type} ){
      33        
835 20         56 return shift @$list;
836             }
837 0         0 return;
838             }
839            
840             ######################################
841            
842            
843             # print %eval tag
844             sub print_eval{
845 6     7 0 14 my($tmpl,$tag)=@_;
846 6         27 $tmpl->evalExpr($tag,$tag->{expr});
847 6         11 return;
848             }
849            
850             # print %var tag
851             sub print_var{
852 389     390 0 482 my($tmpl,$tag)=@_;
853 389         509 my $printer = $tmpl->{printer};
854 389         1229 my $filter = dor( $tag->{filter} ,$tmpl->{filter_default} );
855 389         1186 for my $value ( $tmpl->evalExprList($tag,$tag->{expr}) ){
856 449         969 $value = dor($value,$tmpl->{undef_supply});
857 449         867 $printer->( $filter->($value));
858             }
859 389         4901 return;
860             }
861            
862             sub evalLabel($$$){
863 8     9 0 17 my($tmpl,$tag,$label)=@_;
864 8 100       39 return '' if not defined $label;
865 2         171 return $tmpl->evalExprKw($tag,$label);
866             }
867            
868             # print %for tag
869             sub print_for{
870 20     21 0 34 my($tmpl,$tag)=@_;
871 20         76 my $list = $tmpl->evalExpr($tag,$tag->{listname});
872 20         32 my $index = 0;
873 20 100       62 $tag->{indexstart} and $index = $tmpl->evalExpr($tag,$tag->{indexstart});
874 20         36 for my $v (@$list){
875 139         204 my $oldr;
876             my $oldi;
877 139 50       317 if($tag->{itemname}){
878 139         311 $oldr = $tmpl->setExprValue($tag,$tag->{itemname},$v);
879 139 50       314 ref($oldr) or $tmpl->{printer}->($oldr);
880             }
881 139 100       300 if($tag->{indexname}){
882 4         14 $oldi = $tmpl->setExprValue($tag,$tag->{indexname},$index++);
883 4 50       13 ref($oldi) or $tmpl->{printer}->($oldi);
884             }
885 139         331 my $exit_tag = $tmpl->printBlock( $tag->{block} );
886 139 50       535 ref($oldr) and $tmpl->setExprValue($tag,$tag->{itemname} ,$$oldr);
887 139 100       290 ref($oldi) and $tmpl->setExprValue($tag,$tag->{indexname} ,$$oldi);
888            
889 139 100       330 if($exit_tag){
890             # not for this block?
891 7 100       32 return $exit_tag if dor($tag->{label},'') ne evalLabel($tmpl,$tag,$exit_tag->{label});
892             # for this block.
893 6 50       27 next if $exit_tag->{continue};
894 6 50       27 last if $exit_tag->{break};
895             }
896             }
897 19         38 return;
898             }
899            
900             sub print_while{
901 3     4 0 7 my($tmpl,$tag)=@_;
902 3 50       20 $tag->{ex_init} and $tmpl->evalExpr($tag,$tag->{ex_init});
903 3         5 my $exit_tag;
904 3         6 for(;;){
905 30 100 100     103 last if $tag->{ex_precheck} and not $tmpl->evalExpr($tag,$tag->{ex_precheck});
906 29         79 $exit_tag = $tmpl->printBlock( $tag->{block} );
907 29 100       62 if($exit_tag){
908             # not for this block?
909 1 50       8 last if dor($tag->{label},'') ne evalLabel($tmpl,$tag,$exit_tag->{label});
910             # for this block.
911 1 50       7 if($exit_tag->{break}){
912 1         3 undef $exit_tag;
913 1         3 last;
914             }
915             }
916 28 100 100     100 last if $tag->{ex_postcheck} and not $tmpl->evalExpr($tag,$tag->{ex_postcheck});
917 27 50       134 $tag->{ex_step} and $tmpl->evalExpr($tag,$tag->{ex_step});
918             }
919 3 100       48 $tag->{ex_final} and $tmpl->evalExpr($tag,$tag->{ex_final});
920 3         6 return $exit_tag;
921             }
922            
923             # print %blockpaste tag
924             sub print_block{
925 6     7 0 11 my($tmpl,$tag)=@_;
926 6         17 my $block = $tmpl->{block}{$tag->{name}};
927 6 50       15 if(not defined($block) ){
928 0         0 $tmpl->{printer}->( "[Error: block '$tag->{name}' is not defined]" );
929 0         0 return;
930             }
931 6         16 my $exit_tag = $tmpl->printBlock( $block );
932 6 50       16 return if not $exit_tag;
933             # not for this block?
934 0 0       0 return $exit_tag if dor($tag->{label},'') ne evalLabel($tmpl,$tag,$exit_tag->{label});
935             # for this block.
936             # no difference between break or continue, just exit this block.
937 0         0 return;
938             }
939            
940             # print %eval tag
941             sub print_evalperl{
942 74     75 0 105 my($tmpl,$tag)=@_;
943 74         126 local $_ = $tmpl->{param};
944 74         107 my $code = $tag->{code};
945 74         75 my @data = map{ $tmpl->evalExpr($tag,$_) } @{$tag->{args}};
  34         76  
  74         137  
946 74         95 my $a_code =ord('a');
947 74 100       164 @data and $code = "my(".join(',',map{my $c=chr($_+$a_code);"\$$c"}(0..$#data)).")=\@data;$code";
  34         73  
  34         106  
948 74     3   4841 my $r = eval "{no warnings; $code;}";
  2     3   18  
  2     3   3  
  2     3   96  
  2     2   15  
  2     2   3  
  2     2   67  
  2     2   10  
  2     2   4  
  2     2   61  
  2     2   10  
  2     2   4  
  2     2   52  
  2     2   13  
  2     2   4  
  2     2   64  
  2     2   12  
  2     2   3  
  2     2   79  
  2     2   11  
  2     2   4  
  2     2   77  
  2     2   10  
  2     2   4  
  2     2   63  
  2     2   10  
  2         4  
  2         63  
  2         9  
  2         4  
  2         63  
  2         11  
  2         3  
  2         64  
  2         11  
  2         4  
  2         65  
  2         10  
  2         3  
  2         62  
  2         12  
  2         5  
  2         78  
  2         13  
  2         4  
  2         63  
  2         12  
  2         3  
  2         53  
  2         13  
  2         2  
  2         81  
  2         19  
  2         4  
  2         72  
  2         17  
  2         4  
  2         90  
  2         13  
  2         3  
  2         66  
  2         12  
  2         3  
  2         58  
  2         27  
  2         4  
  2         63  
  2         13  
  2         4  
  2         66  
  2         13  
  2         4  
  2         71  
  2         12  
  2         4  
  2         77  
  2         14  
  2         4  
  2         60  
949 74 100       202 $@ and $tmpl->{printer}->( "[eval failed: $@]");
950 74 100       359 $tag->{result} and $tmpl->setExprValue($tag,$tag->{result},$r);
951 74         147 return;
952             }
953            
954            
955             # print %else tag
956             sub print_else{
957 175     176 0 252 my($tmpl,$tag)=@_;
958            
959 175         392 my $exit_tag = $tmpl->printBlock( $tag->{block} );
960            
961             # normally 'if' is not match for break,continue
962             # match only label is explicitly specified in both of block and break.
963 175 50 100     404 if( $exit_tag
      66        
      33        
964             and defined($exit_tag->{label})
965             and defined($tag->{label})
966             and $exit_tag->{label} eq $tag->{label}
967             ){
968             # exit_tag is solved in this scope.
969 0         0 return;
970             }
971 175         369 return $exit_tag;
972             }
973            
974             # print %if tag
975             sub print_if_simple{
976 275     276 0 345 my($tmpl,$tag)=@_;
977 275         563 my $value = $tmpl->evalExpr($tag,$tag->{expr});
978 275 100       572 $value and return print_else($tmpl,$tag);
979 166         229 $tag=$tag->{next};
980 166 100       354 $tag->{printer} and return $tag->{printer}($tmpl,$tag);
981 142         202 return;
982             }
983            
984             # print %if tag
985             sub print_if_code{
986 126     127 0 169 my($tmpl,$tag)=@_;
987 126         125 my @data = map{ $tmpl->evalExpr($tag,$_) } @{$tag->{args}};
  138         290  
  126         244  
988 126         231 my $code = $tag->{code};
989 126         159 my $a_code =ord('a');
990 126 50       334 @data and $code = "my(".join(',',map{my $c=chr($_+$a_code);"\$$c"}(0..$#data)).")=\@data;$code";
  138         224  
  138         425  
991 126         228 local $_ = $tmpl->{param};
992 126     2   8113 my $value = eval "no warnings; $code";
  2     2   15  
  2     2   4  
  2     2   108  
  2     2   10  
  2     2   4  
  2     2   71  
  2     2   10  
  2     2   5  
  2     2   60  
  2     2   12  
  2     2   6  
  2     2   67  
  2     2   12  
  2     2   3  
  2         62  
  2         12  
  2         4  
  2         65  
  2         12  
  2         4  
  2         75  
  2         14  
  2         4  
  2         76  
  2         12  
  2         6  
  2         73  
  2         16  
  2         3  
  2         81  
  2         13  
  2         5  
  2         77  
  2         12  
  2         4  
  2         74  
  2         13  
  2         7  
  2         70  
  2         11  
  2         5  
  2         67  
  2         14  
  2         196  
  2         66  
993 126 50       307 $@ and $tmpl->{printer}->( "[eval failed: $@]");
994            
995 126 100       281 $value and return print_else($tmpl,$tag);
996 72         136 $tag=$tag->{next};
997 72 100       201 $tag->{printer} and return $tag->{printer}($tmpl,$tag);
998 48         107 return;
999             }
1000            
1001             #####################################################
1002            
1003             # parse template tag
1004             sub parseTemplateTag{
1005 300     301 0 508 my($self,$text)=@_;
1006            
1007             # split to token list
1008 300     3   3478 my @list = $text =~ /$Text::Template::Compact::ExprParser::token_re|"(?:[^"]|"")*"|[\w_]+|\p{IsWord}+/g;
  2         21  
  2         4  
  2         35  
1009 300 50       65357 @list or die $self->parseError("empty template tag");
1010            
1011             # parse filter
1012 300         300 my $filter;
1013 300 100 100     1814 if( @list >= 2 and $filter_map{ $list[-1] } and $list[-2] eq '#' ){
      66        
1014 8         15 $filter = $filter_map{ $list[@list-1] };
1015 8         18 splice @list,@list-2;
1016             }
1017            
1018 300         367 my @taglist;
1019             my $type;
1020 300         543 while(@list){
1021 352 100       708 if($list[0] eq ';'){
1022 29         36 shift @list;
1023 29         66 next;
1024             }
1025            
1026 323         810 my $item = {lno=>$self->{lno}};
1027 323 100       669 $filter and $item->{filter} = $filter;
1028            
1029             # read label:
1030 323 100 100     1318 if( @list >= 2
      66        
1031             and $list[1] eq ':'
1032             and $list[0] =~/^\w/
1033             ){
1034 1         3 $item->{label} = $list[0];
1035 1         3 splice @list,0,2;
1036 1 50       3 last if not @list;
1037             }
1038            
1039             # % type
1040 323 100       559 if( $list[0] eq '%' ){
1041             # skip '%'
1042 180         227 shift @list;
1043             # read type of tag
1044 180 50       371 @list or $self->parseError("no tag type after '%'");
1045 180         347 $type = lc decodeQuote(shift @list);
1046             }else{
1047 143         243 $type = 'print';
1048             }
1049            
1050 323         848 $item->{$item->{type}=$type}=1;
1051            
1052 323 100 100     2048 if( $type eq 'print' ){
    100 100        
    100 66        
    100 100        
    100          
    100          
    100          
    50          
    100          
    100          
    100          
    50          
1053             # %print expr,expr...
1054 150         312 $item->{printer}=\&print_var;
1055 150         392 $item->{expr} = $self->parseExpr(\@list);
1056            
1057             }elsif( $type eq 'eval' ){
1058             # %print expr,expr...
1059 6         20 $item->{printer}=\&print_eval;
1060 6         22 $item->{expr} = $self->parseExpr(\@list);
1061            
1062             }elsif( $type eq 'if' or $type eq 'elsif' ){
1063             # %if expr
1064             # %elsif expr
1065 25         50 $item->{printer}=\&print_if_simple;
1066 25         59 $item->{expr} = $self->parseExpr(\@list);
1067            
1068             }elsif( $type eq 'ifc' or $type eq 'elsifc' ){
1069             # %ifc "code" dataspec dataspec ...
1070             # %elsifc "code" dataspec dataspec ...
1071 14         28 $item->{printer}=\&print_if_code;
1072 14         94 $item->{code} =decodeQuote(shift @list);
1073 14         30 $item->{args}=[];
1074 14   66     63 while(@list and $list[0] ne ';' ){
1075 15         19 push @{$item->{args}},$self->parseExpr(\@list);
  15         41  
1076             }
1077            
1078             }elsif( $type eq 'else'){
1079             # %else
1080 4         15 $item->{printer}=\&print_else;
1081            
1082             }elsif( $type eq 'end'){
1083             # %end
1084            
1085             }elsif( $type eq 'break' or $type eq 'continue' ){
1086             # %break [label]
1087             # %continue [label]
1088 3 100 66     17 if( @list and $list[0] ne ';'){
1089 1         4 $item->{label} = $self->parseExpr(\@list);
1090             }
1091            
1092             }elsif( $type eq 'end'){
1093             # %end
1094            
1095             }elsif( $type eq 'for' ){
1096             # %for item in list indexname indexstart
1097 15         42 $item->{printer}=\&print_for;
1098 15         46 $item->{itemname} = $self->parseExpr(\@list);
1099            
1100 15 50 33     71 (not @list or not $list[0] eq 'in' ) and $self->parseError("expected 'in' keyword is not found.");
1101 15         22 shift @list;
1102            
1103 15         38 $item->{listname} = $self->parseExpr(\@list);
1104            
1105 15 100 100     77 (@list and $list[0] ne ';') and $item->{indexname} = $self->parseExpr(\@list);
1106 15 100 100     81 (@list and $list[0] ne ';') and $item->{indexstart} = $self->parseExpr(\@list);
1107            
1108             }elsif( $type eq 'while' ){
1109             # %for item in list indexname indexstart
1110 3         13 $item->{printer}=\&print_while;
1111 3   66     22 Loop: while( @list and $list[0] ne ';' ){
1112 10         23 for (qw( init precheck postcheck step final )){
1113 28 100       57 if( $list[0] eq $_ ){
1114 10         13 shift @list;
1115 10         31 $item->{"ex_$_"} = $self->parseExpr(\@list);
1116 10         127 next Loop;
1117             }
1118             }
1119 0         0 $self->parseError("expected 'init/precheck/postcheck/step/final' not found.");
1120             }
1121            
1122             }elsif( $type eq 'blockdefine' or $type eq 'blockpaste' ){
1123             # %blockdefine blockname
1124             # %blockpaste blockname
1125 8         18 $item->{printer}=\&print_block;
1126 8 50       18 @list or $self->parseError("no block name after $type");
1127 8         18 $item->{name} = decodeQuote(shift @list);
1128 8 100       22 if( $type eq 'blockdefine' ){
1129 2 50       11 defined( $self->{block}{$item->{name}} ) and $self->parseError("redefined block '$item->{name}'");
1130 2         8 $self->{block}{$item->{name}} = [];
1131             }
1132             }elsif( $type eq 'evalperl' ){
1133             # %evalperl "code" [result] [arg]...
1134 44         88 $item->{printer}=\&print_evalperl;
1135 44 50       82 @list or $self->parseError("no text after 'evalperl'");
1136 44 50       137 $list[0] =~ /^"/ or $self->parseError("you must quote code with \"...\"");
1137 44         78 $item->{code} = decodeQuote(shift @list);
1138 44 100       157 @list and $item->{result} = $self->parseExpr(\@list);
1139 44         77 $item->{args} = [];
1140 44   66     138 while(@list and $list[0] ne ';' ){
1141 4         7 push @{$item->{args}},$self->parseExpr(\@list);
  4         13  
1142             }
1143             }else{
1144             # unsupported tag type
1145 0         0 $self->parseError("unsupported tag type '$type'");
1146             }
1147 323 50 66     806 @list and $list[0] ne ';' and $self->parseError("unexpected token '$list[0]' in template tag");
1148 323         759 push @taglist,$item;
1149             }
1150 300         903 return @taglist;
1151             }
1152            
1153             # compose tree of tag and text.
1154             sub parseBlock{
1155 125     126 0 176 my($self,$rList,$block)=@_;
1156            
1157 125         271 while(@$rList){
1158 569         706 my $item = $rList->[0];
1159             # normal text
1160 569 100       941 if( not ref($item) ){
1161 246         365 push @$block, shift @$rList;
1162 246         529 next;
1163             }
1164             # exit before end of block
1165 323 100       407 last if grep {$item->{type} eq $_} qw( end else elsif elsifc );
  1292         2368  
1166            
1167             # %blockdefine
1168 260 100       464 if( $item->{blockdefine} ){
1169 2         5 shift @$rList;
1170 2         11 $self->parseBlock( $rList,$self->{block}{$item->{name}});
1171 2 50       6 eatType($rList,'end') or $self->parseError("missing end of blockdefine (start at $item->{lno})");
1172 2         11 next;
1173             }
1174            
1175             # append to current block
1176 258         361 push @$block, shift @$rList;
1177            
1178             # %for
1179 258 100 100     963 if( $item->{for} or $item->{while} ){
1180 18         46 $item->{block} = [];
1181 18         67 $self->parseBlock( $rList ,$item->{block});
1182 18 50       47 eatType($rList,'end') or $self->parseError("missing end of $item->{type} loop (start at $item->{lno})");
1183 18         64 next;
1184             }
1185            
1186             # %if ,%elsif,%else
1187 240 100 100     1000 if( $item->{if} or $item->{ifc}){
1188 31         37 for(;;$item = $item->{next}){
1189 43         66 $item->{block} = [];
1190 43         99 $self->parseBlock( $rList ,$item->{block});
1191 43 50       77 @$rList or $self->parseError("missing end of if/elsif/else/elsifc block (start at $item->{lno})");
1192 43         76 $item->{next} = shift @$rList;
1193 43 100       98 last if $item->{next}{end};
1194 12 50 33     36 $item->{label} and not defined($item->{next}->{label}) and $item->{next}->{label}=$item->{label};
1195             }
1196 31         60 next;
1197             }
1198             }
1199             }
1200            
1201             sub closeLine{
1202 399     400 0 468 my($rAll,$rLine)=@_;
1203             my $a = grep{
1204 399 100       547 if( ref($_) ){
  693         1067  
1205 323         621 $_->{print};
1206             }else{
1207 370 100       1187 $_ =~ /[^\s ]/ ?1:0;
1208             }
1209             } @$rLine;
1210 399 100       3791 if($a){
1211 275         408 for (@$rLine,"\x0a"){
1212 875 100 100     3988 if(not ref($_)
      100        
1213             and @$rAll
1214             and not ref($rAll->[-1])
1215             ){
1216 386         904 $rAll->[-1].= $_;
1217             }else{
1218 489         808 push @$rAll,$_;
1219             }
1220             }
1221             }else{
1222 124         219 for (@$rLine){
1223 93 100       295 ref($_) and push @$rAll,$_;
1224             }
1225             }
1226 399         864 @$rLine = ();
1227             }
1228            
1229             # convert from source text to template structure.
1230             # $ok = $tmpl->loadText($filename,\$text [,$blockname]);
1231             sub loadText{
1232 62     63 0 45934 my $self = shift;
1233 62         163 $self->{error}=[];
1234 62         153 $self->{lno}=1;
1235 62         132 $self->{source_name} = $_[0];
1236 62 50       182 my $rText = ref($_[1])?$_[1]:\$_[1];
1237 62   50     10929 my $blockname = ($_[2] || "");
1238            
1239             # split source to tag and text
1240 62         77 my @list;
1241             my @line;
1242 62         87 my $lastend = 0;
1243 62         525 while( $$rText =~ /(\x0D\x0A|\x0D|\x0A)|(?
1244 699         18049 my $pre = substr($$rText,$lastend,$-[0] - $lastend); $lastend = $+[0];
  699         17275  
1245 699 100       1593 if( defined($1) ){
1246 399         578 $pre =~ s/\$\${/\$\{/g;
1247 399 100       928 length($pre) and push @line,$pre;
1248 399         794 closeLine(\@list,\@line);
1249 399         2729 ++$self->{lno};
1250             }else{
1251 300         607 my $inside = substr($2,2);
1252 300         497 $pre =~ s/\$\${/\$\{/g;
1253 300 100       712 length($pre) and push @line,$pre;
1254 300         350 push @line,eval{ $self->parseTemplateTag($inside);};
  300         648  
1255 300         2030 $self->{lno} += $inside =~ tr/\x0a/\x0a/;
1256             }
1257             }
1258 62 50       150 if( $lastend < length($$rText) ){
1259 0         0 my $text =substr($$rText,$lastend);
1260 0         0 $text =~ s/\$\$\{/\$\{/g;
1261 0         0 warn "left=[$text]\n";
1262 0         0 push @line,$text;
1263 0         0 closeLine(\@list,\@line);
1264             }
1265            
1266             # parse control block
1267 62         155 $self->{block}{$blockname} = [];
1268 62         777 eval{ $self->parseBlock( \@list,$self->{block}{$blockname} ); };
  62         240  
1269            
1270 62         84 return !@{$self->{error}};
  62         291  
1271             }
1272            
1273            
1274             # $ok = $tml->loadFile("filename","utf8" [,$blockname]);
1275             sub loadFile{
1276 1     2 0 29 my $self = shift;
1277            
1278 1         8 $self->{lno} = 0;
1279 1         4 $self->{source_name} = $_[0];
1280 1         3 my $enc = $_[1];
1281 1         3 my $blockname = $_[2];
1282            
1283             # find encoding object for source
1284 1 50       4 if(defined $enc){
1285 1 50       6 ref($enc) or $enc = Encode::find_encoding($enc);
1286 1 50       15 if(not ref($enc) =~/Encode/){
1287 0         0 push @{$self->{error}},"$self->{source_name} $self->{lno}: incorrect encode spec.";
  0         0  
1288 0         0 return;
1289             }
1290             }
1291            
1292             # read source text
1293 1         2 my $source;
1294             my $fh;
1295 1 50       50 if(not open $fh,"<",$self->{source_name} ){
1296 0         0 push @{$self->{error}},"$self->{source_name} $self->{lno}: $!";
  0         0  
1297 0         0 return;
1298             }else{
1299 1         4 local $/=undef;
1300 1         51 $source = <$fh>;
1301 1 50       8 defined($enc) and $source = Encode::decode($enc,$source);
1302 1 50       348 if(not close $fh ){
1303 0         0 push @{$self->{error}},"$self->{source_name} $self->{lno}: $!";
  0         0  
1304 0         0 return;
1305             }
1306             }
1307 1         7 return $self->loadText($self->{source_name},\$source,$blockname);
1308             }
1309            
1310             # $teml = Text::Template::Compact->new();
1311             sub new{
1312 2     3 0 24212 return bless{
1313             error => [],
1314             paramEncoding => Encode::find_encoding('utf8'),
1315             filter_default => $filter_map{'html'},
1316             undef_supply => '',
1317             } , shift;
1318             }
1319            
1320             # get error as string.
1321             sub error{
1322 0     1 0 0 return join("\n",@{$_[0]->{error}},'');
  0         0  
1323             }
1324             # get error as string.
1325             sub undef_supply{
1326 1     2 0 5 my $self = shift;
1327 1 50       5 if(@_){
1328 1         3 $self->{undef_supply} = $_[0];
1329             }
1330 1         3 return $self->{undef_supply};
1331             }
1332            
1333             # set encoding for decode parameter
1334             sub param_encoding{
1335 2     3 0 10563 my $self = shift;
1336 2 50       11 if(@_){
1337 2         6 my $enc = $_[0];
1338             # find encoding object for source
1339 2 50       11 if(defined $enc){
1340 2 50       12 ref($enc) or $enc = Encode::find_encoding($enc);
1341 2 50       38 ref($enc) =~/Encode/ or croak "incorrect encode spec.";
1342             }
1343 2         17 $self->{paramEncoding} = $enc;
1344             }
1345 2         5 return;
1346             }
1347            
1348             # set default of filter for variable expand.
1349             sub filter_default{
1350 2     3 0 11 my $self = shift;
1351 2 50       9 if(@_){
1352 2         4 my $filtername = $_[0];
1353 2 50 33     22 if( not $filtername or not $filter_map{$filtername} ){
1354 0         0 croak "unknown filter '$filtername'";
1355             }
1356 2         8 $self->{filter_default} = $filter_map{$filtername};
1357             }
1358 2         4 return;
1359             }
1360            
1361             # print template block(low-level method)
1362             sub printBlock{
1363 411     412 0 542 my($self,$block)=@_;
1364 411         644 for my $item ( @$block ){
1365 1753 100 66     14099 if( not ref $item ){
    100          
1366 883         2009 $self->{printer}->($item);
1367             }elsif( $item->{break} or $item->{continue} ){
1368 7         23 return $item;
1369             }else{
1370 863         1809 my $exit_tag = $item->{printer}($self,$item);
1371 863 100       2005 $exit_tag and return $exit_tag;
1372             }
1373             }
1374 396         3879 return;
1375             }
1376            
1377             # print to filehandle
1378             sub print{
1379 1     2 0 793 my($self,$param,$fh,$enc)=@_;
1380            
1381             # generate closure to print
1382 1 50       5 if(defined $enc){
1383             # find encoding object for source
1384 1 50       7 ref($enc) or $enc = Encode::find_encoding($enc);
1385 1 50       18 ref($enc) =~/Encode/ or croak "incorrect encode spec.";
1386 1     804   9 $self->{printer} = sub{ for(@_){ print $fh Encode::encode($enc,$_); } };
  803         1214  
  803         1880  
1387             }else{
1388 0     1   0 $self->{printer} = sub{ print $fh @_; };
  0         0  
1389             }
1390 1         3 $self->{param} = $param;
1391            
1392             # start root node
1393 1         6 my $exit_tag = $self->printBlock( $self->{block}{""});
1394             }
1395            
1396             sub toString{
1397 61     62 0 27977 my($self,$param)=@_;
1398 61         97 my $result='';
1399 61         112 $self->{param} = $param;
1400 61     551   286 $self->{printer} = sub{ for(@_){ $result .= $_; } };
  550         853  
  550         1947  
1401 61         363 $self->printBlock( $self->{block}{""} );
1402 61         177 return $result;
1403             }
1404            
1405             1;
1406            
1407             __END__