path: root/appl/cmd/sh/tk.b

implement Shellbuiltin;

include "sys.m";
	sys: Sys;
include "draw.m";
include "tk.m";
	tk: Tk;
include "tkclient.m";
	tkclient: Tkclient;
include "sh.m";
	sh: Sh;
	Listnode, Context: import sh;
	myself: Shellbuiltin;

tklock: chan of int;

chans := array[23] of list of (string, chan of string);
wins := array[16] of list of (int, ref Tk->Toplevel);
winid := 0;

badmodule(ctxt: ref Context, p: string)
{
	ctxt.fail("bad module", sys->sprint("tk: cannot load %s: %r", p));
}

initbuiltin(ctxt: ref Context, shmod: Sh): string
{
	sys = load Sys Sys->PATH;
	sh = shmod;

	myself = load Shellbuiltin "$self";
	if (myself == nil) badmodule(ctxt, "self");

	tk = load Tk Tk->PATH;
	if (tk == nil) badmodule(ctxt, Tk->PATH);

	tkclient = load Tkclient Tkclient->PATH;
	if (tkclient == nil) badmodule(ctxt, Tkclient->PATH);
	tkclient->init();

	tklock = chan[1] of int;

	ctxt.addbuiltin("tk", myself);
	ctxt.addbuiltin("chan", myself);
	ctxt.addbuiltin("send", myself);

	ctxt.addsbuiltin("tk", myself);
	ctxt.addsbuiltin("recv", myself);
	ctxt.addsbuiltin("alt", myself);
	ctxt.addsbuiltin("tkquote", myself);
	return nil;
}

whatis(nil: ref Sh->Context, nil: Sh, nil: string, nil: int): string
{
	return nil;
}

getself(): Shellbuiltin
{
	return myself;
}

runbuiltin(ctxt: ref Context, nil: Sh,
			cmd: list of ref Listnode, nil: int): string
{
	case (hd cmd).word {
	"tk" =>		return builtin_tk(ctxt, cmd);
	"chan" =>		return builtin_chan(ctxt, cmd);
	"send" =>		return builtin_send(ctxt, cmd);
	}
	return nil;
}

runsbuiltin(ctxt: ref Context, nil: Sh,
			cmd: list of ref Listnode): list of ref Listnode
{
	case (hd cmd).word {
	"tk" =>		return sbuiltin_tk(ctxt, cmd);
	"recv" =>		return sbuiltin_recv(ctxt, cmd);
	"alt" =>		return sbuiltin_alt(ctxt, cmd);
	"tkquote" =>	return sbuiltin_tkquote(ctxt, cmd);
	}
	return nil;
}

builtin_tk(ctxt: ref Context, argv: list of ref Listnode): string
{
	# usage:	tk window _title_ _options_
	#		tk wintitle _winid_ _title_
	#		tk _winid_ _cmd_
	if (tl argv == nil)
		ctxt.fail("usage", "usage: tk (<winid>|window|onscreen|winctlwintitle|del|namechan) args...");
	argv = tl argv;
	w := (hd argv).word;
	case w {
	"window" =>
		remark(ctxt, string makewin(ctxt, tl argv));
	"wintitle" =>
		argv = tl argv;
		# change the title of a window
		if (len argv != 2 || !isnum((hd argv).word))
			ctxt.fail("usage", "usage: tk wintitle winid title");
		tkclient->settitle(egetwin(ctxt, hd argv), word(hd tl argv));
	"winctl" =>
		argv = tl argv;
		if (len argv != 2 || !isnum((hd argv).word))
			ctxt.fail("usage", "usage: tk winctl winid cmd");
		wid := (hd argv).word;
		win := egetwin(ctxt, hd argv);
		rq := word(hd tl argv);
		if (rq == "exit") {
			delwin(int wid);
			delchan(wid);
		}
		tkclient->wmctl(win, rq);
	"onscreen" =>
		argv = tl argv;
		if (len argv < 1 || !isnum((hd argv).word))
			ctxt.fail("usage", "usage: tk onscreen winid [how]");
		how := "";
		if(tl argv != nil)
			how = word(hd tl argv);
		win := egetwin(ctxt, hd argv);
		tkclient->startinput(win, "ptr" :: "kbd" :: nil);
		tkclient->onscreen(win, how);
	"namechan" =>
		argv = tl argv;
		n := len argv;
		if (n < 2 || n > 3 || !isnum((hd argv).word))
			ctxt.fail("usage", "usage: tk namechan winid chan [name]");
		name: string;
		if (n == 3)
			name = word(hd tl tl argv);
		else
			name = word(hd tl argv);
		tk->namechan(egetwin(ctxt, hd argv), egetchan(ctxt, hd tl argv), name);

	"del" =>
		if (len argv < 2)
			ctxt.fail("usage", "usage: tk del id...");
		for (argv = tl argv; argv != nil; argv = tl argv) {
			id := (hd argv).word;
			if (isnum(id))
				delwin(int id);
			delchan(id);
		}
	* =>
		e := tkcmd(ctxt, argv);
		if (e != nil)
			remark(ctxt, e);
		if (e != nil && e[0] == '!')
			return e;
	}
	return nil;
}

