kvm : keyboard/video/mouse support for virtual consoles

Table of Contents

1 Goals

This module implements an enhanced terminal device with support for unicode and a 256 color palette.

2 Class Hierarchy

  • building blocks
    TPoint
    an (x,y) record pair used for tracking the cursor
    TTextAttr
    a (fg, bg : byte) pair, representing a 256 color palette
    TTermCell
    a (TTextAttr, WideChar) record pair
    TTermGrid
    a GGrid2D subclass containing TTermCell records
  • the interface shared by all units
    TBaseTerm
    abstract superclass
    TGridTerm
    generic in-memory terminal
    TSubTerm
    represents the sub-window of another term
    TAnsiTerm
    outputs ansi escape codes, for external terminal emulators
    TVideoTerm
    uses free pascal's video unit
    THookTerm
    allows callbacks on emit, resize, etc

3 ITerm : the abstract screen interface

A screen tracks a cursor position, bounds, color. 

type ITerm = interface ['{8309B694-C1C4-11E3-8461-00188B5936E2}']
  { queries }
  function  Width : word;
  function  Height: word;
  function  XMax  : word;
  function  YMax  : word;
  function  WhereX: word;
  function  WhereY: word;
  function  GetTextAttr : word;
  function  asTerm : ITerm;
  { commands }
  procedure ClrScr;
  procedure ClrEol;
  procedure NewLine;
  procedure ScrollUp;
  procedure Fg( color : byte );
  procedure Bg( color : byte );
  procedure Emit( s : TStr );
  procedure GotoXY( x, y : word );
  procedure InsLine;
  procedure DelLine;
  procedure SetTextAttr( value : word );
  procedure ShowCursor;
  procedure HideCursor;
  procedure Resize( NewW, NewH : word );
  { properties }
  property  TextAttr : word read GetTextAttr write SetTextAttr;
  procedure dump;
end;

4 Data Types

4.1 TTextAttr

For our text attributes, we're going to use 256 colors. This strikes a good balance between storage space and aesthetics. There's really not much need for more colors than this when we're talking about a fixed-width text display. 

type TTextAttr = record
    bg : byte;
    fg : byte;
  end;

4.2 TTermCell

A terminal cell combines a text attribute with a 16-bit WideChar. 

type TTermCell = record
    ch   : widechar;
    attr : TTextAttr;
  end;

4.3 TTermGrid

A terminal's display buffer is essentially a grid of such cells. I'm using my generic GGrid2d class here to avoid duplicating code. 

type TTermGrid = class (specialize GGrid2d<TTermCell>)
  private
    function GetAttr( const x, y : word ) : TTextAttr;
    function GetChar( const x, y : word ) : WideChar;
    procedure SetAttr( const x, y : word; const value : TTextAttr );
    procedure SetChar( const x, y : word; const value : WideChar );
  public
    property attrs[ x, y : word ] : TTextAttr read GetAttr write SetAttr;
    property chars[ x, y : word ] : WideChar read GetChar write SetChar;
  end;

function TTermGrid.GetAttr( const x, y : word ) : TTextAttr;
  begin
    result.fg := self[ x, y ].attr.fg;
    result.bg := self[ x, y ].attr.bg;
  end;

procedure TTermGrid.SetAttr( const x, y  : word;
                             const value : TTextAttr );
  begin
    with _data[ xyToI( x, y ) ].attr do
      begin
        bg := value.bg;
        fg := value.fg;
      end
  end;

function TTermGrid.GetChar( const x, y : word ) : WideChar;
  begin
    result := self[ x, y ].ch;
  end;

procedure TTermGrid.SetChar( const x, y  : word;
                             const value : WideChar );
  begin
    _data[ xyToI( x, y ) ].ch := value;
  end;

4.4 TPoint

type TPoint = record
  x, y : cardinal;
end;

4.5 Event Types

