3 ################################################################
8 ### $VER: 3.1.1 (% notation)$
12 ###########################################################
18 local(*IN,$intro,$outro)=@_;
20 $$stream{'handle'}=*IN;
21 $$stream{'buffer'}=[];
22 $$stream{'intro'}=$intro;
23 $$stream{'outro'}=$outro;
25 bless $stream, "TokenStream";
35 if (defined ($token=shift(@{$$stream{'buffer'}}))) {
41 *IN=$$stream{'handle'};
45 if (($index=index($token,$$stream{'intro'}))>0) {
46 push(@{$$stream{'buffer'}},substr($token,$index));
47 $token=substr($token,0,$index);
57 my($stream,$value)=@_;
60 unshift(@{$$stream{'buffer'}},@$value);
63 unshift(@{$$stream{'buffer'}},$value);
67 ###########################################################
72 ###########################################################
75 $localfun{'store'}=sub {
76 my($args,$env,$stream)=@_;
77 my($token,$field,$count);
79 # print "STORE $$args[1]\n";
84 $$env{$field}{'_data'}=[];
85 while (($token=$stream->fetch) && ($token ne "<%/store%>")) {
86 push(@{$$env{$field}{'_data'}},$token);
89 $$env{$field}{'_pos'}=0;
90 $$env{$field}{'_size'}=$count;
93 $localfun{'reset'}=sub {
96 $$env{$$args[1]}{'_pos'}=0;
99 $localfun{'insert'}=sub {
100 my($args,$env,$stream)=@_;
102 #print main::DEBUG "INSERT $$args[1] size=",scalar(@{$$env{$$args[1]}{'_data'}})," time=$$env{$$args[1]}{'_pos'}\n";
104 $stream->feed($$env{$$args[1]}{'_data'});
105 $$env{$$args[1]}{'_pos'}++;
108 $localfun{'loop'}=sub {
109 my($args,$env,$stream)=@_;
110 my($token,@loop,$count);
114 #print "LOOP $count\n";
115 while (($token=$stream->fetch) && ($token ne "<%/loop%>")) {
119 $stream->feed(\@loop);
128 $localfun{'load'}=sub {
129 my($args,$env,$stream)=@_;
132 # print "<!-- LOAD: $$args[2] into $$args[1] -->";
134 $$env{$$args[1]}{'_data'}=[];
136 if (open(LOAD,$$args[2])) {
141 push(@{$$env{$$args[1]}{'_data'}},&clone(@temp));
147 $$env{$$args[1]}{'_size'}=$count;
148 $$env{$$args[1]}{'_pos'}=0;
150 # print "LOAD $$args[2] into $$args[1] ($count)\n";
153 $localfun{'loadvalues'}=sub {
154 my($args,$env,$stream)=@_;
157 my($slot,$key,$value,@collect);
159 if (open(LOAD,$$args[1])) {
169 if (/^\[(\w+)\]\s*=\>\s*\[(\w+)\]$/) {
173 if (/([^=\s]+)\s*=\s*(.*?)\s*$/) {
177 if (/([^=\s]+)\s*:\s*(.*)/) {
179 $value=~s/\$\((\w+)\)/$ENV{$value}/e;
180 $$env{$cat}{$key}=$value;
183 if (/([^\<\s]+)\s*\<\<\s*(.*)/) {
187 last if substr($_,0,2) eq "<<";
190 $$env{$cat}{$slot}=join("\n",@collect);
196 print "Cannot loadvalues ".$$args[1]."\n";
200 $localfun{'bind'}=sub {
201 my($args,$env,$stream)=@_;
202 my($temp,$name,$var,$t,$item);
204 shift(@$args); # function name
208 #print "BIND from $name [$$env{$name}{'_pos'}] to $var : ";
210 if ($$env{$name}{'_pos'}<$$env{$name}{'_size'}) {
212 $temp=$$env{$name}{'_data'}[$$env{$name}{'_pos'}];
213 foreach $item (@$args) {
214 #print "\t$item=$$temp[$t]\n";
215 $$env{$var}{$item}=$$temp[$t++];
217 $$env{$name}{'_pos'}++;
224 ### version 3.1 functions
226 $localfun{'incr'}=sub {
229 #print main::DEBUG "INCR $$args[1]\n";
231 $$env{$$args[1]}{'_pos'}++;
234 $localfun{'alias'}=sub {
235 my($args,$env,$stream)=@_;
236 my($temp,$name,$var,$t,$item);
238 shift(@$args); # function name
242 #print main::DEBUG "ALIAS from $name [$$env{$name}{'_pos'}] to $var\n";
244 if ($$env{$name}{'_pos'}<$$env{$name}{'_size'}) {
245 $$env{$var}=$$env{$name}{'_data'}[$$env{$name}{'_pos'}];
252 $localfun{'keyvalue'}=sub {
253 my($args,$env,$stream)=@_;
254 my($from,$to,@buffer,$key,$value);
256 shift(@$args); # function name
261 while (($key,$value)=each %{$$env{$from}}) {
262 push(@buffer,{'key' => $key, 'value' => $value});
264 $$env{$to}{'_data'}=\@buffer;
265 $$env{$to}{'_pos'}=0;
266 $$env{$to}{'_size'}=scalar(@buffer);
268 #print main::DEBUG "keyvalue $from into $to ",scalar(@buffer),"\n";
271 $localfun{'set'}=sub {
272 my($args,$env,$stream)=@_;
275 shift(@$args); # function name
277 $value=shift(@$args);
279 $$env{'_flags'}{$name}=$value;
282 ###########################################################
285 $iffun{'ifdef'}=sub {
287 return ((defined (&getvalue($env,$$args[1]))) ? 0 : 1);
292 return (&getvalue($env,$$args[1]) ? 0 : 1);
295 $iffun{'ifequal'}=sub {
297 return ((&getvalue($env,$$args[1]) eq $$args[2]) ? 0 : 1);
300 $iffun{'ifmember'}=sub {
302 return ((index($$args[1],$$args[2])<0) ? 1 : 0);
305 $iffun{'ifdecr'}=sub {
308 if ($$args[1]=~/(\S+)\.(\S+)/) {
309 return (($$env{$1}{$2}-- > 0) ? 0 : 1);
312 return (($$env{$$args[1]}-- > 0) ? 0 : 1);
316 $iffun{'ifiter'}=sub {
319 if ($$args[2]=~/(\d+)\.(\d+)/) {
320 return (($$env{$$args[1]}{'_pos'} % $1) != $2);
323 return (($$env{$$args[1]}{'_pos'} % $$argv[2]) != 0);
328 ### version 3.1 functions
330 $iffun{'ifplus'}=sub {
332 return ((&getvalue($env,$$args[1])>0) ? 0 : 1);
335 $iffun{'ifminus'}=sub {
337 return ((&getvalue($env,$$args[1])<0) ? 0 : 1);
340 $iffun{'ifpluszero'}=sub {
342 return ((&getvalue($env,$$args[1])>=0) ? 0 : 1);
345 $iffun{'ifminuszero'}=sub {
347 return ((&getvalue($env,$$args[1])<=0) ? 0 : 1);
351 ###########################################################
355 local(*IN,*OUT,$env,$post)=@_;
356 my($token,$ignore,@temp,$templine,$stream);
358 $logfile=$$env{'logfile'};
360 $stream=&TokenStream::new(*IN,"<%","%>");
362 return undef unless defined $stream;
364 #if (!defined $post) { $post=sub { print OUT $_[0] unless $_[0]=~/^\s*$/; }; }
365 if (!defined $post) { $post=sub { print OUT $_[0]; }; }
369 while ($token=$stream->fetch) {
371 if ($token eq "<%endif%>") {
372 $ignore-- if $ignore>0;
376 if (($ignore>0) && (substr($token,0,4) eq "<%if")) {
381 if ($token eq "<%else%>") {
382 ($ignore == 0) && ($ignore=1, next);
383 ($ignore == 1) && ($ignore=0, next);
388 #$token=~s/\^(\'?[\w.]+)(\\)?/&getvalue($env,$1)/eg;
389 #$token=~s/\^(\[\w+\])?([\w.]+)(\\)?/&getvalue($env,$2,$1)/eg;
390 $token=~s/\^(\[\w+\])?([\w\x5b\x5d.]+)(\\)?/&getvalue($env,$2,$1)/eg;
392 # handle none-special case
393 if (substr($token,0,2) ne "<%") {
398 @temp=split(/\s+/,substr($token,2,-2));
400 if (defined $iffun{$temp[0]}) {
401 $ignore=&{$iffun{$temp[0]}}(\@temp,$env);
405 if (defined $localfun{$temp[0]}) {
406 &{$localfun{$temp[0]}}(\@temp,$env,$stream);
414 ###########################################################
417 $perlish=&Codec::new('perlish');
419 $convert{'[perl]'}=sub { return $perlish->encode(@_); };
421 $convert{'[scalar]'}=sub { return scalar($_[0]); };
423 $convert{'[javastyle]'}=sub {
426 substr($value,0,1)=uc(substr($value,0,1));
431 my($env,$key,$fun)=@_;
434 # $key=~s/\./\'\}\{\'/g;
435 # $value=eval "\$\$env{'$key'}";
437 $key=~s/\./\'\}\{\'/g;
439 $key=~s/(\[\d+\])\'\}/\'\}$1/g;
440 $value=eval "\$\$env$key";
442 if ((defined $fun) && (defined $convert{$fun})) { return &{$convert{$fun}}($value); }
443 else { return $value; }