remark(ctxt: ref Context, s: string)
{
	if (ctxt.options() & ctxt.INTERACTIVE)
		sys->print("%s\n", s);
}

# create a new window (and its associated channel)
makewin(ctxt: ref Context, argv: list of ref Listnode): int
{
	if (argv == nil)
		ctxt.fail("usage", "usage: tk window title options");

	if (ctxt.drawcontext == nil)
		ctxt.fail("no draw context", sys->sprint("tk: no graphics context available"));

	(title, options) := (word(hd argv), concat(tl argv));
	(top, topchan) := tkclient->toplevel(ctxt.drawcontext, options, title, Tkclient->Appl);
	newid := addwin(top);
	addchan(string newid, topchan);
	return newid;
}

builtin_chan(ctxt: ref Context, argv: list of ref Listnode): string
{
	# create a new channel
	argv = tl argv;
	if (argv == nil)
		ctxt.fail("usage", "usage: chan name....");
	for (; argv != nil; argv = tl argv) {
		name := (hd argv).word;
		if (name == nil || isnum(name))
			ctxt.fail("bad chan", "tk: bad channel name "+q(name));
		if (addchan(name, chan of string) == nil)
			ctxt.fail("bad chan", "tk: channel "+q(name)+" already exists");
	}
	return nil;
}

builtin_send(ctxt: ref Context, argv: list of ref Listnode): string
{
	if (len argv != 3)
		ctxt.fail("usage", "usage: send chan arg");
	argv = tl argv;
	c := egetchan(ctxt, hd argv);
	c <-= word(hd tl argv);
	return nil;
}


sbuiltin_tk(ctxt: ref Context, argv: list of ref Listnode): list of ref Listnode
{
	# usage:	tk _winid_ _command_
	#		tk window _title_ _options_
	argv = tl argv;
	if (argv == nil)
		ctxt.fail("usage", "tk (window|wid) args");
	case (hd argv).word {
	"window" =>
		return ref Listnode(nil, string makewin(ctxt, tl argv)) :: nil;
	"winids" =>
		ret: list of ref Listnode;
		for (i := 0; i < len wins; i++)
			for (wl := wins[i]; wl != nil; wl = tl wl)
				ret = ref Listnode(nil, string (hd wl).t0) :: ret;
		return ret;
	* =>
		return ref Listnode(nil, tkcmd(ctxt, argv)) :: nil;
	}
}

sbuiltin_alt(ctxt: ref Context, argv: list of ref Listnode): list of ref Listnode
{
	# usage: alt chan ...
	argv = tl argv;
	if (argv == nil)
		ctxt.fail("usage", "usage: alt chan...");
	nc := len argv;
	kbd := array[nc] of chan of int;
	ptr := array[nc] of chan of ref Draw->Pointer;
	ca := array[nc * 3] of chan of string;
	win := array[nc] of ref Tk->Toplevel;
	
	cname := array[nc] of string;
	i := 0;
	for (; argv != nil; argv = tl argv) {
		w := (hd argv).word;
		ca[i*3] = egetchan(ctxt, hd argv);
		cname[i] = w;
		if(isnum(w)){
			win[i] = egetwin(ctxt, hd argv);
			ca[i*3+1] = win[i].ctxt.ctl;
			ca[i*3+2] = win[i].wreq;
			ptr[i] = win[i].ctxt.ptr;
			kbd[i] = win[i].ctxt.kbd;
		}
		i++;
	}
	for(;;) alt{
	(n, key) := <-kbd =>
		tk->keyboard(win[n], key);
	(n, p) := <-ptr =>
		tk->pointer(win[n], *p);
	(n, v) := <-ca =>
		return ref Listnode(nil, cname[n/3]) :: ref Listnode(nil, v) :: nil;
	}
}