type
  TOnEmit = procedure( s : TStr ) of object;
  TOnGotoXY = procedure( x, y : word ) of object;
  TOnSetTextAttr = procedure( a : TTextAttr ) of object;
  TOnSetColor = procedure( color : byte ) of object;

5 TBaseTerm

5.1 interface

type TBaseTerm = class (TInterfacedObject, ITerm)
  protected
    _attr  : TTextAttr;
    _curs  : TPoint;
    _w, _h : word;
  public
    constructor Create( NewW, NewH : word ); virtual;
    function asTerm : ITerm; // weak reference
    function Width : word; virtual; function Height : word; virtual;
    function xMax : word; virtual; function yMax : word; virtual;
    function WhereX : word; virtual; function WhereY : word; virtual;
    procedure GotoXY( x, y : word ); virtual;
    procedure ClrScr; virtual; procedure ClrEol; virtual;
    procedure NewLine; virtual; procedure ScrollUp; virtual;
    procedure Fg( color : byte ); procedure Bg( color : byte );
    function GetTextAttr : word;
    procedure SetTextAttr( value : word ); virtual;
    procedure EmitChar( ch : TChr ); virtual;
    procedure Emit( s : TStr );
    procedure InsLine; virtual; procedure DelLine; virtual;
    procedure ShowCursor; virtual; procedure HideCursor; virtual;
    procedure Resize( NewW, NewH : word ); virtual;
    procedure dump; virtual;
  protected
    _OnEmit : TOnEmit; _OnGotoXY : TOnGotoXY;
    _OnSetTextAttr : TOnSetTextAttr; _OnSetFg, _OnSetBg : TOnSetColor;
  published
    property w : word read Width;
    property h : word read Height;
    property OnEmit : TOnEmit read _OnEmit write _OnEmit;
    property OnGotoXY : TOnGotoXY read _OnGotoXY write _OnGotoXY;
    property OnSetTextAttr : TOnSetTextAttr
      read _OnSetTextAttr write _OnSetTextAttr;
    property OnSetFg : TOnSetColor read _OnSetFg write _OnSetFg;
    property OnSetBg : TOnSetColor read _OnSetBg write _OnSetBg;
    property  TextAttr : word read GetTextAttr write SetTextAttr;
  end;

5.2 implementation

5.2.1 constructor

constructor TBaseTerm.Create( NewW, NewH : word );
  begin
    _w := NewW; _h := NewH;
    _curs.x := 0; _curs.y := 0;
    _attr.fg := $07; _attr.bg := $00; // light gray on black
  end;

5.2.2 memory management helpers

This is so you can treat the instance as an ITerm without accidentally freeing the thing. 

function TBaseTerm.asTerm : ITerm;
  begin result := self; result._AddRef
  end;

5.2.3 display geometry

function TBaseTerm.Width : word; begin result := _w end;
function TBaseTerm.Height: word; begin result := _h end;
function TBaseTerm.XMax : word; begin result := max(0, _w-1) end;
function TBaseTerm.YMax : word; begin result := max(0, _h-1) end;
procedure TBaseTerm.Resize( NewW, NewH : word );
  begin
    _w := NewW; _h := NewH;
  end;

5.2.4 cursor position

function TBaseTerm.WhereX : word; begin result := _curs.x end;
function TBaseTerm.WhereY : word; begin result := _curs.y end;

procedure TBaseTerm.GotoXY( x, y : word );
  begin
    _curs.x := x;
    _curs.y := y;
    if assigned(_OnGotoXY) then _OnGotoXY( x, y );
  end;

procedure TBaseTerm.ClrScr;
  var y : word; i : integer;
  begin
    for y := 0 to yMax do
      begin
        gotoxy(0, y);
        for i := 1 to self.width do Emit(' ');
      end;
    gotoxy(0, 0);
  end;

