Dev/Mod/MsgSpy.odc

MODULE DevMsgSpy;
(**
	project	= "BlackBox"
	organization	= "www.oberon.ch"
	contributors	= "Oberon microsystems"
	version	= "System/Rsrc/About"
	copyright	= "System/Rsrc/About"
	license	= "Docu/BB-License"
	changes	= "
	- YYYYMMDD, nn, ...
	"
	issues	= "
	- ...
	"

**)

	IMPORT SYSTEM, 
		DevDebug, Dialog, Stores, Models, Views, Controllers, Properties, Kernel, 
		Ports, TextModels, TextViews, TextMappers, StdDialog,
		Files, Converters, FormViews, FormModels, Windows, Containers, Services;

	CONST
		refViewSize = 9 * Ports.point;

	TYPE
		View = POINTER TO RECORD (Views.View)
			inner: Views.View
		END;
		
		RefView = POINTER TO RECORD (Views.View)
			msg: ANYPTR
		END;

		Msgs = POINTER TO RECORD
			left, right: Msgs;
			mod, ident: Kernel.Name;
			index: INTEGER;
		END;
		
	VAR
		para* : RECORD
			sel*: Dialog.Selection;
			selectNewMessages*: BOOLEAN;
			showMessages*: BOOLEAN
		END;
		text*: TextModels.Model;
		
		msgs: Msgs;
		size: INTEGER;
		path: ARRAY 4 OF Ports.Point;

	(* -------------------  Selection  ------------------- *)

	PROCEDURE Find(mod, ident: Kernel.Name): Msgs;
		VAR m: Msgs;
	BEGIN m := msgs;
		WHILE m # NIL DO
			IF mod < m.mod THEN m := m.left
			ELSIF mod > m.mod THEN m := m.right
			ELSIF ident < m.ident THEN m := m.left
			ELSIF ident > m.ident THEN m := m.right
			ELSE RETURN m
			END
		END;
		RETURN NIL
	END Find;
	
	PROCEDURE Insert(mod, ident: Kernel.Name);
		PROCEDURE InsertTree(VAR m: Msgs);
			VAR name: ARRAY 64 OF CHAR;
		BEGIN
			IF m = NIL THEN
				NEW(m); m.mod := mod; m.ident := ident; m.index := size-1;
				name := m.mod + "." + m.ident;
				para.sel.SetItem(m.index, name);
				IF para.selectNewMessages THEN para.sel.Incl(m.index, m.index) END
			ELSE
				IF mod < m.mod THEN InsertTree(m.left)
				ELSIF mod > m.mod THEN InsertTree(m.right)
				ELSIF ident < m.ident THEN InsertTree(m.left)
				ELSIF ident > m.ident THEN InsertTree(m.right)
				END
			END
		END InsertTree;
	BEGIN
		INC(size);  para.sel.SetLen(size);	(* increase size and reset all items *)
		InsertTree(msgs);						(* insert the new item *)
		Dialog.UpdateList(para.sel)
	END Insert;

	(* -------------------  RefView ------------------- *)
	
	PROCEDURE (v: RefView) Internalize (VAR rd: Stores.Reader);
		VAR thisVersion: INTEGER;
	BEGIN
		v.Internalize^(rd); IF rd.cancelled THEN RETURN END;
		rd.ReadVersion(0, 0, thisVersion); IF rd.cancelled THEN RETURN END;
	END Internalize;

	PROCEDURE (v: RefView) Externalize (VAR wr: Stores.Writer);
	BEGIN
		v.Externalize^(wr);
		wr.WriteVersion(0);
	END Externalize;

	PROCEDURE (v: RefView) CopyFromSimpleView (source: Views.View);
	BEGIN
		(* v.CopyFrom^(source); *)
		v.msg := source(RefView).msg
	END CopyFromSimpleView;

	PROCEDURE (v: RefView) Restore (f: Views.Frame; l, t, r, b: INTEGER);
	BEGIN
		f.DrawPath(path, 4, Ports.fill, Ports.blue, Ports.closedPoly)
	END Restore;
	
	PROCEDURE (v: RefView) HandleCtrlMsg (
		f: Views.Frame; VAR msg: Controllers.Message; VAR focus: Views.View
	);
		TYPE ControllersMessage = POINTER TO Controllers.Message;
			ViewsMessage = POINTER TO Views.Message;
			ModelsMessage = POINTER TO Models.Message;
			PropMessage = POINTER TO Properties.Message;
		VAR x, y: INTEGER; isDown: BOOLEAN; mo: SET;name: ARRAY 32 OF CHAR;
	BEGIN
		WITH msg: Controllers.TrackMsg DO
			IF v.msg # NIL THEN
				REPEAT
					f.MarkRect(0, 0, refViewSize, refViewSize, Ports.fill, Ports.hilite, Ports.show);
					REPEAT
						f.Input(x, y, mo, isDown)
					UNTIL (x < 0) OR (x > refViewSize) OR (y < 0) OR (y > refViewSize) OR ~isDown;
					f.MarkRect(0, 0, refViewSize, refViewSize, Ports.fill, Ports.hilite, Ports.hide);
					WHILE isDown & ((x < 0) OR (x > refViewSize) OR (y < 0) OR (y > refViewSize)) DO
						f.Input(x, y, mo, isDown)
					END
				UNTIL ~isDown;
				IF (x >= 0) & (x <= refViewSize) & (y >= 0) & (y <= refViewSize) THEN
					IF v.msg IS ControllersMessage THEN name := "Controllers.Message"
					ELSIF v.msg IS PropMessage THEN name := "Properties.Message"
					ELSIF v.msg IS ViewsMessage THEN name := "Views.Message"
					ELSIF v.msg IS ModelsMessage THEN name := "Models.Message"
					ELSE name := "Message Record"
					END;
					DevDebug.ShowHeapObject(SYSTEM.ADR(v.msg^), name)
				END
			END
		| msg: Controllers.PollCursorMsg DO
			msg.cursor := Ports.refCursor
		ELSE
		END
	END HandleCtrlMsg;
	
	PROCEDURE (v: RefView) HandlePropMsg (VAR msg: Properties.Message);
	BEGIN
		WITH msg: Properties.Preference DO
			WITH msg: Properties.ResizePref DO msg.fixed := TRUE
			| msg: Properties.SizePref DO msg.w := refViewSize; msg.h := refViewSize
			| msg: Properties.FocusPref DO msg.hotFocus := TRUE
			ELSE
			END
		ELSE
		END
	END HandlePropMsg;
	
	(* -------------------  Wrapper   ------------------- *)
	
	PROCEDURE (v: View) CopyFromModelView (source: Views.View; model: Models.Model);
	BEGIN
		WITH source: View DO
			IF model = NIL THEN v.inner := Views.CopyOf(source.inner, Views.shallow)
			ELSE v.inner := Views.CopyWithNewModel(source.inner, model)
			END;
			Stores.Join(v, v.inner)
		END
	END CopyFromModelView;
	
	PROCEDURE (v: View) ThisModel (): Models.Model;
	BEGIN
		RETURN v.inner.ThisModel()
	END ThisModel;

	PROCEDURE (v: View) InitContext (context: Models.Context);
	BEGIN
		v.InitContext^(context);
		v.inner.InitContext(context)	(* wrapper and wrapped view share the same context *)
	END InitContext;
	
