X-Git-Url: http://erislabs.net/gitweb/?a=blobdiff_plain;f=dbscripts%2Flib%2Fsubst.pl;fp=dbscripts%2Flib%2Fsubst.pl;h=0000000000000000000000000000000000000000;hb=855ecf8acedb12afbab7a621b2e2c0cf45b2f98f;hp=c45d74ce1f86cce996ae526ec6736450045fa6d9;hpb=978ee2002d8552321b27ef0a234807f1a46998d5;p=mir.git diff --git a/dbscripts/lib/subst.pl b/dbscripts/lib/subst.pl deleted file mode 100755 index c45d74ce..00000000 --- a/dbscripts/lib/subst.pl +++ /dev/null @@ -1,446 +0,0 @@ -#!/usr/bin/perl - -################################################################ -### Preprocessor -### -### m -### -### $VER: 3.1.1 (% notation)$ - -require "codec.pl"; - -########################################################### -### token stuff - -package TokenStream; - -sub new { - local(*IN,$intro,$outro)=@_; - - $$stream{'handle'}=*IN; - $$stream{'buffer'}=[]; - $$stream{'intro'}=$intro; - $$stream{'outro'}=$outro; - - bless $stream, "TokenStream"; - - return $stream; - } - -sub fetch { - my($stream)=shift; - my($token,$old); - local(*IN); - - if (defined ($token=shift(@{$$stream{'buffer'}}))) { - return $token; - } - else { - $old=$/; - $/=$$stream{'outro'}; - *IN=$$stream{'handle'}; - - $token=; - - if (($index=index($token,$$stream{'intro'}))>0) { - push(@{$$stream{'buffer'}},substr($token,$index)); - $token=substr($token,0,$index); - } - - $/=$old; - - return $token; - } - } - -sub feed { - my($stream,$value)=@_; - - if (ref $value) { - unshift(@{$$stream{'buffer'}},@$value); - } - else { - unshift(@{$$stream{'buffer'}},$value); - } - } - -########################################################### -### prepro stuff - -package Subst; - -########################################################### -### local fun :-) - -$localfun{'store'}=sub { - my($args,$env,$stream)=@_; - my($token,$field,$count); - - # print "STORE $$args[1]\n"; - - $field=$$args[1]; - $count=0; - - $$env{$field}{'_data'}=[]; - while (($token=$stream->fetch) && ($token ne "<%/store%>")) { - push(@{$$env{$field}{'_data'}},$token); - $count++; - } - $$env{$field}{'_pos'}=0; - $$env{$field}{'_size'}=$count; - }; - -$localfun{'reset'}=sub { - my($args)=shift; - - $$env{$$args[1]}{'_pos'}=0; - }; - -$localfun{'insert'}=sub { - my($args,$env,$stream)=@_; - - #print main::DEBUG "INSERT $$args[1] size=",scalar(@{$$env{$$args[1]}{'_data'}})," time=$$env{$$args[1]}{'_pos'}\n"; - - $stream->feed($$env{$$args[1]}{'_data'}); - $$env{$$args[1]}{'_pos'}++; - }; - -$localfun{'loop'}=sub { - my($args,$env,$stream)=@_; - my($token,@loop,$count); - - - $count=$$args[1]; - #print "LOOP $count\n"; - while (($token=$stream->fetch) && ($token ne "<%/loop%>")) { - push(@loop,$token); - } - while ($count--) { - $stream->feed(\@loop); - } - }; - -sub clone { - my(@data)=@_; - return \@data; - } - -$localfun{'load'}=sub { - my($args,$env,$stream)=@_; - my(@temp,$count); - - # print ""; - - $$env{$$args[1]}{'_data'}=[]; - $count=0; - if (open(LOAD,$$args[2])) { - while () { - chomp; - #print "ROW: $_\n"; - @temp=split(/\t/); - push(@{$$env{$$args[1]}{'_data'}},&clone(@temp)); - undef @temp; - $count++; - } - close(LOAD); - } - $$env{$$args[1]}{'_size'}=$count; - $$env{$$args[1]}{'_pos'}=0; - - # print "LOAD $$args[2] into $$args[1] ($count)\n"; - }; - -$localfun{'loadvalues'}=sub { - my($args,$env,$stream)=@_; - local(*LOAD); - my($cat)="public"; - my($slot,$key,$value,@collect); - - if (open(LOAD,$$args[1])) { - while () { - s/[\r\n]+//g; - next if /^\s*$/; - next if /^#/; - - if (/^\[(\w+)\]/) { - $cat=$1; - next; - } - if (/^\[(\w+)\]\s*=\>\s*\[(\w+)\]$/) { - $$env{$2}=$$env{$1}; - next; - } - if (/([^=\s]+)\s*=\s*(.*?)\s*$/) { - $$env{$cat}{$1}=$2; - next; - } - if (/([^=\s]+)\s*:\s*(.*)/) { - $key=$1; $value=$2; - $value=~s/\$\((\w+)\)/$ENV{$value}/e; - $$env{$cat}{$key}=$value; - next; - } - if (/([^\<\s]+)\s*\<\<\s*(.*)/) { - $slot=$1; - undef @collect; - while () { - last if substr($_,0,2) eq "<<"; - push(@collect,$_); - } - $$env{$cat}{$slot}=join("\n",@collect); - } - } - close(LOAD); - } - else { - print "Cannot loadvalues ".$$args[1]."\n"; - } - }; - -$localfun{'bind'}=sub { - my($args,$env,$stream)=@_; - my($temp,$name,$var,$t,$item); - - shift(@$args); # function name - $name=shift(@$args); - $var=shift(@$args); - - #print "BIND from $name [$$env{$name}{'_pos'}] to $var : "; - - if ($$env{$name}{'_pos'}<$$env{$name}{'_size'}) { - $t=0; - $temp=$$env{$name}{'_data'}[$$env{$name}{'_pos'}]; - foreach $item (@$args) { - #print "\t$item=$$temp[$t]\n"; - $$env{$var}{$item}=$$temp[$t++]; - } - $$env{$name}{'_pos'}++; - } - else { - undef $$env{$var}; - } - }; - -### version 3.1 functions - -$localfun{'incr'}=sub { - my($args)=shift; - - #print main::DEBUG "INCR $$args[1]\n"; - - $$env{$$args[1]}{'_pos'}++; - }; - -$localfun{'alias'}=sub { - my($args,$env,$stream)=@_; - my($temp,$name,$var,$t,$item); - - shift(@$args); # function name - $name=shift(@$args); - $var=shift(@$args); - - #print main::DEBUG "ALIAS from $name [$$env{$name}{'_pos'}] to $var\n"; - - if ($$env{$name}{'_pos'}<$$env{$name}{'_size'}) { - $$env{$var}=$$env{$name}{'_data'}[$$env{$name}{'_pos'}]; - } - else { - undef $$env{$var}; - } - }; - -$localfun{'keyvalue'}=sub { - my($args,$env,$stream)=@_; - my($from,$to,@buffer,$key,$value); - - shift(@$args); # function name - $from=shift(@$args); - $to=shift(@$args); - - - while (($key,$value)=each %{$$env{$from}}) { - push(@buffer,{'key' => $key, 'value' => $value}); - } - $$env{$to}{'_data'}=\@buffer; - $$env{$to}{'_pos'}=0; - $$env{$to}{'_size'}=scalar(@buffer); - - #print main::DEBUG "keyvalue $from into $to ",scalar(@buffer),"\n"; - }; - -$localfun{'set'}=sub { - my($args,$env,$stream)=@_; - my($name,$value); - - shift(@$args); # function name - $name=shift(@$args); - $value=shift(@$args); - - $$env{'_flags'}{$name}=$value; - }; - -########################################################### -### if fun ?? - -$iffun{'ifdef'}=sub { - my($args,$env)=@_; - return ((defined (&getvalue($env,$$args[1]))) ? 0 : 1); - }; - -$iffun{'ifnz'}=sub { - my($args,$env)=@_; - return (&getvalue($env,$$args[1]) ? 0 : 1); - }; - -$iffun{'ifequal'}=sub { - my($args,$env)=@_; - return ((&getvalue($env,$$args[1]) eq $$args[2]) ? 0 : 1); - }; - -$iffun{'ifmember'}=sub { - my($args,$env)=@_; - return ((index($$args[1],$$args[2])<0) ? 1 : 0); - }; - -$iffun{'ifdecr'}=sub { - my($args,$env)=@_; - - if ($$args[1]=~/(\S+)\.(\S+)/) { - return (($$env{$1}{$2}-- > 0) ? 0 : 1); - } - else { - return (($$env{$$args[1]}-- > 0) ? 0 : 1); - } - }; - -$iffun{'ifiter'}=sub { - my($args,$env)=@_; - - if ($$args[2]=~/(\d+)\.(\d+)/) { - return (($$env{$$args[1]}{'_pos'} % $1) != $2); - } - else { - return (($$env{$$args[1]}{'_pos'} % $$argv[2]) != 0); - } - }; - - -### version 3.1 functions - -$iffun{'ifplus'}=sub { - my($args,$env)=@_; - return ((&getvalue($env,$$args[1])>0) ? 0 : 1); - }; - -$iffun{'ifminus'}=sub { - my($args,$env)=@_; - return ((&getvalue($env,$$args[1])<0) ? 0 : 1); - }; - -$iffun{'ifpluszero'}=sub { - my($args,$env)=@_; - return ((&getvalue($env,$$args[1])>=0) ? 0 : 1); - }; - -$iffun{'ifminuszero'}=sub { - my($args,$env)=@_; - return ((&getvalue($env,$$args[1])<=0) ? 0 : 1); - }; - - -########################################################### -### process - -sub process { - local(*IN,*OUT,$env,$post)=@_; - my($token,$ignore,@temp,$templine,$stream); - - $logfile=$$env{'logfile'}; - - $stream=&TokenStream::new(*IN,"<%","%>"); - - return undef unless defined $stream; - - #if (!defined $post) { $post=sub { print OUT $_[0] unless $_[0]=~/^\s*$/; }; } - if (!defined $post) { $post=sub { print OUT $_[0]; }; } - - $ignore=0; - - while ($token=$stream->fetch) { - # if-endif - if ($token eq "<%endif%>") { - $ignore-- if $ignore>0; - next; - } - - if (($ignore>0) && (substr($token,0,4) eq "<%if")) { - $ignore++; - next; - } - - if ($token eq "<%else%>") { - ($ignore == 0) && ($ignore=1, next); - ($ignore == 1) && ($ignore=0, next); - } - - next if $ignore; - - #$token=~s/\^(\'?[\w.]+)(\\)?/&getvalue($env,$1)/eg; - #$token=~s/\^(\[\w+\])?([\w.]+)(\\)?/&getvalue($env,$2,$1)/eg; - $token=~s/\^(\[\w+\])?([\w\x5b\x5d.]+)(\\)?/&getvalue($env,$2,$1)/eg; - - # handle none-special case - if (substr($token,0,2) ne "<%") { - &$post($token); - next; - } - - @temp=split(/\s+/,substr($token,2,-2)); - - if (defined $iffun{$temp[0]}) { - $ignore=&{$iffun{$temp[0]}}(\@temp,$env); - next; - } - - if (defined $localfun{$temp[0]}) { - &{$localfun{$temp[0]}}(\@temp,$env,$stream); - next; - } - - &$post($token); - } - } - -########################################################### -### binding - -$perlish=&Codec::new('perlish'); - -$convert{'[perl]'}=sub { return $perlish->encode(@_); }; - -$convert{'[scalar]'}=sub { return scalar($_[0]); }; - -$convert{'[javastyle]'}=sub { - my($value)=shift; - $value=lc($value); - substr($value,0,1)=uc(substr($value,0,1)); - return $value; - }; - -sub getvalue { - my($env,$key,$fun)=@_; - my($convert,$value); - -# $key=~s/\./\'\}\{\'/g; -# $value=eval "\$\$env{'$key'}"; - - $key=~s/\./\'\}\{\'/g; - $key="{'".$key."'}"; - $key=~s/(\[\d+\])\'\}/\'\}$1/g; - $value=eval "\$\$env$key"; - - if ((defined $fun) && (defined $convert{$fun})) { return &{$convert{$fun}}($value); } - else { return $value; } - } - -1;