procedure TBaseTerm.ClrEol;
  var oldX, i : word;
  begin
    oldX := _curs.x;
    if oldX < xMax then for i := oldX to xMax do Emit(' ')
    else ok;
  { ensure curs'.x = curs.x ; curs'.y = curs.y }
    self.gotoXY( oldX, _curs.y );
  end;

procedure TBaseTerm.NewLine;
  var yOld : word;
  begin
    yOld := wherey;
    if yOld = yMax then
      begin
        scrollUp; gotoXY( 0, yMax );
        chk.equal( _curs.y, yMax, 'should be at bottom' )
      end
    else begin gotoXY( 0, yOld+1 ) end;
    chk.equal( _curs.x, 0 );
  end;

procedure TBaseTerm.ScrollUp;
  var x, y : cardinal;
  begin
    x := _curs.x; y := _curs.y; gotoXY(0,0); delLine; gotoXY(x, y);
  end;

5.2.5 cursor display

It may not always be possible to change the shape of the cursor, so by default, these do nothing. 

procedure TBaseTerm.ShowCursor; begin ok end;
procedure TBaseTerm.HideCursor; begin ok end;

5.2.6 TODO ins/delete lines

These may have to be pushed down into gridterm, or else everything needs to have a grid. 

procedure TBaseTerm.InsLine; begin ok end;
procedure TBaseTerm.DelLine; begin ok end;

5.2.7 text atttributes

These control the foreground and background colors of the characters generated with (emit). 

function  TBaseTerm.GetTextAttr : word;
  begin
    result := _attr.bg shl 8 + _attr.fg
  end;

procedure TBaseTerm.SetTextAttr( value : word );
  var newAttr : TTextAttr;
  begin
    newAttr := WordToAttr(value);
    if newAttr.fg <> _attr.fg then Fg(newAttr.fg);
    if newAttr.bg <> _attr.bg then Bg(newAttr.bg);
  end;

procedure TBaseTerm.Fg( color : byte );
  begin
    _attr.fg := color;
    if assigned( _OnSetFg ) then _OnSetFg( color );
  end;

procedure TBaseTerm.Bg( color : byte );
  begin
    _attr.bg := color;
    if assigned( _OnSetBg ) then _OnSetBg( color );
  end;

5.2.8 text emitter

procedure TBaseTerm.EmitChar( ch : TChr );
   begin
   end;

procedure TBaseTerm.Emit( s : TStr );
  var
    ch : widechar = #0;
  begin
    for ch in s do begin
      if ch = ^I then Emit('        ')
      else if ch = ^J then NewLine
      else if ord(ch) < 32 then ok
      else begin
        if _curs.x = _w then NewLine;
        EmitChar(ch); _curs.x += 1;
        if assigned(_OnEmit) then _OnEmit(ch);
      end
    end
  end;

5.2.9 debug routines

procedure tbaseterm.dump;
  begin
    if self = nil then trace('[NIL]')
    else begin
      trace(['TERM[', self.classname, ']']);
      indent; begin
        trace(['w:', _w, ' h:', _h]);
      end; dedent;
    end;
  end;

6 TGridTerm

6.1 interface

type TGridTerm = class (TBaseTerm, ITerm)
  private
    _grid : TTermGrid;
  public
    constructor Create( NewW, NewH : word ); override;
    destructor Destroy; override;
    function GetCell( const x, y : word ) : TTermCell;
    procedure PutCell( const x, y : word; const cell : TTermCell );
    procedure ClrScr; override;
    procedure EmitChar( wc : widechar ); override;
    property cells[ x, y : word ] : TTermCell
      read GetCell write PutCell; default;
    procedure DelLine; override;
    procedure Resize( newW, newH : word ); override;
  end;

6.2 Implementation

constructor TGridTerm.Create( NewW, NewH : word );
  begin
    inherited create( NewW, NewH );
    _grid := TTermGrid.Create( NewW, NewH );
    clrscr;
  end;

