ref: a411870ee4640241e3c494367d922847da84f972
dir: purgatorio/appl/lib/selectfile.b
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;
}