MODULEThis module contains the runtime code for FormsVBTs.FVRuntime EXPORTSFVRuntime ,FVTypes ,FormsVBT ;
IMPORT AnchorSplit, AnchorHelpSplit, AnyEvent, Atom, AudioVBT, Axis, BooleanVBT, BorderedVBT, ButtonVBT, ChoiceVBT, Color, ColorName, Cursor, FileBrowserVBT, FileRd, Filter, FlexVBT, FormsVBTPixmapsBundle, Fmt, Font, GuardedBtnVBT, HighlightVBT, HVSplit, IO, IP, Jva, JVSink, ListVBT, Macro, MenuSwitchVBT, MultiClass, MultiSplit, NumericVBT, OSError, PaintOp, Pathname, Pixmap, PixmapVBT, Pts, Rd, RdUtils, ReactivityVBT, RefList, Rsrc, RTTypeSRC, ScaleFilter, ScrollerVBT, Shadow, ShadowedVBT, ShadowedFeedbackVBT, SortedTextRefTbl, SourceVBT, Split, SplitterVBT, SwitchVBT, Sx, Text, TextEditVBT, TextPort, TextPortClass, TextRd, TextureVBT, TextVBT, TextWr, Thread, TrillSwitchVBT, TSplit, TextIntTbl, TypeinVBT, TypescriptVBT, VBT, VBTClass, Web, Wr, ZChassisVBT, ZChildVBT, ZSplit, ZSplitUtils; IMPORT StubImageRd AS ImageRd; IMPORT StubImageVBT AS ImageVBT; FROM RefListUtils IMPORT Push, Pop; <* PRAGMA LL *> REVEAL T = Private BRANDED OBJECT mu: MUTEX; <* LL = mu *> getVBT : SortedTextRefTbl.T; eventCount : CARDINAL := 0; keyRec : REF VBT.KeyRec; mouseRec : REF VBT.MouseRec; positionRec: REF VBT.PositionRec; miscRec : REF VBT.MiscRec; eventCode : CARDINAL := 0; (* typecode of event *) timeStamp : VBT.TimeStamp; gensym := 0; raw := FALSE; OVERRIDES init := InitFromText; initFromFile := InitFromFile; initFromSx := InitFromSx; initFromRd := InitFromRd; initFromRsrc := InitFromRsrc; initFromURL := InitFromURL; snapshot := Snapshot; restore := Restore; END; VAR cleanState: State; (* CONST *)************************** Creation ******************************
PROCEDURE************************** URLs ******************************NewFromFile (filename: TEXT; raw := FALSE; path: Rsrc.Path := NIL): T RAISES {Error, Rd.Failure, Thread.Alerted} = BEGIN RETURN NEW (T).initFromFile (filename, raw, path) END NewFromFile; PROCEDUREInitFromFile (fv : T; filename: TEXT; raw := FALSE; path : Rsrc.Path := NIL ): T RAISES {Error, Rd.Failure, Thread.Alerted} = VAR rd: Rd.T; BEGIN TRY rd := FileRd.Open (filename); TRY RETURN InitFromRd (fv, rd, raw, path) FINALLY Rd.Close (rd) END EXCEPT | OSError.E (code) => RAISE Error (Atom.ToText (code.head)) END END InitFromFile; PROCEDUREInitFromText (fv : T; description: TEXT; raw := FALSE; path : Rsrc.Path := NIL ): T RAISES {Error} = <* FATAL Rd.Failure, Thread.Alerted *> BEGIN RETURN InitFromRd (fv, TextRd.New (description), raw, path) END InitFromText; PROCEDUREInitFromRd (fv: T; rd: Rd.T; raw := FALSE; path: Rsrc.Path := NIL): T RAISES {Error, Rd.Failure, Thread.Alerted} = BEGIN RETURN FromRd(fv, rd, raw, path) END InitFromRd; PROCEDUREFromRd (fv: T; rd: Rd.T; raw := FALSE; path: Rsrc.Path := NIL; baseURL: TEXT :=NIL): T RAISES {Error, Rd.Failure, Thread.Alerted} = VAR desc := Thread.Join(Thread.Fork(NEW(ReaderClosure, rd := rd, stackSize := 10000))); BEGIN TYPECASE desc OF | ReaderClosure (rc) => CASE rc.errType OF | ErrType.ReadError => RAISE Error("Sx.ReadError: " & rc.errArg) | ErrType.EndOfFile => RAISE Error("End of input") | ErrType.Failure => RAISE Rd.Failure(rc.errArg) | ErrType.Alerted => RAISE Thread.Alerted END ELSE RETURN FromSx(fv, desc, raw, path, baseURL); END END FromRd; TYPE ReaderClosure = Thread.SizedClosure OBJECT rd : Rd.T; errType: ErrType; errArg : REFANY OVERRIDES apply := Read END; ErrType = {ReadError, EndOfFile, Failure, Alerted}; PROCEDURERead (rc: ReaderClosure): REFANY = VAR exp : REFANY; gotIt := FALSE; BEGIN TRY exp := Sx.Read (rc.rd, syntax := FVSyntax); gotIt := TRUE; IF Rd.EOF (rc.rd) THEN RETURN exp END; (* Check for extra garbage: *) EVAL Sx.Read (rc.rd, syntax := FVSyntax); RAISE Sx.ReadError ("extra characters on input") EXCEPT | Sx.ReadError (Text) => rc.errArg := Text; rc.errType := ErrType.ReadError | Rd.EndOfFile => IF gotIt THEN RETURN exp END; rc.errType := ErrType.EndOfFile | Rd.Failure (ref) => rc.errArg := ref; rc.errType := ErrType.Failure | Thread.Alerted => rc.errType := ErrType.Alerted END; (* If there's an error, we return the ReaderClosure itself. *) RETURN rc END Read; PROCEDUREInitFromRsrc (fv: T; name: TEXT; path: Rsrc.Path; raw := FALSE): T RAISES {Error, Rd.Failure, Rsrc.NotFound, Thread.Alerted} = VAR rd: Rd.T; BEGIN rd := Rsrc.Open (name, path); TRY RETURN InitFromRd (fv, rd, raw, path) FINALLY Rd.Close (rd) END END InitFromRsrc; PROCEDUREInitFromURL (fv: T; baseURL: TEXT; raw := FALSE): T RAISES {Error, Rd.Failure, Thread.Alerted} = VAR rd := OpenURL(baseURL); BEGIN TRY RETURN FromRd(fv, rd, raw := raw, path := NIL, baseURL := baseURL) FINALLY Rd.Close(rd) END END InitFromURL; PROCEDUREInitFromSx (fv : T; description: Sx.T; raw := FALSE; path : Rsrc.Path := NIL): T RAISES {Error} = BEGIN RETURN FromSx(fv, description, raw, path) END InitFromSx; PROCEDUREFromSx (fv : T; description: Sx.T; raw := FALSE; path : Rsrc.Path := NIL; baseURL : TEXT := NIL ): T RAISES {Error} = VAR state := cleanState; ch : VBT.T; BEGIN fv.getVBT := NEW(SortedTextRefTbl.Default).init(); fv.mu := NEW(MUTEX); fv.keyRec := NEW(REF VBT.KeyRec); fv.mouseRec := NEW(REF VBT.MouseRec); fv.positionRec := NEW(REF VBT.PositionRec); fv.miscRec := NEW(REF VBT.MiscRec); fv.path := RefList.Append(path, RefList.List1(FormsVBTPixmapsBundle.Get())); fv.baseURL := baseURL; fv.raw := raw; MultiClass.Be(fv, NEW(MC)); state.menubar := NEW(VBT.T); IF raw THEN (* fv = (Filter parsedVBT) *) ch := Parse(fv, description, state); EVAL Filter.T.init(fv, ch); ELSE (* fv = (Filter (ZSplit (Highlight (Reactivity parsedVBT)))) *) (* The trick here is that state.zsplit must already be set BEFORE we parse the description. *) WITH react = NEW(FVFilter), highlight = NEW(HighlightVBT.T).init(react), zsplit = NEW(ZSplit.T).init(highlight) DO EVAL Filter.T.init(fv, zsplit); state.zsplit := zsplit; ch := Parse(fv, description, state); EVAL react.init(ch) END END; MultiClass.BeChild(fv, ch); RETURN fv END FromSx; TYPE MC = MultiClass.Filter OBJECT OVERRIDES succ := Succ; pred := Succ; replace := Replace END; PROCEDUREReplace (m: MC; <* UNUSED *> ch: VBT.T; new: VBT.T) = <* FATAL Split.NotAChild *> VAR fv: T := m.vbt; BEGIN IF fv.raw THEN EVAL Filter.Replace (fv, new) ELSE WITH zsplit = Filter.Child (fv), highlight = Split.Succ (zsplit, NIL), react = Filter.Child (highlight) DO EVAL Filter.Replace (react, new) END END END Replace; PROCEDURESucc (m: MC; ch: VBT.T): VBT.T = <* FATAL Split.NotAChild *> VAR fv: T := m.vbt; BEGIN IF ch # NIL THEN RETURN NIL ELSIF fv.raw THEN RETURN Filter.Child (fv) ELSE WITH zsplit = Filter.Child (fv), highlight = Split.Succ (zsplit, NIL), react = Filter.Child (highlight) DO RETURN Filter.Child (react) END END END Succ; PROCEDUREGetZSplit (fv: T): ZSplit.T RAISES {Error} = BEGIN IF fv.raw THEN RAISE Error ("Uncooked FormsVBT (GetZSplit)") END; RETURN Filter.Child (fv) END GetZSplit; PROCEDUREInsert (fv : T; parent : TEXT; description: TEXT; at : CARDINAL := LAST (CARDINAL)): VBT.T RAISES {Error} = VAR stateRef: REF State := VBT.GetProp ( GetVBT (fv, parent), TYPECODE (REF State)); res: VBT.T; rd := TextRd.New (description); BEGIN TRY res := Parse (fv, Sx.Read (rd, syntax := FVSyntax), stateRef^); Rd.Close (rd); InsertVBT (fv, parent, res, at); RETURN res EXCEPT | Sx.ReadError (text) => RAISE Error ("Sx.ReadError: " & text) | Rd.EndOfFile => RAISE Error ("End of input") | Rd.Failure => <* ASSERT FALSE *> | Thread.Alerted => RAISE Error ("Thread.Alerted") END END Insert; PROCEDUREInsertFromFile (fv : T; parent : TEXT; filename: Pathname.T; at : CARDINAL := LAST (CARDINAL)): VBT.T RAISES {Error, Rd.Failure, Thread.Alerted} = VAR rd: Rd.T; BEGIN TRY rd := FileRd.Open (filename); TRY RETURN Insert (fv, parent, Rd.GetText (rd, LAST (CARDINAL)), at) FINALLY Rd.Close (rd) END EXCEPT | OSError.E (code) => RAISE Error (Atom.ToText (code.head)) END END InsertFromFile; PROCEDUREInsertFromRsrc (fv : T; parent: TEXT; name : TEXT; path : Rsrc.Path; n : CARDINAL := LAST (CARDINAL)): VBT.T RAISES {Error, Rd.Failure, Rsrc.NotFound, Thread.Alerted} = BEGIN RETURN Insert (fv, parent, Rsrc.Get (name, path), n) END InsertFromRsrc;
PROCEDURE************************** snapshots ******************************Open (name: TEXT; path: Rsrc.Path; baseURL: TEXT): Rd.T RAISES {Error} = BEGIN IF baseURL # NIL THEN RETURN OpenURL(name, baseURL) ELSE TRY RETURN Rsrc.Open(name, path) EXCEPT Rsrc.NotFound => RAISE Error("No such resource: " & name) END END END Open; PROCEDUREOpenURL (url: TEXT; base: TEXT := NIL): Rd.T RAISES {Error} = VAR rd : Rd.T; header: Web.Header; BEGIN IF base # NIL THEN url := Web.AbsoluteURL(url, base) END; TRY rd := Web.Get(url, header) EXCEPT Thread.Alerted, IP.Error, Web.Error => RAISE Error("Cannot access url:" & url) END; IF header.statusCode = 200 THEN RETURN rd ELSE RAISE Error("Bad http status code accessing url: " & url & " (" & Fmt.Int(header.statusCode) & ")") END END OpenURL;
PROCEDURE========================= Attachment =========================GetVal (fv: T; name: TEXT): REFANY = (* Returns value of name as REFANY, if a value can be retrieved *) BEGIN TRY WITH ri = NEW(REF INTEGER) DO ri^ := GetInteger(fv, name); RETURN ri END EXCEPT Error, Unimplemented => END; TRY WITH rb = NEW(REF BOOLEAN) DO rb^ := GetBoolean(fv, name); IF rb^ THEN RETURN Sx.True ELSE RETURN Sx.False END; END EXCEPT Error, Unimplemented => END; TRY RETURN GetText(fv, name); EXCEPT Error, Unimplemented => END; RETURN NIL END GetVal; PROCEDURESnapshot (fv: T; wr: Wr.T) RAISES {Error} = VAR key : TEXT; val, ignore: REFANY; iter := fv.getVBT.iterateOrdered (); alist: RefList.T := NIL; BEGIN TRY WHILE iter.next (key, ignore) DO val := GetVal (fv, key); IF val # NIL THEN Push (alist, RefList.List2 (Atom.FromText (key), val)) END END; Sx.Print (wr, alist); Wr.PutChar (wr, '\n') EXCEPT | Sx.PrintError, Thread.Alerted, Wr.Failure => RAISE Error ("Problem writing snapshot"); END END Snapshot; PROCEDURERestore (fv: T; rd: Rd.T) RAISES {Mismatch, Error} = VAR mismatch := FALSE; ignoreRef: REFANY; name : TEXT; BEGIN TRY TYPECASE Sx.Read(rd) OF | NULL => | RefList.T (sx) => WHILE sx # NIL DO TYPECASE sx.head OF | RefList.T (l) => IF RefList.Length(l) # 2 THEN RAISE Error("Illegal expression in snapshot") END; TYPECASE l.head OF | Atom.T (sym) => name := Atom.ToText(sym); IF NOT fv.getVBT.get(name, ignoreRef) THEN mismatch := TRUE ELSE TYPECASE l.tail.head OF | TEXT (text) => PutText(fv, name, text) | REF BOOLEAN (refBool) => PutBoolean(fv, name, refBool^) | REF INTEGER (refInt) => PutInteger(fv, name, refInt^) | Atom.T (atm) => IF atm = Sx.True THEN PutBoolean(fv, name, TRUE) ELSIF atm = Sx.False THEN PutBoolean(fv, name, FALSE) ELSE RAISE Error("Value of component " & Atom.ToText(sym) & " has illegal value: " & Atom.ToText(atm)); END; ELSE RAISE Error("Value of component " & Atom.ToText(sym) & " has illegal type"); END (* TYPECASE *) END (* IF *) ELSE RAISE Error("Illegal component name in snapshot"); END (* TYPECASE *) ELSE RAISE Error("Snapshot is not a valid s-expression"); END; (* TYPECASE *) sx := sx.tail END; (* WHILE *) IF mismatch THEN RAISE Mismatch END; ELSE RAISE Error("Snapshot is not a valid s-expression") END (* TYPECASE *) EXCEPT | Sx.ReadError, Rd.EndOfFile, Thread.Alerted, Unimplemented => RAISE Error("Problem with reading snapshot") END END Restore;
TYPE ClosureRef = BRANDED REF RECORD fv: T; name: TEXT; cl: Closure END; PROCEDURE========================= Edit Ops =========================Attach (fv: T; name: TEXT; cl: Closure) RAISES {Error} = VAR vbt := GetVBT (fv, name); BEGIN TYPECASE vbt OF | FVBoolean, FVBrowser, FVButton, FVChoice, FVCloseButton, FVFileBrowser, FVGuard, FVLinkButton, FVLinkMButton, FVMButton, FVMenu, FVMultiBrowser, FVNumeric, FVPageButton, FVPageMButton, FVPopButton, FVPopMButton, FVRadio, FVScroller, FVSource, FVTextEdit, FVTrillButton, FVTypeIn, FVZChassis, FVZChild, ReservedVBT => IF cl # NIL THEN VBT.PutProp ( vbt, NEW (ClosureRef, fv := fv, name := name, cl := cl)) ELSE VBT.RemProp (vbt, TYPECODE (ClosureRef)) END ELSE RAISE Error ("The component named \"" & name & "\" does not generate events.") END; END Attach; PROCEDUREMouseProc (self: VBT.T; READONLY cd: VBT.MouseRec) = (* This is the callback, directly or indirectly, for all the components that generate events (see Attach) except TypeIn, TextEdit, and Numeric, which handle attachment directly and using KeyProc. *) VAR cr: ClosureRef := VBT.GetProp (self, TYPECODE (ClosureRef)); fv: T; BEGIN IF cr # NIL THEN fv := cr.fv; LOCK fv.mu DO INC (fv.eventCount); IF fv.eventCount = 1 THEN fv.mouseRec^ := cd; fv.eventCode := TYPECODE (REF VBT.MouseRec) END END; TRY cr.cl.apply (fv, cr.name, cd.time) FINALLY LOCK fv.mu DO DEC (fv.eventCount) END END; END END MouseProc; PROCEDUREKeyProc (self: VBT.T; READONLY cd: VBT.KeyRec) = VAR cr: ClosureRef := VBT.GetProp (self, TYPECODE (ClosureRef)); fv: T; BEGIN IF cr # NIL THEN fv := cr.fv; LOCK fv.mu DO INC (fv.eventCount); IF fv.eventCount = 1 THEN fv.keyRec^ := cd; fv.eventCode := TYPECODE (REF VBT.KeyRec) END END; TRY cr.cl.apply (fv, cr.name, cd.time) FINALLY LOCK fv.mu DO DEC (fv.eventCount) END END END END KeyProc; TYPE OldClosure = Closure OBJECT ref : REFANY; proc: Proc OVERRIDES apply := OldApply END; PROCEDUREAttachProc (fv: T; name: TEXT; proc: Proc; cl: REFANY := NIL) RAISES {Error} = BEGIN IF proc # NIL THEN Attach (fv, name, NEW (OldClosure, ref := cl, proc := proc)) ELSE Attach (fv, name, NIL) END END AttachProc; PROCEDUREOldApply (oc: OldClosure; fv: T; name: TEXT; time: VBT.TimeStamp) = BEGIN oc.proc (fv, name, oc.ref, time) END OldApply;
TYPE C = Closure OBJECT port: TextPort.T; op : Op OVERRIDES apply := ApplyEditOp END; Op = {cut, copy, paste, clear, selectAll, undo, redo, first, next, prev}; PROCEDURE===================== MakeEvent & GetTheEvent ====================AttachEditOps (fv : T; editorName: TEXT; cut, copy, paste, clear, selectAll, undo, redo, findFirst, findNext, findPrev: TEXT := NIL) RAISES {Error} = VAR port: TextPort.T := NIL; BEGIN TYPECASE GetVBT (fv, editorName) OF | NULL => | FVTextEdit (vbt) => port := vbt.tp | FVNumeric (vbt) => port := vbt.typein | FVTypescript (vbt) => port := vbt.tp | FVTypeIn (vbt) => port := vbt ELSE END; IF port = NIL THEN RAISE Error ("There's no TextPort in the component named \"" & editorName & "\"") END; IF cut # NIL THEN Attach (fv, cut, NEW (C, port := port, op := Op.cut)) END; IF copy # NIL THEN Attach (fv, copy, NEW (C, port := port, op := Op.copy)) END; IF paste # NIL THEN Attach (fv, paste, NEW (C, port := port, op := Op.paste)) END; IF clear # NIL THEN Attach (fv, clear, NEW (C, port := port, op := Op.clear)) END; IF selectAll # NIL THEN Attach (fv, selectAll, NEW (C, port := port, op := Op.selectAll)) END; IF undo # NIL THEN Attach (fv, undo, NEW (C, port := port, op := Op.undo)) END; IF redo # NIL THEN Attach (fv, redo, NEW (C, port := port, op := Op.redo)) END; IF findFirst # NIL THEN Attach (fv, findFirst, NEW (C, port := port, op := Op.first)) END; IF findNext # NIL THEN Attach (fv, findNext, NEW (C, port := port, op := Op.next)) END; IF findPrev # NIL THEN Attach (fv, findPrev, NEW (C, port := port, op := Op.prev)) END; END AttachEditOps; PROCEDUREApplyEditOp ( cl : C; <* UNUSED *> fv : T; <* UNUSED *> name: TEXT; time: VBT.TimeStamp) = VAR port := cl.port; m := port.m; BEGIN LOCK port.mu DO CASE cl.op OF | Op.cut => m.cut (time) | Op.copy => m.copy (time) | Op.paste => m.paste (time) | Op.clear => m.clear () | Op.selectAll => m.select (time, 0, LAST (CARDINAL), replaceMode := TRUE) | Op.undo => TextPortClass.Undo (port) | Op.redo => TextPortClass.Redo (port) | Op.first => port.findSource (time, TextPortClass.Loc.First) | Op.next => port.findSource (time, TextPortClass.Loc.Next) | Op.prev => port.findSource (time, TextPortClass.Loc.Prev) END END END ApplyEditOp; TYPE ReservedVBT = VBT.Leaf BRANDED OBJECT END; PROCEDUREAddSymbol (fv: T; name: TEXT) RAISES {Error} = VAR ref: REFANY; BEGIN LOCK fv.mu DO IF fv.getVBT.get (name, ref) THEN RAISE Error ("The name " & name & " is already in use.") ELSE EVAL fv.getVBT.put (name, NEW (ReservedVBT)) END END END AddSymbol; PROCEDUREAddUniqueSymbol (fv: T): TEXT = VAR ref : REFANY; name: TEXT; BEGIN LOCK fv.mu DO LOOP name := "-v-b-t-" & Fmt.Int (fv.gensym); IF fv.getVBT.get (name, ref) THEN INC (fv.gensym) ELSE EXIT END END; EVAL fv.getVBT.put (name, NEW (ReservedVBT)); RETURN name END END AddUniqueSymbol;
VAR MakeEventSelection: VBT.Selection; (* CONST *) PROCEDURE*********************** Text edit-widget callback ***********************MakeEvent (fv: T; name: TEXT; time: VBT.TimeStamp) RAISES {Error} = <* LL = VBT.mu *> VAR vbt := GetVBT (fv, name); cr : ClosureRef := VBT.GetProp (vbt, TYPECODE (ClosureRef)); popTarget : PopTarget := VBT.GetProp (vbt, TYPECODE (PopTarget)); pageTarget: PageTarget := VBT.GetProp (vbt, TYPECODE (PageTarget)); linkTarget: LinkTarget := VBT.GetProp (vbt, TYPECODE (LinkTarget)); BEGIN IF cr = NIL AND popTarget = NIL AND pageTarget = NIL AND linkTarget = NIL THEN RAISE Error ("Nothing attached to " & name) END; IF popTarget # NIL THEN popTarget.apply (time) ELSIF pageTarget # NIL THEN pageTarget.apply (time) ELSIF linkTarget # NIL THEN linkTarget.apply (time) END; IF cr # NIL THEN LOCK fv.mu DO INC (fv.eventCount); IF fv.eventCount = 1 THEN fv.miscRec.type := MakeEventMiscCodeType; fv.miscRec.time := time; fv.miscRec.selection := MakeEventSelection; fv.eventCode := TYPECODE (REF VBT.MiscRec) END END; TRY cr.cl.apply (cr.fv, cr.name, time) FINALLY LOCK fv.mu DO DEC (fv.eventCount) END END END END MakeEvent; PROCEDUREGetTheEvent (fv: T): AnyEvent.T RAISES {Error} = VAR tc: CARDINAL; BEGIN LOCK fv.mu DO tc := fv.eventCode; IF fv.eventCount = 0 THEN RAISE Error ("There is no active event") (* ELSIF fv.eventCount > 1 THEN RAISE Error ("More than 1 event is active") *) ELSIF tc = TYPECODE (REF VBT.KeyRec) THEN RETURN AnyEvent.FromKey (fv.keyRec^) ELSIF tc = TYPECODE (REF VBT.MouseRec) THEN RETURN AnyEvent.FromMouse (fv.mouseRec^) ELSIF tc = TYPECODE (REF VBT.PositionRec) THEN RETURN AnyEvent.FromPosition (fv.positionRec^) ELSIF tc = TYPECODE (REF VBT.MiscRec) THEN RETURN AnyEvent.FromMisc (fv.miscRec^) ELSE RAISE Error ("Internal error: The active event has an unknown type") END END END GetTheEvent; PROCEDUREGetTheEventTime (fv: T): VBT.TimeStamp RAISES {Error} = VAR tc: CARDINAL; BEGIN LOCK fv.mu DO IF fv.eventCount = 0 THEN RETURN 0 END; tc := fv.eventCode; IF tc = TYPECODE (REF VBT.KeyRec) THEN RETURN fv.keyRec.time ELSIF tc = TYPECODE (REF VBT.MouseRec) THEN RETURN fv.mouseRec.time ELSIF tc = TYPECODE (REF VBT.PositionRec) THEN RETURN fv.positionRec.time ELSIF tc = TYPECODE (REF VBT.MiscRec) THEN RETURN fv.miscRec.time ELSE RAISE Error ("Internal error: The active event has an unknown type") END END END GetTheEventTime;
REVEAL Port = PublicPort BRANDED OBJECT textedit: FVTextEdit; reportKeys: BOOLEAN; OVERRIDES init := PortInit; filter := PortFilter; END; PROCEDURE*********************** Typein-widget callback ***********************PortInit (v: Port; textedit: FVTextEdit; reportKeys: BOOLEAN; font: Font.T; colorScheme: PaintOp.ColorScheme; wrap, readOnly: BOOLEAN; turnMargin: REAL): Port = BEGIN v.textedit := textedit; v.reportKeys := reportKeys; RETURN TextPort.T.init(v, font := font, colorScheme := colorScheme, readOnly := readOnly, wrap := wrap, turnMargin := turnMargin) END PortInit; PROCEDUREPortFilter (v: Port; cd: VBT.KeyRec) = BEGIN IF NOT v.reportKeys THEN TextPort.T.filter (v, cd) ELSE WITH len = TextPort.Length (v), text = TextPort.GetText(v) DO TextPort.T.filter (v, cd); IF len = TextPort.Length (v) THEN IF Text.Equal (text, TextPort.GetText (v)) THEN RETURN END END END; KeyProc (v.textedit, cd) END END PortFilter;
REVEAL FVTypeIn = TypeinVBT.T BRANDED OBJECT OVERRIDES returnAction := DeliverText END; PROCEDURE====================== Pixmap =====================DeliverText (typein: TypeinVBT.T; READONLY cd: VBT.KeyRec) = (* Callback for our TypeIns. *) BEGIN IF VBT.GetProp (typein, TYPECODE (ClosureRef)) = NIL THEN TypeinVBT.T.returnAction (typein, cd) ELSE KeyProc (typein, cd) END END DeliverText;
REVEAL FVImage = PrivateImage BRANDED OBJECT OVERRIDES shape := ImageShape; END; PROCEDURE====================== FileBrowser =====================ImageShape (v: PrivateImage; ax: Axis.T; n: CARDINAL): VBT.SizeRange = (* LL = VBT.mu.v *) VAR sr := ImageVBT.T.shape(v, ax, n); BEGIN sr.hi := 99999; RETURN sr END ImageShape;
REVEAL FVFileBrowser = FileBrowserVBT.T BRANDED OBJECT OVERRIDES activateFile := ActivateFileB END; PROCEDURE====================== Browser =====================ActivateFileB ( self : FVFileBrowser; <* UNUSED *> filename: TEXT; event : AnyEvent.T) = (* callback for our FileBrowserVBTs. *) VAR mr: VBT.MouseRec; BEGIN TYPECASE event OF | AnyEvent.Key (key) => mr.time := key.key.time; MouseProc (self, mr); | AnyEvent.Mouse (mouse) => MouseProc (self, mouse.mouse) ELSE END; END ActivateFileB;
REVEAL UniSelector = PrivateUniSelector BRANDED OBJECT OVERRIDES insideClick := InsideClick; outsideClick := OutsideClick END; PROCEDURE====================== Buttons =====================InsideClick ( v : UniSelector; READONLY cd : VBT.MouseRec; this: ListVBT.Cell ) = BEGIN ListVBT.UniSelector.insideClick (v, cd, this); IF cd.clickType = VBT.ClickType.LastUp AND (v.quick OR cd.clickCount = 3) THEN MouseProc (v.browser, cd) END END InsideClick; PROCEDUREOutsideClick ( v : UniSelector; READONLY cd : VBT.MouseRec) = BEGIN ListVBT.UniSelector.outsideClick (v, cd); IF cd.clickType = VBT.ClickType.LastUp AND (v.quick OR cd.clickCount = 3) THEN MouseProc (v.browser, cd) END END OutsideClick; REVEAL MultiSelector = PrivateMultiSelector BRANDED OBJECT OVERRIDES insideClick := MultiInsideClick; outsideClick := MultiOutsideClick END; PROCEDUREMultiInsideClick ( v : MultiSelector; READONLY cd : VBT.MouseRec; this: ListVBT.Cell ) = BEGIN ListVBT.MultiSelector.insideClick (v, cd, this); IF cd.clickType = VBT.ClickType.LastUp AND (v.quick OR cd.clickCount = 3) THEN MouseProc (v.browser, cd) END END MultiInsideClick; PROCEDUREMultiOutsideClick ( v : MultiSelector; READONLY cd : VBT.MouseRec) = BEGIN ListVBT.MultiSelector.outsideClick (v, cd); IF cd.clickType = VBT.ClickType.LastUp AND (v.quick OR cd.clickCount = 3) THEN MouseProc (v.browser, cd) END END MultiOutsideClick;
REVEAL FVBoolean = BooleanVBT.T BRANDED OBJECT OVERRIDES callback := MouseProc END; FVButton = SwitchVBT.T BRANDED OBJECT OVERRIDES callback := MouseProc END; FVGuard = GuardedBtnVBT.T BRANDED OBJECT OVERRIDES callback := MouseProc END; FVMButton = MenuSwitchVBT.T BRANDED OBJECT OVERRIDES callback := MouseProc END; FVScroller = ScrollerVBT.T BRANDED OBJECT OVERRIDES callback := MouseProc END; FVSource = SourceVBT.T BRANDED OBJECT OVERRIDES callback := MouseProc END; FVTrillButton = TrillSwitchVBT.T BRANDED OBJECT OVERRIDES callback := MouseProc END; FVZChassis = ZChassisVBT.T BRANDED OBJECT OVERRIDES callback := MouseProc END;====================== Radio & Choice =====================
REVEAL FVChoice = PrivateChoice BRANDED OBJECT OVERRIDES callback := ChoiceCallback END; PROCEDURE============================ FirstFocus ===========================ChoiceCallback (self: FVChoice; READONLY cd: VBT.MouseRec) = BEGIN MouseProc (self, cd); MouseProc (self.radio, cd) END ChoiceCallback;
The following widgets play the first-focus game: Helper, Numeric (.typein), TextEdit (.tp), TypeIn, and TypeScript (.tp). When a component of this type is encountered during the parsing of an s-expression, and if the FirstFocus property was set TRUE, SetFirstFocus is called to mark the VBT as having a TRUE FirstFocus property. Later, when a TSplit or sub-window is made visible, FirstFocus is called to find a visible descendant that was marked as having a TRUE FirstFocus property.
TYPE FirstFocusProp = BRANDED REF INTEGER; PROCEDURE====================== PopButton & PopMButton ===================== ========================== PopUp & PopDown ========================SetFirstFocus (widget: VBT.T) = VAR prop := NEW(FirstFocusProp); BEGIN VBT.PutProp(widget, prop) END SetFirstFocus; PROCEDUREFirstFocus (v: VBT.T; time: VBT.TimeStamp) = VAR widget: VBT.T; port : TextPort.T; BEGIN widget := FindFocus(v); IF widget = NIL THEN RETURN END; TYPECASE widget OF | FVHelper (h) => port := h; | FVNumeric (n) => port := n.typein; | FVTextEdit (t) => port := t.tp; | FVTypeIn (t) => port := t; | FVTypescript (t) => port := t.tp; ELSE <* ASSERT FALSE *> END; IF NOT TextPort.TryFocus(port, time) THEN RETURN END; IF ISTYPE(port, TypeinVBT.T) THEN TextPort.Select(port, time, replaceMode := TRUE) END END FirstFocus; PROCEDUREFindFocus (v: VBT.T): VBT.T = <* FATAL MultiSplit.NotAChild *> VAR ch, focus: VBT.T; BEGIN IF VBT.GetProp(v, TYPECODE(FirstFocusProp)) # NIL THEN RETURN v END; IF LeafVBT (v) THEN RETURN NIL END; IF ISTYPE(v, FVTSplit) THEN ch := TSplit.GetCurrent(v); IF ch # NIL THEN RETURN FindFocus(ch) END ELSE ch := MultiSplit.Succ(v, NIL); WHILE ch # NIL DO focus := FindFocus(ch); IF focus # NIL THEN RETURN focus END; ch := MultiSplit.Succ(v, ch); END END; RETURN NIL; END FindFocus;
REVEAL FVPopButton = SwitchVBT.T BRANDED OBJECT OVERRIDES callback := PopButtonProc END; FVPopMButton = MenuSwitchVBT.T BRANDED OBJECT OVERRIDES callback := PopButtonProc END; TYPE Callback = OBJECT METHODS apply (time: VBT.TimeStamp) END; PopTarget = Callback OBJECT target: ZChildVBT.T OVERRIDES apply := ApplyPopTarget END; PROCEDURE===================== PageButton, PageMButton ============================SetPopTarget (source: ButtonVBT.T; target: ZChildVBT.T) = BEGIN VBT.PutProp (source, NEW (PopTarget, target := target)) END SetPopTarget; PROCEDUREPopButtonProc (self: VBT.T; READONLY cd: VBT.MouseRec) = (* Callback procedure for Pop[M]Button *) VAR popTarget: PopTarget := VBT.GetProp (self, TYPECODE (PopTarget)); BEGIN IF popTarget # NIL THEN popTarget.apply (cd.time) END; MouseProc (self, cd) END PopButtonProc; PROCEDUREApplyPopTarget (p: PopTarget; time: VBT.TimeStamp) = BEGIN DoPopUp (p.target, forcePlace := FALSE, time := time); END ApplyPopTarget; PROCEDUREPopUp (fv : T; name : TEXT; forcePlace: BOOLEAN := FALSE; time : VBT.TimeStamp := 0 ) RAISES {Error} = VAR vbt := GetVBT (fv, name); BEGIN IF time = 0 THEN time := GetTheEventTime (fv) END; DoPopUp (vbt, forcePlace, time); END PopUp; PROCEDUREDoPopUp (vbt: VBT.T; forcePlace: BOOLEAN; time: VBT.TimeStamp) = VAR zchild := ZSplitUtils.FindZChild (vbt); BEGIN IF zchild # NIL THEN ZChildVBT.Pop (zchild, forcePlace); FirstFocus (zchild, time) END END DoPopUp; PROCEDUREPopDown (fv: T; name: TEXT) RAISES {Error} = VAR zchild := ZSplitUtils.FindZChild (GetVBT (fv, name)); BEGIN IF zchild # NIL THEN ZSplit.Unmap (zchild) END END PopDown;
TYPE PageTarget = Callback OBJECT target : FVTSplit; backwards: BOOLEAN OVERRIDES apply := ApplyPageTarget END; REVEAL FVPageButton = PublicPageButton BRANDED OBJECT backwards := FALSE OVERRIDES callback := PageButtonProc; init := InitPageButton END; FVPageMButton = PublicPageMButton BRANDED OBJECT backwards := FALSE OVERRIDES callback := PageButtonProc; init := InitPageMButton END; PROCEDURE===================== LinkButton, LinkMButton ============================InitPageButton (b : FVPageButton; ch : VBT.T; shadow : Shadow.T; backwards: BOOLEAN; tsplit : FVTSplit ): FVPageButton = BEGIN EVAL SwitchVBT.T.init (b, NEW (ShadowedFeedbackVBT.T).init (ch, shadow)); VBT.PutProp ( b, NEW (PageTarget, backwards := backwards, target := tsplit)); RETURN b END InitPageButton; PROCEDUREInitPageMButton (b : FVPageMButton; ch : VBT.T; shadow : Shadow.T; backwards: BOOLEAN; tsplit : FVTSplit ): FVPageMButton = BEGIN EVAL MenuSwitchVBT.T.init (b, ShadowedFeedbackVBT.NewMenu (ch, shadow)); VBT.PutProp ( b, NEW (PageTarget, backwards := backwards, target := tsplit)); RETURN b END InitPageMButton; PROCEDURESetPageTarget (source: ButtonVBT.T; target: FVTSplit) = VAR p: PageTarget := VBT.GetProp (source, TYPECODE (PageTarget)); BEGIN p.target := target END SetPageTarget; PROCEDUREPageButtonProc (self: VBT.T; READONLY cd: VBT.MouseRec) = VAR p: PageTarget := VBT.GetProp (self, TYPECODE (PageTarget)); BEGIN IF p # NIL THEN p.apply (cd.time) END; MouseProc (self, cd) END PageButtonProc; PROCEDUREApplyPageTarget (p: PageTarget; time: VBT.TimeStamp) = VAR tsplit := p.target; current := TSplit.GetCurrent (tsplit); next : VBT.T; <* FATAL Split.NotAChild *> BEGIN IF p.backwards THEN next := Split.Pred (tsplit, current); IF next = NIL AND tsplit.circular THEN next := Split.Pred (tsplit, NIL) END ELSE next := Split.Succ (tsplit, current); IF next = NIL AND tsplit.circular THEN next := Split.Succ (tsplit, NIL) END END; IF next # NIL THEN TSplit.SetCurrent (tsplit, next); FirstFocus (next, time) END; END ApplyPageTarget;
TYPE LinkTarget = Callback OBJECT Tparent: FVTSplit; Tchild : VBT.T OVERRIDES apply := ApplyLinkTarget END; REVEAL FVLinkButton = SwitchVBT.T BRANDED OBJECT OVERRIDES callback := LinkButtonProc END; FVLinkMButton = MenuSwitchVBT.T BRANDED OBJECT OVERRIDES callback := LinkButtonProc END; PROCEDURE=========================== CloseButton ============================SetLinkTarget (source: ButtonVBT.T; target: VBT.T) = BEGIN VBT.PutProp (source, NEW (LinkTarget, Tchild := target, Tparent := VBT.Parent (target))) END SetLinkTarget; PROCEDURELinkButtonProc (self: VBT.T; READONLY cd: VBT.MouseRec) = VAR lt: LinkTarget := VBT.GetProp (self, TYPECODE (LinkTarget)); BEGIN IF lt # NIL THEN lt.apply (cd.time) END; MouseProc (self, cd) END LinkButtonProc; PROCEDUREApplyLinkTarget (lt: LinkTarget; time: VBT.TimeStamp) = BEGIN TRY TSplit.SetCurrent (lt.Tparent, lt.Tchild); FirstFocus (lt.Tchild, time) EXCEPT | Split.NotAChild => (* ignore *) END END ApplyLinkTarget;
REVEAL FVCloseButton = PrivateCloseButton BRANDED OBJECT OVERRIDES callback := CloseButtonProc; init := InitCloseButton END; PROCEDURE============================= HBox, VBox ==============================InitCloseButton (b: FVCloseButton; ch: VBT.T; shadow: Shadow.T): FVCloseButton = BEGIN EVAL SwitchVBT.T.init (b, NEW (ShadowedFeedbackVBT.T).init (ch, shadow)); RETURN b END InitCloseButton; PROCEDURECloseButtonProc ( self: FVCloseButton; READONLY cd : VBT.MouseRec ) = VAR zch := ZSplitUtils.FindZChild (self.target); BEGIN IF zch # NIL THEN ZSplit.Unmap (zch); MouseProc (self, cd); MouseProc (zch, cd) END END CloseButtonProc;
REVEAL FVHBox = HVSplit.T BRANDED OBJECT OVERRIDES shape := HVSplitShape END; FVVBox = HVSplit.T BRANDED OBJECT OVERRIDES shape := HVSplitShape END; CONST EmptyShape = VBT.SizeRange {lo := 0, pref := 0, hi := 1}; PROCEDURE============================= HTile, VTile ==============================HVSplitShape (v: HVSplit.T; ax: Axis.T; n: CARDINAL): VBT.SizeRange = BEGIN IF v.succ (NIL) = NIL THEN RETURN EmptyShape ELSE RETURN HVSplit.T.shape (v, ax, n) END END HVSplitShape;
REVEAL FVHTile = SplitterVBT.T BRANDED OBJECT OVERRIDES shape := HVTileShape END; FVVTile = SplitterVBT.T BRANDED OBJECT OVERRIDES shape := HVTileShape END; PROCEDURE============================= Numeric ==============================HVTileShape (v: SplitterVBT.T; ax: Axis.T; n: CARDINAL): VBT.SizeRange = BEGIN IF v.succ (NIL) = NIL THEN RETURN EmptyShape ELSE RETURN SplitterVBT.T.shape (v, ax, n) END END HVTileShape;
REVEAL FVNumeric = NumericVBT.T BRANDED OBJECT OVERRIDES callback := NumericProc END; PROCEDURE============================= Menu ==============================NumericProc (self: FVNumeric; event: AnyEvent.T) = BEGIN TYPECASE event OF | AnyEvent.Mouse (mouse) => MouseProc (self, mouse.mouse) | AnyEvent.Key (key) => IF VBT.GetProp (self, TYPECODE (ClosureRef)) = NIL THEN NumericVBT.T.callback (self, event) ELSE KeyProc (self, key.key) END ELSE <* ASSERT FALSE *> END END NumericProc;
REVEAL FVMenu = AnchorSplit.T BRANDED OBJECT OVERRIDES pre := PreMenu END; PROCEDURE============================= Help ==============================PreMenu (v: AnchorSplit.T) = VAR mouse: VBT.MouseRec; BEGIN mouse.time := 0; MouseProc (v, mouse); AnchorSplit.T.pre (v); END PreMenu;
REVEAL FVHelp = AnchorHelpSplit.T BRANDED OBJECT END;============================= IntApply ============================
REVEAL FVIntApply = IntApplyPublic BRANDED OBJECT name : TEXT; (* name of destination VBT *) property: TEXT := NIL; (* name of property to set, if any *) OVERRIDES init := IntApplyInit; discard := IntApplyDiscard; misc := IntApplyMisc; END; PROCEDURE====================== Runtime support routines ====================IntApplyInit (v : FVIntApply; fv : VBT.T; ch : VBT.T; name : TEXT; property: TEXT := NIL): FVIntApply RAISES {Error} = BEGIN v.name := name; v.property := property; TYPECASE fv OF | T => TYPECASE ch OF | FVNumeric, FVScroller => IF VBT.GetProp(ch, TYPECODE(ClosureRef)) # NIL THEN RAISE Error("IntApply: child already has event handler attached"); END; VBT.PutProp(ch, NEW(ClosureRef, fv := fv, cl := NEW(IAClosure, ia := v))); ELSE RAISE Error("IntApply: child not a Numeric or Scroller"); END; ELSE RAISE Error("IntApply: not attached to a FormsVBT"); END; RETURN Filter.T.init(v, ch); END IntApplyInit; PROCEDUREIntApplyMisc (v: FVIntApply; READONLY cd: VBT.MiscRec) = VAR ch := Filter.Child(v); BEGIN IF cd.type = VBT.Deleted OR cd.type = VBT.Disconnected AND ch # NIL THEN (* remove the callback if its ours *) WITH cr = VBT.GetProp(ch, TYPECODE(ClosureRef)) DO IF cr # NIL AND ISTYPE(NARROW(cr, ClosureRef).cl, IAClosure) THEN VBT.RemProp(ch, TYPECODE(ClosureRef)) END; END; END; Filter.T.misc(v, cd); END IntApplyMisc; PROCEDUREIntApplyDiscard (v: FVIntApply) = VAR ch := Filter.Child(v); BEGIN IF ch # NIL THEN WITH cr = VBT.GetProp(ch, TYPECODE(ClosureRef)) DO IF cr # NIL AND ISTYPE(NARROW(cr, ClosureRef).cl, IAClosure) THEN VBT.RemProp(ch, TYPECODE(ClosureRef)) END; END; END; Filter.T.discard(v); END IntApplyDiscard; TYPE IAClosure = Closure OBJECT ia: FVIntApply; OVERRIDES apply := IAApply; END; PROCEDUREIAApply ( cl : IAClosure; fv : T; <* UNUSED *> name: TEXT; <* UNUSED*> time: VBT.TimeStamp) = VAR int: INTEGER; BEGIN TRY TYPECASE Filter.Child(cl.ia) OF | FVScroller (t) => int := ScrollerVBT.Get(t) | FVNumeric (t) => int := NumericVBT.Get(t) ELSE RAISE Unimplemented; END; IF cl.ia.property = NIL THEN PutInteger(fv, cl.ia.name, int); ELSE PutIntegerProperty(fv, cl.ia.name, cl.ia.property, int); END; EXCEPT | Error, Unimplemented => <* ASSERT FALSE *> END; END IAApply;
PROCEDURE*********************** Direct access ************************GetText (fv: T; name: TEXT): TEXT RAISES {Error, Unimplemented} = BEGIN TYPECASE GetVBT (fv, name) OF | FVBrowser (v) => VAR this: ListVBT.Cell; BEGIN IF v.getFirstSelected (this) THEN RETURN v.getValue (this) END; RETURN "" END | FVFileBrowser (v) => TRY RETURN FileBrowserVBT.GetFile (v) EXCEPT | FileBrowserVBT.Error (e) => RAISE Error (Fmt.F ("Error for %s: %s", e.path, e.text)) END | FVText (t) => RETURN TextVBT.Get (t) | FVTypescript (v) => TRY RETURN Rd.GetText (TypescriptVBT.GetRd (v), LAST (CARDINAL)) EXCEPT | Rd.Failure (ref) => RAISE Error (RdUtils.FailureText (ref)) | Thread.Alerted => RAISE Error ("Thread.Alerted") END | TextEditVBT.T (v) => RETURN TextPort.GetText (v.tp) | TextPort.T (v) => RETURN TextPort.GetText (v) | FVNumeric (v) => IF NumericVBT.IsEmpty (v) THEN RETURN "" ELSE RETURN Fmt.Int (NumericVBT.Get (v)) END ELSE RAISE Unimplemented END END GetText; PROCEDUREPutText (fv: T; name: TEXT; text: TEXT; append := FALSE) RAISES {Error, Unimplemented} = BEGIN TYPECASE GetVBT (fv, name) OF | FVBrowser (v) => VAR this: ListVBT.Cell; BEGIN IF v.getFirstSelected (this) THEN v.setValue (this, text) END END | FVFileBrowser (v) => TRY FileBrowserVBT.Set (v, text) EXCEPT FileBrowserVBT.Error (e) => RAISE Error (Fmt.F ("Error for %s: %s", e.path, e.text)) END | FVPixmap (t) => PixmapVBT.Put (t, GetPixmap (text, fv.path, NIL)) | FVImage (t) => VAR pm: ImageRd.T; len: INTEGER; BEGIN TRY Rd.Close (t.rd); t.rd := NIL EXCEPT | Rd.Failure (ref) => RAISE Error (RdUtils.FailureText (ref)) | Thread.Alerted => (* ignore *) END; TRY t.rd := Rsrc.Open (text, fv.path) EXCEPT | Rsrc.NotFound => RAISE Error("No such resource: " & text) END; TRY len := Rd.Length(t.rd) EXCEPT | Rd.Failure (ref) => RAISE Error(RdUtils.FailureText(ref)) | Thread.Alerted => (* ignore *) END; pm := t.get(); EVAL pm.init (t.rd, 0, len, t.op, NIL, t.gamma); t.put (pm, t.bg); END; | FVText (t) => IF append THEN TextVBT.Put (t, TextVBT.Get (t) & text) ELSE TextVBT.Put (t, text) END | FVTypescript (v) => TRY Wr.PutText (TypescriptVBT.GetWr (v), text) EXCEPT | Wr.Failure (ref) => RAISE Error (RdUtils.FailureText (ref)) | Thread.Alerted => (* ignore *) END | TextEditVBT.T (v) => IF append THEN TextPort.PutText (v.tp, text) ELSE TextPort.SetText (v.tp, text) END | TextPort.T (v) => IF append THEN TextPort.PutText (v, text) ELSE TextPort.SetText (v, text) END ELSE RAISE Unimplemented END END PutText; PROCEDUREGetInteger (fv: T; name: TEXT): INTEGER RAISES {Error, Unimplemented} = <* FATAL Split.NotAChild *> BEGIN TYPECASE GetVBT (fv, name) OF | FVScroller (t) => RETURN ScrollerVBT.Get (t) | FVNumeric (t) => RETURN NumericVBT.Get (t) | FVTSplit (t) => RETURN Split.Index (t, TSplit.GetCurrent (t)) | FVBrowser (t) => VAR this: ListVBT.Cell; BEGIN IF t.getFirstSelected (this) THEN RETURN this END; RAISE Error ("Nothing has been selected.") END ELSE RAISE Unimplemented END END GetInteger; PROCEDUREPutInteger (fv: T; name: TEXT; int: INTEGER) RAISES {Error, Unimplemented} = VAR vbt: VBT.T; <* FATAL Split.NotAChild *> BEGIN TYPECASE GetVBT (fv, name) OF | FVScroller (t) => ScrollerVBT.Put (t, int) | FVNumeric (t) => NumericVBT.Put (t, int) | FVTSplit (t) => IF 0 <= int AND int < Split.NumChildren (t) THEN vbt := Split.Nth (t, int); TSplit.SetCurrent (t, vbt); FirstFocus (vbt, GetTheEventTime (fv)) ELSE RAISE Error (Fmt.F ("%s is an illegal TSplit-index for %s.", Fmt.Int (int), name)) END | FVBrowser (t) => IF 0 <= int AND int < t.count () THEN t.selectOnly (int) ELSE RAISE Error (Fmt.F ("%s is an illegal selection for %s.", Fmt.Int (int), name)) END ELSE RAISE Unimplemented END END PutInteger; PROCEDUREGetIntegerProperty (fv: T; name, propertyName: TEXT): INTEGER RAISES {Error, Unimplemented} = VAR fvbt := GetVBT (fv, name); BEGIN IF Text.Equal(propertyName, "NorthEdge") THEN RETURN ROUND(FLOAT(VBT.Domain(fvbt).north)/ Pts.ToPixels(fvbt, 1.0, Axis.T.Ver)); ELSIF Text.Equal(propertyName, "SouthEdge") THEN RETURN ROUND(FLOAT(VBT.Domain(fvbt).south)/ Pts.ToPixels(fvbt, 1.0, Axis.T.Ver)); ELSIF Text.Equal(propertyName, "EastEdge") THEN RETURN ROUND(FLOAT(VBT.Domain(fvbt).east)/ Pts.ToPixels(fvbt, 1.0, Axis.T.Hor)); ELSIF Text.Equal(propertyName, "WestEdge") THEN RETURN ROUND(FLOAT(VBT.Domain(fvbt).west)/ Pts.ToPixels(fvbt, 1.0, Axis.T.Hor)); ELSE TYPECASE fvbt OF | TextEditVBT.T (v) => IF Text.Equal(propertyName, "Position") THEN RETURN TextPort.Index(v.tp) ELSIF Text.Equal(propertyName, "Length") THEN RETURN TextPort.Length(v.tp) END | FVNumeric (v) => IF Text.Equal (propertyName, "Min") THEN RETURN NumericVBT.GetMin (v) ELSIF Text.Equal (propertyName, "Max") THEN RETURN NumericVBT.GetMax (v) END | FVScroller (v) => IF Text.Equal (propertyName, "Min") THEN RETURN ScrollerVBT.GetMin (v) ELSIF Text.Equal (propertyName, "Max") THEN RETURN ScrollerVBT.GetMax (v) ELSIF Text.Equal (propertyName, "Step") THEN RETURN ScrollerVBT.GetStep (v) ELSIF Text.Equal (propertyName, "Thumb") THEN RETURN ScrollerVBT.GetThumb (v) END ELSE END; RAISE Unimplemented END; END GetIntegerProperty; PROCEDUREPutIntegerProperty (fv : T; name, p: TEXT; value : INTEGER) RAISES {Error, Unimplemented} = BEGIN TYPECASE GetVBT(fv, name) OF | TextEditVBT.T (v) => IF Text.Equal(p, "Position") THEN TextPort.Seek(v.tp, Cardinal(value, p)); RETURN ELSIF Text.Equal(p, "Normalize") THEN TextPort.Normalize(v.tp, Cardinal(value, p)); RETURN END | FVNumeric (v) => IF Text.Equal(p, "Min") THEN NumericVBT.PutBounds(v, value, NumericVBT.GetMax(v)); RETURN ELSIF Text.Equal(p, "Max") THEN NumericVBT.PutBounds(v, NumericVBT.GetMin(v), value); RETURN END | FVScroller (v) => IF Text.Equal(p, "Step") THEN ScrollerVBT.PutStep(v, Cardinal(value, p)); RETURN ELSE VAR min := ScrollerVBT.GetMin(v); max := ScrollerVBT.GetMax(v); thumb := ScrollerVBT.GetThumb(v); BEGIN IF Text.Equal(p, "Min") THEN min := value ELSIF Text.Equal(p, "Max") THEN max := value ELSIF Text.Equal(p, "Thumb") THEN thumb := Cardinal(value, p) END; ScrollerVBT.PutBounds(v, min, max, thumb); RETURN END END | FVVideo (v) => EVAL Cardinal(value, p); IF Text.Equal(p, "Quality") THEN IF value < FIRST(JVSink.Quality) OR LAST(JVSink.Quality) < value THEN RAISE Error("Video: quality must be between 0 and 15"); END; v.setQuality(value); ELSIF Text.Equal(p, "Width") THEN SetVideoSize(v, value, Axis.T.Hor); ELSIF Text.Equal(p, "Height") THEN SetVideoSize(v, value, Axis.T.Ver); ELSIF Text.Equal(p, "MSecs") THEN v.setMinFrameMSecs(value); END; RETURN | FVAudio (t) => IF Text.Equal(p, "Volume") THEN IF value < FIRST(Jva.Volume) OR LAST(Jva.Volume) < value THEN RAISE Error( Fmt.F("Audio: volume must be in range [%s..%s]", Fmt.Int(FIRST(Jva.Volume)), Fmt.Int(LAST(Jva.Volume)))); END; TRY AudioVBT.SetVolume(t, value); EXCEPT | Thread.Alerted => RAISE Error("PutInteger: Audio, Thread Alerted"); END (* TRY *); RETURN END (* IF *) ELSE END; RAISE Unimplemented END PutIntegerProperty; PROCEDUREGetRealProperty (fv: T; name, propertyName: TEXT): REAL RAISES {Error, Unimplemented} = VAR hscale, vscale: REAL; BEGIN TYPECASE GetVBT(fv, name) OF | ScaleFilter.T (v) => ScaleFilter.Get(v, hscale, vscale); IF Text.Equal(propertyName, "HScale") THEN RETURN hscale ELSIF Text.Equal(propertyName, "VScale") THEN RETURN vscale END ELSE END; RAISE Unimplemented END GetRealProperty; PROCEDUREPutRealProperty (fv: T; name, p: TEXT; value: REAL) RAISES {Error, Unimplemented} = VAR hscale, vscale: REAL; BEGIN TYPECASE GetVBT(fv, name) OF | ScaleFilter.T (v) => ScaleFilter.Get(v, hscale, vscale); IF Text.Equal(p, "HScale") THEN ScaleFilter.Scale(v, value, vscale); RETURN ELSIF Text.Equal(p, "VScale") THEN ScaleFilter.Scale(v, hscale, value); RETURN END ELSE END; RAISE Unimplemented END PutRealProperty; PROCEDUREGetBooleanProperty (fv: T; name, propertyName: TEXT): BOOLEAN RAISES {Error, Unimplemented} = BEGIN TYPECASE GetVBT(fv, name) OF | TextEditVBT.T (v) => IF Text.Equal(propertyName, "ReadOnly") THEN RETURN v.tp.getReadOnly() ELSE END; | ShadowedVBT.T (v) => IF Text.Equal(propertyName, "Raised") THEN RETURN ShadowedVBT.GetStyle (v) = Shadow.Style.Raised ELSIF Text.Equal(propertyName, "Flat") THEN RETURN ShadowedVBT.GetStyle (v) = Shadow.Style.Flat ELSIF Text.Equal(propertyName, "Lowered") THEN RETURN ShadowedVBT.GetStyle (v) = Shadow.Style.Lowered ELSIF Text.Equal(propertyName, "Ridged") THEN RETURN ShadowedVBT.GetStyle (v) = Shadow.Style.Ridged ELSIF Text.Equal(propertyName, "Chiseled") THEN RETURN ShadowedVBT.GetStyle (v) = Shadow.Style.Chiseled END ELSE END; RAISE Unimplemented END GetBooleanProperty; PROCEDUREPutBooleanProperty (fv : T; name, p: TEXT; value : BOOLEAN) RAISES {Error, Unimplemented} = BEGIN TYPECASE GetVBT(fv, name) OF | TextEditVBT.T (v) => IF Text.Equal(p, "ReadOnly") THEN v.tp.setReadOnly(value); RETURN END | ShadowedVBT.T (v) => IF Text.Equal(p, "Raised") THEN ShadowedVBT.SetStyle (v, Shadow.Style.Raised); RETURN ELSIF Text.Equal(p, "Flat") THEN ShadowedVBT.SetStyle (v, Shadow.Style.Flat); RETURN ELSIF Text.Equal(p, "Lowered") THEN ShadowedVBT.SetStyle (v, Shadow.Style.Lowered); RETURN ELSIF Text.Equal(p, "Ridged") THEN ShadowedVBT.SetStyle (v, Shadow.Style.Ridged); RETURN ELSIF Text.Equal(p, "Chiseled") THEN ShadowedVBT.SetStyle (v, Shadow.Style.Chiseled); RETURN END | FVVideo (v) => IF Text.Equal(p, "Synchronous") THEN v.setSynchronous(value); RETURN ELSIF Text.Equal(p, "Paused") THEN v.setPaused(value); RETURN ELSIF Text.Equal(p, "FixedSize") THEN v.setFixedSize(value); VBT.NewShape(v); RETURN ELSE RAISE Error("Video: unknown Boolean property " & p); END; | FVAudio (a) => TRY IF Text.Equal(p, "Mute") THEN AudioVBT.SetMute(a, value); RETURN ELSIF Text.Equal(p, "IgnoreMapping") THEN AudioVBT.SetIgnoreMapping(a, value); RETURN ELSE RAISE Error("Audio: unknown Boolean property " & p); END; EXCEPT | Thread.Alerted => RAISE Error("Audio: Put Boolean, Thread Alerted"); END; ELSE END; RAISE Unimplemented END PutBooleanProperty; PROCEDURECardinal (n: INTEGER; name: TEXT): CARDINAL RAISES {Error} = BEGIN IF n < 0 THEN RAISE Error (Fmt.F ("Value for %s, %s, should be a CARDINAL.", name, Fmt.Int (n))) ELSE RETURN n END END Cardinal; PROCEDURESetVideoSize (v: FVVideo; value: CARDINAL; ax: Axis.T) = VAR width, height: CARDINAL; BEGIN v.getSize(width, height); CASE ax OF | Axis.T.Hor => width := value; | Axis.T.Ver => height := value; END; v.setSize(width, height); VBT.NewShape(v); END SetVideoSize; PROCEDUREPutBoolean (fv: T; name: TEXT; val: BOOLEAN) RAISES {Error, Unimplemented} = BEGIN TYPECASE GetVBT (fv, name) OF | FVBoolean (b) => BooleanVBT.Put (b, val) | FVChoice (c) => IF val THEN ChoiceVBT.Put (c) ELSIF ChoiceVBT.Get (c) = c THEN ChoiceVBT.Clear (c) END ELSE RAISE Unimplemented END END PutBoolean; PROCEDUREPutChoice (fv: T; radioName, choiceName: TEXT) RAISES {Error, Unimplemented} = BEGIN TYPECASE GetVBT (fv, radioName) OF | FVRadio (r) => IF choiceName = NIL THEN WITH cur = ChoiceVBT.Selection (r.radio) DO IF cur # NIL THEN ChoiceVBT.Clear (cur) END END ELSE TYPECASE GetVBT (fv, choiceName) OF | FVChoice (c) => ChoiceVBT.Put (c) ELSE RAISE Error ("No Choice named " & choiceName) END END ELSE RAISE Unimplemented END END PutChoice;
PROCEDURE********************** Special controls **********************SetVBT (fv: T; name: TEXT; vbt: VBT.T) RAISES {Error} = BEGIN LOCK fv.mu DO IF fv.getVBT.put (name, vbt) THEN RAISE Error ("There is already a VBT named " & name) END END END SetVBT; PROCEDUREGetVBT (fv: T; name: TEXT): VBT.T RAISES {Error} = VAR result: REFANY; BEGIN LOCK fv.mu DO IF fv.getVBT.get (name, result) THEN RETURN result END; RAISE Error ("There is no VBT named " & name) END END GetVBT; PROCEDUREGetName (vbt: VBT.T): TEXT RAISES {Error} = VAR stateRef: REF State := VBT.GetProp(vbt, TYPECODE(REF State)); BEGIN IF stateRef # NIL AND stateRef.name # NIL THEN RETURN stateRef.name ELSE RAISE Error("VBT is not named") END END GetName; PROCEDURERemoveName (fv: T; vbt: VBT.T) RAISES {Error} = <* FATAL MultiSplit.NotAChild *> VAR stateRef: REF State; result: REFANY; BEGIN stateRef := VBT.GetProp(vbt, TYPECODE(REF State)); LOCK fv.mu DO IF stateRef # NIL AND stateRef.name # NIL THEN IF NOT fv.getVBT.delete(stateRef.name, result) THEN <* ASSERT FALSE *> END END END; (* now recursively remove the names of all descendants as well *) IF NOT LeafVBT(vbt) THEN VAR ch := MultiSplit.Succ (vbt, NIL); BEGIN WHILE ch # NIL DO RemoveName (fv, ch); ch := MultiSplit.Succ (vbt, ch) END END END END RemoveName; PROCEDUREDelete (fv: T; parent: TEXT; at: CARDINAL; count: CARDINAL := 1) RAISES {Error} = BEGIN TRY WITH p = GetVBT (fv, parent), at = MIN (at, MultiSplit.NumChildren (p)) DO FOR i := 1 TO MIN (count, MultiSplit.NumChildren (p) - at) DO WITH ch = MultiSplit.Nth(p, at) DO RemoveName (fv, ch); MultiSplit.Delete (p, ch) END END END EXCEPT | MultiSplit.NotAChild => RAISE Error ("Delete: No Split named " & parent) END END Delete; PROCEDUREInsertVBT (fvLocal: T; parent : TEXT; child : VBT.T; at : CARDINAL := LAST (CARDINAL)) RAISES {Error} = BEGIN TRY WITH p = GetVBT (fvLocal, parent), at = MIN (at, MultiSplit.NumChildren (p)) DO IF at = 0 THEN MultiSplit.Insert (p, NIL, child) ELSE MultiSplit.Insert (p, MultiSplit.Nth (p, at - 1), child) END END EXCEPT | MultiSplit.NotAChild => RAISE Error ("InsertVBT: No Split named " & parent) END END InsertVBT; PROCEDUREDeleteVBT (fv: T; parent: TEXT; at: CARDINAL; count: CARDINAL := 1) RAISES {Error} = BEGIN TRY WITH p = GetVBT (fv, parent), at = MIN (at, MultiSplit.NumChildren (p)) DO FOR i := 1 TO MIN (count, MultiSplit.NumChildren (p) - at) DO WITH ch = MultiSplit.Nth(p, at) DO MultiSplit.Delete (p, ch) END END END EXCEPT | MultiSplit.NotAChild => RAISE Error ("DeleteVBT: No Split named " & parent) END END DeleteVBT; PROCEDURELeafVBT (v: VBT.T): BOOLEAN = BEGIN RETURN NOT ISTYPE(v, VBT.Split) AND MultiClass.Resolve(v) = NIL END LeafVBT;
PROCEDURE*********************** Runtime properties ***********************TakeFocus (fv : T; name : TEXT; eventTime: VBT.TimeStamp; select := FALSE) RAISES {Error} = VAR vbt := GetVBT (fv, name); PROCEDURE focus (port: TextPort.T) = BEGIN IF TextPort.TryFocus (port, eventTime) AND select THEN TextPort.Select ( port, eventTime, 0, LAST (CARDINAL), replaceMode := TRUE) END END focus; BEGIN TYPECASE vbt OF | TextPort.T (v) => focus (v) | TextEditVBT.T (v) => focus (v.tp) | FVNumeric (v) => focus (v.typein) ELSE RAISE Error (name & " cannot take a keyboard focus") END END TakeFocus;
PROCEDURE************************ Generic interactors *********************GetTextProperty (fv: T; name, prop: TEXT): TEXT RAISES {Error, Unimplemented} = VAR vbt := GetVBT (fv, name); stateRef: REF State := VBT.GetProp (vbt, TYPECODE (REF State)); BEGIN IF Text.Equal (prop, "Select") THEN TYPECASE vbt OF | FVBrowser, FVMultiBrowser => VAR v := NARROW(vbt, ListVBT.T); cells := v.getAllSelected(); sel: TEXT; BEGIN IF NUMBER(cells^) # 0 THEN sel := v.getValue (cells[FIRST(cells^)]) ; FOR c := FIRST(cells^)+1 TO LAST(cells^) DO sel := sel & "\n" & v.getValue (cells[c]) END; RETURN sel ELSE RETURN NIL END END ELSE RAISE Unimplemented END ELSIF Text.Equal(prop, "Items") THEN TYPECASE vbt OF | FVBrowser, FVMultiBrowser => VAR v := NARROW (vbt, ListVBT.T); stringRep := ""; BEGIN IF v.count() # 0 THEN stringRep := v.getValue(0); FOR this := 1 TO v.count() - 1 DO stringRep := stringRep & "\n" & v.getValue(this) END; END; RETURN stringRep END ELSE RAISE Unimplemented END ELSIF Text.Equal(prop, "ActiveTarget") THEN TYPECASE vbt OF | FVSource (v) => WITH target = SourceVBT.GetTarget(v) DO IF target = NIL THEN RAISE Error ("No active target") END; RETURN GetName (target); END ELSE RAISE Unimplemented END ELSIF stateRef = NIL THEN RAISE Error (Fmt.F ("The form named \"%s\" has no properties", name)) ELSIF Text.Equal (prop, "Font") THEN RETURN stateRef.fontName ELSIF Text.Equal (prop, "LabelFont") THEN RETURN stateRef.labelFontName ELSE RAISE Unimplemented END END GetTextProperty; PROCEDUREPutTextProperty (fv: T; name, property: TEXT; t: TEXT) RAISES {Error, Unimplemented} = VAR vbt := GetVBT (fv, name); stateRef: REF State := VBT.GetProp (vbt, TYPECODE (REF State)); indx, ct, from : INTEGER; PROCEDURE setFont (v: TextPort.T) = BEGIN stateRef.fontName := t; stateRef.font := FindFont (t); stateRef.fontMetrics := NIL; v.setFont (stateRef.font) END setFont; BEGIN IF Text.Equal (property, "Select") THEN TYPECASE vbt OF | FVBrowser, FVMultiBrowser => VAR v := NARROW(vbt, ListVBT.T); BEGIN FOR this := 0 TO v.count () - 1 DO IF Text.Equal (v.getValue (this), t) THEN v.selectOnly (this); (* turn off previous selection if any *) RETURN END (* IF *) END; v.selectNone (); RETURN END (* BEGIN *) ELSE END (* TYPECASE *) ELSIF Text.Equal (property, "SelectAlso") AND ISTYPE(vbt, FVMultiBrowser) THEN (* Selects t if present, else noop *) VAR v := NARROW(vbt, ListVBT.T); BEGIN FOR this := 0 TO v.count () - 1 DO IF Text.Equal (v.getValue (this), t) THEN v.select (this, TRUE); (* turn off previous selection if any *) RETURN END END; RETURN; END (* BEGIN *) ELSIF Text.Equal (property, "ScrollToShow") THEN (* Scrolls to first occurrence of specified item. Noop if not present *) TYPECASE vbt OF | FVBrowser, FVMultiBrowser => VAR v := NARROW(vbt, ListVBT.T); BEGIN FOR this := 0 TO v.count () - 1 DO IF Text.Equal (v.getValue (this), t) THEN v.scrollToShow(this); RETURN END END; RETURN END (* BEGIN *) ELSE END (* TYPECASE *) ELSIF Text.Equal (property, "Items") THEN TYPECASE vbt OF | FVBrowser, FVMultiBrowser => (* FVBrowser and FVMultiBrowser are ListVBTs - interpret t as a sequence of cells demarcated by '\n'. Insert appropriately *) VAR v := NARROW(vbt, ListVBT.T); BEGIN v.removeCells(0, v.count()); (* empty listVBT *) indx := Text.FindChar(t, '\n', 0); from := 0; ct := 0; WHILE indx # -1 DO v.insertCells(ct, 1); v.setValue(ct, Text.Sub(t, from, indx-from)); from := indx+1; INC(ct); IF from < Text.Length(t) THEN indx := Text.FindChar(t, '\n', from); ELSE indx := -1 END END; IF from < Text.Length(t) THEN (* last cell *) v.insertCells(ct, 1); v.setValue(ct, Text.Sub(t, from)); END; v.selectNone (); RETURN END (* BEGIN *) ELSE END (* TYPECASE *) ELSIF stateRef = NIL THEN RAISE Error (Fmt.F ("The form named \"%s\" has no properties", name)) ELSIF Text.Equal (property, "Color") OR Text.Equal (property, "BgColor") THEN TRY PutColorProperty (fv, name, property, ColorName.ToRGB (t)); RETURN EXCEPT | ColorName.NotFound => RAISE Error ("No such color: " & t) END ELSIF Text.Equal (property, "Font") THEN TYPECASE vbt OF | TextPort.T (v) => setFont (v); RETURN | TextEditVBT.T (v) => setFont (v.tp); RETURN | NumericVBT.T (v) => setFont (v.typein); RETURN ELSE END ELSIF Text.Equal (property, "LabelFont") THEN TYPECASE vbt OF | FVText (v) => stateRef.labelFontName := t; stateRef.labelFont := FindFont (t); stateRef.labelFontMetrics := NIL; TextVBT.SetFont (v, stateRef.labelFont, TextVBT.GetQuad (v)); RETURN ELSE END END; RAISE Unimplemented END PutTextProperty; PROCEDUREGetColorProperty (fv: T; name, property: TEXT): Color.T RAISES {Error, Unimplemented} = VAR vbt := GetVBT (fv, name); stateRef: REF State := VBT.GetProp (vbt, TYPECODE (REF State)); BEGIN IF Text.Equal (property, "Color") THEN RETURN stateRef.fgRGB ELSIF Text.Equal (property, "BgColor") THEN RETURN stateRef.bgRGB ELSIF Text.Equal (property, "LightShadow") THEN RETURN stateRef.lightRGB ELSIF Text.Equal (property, "DarkShadow") THEN RETURN stateRef.darkRGB ELSE RAISE Unimplemented END END GetColorProperty; PROCEDUREPutColorProperty ( fv : T; name, property: TEXT; READONLY color : Color.T) RAISES {Error, Unimplemented} = PROCEDURE setColor (v: TextPort.T) = BEGIN v.setColorScheme ( PaintOp.MakeColorScheme (stateRef.bgOp, stateRef.fgOp)) END setColor; VAR vbt := GetVBT (fv, name); stateRef: REF State := VBT.GetProp (vbt, TYPECODE (REF State)); BEGIN IF Text.Equal (property, "Color") THEN stateRef.fgRGB := color; stateRef.fgOp := PaintOp.FromRGB (color.r, color.g, color.b, PaintOp.Mode.Accurate); TYPECASE vbt OF | TextureVBT.T (v) => VAR op: PaintOp.T; txt: Pixmap.T; nwAlign: BOOLEAN; BEGIN TextureVBT.Get(v, op, txt, nwAlign); TextureVBT.Set (v, PaintOp.Pair(stateRef.bgOp, stateRef.fgOp), txt, nwAlign) END; | FVBar (v) => TextureVBT.Set (Filter.Child (v), stateRef.fgOp) | FVBorder (v) => BorderedVBT.SetColor (v, stateRef.fgOp) | TextPort.T (v) => setColor (v) | TextEditVBT.T (v) => setColor (v.tp) | NumericVBT.T (v) => setColor (v.typein) | PixmapVBT.T (v) => PixmapVBT.SetColors (v, PaintOp.Pair (stateRef.bgOp, stateRef.fgOp), stateRef.bgOp); | FVText (v) => TextVBT.SetFont ( v, TextVBT.GetFont (v), PaintOp.MakeColorQuad (stateRef.bgOp, stateRef.fgOp)) ELSE RAISE Unimplemented END ELSIF Text.Equal (property, "BgColor") THEN stateRef.bgRGB := color; stateRef.bgOp := PaintOp.FromRGB (color.r, color.g, color.b, PaintOp.Mode.Accurate); TYPECASE vbt OF | TextureVBT.T (v) => VAR op: PaintOp.T; txt: Pixmap.T; nwAlign: BOOLEAN; BEGIN TextureVBT.Get(v, op, txt, nwAlign); TextureVBT.Set (v, PaintOp.Pair(stateRef.bgOp, stateRef.fgOp), txt, nwAlign) END; | FVGlue (v) => TextureVBT.Set (Filter.Child (v), stateRef.bgOp) | FVRim (v) => BorderedVBT.SetColor (v, stateRef.bgOp) | TextPort.T (v) => setColor (v) | TextEditVBT.T (v) => setColor (v.tp) | NumericVBT.T (v) => setColor (v.typein) | PixmapVBT.T (v) => PixmapVBT.SetColors (v, PaintOp.Pair (stateRef.bgOp, stateRef.fgOp), stateRef.bgOp); | FVText (v) => TextVBT.SetFont ( v, TextVBT.GetFont (v), PaintOp.MakeColorQuad (stateRef.bgOp, stateRef.fgOp)) ELSE RAISE Unimplemented END ELSE RAISE Unimplemented END END PutColorProperty; VAR fontCache := NEW (TextIntTbl.Default).init (); fontCacheMu := NEW(MUTEX); PROCEDUREFindFont (fontname: TEXT): Font.T = VAR fontnumber: INTEGER; BEGIN LOCK fontCacheMu DO IF fontCache.get(fontname, fontnumber) THEN RETURN Font.T{fontnumber} ELSE WITH f = Font.FromName(ARRAY OF TEXT{fontname}) DO EVAL fontCache.put(fontname, f.fnt); RETURN f END END END END FindFont; PROCEDUREMakeActive (fv: T; name: TEXT; cursor := "") RAISES {Error} = BEGIN SetReactivity(fv, name, ReactivityVBT.State.Active, cursor); END MakeActive; PROCEDUREMakePassive (fv: T; name: TEXT; cursor := "") RAISES {Error} = BEGIN SetReactivity(fv, name, ReactivityVBT.State.Passive, cursor); END MakePassive; PROCEDUREMakeDormant (fv: T; name: TEXT; cursor := "") RAISES {Error} = BEGIN SetReactivity(fv, name, ReactivityVBT.State.Dormant, cursor); END MakeDormant; PROCEDUREMakeVanish (fv: T; name: TEXT; cursor:= "") RAISES {Error} = BEGIN SetReactivity(fv, name, ReactivityVBT.State.Vanish, cursor); END MakeVanish; PROCEDURESetReactivity (fv : T; name : Text.T; state : ReactivityVBT.State; cursor: TEXT ) RAISES {Error} = VAR curs: Cursor.T; BEGIN IF Text.Empty(cursor) THEN curs := Cursor.DontCare ELSE curs := Cursor.FromName(ARRAY OF TEXT{cursor}) END; ReactivityVBT.Set(FindReactivityVBT(fv, name), state, curs); END SetReactivity; PROCEDUREIsActive (fv: T; name: Text.T): BOOLEAN RAISES {Error} = BEGIN RETURN TestReactivity(fv, name, ReactivityVBT.State.Active); END IsActive; PROCEDUREIsPassive (fv: T; name: Text.T): BOOLEAN RAISES {Error} = BEGIN RETURN TestReactivity(fv, name, ReactivityVBT.State.Passive); END IsPassive; PROCEDUREIsDormant (fv: T; name: Text.T): BOOLEAN RAISES {Error} = BEGIN RETURN TestReactivity(fv, name, ReactivityVBT.State.Dormant); END IsDormant; PROCEDUREIsVanished (fv: T; name: Text.T): BOOLEAN RAISES {Error} = BEGIN RETURN TestReactivity(fv, name, ReactivityVBT.State.Vanish); END IsVanished; PROCEDURETestReactivity (fv: T; name: Text.T; state: ReactivityVBT.State): BOOLEAN RAISES {Error} = BEGIN RETURN state = ReactivityVBT.Get (FindReactivityVBT (fv, name)); END TestReactivity; PROCEDUREFindReactivityVBT (fv: T; name: Text.T): FVFilter RAISES {Error} = VAR v := GetVBT (fv, name); BEGIN WHILE v # NIL DO TYPECASE v OF FVFilter => RETURN v ELSE END; v := VBT.Parent (v); END; RAISE Error ("Cannot find FVFilter"); END FindReactivityVBT; PROCEDUREGetBoolean (fv: T; name: TEXT): BOOLEAN RAISES {Error, Unimplemented} = BEGIN TYPECASE GetVBT (fv, name) OF | FVBoolean (b) => RETURN BooleanVBT.Get (b) | FVChoice (c) => RETURN ChoiceVBT.Get (c) = c ELSE RAISE Unimplemented END END GetBoolean; PROCEDUREGetChoice (fv: T; radioName: TEXT): TEXT RAISES {Error, Unimplemented} = BEGIN TYPECASE GetVBT (fv, radioName) OF | FVRadio (r) => TYPECASE ChoiceVBT.Selection (r.radio) OF | NULL => RETURN NIL | FVChoice (c) => RETURN c.name ELSE END ELSE END; RAISE Unimplemented END GetChoice; PROCEDUREMakeSelected (fv: T; choiceName: TEXT) RAISES {Error} = BEGIN TYPECASE GetVBT (fv, choiceName) OF | FVChoice (c) => ChoiceVBT.Put (c) ELSE RAISE Error ("No Choice named " & choiceName) END END MakeSelected; PROCEDUREIsSelected (fv: T; choiceName: TEXT): BOOLEAN RAISES {Error} = BEGIN TYPECASE GetVBT (fv, choiceName) OF | FVChoice (c) => RETURN ChoiceVBT.Get (c) = c ELSE RAISE Error ("No Choice named " & choiceName) END END IsSelected;
PROCEDURE*********************** Debugging tools ***********************PutGeneric (fv: T; genericName: TEXT; vbt: VBT.T) RAISES {Error} = BEGIN TYPECASE GetVBT (fv, genericName) OF | FVGeneric (v) => IF vbt = NIL THEN EVAL Filter.Replace (v, NIL); FlexVBT.Set (v, EMPTYSHAPE) ELSE EVAL Filter.Replace (v, vbt); FlexVBT.Set (v, FlexVBT.Default) END; RETURN ELSE RAISE Error ("No Generic named " & genericName) END END PutGeneric; PROCEDUREGetGeneric (fv: T; genericName: TEXT): VBT.T RAISES {Error} = BEGIN TYPECASE GetVBT (fv, genericName) OF | FVGeneric (v) => RETURN Filter.Child (v) ELSE RAISE Error ("No Generic named " & genericName) END END GetGeneric;
PROCEDUREToText (x : REFANY; maxDepth : CARDINAL := LAST (CARDINAL); maxLength: CARDINAL := LAST (CARDINAL) ): TEXT = BEGIN TYPECASE x OF | NULL => RETURN "NIL" | Atom.T (sym) => RETURN Atom.ToText (sym) | TEXT (t) => RETURN t ELSE WITH wr = TextWr.New () DO TRY Sx.Print (wr, x, maxDepth, maxLength); RETURN TextWr.ToText (wr) EXCEPT | Thread.Alerted, Sx.PrintError, Wr.Failure => RETURN "<Unprintable expression>" END END END END ToText; PROCEDURENamedVBTs (t: T): RefList.T = VAR name: TEXT; vbt : REFANY; res : RefList.T := NIL; iter := t.getVBT.iterateOrdered (FALSE); BEGIN WHILE iter.next (name, vbt) DO Push (res, RefList.List2 (name, vbt)) END; RETURN res END NamedVBTs; <*UNUSED *> (* except during debugging! *) PROCEDUREDumpTable (fv: T) = VAR value : REFANY; key : TEXT; alist, pair: RefList.T; BEGIN alist := NamedVBTs (fv); WHILE alist # NIL DO pair := Pop (alist); key := Pop (pair); value := pair.head; IO.Put (key); IO.Put (" -> "); IO.Put (RTTypeSRC.TypeName (value)); IO.Put ("\n") END END DumpTable; PROCEDUREGetAttachments (fv: T): RefList.T = VAR key : TEXT; value : REFANY; alist : RefList.T := NIL; iter := fv.getVBT.iterate (); property: REFANY; BEGIN WHILE iter.next (key, value) DO property := VBT.GetProp (value, TYPECODE (ClosureRef)); IF property # NIL THEN Push (alist, RefList.List2 (key, property)) END END; RETURN alist END GetAttachments; PROCEDURESetAttachments (fv: T; alist: RefList.T) RAISES {Error} = VAR name : TEXT; attachment: ClosureRef; pair : RefList.T; BEGIN WHILE alist # NIL DO pair := Pop (alist); name := pair.head; attachment := pair.tail.head; Attach (fv, name, attachment.cl) END END SetAttachments; PROCEDUREInitRuntime () = BEGIN MakeEventMiscCodeType := VBT.GetMiscCodeType ("FVRuntime.MakeEvent"); MakeEventSelection := VBT.GetSelection ("FVRuntime.MakeEvent"); cleanState.fgOp := PaintOp.FromRGB ( cleanState.fgRGB.r, cleanState.fgRGB.g, cleanState.fgRGB.b, PaintOp.Mode.Accurate, bw := PaintOp.BW.UseFg); cleanState.bgOp := PaintOp.FromRGB ( cleanState.bgRGB.r, cleanState.bgRGB.g, cleanState.bgRGB.b, PaintOp.Mode.Accurate, bw := PaintOp.BW.UseBg); cleanState.lightOp := PaintOp.FromRGB ( cleanState.lightRGB.r, cleanState.lightRGB.g, cleanState.lightRGB.b, PaintOp.Mode.Accurate, bw := PaintOp.BW.UseFg); cleanState.darkOp := PaintOp.FromRGB ( cleanState.darkRGB.r, cleanState.darkRGB.g, cleanState.darkRGB.b, PaintOp.Mode.Accurate, bw := PaintOp.BW.UseFg); cleanState.fontMetrics := DefaultFontMetrics; cleanState.fontName := MetricsToName (cleanState.fontMetrics); cleanState.font := Font.FromName (ARRAY OF TEXT {cleanState.fontName}); cleanState.labelFontMetrics := DefaultLabelFontMetrics; cleanState.labelFontName := MetricsToName (cleanState.labelFontMetrics); cleanState.labelFont := Font.FromName (ARRAY OF TEXT {cleanState.labelFontName}); cleanState.shadow := Shadow.New (cleanState.shadowSz, cleanState.bgOp, cleanState.fgOp, cleanState.lightOp, cleanState.darkOp); (* Initial state.zsplit are set in Init. *) END InitRuntime; BEGIN (* From the FormsVBT language itself: *) qBOA := Atom.FromText ("BOA"); qName := Atom.FromText ("Name"); qValue := Atom.FromText ("Value"); (* "Internal" symbols for macros: *) qBackquote := Atom.FromText (" backquote "); qComma := Atom.FromText (" comma "); qCommaAtsign := Atom.FromText (" comma-atsign "); qQuote := Atom.FromText (" quote "); InitParser (); InitRuntime (); Macro.Init () END FVRuntime.