destructor TGridTerm.Destroy;
  begin;
    _grid.Free;
    inherited destroy;
  end;

procedure TGridTerm.Resize( newW, newH : word );
  begin
    inherited resize( newW, newH ); _grid.Resize( newW, newH ); clrscr;
  end;

procedure TGridTerm.ClrScr;
  var cell : TTermCell;
  begin
    inherited clrscr;
    cell.ch := ' ';
    cell.attr := _attr;
    _grid.fill(cell);
    gotoxy(0,0);
  end;

procedure TGridTerm.EmitChar( wc : widechar );
  var cell : TTermCell;
  begin
    if (_curs.x < _w) and (_curs.y < _h) then
    begin
      cell.attr := _attr; cell.ch := wc;
      _grid[_curs.x, _curs.y] := cell;
    end
  end;

function TGridTerm.GetCell( const x, y : word ) : TTermCell;
  begin
    result := _grid[x,y]
  end;

procedure TGridTerm.PutCell( const x, y : word; const cell : TTermCell );
  begin
    _grid[x,y] := cell;
  end;

procedure TGridTerm.DelLine;
  var curx, cury, x, y : integer; a : TTextAttr; c : TTermCell;
  begin
    curx := wherex; cury := wherey; a := _attr;
    for y := cury to ymax-1 do
      begin
        gotoxy(0, y);
        for x := 0 to xmax do
          begin
            c := _grid[x, y+1];
            SetTextAttr(AttrToWord(c.attr)); emit(c.ch);
          end;
        end;
    gotoxy(0, ymax); clreol;
    gotoxy(curx, cury);
    settextattr(attrtoword(a));
  end;

7 TAnsiTerm

type TAnsiTerm = class (TBaseTerm)
  public
    constructor Create( NewW, NewH : word; CurX, CurY : byte );
      reintroduce;
    procedure DoGotoXY( x, y : word );
    procedure DoEmit( s : TStr );
    //  the rest of these should be callbacks too:
    procedure ResetColor;
    procedure DoSetFg( color : byte );
    procedure DoSetBg( color : byte );
    procedure ClrScr; override;
    procedure ShowCursor; override;
    procedure HideCursor; override;
    procedure ScrollUp; override;
  end;

constructor TAnsiTerm.Create(NewW, NewH : word; CurX, CurY : byte);
  begin
    inherited Create( NewW, NewH );
    // we set xy directly because the cursor is already
    // somewhere when the program starts.
    _curs.x := curx;
    _curs.y := cury;
    _OnGotoXY := @DoGotoXY;
    _OnEmit := @DoEmit;
    _OnSetFg := @DoSetFg;
    _OnSetBg := @DoSetBg;
    resetcolor;
  end;

