ref: 38c0cf0737de03906729054ad7b7b011dd1ca475
dir: /appl/lib/tcl_core.b/
implement Tcl_Core;
# these are the outside modules, self explanatory..
include "sys.m";
sys: Sys;
include "draw.m";
draw: Draw;
include "bufio.m";
bufmod : Bufio;
Iobuf : import bufmod;
include "string.m";
str : String;
include "tk.m";
tk: Tk;
include "wmlib.m";
wmlib: Wmlib;
# these are stand alone Tcl libraries, for Tcl pieces that
# are "big" enough to be called their own.
include "tcl.m";
include "tcllib.m";
include "utils.m";
htab: Str_Hashtab;
mhtab : Mod_Hashtab;
shtab : Sym_Hashtab;
stack : Tcl_Stack;
utils : Tcl_Utils;
Hash: import htab;
MHash : import mhtab;
SHash : import shtab;
# global error flag and message. One day, this will be stack based..
errmsg : string;
error, mypid : int;
sproc : adt {
name : string;
args : string;
script : string;
};
TCL_UNKNOWN, TCL_SIMPLE, TCL_ARRAY : con iota;
# Global vars. Simple variables, and associative arrays.
libmods : ref MHash;
proctab := array[100] of sproc;
retfl : int;
symtab : ref SHash;
nvtab : ref Hash;
avtab : array of (ref Hash,string);
tclmod : TclData;
core_commands:=array[] of {
"append" , "array", "break" , "continue" , "catch", "dumpstack",
"exit" , "expr" , "eval" ,
"for" , "foreach" ,
"global" , "if" , "incr" , "info",
"lappend" , "level" , "load" ,
"proc" , "return" , "set" ,
"source" ,"switch" , "time" ,
"unset" , "uplevel", "upvar", "while" , "#"
};
about() : array of string {
return core_commands;
}
init(ctxt: ref Draw->Context, argv: list of string) {
sys = load Sys Sys->PATH;
draw = load Draw Draw->PATH;
bufmod = load Bufio Bufio->PATH;
htab = load Str_Hashtab Str_Hashtab->PATH;
mhtab = load Mod_Hashtab Mod_Hashtab->PATH;
shtab = load Sym_Hashtab Sym_Hashtab->PATH;
stack = load Tcl_Stack Tcl_Stack->PATH;
str = load String String->PATH;
utils = load Tcl_Utils Tcl_Utils->PATH;
tk = load Tk Tk->PATH;
wmlib= load Wmlib Wmlib->PATH;
if (bufmod == nil || htab == nil || stack == nil ||
str == nil || utils == nil || tk == nil ||
wmlib==nil || mhtab == nil || shtab == nil){
sys->print("can't load initial modules %r\n");
exit;
}
# get a new stack frame.
stack->init();
(nvtab,avtab,symtab)=stack->newframe();
libmods=mhtab->alloc(101);
# grab my pid, and set a new group to make me easy to kill.
mypid=sys->pctl(sys->NEWPGRP, nil);
# no default top window.
tclmod.top=nil;
tclmod.context=ctxt;
tclmod.debug=0;
# set up library modules.
args:=array[] of {"do_load","io"};
do_load(args);
args=array[] of {"do_load","string"};
do_load(args);
args=array[] of {"do_load","calc"};
do_load(args);
args=array[] of {"do_load","list"};
do_load(args);
args=array[] of {"do_load","tk"};
do_load(args);
arr:=about();
for(i:=0;i<len arr;i++)
libmods.insert(arr[i],nil);
# cmd line args...
if (argv != nil)
argv = tl argv;
while (argv != nil) {
loadfile(hd argv);
argv = tl argv;
}
}
set_top(win:ref Tk->Toplevel){
tclmod.top=win;
}
clear_error(){
error=0;
errmsg="";
}
notify(num : int,s : string) : string {
error=1;
case num{
1 =>
errmsg=sys->sprint(
"wrong # args: should be \"%s\"",s);
* =>
errmsg= s;
}
return errmsg;
}
grab_lines(new_inp,unfin: string ,lines : chan of string){
error=0;
tclmod.lines=lines;
input,line : string;
if (new_inp==nil)
new_inp = "tcl%";
if (unfin==nil)
unfin = "tcl>";
sys->print("%s ", new_inp);
iob := bufmod->fopen(sys->fildes(0),bufmod->OREAD);
if (iob==nil){
sys->print("cannot open stdin for reading.\n");
return;
}
while((input=iob.gets('\n'))!=nil){
line+=input;
if (!finished(line,0))
sys->print("%s ", unfin);
else{
lines <- = line;
line=nil;
}
}
}
# this is the main function. Its input is a complete (i.e. matching
# brackets etc) tcl script, and its output is a message - if there
# is one.
evalcmd(s: string, termchar: int) : string {
msg : string;
i:=0;
retfl=0;
if (tclmod.debug==2)
sys->print("Entered evalcmd, s=%s, termchar=%c\n",s,termchar);
# strip null statements..
while((i<len s) && (s[i]=='\n' || s[i]==';')) i++;
if (i==len s) return nil;
# parse the script statement by statement
for(;s!=nil;i++){
# wait till we have a complete statement
if (i==len s || ((s[i]==termchar || s[i]==';' || s[i]=='\n')
&& finished(s[0:i],termchar))){
# throw it away if its a comment...
if (s[0]!='#')
argv := parsecmd(s[0:i],termchar,0);
msg = nil;
if (tclmod.debug==2)
for(k:=0;k<len argv;k++)
sys->print("argv[%d]: (%s)\n",k,argv[k]);
# argv is now a completely parsed array of arguments
# for the Tcl command..
# find the module that the command is in and
# execute it.
if (len argv != 0){
mod:=lookup(argv[0]);
if (mod!=nil){
(error,msg)=
mod->exec(ref tclmod,argv);
if (error)
errmsg=msg;
} else {
if (argv[0]!=nil &&
argv[0][0]=='.')
msg=do_tk(argv);
else
msg=exec(argv);
}
}
# was there an error?
if (error) {
if (len argv > 0 && argv[0]!=""){
stat : string;
stat = "In function "+argv[0];
if (len argv >1 && argv[1]!=""){
stat[len stat]=' ';
stat+=argv[1];
}
stat+=".....\n\t";
errmsg=stat+errmsg;
}
msg=errmsg;
}
# we stop parsing if we hit a break, continue, return,
# error, termchar or end of string.
if (msg=="break" || msg=="continue" || error || retfl==1
|| len s <= i || (len s > i && s[i]==termchar))
return msg;
# otherwise eat up the parsed statement and continue
s=s[i+1:];
i=-1;
}
}
return msg;
}
# returns 1 if the line has matching braces, brackets and
# double-quotes and does not end in "\\\n"
finished(s : string, termchar : int) : int {
cb:=0;
dq:=0;
sb:=0;
if (s==nil) return 1;
if (termchar=='}') cb++;
if (termchar==']') sb++;
if (len s > 1 && s[len s -2]=='\\')
return 0;
if (s[0]=='{') cb++;
if (s[0]=='}' && cb>0) cb--;
if (s[0]=='[') sb++;
if (s[0]==']' && sb>0) sb--;
if (s[0]=='"') dq=1-dq;
for(i:=1;i<len s;i++){
if (s[i]=='{' && s[i-1]!='\\') cb++;
if (s[i]=='}' && s[i-1]!='\\' && cb>0) cb--;
if (s[i]=='[' && s[i-1]!='\\') sb++;
if (s[i]==']' && s[i-1]!='\\' && sb>0) sb--;
if (s[i]=='"' && s[i-1]!='\\') dq=1-dq;
}
return (cb==0 && sb==0 && dq==0);
}
# counts the offset till the next matching ']'
strip_to_match(s : string, ptr: int) : int {
j :=0;
nb:=0;
while(j<len s){
if (s[j]=='{')
while (j < len s && s[j]!='}') j++;
if (s[j]=='[') nb++;
if (s[j]==']'){
nb--;
if (nb==-1) return ptr+j;
}
j++;
}
return ptr+j;
}
# returns the type of variable represented by the string s, which is
# a name.
isa(s: string) : (int,int,string) {
found,val : int;
name,al : string;
curlev:=stack->level();
if (tclmod.debug==2)
sys->print("Called isa with %s, current stack level is %d\n",s,curlev);
(found,nil)=nvtab.find(s);
if (found) return (TCL_SIMPLE,curlev,s);
for (i:=0;i<len avtab;i++){
(nil,name)=avtab[i];
if (name==s) return (TCL_ARRAY,curlev,s);
}
if (symtab==nil)
return (TCL_UNKNOWN,curlev,s);
(found,val,al)=symtab.find(s);
if (!found)
return (TCL_UNKNOWN,curlev,s);
(tnv,tav,nil):=stack->examine(val);
if (tclmod.debug==2)
sys->print("have a level %d for %s\n",val,al);
if (tnv!=nil){
(found,nil)=tnv.find(al);
if (found) return (TCL_SIMPLE,val,al);
}
if (tav!=nil){
for (i=0;i<len tav;i++){
(nil,name)=tav[i];
if (name==al) return (TCL_ARRAY,val,al);
}
}
if (tclmod.debug==2)
sys->print("%s not found, creating at stack level %d\n",al,val);
return (TCL_UNKNOWN,val,al);
}
# This function only works if the string is already parsed!
# takes a var_name and returns the hash table for it and the
# name to look up. This is one of two things:
# for simple variables:
# findvar(foo) ---> (nvtab,foo)
# for associative arrays:
# findvar(foo(bar)) -----> (avtab[i],bar)
# where avtab[i].name==foo
# if create is 1, then an associative array is created upon first
# reference.
# returns (nil,error message) if there is a problem.
find_var(s : string,create : int) : (ref Hash,string) {
rest,name,index : string;
retval,tnv : ref Hash;
tav : array of (ref Hash,string);
i,tag,lev: int;
(name,index)=str->splitl(s,"(");
if (index!=nil){
(index,rest)=str->splitl(index[1:],")");
if (rest!=")")
return (nil,"bad variable name");
}
(tag,lev,name) = isa(name);
case tag {
TCL_SIMPLE =>
if (index!=nil)
return (nil,"variable isn't array");
(tnv,nil,nil)=stack->examine(lev);
return (tnv,name);
TCL_ARRAY =>
if (index==nil)
return (nil,"variable is array");
(nil,tav,nil)=stack->examine(lev);
for(i=0;i<len tav;i++){
(retval,rest)=tav[i];
if (rest==name)
return (retval,index);
}
return (nil,"find_var: impossible!!");
# if we get here, the variable needs to be
# created.
TCL_UNKNOWN =>
if (!create)
return (nil,"no such variable");
(tnv,tav,nil)=stack->examine(lev);
if (index==nil)
return (tnv,name);
}
# if we get here, we are creating an associative variable in the
# tav array.
for(i=0;i<len tav;i++){
(retval,rest)=tav[i];
if (rest==nil){
retval=htab->alloc(101);
tav[i]=(retval,name);
return (retval,index);
}
}
return (nil,"associative array table full!");
}
# the main parsing function, a la ousterhouts man pages. Takes a
# string that is meant to be a tcl statement and parses it,
# reevaluating and quoting upto the termchar character. If disable
# is true, then whitespace is not ignored.
parsecmd(s: string, termchar,disable: int) : array of string {
argv:= array[200] of string;
buf,nm,id: string;
argc := 0;
nc := 0;
c :=0;
tab : ref Hash;
if (disable && (termchar=='\n' || termchar==';')) termchar=0;
outer:
for (i := 0; i<len s ;) {
if ((i>0 &&s[i-1]!='\\' &&s[i]==termchar)||(s[0]==termchar))
break;
case int s[i] {
' ' or '\t' or '\n' =>
if (!disable){
if (nc > 0) { # end of a word?
argv[argc++] = buf;
buf = nil;
nc = 0;
}
i++;
}
else
buf[nc++]=s[i++];
'$' =>
if (i>0 && s[i-1]=='\\')
buf[nc++]=s[i++];
else {
(nm,id) = parsename(s[i+1:], termchar);
if (id!=nil)
nm=nm+"("+id+")";
(tab,nm)=find_var(nm,0); #don't create var!
if (len nm > 0 && tab!=nil) {
(found, val) := tab.find(nm);
buf += val;
nc += len val;
#sys->print("Here s[i:] is (%s)\n",s[i:]);
if(nm==id)
while(s[i]!=')') i++;
else
if (s[i+1]=='{')
while(s[i]!='}') i++;
else
i += len nm;
if (nc==0 && (i==len s-1 ||
s[i+1]==' ' ||
s[i+1]=='\t'||
s[i+1]==termchar))
argv[argc++]=buf;
} else {
buf[nc++] = '$';
}
i++;
}
'{' =>
if (i>0 && s[i-1]=='\\')
buf[nc++]=s[i++];
else if (s[i+1]=='}'){
argv[argc++] = nil;
buf = nil;
nc = 0;
i+=2;
} else {
nbra := 1;
for (i++; i < len s; i++) {
if (s[i] == '{')
nbra++;
else if (s[i] == '}') {
nbra--;
if (nbra == 0) {
i++;
continue outer;
}
}
buf[nc++] = s[i];
}
}
'[' =>
if (i>0 && s[i-1]=='\\')
buf[nc++]=s[i++];
else{
a:=evalcmd(s[i+1:],']');
if (error)
return nil;
if (nc>0){
buf+=a;
nc += len a;
} else {
argv[argc++] = a;
buf = nil;
nc = 0;
}
i++;
i=strip_to_match(s[i:],i);
i++;
}
'"' =>
if (i>0 && s[i-1]!='\\' && nc==0){
ans:=parsecmd(s[i+1:],'"',1);
#sys->print("len ans is %d\n",len ans);
if (len ans!=0){
for(;;){
i++;
if(s[i]=='"' &&
s[i-1]!='\\')
break;
}
i++;
argv[argc++] = ans[0];
} else {
argv[argc++] = nil;
i+=2;
}
buf = nil;
nc = 0;
}
else buf[nc++] = s[i++];
* =>
if (s[i]=='\\'){
c=unesc(s[i:]);
if (c!=0){
buf[nc++] = c;
i+=2;
} else {
if (i+1 < len s && !(s[i+1]=='"'
|| s[i+1]=='$' || s[i+1]=='{'
|| s[i+1]=='['))
buf[nc++]=s[i];
i++;
}
c=0;
} else
buf[nc++]=s[i++];
}
}
if (nc > 0) # fix up last word if present
argv[argc++] = buf;
ret := array[argc] of string;
ret[0:] = argv[0:argc];
return ret;
}
# parses a name by Tcl rules, a valid name is either $foo, $foo(bar)
# or ${foo}.
parsename(s: string, termchar: int) : (string,string) {
ret,arr,rest: string;
rets : array of string;
if (len s == 0)
return (nil,nil);
if (s[0]=='{'){
(ret,nil)=str->splitl(s,"}");
#sys->print("returning [%s]\n",ret[1:]);
return (ret[1:],nil);
}
loop: for (i := 0; i < len s && s[i] != termchar; i++) {
case (s[i]) {
'a' to 'z' or 'A' to 'Z' or '0' to '9' or '_' =>
ret[i] = s[i];
* =>
break loop;
'(' =>
arr=ret[0:i];
rest=s[i+1:];
rets=parsecmd(rest,')',0);
# should always be len 1?
if (len rets >1)
sys->print("len rets>1 in parsename!\n");
return (arr,rets[0]);
}
}
return (ret,nil);
}
loadfile(file :string) : string {
iob : ref Iobuf;
msg,input,line : string;
if (file==nil)
return nil;
iob = bufmod->open(file,bufmod->OREAD);
if (iob==nil)
return notify(0,sys->sprint(
"couldn't read file \"%s\":%r",file));
while((input=iob.gets('\n'))!=nil){
line+=input;
if (finished(line,0)){
# put in a return catch here...
line = prepass(line);
msg=evalcmd(line,0);
if (error) return errmsg;
line=nil;
}
}
return msg;
}
#unescapes a string. Can do better.....
unesc(s: string) : int {
c: int;
if (len s == 1) return 0;
case s[1] {
'a'=> c = '\a';
'n'=> c = '\n';
't'=> c = '\t';
'r'=> c = '\r';
'b'=> c = '\b';
'\\'=> c = '\\';
'}' => c = '}';
']' => c=']';
# do hex and octal.
* => c = 0;
}
return c;
}
# prepass a string and replace "\\n[ \t]*" with ' '
prepass(s : string) : string {
for(i := 0; i < len s; i++) {
if(s[i] != '\\')
continue;
j:=i;
if (s[i+1] == '\n') {
s[j]=' ';
i++;
while(i<len s && (s[i]==' ' || s[i]=='\t'))
i++;
if (i==len s)
s = s[0:j];
else
s=s[0:j]+s[i+1:];
i=j;
}
}
return s;
}
exec(argv : array of string) : string {
msg : string;
if (argv[0]=="")
return nil;
case (argv[0]) {
"append" =>
msg= do_append(argv);
"array" =>
msg= do_array(argv);
"break" or "continue" =>
return argv[0];
"catch" =>
msg=do_catch(argv);
"debug" =>
msg=do_debug(argv);
"dumpstack" =>
msg=do_dumpstack(argv);
"exit" =>
do_exit();
"expr" =>
msg = do_expr(argv);
"eval" =>
msg = do_eval(argv);
"for" =>
msg = do_for(argv);
"foreach" =>
msg = do_foreach(argv);
"format" =>
msg = do_string(argv);
"global" =>
msg = do_global(argv);
"if" =>
msg = do_if(argv);
"incr" =>
msg = do_incr(argv);
"info" =>
msg = do_info(argv);
"lappend" =>
msg = do_lappend(argv);
"level" =>
msg=sys->sprint("Current Stack "+
"level is %d",
stack->level());
"load" =>
msg=do_load(argv);
"proc" =>
msg=do_proc(argv);
"return" =>
msg=do_return(argv);
retfl =1;
"set" =>
msg = do_set(argv);
"source" =>
msg = do_source(argv);
"string" =>
msg = do_string(argv);
"switch" =>
msg = do_switch(argv);
"time" =>
msg=do_time(argv);
"unset" =>
msg = do_unset(argv);
"uplevel" =>
msg=do_uplevel(argv);
"upvar" =>
msg=do_upvar(argv);
"while" =>
msg = do_while(argv);
"#" =>
msg=nil;
* =>
msg = uproc(argv);
}
return msg;
}
# from here on is the list of commands, alpahabetised, we hope.
do_append(argv :array of string) : string {
tab : ref Hash;
if (len argv==1 || len argv==2)
return notify(1,
"append varName value ?value ...?");
name := argv[1];
(tab,name)=find_var(name,1);
if (tab==nil)
return notify(0,name);
(found, val) := tab.find(name);
for (i:=2;i<len argv;i++)
val+=argv[i];
tab.insert(name,val);
return val;
}
do_array(argv : array of string) : string {
tab : ref Hash;
name : string;
flag : int;
if (len argv!=3)
return notify(1,"array [names, size] name");
case argv[1] {
"names" =>
flag=1;
"size" =>
flag=0;
* =>
return notify(0,"expexted names or size, got "+argv[1]);
}
(tag,lev,al) := isa(argv[2]);
if (tag!=TCL_ARRAY)
return notify(0,argv[2]+" isn't an array");
(nil,tav,nil):=stack->examine(lev);
for (i:=0;i<len tav;i++){
(tab,name)=tav[i];
if (name==al) break;
}
if (flag==0)
return string tab.lsize;
return tab.dump();
}
do_catch(argv : array of string) : string {
if (len argv==1 || len argv > 3)
return notify(1,"catch command ?varName?");
msg:=evalcmd(argv[1],0);
if (len argv==3 && error){
(tab,name):=find_var(argv[2],1);
if (tab==nil)
return notify(0,name);
tab.insert(name, msg);
}
ret:=string error;
error=0;
return ret;
}
do_debug(argv : array of string) : string {
add : string;
if (len argv!=2)
return notify(1,"debug");
(i,rest):=str->toint(argv[1],10);
if (rest!=nil)
return notify(0,"Expected integer and got "+argv[1]);
tclmod.debug=i;
if (tclmod.debug==0)
add="off";
else
add="on";
return "debugging is now "+add+" at level"+ string i;
}
do_dumpstack(argv : array of string) : string {
if (len argv!=1)
return notify(1,"dumpstack");
stack->dump();
return nil;
}
do_eval(argv : array of string) : string {
eval_str : string;
for(i:=1;i<len argv;i++){
eval_str += argv[i];
eval_str[len eval_str]=' ';
}
return evalcmd(eval_str[0:len eval_str -1],0);
}
do_exit(){
kfd := sys->open("#p/"+string mypid+"/ctl", sys->OWRITE);
if(kfd == nil)
sys->print("error opening pid %d (%r)\n",mypid);
sys->fprint(kfd, "killgrp");
exit;
}
do_expr(argv : array of string) : string {
retval : string;
for (i:=1;i<len argv;i++){
retval+=argv[i];
retval[len retval]=' ';
}
retval=retval[0: len retval -1];
argv=parsecmd(retval,0,0);
cal:=lookup("calc");
(err,ret):= cal->exec(ref tclmod,argv);
if (err) return notify(0,ret);
return ret;
}
do_for(argv : array of string) : string {
if (len argv!=5)
return notify(1,"for start test next command");
test := array[] of {"expr",argv[2]};
evalcmd(argv[1],0);
for(;;){
msg:=do_expr(test);
if (msg=="Error!")
return notify(0,sys->sprint(
"syntax error in expression \"%s\"",
argv[2]));
if (msg=="0")
return nil;
msg=evalcmd(argv[4],0);
if (msg=="break")
return nil;
if (msg=="continue"); #do nothing!
evalcmd(argv[3],0);
if (error)
return errmsg;
}
}
do_foreach(argv: array of string) : string{
tab : ref Hash;
if (len argv!=4)
return notify(1,"foreach varName list command");
name := argv[1];
(tab,name)=find_var(name,1);
if (tab==nil)
return notify(0,name);
arr:=utils->break_it(argv[2]);
for(i:=0;i<len arr;i++){
tab.insert(name,arr[i]);
evalcmd(argv[3],0);
}
return nil;
}
do_global(argv : array of string) : string {
if (len argv==1)
return notify(1,"global varName ?varName ...?");
if (symtab==nil)
return nil;
for (i:=1 ; i < len argv;i++)
symtab.insert(argv[i],argv[i],0);
return nil;
}
do_if(argv : array of string) : string {
if (len argv==1)
return notify(1,"no expression after \"if\" argument");
expr1 := array[] of {"expr",argv[1]};
msg:=do_expr(expr1);
if (msg=="Error!")
return notify(0,sys->sprint(
"syntax error in expression \"%s\"",
argv[1]));
if (len argv==2)
return notify(1,sys->sprint(
"no script following \""+
"%s\" argument",msg));
if (msg=="0"){
if (len argv>3){
if (argv[3]=="else"){
if (len argv==4)
return notify(1,
"no script"+
" following \"else\" argument");
return evalcmd(argv[4],0);
}
if (argv[3]=="elseif"){
argv[3]="if";
return do_if(argv[3:]);
}
}
return nil;
}
return evalcmd(argv[2],0);
}
do_incr(argv :array of string) : string {
num,xtra : int;
rest :string;
tab : ref Hash;
if (len argv==1)
return notify(1,"incr varName ?increment?");
name := argv[1];
(tab,name)=find_var(name,0); #doesn't create!!
if (tab==nil)
return notify(0,name);
(found, val) := tab.find(name);
if (!found)
return notify(0,sys->sprint("can't read \"%s\": "
+"no such variable",name));
(num,rest)=str->toint(val,10);
if (rest!=nil)
return notify(0,sys->sprint(
"expected integer but got \"%s\"",val));
if (len argv == 2){
num+=1;
tab.insert(name,string num);
}
if (len argv == 3) {
val = argv[2];
(xtra,rest)=str->toint(val,10);
if (rest!=nil)
return notify(0,sys->sprint(
"expected integer but got \"%s\""
,val));
num+=xtra;
tab.insert(name, string num);
}
return string num;
}
do_info(argv : array of string) : string {
if (len argv==1)
return notify(1,"info option ?arg arg ...?");
case argv[1] {
"args" =>
return do_info_args(argv,0);
"body" =>
return do_info_args(argv,1);
"commands" =>
return do_info_commands(argv);
"exists" =>
return do_info_exists(argv);
"procs" =>
return do_info_procs(argv);
}
return sys->sprint(
"bad option \"%s\": should be args, body, commands, exists, procs",
argv[1]);
}
do_info_args(argv : array of string,body :int) : string {
name: string;
s : sproc;
if (body)
name="body";
else
name="args";
if (len argv!=3)
return notify(1,"info "+name+" procname");
for(i:=0;i<len proctab;i++){
s=proctab[i];
if (s.name==argv[2])
break;
}
if (i==len proctab)
return notify(0,argv[2]+" isn't a procedure.");
if (body)
return s.script;
return s.args;
}
do_info_commands(argv : array of string) : string {
if (len argv==1 || len argv>3)
return notify(1,"info commands [pattern]");
return libmods.dump();
}
do_info_exists(argv : array of string) : string {
name, index : string;
tab : ref Hash;
if (len argv!=3)
return notify(1,"info exists varName");
(name,index)=parsename(argv[2],0);
(i,nil,nil):=isa(name);
if (i==TCL_UNKNOWN)
return "0";
if (index==nil)
return "1";
(tab,name)=find_var(argv[2],0);
if (tab==nil)
return "0";
(found, val) := tab.find(name);
if (!found)
return "0";
return "1";
}
do_info_procs(argv : array of string) : string {
if (len argv==1 || len argv>3)
return notify(1,"info procs [pattern]");
retval : string;
for(i:=0;i<len proctab;i++){
s:=proctab[i];
if (s.name!=nil){
retval+=s.name;
retval[len retval]=' ';
}
}
return retval;
}
do_lappend(argv : array of string) : string{
tab : ref Hash;
retval :string;
retval=nil;
if (len argv==1 || len argv==2)
return notify(1,
"lappend varName value ?value ...?");
name := argv[1];
(tab,name)=find_var(name,1);
if (tab==nil)
return notify(0,name);
(found, val) := tab.find(name);
for(i:=2;i<len argv;i++){
flag:=0;
if (spaces(argv[i])) flag=1;
if (flag) retval[len retval]='{';
retval += argv[i];
if (flag) retval[len retval]='}';
retval[len retval]=' ';
}
if (retval!=nil)
retval=retval[0:len retval-1];
if (val!=nil)
retval=val+" "+retval;
tab.insert(name,retval);
return retval;
}
spaces(s : string) : int{
if (s==nil) return 1;
for(i:=0;i<len s;i++)
if (s[i]==' ' || s[i]=='\t') return 1;
return 0;
}
do_load(argv : array of string) : string {
# look for a dis library to load up, then
# add to library array.
if (len argv!=2)
return notify(1,"load libname");
fname:="/dis/lib/tcl_"+argv[1]+".dis";
mod:= load TclLib fname;
if (mod==nil)
return notify(0,
sys->sprint("Cannot load %s",fname));
arr:=mod->about();
for(i:=0;i<len arr;i++)
libmods.insert(arr[i],mod);
return nil;
}
do_proc(argv : array of string) : string {
if (len argv != 4)
return notify(1,"proc name args body");
for(i:=0;i<len proctab;i++)
if (proctab[i].name==nil ||
proctab[i].name==argv[1]) break;
if (i==len proctab)
return notify(0,"procedure table full!");
proctab[i].name=argv[1];
proctab[i].args=argv[2];
proctab[i].script=argv[3];
return nil;
}
do_return(argv : array of string) : string {
if (len argv==1)
return nil;
# put in options here.....
return argv[1];
}
do_set(argv : array of string) : string {
tab : ref Hash;
if (len argv == 1 || len argv > 3)
return notify(1,"set varName ?newValue?");
name := argv[1];
(tab,name)=find_var(name,1);
if (tab==nil)
return notify(0,name);
(found, val) := tab.find(name);
if (len argv == 2)
if (!found)
val = notify(0,sys->sprint(
"can't read \"%s\": "
+"no such variable",name));
if (len argv == 3) {
val = argv[2];
tab.insert(name, val);
}
return val;
}
do_source(argv : array of string) : string {
if (len argv !=2)
return notify(1,"source fileName");
return loadfile(argv[1]);
}
do_string(argv : array of string) : string {
stringmod := lookup("string");
if (stringmod==nil)
return notify(0,sys->sprint(
"String Package not loaded (%r)"));
(err,retval):= stringmod->exec(ref tclmod,argv);
if (err) return notify(0,retval);
return retval;
}
do_switch(argv : array of string) : string {
i:=0;
arr : array of string;
if (len argv < 3)
return notify(1,"switch "
+"?switches? string pattern body ... "+
"?default body?\"");
if (len argv == 3)
arr=utils->break_it(argv[2]);
else
arr=argv[2:];
if (len arr % 2 !=0)
return notify(0,
"extra switch pattern with no body");
for (i=0;i<len arr;i+=2)
if (argv[1]==arr[i])
break;
if (i==len arr){
if (arr[i-2]=="default")
return evalcmd(arr[i-1],0);
else return nil;
}
while (i<len arr && arr[i+1]=="-") i+=2;
return evalcmd(arr[i+1],0);
}
do_time(argv : array of string) : string {
rest : string;
end,start,times : int;
if (len argv==1 || len argv>3)
return notify(1,"time command ?count?");
if (len argv==2)
times=1;
else{
(times,rest)=str->toint(argv[2],10);
if (rest!=nil)
return notify(0,sys->sprint(
"expected integer but got \"%s\"",argv[2]));
}
start=sys->millisec();
for(i:=0;i<times;i++)
evalcmd(argv[1],0);
end=sys->millisec();
r:= (real end - real start) / real times;
return sys->sprint("%g milliseconds per iteration", r);
}
do_unset(argv : array of string) : string {
tab : ref Hash;
name: string;
if (len argv == 1)
return notify(1,"unset "+
"varName ?varName ...?");
for(i:=1;i<len argv;i++){
name = argv[i];
(tab,name)=find_var(name,0);
if (tab==nil)
return notify(0,sys->sprint("can't unset \"%s\": no such" +
" variable",name));
tab.delete(name);
}
return nil;
}
do_uplevel(argv : array of string) : string {
level: int;
rest,scr : string;
scr=nil;
exact:=0;
i:=1;
if (len argv==1)
return notify(1,"uplevel ?level? command ?arg ...?");
if (len argv==2)
level=-1;
else {
lev:=argv[1];
if (lev[0]=='#'){
exact=1;
lev=lev[1:];
}
(level,rest)=str->toint(lev,10);
if (rest!=nil){
i=2;
level =-1;
}
}
oldlev:=stack->level();
if (!exact)
level+=oldlev;
(tnv,tav,sym):=stack->examine(level);
if (tnv==nil && tav==nil)
return notify(0,"bad level "+argv[1]);
if (tclmod.debug==2)
sys->print("In uplevel, current level is %d, moving to level %d\n",
oldlev,level);
stack->move(level);
oldav:=avtab;
oldnv:=nvtab;
oldsym:=symtab;
avtab=tav;
nvtab=tnv;
symtab=sym;
for(;i<len argv;i++)
scr=scr+argv[i]+" ";
msg:=evalcmd(scr[0:len scr-1],0);
avtab=oldav;
nvtab=oldnv;
symtab=oldsym;
ok:=stack->move(oldlev);
if (tclmod.debug==2)
sys->print("Leaving uplevel, current level is %d, moving back to"+
" level %d,move was %d\n",
level,oldlev,ok);
return msg;
}
do_upvar(argv : array of string) : string {
level:int;
rest:string;
i:=1;
exact:=0;
if (len argv<3 || len argv>4)
return notify(1,"upvar ?level? ThisVar OtherVar");
if (len argv==3)
level=-1;
else {
lev:=argv[1];
if (lev[0]=='#'){
exact=1;
lev=lev[1:];
}
(level,rest)=str->toint(lev,10);
if (rest!=nil){
i=2;
level =-1;
}
}
if (!exact)
level+=stack->level();
symtab.insert(argv[i],argv[i+1],level);
return nil;
}
do_while(argv : array of string) : string {
if (len argv!=3)
return notify(1,"while test command");
for(;;){
expr1 := array[] of {"expr",argv[1]};
msg:=do_expr(expr1);
if (msg=="Error!")
return notify(0,sys->sprint(
"syntax error in expression \"%s\"",
argv[1]));
if (msg=="0")
return nil;
evalcmd(argv[2],0);
if (error)
return errmsg;
}
}
uproc(argv : array of string) : string {
cmd,add : string;
for(i:=0;i< len proctab;i++)
if (proctab[i].name==argv[0])
break;
if (i==len proctab)
return notify(0,sys->sprint("invalid command name \"%s\"",
argv[0]));
# save tables
# push a newframe
# bind args to arguments
# do cmd
# pop frame
# return msg
# globals are supported, but upvar and uplevel are not!
arg_arr:=utils->break_it(proctab[i].args);
j:=len arg_arr;
if (len argv < j+1 && arg_arr[j-1]!="args"){
j=len argv-1;
return notify(0,sys->sprint(
"no value given for"+
" parameter \"%s\" to \"%s\"",
arg_arr[j],proctab[i].name));
}
if ((len argv > j+1) && arg_arr[j-1]!="args")
return notify(0,"called "+proctab[i].name+
" with too many arguments");
oldavtab:=avtab;
oldnvtab:=nvtab;
oldsymtab:=symtab;
(nvtab,avtab,symtab)=stack->newframe();
for (j=0;j< len arg_arr-1;j++){
cmd="set "+arg_arr[j]+" {"+argv[j+1]+"}";
evalcmd(cmd,0);
}
if (len arg_arr>j && arg_arr[j] != "args") {
cmd="set "+arg_arr[j]+" {"+argv[j+1]+"}";
evalcmd(cmd,0);
}
else {
if (len arg_arr > j) {
if (j+1==len argv)
add="";
else
add=argv[j+1];
cmd="set "+arg_arr[j]+" ";
arglist:="{"+add+" ";
j++;
while(j<len argv-1) {
arglist+=argv[j+1];
arglist[len arglist]=' ';
j++;
}
arglist[len arglist]='}';
cmd+=arglist;
evalcmd(cmd,0);
}
}
msg:=evalcmd(proctab[i].script,0);
stack->pop();
avtab=oldavtab;
nvtab=oldnvtab;
symtab=oldsymtab;
#sys->print("Error is %d, msg is %s\n",error,msg);
return msg;
}
do_tk(argv : array of string) : string {
tkpack:=lookup("button");
(err,retval):= tkpack->exec(ref tclmod,argv);
if (err) return notify(0,retval);
return retval;
}
lookup(s : string) : TclLib {
(found,mod):=libmods.find(s);
if (!found)
return nil;
return mod;
}