<* PRAGMA LL *> MODULE; IMPORT Cursor, Fmt, ISOChar, KeyboardKey, KeyFilter, MText, MTextRd, MTextUnit, PaintOp, Rd, RdUtils, Rect, Stdio, Text, TextPort, Thread, TypescriptVBT, VBT, VTDef, VText, Wr; FROM TextPort IMPORT Extent, NotFound; REVEAL Model = PublicModel BRANDED OBJECT OVERRIDES init := Init; close := Close; arrowKey := ArrowKey; clear := Clear; cut := Cut; extend := Extend; getSelectedText := GetSelectedText; getSelection := GetSelection; highlight := Highlight; misc := Misc; paste := Paste; position := Position; putSelectedText := PutSelectedText; read := Read; seek := Seek; select := Select; takeSelection := TakeSelection; write := Write; END; PROCEDURE TextPortClass Init ( m : Model; <* UNUSED *> cs : PaintOp.ColorScheme; keyfilter: KeyFilter.T ): Model = BEGIN m.keyfilter := keyfilter; RETURN m END Init; PROCEDUREClose (m: Model) = CONST name = "Close"; VAR v := m.v; BEGIN VBT.Release (v, VBT.KBFocus); VBT.Release (v, VBT.Source); VBT.Release (v, VBT.Target); TRY VText.SwitchCaret (v.vtext, VText.OnOffState.Off); FOR t := Primary TO Secondary DO IF m.selection [t] # NIL THEN VText.DeleteInterval (m.selection [t].interval) END END EXCEPT | VTDef.Error (ec) => v.vterror (name, ec) | Rd.EndOfFile => v.rdeoferror (name) | Rd.Failure (ref) => v.rdfailure (name, ref) | Thread.Alerted => END END Close; PROCEDURECut (m: Model; time: VBT.TimeStamp) = BEGIN m.copy (time); m.clear () END Cut; PROCEDUREClear (m: Model) = BEGIN m.putSelectedText ("", Primary) END Clear;
* Caret and interval-twiddling
PROCEDUREArrowKey (m: Model; READONLY cd: VBT.KeyRec) = BEGIN CASE cd.whatChanged OF | KeyboardKey.Left => ToPrevChar (m.v) | KeyboardKey.Right => ToNextChar (m.v) | KeyboardKey.Up => UpOneLine (m.v) | KeyboardKey.Down => DownOneLine (m.v) ELSE <* ASSERT FALSE *> END END ArrowKey; PROCEDUREFindNextWord (v: T): Extent = VAR right := LocateNextWordBoundary (v); left := MTextUnit.StartOfRun (v.vtext.mtext, right); BEGIN IF left >= 0 THEN RETURN Extent {left, right} ELSE RETURN NotFound END END FindNextWord; PROCEDUREFindPrevWord (v: T): Extent = VAR left := LocateNextWordBoundary (v, reverse := TRUE); right := MTextUnit.EndOfRun (v.vtext.mtext, left); BEGIN IF right >= 0 THEN RETURN Extent {left, right} ELSE RETURN NotFound END END FindPrevWord; VAR readerLock := NEW (MUTEX); reader := NEW (MTextRd.T); <* LL = readerLock *> PROCEDURELocateNextWordBoundary (v: T; reverse := FALSE): CARDINAL = VAR index := v.index (); rd : Rd.T; c : CHAR; count := 0; BEGIN LOCK readerLock DO TRY rd := reader.init (v.vtext.mtext, index, reverse := reverse); REPEAT c := Rd.GetChar (rd); INC (count); UNTIL c IN ISOChar.AlphaNumerics; REPEAT c := Rd.GetChar (rd); INC (count); UNTIL NOT c IN ISOChar.AlphaNumerics; DEC (count) EXCEPT Rd.EndOfFile, Rd.Failure, Thread.Alerted => END END; IF reverse THEN RETURN index - count ELSE RETURN index + count END END LocateNextWordBoundary; PROCEDUREAtCRLF (v: T; index: INTEGER): BOOLEAN = VAR m := v.vtext.mtext; BEGIN RETURN (index+1 < MText.Length (m)) AND MText.GetChar (m, index) = '\r' AND MText.GetChar (m, index+1) = '\n'; END AtCRLF; PROCEDUREToPrevChar (v: T) = VAR index := v.index (); BEGIN IF index > 1 AND AtCRLF (v, index-2) THEN DEC (index); END; IF index > 0 THEN v.m.seek (index - 1); END END ToPrevChar; PROCEDUREToNextChar (v: T) = VAR index := v.index (); BEGIN IF AtCRLF (v, index) THEN INC (index); END; v.m.seek (index + 1) END ToNextChar; PROCEDUREToStartOfLine (v: T) = BEGIN v.m.seek (MTextUnit.LineInfo (v.vtext.mtext, v.index ()).left) END ToStartOfLine; PROCEDUREToEndOfLine (v: T) = BEGIN v.m.seek (MTextUnit.LineInfo (v.vtext.mtext, v.index ()).rightEnd) END ToEndOfLine; PROCEDUREToOtherEnd (v: T) = VAR x := v.m.getSelection (); BEGIN IF v.index () = x.l THEN v.m.seek (x.r) ELSE v.m.seek (x.l) END END ToOtherEnd;
* Vertical movement commands.
PROCEDUREUpOneLine (v: T) = BEGIN GoUpDown (v, goUp := TRUE) END UpOneLine; PROCEDUREDownOneLine (v: T) = BEGIN GoUpDown (v, goUp := FALSE) END DownOneLine; PROCEDUREGoUpDown (v: T; goUp: BOOLEAN) = VAR mtext := v.vtext.mtext; e : MTextUnit.Extent := MTextUnit.LineExtent (mtext, v.index ()); BEGIN (* Vertical movement commands *) IF v.lastCmdKind # CommandKind.VertCommand THEN v.wishCol := v.index () - e.left END; v.thisCmdKind := CommandKind.VertCommand; IF goUp THEN IF e.left = 0 THEN RETURN END; e := MTextUnit.LineExtent (mtext, e.left - 1) ELSE e.left := e.right END; v.m.seek ( MIN (e.left + v.wishCol, MTextUnit.LineInfo (mtext, e.left).rightEnd)) END GoUpDown;
* Deletion commands.
PROCEDUREDeletePrevChar (v: T): Extent = VAR here := v.index (); BEGIN IF here > 1 AND AtCRLF (v, here - 2) THEN RETURN v.replace (here - 2, here, "") ELSIF here > 0 THEN RETURN v.replace (here - 1, here, "") ELSE RETURN NotFound END END DeletePrevChar; PROCEDUREDeleteNextChar (v: T): Extent = VAR here := v.index (); BEGIN IF AtCRLF (v, here) THEN RETURN v.replace (here, here + 2, "") ELSE RETURN v.replace (here, here + 1, "") END; END DeleteNextChar; PROCEDUREDeleteToEndOfWord (v: T): Extent = VAR start := v.index (); end := LocateNextWordBoundary (v); BEGIN RETURN v.replace (start, end, "") END DeleteToEndOfWord; PROCEDUREDeleteToStartOfWord (v: T): Extent = VAR end := v.index (); start := LocateNextWordBoundary (v, reverse := TRUE); BEGIN RETURN v.replace (start, end, "") END DeleteToStartOfWord; PROCEDUREDeleteCurrentWord (v: T): Extent = PROCEDURE WordAt (mtext: MText.T; index: CARDINAL): Extent = (** A word is - a run of alphanumerics - a run of blanks - any other single character We find a word such that left <= index < right. **) VAR e: MTextUnit.Extent; BEGIN e := MTextUnit.RunExtent (mtext, index, ISOChar.AlphaNumerics); IF e.inside THEN RETURN Extent {e.left, e.right} ELSE e := MTextUnit.RunExtent (mtext, index, ISOChar.Spaces); IF e.inside THEN RETURN Extent {e.left, e.right} ELSE RETURN Extent {index, index + 1} END END END WordAt; VAR extent := WordAt (v.vtext.mtext, v.index ()); BEGIN RETURN v.replace (extent.l, extent.r, "") END DeleteCurrentWord; PROCEDUREDeleteToStartOfLine (v: T): Extent = VAR here := v.index (); left := MTextUnit.StartOfLine (v.vtext.mtext, here); BEGIN IF here = left THEN (* Already at the start of line; delete preceding newline if any. *) RETURN DeletePrevChar (v); ELSE RETURN v.replace (left, here, "") END END DeleteToStartOfLine; PROCEDUREDeleteToEndOfLine (v: T): Extent = VAR here := v.index (); info := MTextUnit.LineInfo (v.vtext.mtext, here); BEGIN IF here = info.rightEnd THEN (* We're already at the end of line. *) RETURN v.replace (here, info.right, "") ELSE RETURN v.replace (here, info.rightEnd, "") END END DeleteToEndOfLine; PROCEDUREDeleteCurrentLine (v: T): Extent = VAR here := v.index (); info := MTextUnit.LineInfo (v.vtext.mtext, here); BEGIN RETURN v.replace (info.left, info.right, "") END DeleteCurrentLine;
* Other modifications.
PROCEDURESwapChars (v: T) = (* Swap the two characters to the left of the caret. *) VAR here := v.index (); two : ARRAY [0 .. 1] OF CHAR; BEGIN IF here - 2 < v.typeinStart THEN RETURN END; two [1] := MText.GetChar (v.vtext.mtext, here - 2); two [0] := MText.GetChar (v.vtext.mtext, here - 1); EVAL v.replace (here - 2, here, Text.FromChars (two)) END SwapChars; PROCEDUREInsertNewline (v: T) = (* Insert a newline without moving the cursor. *) VAR here := v.index (); BEGIN v.m.seek (v.replace (here, here, Wr.EOL).l) END InsertNewline;
* Searching
PROCEDURE*************** Scrolling the display *******************Find (v: T; pattern: TEXT; loc := Loc.Next; ignoreCase := TRUE): Extent = CONST name = "Find"; VAR len := Text.Length (pattern); found: INTEGER; start := v.index (); can : RdUtils.Canonicalize := NIL; BEGIN IF len = 0 THEN RETURN NotFound END; IF ignoreCase THEN can := ToUpperCaseISO END; TRY CASE loc OF | Loc.First, Loc.Next => IF loc = Loc.First THEN start := 0 END; LOCK readerLock DO EVAL reader.init (v.vtext.mtext, start := start); found := RdUtils.Find (reader, pattern, can); IF found >= 0 THEN RETURN Extent {found, found + len} END END | Loc.Prev => LOCK readerLock DO EVAL reader.init (v.vtext.mtext, start := start, rangeStart := 0, rangeEnd := start, reverse := TRUE); found := RdUtils.Find (reader, TextReverse (pattern), can); IF found >= 0 THEN RETURN Extent {start - found - len, start - found} END (* IF *) END (* LOCK *) END (* CASE *) EXCEPT | Rd.Failure (ref) => v.rdfailure (name, ref) | Thread.Alerted => END; RETURN NotFound END Find; PROCEDUREToUpperCaseISO (ch: CHAR): CHAR = BEGIN RETURN ISOChar.Upper [ch] END ToUpperCaseISO; PROCEDUREFindAndSelect (v : T; pattern: TEXT; time : VBT.TimeStamp; loc := Loc.Next; ignoreCase := TRUE ) = CONST map = ARRAY Loc OF VText.WhichEnd { VText.WhichEnd.Right, VText.WhichEnd.Right, VText.WhichEnd.Left}; VAR ext := Find (v, pattern, loc, ignoreCase); BEGIN IF ext = TextPort.NotFound THEN v.notFound () ELSE v.m.select (time, ext.l, ext.r, replaceMode := TRUE, caretEnd := map [loc]); v.normalize (ext.l) END END FindAndSelect; PROCEDURETextReverse (t: TEXT): TEXT = VAR buf := NEW (REF ARRAY OF CHAR, Text.Length (t)); i := FIRST (buf^); j := LAST (buf^); c : CHAR; BEGIN Text.SetChars (buf^, t); WHILE i < j DO c := buf [i]; buf [i] := buf [j]; buf [j] := c; INC (i); DEC (j) END; RETURN Text.FromChars (buf^) END TextReverse; PROCEDURETextLowerCase (t: TEXT): TEXT = VAR buf := NEW (REF ARRAY OF CHAR, Text.Length (t)); BEGIN Text.SetChars (buf^, t); FOR i := FIRST (buf^) TO LAST (buf^) DO buf [i] := ISOChar.Lower [buf [i]] END; RETURN Text.FromChars (buf^) END TextLowerCase; PROCEDUREGetRange ( v : T; READONLY cp : VBT.CursorPosition; mode: VText.SelectionMode ): IRange = <* LL = v.mu *> CONST name = "GetRange"; VAR whichEnd : VText.WhichEnd; rect : Rect.T; lineNum : CARDINAL; ch : CHAR; atEnd : BOOLEAN; lt, md, rt: CARDINAL; e : MTextUnit.Extent; VAR vt := v.vtext; BEGIN TRY VText.PounceLocate (vt, 0, cp.pt, lt, rt, lineNum, ch); atEnd := lt = rt; IF atEnd AND lt > 0 THEN DEC (lt) END; CASE mode OF | VText.SelectionMode.ParagraphSelection => (* paragraph strategy differs from VText's strategy *) e := MTextUnit.ParagraphExtent (vt.mtext, lt); lt := e.left; rt := e.right | VText.SelectionMode.LineSelection => e := MTextUnit.LineExtent (vt.mtext, lt); lt := e.left; rt := e.right ELSE VText.PounceExtend (vt, 0, lt, rt, lineNum, ch, mode) END; whichEnd := VText.PounceEncage (vt, 0, cp.pt, lt, md, rt, rect); VBT.SetCage (vt.vbt, VBT.CageFromRect (rect, cp)); IF ( mode = VText.SelectionMode.CharSelection OR mode = VText.SelectionMode.WordSelection) AND ch # '\n' AND (whichEnd = VText.WhichEnd.Right OR atEnd) THEN md := rt ELSE md := lt END EXCEPT | VTDef.Error (ec) => v.vterror (name, ec) | Rd.EndOfFile => v.rdeoferror (name) | Rd.Failure (ref) => v.rdfailure (name, ref) | Thread.Alerted => END; RETURN IRange {lt, md, rt} END GetRange;
PROCEDURE**************************** Undo *******************************Scroll (v: T; delta: INTEGER) RAISES {VTDef.Error, Rd.EndOfFile, Rd.Failure, Thread.Alerted} = VAR vt := v.vtext; p := VText.CaretIndex (vt); BEGIN VText.Scroll (vt, 0, delta); IF VText.InRegion (vt, 0, p) THEN (* skip *) ELSIF delta < 0 THEN VText.MoveCaret (vt, VText.UpLines (vt, p, -delta, 0)) ELSE VText.MoveCaret (vt, VText.StartIndex (vt, 0)) END; VBT.Mark (v) END Scroll; PROCEDUREScrollOneLineUp (v: T) RAISES {VTDef.Error, Rd.EndOfFile, Rd.Failure, Thread.Alerted} = BEGIN Scroll (v, 1) END ScrollOneLineUp; PROCEDUREScrollOneLineDown (v: T) RAISES {VTDef.Error, Rd.EndOfFile, Rd.Failure, Thread.Alerted} = BEGIN Scroll (v, -1) END ScrollOneLineDown; PROCEDUREScrollOneScreenUp (v: T) RAISES {VTDef.Error, Rd.EndOfFile, Rd.Failure, Thread.Alerted} = BEGIN Scroll (v, MAX (1, v.vtext.region [0].nLines - 2)) END ScrollOneScreenUp; PROCEDUREScrollOneScreenDown (v: T) RAISES {VTDef.Error, Rd.EndOfFile, Rd.Failure, Thread.Alerted} = BEGIN Scroll (v, -MAX (1, v.vtext.region [0].nLines - 2)) END ScrollOneScreenDown;
REVEAL UndoRec = BRANDED OBJECT begin, end: VText.Index := 0; text := ""; next, prev: UndoRec := NIL END; PROCEDURE******************** Default methods ****************************AddToUndo (v: T; begin, end: CARDINAL; newText: TEXT) = <* LL = v.mu *> VAR n := Text.Length (newText); r := v.cur; vv: VBT.T := v; (* ISTYPE demands that v be assignable to TypescriptVBT.T*) BEGIN IF v.readOnly OR begin = end AND n = 0 OR ISTYPE (vv, TypescriptVBT.T) THEN RETURN END; IF r.prev # NIL AND begin = end AND n = 1 AND r.prev.end = begin AND Text.GetChar (newText, 0) IN ISOChar.Graphics THEN (* It's straight typing. Extend the previous record. *) INC (r.prev.end) ELSE r.begin := begin; r.end := begin + n; r.text := MText.GetText (v.vtext.mtext, begin, end); IF r.next = NIL THEN r.next := NEW (UndoRec, prev := r) END; v.cur := r.next END; TraceUndo (v) END AddToUndo; VAR tracingUndo := FALSE; (* For runtime debugging *) PROCEDURETraceUndo (v: T) = <* LL = v.mu *> <* FATAL Wr.Failure, Thread.Alerted *> VAR r := v.cur; t: TEXT; n: INTEGER := 0; BEGIN IF NOT tracingUndo THEN RETURN END; WHILE r.prev # NIL DO r := r.prev; INC (n) END; WHILE r.next # NIL DO t := r.text; IF Text.Length (t) > 20 THEN t := Text.Sub (t, 0, 20) & "..." END; IF n = 0 THEN Wr.PutText (Stdio.stderr, "***** ") END; Wr.PutText (Stdio.stderr, Fmt.F ("[%s .. %s] = \"%s\"\n", Fmt.Int (r.begin), Fmt.Int (r.end), t)); r := r.next; DEC (n) END; Wr.PutText (Stdio.stderr, "-------------------\n") END TraceUndo; PROCEDUREUndo (v: T) = BEGIN IF v.cur.prev # NIL THEN v.cur := v.cur.prev; Exchange (v) END END Undo; PROCEDURERedo (v: T) = BEGIN IF v.cur.next # NIL THEN Exchange (v); v.cur := v.cur.next END END Redo; PROCEDUREUndoCount (v: T): CARDINAL = <* LL < v.mu *> VAR n: CARDINAL := 0; r: UndoRec; BEGIN LOCK v.mu DO r := v.cur; WHILE r.prev # NIL DO INC (n); r := r.prev END; RETURN n END END UndoCount; PROCEDURERedoCount (v: T): CARDINAL = <* LL < v.mu *> VAR n: CARDINAL := 0; r: UndoRec; BEGIN LOCK v.mu DO r := v.cur; WHILE r.next # NIL DO INC(n); r := r.next END; RETURN n END END RedoCount; PROCEDUREResetUndo (v: T) = <* LL < v.mu *> BEGIN LOCK v.mu DO v.cur := NEW(UndoRec) END END ResetUndo; PROCEDUREExchange (v: T) = <* LL = v.mu *> CONST name = "Undo"; VAR prev := ""; r := v.cur; BEGIN IF r.begin < r.end AND r.begin < v.length () THEN prev := v.getText (r.begin, r.end) END; v.normalize (r.begin); TRY VText.Replace (v.vtext, r.begin, r.end, r.text) EXCEPT | VTDef.Error (ec) => v.vterror (name, ec) | Rd.EndOfFile => v.rdeoferror (name) | Rd.Failure (ref) => v.rdfailure (name, ref) | Thread.Alerted => END; r.end := r.begin + Text.Length (r.text); r.text := prev; TraceUndo (v) END Exchange;
PROCEDUREMisc (m: Model; READONLY cd: VBT.MiscRec) = CONST name = "Misc"; VAR v := m.v; PROCEDURE turnOff (vtype: VType) RAISES {VTDef.Error} = BEGIN IF NOT v.owns [vtype] THEN RETURN END; v.owns [vtype] := FALSE; FOR type := Primary TO Secondary DO VAR rec := m.selection [type]; BEGIN IF rec # NIL AND rec.alias = cd.selection THEN VText.SwitchInterval (rec.interval, VText.OnOffState.Off) END END END END turnOff; BEGIN TRY IF cd.type = VBT.Lost THEN IF cd.selection = VBT.KBFocus AND v.owns [Focus] THEN v.owns [Focus] := FALSE; VText.SwitchCaret (v.vtext, VText.OnOffState.Off); v.ULfocus (FALSE, cd.time) ELSIF cd.selection = VBT.Source THEN turnOff (Source) ELSIF cd.selection = VBT.Target THEN turnOff (Target) END ELSIF cd.type = VBT.TakeSelection AND cd.selection = VBT.KBFocus THEN EVAL v.getKFocus (cd.time) END; VBT.Mark (v) EXCEPT | VTDef.Error (ec) => v.vterror (name, ec) | Rd.EndOfFile => v.rdeoferror (name) | Rd.Failure (ref) => v.rdfailure (name, ref) | Thread.Alerted => END END Misc; PROCEDUREGetSelectedText (m: Model; sel: TextPort.SelectionType): TEXT = VAR extent := m.getSelection (sel); BEGIN IF extent.l = extent.r THEN RETURN "" ELSE RETURN m.v.getText (extent.l, extent.r) END END GetSelectedText; PROCEDUREPaste (m: Model; time: VBT.TimeStamp) = BEGIN TRY m.v.insert (m.read (VBT.Source, time)) EXCEPT | VBT.Error (ec) => m.v.vbterror ("Paste", ec) END END Paste; PROCEDURERead (m: Model; READONLY s: VBT.Selection; time: VBT.TimeStamp): TEXT RAISES {VBT.Error} = BEGIN TYPECASE VBT.Read (m.v, s, time).toRef () OF | NULL => RAISE VBT.Error (VBT.ErrorCode.WrongType) | TEXT (t) => RETURN t ELSE RAISE VBT.Error (VBT.ErrorCode.WrongType) END END Read; PROCEDUREWrite ( m : Model; READONLY s : VBT.Selection; time: VBT.TimeStamp; t : TEXT ) RAISES {VBT.Error} = BEGIN VBT.Write (m.v, s, time, VBT.FromRef (t)) END Write; PROCEDURESeek (m: Model; position: CARDINAL) = CONST name = "Seek"; BEGIN TRY VText.MoveCaret (m.v.vtext, position); VBT.Mark (m.v) EXCEPT | VTDef.Error (ec) => m.v.vterror (name, ec) | Rd.EndOfFile => m.v.rdeoferror (name) | Rd.Failure (ref) => m.v.rdfailure (name, ref) | Thread.Alerted => END END Seek; PROCEDUREChangeIntervalOptions (v: T; rec: SelectionRecord) RAISES {VTDef.Error} = VAR st := VBT.ScreenTypeOf (v); interval := rec.interval; options := interval.getOptions (); replaceMode := rec.type = Primary AND v.isReplaceMode (); BEGIN IF st = NIL THEN RETURN END; options.whiteStroke := PaintOp.bgFg; (* Reset. *) options.whiteBlack := PaintOp.bgFg; IF st.depth <= 1 THEN (* monochrome *) IF replaceMode THEN options.style := VTDef.IntervalStyle.InverseStyle ELSIF rec.alias = VBT.Source THEN options.style := VTDef.IntervalStyle.ThinUnderlineStyle ELSE options.style := VTDef.IntervalStyle.UnderlineStyle END ELSIF replaceMode THEN options.style := VTDef.IntervalStyle.HighlightStyle; options.whiteBlack := ReplaceColorScheme ELSIF rec.alias = VBT.Source THEN options.style := VTDef.IntervalStyle.ThinUnderlineStyle; options.whiteStroke := SourceColorScheme ELSE options.style := VTDef.IntervalStyle.UnderlineStyle; IF v.readOnly THEN options.whiteStroke := ReadOnlyColorScheme ELSE options.whiteStroke := WritableColorScheme END END; VText.ChangeIntervalOptions (interval, options); VBT.Mark (v) END ChangeIntervalOptions; VAR ReplaceColorScheme := (* black letters on a pale red background *) PaintOp.MakeColorScheme ( bg := PaintOp.FromRGB (r := 1.0, g := 0.7, b := 0.7), fg := PaintOp.Fg); (* For underlines, only the .fg field is used. *) SourceColorScheme := (* green underline *) PaintOp.MakeColorScheme ( fg := PaintOp.FromRGB (r := 0.0, g := 0.8, b := 0.0), bg := PaintOp.Bg); ReadOnlyColorScheme := (* blue underline *) PaintOp.MakeColorScheme ( fg := PaintOp.FromRGB (r := 0.0, g := 0.0, b := 1.0), bg := PaintOp.Bg); WritableColorScheme := (* red underline *) PaintOp.MakeColorScheme ( fg := PaintOp.FromRGB (r := 1.0, g := 0.0, b := 0.0), bg := PaintOp.Bg); PROCEDUREHighlight (m: Model; rec: SelectionRecord; READONLY r: IRange) = CONST name = "Highlight"; BEGIN TRY VText.MoveInterval (rec.interval, r.left, r.right); VText.SwitchInterval (rec.interval, VText.OnOffState.On); rec.cursor := r.middle; m.seek (r.middle); VBT.Mark (m.v) EXCEPT | VTDef.Error (ec) => m.v.vterror (name, ec) END END Highlight; PROCEDURETakeSelection ( m : Model; READONLY sel : VBT.Selection; type: TextPort.SelectionType; time: VBT.TimeStamp ): BOOLEAN = CONST name = "TakeSelection"; VAR v := m.v; rec := m.selection [type]; PROCEDURE take (vtype: VType): BOOLEAN = BEGIN IF NOT v.owns [vtype] THEN TRY VBT.Acquire (v, sel, time); IF type = Secondary OR v.getKFocus (time) THEN v.owns [vtype] := TRUE; IF rec.alias = sel THEN VText.SwitchInterval (rec.interval, VText.OnOffState.On) END ELSE VBT.Release (v, sel) END; VBT.Mark (v) EXCEPT | VBT.Error (ec) => v.vbterror (name, ec) | VTDef.Error (ec) => v.vterror (name, ec) END END; RETURN v.owns [vtype] END take; BEGIN IF sel = VBT.Source THEN RETURN take (Source) ELSIF sel = VBT.Target THEN RETURN take (Target) ELSE <* ASSERT FALSE *> END; END TakeSelection; PROCEDUREExtend (m: Model; rec: SelectionRecord; newL, newR: CARDINAL) = BEGIN IF m.approachingFromLeft AND newL < rec.anchor.r OR NOT m.approachingFromLeft AND newR <= rec.anchor.l THEN m.highlight (rec, IRange {newL, newL, rec.anchor.r}) ELSE m.highlight (rec, IRange {rec.anchor.l, newR, newR}) END END Extend; PROCEDUREPosition (m: Model; READONLY cd: VBT.PositionRec) = VAR rec := m.selection [m.dragType]; r := GetRange (m.v, cd.cp, rec.mode); BEGIN IF rec.mode = VText.SelectionMode.CharSelection THEN m.extend (rec, r.middle, r.middle) ELSE m.extend (rec, r.left, r.right) END END Position; PROCEDUREGetSelection (m: Model; sel := Primary): TextPort.Extent = VAR rec := m.selection [sel]; BEGIN IF rec = NIL THEN RETURN TextPort.NotFound ELSE RETURN TextPort.Extent {rec.interval.left (), rec.interval.right ()} END END GetSelection; PROCEDURESelect (m : Model; time : VBT.TimeStamp; begin : CARDINAL := 0; end : CARDINAL := LAST (CARDINAL); type := Primary; replaceMode := FALSE; caretEnd := VText.WhichEnd.Right) = CONST name = "Select"; VAR rec := m.selection [type]; BEGIN IF rec = NIL THEN (* skip *) ELSIF rec.alias = VBT.Source AND NOT m.takeSelection (VBT.Source, type, time) THEN (* skip *) ELSIF rec.alias = VBT.Target AND NOT m.takeSelection (VBT.Target, type, time) THEN (* skip *) ELSE IF type = Primary THEN rec.replaceMode := replaceMode AND NOT m.v.readOnly; TRY ChangeIntervalOptions (m.v, rec) EXCEPT | VTDef.Error (ec) => m.v.vterror (name, ec) END END; IF caretEnd = VText.WhichEnd.Left THEN m.highlight (rec, IRange {begin, begin, end}) ELSE m.highlight (rec, IRange {begin, end, end}) END END END Select; PROCEDUREPutSelectedText (m: Model; t: TEXT; type: TextPort.SelectionType) = CONST name = "PutSelectedText"; VAR rec := m.selection [type]; BEGIN IF rec = NIL THEN RETURN END; VAR interval := rec.interval; left := interval.left (); right := interval.right (); BEGIN TRY IF m.v.replace (left, right, t) = TextPort.NotFound THEN RETURN END; (* NB: Replace changes interval! *) rec.replaceMode := FALSE; ChangeIntervalOptions (m.v, rec); VText.MoveInterval (interval, left, left + Text.Length (t)) EXCEPT | VTDef.Error (ec) => m.v.vterror (name, ec) END END END PutSelectedText; REVEAL Composer = KeyFilter.ComposeChar BRANDED OBJECT OVERRIDES feedback := Feedback END; VAR cursors := ARRAY BOOLEAN OF Cursor.T {Cursor.TextPointer, Cursor.FromName (ARRAY OF TEXT {"XC_exchange"})}; PROCEDUREFeedback (<* UNUSED *> c: Composer; v: VBT.T; composing: BOOLEAN) = BEGIN VBT.SetCursor (v, cursors [composing]) END Feedback; BEGIN END TextPortClass.