procedure TAnsiTerm.DoSetFg( color : byte );
  begin
    { xterm 256-color extensions }
    write( stdout, #27, '[38;5;', color , 'm' )
  end;

procedure TAnsiTerm.DoSetBg( color : byte );
  begin
    { xterm 256-color extensions }
    write( stdout, #27, '[48;5;', color , 'm' )
  end;

procedure TAnsiTerm.ClrScr;
  begin
    write( stdout, #27, '[H', #27, '[J' );
    _curs.x := 0; _curs.y := 0;
  end;

procedure TAnsiTerm.DoGotoXY( x, y : word );
  begin
    write(stdout, #27, '[', y + 1, ';', x + 1, 'H' )
  end;

procedure TAnsiTerm.DoEmit( s : TStr );
  begin
    write(stdout, utf8encode(s));
  end;

procedure TAnsiTerm.ScrollUp;
  var x, y : word;
  begin
    y := _curs.y;
    if y = ymax then writeln(stdout)
    else begin
      x := _curs.x;
      gotoxy(0,ymax);
      writeln(stdout);
      gotoxy(x,y);
    end;
  end;

procedure TAnsiTerm.ResetColor;
  begin
    _attr.bg := 0; _attr.fg := 7;
    write(stdout, #27, '[0m' )
  end;

procedure TAnsiTerm.ShowCursor; // !! xterm / dec terminals
  begin
    write(stdout, #27, '[?25h');
  end;

procedure TAnsiTerm.HideCursor; // !! xterm / dec terminals
  begin
    write(stdout, #27, '[?25l');
  end;

8 TSubTerm : a window inside a terminal

8.1 interface

type
  TSubTerm = class (TGridTerm)
    protected
      _term : ITerm;
      _x, _y : word;
    public
      constructor Create(term : ITerm; x, y, NewW, NewH : word ); reintroduce;
      procedure DoGotoXY( x, y : word );
      procedure DoEmit( s : TStr );
      procedure DoSetFg( color : byte );
      procedure DoSetBg( color : byte );
      procedure HideCursor; override;
      procedure ShowCursor; override;
    end;

8.2 implementation

We start with a handful of member variables to track the bounds: 

constructor TSubTerm.Create(term : ITerm; x, y, NewW, NewH : word );
  begin
    inherited Create(NewW, NewH);
    _term := term;
    _x := x; _y := y;
    _OnEmit := @DoEmit;
    _OnGotoXy := @DoGotoXY;
    _OnSetFg := @DoSetFg;
    _OnSetBg := @DoSetBg;
  end;

procedure TSubTerm.DoGotoXY( x, y : word );
  begin _term.GotoXY( x + _x, y + _y );
  end;

procedure TSubTerm.DoEmit( s : TStr );
  begin _term.Emit( s );
  end;

procedure TSubTerm.DoSetFg( color : byte );
  begin _term.Fg(color)
  end;

procedure TSubTerm.DoSetBg( color : byte );
  begin _term.Bg(color)
  end;

procedure TSubTerm.HideCursor;
  begin _term.HideCursor;
  end;
procedure TSubTerm.ShowCursor;
  begin _term.ShowCursor;
  end;

9 THookTerm : wraps another term with callbacks for all routines

9.1 interface

type TTermMessage = (hkClrScr, hkClrEol, hkNewLine, hkScrollUp,
         hkFg, hkBg, hkEmit, hkGoXY, hkInsLine, hkDelLine,
         hkAttr, hkShowCursor, hkHideCursor, hkResize );
     TTermCallback =
         procedure( msg : TTermMessage; args : array of variant )
            of object;
type THookTerm = class (TInterfacedObject, ITerm)
  protected
    _self : ITerm;
    _Subject : ITerm; // the term to which we will relay events
    _OnChange : TTermCallback;
  published
    constructor Create;
    function  asTerm : ITerm;
    procedure DoNothing( msg : TTermMessage; args : array of variant );
    property OnChange : TTermCallback read _OnChange write _OnChange;
    function  Width : word;
    function  Height: word;
    function  XMax  : word;
    function  YMax  : word;
    function  WhereX: word;
    function  WhereY: word;
    procedure ClrScr;
    procedure ClrEol;
    procedure NewLine;
    procedure ScrollUp;
    procedure Fg( color : byte );
    procedure Bg( color : byte );
    procedure Emit( s : TStr );
    procedure GotoXY( x, y : word );
    procedure InsLine;
    procedure DelLine;
    procedure SetTextAttr( value : word );
    function  GetTextAttr : word;
    procedure ShowCursor;
    procedure HideCursor;
    procedure Resize( NewW, NewH : word );
    property  TextAttr : word read GetTextAttr write SetTextAttr;
  public { debug stuff }
    function  GetSubject : ITerm;
    property subject : ITerm read GetSubject write _subject;
    procedure dump;
  end;

9.2 implementation

9.2.1 constructor and empty callback

constructor THookTerm.Create;
  begin inherited;
    _self := ITerm(self);
    _OnChange := @self.DoNothing;
    _Subject := kvm.asTerm;
  end;

procedure THookTerm.Dump;
  var indent : TStr;
  begin
    if self = nil then trace('[NIL]')
    else begin
      trace('THookTerm');
      trace(' _subject: '); _subject.dump;
    end
  end;

// HookTerms don't descend from baseterm ( for now, anyway )
function THookTerm.asTerm : ITerm;
  begin result := _self; result._addref;
  end;

function THookTerm.GetSubject : ITerm;
  begin result := _subject.asTerm
  end;

procedure THookTerm.DoNothing( msg : TTermMessage;
                               args : array of variant );
  begin // empty method as default callback
  end;

9.2.2 passthrough queries (no callback)

function THookTerm.Width : word;
  begin result := _subject.width
  end;

function THookTerm.Height: word;
  begin result := _subject.height
  end;

function THookTerm.XMax  : word;
  begin result := _subject.xmax
  end;

function THookTerm.YMax  : word;
  begin result := _subject.ymax
  end;

function THookTerm.WhereX: word;
  begin result := _subject.wherex
  end;

function THookTerm.WhereY: word;
  begin result := _subject.wherex
  end;

function THookTerm.GetTextAttr : word;
  begin result := _subject.textattr
  end;

9.2.3 callbacks

procedure THookTerm.ClrScr;
  begin _subject.ClrScr; OnChange( hkClrScr, [ ]);
  end;

procedure THookTerm.ClrEol;
  begin _subject.ClrScr; OnChange( hkClrEol, [ ]);
  end;

procedure THookTerm.NewLine;
  begin _subject.ClrScr; OnChange( hkNewLine, [ ]);
  end;

procedure THookTerm.ScrollUp;
  begin _subject.ScrollUp; OnChange( hkScrollUp, [ ]);
  end;

procedure THookTerm.Fg( color : byte );
  begin _subject.Fg(color); OnChange( hkFg, [ color ]);
  end;

procedure THookTerm.Bg( color : byte );
  begin _subject.Bg(color); OnChange( hkBg, [ color ]);
  end;

procedure THookTerm.Emit( s : TStr );
  begin _subject.Emit( s ); OnChange( hkEmit, [ s ]);
  end;

procedure THookTerm.GotoXY( x, y : word );
  begin _subject.GotoXY( x, y ); OnChange( hkGoXY, [ x, y ]);
  end;

procedure THookTerm.InsLine;
  begin _subject.InsLine; OnChange( hkInsLine, [ ]);
  end;

procedure THookTerm.DelLine;
  begin _subject.DelLine; OnChange( hkDelLine, [ ]);
  end;

procedure THookTerm.SetTextAttr( value : word );
  begin _subject.SetTexTAttr(value); OnChange( hkAttr, [ value ]);
  end;

procedure THookTerm.ShowCursor;
  begin _subject.ShowCursor; OnChange( hkShowCursor, [ ]);
  end;

procedure THookTerm.HideCursor;
  begin _subject.HideCursor; OnChange( hkHideCursor, [ ]);
  end;

procedure THookTerm.Resize( NewW, NewH : word );
  begin _subject.Resize( newW, newH ); OnChange( hkResize, [ NewW, NewH ]);
  end;

10 TODO TVideoTerm : uses free pascal's video unit

type TVideoTerm = class (TANSITerm)
end;

11 char mnemonics for ansi colors.

procedure bg( ch :  char );
  var i : byte;
  begin
    i := pos( ch, 'krgybmcwKRGYBMCW' );
    if i > 0 then bg( i - 1  );
  end;

procedure fg( ch :  char );
  var i : byte;
  begin
    i := pos( ch, 'krgybmcwKRGYBMCW' );
    if i > 0 then fg( i - 1  );
  end;

These allow you to use one-letter characters for the first 16 colors, instead of refering to them by number. They are arranged according to the ANSI standard.

k 0 black   K 8 dark gray
r 1 red   R 9 light red
g 2 green   G 10 light green
y 3 dark yellow/brown   Y 11 yellow
b 4 blue   B 12 light blue
m 5 magenta   M 13 light magenta
c 6 cyan   C 14 light cyan
w 7 light gray   W 15 white

See also the cw unit (color + write).

12 Text driver, for redirecting write and writeln

function KvmWrite(var f: textrec): integer;
  var s: ansistring;
  begin
    if f.bufpos > 0 then
      begin
        setlength(s, f.bufpos);
        move(f.buffer, s[1], f.bufpos);
        kvm.emit(TStr(s)); // convert to widestring
      end;
    f.bufpos := 0;
    Result := 0;
  end;

function KvmClose(var txt: TTextRec): integer;
  begin
    Result := 0;
  end;

function KvmOpen(var txt: TTextRec): integer;
  begin
    case txt.mode of
      fmOutput:
      begin
        txt.inOutFunc := @KvmWrite;
        txt.flushFunc := @KvmWrite;
      end
      else // todo : error;
    end;
    Result := 0;
  end;

// http://docwiki.embarcadero.com/RADStudio/XE5/en/Standard_Routines_and_Input-Output
procedure AssignKvm(var txt: Text);
  begin
    Assign(txt, '');
    with TTextRec(txt) do
    begin
      mode := fmClosed;
      openFunc := @KvmOpen;
      closeFunc := @KvmClose;
    end;
  end;

13 Unit Life cycle

There are basically three steps to deal with: 

initialization
  <<redirect-io>>
  <<create-term-obj>>
  <<create-term-stack>>
finalization
  { the terms are freed automatically by reference count }
  PopTerms; work := nil;

First, we want to redirect the Output file, so that calls to Write and WriteLn are sent through KvmWrite. Since we may still need to access the standard output (especially in the case of ANSITerm), we'll also create a new file descriptor. 

Assign(stdout,''); Rewrite(stdout);
AssignKVM(output); Rewrite(output);

The second step is simply to create a new ITerm instance and assign the work variable. 

{$IFDEF UNIX}
function GetLiveAnsiTerm : TAnsiTerm;
  var termw, termh : byte; curx, cury : byte;
  begin
    terminal.getwh(termw, termh);
    curx := terminal.startX;
    cury := terminal.startY;
    result := TAnsiTerm.Create( termw, termh, curx, cury );
  end;
{$ENDIF}

{$IFDEF UNIX}
  work :={$IFDEF VIDEOKVM}TVideoTerm.Create
         {$ELSE}GetLiveANSITerm{$ENDIF};
{$ELSE}
  work := TGridTerm.Create(64, 16);
{$ENDIF}

The third step is just to initialize an empty stack: 

termstack := TTermStack.Create(32);

14 The Terminal Stack

14.1 interface

We maintain a stack of ITerm instances so that kvm.work can be assigned and later restored. 

{ context stack }
procedure PushTerm( term : ITerm );
function SubTerm( x, y, w, h : word ) : ITerm;
procedure PopTerm;
procedure PopTerms;

PushTerm pushes the current terminal onto a stack and sets kvm.work to the given terminal.

SubTerm instantiates a new TSubTerm that controls a subregion of kvm.work and then calls PushTerm on it. This is handy for drawing nested components. See TView.Update in utv.pas for an example.

PopTerm discards the topmost item on the stack and restors kvm.work.

PopTerm calls PopTerm until the stack is empty. This is done automatically during finalization, and is only exposed in the interface so that cx.pas can direct the stacktrace to the main terminal in the event of an uncaught exception.

14.2 implementation

type TTermStack = specialize GStack<ITerm>;
var termStack : TTermStack;
var work : ITerm;

procedure PushTerm( term : ITerm );
  begin
    termStack.push( work );
    work := term;
  end;

function SubTerm( x, y, w, h : word ) : ITerm;
  begin
    result := TSubTerm.Create( work, x, y , w , h );
    pushTerm( result );
  end;

procedure PopTerm;
  begin
    work := termStack.Pop;
  end;

procedure PopTerms;
  begin
    while termStack.count > 0 do work := termStack.Pop;
  end;

15 APPENDIX Top-level convenience routines

In general, you're only going to work with one screen at a time, so it's convenient to have a set of routines that deal with whatever the current screen happens to be at the moment.

15.1 interface

{ conversion helpers }
function WordToAttr(w : word): TTextAttr;
function AttrToWord(a : TTextAttr) : word;

{ convenience routines for global instance }
function  asTerm : ITerm; // always a weak reference
function  Width : word;
function  Height: word;
function  XMax  : word;
function  YMax  : word;
function  WhereX : word;
function  WhereY : word;
procedure ClrScr;
procedure ClrEol;
procedure Newline;
procedure Fg( color : byte );
procedure Bg( color : byte );
procedure Emit( s : TStr );
procedure GotoXY( x, y : word );
procedure InsLine;
procedure DelLine;
procedure SetTextAttr( value : word );
function  GetTextAttr : word;
property  TextAttr : word read GetTextAttr write SetTextAttr;
procedure ShowCursor;
procedure HideCursor;

15.2 implementation

15.3 conversions

function WordToAttr(w : word): TTextAttr; inline;
  begin
    result.bg := hi(w);
    result.fg := lo(w);
  end;

function AttrToWord(a : TTextAttr) : word; inline;
  begin
    result := (word(a.bg) shl 8)  + word(a.fg);
  end;

15.4 convenience routines

The others just delegate to the work term. 

function  asTerm : ITerm; begin result := work.asTerm end;

function  Width  : word; begin result := work.Width end;
function  Height : word; begin result := work.Height end;
function  XMax   : word; begin result := work.xMax end;
function  YMax   : word; begin result := work.yMax end;
function  WhereX : word; begin result := work.WhereX end;
function  WhereY : word; begin result := work.WhereY end;

procedure Fg( color : byte );    begin work.Fg( color ) end;
procedure Bg( color : byte );    begin work.Bg( color ) end;
procedure Emit( s : TStr );      begin work.Emit( s ) end;
procedure GotoXY( x, y : word ); begin work.GotoXY( x, y ) end;

procedure ClrScr;  begin work.ClrScr end;
procedure ClrEol;  begin work.ClrEol end;
procedure NewLine; begin work.NewLine end;
procedure InsLine; begin work.InsLine end;
procedure DelLine; begin work.DelLine end;

procedure ShowCursor; begin work.ShowCursor end;
procedure HideCursor; begin work.HideCursor end;

procedure SetTextAttr( value : word );
  begin work.TextAttr := value
  end;

function  GetTextAttr : word;
  begin result := work.TextAttr
  end;

16 OUTPUT kvm.pas

{!! WARNING!! GENERATED FILE. edit ../org/kvm.pas.org instead!! !!}


{$mode objfpc}{$i xpc.inc}{$m+}
unit kvm;
interface uses xpc, ugrid2d, sysutils, strutils, chk, stacks,
  {$ifdef VIDEOKVM}video
  {$else}terminal
  {$endif}
  ;

var stdout : text;

<<ITerm>>
<<TTextAttr>>

<<toplevel>>

<<TTermCell>>
<<TTermGrid>>
<<TPoint>>
<<event-types>>

<<TBaseTerm>>
<<TGridTerm>>
<<TAnsiTerm>>
<<TVideoTerm>>
<<TSubTerm>>
<<THookTerm>>

procedure fg( ch : char );
procedure bg( ch : char );

<<extras>>
<<@kvm:interface>>

implementation
  <<@kvm:impl>>
  <<@hook:impl>>
  <<textdriver>>
<<lifecycle>>
end.