ref: 1018d7a7091fd5e0433f501a3474cdc3fec322cc
dir: /appl/wm/debdata.b/
implement DebData; include "sys.m"; sys: Sys; include "draw.m"; include "string.m"; str: String; include "tk.m"; tk: Tk; include "tkclient.m"; tkclient: Tkclient; include "dialog.m"; include "selectfile.m"; include "debug.m"; debug: Debug; Sym, Src, Exp, Module: import debug; include "wmdeb.m"; debsrc: DebSrc; DatumSize: con 32; WalkWidth: con "20"; context: ref Draw->Context; tktop: ref Tk->Toplevel; var: ref Vars; vid: int; tkids := 1; # increasing id of tk pieces icondir : con "debug/"; tkconfig := array[] of { "frame .body -width 400 -height 400", "pack .Wm_t -side top -fill x", "pack .body -expand 1 -fill both", "pack propagate . 0", "update", "image create bitmap Itemopen -file "+icondir+ "open.bit -maskfile "+icondir+"open.mask", "image create bitmap Itemclosed -file "+icondir+ "closed.bit -maskfile "+icondir+"closed.mask", }; init(acontext: ref Draw->Context, geom: string, adebsrc: DebSrc, astr: String, adebug: Debug): (ref Tk->Toplevel, chan of string, chan of string) { context = acontext; debsrc = adebsrc; sys = load Sys Sys->PATH; tk = load Tk Tk->PATH; str = astr; debug = adebug; tkclient = load Tkclient Tkclient->PATH; tkclient->init(); titlebut: chan of string; (tktop, titlebut) = tkclient->toplevel(context, geom, "Stack", Tkclient->Resize); buts := chan of string; tk->namechan(tktop, buts, "buts"); for(i := 0; i < len tkconfig; i++) tk->cmd(tktop, tkconfig[i]); tkcmd("update"); tkclient->onscreen(tktop, nil); tkclient->startinput(tktop, "kbd" :: "ptr" :: nil); return (tktop, buts, titlebut); } ctl(s: string) { if(var == nil) return; arg := s[1:]; case s[0]{ 'o' => var.expand(arg); var.update(); 'c' => var.contract(arg); var.update(); 'y' => var.scrolly(arg); 's' => var.showsrc(arg); } tkcmd("update"); } wmctl(s: string) { if(s == "exit"){ tkcmd(". unmap"); return; } tkclient->wmctl(tktop, s); tkcmd("update"); } Vars.create(): ref Vars { t := ".body.v"+string vid++; tkcmd("frame "+t); tkcmd("canvas "+t+".cvar -width 2 -height 2 -yscrollcommand {"+t+".sy set} -xscrollcommand {"+t+".sxvar set}"); tkcmd("frame "+t+".f0"); tkcmd(t+".cvar create window 0 0 -window "+t+".f0 -anchor nw"); tkcmd("scrollbar "+t+".sxvar -orient horizontal -command {"+t+".cvar xview}"); tkcmd("scrollbar "+t+".sy -command {send buts y}"); tkcmd("pack "+t+".sy -side right -fill y -in "+t); tkcmd("pack "+t+".sxvar -fill x -side bottom -in "+t); tkcmd("pack "+t+".cvar -expand 1 -fill both -in "+t); return ref Vars(t, 0, nil); } Vars.show(v: self ref Vars) { if(v == var) return; if(var != nil) tkcmd("pack forget "+var.tk); var = v; tkcmd("pack "+var.tk+" -expand 1 -fill both"); v.update(); } Vars.delete(v: self ref Vars) { if(var == v) var = nil; tkcmd("destroy "+v.tk); tkcmd("update"); } Vars.refresh(v: self ref Vars, ea: array of ref Exp) { nea := len ea; newd := array[nea] of ref Datum; da := v.d; nd := len da; n := nea; if(n > nd) n = nd; for(i := 0; i < n; i++){ d := da[nd-i-1]; if(!sameexp(ea[nea-i-1], d.e, 1)) break; newd[nea-i-1] = d; } n = nea-i; for(; i < nd; i++) da[nd-i-1].destroy(); v.d = nil; for(i = 0; i < n; i++){ debsrc->findmod(ea[i].m); ea[i].findsym(); newd[i] = mkkid(ea[i], v.tk, "0", string tkids++, nil, nil, -1, ""); } for(; i < nea; i++){ debsrc->findmod(ea[i].m); ea[i].findsym(); d := newd[i]; newd[i] = mkkid(ea[i], v.tk, "0", d.tkid, d.kids, d.val, d.canwalk, ""); } v.d = newd; v.update(); } Vars.update(v: self ref Vars) { tkcmd("update"); tkcmd(v.tk+".cvar configure -scrollregion {0 0 ["+v.tk+".f0 cget -width] ["+v.tk+".f0 cget -height]}"); tkcmd("update"); } Vars.scrolly(v: self ref Vars, pos: string) { tkcmd(v.tk+".cvar yview"+pos); } Vars.showsrc(v: self ref Vars, who: string) { (sid, kids) := str->splitl(who[1:], "."); showsrc(v.d, sid, kids); } showsrc(da: array of ref Datum, id, kids: string) { if(da == nil) return; for(i := 0; i < len da; i++){ d := da[i]; if(d.tkid != id) continue; if(kids == "") d.showsrc(); else{ sid : string; (sid, kids) = str->splitl(kids[1:], "."); showsrc(d.kids, sid, kids); } break; } } Vars.expand(v: self ref Vars, who: string) { (sid, kids) := str->splitl(who[1:], "."); v.d = expandkid(v.d, sid, kids, who); } expandkid(da: array of ref Datum, id, kids, who: string): array of ref Datum { if(da == nil) return nil; for(i := 0; i < len da; i++){ d := da[i]; if(d.tkid != id) continue; if(kids == "") da[i] = d.expand(nil, who); else{ sid : string; (sid, kids) = str->splitl(kids[1:], "."); d.kids = expandkid(d.kids, sid, kids, who); } break; } return da; } Vars.contract(v: self ref Vars, who: string) { (sid, kids) := str->splitl(who[1:], "."); v.d = contractkid(v.d, sid, kids, who); } contractkid(da: array of ref Datum, id, kids, who: string): array of ref Datum { if(da == nil) return nil; for(i := 0; i < len da; i++){ d := da[i]; if(d.tkid != id) continue; if(kids == "") da[i] = d.contract(who); else{ sid : string; (sid, kids) = str->splitl(kids[1:], "."); d.kids = contractkid(d.kids, sid, kids, who); } break; } return da; } Datum.contract(d: self ref Datum, who: string): ref Datum { vtk := d.vtk; tkid := d.tkid; if(tkid == "") return d; kids := d.kids; if(kids == nil){ tkcmd(vtk+".v"+tkid+".b configure -image Itemclosed -command {send buts o"+who+"}"); return d; } for(i := 0; i < len kids; i++) kids[i].destroy(); d.kids = nil; tkcmd("destroy "+vtk+".f"+tkid); tkcmd(vtk+".v"+tkid+".b configure -image Itemclosed -command {send buts o"+who+"}"); return d; } Datum.showsrc(d: self ref Datum) { debsrc->showmodsrc(debsrc->findmod(d.e.m), d.e.src()); } Datum.destroy(d: self ref Datum) { kids := d.kids; for(i := 0; i < len kids; i++) kids[i].destroy(); vtk := d.vtk; tkid := string d.tkid; if(d.kids != nil){ tkcmd("destroy "+vtk+".f"+tkid); } d.kids = nil; tkcmd("destroy "+vtk+".v"+tkid); } mkkid(e: ref Exp, vtk, parent, me: string, okids: array of ref Datum, oval:string, owalk: int, who: string): ref Datum { (val, walk) := e.val(); who = who+"."+me; # make the tk goo if(walk != owalk){ if(owalk == -1){ tkcmd("frame "+vtk+".v"+me); tkcmd("label "+vtk+".v"+me+".l -text '"+e.name); tkcmd("bind "+vtk+".v"+me+".l <ButtonRelease-1> 'send buts s"+who); }else{ tkcmd("destroy "+vtk+".v"+me+".b"); } if(walk) tkcmd("button "+vtk+".v"+me+".b -image Itemclosed -command 'send buts o"+who); else tkcmd("frame "+vtk+".v"+me+".b -width "+WalkWidth); } n := 16 - len e.name; if(n < 4) n = 4; pad := " "[:n]; # tk value goo if(val == "") val = " "; if(oval != ""){ if(val != oval) tkcmd(vtk+".v"+me+".val configure -text '"+pad+val); }else tkcmd("label "+vtk+".v"+me+".val -text '"+pad+val); tkcmd("pack "+vtk+".v"+me+".b "+vtk+".v"+me+".l "+vtk+".v"+me+".val -side left"); tkcmd("pack "+vtk+".v"+me+" -side top -anchor w -in "+vtk+".f"+parent); d := ref Datum(me, parent, vtk, e, val, walk, nil); if(okids != nil){ if(walk) return d.expand(okids, who); for(i := 0; i < len okids; i++) okids[i].destroy(); } return d; } Datum.expand(d: self ref Datum, okids: array of ref Datum, who: string): ref Datum { e := d.e.expand(); if(e == nil) return d; vtk := d.vtk; me := d.tkid; # make the tk goo for holding kids needtk := okids == nil; if(needtk){ tkcmd("frame "+vtk+".f"+me); tkcmd("frame "+vtk+".f"+me+".x -width "+WalkWidth); tkcmd("frame "+vtk+".f"+me+".v"); tkcmd("pack "+vtk+".f"+me+".x "+vtk+".f"+me+".v -side left -fill y -expand 1"); } kids := array[len e] of ref Datum; for(i := 0; i < len e; i++){ if(i >= len okids) break; ok := okids[i]; if(!sameexp(e[i], ok.e, 0)) break; kids[i] = mkkid(e[i], vtk, me, ok.tkid, ok.kids, ok.val, ok.canwalk, who); } for(oi := i; oi < len okids; oi++) okids[oi].destroy(); for(; i < len e; i++) kids[i] = mkkid(e[i], vtk, me, string tkids++, nil, nil, -1, who); tkcmd("pack "+vtk+".f"+me+" -side top -anchor w -after "+vtk+".v"+me); tkcmd(vtk+".v"+me+".b configure -image Itemopen -command {send buts c"+who+"}"); d.kids = kids; return d; } sameexp(e, f: ref Exp, offmatch: int): int { if(e.m != f.m || e.p != f.p || e.name != f.name) return 0; return !offmatch || e.offset == f.offset; } tkcmd(cmd: string): string { s := tk->cmd(tktop, cmd); # if(len s != 0 && s[0] == '!') # sys->print("%s '%s'\n", s, cmd); return s; } raisex() { tkcmd(". map; raise .; update"); }