(*
	PROCEDURE (v: View) PropagateDomain;
	BEGIN
		Stores.InitDomain(v.inner, v.domain)
	END PropagateDomain;
*)

	PROCEDURE (v: View) Neutralize;
	BEGIN
		v.inner.Neutralize
	END Neutralize;

	(* NewFrame: wrapper uses standard frame *)
	(* Background: wrapper has no intrinsic background color *)

	PROCEDURE (v: View) Restore (f: Views.Frame; l, t, r, b: INTEGER);
	BEGIN
		Views.InstallFrame(f, v.inner, 0, 0, 0, TRUE)
	END Restore;

	(* RestoreMarks: wrapper has no intrinsic marks, wrapped view's RestoreMarks is called by framework *)
	
	PROCEDURE DescOfMsg (VAR x: ANYREC): Kernel.Type;
		VAR desc: Kernel.Type;
	BEGIN
		desc := SYSTEM.VAL(Kernel.Type, SYSTEM.TYP(x));	(* tdesc of x *)
		RETURN desc
	END DescOfMsg;
	
	PROCEDURE WriteLog(t: Kernel.Type; VAR msg: ANYREC; name: ARRAY OF SHORTCHAR);
		VAR link: RefView; p: ANYPTR; name2 : ARRAY 256 OF CHAR; f: TextMappers.Formatter;
	BEGIN
		Kernel.NewObj(p, t);
		SYSTEM.MOVE(SYSTEM.ADR(msg), p, t.size);
		NEW(link); link.msg := p;
		name2 := t.mod.name$ + "." + name$;
		
		f.ConnectTo(text);
		f.WriteString(name2 + " ");
		f.WriteView(link);
		f.WriteLn;
		TextViews.ShowRange(text, text.Length(), text.Length(), ~TextViews.focusOnly)
	END WriteLog;
	
	PROCEDURE (v: View) HandleCtrlMsg (f: Views.Frame; VAR msg: Controllers.Message; VAR focus: Views.View);
		VAR name: Kernel.Name; t: Kernel.Type; m: Msgs;
	BEGIN
		t := DescOfMsg(msg);
		Kernel.GetTypeName (t, name);
		m := Find(t.mod.name, name);
		IF m = NIL THEN Insert(t.mod.name, name)
		ELSIF para.sel.In(m.index) & para.showMessages THEN WriteLog(t, msg, name);
		END;
		focus := v.inner	(* forward all controller messages to wrapped view *)
	END HandleCtrlMsg;
	
	PROCEDURE (v: View) ExternalizeAs (VAR s: Stores.Store);
	BEGIN
		s := v.inner
	END ExternalizeAs;
	
	PROCEDURE (v: View) HandlePropMsg (VAR msg: Properties.Message);
		VAR name: Kernel.Name; t: Kernel.Type; m: Msgs;
	BEGIN
		t := DescOfMsg(msg);
		Kernel.GetTypeName (t, name);
		m := Find(t.mod.name, name);
		IF m = NIL THEN Insert(t.mod.name, name)
		ELSIF para.sel.In(m.index) & para.showMessages THEN WriteLog(t, msg, name);
		END;			
		Views.HandlePropMsg(v.inner, msg)
	END HandlePropMsg;
	
	PROCEDURE (v: View) HandleViewMsg (f: Views.Frame; VAR msg: Views.Message);
		VAR name: Kernel.Name; t: Kernel.Type; m: Msgs;
	BEGIN
		t := DescOfMsg(msg);
		Kernel.GetTypeName (t, name);
		m := Find(t.mod.name, name);
		IF m = NIL THEN Insert(t.mod.name, name)
		ELSIF para.sel.In(m.index) & para.showMessages THEN WriteLog(t, msg, name);
		END;

		WITH msg: Views.ScrollClassMsg DO
			msg.allowBitmapScrolling := TRUE
		ELSE
		END
		(* framework performs message propagation *)
	END HandleViewMsg;

	PROCEDURE (v: View) HandleModelMsg (VAR msg: Models.Message);
		VAR name: Kernel.Name; t: Kernel.Type; m: Msgs;
	BEGIN
		t := DescOfMsg(msg);
		Kernel.GetTypeName (t, name);
		m := Find(t.mod.name, name);
		IF m = NIL THEN Insert(t.mod.name, name)
		ELSIF para.sel.In(m.index) & para.showMessages THEN WriteLog(t, msg, name);
		END;
		(* framework performs message propagation *)
	END HandleModelMsg;

	
	PROCEDURE Toggle*;
		VAR v: Views.View; w: View; replace: Controllers.ReplaceViewMsg;
	BEGIN
		Controllers.SetCurrentPath(Controllers.targetPath);
		v := Containers.FocusSingleton();
		Controllers.ResetCurrentPath();
		IF v # NIL THEN
			WITH v: View DO
				replace.old := v; replace.new := v.inner;
			ELSE
				NEW(w); w.inner := v;
				replace.old := v; replace.new := w;
			END;
			Controllers.Forward(replace)
		ELSE Dialog.Beep
		END
	END Toggle;
	
	PROCEDURE ToggleGuard* (VAR par: Dialog.Par);
		VAR v : Views.View;
	BEGIN
		Controllers.SetCurrentPath(Controllers.targetPath);
		v := Containers.FocusSingleton();
		Controllers.ResetCurrentPath();
		IF (v = NIL) OR ~(v IS View) THEN
			par.label := "#Dev:AddView";
			par.disabled := v = NIL
		ELSE
			par.label := "#Dev:RemoveView"
		END
	END ToggleGuard;
	
	PROCEDURE Reset*;
	BEGIN
		msgs := NIL; size := 0; para.sel.SetLen(size);
		Dialog.UpdateList(para.sel)
	END Reset;
	
	PROCEDURE Clear*;
	BEGIN
		text.Delete(0, text.Length())
	END Clear;
	
	PROCEDURE PathToSpec (VAR path: ARRAY OF CHAR; VAR loc: Files.Locator; VAR name: Files.Name);
		VAR i, j: INTEGER; ch: CHAR;
	BEGIN
		i := 0; j := 0; loc := Files.dir.This("");
		WHILE (loc.res = 0) & (i < LEN(path) - 1) & (j < LEN(name) - 1) & (path[i] # 0X) DO
			ch := path[i]; INC(i);
			IF (j > 0) & ((ch = "/") OR (ch = "\")) THEN
				name[j] := 0X; j := 0; loc := loc.This(name)
			ELSE
				name[j] := ch; INC(j)
			END
		END;
		IF path[i] = 0X THEN name[j] := 0X
		ELSE loc.res := 1; name := ""
		END
	END PathToSpec;

	PROCEDURE OpenDialog*(file, title: ARRAY OF CHAR);
		VAR loc: Files.Locator; fname: Files.Name; conv: Converters.Converter; view, v, t: Views.View;
			r: FormModels.Reader; t0: Views.Title; done: BOOLEAN; c: Containers.Controller;
	BEGIN
		Dialog.MapString(title, t0);
		Windows.SelectByTitle(NIL, {Windows.isTool}, t0, done);
		IF ~ done THEN
			PathToSpec(file, loc, fname);
			IF loc.res = 0 THEN
				conv := NIL;
				view := Views.Old(Views.dontAsk, loc, fname, conv);
				IF view IS FormViews.View THEN t := NIL;
					r := view(FormViews.View).ThisModel().NewReader(NIL);
					r.ReadView(v);
					WHILE (v # NIL) & (t = NIL) DO
						t := Properties.ThisType(v, "TextViews.View");
						r.ReadView(v)
					END;
					IF t # NIL THEN
						text := t(TextViews.View).ThisModel();
						text.Delete(0, text.Length())
					END;
				END;
				IF view # NIL THEN
					WITH view: Containers.View DO
						c := view.ThisController();
						IF c # NIL THEN
							c.SetOpts(c.opts - {Containers.noFocus} + {Containers.noCaret, Containers.noSelection})
						ELSE Dialog.ShowMsg("#System:NotEditable")
						END
					ELSE Dialog.ShowMsg("#System:ContainerExpected")
					END;
					IF text # NIL THEN
						StdDialog.Open(view, title, NIL, "", NIL, TRUE, FALSE, TRUE, FALSE, TRUE)
					ELSE
						Dialog.ShowMsg("#Dev:TextInDialogExpected")
					END
				END
			ELSE Dialog.ShowParamMsg("#System:FileNotFound", file, "", "")
			END;
		END
	END OpenDialog;

BEGIN
(*  NEW(action); action.Do; *)
	para.showMessages := TRUE;
	size := 0;
	path[0].x := refViewSize DIV 2; path[0].y := 0;
	path[1].x := refViewSize; path[1].y := refViewSize DIV 2;
	path[2].x := refViewSize DIV 2; path[2].y := refViewSize;
	path[3].x := 0; path[3].y := refViewSize DIV 2;
END DevMsgSpy.

 "DevMsgSpy.OpenDialog('Dev/Rsrc/MsgSpy', 'Message Spy')"

Menu:
"Message Spy..."	""	"DevMsgSpy.OpenDialog('Dev/Rsrc/MsgSpy', 'Message Spy')"	""

Strings: (Dev)
AddView	Add View
RemoveView	Remove View
TextInDialogExpected	Text in Dialog expected

Dialog:
StdCoder.Decode ..,, ..qX....3Qw7uP5PRPPNR9Rbf9b8R79FTvMf1uZlbcjRAktYcjRgp,
 xW1xhiZiVBhihgmRiioedhgrp9XjJHPNjvQRdJHXS7wb8RTfQ9vQRtIdvPZHjU..D.JA06.Css
 HorC4sQqorGqmmKjAST1.PuP.PuP7PNCLLq2o9ZD,6.ciDU7Umy.0E.0.3IXyKtqKfaqmQCb8R
 7fJHPNjfL4TXyKt.bHfEjIy0.,.s,cMD.,6.5IXyKtgdjZACbHlayKmKaSNwB0UnNHEjIy4.,U
 uq.e.8P16.,6.cUCoruamxhgRiiQeZZhZRgoBhjph0xhsp9XzE.QcjphoVSdw5.0.Z00.p,0E0
 GYZdRqYntNCZkNSuWkNM8bVd9CbZ7P6..k.E.0ke59,BXgevQ4,TCbE,5zV.C5FPN5vO3uPlfL
 8z4U.EEF.E2F.Y....05.C5MNCaodHKarNHKantQ4abNNCb.MH4amtO0WC,0WBNNsQ.66aai76
 mYdtQGb.6...YiVA.1hBFlSzs9gh6Z33gwRE.6.YF0E.Eu0.,E0Uq,S4.05MMsQWajtRq2sQ.6
 .CZc,0WB,C5.0WddPUjtN0E.0E...2cNA.fCKNl2Ts9Aoe343Qw.6IfvQFfEf9RdvPRfL8z4U.
 EjU.EXU.Y..sNC3U17PKaVV.2U17P.00U.E...AYJ51f9APldCmGghh443gwT.0.,X.2.272.7
 .O5UH,cIKanNNG5C2MM.aan7R6...A2guy23bu69lajvJIkmz,6.o96.o66.7sIGbYtEqaYtQu
 W1VjtQKa2NO4agtPSa.sEm4C50.,.U,E.Yyvp2188PFHeQNAbZ443Qwb8R7vI5fQT9PNPNZvQR
 dJ.5.,6.Yo0k1E49.,E.8cIhgsZiKBhZtQC3h0xmsHpmW5sQO3uZmL.0U..w.oa0.,sUGpmWbB
 xhYltQeoNHEjAyI,ktg7cL8T1U.kk2.T.n0,6.Eb2.86.QC18RdfQHfMf9R9vQxGtH.0..c4E.
 k.UesFnQ.E.0t.U,UzjV0CyIhACoruKuEqUHZC58RZ9Pxms,.U1xB.uZlT6AA.cQ...b1.o9ZD
 ,6.636.M00U.2..AU0CyIVGhighgmRCbWGhigFjAyI,ktIepVSdw5.,6.IIw.IH2U.sU.ktQ8C
 JuaLqKKjAyI,.AjgVmz.2U..2,w86.IE.U,ZC..2..EGE.4E.E.EECOhU.wcNC.zwPA.A.2U.E
 ,9z8U...p.0.4.I3E.6.VQ.E..2eHJ.6...Z1Jsp0E9mr72YKQ4hO8BF,9z5U.E41.,.d1,E0G
 2O5sNC3a5GZjtNSagNN0U,7NGaUMHC5C36.GYZdR..u0Ub7PsFKbVdQG40..EulEPHIoY8L4nw
 gLF.3U..8ssP2Coru4UntIGqVyKr.o9XjF..Cb1,USdwl.,..A,,E.0U06.,6.,c.16QBaywPW
 .0.161lbA2TmNeHXGBnmcUXDF.sET1.4zVkk.Um,..QC.Ej2yHZCQCwBu32..W.0..0F6Cb.yy
 W8Utj00My7Yb6OQzL0yl1...
 --- end of encoding ---