ref: f5cc6fbe3a7bcf8bdb002c646ddd519014afafd2
dir: /appl/lib/tcl_tk.b/
implement TclLib;
include "sys.m";
sys: Sys;
include "draw.m";
include "string.m";
str : String;
include "tk.m";
tk: Tk;
include "tkclient.m";
tkclient: Tkclient;
include "tcl.m";
include "tcllib.m";
error,started : int;
w_cfg := array[] of {
"pack .Wm_t -side top -fill x",
"update",
};
tclmod : ref Tcl_Core->TclData;
windows := array[100] of (string, ref Tk->Toplevel, chan of string);
valid_commands:= array[] of {
"bind" , "bitmap" , "button" ,
"canvas" , "checkbutton" , "destroy" ,
"entry" , "focus", "frame" , "grab", "image" , "label" ,
"listbox" ,"lower", "menu" , "menubutton" ,
"pack" , "radiobutton" , "raise", "scale" ,
"scrollbar" , "text" , "update" ,
"toplevel" , "variable"
};
about() : array of string {
return valid_commands;
}
init() : string {
sys = load Sys Sys->PATH;
str = load String String->PATH;
tk = load Tk Tk->PATH;
tkclient = load Tkclient Tkclient->PATH;
if (tkclient==nil || str==nil || tk==nil)
return "Not Initialised";
# set up Draw context
tkclient->init();
started=1;
return nil;
}
exec(tcl : ref Tcl_Core->TclData,argv : array of string) : (int,string) {
retval : string;
retval="";
han,whan : ref Tk->Toplevel;
whan=nil;
msg : string;
c : chan of string;
msg=nil;
error=0;
tclmod=tcl;
if (!started)
if (init()!=nil)
return (1,"Can't Initialise TK");
if (argv[0][0]!='.')
case argv[0] {
"destroy" =>
for (j:=1;j<len argv;j++){
(msg,han)=sweepthru(argv[j]);
if (msg==nil){
if (argv[j][0]=='.')
argv[j]=argv[j][1:];
for(i:=0;i<100;i++){
(retval,nil,c)=windows[i];
if (retval==argv[1]){
c <-= "exit";
break;
}
}
}
else
msg=tkcmd(whan,"destroy "+msg);
}
return (error,msg);
"bind" or "bitmap" or "button" or
"canvas" or "checkbutton" or "entry" or
"focus" or "frame" or "grab" or
"image" or "label" or "listbox" or "lower" or
"menu" or "menubutton" or "pack" or
"radiobutton" or "raise" or "scale" or
"scrollbar" or "text" or "update" or
"variable" =>
; # do nothing
"toplevel" =>
msg=do_toplevel(argv);
return (error,msg);
* =>
return (0,"Unknown");
}
# so it's a tk-command ... replace any -command with
# a send on the tcl channel.
if (argv[0]=="bind")
argv[3]="{send Tcl_Chan "+argv[3]+"}";
for (i:=0;i<len argv;i++){
(argv[i],han)=sweepthru(argv[i]);
if (han!=nil) whan=han;
if (argv[i]!="-tcl")
retval+=argv[i];
if (i+1<len argv &&
(argv[i]=="-command" || argv[i]=="-yscrollcommand"
|| argv[i]=="-tcl" || argv[i]=="-xscrollcommand"))
argv[i+1]="{send Tcl_Chan "+argv[i+1]+"}";
if (argv[i]!="-tcl")
retval[len retval]=' ';
}
retval=retval[0:len retval -1];
if (tclmod.debug==1)
sys->print("Sending [%s] to tkcmd.\n",retval);
msg=tkcmd(whan,retval);
if (msg!="" && msg[0]=='!')
error=1;
return (error,msg);
}
sweepthru(s: string) : (string,ref Tk->Toplevel) {
han : ref Tk->Toplevel;
ret : string;
if (s=="" || s=="." || s[0]!='.')
return (s,nil);
(wname,rest):=str->splitl(s[1:],".");
for (i:=0;i<len windows;i++){
(ret,han,nil)=windows[i];
if (ret==wname)
break;
}
if (i==len windows)
return (s,nil);
return (rest,han);
}
do_toplevel(argv : array of string): string
{
name : string;
whan : ref Tk->Toplevel;
if (len argv!=2)
return notify(1,"toplevel name");
if (argv[1][0]=='.')
argv[1]=argv[1][1:];
for(i:=0;i<len windows;i++){
(name,whan,nil)=windows[i];
if(whan==nil || name==argv[1])
break;
}
if (i==len windows)
return notify(0,"Too many top level windows");
if (name==argv[1])
return notify(0,argv[1]+" is already a window name in use.");
(top, menubut) := tkclient->toplevel(tclmod.context, "", argv[1], Tkclient->Appl);
whan = top;
windows[i]=(argv[1],whan,menubut);
if (tclmod.debug==1)
sys->print("creating window %d, name %s, handle %ux\n",i,argv[1],whan);
cmd := chan of string;
tk->namechan(whan, cmd, argv[1]);
for(i=0; i<len w_cfg; i++)
tk->cmd(whan, w_cfg[i]);
tkclient->onscreen(whan, nil);
tkclient->startinput(whan, "kbd"::"ptr"::nil);
stop := chan of int;
spawn tkclient->handler(whan, stop);
spawn menulisten(whan,menubut, stop);
return nil;
}
menulisten(t : ref Tk->Toplevel, menubut : chan of string, stop: chan of int) {
for(;;) alt {
menu := <-menubut =>
if(menu == "exit"){
for(i:=0;i<len windows;i++){
(name,whan,nil):=windows[i];
if(whan==t)
break;
}
if (i!=len windows)
windows[i]=("",nil,nil);
stop <-= 1;
exit;
}
tkclient->wmctl(t, menu);
}
}
tkcmd(t : ref Tk->Toplevel, cmd: string): string {
if (len cmd ==0 || tclmod.top==nil) return nil;
if (t==nil){
t=tclmod.top;
#sys->print("Sending to WishPad\n");
}
s := tk->cmd(t, cmd);
tk->cmd(t,"update");
return s;
}
notify(num : int,s : string) : string {
error=1;
case num{
1 =>
return sys->sprint(
"wrong # args: should be \"%s\"",s);
* =>
return s;
}
}