sbuiltin_recv(ctxt: ref Context, argv: list of ref Listnode): list of ref Listnode
{
	# usage: recv chan
	if (len argv != 2)
		ctxt.fail("usage", "usage: recv chan");
	ch := hd tl argv;
	c := egetchan(ctxt, ch);
	if(!isnum(ch.word))
		return ref Listnode(nil, <-c) :: nil;

	win := egetwin(ctxt, ch);
	for(;;)alt{
	key := <-win.ctxt.kbd =>
		tk->keyboard(win, key);
	p := <-win.ctxt.ptr =>
		tk->pointer(win, *p);
	s := <-win.ctxt.ctl or
	s = <-win.wreq or
	s = <-c =>
		return ref Listnode(nil, s) :: nil;
	}
}

sbuiltin_tkquote(ctxt: ref Context, argv: list of ref Listnode): list of ref Listnode
{
	if (len argv != 2)
		ctxt.fail("usage", "usage: tkquote arg");
	return ref Listnode(nil, tk->quote(word(hd tl argv))) :: nil;
}

tkcmd(ctxt: ref Context, argv: list of ref Listnode): string
{
	if (argv == nil || !isnum((hd argv).word))
		ctxt.fail("usage", "usage: tk winid command");

	return tk->cmd(egetwin(ctxt, hd argv), concat(tl argv));
}

hashfn(s: string, n: int): int
{
	h := 0;
	m := len s;
	for(i:=0; i<m; i++){
		h = 65599*h+s[i];
	}
	return (h & 16r7fffffff) % n;
}

q(s: string): string
{
	return "'" + s + "'";
}

egetchan(ctxt: ref Context, n: ref Listnode): chan of string
{
	if ((c := getchan(n.word)) == nil)
		ctxt.fail("bad chan", "tk: bad channel name "+ q(n.word));
	return c;
}

# assumes that n.word has been checked and found to be numeric.
egetwin(ctxt: ref Context, n: ref Listnode): ref Tk->Toplevel
{
	wid := int n.word;
	if (wid < 0 || (top := getwin(wid)) == nil)
		ctxt.fail("bad win", "tk: unknown window id " + q(n.word));
	return top;
}

getchan(name: string): chan of string
{
	n := hashfn(name, len chans);
	for (cl := chans[n]; cl != nil; cl = tl cl) {
		(cname, c) := hd cl;
		if (cname == name)
			return c;
	}
	return nil;
}

addchan(name: string, c: chan of string): chan of string
{
	n := hashfn(name, len chans);
	tklock <-= 1;
	if (getchan(name) == nil)
		chans[n] = (name, c) :: chans[n];
	<-tklock;
	return c;
}

delchan(name: string)
{
	n := hashfn(name, len chans);
	tklock <-= 1;
	ncl: list of (string, chan of string);
	for (cl := chans[n]; cl != nil; cl = tl cl) {
		(cname, nil) := hd cl;
		if (cname != name)
			ncl = hd cl :: ncl;
	}
	chans[n] = ncl;
	<-tklock;
}

addwin(top: ref Tk->Toplevel): int
{
	tklock <-= 1;
	id := winid++;
	slot := id % len wins;
	wins[slot] = (id, top) :: wins[slot];
	<-tklock;
	return id;
}

delwin(id: int)
{
	tklock <-= 1;
	slot := id % len wins;
	nwl: list of (int, ref Tk->Toplevel);
	for (wl := wins[slot]; wl != nil; wl = tl wl) {
		(wid, nil) := hd wl;
		if (wid != id)
			nwl = hd wl :: nwl;
	}
	wins[slot] = nwl;
	<-tklock;
}

getwin(id: int): ref Tk->Toplevel
{
	slot := id % len wins;
	for (wl := wins[slot]; wl != nil; wl = tl wl) {
		(wid, top) := hd wl;
		if (wid == id)
			return top;
	}
	return nil;
}

word(n: ref Listnode): string
{
	if (n.word != nil)
		return n.word;
	if (n.cmd != nil)
		n.word = sh->cmd2string(n.cmd);
	return n.word;
}

isnum(s: string): int
{
	for (i := 0; i < len s; i++)
		if (s[i] > '9' || s[i] < '0')
			return 0;
	return 1;
}

concat(argv: list of ref Listnode): string
{
	if (argv == nil)
		return nil;
	s := word(hd argv);
	for (argv = tl argv; argv != nil; argv = tl argv)
		s += " " + word(hd argv);
	return s;
}

lockproc(c: chan of int)
{
	sys->pctl(Sys->NEWFD|Sys->NEWNS, nil);
	for(;;){
		c <-= 1;
		<-c;
	}
}