20060303a

1 files changed, 566 insertions, 0 deletions

diff --git a/appl/wm/toolbar.b b/appl/wm/toolbar.b
new file mode 100644
index 00000000..a96f5ba4
--- /dev/null
+++ b/appl/wm/toolbar.b
@@ -0,0 +1,566 @@
+implement Toolbar;
+include "sys.m";
+	sys: Sys;
+include "draw.m";
+	draw: Draw;
+	Screen, Display, Image, Rect, Point, Wmcontext, Pointer: import draw;
+include "tk.m";
+	tk: Tk;
+include "tkclient.m";
+	tkclient: Tkclient;
+include "sh.m";
+	shell: Sh;
+	Listnode, Context: import shell;
+include "string.m";
+	str: String;
+include "arg.m";
+
+myselfbuiltin: Shellbuiltin;
+
+Toolbar: module 
+{
+	init:	fn(ctxt: ref Draw->Context, argv: list of string);
+	initbuiltin: fn(c: ref Context, sh: Sh): string;
+	runbuiltin: fn(c: ref Context, sh: Sh,
+			cmd: list of ref Listnode, last: int): string;
+	runsbuiltin: fn(c: ref Context, sh: Sh,
+			cmd: list of ref Listnode): list of ref Listnode;
+	whatis: fn(c: ref Sh->Context, sh: Sh, name: string, wtype: int): string;
+	getself: fn(): Shellbuiltin;
+};
+
+MAXCONSOLELINES:	con 1024;
+
+# execute this if no menu items have been created
+# by the init script.
+defaultscript :=
+	"{menu shell " +
+		"{{autoload=std; load $autoload; pctl newpgrp; wm/sh}&}}";
+
+tbtop: ref Tk->Toplevel;
+screenr: Rect;
+
+badmodule(p: string)
+{
+	sys->fprint(stderr(), "toolbar: cannot load %s: %r\n", p);
+	raise "fail:bad module";
+}
+
+init(ctxt: ref Draw->Context, argv: list of string)
+{
+	sys  = load Sys Sys->PATH;
+	draw = load Draw Draw->PATH;
+	if(draw == nil)
+		badmodule(Draw->PATH);
+	tk   = load Tk Tk->PATH;
+	if(tk == nil)
+		badmodule(Tk->PATH);
+
+	str = load String String->PATH;
+	if(str == nil)
+		badmodule(String->PATH);
+
+	tkclient = load Tkclient Tkclient->PATH;
+	if(tkclient == nil)
+		badmodule(Tkclient->PATH);
+	tkclient->init();
+
+	shell = load Sh Sh->PATH;
+	if (shell == nil)
+		badmodule(Sh->PATH);
+	arg := load Arg Arg->PATH;
+	if (arg == nil)
+		badmodule(Arg->PATH);
+
+	myselfbuiltin = load Shellbuiltin "$self";
+	if (myselfbuiltin == nil)
+		badmodule("$self(Shellbuiltin)");
+
+	sys->pctl(Sys->NEWPGRP|Sys->FORKNS, nil);
+
+	sys->bind("#p", "/prog", sys->MREPL);
+	sys->bind("#s", "/chan", sys->MBEFORE);
+
+	arg->init(argv);
+	arg->setusage("toolbar [-s]");
+	startmenu := 1;
+	while((c := arg->opt()) != 0){
+		case c {
+		's' =>
+			startmenu = 0;
+		* =>
+			arg->usage();
+		}
+	}
+	argv = arg->argv();
+	arg = nil;
+
+	if (ctxt == nil){
+		sys->fprint(sys->fildes(2), "toolbar: must run under a window manager\n");
+		raise "fail:no wm";
+	}
+
+	exec := chan of string;
+	task := chan of string;
+
+	tbtop = toolbar(ctxt, startmenu, exec, task);
+	tkclient->startinput(tbtop, "ptr" :: "control" :: nil);
+	layout(tbtop);
+
+	shctxt := Context.new(ctxt);
+	shctxt.addmodule("wm", myselfbuiltin);
+
+	snarfIO := sys->file2chan("/chan", "snarf");
+	if(snarfIO == nil)
+		fatal(sys->sprint("cannot make /chan/snarf: %r"));
+	sync := chan of string;
+	spawn consoleproc(ctxt, sync);
+	if ((err := <-sync) != nil)
+		fatal(err);
+
+	setupfinished := chan of int;
+	donesetup := 0;
+	spawn setup(shctxt, setupfinished);
+
+	snarf: array of byte;
+#	write("/prog/"+string sys->pctl(0, nil)+"/ctl", "restricted"); # for testing
+	for(;;) alt{
+	s := <-tbtop.ctxt.kbd =>
+		tk->keyboard(tbtop, c);
+	m := <-tbtop.ctxt.ptr =>
+		tk->pointer(tbtop, *m);
+	s := <-tbtop.ctxt.ctl or
+	s = <-tbtop.wreq =>
+		wmctl(tbtop, s);
+	s := <-exec =>
+		# guard against parallel access to the shctxt environment
+		if (donesetup){
+			{
+ 				shctxt.run(ref Listnode(nil, s) :: nil, 0);
+			} exception e {"fail:*" =>;}
+		}
+	detask := <-task =>
+		deiconify(detask);
+	(off, data, fid, wc) := <-snarfIO.write =>
+		if(wc == nil)
+			break;
+		if (off == 0)			# write at zero truncates
+			snarf = data;
+		else {
+			if (off + len data > len snarf) {
+				nsnarf := array[off + len data] of byte;
+				nsnarf[0:] = snarf;
+				snarf = nsnarf;
+			}
+			snarf[off:] = data;
+		}
+		wc <-= (len data, "");
+	(off, nbytes, nil, rc) := <-snarfIO.read =>
+		if(rc == nil)
+			break;
+		if (off >= len snarf) {
+			rc <-= (nil, "");		# XXX alt
+			break;
+		}
+		e := off + nbytes;
+		if (e > len snarf)
+			e = len snarf;
+		rc <-= (snarf[off:e], "");	# XXX alt
+	donesetup = <-setupfinished =>
+		;	
+	}
+}
+
+wmctl(top: ref Tk->Toplevel, c: string)
+{
+	args := str->unquoted(c);
+	if(args == nil)
+		return;
+	n := len args;
+
+	case hd args{
+	"request" =>
+		# request clientid args...
+		if(n < 3)
+			return;
+		args = tl args;
+		clientid := hd args;
+		args = tl args;
+		err := handlerequest(clientid, args);
+		if(err != nil)
+			sys->fprint(sys->fildes(2), "toolbar: bad wmctl request %#q: %s\n", c, err);
+	"newclient" =>
+		# newclient id
+		;
+	"delclient" =>
+		# delclient id
+		deiconify(hd tl args);
+	"rect" =>
+		tkclient->wmctl(top, c);
+		layout(top);
+	* =>
+		tkclient->wmctl(top, c);
+	}
+}
+
+handlerequest(clientid: string, args: list of string): string
+{
+	n := len args;
+	case hd args {
+	"task" =>
+		# task name
+		if(n != 2)
+			return "no task label given";
+		iconify(clientid, hd tl args);
+	"untask" or
+	"unhide" =>
+		deiconify(clientid);
+	* =>
+		return "unknown request";
+	}
+	return nil;
+}
+
+iconify(id, label: string)
+{
+	label = condenselabel(label);
+	e := tk->cmd(tbtop, "button .toolbar." +id+" -command {send task "+id+"} -takefocus 0");
+	cmd(tbtop, ".toolbar." +id+" configure -text '" + label);
+	if(e[0] != '!')
+		cmd(tbtop, "pack .toolbar."+id+" -side left -fill y");
+	cmd(tbtop, "update");
+}
+
+deiconify(id: string)
+{
+	e := tk->cmd(tbtop, "destroy .toolbar."+id);
+	if(e == nil){
+		tkclient->wmctl(tbtop, sys->sprint("ctl %q untask", id));
+		tkclient->wmctl(tbtop, sys->sprint("ctl %q kbdfocus 1", id));
+	}
+	cmd(tbtop, "update");
+}
+
+layout(top: ref Tk->Toplevel)
+{
+	r := top.screenr;
+	h := 32;
+	if(r.dy() < 480)
+		h = tk->rect(top, ".b", Tk->Border|Tk->Required).dy();
+	cmd(top, ". configure -x " + string r.min.x +
+			" -y " + string (r.max.y - h) +
+			" -width " + string r.dx() +
+			" -height " + string h);
+	cmd(top, "update");
+	tkclient->onscreen(tbtop, "exact");
+}
+
+toolbar(ctxt: ref Draw->Context, startmenu: int,
+		exec, task: chan of string): ref Tk->Toplevel
+{
+	(tbtop, nil) = tkclient->toplevel(ctxt, nil, nil, Tkclient->Plain);
+	screenr = tbtop.screenr;
+
+	cmd(tbtop, "button .b -text {XXX}");
+	cmd(tbtop, "pack propagate . 0");
+
+	tk->namechan(tbtop, exec, "exec");
+	tk->namechan(tbtop, task, "task");
+	cmd(tbtop, "frame .toolbar");
+	if (startmenu) {
+		cmd(tbtop, "menubutton .toolbar.start -menu .m -borderwidth 0 -bitmap vitasmall.bit");
+		cmd(tbtop, "pack .toolbar.start -side left");
+	}
+	cmd(tbtop, "pack .toolbar -fill x");
+	cmd(tbtop, "menu .m");
+	return tbtop;
+}
+
+setup(shctxt: ref Context, finished: chan of int)
+{
+	ctxt := shctxt.copy(0);
+	ctxt.run(shell->stringlist2list("run"::"/lib/wmsetup"::nil), 0);
+	# if no items in menu, then create some.
+	if (tk->cmd(tbtop, ".m type 0")[0] == '!')
+		ctxt.run(shell->stringlist2list(defaultscript::nil), 0);
+	cmd(tbtop, "update");
+	finished <-= 1;
+}
+
+condenselabel(label: string): string
+{
+	if(len label > 15){
+		new := "";
+		l := 0;
+		while(len label > 15 && l < 3) {
+			new += label[0:15]+"\n";
+			label = label[15:];
+			for(v := 0; v < len label; v++)
+				if(label[v] != ' ')
+					break;
+			label = label[v:];
+			l++;
+		}
+		label = new + label;
+	}
+	return label;
+}
+
+initbuiltin(ctxt: ref Context, nil: Sh): string
+{
+	if (tbtop == nil) {
+		sys = load Sys Sys->PATH;
+		sys->fprint(sys->fildes(2), "wm: cannot load wm as a builtin\n");
+		raise "fail:usage";
+	}
+	ctxt.addbuiltin("menu", myselfbuiltin);
+	ctxt.addbuiltin("delmenu", myselfbuiltin);
+	ctxt.addbuiltin("error", myselfbuiltin);
+	return nil;
+}
+
+whatis(nil: ref Sh->Context, nil: Sh, nil: string, nil: int): string
+{
+	return nil;
+}
+
+runbuiltin(c: ref Context, sh: Sh,
+			cmd: list of ref Listnode, nil: int): string
+{
+	case (hd cmd).word {
+	"menu" =>	return builtin_menu(c, sh, cmd);
+	"delmenu" =>	return builtin_delmenu(c, sh, cmd);
+	}
+	return nil;
+}
+
+runsbuiltin(nil: ref Context, nil: Sh,
+			nil: list of ref Listnode): list of ref Listnode
+{
+	return nil;
+}
+
+stderr(): ref Sys->FD
+{
+	return sys->fildes(2);
+}
+
+word(ln: ref Listnode): string
+{
+	if (ln.word != nil)
+		return ln.word;
+	if (ln.cmd != nil)
+		return shell->cmd2string(ln.cmd);
+	return nil;
+}
+
+menupath(title: string): string
+{
+	mpath := ".m."+title;
+	for(j := 0; j < len mpath; j++)
+		if(mpath[j] == ' ')
+			mpath[j] = '_';
+	return mpath;
+}
+
+builtin_menu(nil: ref Context, nil: Sh, argv: list of ref Listnode): string
+{
+	n := len argv;
+	if (n < 3 || n > 4) {
+		sys->fprint(stderr(), "usage: menu topmenu [ secondmenu ] command\n");
+		raise "fail:usage";
+	}
+	primary := (hd tl argv).word;
+	argv = tl tl argv;
+
+	if (n == 3) {
+		w := word(hd argv);
+		if (len w == 0)
+			cmd(tbtop, ".m insert 0 separator");
+		else
+			cmd(tbtop, ".m insert 0 command -label " + tk->quote(primary) +
+				" -command {send exec " + w + "}");
+	} else {
+		secondary := (hd argv).word;
+		argv = tl argv;
+
+		mpath := menupath(primary);
+		e := tk->cmd(tbtop, mpath+" cget -width");
+		if(e[0] == '!') {
+			cmd(tbtop, "menu "+mpath);
+			cmd(tbtop, ".m insert 0 cascade -label "+tk->quote(primary)+" -menu "+mpath);
+		}
+		w := word(hd argv);
+		if (len w == 0)
+			cmd(tbtop, mpath + " insert 0 separator");
+		else
+			cmd(tbtop, mpath+" insert 0 command -label "+tk->quote(secondary)+
+				" -command {send exec "+w+"}");
+	}
+	return nil;
+}
+
+builtin_delmenu(nil: ref Context, nil: Sh, nil: list of ref Listnode): string
+{
+	delmenu(".m");
+	cmd(tbtop, "menu .m");
+	return nil;
+}
+
+delmenu(m: string)
+{
+	for (i := int cmd(tbtop, m + " index end"); i >= 0; i--)
+		if (cmd(tbtop, m + " type " + string i) == "cascade")
+			delmenu(cmd(tbtop, m + " entrycget " + string i + " -menu"));
+	cmd(tbtop, "destroy " + m);
+}
+
+getself(): Shellbuiltin
+{
+	return myselfbuiltin;
+}
+
+cmd(top: ref Tk->Toplevel, c: string): string
+{
+	s := tk->cmd(top, c);
+	if (s != nil && s[0] == '!')
+		sys->fprint(stderr(), "tk error on %#q: %s\n", c, s);
+	return s;
+}
+
+kill(pid: int, note: string): int
+{
+	fd := sys->open("/prog/"+string pid+"/ctl", Sys->OWRITE);
+	if(fd == nil || sys->fprint(fd, "%s", note) < 0)
+		return -1;
+	return 0;
+}
+
+fatal(s: string)
+{
+	sys->fprint(sys->fildes(2), "wm: %s\n", s);
+	kill(sys->pctl(0, nil), "killgrp");
+	raise "fail:error";
+}
+
+bufferproc(in, out: chan of string)
+{
+	h, t: list of string;
+	dummyout := chan of string;
+	for(;;){
+		outc := dummyout;
+		s: string;
+		if(h != nil || t != nil){
+			outc = out;
+			if(h == nil)
+				for(; t != nil; t = tl t)
+					h = hd t :: h;
+			s = hd h;
+		}
+		alt{
+		x := <-in =>
+			t = x :: t;
+		outc <-= s =>
+			h = tl h;
+		}
+	}
+}
+
+con_cfg := array[] of
+{
+	"frame .cons",
+	"scrollbar .cons.scroll -command {.cons.t yview}",
+	"text .cons.t -width 60w -height 15w -bg white "+
+		"-fg black -font /fonts/misc/latin1.6x13.font "+
+		"-yscrollcommand {.cons.scroll set}",
+	"pack .cons.scroll -side left -fill y",
+	"pack .cons.t -fill both -expand 1",
+	"pack .cons -expand 1 -fill both",
+	"pack propagate . 0",
+	"update"
+};
+nlines := 0;		# transcript length
+
+consoleproc(ctxt: ref Draw->Context, sync: chan of string)
+{
+	iostdout := sys->file2chan("/chan", "wmstdout");
+	if(iostdout == nil){
+		sync <-= sys->sprint("cannot make /chan/wmstdout: %r");
+		return;
+	}
+	iostderr := sys->file2chan("/chan", "wmstderr");
+	if(iostderr == nil){
+		sync <-= sys->sprint("cannot make /chan/wmstdout: %r");
+		return;
+	}
+
+	sync <-= nil;
+
+	(top, titlectl) := tkclient->toplevel(ctxt, "", "Log", tkclient->Appl); 
+	for(i := 0; i < len con_cfg; i++)
+		cmd(top, con_cfg[i]);
+
+	r := tk->rect(top, ".", Tk->Border|Tk->Required);
+	cmd(top, ". configure -x " + string ((top.screenr.dx() - r.dx()) / 2 + top.screenr.min.x) +
+				" -y " + string (r.dy() / 3 + top.screenr.min.y));
+
+	tkclient->startinput(top, "ptr"::"kbd"::nil);
+	tkclient->onscreen(top, "onscreen");
+	tkclient->wmctl(top, "task");
+
+	for(;;) alt {
+	c := <-titlectl or
+	c = <-top.wreq or
+	c = <-top.ctxt.ctl =>
+		if(c == "exit")
+			c = "task";
+		tkclient->wmctl(top, c);
+	c := <-top.ctxt.kbd =>
+		tk->keyboard(top, c);
+	p := <-top.ctxt.ptr =>
+		tk->pointer(top, *p);
+	(off, nbytes, fid, rc) := <-iostdout.read =>
+		if(rc == nil)
+			break;
+		alt{
+		rc <-= (nil, "inappropriate use of file") =>;
+		* =>;
+		}
+	(off, nbytes, fid, rc) := <-iostderr.read =>
+		if(rc == nil)
+			break;
+		alt{
+		rc <-= (nil, "inappropriate use of file") =>;
+		* =>;
+		}
+	(off, data, fid, wc) := <-iostdout.write =>
+		conout(top, data, wc);
+	(off, data, fid, wc) := <-iostderr.write =>
+		conout(top, data, wc);
+		if(wc != nil)
+			tkclient->wmctl(top, "untask");
+	}
+}
+
+conout(top: ref Tk->Toplevel, data: array of byte, wc: Sys->Rwrite)
+{
+	if(wc == nil)
+		return;
+
+	s := string data;
+	tk->cmd(top, ".cons.t insert end '"+ s);
+	alt{
+	wc <-= (len data, nil) =>;
+	* =>;
+	}
+
+	for(i := 0; i < len s; i++)
+		if(s[i] == '\n')
+			nlines++;
+	if(nlines > MAXCONSOLELINES){
+		cmd(top, ".cons.t delete 1.0 " + string (nlines/4) + ".0; update");
+		nlines -= nlines / 4;
+	}
+
+	tk->cmd(top, ".cons.t see end; update");
+}