20060303a

1 files changed, 624 insertions, 0 deletions

diff --git a/appl/lib/selectfile.b b/appl/lib/selectfile.b
new file mode 100644
index 00000000..15c55766
--- /dev/null
+++ b/appl/lib/selectfile.b
@@ -0,0 +1,624 @@
+implement Selectfile;
+
+include "sys.m";
+	sys: Sys;
+	Dir: import sys;
+
+include "draw.m";
+	draw: Draw;
+	Screen, Rect, Point: import draw;
+
+include "tk.m";
+	tk: Tk;
+
+include "string.m";
+	str: String;
+
+include "tkclient.m";
+	tkclient: Tkclient;
+
+include "workdir.m";
+
+include "readdir.m";
+	readdir: Readdir;
+
+include "filepat.m";
+	filepat: Filepat;
+
+include "selectfile.m";
+
+Browser: adt {
+	top:		ref Tk->Toplevel;
+	ncols:	int;
+	colwidth:	int;
+	w:		string;
+	init:		fn(top: ref Tk->Toplevel, w: string, colwidth: string): (ref Browser, chan of string);
+
+	addcol:	fn(c: self ref Browser, t: string, d: array of string);
+	delete:	fn(c: self ref Browser, colno: int);
+	selection:	fn(c: self ref Browser, cno: int): string;
+	select:	fn(b: self ref Browser, cno: int, e: string);
+	entries:	fn(b: self ref Browser, cno: int): array of string;
+	resize:	fn(c: self ref Browser);
+};
+
+BState: adt {
+	b:			ref Browser;
+	bpath:		string;		# path currently displayed in browser
+	epath:		string;		# path entered by user
+	dirfetchpid:	int;
+	dirfetchpath:	string;
+};
+
+filename_config := array[] of {
+	"entry .e -bg white",
+	"frame .pf",
+	"entry .pf.e",
+	"label .pf.t -text {Filter:}",
+	"entry .pats",
+	"bind .e <Key> +{send ech key}",
+	"bind .e <Key-\n> {send ech enter}",
+	"bind .e {<Key-\t>} {send ech expand}",
+	"bind .pf.e <Key-\n> {send ech setpat}",
+	"bind . <Configure> {send ech config}",
+	"pack .b -side top -fill both -expand 1",
+	"pack .pf.t -side left",
+	"pack .pf.e -side top -fill x",
+	"pack .pf -side top -fill x",
+	"pack .e -side top -fill x",
+	"pack propagate . 0",
+};
+
+debugging := 0;
+STEP: con 20;
+
+init(): string
+{
+	sys = load Sys Sys->PATH;
+	draw = load Draw Draw->PATH;
+	tk = load Tk Tk->PATH;
+	tkclient = load Tkclient Tkclient->PATH;
+	tkclient->init();
+	str = load String String->PATH;
+	readdir = load Readdir Readdir->PATH;
+	filepat = load Filepat Filepat->PATH;
+	return nil;
+}
+
+filename(ctxt: ref Draw->Context, parent: ref Draw->Image,
+		title: string,
+		pats: list of string,
+		dir: string): string
+{
+	patstr: string;
+
+	if (dir == nil || dir == ".") {
+		wd := load Workdir Workdir->PATH;
+		if ((dir = wd->init()) != nil) {
+			(ok, nil) := sys->stat(dir);
+			if (ok == -1)
+				dir = nil;
+		}
+		wd = nil;
+	}
+	if (dir == nil)
+		dir = "/";
+	(pats, patstr) = makepats(pats);
+	where := localgeom(parent);
+	if (title == nil)
+		title = "Open";
+	(top, wch) := tkclient->toplevel(ctxt, where+" -bd 1", # -font /fonts/misc/latin1.6x13.font", 
+			title, Tkclient->Popup|Tkclient->Resize|Tkclient->OK);
+	(b, colch) := Browser.init(top, ".b", "16w");
+	entrych := chan of string;
+	tk->namechan(top, entrych, "ech");
+	tkcmds(top, filename_config);
+	cmd(top, ". configure -width " + string (b.colwidth * 3) + " -height 20h");
+	cmd(top, ".e insert 0 '" + dir);
+	cmd(top, ".pf.e insert 0 '" + patstr);
+	s := ref BState(b, nil, dir, -1, nil);
+	s.b.resize();
+	dfch := chan of (string, array of ref Sys->Dir);
+	if (parent == nil)
+		centre(top);
+	tkclient->onscreen(top, nil);
+	tkclient->startinput(top, "kbd" :: "ptr" :: nil);
+loop: for (;;) {
+		if (debugging) {
+			sys->print("filename: before sync, bpath: '%s'; epath: '%s'\n",
+				s.bpath, s.epath);
+		}
+		bsync(s, dfch, pats);
+		if (debugging) {
+			sys->print("filename: after sync, bpath: '%s'; epath: '%s'", s.bpath, s.epath);
+			if (s.dirfetchpid == -1)
+				sys->print("\n");
+			else
+				sys->print("; fetching '%s' (pid %d)\n", s.dirfetchpath, s.dirfetchpid);
+		}
+		cmd(top, "focus .e");
+		cmd(top, "update");
+		alt {
+		c := <-top.ctxt.kbd =>
+			tk->keyboard(top, c);
+		p := <-top.ctxt.ptr =>
+			tk->pointer(top, *p);
+		c := <-top.ctxt.ctl or
+		c = <-top.wreq =>
+			tkclient->wmctl(top, c);
+		c := <-colch =>
+			double := c[0] == 'd';
+			c = c[1:];
+			(bpath, nbpath, elem) := (s.bpath, "", "");
+			for (cno := 0; cno <= int c; cno++) {
+				(elem, bpath) = nextelem(bpath);
+				nbpath = pathcat(nbpath, elem);
+			}
+			nsel := s.b.selection(int c);
+			if (nsel != nil)
+				nbpath = pathcat(nbpath, nsel);
+			s.epath = nbpath;
+			cmd(top, ".e delete 0 end");
+			cmd(top, ".e insert 0 '" + s.epath);
+			if (double)
+				break loop;
+		c := <-entrych =>
+			case c {
+			"enter" =>
+				break loop;
+			"config" =>
+				s.b.resize();
+			"key" =>
+				s.epath = cmdget(top, ".e get");
+			"expand" =>
+				cmd(top, ".e delete 0 end");
+				cmd(top, ".e insert 0 '" + s.bpath);
+				s.epath = s.bpath;
+			"setpat" =>
+				patstr = cmdget(top, ".pf.e get");
+				if (patstr == "  debug  ")
+					debugging = !debugging;
+				else {
+					(nil, pats) = sys->tokenize(patstr, " ");
+					s.b.delete(0);
+					s.bpath = nil;
+				}
+			}
+		c := <-wch =>
+			if (c == "ok")
+				break loop;
+			if (c == "exit") {
+				s.epath = nil;
+				break loop;
+			}
+			tkclient->wmctl(top, c);
+		(t, d) := <-dfch =>
+			ds := array[len d] of string;
+			for (i := 0; i < len d; i++) {
+				n := d[i].name;
+				if ((d[i].mode & Sys->DMDIR) != 0)
+					n[len n] = '/';
+				ds[i] = n;
+			}
+			s.b.addcol(t, ds);
+			ds = nil;
+			d = nil;
+			s.bpath = s.dirfetchpath;
+			s.dirfetchpid = -1;
+		}
+	}
+	if (s.dirfetchpid != -1)
+		kill(s.dirfetchpid);
+	return s.epath;
+}
+
+bsync(s: ref BState, dfch: chan of (string, array of ref Sys->Dir), pats: list of string)
+{
+	(epath, bpath) := (s.epath, s.bpath);
+	cno := 0;
+	prefix, e1, e2: string = "";
+
+	# find maximal prefix of epath and bpath.
+	for (;;) {
+		p1, p2: string;
+		(e1, p1) = nextelem(epath);
+		(e2, p2) = nextelem(bpath);
+		if (e1 == nil || e1 != e2)
+			break;
+		prefix = pathcat(prefix, e1);
+		(epath, bpath) = (p1, p2);
+		cno++;
+	}
+
+	if (epath == nil) {
+		if (bpath != nil) {
+			s.b.delete(cno);
+			s.b.select(cno - 1, nil);
+			s.bpath = prefix;
+		}
+		return;
+	}
+
+	# if the paths have no prefix in common then we're starting
+	# at a different root - don't do anything until
+	# we know we have at least one full element.
+	# even then, if it's not a directory, we have to ignore it.
+	if (cno == 0 && islastelem(epath))
+		return;
+
+	if (e1 != nil && islastelem(epath)) {
+		# find first prefix-matching entry.
+		match := "";
+		for ((i, ents) := (0, s.b.entries(cno - 1)); i < len ents; i++) {
+			m := ents[i];
+			if (len m >= len e1 && m[0:len e1] == e1) {
+				match = deslash(m);
+				break;
+			}
+		}
+		if (match != nil) {
+			if (match == e2 && islastelem(bpath))
+				return;
+
+			epath = pathcat(match,  epath[len e1:]);
+			e1 = match;
+			if (e1 == e2)
+				cno++;
+		} else {
+			s.b.delete(cno);
+			s.bpath = prefix;
+			return;
+		}
+	}
+
+	s.b.delete(cno);
+	s.b.select(cno - 1, e1);
+	np := pathcat(prefix, e1);
+	if (s.dirfetchpid != -1) {
+		if (np == s.dirfetchpath)
+			return;
+		kill(s.dirfetchpid);
+		s.dirfetchpid = -1;
+	}
+	(ok, dir) := sys->stat(np);
+	if (ok != -1 && (dir.mode & Sys->DMDIR) != 0) {
+		sync := chan of int;
+		spawn dirfetch(np, e1, sync, dfch, pats);
+		s.dirfetchpid = <-sync;
+		s.dirfetchpath = np;
+	} else if (ok != -1)
+		s.bpath = np;
+	else
+		s.bpath = prefix;
+}
+
+dirfetch(p: string, t: string, sync: chan of int,
+		dfch: chan of (string, array of ref Sys->Dir),
+		pats: list of string)
+{
+	sync <-= sys->pctl(0, nil);
+	(a, e) := readdir->init(p, Readdir->NAME|Readdir->COMPACT);
+	if (e != -1) {
+		j := 0;
+		for (i := 0; i < len a; i++) {
+			pl := pats;
+			if ((a[i].mode & Sys->DMDIR) == 0) {
+				for (; pl != nil; pl = tl pl)
+					if (filepat->match(hd pl, a[i].name))
+						break;
+			}
+			if (pl != nil || pats == nil)
+				a[j++] = a[i];
+		}
+		a = a[0:j];
+	}
+	dfch <-= (t, a);
+}
+
+dist(top: ref Tk->Toplevel, s: string): int
+{
+	cmd(top, "frame .xxxx -width " + s);
+	d := int cmd(top, ".xxxx cget -width");
+	cmd(top, "destroy .xxxx");
+	return d;
+}
+	
+Browser.init(top: ref Tk->Toplevel, w: string, colwidth: string): (ref Browser, chan of string)
+{
+	b := ref Browser;
+	b.top = top;
+	b.ncols = 0;
+	b.colwidth = dist(top, colwidth);
+	b.w = w;
+	cmd(b.top, "frame " + b.w);
+	cmd(b.top, "canvas " + b.w + ".c -width 0 -height 0 -xscrollcommand {" + b.w + ".s set}");
+	cmd(b.top, "frame " + b.w + ".c.f -bd 0");
+	cmd(b.top, "pack propagate " + b.w + ".c.f 0");
+	cmd(b.top, b.w + ".c create window 0 0 -tags win -window " + b.w + ".c.f -anchor nw");
+	cmd(b.top, "scrollbar "+b.w+".s -command {"+b.w+".c xview} -orient horizontal");
+	cmd(b.top, "bind "+b.w+".c <Configure> {"+b.w+".c itemconfigure win -height ["+b.w+".c cget -actheight]}");
+	cmd(b.top, "pack "+b.w+".c -side top -fill both -expand 1");
+	cmd(b.top, "pack "+b.w+".s -side top -fill x");
+	ch := chan of string;
+	tk->namechan(b.top, ch, "colch");
+	return (b, ch);
+}
+
+xview(top: ref Tk->Toplevel, w: string): (real, real)
+{
+	s := tk->cmd(top, w + " xview");
+	if (s != nil && s[0] != '!') {
+		(n, v) := sys->tokenize(s, " ");
+		if (n == 2)
+			return (real hd v, real hd tl v);
+	}
+	return (0.0, 0.0);
+}
+
+setscrollregion(b: ref Browser)
+{
+	(w, h) := (b.colwidth * (b.ncols + 1), int cmd(b.top, b.w + ".c cget -actheight"));
+	cmd(b.top, b.w+".c.f configure -width " + string w + " -height " + string h);
+#	w := int cmd(b.top, b.w+".c.f cget -actwidth");
+#	w += int cmd(b.top, b.w+".c cget -actwidth") - b.colwidth;
+#	h := int cmd(b.top, b.w+".c.f cget -actheight");
+	if (w > 0 && h > 0)
+		cmd(b.top, b.w + ".c configure -scrollregion {0 0 " + string w + " " + string h + "}");
+	(start, end) := xview(b.top, b.w+".c");
+	if (end > 1.0)
+		cmd(b.top, b.w+".c xview scroll left 0 units");
+}
+
+Browser.addcol(b: self ref Browser, title: string, d: array of string)
+{
+	ncol := string b.ncols++;
+
+	f := b.w + ".c.f.d" + ncol;
+	cmd(b.top, "frame " + f + " -bg green -width " + string b.colwidth);
+
+	t := f + ".t";
+	cmd(b.top, "label " + t + " -text " + tk->quote(title) + " -bg black -fg white");
+
+	sb := f + ".s";
+	lb := f + ".l";
+	cmd(b.top, "scrollbar " + sb +
+		" -command {" + lb + " yview}");
+
+	cmd(b.top, "listbox " + lb +
+		" -selectmode browse" +
+		" -yscrollcommand {" + sb + " set}" +
+		" -bd 2");
+
+	cmd(b.top, "bind " + lb + " <ButtonRelease-1> +{send colch s " + ncol + "}");
+	cmd(b.top, "bind " + lb + " <Double-Button-1> +{send colch d " + ncol + "}");
+	cmd(b.top, "pack propagate " + f + " 0");
+	cmd(b.top, "pack " + t + " -side top -fill x");
+	cmd(b.top, "pack " + sb + " -side left -fill y");
+	cmd(b.top, "pack " + lb + " -side left -fill both -expand 1");
+	cmd(b.top, "pack " + f + " -side left -fill y");
+	for (i := 0; i < len d; i++)
+		cmd(b.top, lb + " insert end '" + d[i]);
+	setscrollregion(b);
+	seecol(b, b.ncols - 1);
+}
+
+Browser.resize(b: self ref Browser)
+{
+	if (b.ncols == 0)
+		return;
+	setscrollregion(b);
+}
+
+seecol(b: ref Browser, cno: int)
+{
+	w := b.w + ".c.f.d" + string cno;
+	min := int cmd(b.top, w + " cget -actx");
+	max := min + int cmd(b.top, w + " cget -actwidth") +
+			2 * int cmd(b.top, w + " cget -bd");
+	min = int cmd(b.top, b.w+".c canvasx " + string min);
+	max = int cmd(b.top, b.w +".c canvasx " + string max);
+
+	# see first the right edge; then the left edge, to ensure
+	# that the start of a column is visible, even if the window
+	# is narrower than one column.
+	cmd(b.top, b.w + ".c see " + string max + " 0");
+	cmd(b.top, b.w + ".c see " + string min + " 0");
+}
+
+Browser.delete(b: self ref Browser, colno: int)
+{
+	while (b.ncols > colno)
+		cmd(b.top, "destroy " + b.w+".c.f.d" + string --b.ncols);
+	setscrollregion(b);
+}
+
+Browser.selection(b: self ref Browser, cno: int): string
+{
+	if (cno >= b.ncols || cno < 0)
+		return nil;
+	l := b.w+".c.f.d" + string cno + ".l";
+	sel := cmd(b.top, l + " curselection");
+	if (sel == nil)
+		return nil;
+	return cmdget(b.top, l + " get " + sel);
+}
+
+Browser.select(b: self ref Browser, cno: int, e: string)
+{
+	if (cno < 0 || cno >= b.ncols)
+		return;
+	l := b.w+".c.f.d" + string cno + ".l";
+	cmd(b.top, l + " selection clear 0 end");
+	if (e == nil)
+		return;
+	ents := b.entries(cno);
+	for (i := 0; i < len ents; i++) {
+		if (deslash(ents[i]) == e) {
+			cmd(b.top, l + " selection set " + string i);
+			cmd(b.top, l + " see " + string i);
+			return;
+		}
+	}
+}
+
+Browser.entries(b: self ref Browser, cno: int): array of string
+{
+	if (cno < 0 || cno >= b.ncols)
+		return nil;
+	l := b.w+".c.f.d" + string cno + ".l";
+	nent := int cmd(b.top, l + " index end") + 1;
+	ents := array[nent] of string;
+	for (i := 0; i < len ents; i++)
+		ents[i] = cmdget(b.top, l + " get " + string i);
+	return ents;
+}
+
+# turn each pattern of the form "*.b (Limbo files)" into "*.b".
+# ignore '*' as it's a hangover from a past age.
+makepats(pats: list of string): (list of string, string)
+{
+	np: list of string;
+	s := "";
+	for (; pats != nil; pats = tl pats) {
+		p := hd pats;
+		for (i := 0; i < len p; i++)
+			if (p[i] == ' ')
+				break;
+		pat := p[0:i];
+		if (p != "*") {
+			np = p[0:i] :: np;
+			s += hd np;
+			if (tl pats != nil)
+				s[len s] = ' ';
+		}
+	}
+	return (np, s);
+}
+
+widgetwidth(top: ref Tk->Toplevel, w: string): int
+{
+	return int cmd(top, w + " cget -width") + 2 * int cmd(top, w + " cget -bd");
+}
+
+skipslash(path: string): string
+{
+	for (i := 0; i < len path; i++)
+		if (path[i] != '/')
+			return path[i:];
+	return nil;
+}
+
+nextelem(path: string): (string, string)
+{
+	if (path == nil)
+		return (nil, nil);
+	if (path[0] == '/')
+		return ("/", skipslash(path));
+	for (i := 0; i < len path; i++)
+		if (path[i] == '/')
+			break;
+	return (path[0:i], skipslash(path[i:]));
+}
+
+islastelem(path: string): int
+{
+	for (i := 0; i < len path; i++)
+		if (path[i] == '/')
+			return 0;
+	return 1;
+}
+
+pathcat(path, elem: string): string
+{
+	if (path != nil && path[len path - 1] != '/')
+		path[len path] = '/';
+	return path + elem;
+}
+
+# remove a possible trailing slash
+deslash(s: string): string
+{
+	if (len s > 0 && s[len s - 1] == '/')
+		s = s[0:len s - 1];
+	return s;
+}
+
+#
+# find upper left corner for subsidiary child window (always at constant
+# position relative to parent)
+#
+localgeom(im: ref Draw->Image): string
+{
+	if (im == nil)
+		return nil;
+
+	return sys->sprint("-x %d -y %d", im.r.min.x+STEP, im.r.min.y+STEP);
+}
+
+centre(t: ref Tk->Toplevel)
+{
+	org: Point;
+	org.x = t.screenr.dx() / 2 - int cmd(t, ". cget -width") / 2;
+	org.y = t.screenr.dy() / 3 - int cmd(t, ". cget -height") / 2;
+	if (org.y < 0)
+		org.y = 0;
+	cmd(t, ". configure -x " + string org.x + " -y " + string org.y);
+}
+
+tkcmds(top: ref Tk->Toplevel, a: array of string)
+{
+	n := len a;
+	for(i := 0; i < n; i++)
+		tk->cmd(top, a[i]);
+}
+
+topopts := array[] of {
+	"font"
+#	, "bd"			# Wait for someone to ask for these
+#	, "relief"		# Note: colors aren't inherited, it seems
+};
+
+opts(top: ref Tk->Toplevel) : string
+{
+	if (top == nil)
+		return nil;
+	opts := "";
+	for ( i := 0; i < len topopts; i++ ) {
+		cfg := tk->cmd(top, ". cget " + topopts[i]);
+		if ( cfg != "" && cfg[0] != '!' )
+			opts += " -" + topopts[i] + " " + tk->quote(cfg);
+	}
+	return opts;
+}
+ 
+kill(pid: int): int
+{
+	fd := sys->open("/prog/"+string pid+"/ctl", Sys->OWRITE);
+	if (fd == nil)
+		return -1;
+	if (sys->write(fd, array of byte "kill", 4) != 4)
+		return -1;
+	return 0;
+}
+Showtk: con 0;
+
+cmd(top: ref Tk->Toplevel, s: string): string
+{
+	if (Showtk)
+		sys->print("%s\n", s);
+	e := tk->cmd(top, s);
+	if (e != nil && e[0] == '!')
+		sys->fprint(sys->fildes(2), "tkclient: tk error %s on '%s'\n", e, s);
+	return e;
+}
+
+cmdget(top: ref Tk->Toplevel, s: string): string
+{
+	if (Showtk)
+		sys->print("%s\n", s);
+	tk->cmd(top, "variable lasterror");
+	e := tk->cmd(top, s);
+	lerr := tk->cmd(top, "variable lasterror");
+	if (lerr != nil) sys->fprint(sys->fildes(2), "tkclient: tk error %s on '%s'\n", e, s);
+	return e;
+}