20060303a

1 files changed, 590 insertions, 0 deletions

diff --git a/appl/lib/wmlib.b b/appl/lib/wmlib.b
new file mode 100644
index 00000000..804d532e
--- /dev/null
+++ b/appl/lib/wmlib.b
@@ -0,0 +1,590 @@
+implement Wmlib;
+
+#
+# Copyright © 2003 Vita Nuova Holdings Limited
+#
+
+# basic window manager functionality, used by
+# tkclient and wmclient to create more usable functionality.
+
+include "sys.m";
+	sys: Sys;
+include "draw.m";
+	draw: Draw;
+	Display, Image, Screen, Rect, Point, Pointer, Wmcontext, Context: import draw;
+include "wmsrv.m";
+include "wmlib.m";
+
+Client: adt{
+	ptrpid:	int;
+	kbdpid:	int;
+	ctlpid:	int;
+	req:		chan of (array of byte, Sys->Rwrite);
+	dir:		string;
+	ctlfd:		ref Sys->FD;
+	winfd:	ref Sys->FD;
+};
+
+DEVWM: con "/mnt/wm";
+Ptrsize: con 1+4*12;		# 'm' plus 4 12-byte decimal integers
+
+kbdstarted: int;
+ptrstarted: int;
+wptr: chan of Point;		# set mouse position (only if we've opened /dev/pointer directly)
+cswitch: chan of (string, int, chan of string);	# switch cursor images (as for wptr)
+
+init()
+{
+	sys = load Sys Sys->PATH;
+	draw = load Draw Draw->PATH;
+}
+
+#	(_screen, dispi) := ctxt.display.getwindow("/dev/winname", nil, nil, 1); XXX corrupts heap... fix it!
+
+makedrawcontext(): ref Draw->Context
+{
+	display := Display.allocate(nil);
+	if(display == nil){
+		sys->fprint(sys->fildes(2), "wmlib: can't allocate Display: %r\n");
+		raise "fail:no display";
+	}
+	return ref Draw->Context(display, nil, nil);
+}
+
+importdrawcontext(devdraw, mntwm: string): (ref Draw->Context, string)
+{
+	if(mntwm == nil)
+		mntwm = "/mnt/wm";
+
+	display := Display.allocate(devdraw);
+	if(display == nil)
+		return (nil, sys->sprint("cannot allocate display: %r"));
+	(ok, nil) := sys->stat(mntwm + "/clone");
+	if(ok == -1)
+		return (nil, "cannot find wm namespace");
+	wc := chan of (ref Draw->Context, string);
+	spawn wmproxy(display, mntwm, wc);
+	return <-wc;
+}
+
+# XXX we have no way of knowing when this process should go away...
+# perhaps a Draw->Context should hold a file descriptor
+# so that we do.
+wmproxy(display: ref Display, dir: string, wc: chan of (ref Draw->Context, string))
+{
+	wmsrv := load Wmsrv Wmsrv->PATH;
+	if(wmsrv == nil){
+		wc <-= (nil, sys->sprint("cannot load %s: %r", Wmsrv->PATH));
+		return;
+	}
+	sys->pctl(Sys->NEWFD, 1 :: 2 :: nil);
+
+	(wm, join, req) := wmsrv->init();
+	if(wm == nil){
+		wc <-= (nil, sys->sprint("%r"));
+		return;
+	}
+	wc <-= (ref Draw->Context(display, nil, wm), nil);
+
+	clients: array of ref Client;
+	for(;;) alt{
+	(sc, rc) := <-join =>
+		sync := chan of (ref Client, string);
+		spawn clientproc(display, sc, dir, sync);
+		(c, err) := <-sync;
+		rc <-= err;
+		if(c != nil){
+			if(sc.id >= len clients)
+				clients = (array[sc.id + 1] of ref Client)[0:] = clients;
+			clients[sc.id] = c;
+		}
+	(sc, data, rc) := <-req =>
+		clients[sc.id].req <-= (data, rc);
+		if(rc == nil)
+			clients[sc.id] = nil;
+	}
+}
+
+zclient: Client;
+clientproc(display: ref Display, sc: ref Wmsrv->Client, dir: string, rc: chan of (ref Client, string))
+{
+	ctlfd := sys->open(dir + "/clone", Sys->ORDWR);
+	if(ctlfd == nil){
+		rc <-= (nil, sys->sprint("cannot open %s/clone: %r", dir));
+		return;
+	}
+	buf := array[20] of byte;
+	n := sys->read(ctlfd, buf, len buf);
+	if(n <= 0){
+		rc <-= (nil, "cannot read ctl id");
+		return;
+	}
+	sys->fprint(ctlfd, "fixedorigin");
+	dir += "/" + string buf[0:n];
+	c := ref zclient;
+	c.req = chan of (array of byte, Sys->Rwrite);
+	c.dir = dir;
+	c.ctlfd = ctlfd;
+	if ((c.winfd = sys->open(dir + "/winname", Sys->OREAD)) == nil){
+		rc <-= (nil, sys->sprint("cannot open %s/winname: %r", dir));
+		return;
+	}
+	rc <-= (c, nil);
+
+	pidc := chan of int;
+	spawn ctlproc(pidc, ctlfd, sc.ctl);
+	c.ctlpid = <-pidc;
+	for(;;) {
+		(data, drc) := <-c.req;
+		if(drc == nil)
+			break;
+		err := handlerequest(display, c, sc, data);
+		n = len data;
+		if(err != nil)
+			n = -1;
+		alt{
+		drc <-= (n, err) =>;
+		* =>;
+		}
+	}
+	sc.stop <-= 1;
+	kill(c.kbdpid, "kill");
+	kill(c.ptrpid, "kill");
+	kill(c.ctlpid, "kill");
+	c.ctlfd = nil;
+	c.winfd = nil;
+}
+
+handlerequest(display: ref Display, c: ref Client, sc: ref Wmsrv->Client, data: array of byte): string
+{
+	req := string data;
+	if(req == nil)
+		return nil;
+	(w, e) := qword(req, 0);
+	case w {
+	"start" =>
+		(w, e) = qword(req, e);
+		case w {
+		"ptr" or
+		"mouse" =>
+			if(c.ptrpid == -1)
+				return "already started";
+			fd := sys->open(c.dir + "/pointer", Sys->OREAD);
+			if(fd == nil)
+				return sys->sprint("cannot open %s: %r", c.dir + "/pointer");
+			sync := chan of int;
+			spawn ptrproc(sync, fd, sc.ptr);
+			c.ptrpid = <-sync;
+			return nil;
+		"kbd" =>
+			if(c.kbdpid == -1)
+				return "already started";
+			sync := chan of (int, string);
+			spawn kbdproc(sync, c.dir + "/keyboard", sc.kbd);
+			(pid, err) := <-sync;
+			c.kbdpid = pid;
+			return err;
+		}
+	}
+
+	if(sys->write(c.ctlfd, data, len data) == -1)
+		return sys->sprint("%r");
+	if(req[0] == '!'){
+		buf := array[100] of byte;
+		n := sys->read(c.winfd, buf, len buf);
+		if(n <= 0)
+			return sys->sprint("read winname: %r");
+		name := string buf[0:n];
+		# XXX this is the dodgy bit...
+		i := display.namedimage(name);
+		if(i == nil)
+			return sys->sprint("cannot get image %#q: %r", name);
+		s := Screen.allocate(i, display.white, 0);
+		i = s.newwindow(i.r, Draw->Refnone, Draw->Nofill);
+		rc := chan of int;
+		sc.images <-= (nil, i, rc);
+		if(<-rc == -1)
+			return "image request already in progress";
+	}
+	return nil;
+}
+
+connect(ctxt: ref Context): ref Wmcontext
+{
+	# don't automatically make a new Draw->Context, 'cos the
+	# client should be aware that there's no wm so multiple
+	# windows won't work correctly.
+	# ... unless there's an exported wm available, of course!
+	if(ctxt == nil){
+		sys->fprint(sys->fildes(2), "wmlib: no draw context\n");
+		raise "fail:error";
+	}
+	if(ctxt.wm == nil){
+		wm := ref Wmcontext(
+			chan of int,
+			chan of ref Draw->Pointer,
+			chan of string,
+			nil,	# unused
+			chan of ref Image,
+			nil,
+			ctxt
+		);
+		return wm;
+	}
+	fd := sys->open("/chan/wmctl", Sys->ORDWR);
+	if(fd == nil){
+		sys->fprint(sys->fildes(2), "wmlib: cannot open /chan/wmctl: %r\n");
+		raise "fail:error";
+	}
+	buf := array[32] of byte;
+	n := sys->read(fd, buf, len buf);
+	if(n < 0){
+		sys->fprint(sys->fildes(2), "wmlib: cannot get window token: %r\n");
+		raise "fail:error";
+	}
+	reply := chan of (string, ref Wmcontext);
+	ctxt.wm <-= (string buf[0:n], reply);
+	(err, wm) := <-reply;
+	if(err != nil){
+		sys->fprint(sys->fildes(2), "wmlib: cannot connect: %s\n", err);
+		raise "fail:" + err;
+	}
+	wm.connfd = fd;
+	wm.ctxt = ctxt;
+	return wm;
+}
+
+startinput(wm: ref Wmcontext, devs: list of string): string
+{
+	for(; devs != nil; devs = tl devs)
+		wmctl(wm, "start " + hd devs);
+	return nil;
+}
+
+reshape(wm: ref Wmcontext, name: string, r: Draw->Rect, i: ref Draw->Image, how: string): ref Draw->Image
+{
+	if(name == nil)
+		return nil;
+	(nil, ni, err) := wmctl(wm, sys->sprint("!reshape %s -1 %d %d %d %d %s", name, r.min.x, r.min.y, r.max.x, r.max.y, how));
+	if(err == nil)
+		return ni;
+	return i;
+}
+
+#
+# wmctl implements the default window behaviour
+#
+wmctl(wm: ref Wmcontext, request: string): (string, ref Image, string)
+{
+	(w, e) := qword(request, 0);
+	case w {
+	"exit" =>
+		kill(sys->pctl(0, nil), "killgrp");
+		exit;
+	* =>
+		if(wm.connfd != nil){
+			# standard form for requests: if request starts with '!',
+			# then the next word gives the tag of the window that the
+			# request applies to, and a new image is provided.
+			if(sys->fprint(wm.connfd, "%s", request) == -1){
+				sys->fprint(sys->fildes(2), "wmlib: wm request '%s' failed\n", request);
+				return (nil, nil, sys->sprint("%r"));
+			}
+			if(request[0] == '!'){
+				i := <-wm.images;
+				if(i == nil)
+					i = <-wm.images;
+				return (qword(request, e).t0, i, nil);
+			}
+			return (nil, nil, nil);
+		}
+		# requests we can handle ourselves, if we have to.
+		case w{
+		"start" =>
+			(w, e) = qword(request, e);
+			case w{
+			"ptr" or
+			"mouse" =>
+				if(!ptrstarted){
+					fd := sys->open("/dev/pointer", Sys->ORDWR);
+					if(fd != nil)
+						wptr = chan of Point;
+					else
+						fd = sys->open("/dev/pointer", Sys->OREAD);
+					if(fd == nil)
+						return (nil, nil, sys->sprint("cannot open /dev/pointer: %r"));
+					cfd := sys->open("/dev/cursor", Sys->OWRITE);
+					if(cfd != nil)
+						cswitch = chan of (string, int, chan of string);
+					spawn wptrproc(fd, cfd);
+					sync := chan of int;
+					spawn ptrproc(sync, fd, wm.ptr);
+					<-sync;
+					ptrstarted = 1;
+				}
+			"kbd" =>
+				if(!kbdstarted){
+					sync := chan of (int, string);
+					spawn kbdproc(sync, "/dev/keyboard", wm.kbd);
+					(nil, err) := <-sync;
+					if(err != nil)
+						return (nil, nil, err);
+					spawn sendreq(wm.ctl, "haskbdfocus 1");
+					kbdstarted = 1;
+				}
+			* =>
+				return (nil, nil, "unknown input source");
+			}
+			return (nil, nil, nil);
+		"ptr" =>
+			if(wptr == nil)
+				return (nil, nil, "cannot change mouse position");
+			p: Point;
+			(w, e) = qword(request, e);
+			p.x = int w;
+			(w, e) = qword(request, e);
+			p.y = int w;
+			wptr <-= p;
+			return (nil, nil, nil);
+		"cursor" =>
+			if(cswitch == nil)
+				return (nil, nil, "cannot switch cursor");
+			cswitch <-= (request, e, reply := chan of string);
+			return (nil, nil, <-reply);
+		* =>
+			return (nil, nil, "unknown wmctl request");
+		}
+	}
+}
+
+sendreq(c: chan of string, s: string)
+{
+	c <-= s;
+}
+
+ctlproc(sync: chan of int, fd: ref Sys->FD, ctl: chan of string)
+{
+	sync <-= sys->pctl(0, nil);
+	buf := array[4096] of byte;
+	while((n := sys->read(fd, buf, len buf)) > 0)
+		ctl <-= string buf[0:n];
+}
+
+kbdproc(sync: chan of (int, string), f: string, keys: chan of int)
+{
+	sys->pctl(Sys->NEWFD, nil);
+	fd := sys->open(f, Sys->OREAD);
+	if(fd == nil){
+		sync <-= (-1, sys->sprint("cannot open /dev/keyboard: %r"));
+		return;
+	}
+	sync <-= (sys->pctl(0, nil), nil);
+	buf := array[12] of byte;
+	while((n := sys->read(fd, buf, len buf)) > 0){
+		s := string buf[0:n];
+		for(j := 0; j < len s; j++)
+			keys <-= int s[j];
+	}
+}
+
+wptrproc(pfd, cfd: ref Sys->FD)
+{
+	if(wptr == nil && cswitch == nil)
+		return;
+	if(wptr == nil)
+		wptr = chan of Point;
+	if(cswitch == nil)
+		cswitch = chan of (string, int, chan of string);
+	for(;;)alt{
+	p := <-wptr =>
+		sys->fprint(pfd, "m%11d %11d", p.x, p.y);
+	(c, start, reply) := <-cswitch =>
+		buf: array of byte;
+		if(start == len c){
+			buf = array[0] of byte;
+		}else{
+			hot, size: Point;
+			(w, e) := qword(c, start);
+			hot.x = int w;
+			(w, e) = qword(c, e);
+			hot.y = int w;
+			(w, e) = qword(c, e);
+			size.x = int w;
+			(w, e) = qword(c, e);
+			size.y = int w;
+			((d0, d1), nil) := splitqword(c, e);
+			nb := size.x/8*size.y;
+			if(d1 - d0 != nb * 2){
+				reply <-= "inconsistent cursor image data";
+				break;
+			}
+			buf = array[4*4 + nb] of byte;
+			bplong(buf, 0*4, hot.x);
+			bplong(buf, 1*4, hot.y);
+			bplong(buf, 2*4, size.x);
+			bplong(buf, 3*4, size.y);
+			j := 4*4;
+			for(i := d0; i < d1; i += 2)
+				buf[j++] = byte ((hexc(c[i]) << 4) | hexc(c[i+1]));
+		}
+		if(sys->write(cfd, buf, len buf) != len buf)
+			reply <-= sys->sprint("%r");
+		else
+			reply <-= nil;
+	}
+}
+
+hexc(c: int): int
+{
+	if(c >= '0' && c <= '9')
+		return c - '0';
+	if(c >= 'a' && c <= 'f')
+		return c - 'a' + 10;
+	if(c >= 'A' && c <= 'F')
+		return c - 'A' + 10;
+	return 0;
+}
+
+bplong(d: array of byte, o: int, x: int)
+{
+	d[o] = byte x;
+	d[o+1] = byte (x >> 8);
+	d[o+2] = byte (x >> 16);
+	d[o+3] = byte (x >> 24);
+}
+
+ptrproc(sync: chan of int, fd: ref Sys->FD, ptr: chan of ref Draw->Pointer)
+{
+	sync <-= sys->pctl(0, nil);
+
+	b:= array[Ptrsize] of byte;
+	while(sys->read(fd, b, len b) > 0){
+		p := bytes2ptr(b);
+		if(p != nil)
+			ptr <-= p;
+	}
+}
+
+bytes2ptr(b: array of byte): ref Pointer
+{
+	if(len b < Ptrsize || int b[0] != 'm')
+		return nil;
+	x := int string b[1:13];
+	y := int string b[13:25];
+	but := int string b[25:37];
+	msec := int string b[37:49];
+	return ref Pointer (but, (x, y), msec);
+}
+
+snarfbuf: string;		# at least we get *something* when there's no wm.
+
+snarfget(): string
+{
+	fd := sys->open("/chan/snarf", sys->OREAD);
+	if(fd == nil)
+		return snarfbuf;
+
+	buf := array[8192] of byte;
+	nr := 0;
+	while ((n := sys->read(fd, buf[nr:], len buf - nr)) > 0) {
+		nr += n;
+		if (nr == len buf) {
+			nbuf := array[len buf * 2] of byte;
+			nbuf[0:] = buf;
+			buf = nbuf;
+		}
+	}
+	return string buf[0:nr];
+}
+
+snarfput(buf: string)
+{
+	fd := sys->open("/chan/snarf", sys->OWRITE);
+	if(fd != nil)
+		sys->fprint(fd, "%s", buf);
+	else
+		snarfbuf = buf;
+}
+
+# return (qslice, end).
+# the slice has a leading quote if the word is quoted; it does not include the terminating quote.
+splitqword(s: string, start: int): ((int, int), int)
+{
+	for(; start < len s; start++)
+		if(s[start] != ' ')
+			break;
+	if(start >= len s)
+		return ((start, start), start);
+	i := start;
+	end := -1;
+	if(s[i] == '\''){
+		gotq := 0;
+		for(i++; i < len s; i++){
+			if(s[i] == '\''){
+				if(i + 1 >= len s || s[i + 1] != '\''){
+					end = i+1;
+					break;
+				}
+				i++;
+				gotq = 1;
+			}
+		}
+		if(!gotq && i > start+1)
+			start++;
+		if(end == -1)
+			end = i;
+	} else {
+		for(; i < len s; i++)
+			if(s[i] == ' ')
+				break;
+		end = i;
+	}
+	return ((start, i), end);
+}
+
+# unquote a string slice as returned by sliceqword.
+qslice(s: string, r: (int, int)): string
+{
+	if(r.t0 == r.t1)
+		return nil;
+	if(s[r.t0] != '\'')
+		return s[r.t0:r.t1];
+	t := "";
+	for(i := r.t0 + 1; i < r.t1; i++){
+		t[len t] = s[i];
+		if(s[i] == '\'')
+			i++;
+	}
+	return t;
+}
+
+qword(s: string, start: int): (string, int)
+{
+	(w, next) := splitqword(s, start);
+	return (qslice(s, w), next);
+}
+
+s2r(s: string, e: int): (Rect, int)
+{
+	r: Rect;
+	w: string;
+	(w, e) = qword(s, e);
+	r.min.x = int w;
+	(w, e) = qword(s, e);
+	r.min.y = int w;
+	(w, e) = qword(s, e);
+	r.max.x = int w;
+	(w, e) = qword(s, e);
+	r.max.y = int w;
+	return (r, e);
+}
+
+kill(pid: int, note: string): int
+{
+	fd := sys->open("#p/"+string pid+"/ctl", Sys->OWRITE);
+	if(fd == nil)		# dodgy failover
+		fd = sys->open("/prog/"+string pid+"/ctl", Sys->OWRITE);
+	if(fd == nil || sys->fprint(fd, "%s", note) < 0)
+		return -1;
+	return 0;
+}