dbscripts/lib/subst.pl

   1 #!/usr/bin/perl
   2
   3 ################################################################
   4 ###     Preprocessor
   5 ###
   6 ### m
   7 ###
   8 ### $VER: 3.1.1 (% notation)$
   9
  10 require "codec.pl";
  11
  12 ###########################################################
  13 ### token stuff
  14
  15 package TokenStream;
  16
  17 sub new {
  18         local(*IN,$intro,$outro)=@_;
  19
  20         $$stream{'handle'}=*IN;
  21         $$stream{'buffer'}=[];
  22         $$stream{'intro'}=$intro;
  23         $$stream{'outro'}=$outro;
  24
  25         bless $stream, "TokenStream";
  26
  27         return $stream;
  28         }
  29
  30 sub fetch {
  31         my($stream)=shift;
  32         my($token,$old);
  33         local(*IN);
  34
  35         if (defined ($token=shift(@{$$stream{'buffer'}}))) {
  36                 return $token;
  37                 }
  38         else {
  39                 $old=$/;
  40                 $/=$$stream{'outro'};
  41                 *IN=$$stream{'handle'};
  42
  43                 $token=<IN>;
  44
  45                 if (($index=index($token,$$stream{'intro'}))>0) {
  46                         push(@{$$stream{'buffer'}},substr($token,$index));
  47                         $token=substr($token,0,$index);
  48                         }
  49
  50                 $/=$old;
  51
  52                 return $token;
  53                 }
  54         }
  55
  56 sub feed {
  57         my($stream,$value)=@_;
  58
  59         if (ref $value) {
  60                 unshift(@{$$stream{'buffer'}},@$value);
  61                 }
  62         else {
  63                 unshift(@{$$stream{'buffer'}},$value);
  64                 }
  65         }
  66
  67 ###########################################################
  68 ### prepro stuff
  69
  70 package Subst;
  71
  72 ###########################################################
  73 ### local fun :-)
  74
  75 $localfun{'store'}=sub {
  76         my($args,$env,$stream)=@_;
  77         my($token,$field,$count);
  78
  79         # print  "STORE $$args[1]\n";
  80
  81         $field=$$args[1];
  82         $count=0;
  83
  84         $$env{$field}{'_data'}=[];
  85         while (($token=$stream->fetch) && ($token ne "<%/store%>")) {
  86                 push(@{$$env{$field}{'_data'}},$token);
  87                 $count++;
  88                 }
  89         $$env{$field}{'_pos'}=0;
  90         $$env{$field}{'_size'}=$count;
  91         };
  92
  93 $localfun{'reset'}=sub {
  94         my($args)=shift;
  95
  96         $$env{$$args[1]}{'_pos'}=0;
  97         };
  98
  99 $localfun{'insert'}=sub {
 100         my($args,$env,$stream)=@_;
 101
 102         #print main::DEBUG "INSERT $$args[1] size=",scalar(@{$$env{$$args[1]}{'_data'}})," time=$$env{$$args[1]}{'_pos'}\n";
 103
 104         $stream->feed($$env{$$args[1]}{'_data'});
 105         $$env{$$args[1]}{'_pos'}++;
 106         };
 107
 108 $localfun{'loop'}=sub {
 109         my($args,$env,$stream)=@_;
 110         my($token,@loop,$count);
 111
 112
 113         $count=$$args[1];
 114         #print "LOOP $count\n";
 115         while (($token=$stream->fetch) && ($token ne "<%/loop%>")) {
 116                 push(@loop,$token);
 117                 }
 118         while ($count--) {
 119                 $stream->feed(\@loop);
 120                 }
 121         };
 122
 123 sub clone {
 124         my(@data)=@_;
 125         return \@data;
 126         }
 127
 128 $localfun{'load'}=sub {
 129         my($args,$env,$stream)=@_;
 130         my(@temp,$count);
 131
 132         # print "<!-- LOAD: $$args[2] into $$args[1] -->";
 133
 134         $$env{$$args[1]}{'_data'}=[];
 135         $count=0;
 136         if (open(LOAD,$$args[2])) {
 137                 while (<LOAD>) {
 138                         chomp;
 139                         #print "ROW: $_\n";
 140                         @temp=split(/\t/);
 141                         push(@{$$env{$$args[1]}{'_data'}},&clone(@temp));
 142                         undef @temp;
 143                         $count++;
 144                         }
 145                 close(LOAD);
 146                 }
 147         $$env{$$args[1]}{'_size'}=$count;
 148         $$env{$$args[1]}{'_pos'}=0;
 149
 150         # print "LOAD $$args[2] into $$args[1] ($count)\n";
 151         };
 152
 153 $localfun{'loadvalues'}=sub {
 154         my($args,$env,$stream)=@_;
 155         local(*LOAD);
 156         my($cat)="public";
 157         my($slot,$key,$value,@collect);
 158
 159         if (open(LOAD,$$args[1])) {
 160                 while (<LOAD>) {
 161                         s/[\r\n]+//g;
 162                         next if /^\s*$/;
 163                         next if /^#/;
 164
 165                         if (/^\[(\w+)\]/) {
 166                                 $cat=$1;
 167                                 next;
 168                                 }
 169                         if (/^\[(\w+)\]\s*=\>\s*\[(\w+)\]$/) {
 170                                 $$env{$2}=$$env{$1};
 171                                 next;
 172                                 }
 173                         if (/([^=\s]+)\s*=\s*(.*?)\s*$/) {
 174                                 $$env{$cat}{$1}=$2;
 175                                 next;
 176                                 }
 177                         if (/([^=\s]+)\s*:\s*(.*)/) {
 178                                 $key=$1; $value=$2;
 179                                 $value=~s/\$\((\w+)\)/$ENV{$value}/e;
 180                                 $$env{$cat}{$key}=$value;
 181                                 next;
 182                                 }
 183                         if (/([^\<\s]+)\s*\<\<\s*(.*)/) {
 184                                 $slot=$1;
 185                                 undef @collect;
 186                                 while (<LOAD>) {
 187                                         last if substr($_,0,2) eq "<<";
 188                                         push(@collect,$_);
 189                                         }
 190                                 $$env{$cat}{$slot}=join("\n",@collect);
 191                                 }
 192                         }
 193                 close(LOAD);
 194                 }
 195         else {
 196                 print "Cannot loadvalues ".$$args[1]."\n";
 197                 }
 198         };
 199
 200 $localfun{'bind'}=sub {
 201         my($args,$env,$stream)=@_;
 202         my($temp,$name,$var,$t,$item);
 203
 204         shift(@$args);  # function name
 205         $name=shift(@$args);
 206         $var=shift(@$args);
 207
 208         #print "BIND from $name [$$env{$name}{'_pos'}] to $var : ";
 209
 210         if ($$env{$name}{'_pos'}<$$env{$name}{'_size'}) {
 211                 $t=0;
 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++];
 216                         }
 217                 $$env{$name}{'_pos'}++;
 218                 }
 219         else {
 220                 undef $$env{$var};
 221                 }
 222         };
 223
 224 ### version 3.1 functions
 225
 226 $localfun{'incr'}=sub {
 227         my($args)=shift;
 228
 229         #print main::DEBUG "INCR $$args[1]\n";
 230
 231         $$env{$$args[1]}{'_pos'}++;
 232         };
 233
 234 $localfun{'alias'}=sub {
 235         my($args,$env,$stream)=@_;
 236         my($temp,$name,$var,$t,$item);
 237
 238         shift(@$args);  # function name
 239         $name=shift(@$args);
 240         $var=shift(@$args);
 241
 242         #print main::DEBUG "ALIAS from $name [$$env{$name}{'_pos'}] to $var\n";
 243
 244         if ($$env{$name}{'_pos'}<$$env{$name}{'_size'}) {
 245                 $$env{$var}=$$env{$name}{'_data'}[$$env{$name}{'_pos'}];
 246                 }
 247         else {
 248                 undef $$env{$var};
 249                 }
 250         };
 251
 252 $localfun{'keyvalue'}=sub {
 253         my($args,$env,$stream)=@_;
 254         my($from,$to,@buffer,$key,$value);
 255
 256         shift(@$args);  # function name
 257         $from=shift(@$args);
 258         $to=shift(@$args);
 259
 260
 261         while (($key,$value)=each %{$$env{$from}}) {
 262                 push(@buffer,{'key' => $key, 'value' => $value});
 263                 }
 264         $$env{$to}{'_data'}=\@buffer;
 265         $$env{$to}{'_pos'}=0;
 266         $$env{$to}{'_size'}=scalar(@buffer);
 267
 268         #print main::DEBUG "keyvalue $from into $to ",scalar(@buffer),"\n";
 269         };
 270
 271 $localfun{'set'}=sub {
 272         my($args,$env,$stream)=@_;
 273         my($name,$value);
 274
 275         shift(@$args);  # function name
 276         $name=shift(@$args);
 277         $value=shift(@$args);
 278
 279         $$env{'_flags'}{$name}=$value;
 280         };
 281
 282 ###########################################################
 283 ### if fun ??
 284
 285 $iffun{'ifdef'}=sub {
 286         my($args,$env)=@_;
 287         return ((defined (&getvalue($env,$$args[1]))) ? 0 : 1);
 288         };
 289
 290 $iffun{'ifnz'}=sub {
 291         my($args,$env)=@_;
 292         return (&getvalue($env,$$args[1]) ? 0 : 1);
 293         };
 294
 295 $iffun{'ifequal'}=sub {
 296         my($args,$env)=@_;
 297         return ((&getvalue($env,$$args[1]) eq $$args[2]) ? 0 : 1);
 298         };
 299
 300 $iffun{'ifmember'}=sub {
 301         my($args,$env)=@_;
 302         return ((index($$args[1],$$args[2])<0) ? 1 : 0);
 303         };
 304
 305 $iffun{'ifdecr'}=sub {
 306         my($args,$env)=@_;
 307
 308         if ($$args[1]=~/(\S+)\.(\S+)/) {
 309                 return (($$env{$1}{$2}-- > 0) ? 0 : 1);
 310                 }
 311         else {
 312                 return (($$env{$$args[1]}-- > 0) ? 0 : 1);
 313                 }
 314         };
 315
 316 $iffun{'ifiter'}=sub {
 317         my($args,$env)=@_;
 318
 319         if ($$args[2]=~/(\d+)\.(\d+)/) {
 320                 return (($$env{$$args[1]}{'_pos'} % $1) != $2);
 321                 }
 322         else {
 323                 return (($$env{$$args[1]}{'_pos'} % $$argv[2]) != 0);
 324                 }
 325         };
 326
 327
 328 ### version 3.1 functions
 329
 330 $iffun{'ifplus'}=sub {
 331         my($args,$env)=@_;
 332         return ((&getvalue($env,$$args[1])>0) ? 0 : 1);
 333         };
 334
 335 $iffun{'ifminus'}=sub {
 336         my($args,$env)=@_;
 337         return ((&getvalue($env,$$args[1])<0) ? 0 : 1);
 338         };
 339
 340 $iffun{'ifpluszero'}=sub {
 341         my($args,$env)=@_;
 342         return ((&getvalue($env,$$args[1])>=0) ? 0 : 1);
 343         };
 344
 345 $iffun{'ifminuszero'}=sub {
 346         my($args,$env)=@_;
 347         return ((&getvalue($env,$$args[1])<=0) ? 0 : 1);
 348         };
 349
 350
 351 ###########################################################
 352 ### process
 353
 354 sub process {
 355         local(*IN,*OUT,$env,$post)=@_;
 356         my($token,$ignore,@temp,$templine,$stream);
 357
 358         $logfile=$$env{'logfile'};
 359
 360         $stream=&TokenStream::new(*IN,"<%","%>");
 361
 362         return undef unless defined $stream;
 363
 364         #if (!defined $post) { $post=sub { print OUT $_[0] unless $_[0]=~/^\s*$/; }; }
 365         if (!defined $post) { $post=sub { print OUT $_[0]; }; }
 366
 367         $ignore=0;
 368
 369         while ($token=$stream->fetch) {
 370                 # if-endif
 371                 if      ($token eq "<%endif%>") {
 372                         $ignore-- if $ignore>0;
 373                         next;
 374                         }
 375
 376                 if (($ignore>0) && (substr($token,0,4) eq "<%if")) {
 377                         $ignore++;
 378                         next;
 379                         }
 380
 381                 if ($token eq "<%else%>") {
 382                         ($ignore == 0) && ($ignore=1, next);
 383                         ($ignore == 1) && ($ignore=0, next);
 384                         }
 385
 386                 next if $ignore;
 387
 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;
 391
 392                 # handle none-special case
 393                 if (substr($token,0,2) ne "<%") {
 394                         &$post($token);
 395                         next;
 396                         }
 397
 398                 @temp=split(/\s+/,substr($token,2,-2));
 399
 400                 if (defined $iffun{$temp[0]}) {
 401                         $ignore=&{$iffun{$temp[0]}}(\@temp,$env);
 402                         next;
 403                         }
 404
 405                 if (defined $localfun{$temp[0]}) {
 406                         &{$localfun{$temp[0]}}(\@temp,$env,$stream);
 407                         next;
 408                         }
 409
 410                 &$post($token);
 411                 }
 412         }
 413
 414 ###########################################################
 415 ### binding
 416
 417 $perlish=&Codec::new('perlish');
 418
 419 $convert{'[perl]'}=sub { return $perlish->encode(@_); };
 420
 421 $convert{'[scalar]'}=sub { return scalar($_[0]); };
 422
 423 $convert{'[javastyle]'}=sub {
 424         my($value)=shift;
 425         $value=lc($value);
 426         substr($value,0,1)=uc(substr($value,0,1));
 427         return $value;
 428         };
 429
 430 sub getvalue {
 431         my($env,$key,$fun)=@_;
 432         my($convert,$value);
 433
 434 #       $key=~s/\./\'\}\{\'/g;
 435 #       $value=eval "\$\$env{'$key'}";
 436
 437         $key=~s/\./\'\}\{\'/g;
 438         $key="{'".$key."'}";
 439         $key=~s/(\[\d+\])\'\}/\'\}$1/g;
 440         $value=eval "\$\$env$key";
 441
 442         if ((defined $fun) && (defined $convert{$fun})) { return &{$convert{$fun}}($value); }
 443         else              { return $value; }
 444         }
 445
 446 1;