mirror of
https://github.com/doublecmd/doublecmd.git
synced 2026-06-21 09:58:13 +00:00
2196 lines
60 KiB
ObjectPascal
2196 lines
60 KiB
ObjectPascal
{
|
|
Double Commander
|
|
-------------------------------------------------------------------------
|
|
Virtual terminal emulator control
|
|
|
|
Alexander Koblov, 2021-2022
|
|
|
|
Based on ComPort Library
|
|
https://sourceforge.net/projects/comport
|
|
Author:
|
|
Dejan Crnila, 1998 - 2002
|
|
Maintainers:
|
|
Lars B. Dybdahl, 2003
|
|
Brian Gochnauer, 2010
|
|
License:
|
|
Public Domain
|
|
}
|
|
|
|
unit VTEmuCtl;
|
|
|
|
{$mode delphi}
|
|
{$pointermath on}
|
|
|
|
interface
|
|
|
|
uses
|
|
LCLType, Classes, Controls, StdCtrls, ExtCtrls, Forms, Messages, Graphics,
|
|
VTEmuEsc, LCLIntf, Types, LazUtf8, LMessages;
|
|
|
|
type
|
|
|
|
TOnRxBuf = procedure(Sender: TObject; const Buffer; Count: Integer) of object;
|
|
|
|
{ TCustomPtyDevice }
|
|
|
|
TCustomPtyDevice = class(TComponent)
|
|
protected
|
|
FOnRxBuf: TOnRxBuf;
|
|
FConnected: Boolean;
|
|
protected
|
|
procedure SetConnected(AValue: Boolean); virtual; abstract;
|
|
public
|
|
function WriteStr(const Str: string): Integer; virtual; abstract;
|
|
function SetCurrentDir(const Path: String): Boolean; virtual; abstract;
|
|
function SetScreenSize(aCols, aRows: Integer): Boolean; virtual; abstract;
|
|
property OnRxBuf: TOnRxBuf read FOnRxBuf write FOnRxBuf;
|
|
property Connected: Boolean read FConnected write SetConnected default False;
|
|
end;
|
|
|
|
TCustomComTerminal = class; // forward declaration
|
|
|
|
// terminal character
|
|
PComTermChar = ^TComTermChar;
|
|
TComTermChar = record
|
|
Ch: TUTF8Char;
|
|
FrontColor: TColor;
|
|
BackColor: TColor;
|
|
Underline: Boolean;
|
|
Bold: Boolean;
|
|
end;
|
|
|
|
// buffer which holds terminal screen data
|
|
TComTermBuffer = class
|
|
private
|
|
FBuffer: PByte;
|
|
FTabs: Pointer;
|
|
FTopLeft: TPoint;
|
|
FCaretPos: TPoint;
|
|
FScrollRange: TRect;
|
|
FOwner: TCustomComTerminal;
|
|
strict private
|
|
FRows: Integer;
|
|
FColumns: Integer;
|
|
public
|
|
constructor Create(AOwner: TCustomComTerminal);
|
|
destructor Destroy; override;
|
|
procedure Init(ARows, AColumns: Integer);
|
|
procedure SetChar(Column, Row: Integer; TermChar: TComTermChar);
|
|
function GetChar(Column, Row: Integer): TComTermChar;
|
|
procedure SetTab(Column: Integer; Put: Boolean);
|
|
function GetTab(Column: Integer): Boolean;
|
|
function NextTab(Column: Integer): Integer;
|
|
procedure ClearAllTabs;
|
|
procedure ScrollDown;
|
|
procedure ScrollUp;
|
|
procedure EraseScreenLeft(Column, Row: Integer);
|
|
procedure EraseScreenRight(Column, Row: Integer);
|
|
procedure EraseLineLeft(Column, Row: Integer);
|
|
procedure EraseLineRight(Column, Row: Integer);
|
|
procedure EraseChar(Column, Row, Count: Integer);
|
|
procedure DeleteChar(Column, Row, Count: Integer);
|
|
procedure DeleteLine(Row, Count: Integer);
|
|
procedure InsertLine(Row, Count: Integer);
|
|
function GetLineLength(Line: Integer): Integer;
|
|
function GetLastLine: Integer;
|
|
property Rows: Integer read FRows;
|
|
property Columns: Integer read FColumns;
|
|
end;
|
|
|
|
// terminal types
|
|
TTermEmulation = (teVT100orANSI, teVT52, teNone);
|
|
TTermCaret = (tcBlock, tcUnderline, tcNone);
|
|
TAdvanceCaret = (acChar, acReturn, acLineFeed, acReverseLineFeed,
|
|
acTab, acBackspace, acPage);
|
|
TArrowKeys = (akTerminal, akWindows);
|
|
TTermAttributes = record
|
|
FrontColor: TColor;
|
|
BackColor: TColor;
|
|
Invert: Boolean;
|
|
Bold: Boolean;
|
|
Underline: Boolean;
|
|
end;
|
|
TTermMode = record
|
|
Keys: TArrowKeys;
|
|
CharSet: Boolean;
|
|
MouseMode: Boolean;
|
|
MouseTrack: Boolean;
|
|
end;
|
|
|
|
TEscapeEvent = procedure(Sender: TObject; var EscapeCodes: TEscapeCodes) of object;
|
|
TUnhandledEvent = procedure(Sender: TObject; Code: TEscapeCode; Data: string) of object;
|
|
TUnhandledModeEvent = procedure(Sender: TObject; const Data: string; OnOff: Boolean) of object;
|
|
TStrRecvEvent = procedure(Sender: TObject; var Str: string) of object;
|
|
TChScreenEvent = procedure(Sender: TObject; Ch: TUTF8Char) of object;
|
|
|
|
// communication terminal control
|
|
|
|
{ TCustomComTerminal }
|
|
|
|
TCustomComTerminal = class(TCustomControl)
|
|
private
|
|
FPtyDevice: TCustomPtyDevice;
|
|
FScrollBars: TScrollStyle;
|
|
FArrowKeys: TArrowKeys;
|
|
FWantTab: Boolean;
|
|
FColumns: Integer;
|
|
FRows: Integer;
|
|
FVisibleRows: Integer;
|
|
FLocalEcho: Boolean;
|
|
FSendLF: Boolean;
|
|
FAppendLF: Boolean;
|
|
FForce7Bit: Boolean;
|
|
FWrapLines: Boolean;
|
|
FSmoothScroll: Boolean;
|
|
FAutoFollow : Boolean;
|
|
FFontHeight: Integer;
|
|
FFontWidth: Integer;
|
|
FPartChar: TUTF8Char;
|
|
FEmulation: TTermEmulation;
|
|
FCaret: TTermCaret;
|
|
FCaretPos: TPoint;
|
|
FSaveCaret: TPoint;
|
|
FCaretCreated: Boolean;
|
|
FTopLeft: TPoint;
|
|
FCaretHeight: Integer;
|
|
FSaveAttr: TTermAttributes;
|
|
FBuffer: TComTermBuffer;
|
|
FMainBuffer: TComTermBuffer;
|
|
FAlternateBuffer: TComTermBuffer;
|
|
FParams: TStrings;
|
|
FEscapeCodes: TEscapeCodes;
|
|
FTermAttr: TTermAttributes;
|
|
FTermMode: TTermMode;
|
|
FOnChar: TChScreenEvent;
|
|
FOnGetEscapeCodes: TEscapeEvent;
|
|
FOnUnhandledCode: TUnhandledEvent;
|
|
FOnUnhandledMode: TUnhandledModeEvent;
|
|
FOnStrRecieved: TStrRecvEvent;
|
|
procedure AdvanceCaret(Kind: TAdvanceCaret);
|
|
function CalculateMetrics: Boolean;
|
|
procedure CreateEscapeCodes;
|
|
procedure CreateTerminalCaret;
|
|
procedure DrawChar(AColumn, ARow: Integer; Ch: TComTermChar);
|
|
function GetCharAttr: TComTermChar;
|
|
function GetConnected: Boolean;
|
|
procedure HideCaret;
|
|
procedure InitCaret;
|
|
procedure InvalidatePortion(ARect: TRect);
|
|
procedure ModifyScrollBar(ScrollBar, ScrollCode, Pos: Integer);
|
|
procedure SetColumns(const Value: Integer);
|
|
procedure SetPtyDevice(const Value: TCustomPtyDevice);
|
|
procedure SetConnected(const Value: Boolean);
|
|
procedure SetEmulation(const Value: TTermEmulation);
|
|
procedure SetRows(const Value: Integer);
|
|
procedure SetScrollBars(const Value: TScrollStyle);
|
|
procedure SetCaret(const Value: TTermCaret);
|
|
procedure SetAttributes(AParams: TStrings);
|
|
procedure SetMode(AParams: TStrings; OnOff: Boolean);
|
|
procedure ShowCaret;
|
|
procedure StringReceived(Str: string);
|
|
procedure PaintTerminal(Rect: TRect);
|
|
procedure PaintDesign;
|
|
procedure PutChar(Ch: TUTF8Char);
|
|
function PutEscapeCode(ACode: TEscapeCode; AParams: TStrings): Boolean;
|
|
procedure RestoreAttr;
|
|
procedure RestoreCaretPos;
|
|
procedure RxBuf(Sender: TObject; const Buffer; Count: Integer);
|
|
procedure SaveAttr;
|
|
procedure SaveCaretPos;
|
|
procedure SendChar(Ch: TUTF8Char);
|
|
procedure SendCode(Code: TEscapeCode; AParams: TStrings);
|
|
procedure SendCodeNoEcho(Code: TEscapeCode; AParams: TStrings);
|
|
procedure MouseEvent(Code: TEscapeCode; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
|
|
procedure PerformTest(ACh: Char);
|
|
procedure UpdateScrollPos;
|
|
procedure UpdateScrollRange;
|
|
procedure WrapLine(AWidth: Integer);
|
|
protected
|
|
procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
|
|
procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
|
|
procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
|
|
procedure WMHScroll(var Message: TWMHScroll); message WM_HSCROLL;
|
|
procedure WMKillFocus(var Message: TWMSetFocus); message WM_KILLFOCUS;
|
|
procedure WMLButtonDown(var Message: TLMLButtonDown); message WM_LBUTTONDOWN;
|
|
procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
|
|
procedure WMSize(var Msg: TWMSize); message WM_SIZE;
|
|
procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;
|
|
function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;
|
|
procedure CreateParams(var Params: TCreateParams); override;
|
|
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
|
|
procedure KeyPress(var Key: Char); override;
|
|
procedure UTF8KeyPress(var UTF8Key: TUTF8Char); override;
|
|
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
|
|
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
|
|
procedure CreateWnd; override;
|
|
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
|
|
procedure Paint; override;
|
|
procedure DoChar(Ch: TUTF8Char); dynamic;
|
|
procedure DoGetEscapeCodes(var EscapeCodes: TEscapeCodes); dynamic;
|
|
procedure DoStrRecieved(var Str: string); dynamic;
|
|
procedure DoUnhandledCode(Code: TEscapeCode; Data: string); dynamic;
|
|
procedure DoUnhandledMode(const Data: string; OnOff: Boolean); dynamic;
|
|
function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; override;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
procedure ClearScreen;
|
|
procedure MoveCaret(AColumn, ARow: Integer);
|
|
procedure Write(const Buffer:string; Size: Integer);
|
|
procedure WriteStr(const Str: string);
|
|
procedure WriteEscCode(ACode: TEscapeCode; AParams: TStrings);
|
|
procedure LoadFromStream(Stream: TStream);
|
|
procedure SaveToStream(Stream: TStream);
|
|
procedure SelectFont;
|
|
property AppendLF: Boolean read FAppendLF write FAppendLF default False;
|
|
property AutoFollow : Boolean read FAutoFollow write FAutoFollow default True;
|
|
property ArrowKeys: TArrowKeys read FArrowKeys write FArrowKeys default akTerminal;
|
|
property Caret: TTermCaret read FCaret write SetCaret default tcBlock;
|
|
property Connected: Boolean read GetConnected write SetConnected stored False;
|
|
property PtyDevice: TCustomPtyDevice read FPtyDevice write SetPtyDevice;
|
|
property Columns: Integer read FColumns write SetColumns default 80;
|
|
property Emulation: TTermEmulation read FEmulation write SetEmulation;
|
|
property EscapeCodes: TEscapeCodes read FEscapeCodes;
|
|
property Force7Bit: Boolean read FForce7Bit write FForce7Bit default False;
|
|
property LocalEcho: Boolean read FLocalEcho write FLocalEcho default False;
|
|
property SendLF: Boolean read FSendLF write FSendLF default False;
|
|
property ScrollBars: TScrollStyle read FScrollBars write SetScrollBars;
|
|
property SmoothScroll: Boolean read FSmoothScroll write FSmoothScroll default False;
|
|
property Rows: Integer read FRows write SetRows default 24;
|
|
property WantTab: Boolean read FWantTab write FWantTab default False;
|
|
property WrapLines: Boolean read FWrapLines write FWrapLines default False;
|
|
property OnChar: TChScreenEvent read FOnChar write FOnChar;
|
|
property OnGetEscapeCodes: TEscapeEvent
|
|
read FOnGetEscapeCodes write FOnGetEscapeCodes;
|
|
property OnStrRecieved: TStrRecvEvent
|
|
read FOnStrRecieved write FOnStrRecieved;
|
|
property OnUnhandledMode: TUnhandledModeEvent
|
|
read FOnUnhandledMode write FOnUnhandledMode;
|
|
property OnUnhandledCode: TUnhandledEvent
|
|
read FOnUnhandledCode write FOnUnhandledCode;
|
|
end;
|
|
|
|
// publish properties
|
|
TVirtualTerminal = class(TCustomComTerminal)
|
|
published
|
|
property Align;
|
|
property AppendLF;
|
|
property ArrowKeys;
|
|
property BorderStyle;
|
|
property Color;
|
|
property Columns;
|
|
property PtyDevice;
|
|
property Connected;
|
|
property DragCursor;
|
|
property DragMode;
|
|
property Emulation;
|
|
property Enabled;
|
|
property Font;
|
|
property Force7Bit;
|
|
property Hint;
|
|
property LocalEcho;
|
|
property ParentColor;
|
|
property ParentShowHint;
|
|
property PopupMenu;
|
|
property Rows;
|
|
property ScrollBars;
|
|
property SendLF;
|
|
property ShowHint;
|
|
property SmoothScroll;
|
|
property TabOrder;
|
|
property TabStop default True;
|
|
property Caret;
|
|
property Visible;
|
|
property WantTab;
|
|
property WrapLines;
|
|
property Anchors;
|
|
property AutoSize;
|
|
property Constraints;
|
|
property DragKind;
|
|
property OnChar;
|
|
property OnClick;
|
|
property OnDblClick;
|
|
property OnDragDrop;
|
|
property OnDragOver;
|
|
property OnEndDrag;
|
|
property OnEnter;
|
|
property OnExit;
|
|
property OnGetEscapeCodes;
|
|
property OnKeyDown;
|
|
property OnKeyPress;
|
|
property OnKeyUp;
|
|
property OnMouseDown;
|
|
property OnMouseMove;
|
|
property OnMouseUp;
|
|
property OnStartDrag;
|
|
property OnStrRecieved;
|
|
property OnUnhandledCode;
|
|
property OnConstrainedResize;
|
|
property OnDockDrop;
|
|
property OnEndDock;
|
|
property OnMouseWheel;
|
|
property OnMouseWheelDown;
|
|
property OnMouseWheelUp;
|
|
property OnResize;
|
|
property OnStartDock;
|
|
property OnUnDock;
|
|
property OnContextPopup;
|
|
end;
|
|
|
|
implementation
|
|
|
|
uses
|
|
SysUtils, Dialogs, Math, VTColorTable, VTWideCharWidth;
|
|
|
|
const
|
|
TMPF_FIXED_PITCH = $01;
|
|
|
|
(*****************************************
|
|
* TComTermBuffer class *
|
|
*****************************************)
|
|
|
|
// create class
|
|
constructor TComTermBuffer.Create(AOwner: TCustomComTerminal);
|
|
begin
|
|
inherited Create;
|
|
FOwner := AOwner;
|
|
FTopLeft := Classes.Point(1, 1);
|
|
FCaretPos := Classes.Point(1, 1);
|
|
end;
|
|
|
|
// destroy class
|
|
destructor TComTermBuffer.Destroy;
|
|
begin
|
|
if FBuffer <> nil then
|
|
begin
|
|
FreeMem(FBuffer);
|
|
FreeMem(FTabs);
|
|
end;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
// put char in buffer
|
|
procedure TComTermBuffer.SetChar(Column, Row: Integer; TermChar: TComTermChar);
|
|
var
|
|
Address: Integer;
|
|
begin
|
|
if (Row > FRows) or (Column > FColumns) then
|
|
Exit;
|
|
|
|
Address := (Row - 1) * FColumns + (Column - 1);
|
|
PComTermChar(FBuffer + (Address * SizeOf(TComTermChar)))^:= TermChar;
|
|
end;
|
|
|
|
// get char from buffer
|
|
function TComTermBuffer.GetChar(Column, Row: Integer): TComTermChar;
|
|
var
|
|
Address: Integer;
|
|
begin
|
|
if (Row > FRows) or (Column > FColumns) then
|
|
Exit(Default(TComTermChar));
|
|
|
|
Address := (Row - 1) * FColumns + (Column - 1);
|
|
Result:= PComTermChar(FBuffer + (Address * SizeOf(TComTermChar)))^;
|
|
end;
|
|
|
|
// scroll down up line
|
|
procedure TComTermBuffer.ScrollDown;
|
|
begin
|
|
DeleteLine(FScrollRange.Top, 1);
|
|
end;
|
|
|
|
// scroll up one line
|
|
procedure TComTermBuffer.ScrollUp;
|
|
begin
|
|
InsertLine(FScrollRange.Top, 1)
|
|
end;
|
|
|
|
procedure TComTermBuffer.EraseLineLeft(Column, Row: Integer);
|
|
var
|
|
Index: Integer;
|
|
B: PComTermChar;
|
|
begin
|
|
if (Row > FRows) or (Column > FColumns) then Exit;
|
|
|
|
// in memory
|
|
B:= PComTermChar(FBuffer) + ((Row - 1) * FColumns);
|
|
for Index:= 0 to Column - 1 do
|
|
begin
|
|
B[Index].Ch:= #32;
|
|
B[Index].BackColor:= FOwner.FTermAttr.BackColor;
|
|
B[Index].FrontColor:= FOwner.FTermAttr.FrontColor;
|
|
end;
|
|
|
|
// on screen
|
|
if FOwner.DoubleBuffered then
|
|
FOwner.Invalidate
|
|
else
|
|
FOwner.InvalidatePortion(Classes.Rect(1, Row, Column, Row));
|
|
end;
|
|
|
|
// erase line
|
|
procedure TComTermBuffer.EraseLineRight(Column, Row: Integer);
|
|
var
|
|
Index: Integer;
|
|
Count: Integer;
|
|
B: PComTermChar;
|
|
begin
|
|
if (Row > FRows) or (Column > FColumns) then Exit;
|
|
|
|
// in memory
|
|
Count:= (FColumns - Column + 1);
|
|
B:= PComTermChar(FBuffer) + ((Row - 1) * FColumns + (Column - 1));
|
|
for Index:= 0 to Count - 1 do
|
|
begin
|
|
B[Index].Ch:= #32;
|
|
B[Index].BackColor:= FOwner.FTermAttr.BackColor;
|
|
B[Index].FrontColor:= FOwner.FTermAttr.FrontColor;
|
|
end;
|
|
|
|
// on screen
|
|
if FOwner.DoubleBuffered then
|
|
FOwner.Invalidate
|
|
else
|
|
FOwner.InvalidatePortion(Classes.Rect(Column, Row, FColumns, Row));
|
|
end;
|
|
|
|
procedure TComTermBuffer.EraseChar(Column, Row, Count: Integer);
|
|
var
|
|
Index: Integer;
|
|
B: PComTermChar;
|
|
begin
|
|
if (Row > FRows) or (Column > FColumns) then Exit;
|
|
if (Column + Count > FColumns) then Count:= FColumns - Column;
|
|
|
|
// in memory
|
|
B:= PComTermChar(FBuffer) + ((Row - 1) * FColumns + (Column - 1));
|
|
for Index:= 0 to Count - 1 do
|
|
begin
|
|
B[Index].Ch:= #32;
|
|
B[Index].BackColor:= FOwner.FTermAttr.BackColor;
|
|
B[Index].FrontColor:= FOwner.FTermAttr.FrontColor;
|
|
end;
|
|
|
|
// on screen
|
|
if FOwner.DoubleBuffered then
|
|
FOwner.Invalidate
|
|
else
|
|
FOwner.InvalidatePortion(Classes.Rect(Column, Row, FColumns, Row));
|
|
end;
|
|
|
|
procedure TComTermBuffer.DeleteChar(Column, Row, Count: Integer);
|
|
var
|
|
Index: Integer;
|
|
DstAddr: PComTermChar;
|
|
SrcAddr: PComTermChar;
|
|
begin
|
|
if (Row > FRows) or (Column > FColumns) then Exit;
|
|
if (Column + Count > FColumns) then Count:= FColumns - Column;
|
|
|
|
// in memory
|
|
DstAddr:= PComTermChar(FBuffer) + ((Row - 1) * FColumns + (Column - 1));
|
|
SrcAddr:= PComTermChar(FBuffer) + ((Row - 1) * FColumns + (Column - 1) + Count);
|
|
|
|
// Move characters
|
|
Count:= (FColumns - (Column + Count));
|
|
Move(SrcAddr^, DstAddr^, Count * SizeOf(TComTermChar));
|
|
|
|
// Erase moved
|
|
for Index:= 0 to Count - 1 do
|
|
begin
|
|
SrcAddr[Index].Ch:= #32;
|
|
SrcAddr[Index].BackColor:= FOwner.FTermAttr.BackColor;
|
|
SrcAddr[Index].FrontColor:= FOwner.FTermAttr.FrontColor;
|
|
end;
|
|
|
|
// on screen
|
|
if FOwner.DoubleBuffered then
|
|
FOwner.Invalidate
|
|
else
|
|
FOwner.InvalidatePortion(Classes.Rect(Column, Row, FColumns, Row));
|
|
end;
|
|
|
|
procedure TComTermBuffer.DeleteLine(Row, Count: Integer);
|
|
var
|
|
Index: Integer;
|
|
B: PComTermChar;
|
|
DstAddr: Pointer;
|
|
SrcAddr: Pointer;
|
|
BytesToMove: Integer;
|
|
Top, Bottom: Integer;
|
|
begin
|
|
Top:= FScrollRange.Top;
|
|
Bottom:= FScrollRange.Bottom;
|
|
|
|
if (Row < Top) or (Row > Bottom) then Exit;
|
|
if (Row - 1) + Count > Bottom then Count:= Bottom - Row + 1;
|
|
|
|
if Row < Bottom then
|
|
begin
|
|
DstAddr := (FBuffer + (Row - 1) * FColumns * SizeOf(TComTermChar));
|
|
SrcAddr := (FBuffer + (Row + Count - 1) * FColumns * SizeOf(TComTermChar));
|
|
BytesToMove := (Bottom - Row - Count + 1) * FColumns * SizeOf(TComTermChar);
|
|
|
|
// scroll in buffer
|
|
Move(SrcAddr^, DstAddr^, BytesToMove);
|
|
end;
|
|
|
|
B:= PComTermChar(FBuffer) + ((Bottom - Count) * FColumns);
|
|
for Index:= 0 to Count * FColumns - 1 do
|
|
begin
|
|
B[Index].Ch:= #32;
|
|
B[Index].BackColor:= FOwner.FTermAttr.BackColor;
|
|
B[Index].FrontColor:= FOwner.FTermAttr.FrontColor;
|
|
end;
|
|
|
|
// on screen
|
|
if FOwner.DoubleBuffered then
|
|
FOwner.Invalidate
|
|
else
|
|
FOwner.InvalidatePortion(Classes.Rect(1, Row, FColumns, Bottom));
|
|
end;
|
|
|
|
procedure TComTermBuffer.InsertLine(Row, Count: Integer);
|
|
var
|
|
Index: Integer;
|
|
B: PComTermChar;
|
|
DstAddr: Pointer;
|
|
SrcAddr: Pointer;
|
|
BytesToMove: Integer;
|
|
Top, Bottom: Integer;
|
|
begin
|
|
Top:= FScrollRange.Top;
|
|
Bottom:= FScrollRange.Bottom;
|
|
|
|
if (Row < Top) or (Row > Bottom) then Exit;
|
|
if (Row - 1) + Count > Bottom then Count:= Bottom - Row + 1;
|
|
|
|
if Row < Bottom then
|
|
begin
|
|
SrcAddr := (FBuffer + (Row - 1) * FColumns * SizeOf(TComTermChar));
|
|
DstAddr := (FBuffer + (Row + Count - 1) * FColumns * SizeOf(TComTermChar));
|
|
BytesToMove := (Bottom - Row - Count + 1) * FColumns * SizeOf(TComTermChar);
|
|
|
|
// scroll in buffer
|
|
Move(SrcAddr^, DstAddr^, BytesToMove);
|
|
end;
|
|
|
|
B:= PComTermChar(FBuffer) + ((Row - 1) * FColumns);
|
|
for Index:= 0 to Count * FColumns - 1 do
|
|
begin
|
|
B[Index].Ch:= #32;
|
|
B[Index].BackColor:= FOwner.FTermAttr.BackColor;
|
|
B[Index].FrontColor:= FOwner.FTermAttr.FrontColor;
|
|
end;
|
|
|
|
// on screen
|
|
if FOwner.DoubleBuffered then
|
|
FOwner.Invalidate
|
|
else
|
|
FOwner.InvalidatePortion(Classes.Rect(1, Row, FColumns, Bottom));
|
|
end;
|
|
|
|
// erase screen
|
|
procedure TComTermBuffer.EraseScreenLeft(Column, Row: Integer);
|
|
var
|
|
Index: Integer;
|
|
Count: Integer;
|
|
B: PComTermChar;
|
|
begin
|
|
if (Row > FRows) or (Column > FColumns) then Exit;
|
|
|
|
// in memory
|
|
B:= PComTermChar(FBuffer);
|
|
Count:= (Row * FColumns + Column);
|
|
for Index:= 0 to Count - 1 do
|
|
begin
|
|
B[Index].Ch:= #32;
|
|
B[Index].BackColor:= FOwner.FTermAttr.BackColor;
|
|
B[Index].FrontColor:= FOwner.FTermAttr.FrontColor;
|
|
end;
|
|
|
|
// on screen
|
|
if FOwner.DoubleBuffered then
|
|
FOwner.Invalidate
|
|
else
|
|
FOwner.InvalidatePortion(Classes.Rect(1, 1, FColumns, Row))
|
|
end;
|
|
|
|
// erase screen
|
|
procedure TComTermBuffer.EraseScreenRight(Column, Row: Integer);
|
|
var
|
|
Index: Integer;
|
|
Count: Integer;
|
|
B: PComTermChar;
|
|
begin
|
|
if (Row > FRows) or (Column > FColumns) then Exit;
|
|
|
|
// in memory
|
|
B:= PComTermChar(FBuffer) + ((Row - 1) * FColumns + (Column - 1));
|
|
Count:= ((FRows - Row) * FColumns + (FColumns - Column) + 1);
|
|
for Index:= 0 to Count - 1 do
|
|
begin
|
|
B[Index].Ch:= #32;
|
|
B[Index].BackColor:= FOwner.FTermAttr.BackColor;
|
|
B[Index].FrontColor:= FOwner.FTermAttr.FrontColor;
|
|
end;
|
|
|
|
// on screen
|
|
if FOwner.DoubleBuffered then
|
|
FOwner.Invalidate
|
|
else
|
|
FOwner.InvalidatePortion(Classes.Rect(1, Row, FColumns, FRows))
|
|
end;
|
|
|
|
// init buffer
|
|
procedure TComTermBuffer.Init(ARows, AColumns: Integer);
|
|
var
|
|
I: Integer;
|
|
begin
|
|
if ARows > 0 then
|
|
FRows:= ARows;
|
|
if AColumns > 0 then
|
|
FColumns:= AColumns;
|
|
if FBuffer <> nil then
|
|
begin
|
|
FreeMem(FBuffer);
|
|
FreeMem(FTabs);
|
|
end;
|
|
GetMem(FBuffer, FColumns * FRows * SizeOf(TComTermChar));
|
|
FillChar(FBuffer^, FColumns * FRows * SizeOf(TComTermChar), 0);
|
|
GetMem(FTabs, FColumns * SizeOf(Boolean));
|
|
FillChar(FTabs^, FColumns * SizeOf(Boolean), 0);
|
|
I := 1;
|
|
while (I <= FColumns) do
|
|
begin
|
|
SetTab(I, True);
|
|
Inc(I, 8);
|
|
end;
|
|
FScrollRange.Top:= 1;
|
|
FScrollRange.Bottom:= FRows;
|
|
end;
|
|
|
|
// get tab at Column
|
|
function TComTermBuffer.GetTab(Column: Integer): Boolean;
|
|
begin
|
|
Result := Boolean((FTabs + (Column - 1) * SizeOf(Boolean))^);
|
|
end;
|
|
|
|
// set tab at column
|
|
procedure TComTermBuffer.SetTab(Column: Integer; Put: Boolean);
|
|
begin
|
|
Boolean((FTabs + (Column - 1) * SizeOf(Boolean))^) := Put;
|
|
end;
|
|
|
|
// find nexts tab position
|
|
function TComTermBuffer.NextTab(Column: Integer): Integer;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
I := Column;
|
|
while (I <= FColumns) do
|
|
if GetTab(I) then
|
|
Break
|
|
else
|
|
Inc(I);
|
|
if I > FColumns then
|
|
Result := 0
|
|
else
|
|
Result := I;
|
|
end;
|
|
|
|
// clear all tabs
|
|
procedure TComTermBuffer.ClearAllTabs;
|
|
begin
|
|
FillChar(FTabs^, FColumns * SizeOf(Boolean), 0);
|
|
end;
|
|
|
|
function TComTermBuffer.GetLineLength(Line: Integer): Integer;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
Result := 0;
|
|
for I := 1 to FColumns do
|
|
if GetChar(I, Line).Ch <> #0 then
|
|
Result := I;
|
|
end;
|
|
|
|
function TComTermBuffer.GetLastLine: Integer;
|
|
var
|
|
J: Integer;
|
|
begin
|
|
Result := 0;
|
|
for J := 1 to FRows do
|
|
if GetLineLength(J) > 0 then
|
|
Result := J;
|
|
end;
|
|
|
|
(*****************************************
|
|
* TComCustomTerminal control *
|
|
*****************************************)
|
|
|
|
// create control
|
|
constructor TCustomComTerminal.Create(AOwner: TComponent);
|
|
begin
|
|
FScrollBars := ssVertical;
|
|
|
|
inherited Create(AOwner);
|
|
|
|
Parent:= TWinControl(AOwner);
|
|
|
|
BorderStyle := bsSingle;
|
|
Color := clBlack;
|
|
DoubleBuffered := True;
|
|
TabStop := True;
|
|
Font.Name := 'Consolas';
|
|
Font.Color:= clWhite;
|
|
FEmulation := teVT100orANSI;
|
|
FColumns := 80;
|
|
FRows := 100;
|
|
FVisibleRows:= 25;
|
|
FWrapLines := True;
|
|
FAutoFollow := True;
|
|
FCaretPos := Classes.Point(1, 1);
|
|
FTopLeft := Classes.Point(1, 1);
|
|
FMainBuffer := TComTermBuffer.Create(Self);
|
|
FAlternateBuffer := TComTermBuffer.Create(Self);
|
|
FTermAttr.FrontColor := Font.Color;
|
|
FTermAttr.BackColor := Color;
|
|
|
|
FBuffer:= FMainBuffer;
|
|
FParams:= TStringList.Create;
|
|
|
|
CreateEscapeCodes;
|
|
if not (csDesigning in ComponentState) then
|
|
begin
|
|
FMainBuffer.Init(FRows, FColumns);
|
|
FAlternateBuffer.Init(FVisibleRows, FColumns);
|
|
end;
|
|
|
|
SetBounds(Left, Top, 400, 250);
|
|
end;
|
|
|
|
// destroy control
|
|
destructor TCustomComTerminal.Destroy;
|
|
begin
|
|
PtyDevice := nil;
|
|
FMainBuffer.Free;
|
|
FAlternateBuffer.Free;
|
|
FEscapeCodes.Free;
|
|
FParams.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
// clear terminal screen
|
|
procedure TCustomComTerminal.ClearScreen;
|
|
begin
|
|
FBuffer.Init(0, 0);
|
|
FTopLeft := Classes.Point(1, 1);
|
|
MoveCaret(1, 1);
|
|
UpdateScrollRange;
|
|
Invalidate;
|
|
end;
|
|
|
|
// move caret
|
|
procedure TCustomComTerminal.MoveCaret(AColumn, ARow: Integer);
|
|
begin
|
|
if AColumn > FBuffer.Columns then
|
|
begin
|
|
if FWrapLines then
|
|
FCaretPos.X := FBuffer.Columns + 1
|
|
else
|
|
FCaretPos.X := FBuffer.Columns
|
|
end
|
|
else
|
|
if AColumn < 1 then
|
|
FCaretPos.X := 1
|
|
else
|
|
FCaretPos.X := AColumn;
|
|
|
|
if ARow > FBuffer.Rows then
|
|
FCaretPos.Y := FBuffer.Rows
|
|
else
|
|
if ARow < 1 then
|
|
FCaretPos.Y := 1
|
|
else
|
|
FCaretPos.Y := ARow;
|
|
|
|
if FCaretCreated then
|
|
SetCaretPos((FCaretPos.X - FTopLeft.X) * FFontWidth,
|
|
(FCaretPos.Y - FTopLeft.Y) * FFontHeight + FFontHeight - FCaretHeight);
|
|
end;
|
|
|
|
// write data to screen
|
|
procedure TCustomComTerminal.Write(const Buffer:string; Size: Integer);
|
|
var
|
|
I: Integer;
|
|
L: Integer;
|
|
Ch: TUTF8Char;
|
|
Res: TEscapeResult;
|
|
begin
|
|
HideCaret;
|
|
try
|
|
// show it on screen
|
|
I:= 1;
|
|
while I <= Size do
|
|
begin
|
|
L:= UTF8CodepointSizeFast(@Buffer[I]);
|
|
Ch:= Copy(Buffer, I, L);
|
|
|
|
// got partial character
|
|
if (I + L - 1 > Size) then
|
|
begin
|
|
FPartChar:= Ch;
|
|
Break;
|
|
end;
|
|
|
|
if (FEscapeCodes <> nil) then
|
|
begin
|
|
Res := FEscapeCodes.ProcessChar(Ch);
|
|
if Res = erChar then
|
|
PutChar(FEscapeCodes.Character);
|
|
if Res = erCode then
|
|
begin
|
|
if not PutEscapeCode(FEscapeCodes.Code, FEscapeCodes.Params) then
|
|
DoUnhandledCode(FEscapeCodes.Code, FEscapeCodes.Data);
|
|
FEscapeCodes.Params.Clear;
|
|
end;
|
|
end
|
|
else begin
|
|
PutChar(Ch);
|
|
end;
|
|
I+= L;
|
|
end;
|
|
finally
|
|
ShowCaret;
|
|
end;
|
|
end;
|
|
|
|
// write string on screen, but not to port
|
|
procedure TCustomComTerminal.WriteStr(const Str: string);
|
|
begin
|
|
Write(Str, Length(Str));
|
|
end;
|
|
|
|
// write escape code on screen
|
|
procedure TCustomComTerminal.WriteEscCode(ACode: TEscapeCode;
|
|
AParams: TStrings);
|
|
begin
|
|
if FEscapeCodes <> nil then
|
|
PutEscapeCode(ACode, AParams);
|
|
end;
|
|
|
|
// load screen buffer from file
|
|
procedure TCustomComTerminal.LoadFromStream(Stream: TStream);
|
|
var
|
|
ABuffer: TBytes;
|
|
begin
|
|
HideCaret;
|
|
ABuffer:= Default(TBytes);
|
|
SetLength(ABuffer, Stream.Size);
|
|
Stream.ReadBuffer(ABuffer[0], Length(ABuffer));
|
|
RxBuf(Self, ABuffer[0], Length(ABuffer));
|
|
ShowCaret;
|
|
end;
|
|
|
|
// save screen buffer to file
|
|
procedure TCustomComTerminal.SaveToStream(Stream: TStream);
|
|
var
|
|
I, J: Integer;
|
|
Ch: TUTF8Char;
|
|
EndLine: string;
|
|
LastChar, LastLine: Integer;
|
|
begin
|
|
EndLine := #13#10;
|
|
LastLine := FBuffer.GetLastLine;
|
|
for J := 1 to LastLine do
|
|
begin
|
|
LastChar := FBuffer.GetLineLength(J);
|
|
if LastChar > 0 then
|
|
begin
|
|
for I := 1 to LastChar do
|
|
begin
|
|
Ch := FBuffer.GetChar(I, J).Ch;
|
|
// replace null characters with blanks
|
|
if Ch = #0 then
|
|
Ch := #32;
|
|
Stream.Write(Ch, Length(Ch));
|
|
end;
|
|
end;
|
|
// new line
|
|
if J <> LastLine then
|
|
Stream.Write(EndLine[1], Length(EndLine));
|
|
end;
|
|
end;
|
|
|
|
// select terminal font
|
|
procedure TCustomComTerminal.SelectFont;
|
|
begin
|
|
with TFontDialog.Create(Application) do
|
|
begin
|
|
Options := Options + [fdFixedPitchOnly];
|
|
Font := Self.Font;
|
|
if Execute then
|
|
Self.Font := Font;
|
|
Free;
|
|
end;
|
|
end;
|
|
|
|
// process font change
|
|
procedure TCustomComTerminal.CMFontChanged(var Message: TMessage);
|
|
begin
|
|
inherited;
|
|
FTermAttr.FrontColor := Font.Color;
|
|
if not CalculateMetrics then
|
|
;//Font.Name := ComTerminalFont.Name;
|
|
if fsUnderline in Font.Style then
|
|
Font.Style := Font.Style - [fsUnderline];
|
|
AdjustSize;
|
|
UpdateScrollRange;
|
|
end;
|
|
|
|
procedure TCustomComTerminal.CMColorChanged(var Message: TMessage);
|
|
begin
|
|
inherited;
|
|
FTermAttr.BackColor := Color;
|
|
end;
|
|
|
|
procedure TCustomComTerminal.WMGetDlgCode(var Message: TWMGetDlgCode);
|
|
begin
|
|
// request arrow keys and WM_CHAR message to be handled by the control
|
|
Message.Result := DLGC_WANTARROWS or DLGC_WANTCHARS;
|
|
// tab key
|
|
if FWantTab then
|
|
Message.Result := Message.Result or DLGC_WANTTAB;
|
|
end;
|
|
|
|
// lost focus
|
|
procedure TCustomComTerminal.WMKillFocus(var Message: TWMSetFocus);
|
|
begin
|
|
// destroy caret because it could be requested by some other control
|
|
DestroyCaret(Handle);
|
|
FCaretCreated := False;
|
|
inherited;
|
|
end;
|
|
|
|
// gained focus
|
|
procedure TCustomComTerminal.WMSetFocus(var Message: TWMSetFocus);
|
|
begin
|
|
inherited;
|
|
// control activated, create caret
|
|
InitCaret;
|
|
end;
|
|
|
|
// left button pressed
|
|
procedure TCustomComTerminal.WMLButtonDown(var Message: TLMLButtonDown);
|
|
begin
|
|
// set focus when left button down
|
|
if CanFocus and TabStop then
|
|
SetFocus;
|
|
inherited;
|
|
end;
|
|
|
|
// size changed
|
|
procedure TCustomComTerminal.WMSize(var Msg: TWMSize);
|
|
var
|
|
ARows, AColumns: Integer;
|
|
begin
|
|
inherited WMSize(Msg);
|
|
|
|
if (ClientWidth = 0) or (ClientHeight = 0) then
|
|
Exit;
|
|
|
|
ARows:= Max(2, ClientHeight div FFontHeight);
|
|
AColumns:= Max(2, ClientWidth div FFontWidth);
|
|
|
|
if (ARows <> FVisibleRows) or (AColumns <> FColumns) then
|
|
begin
|
|
FColumns := AColumns;
|
|
FVisibleRows := ARows;
|
|
FRows := Max(FRows, FVisibleRows);
|
|
AdjustSize;
|
|
if not ((csLoading in ComponentState) or (csDesigning in ComponentState)) then
|
|
begin
|
|
FMainBuffer.Init(FRows, FColumns);
|
|
FAlternateBuffer.Init(FVisibleRows, FColumns);
|
|
if Assigned(FPtyDevice) then
|
|
FPtyDevice.SetScreenSize(FColumns, FVisibleRows);
|
|
Invalidate;
|
|
end;
|
|
UpdateScrollRange;
|
|
|
|
if (FCaretPos.Y = FBuffer.Rows) or
|
|
((FCaretPos.Y - FTopLeft.Y) >= FVisibleRows) then
|
|
begin
|
|
ARows:= FCaretPos.Y - FVisibleRows;
|
|
ModifyScrollBar(SB_Vert, SB_THUMBPOSITION, ARows);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
// vertical scroll
|
|
procedure TCustomComTerminal.WMHScroll(var Message: TWMHScroll);
|
|
begin
|
|
ModifyScrollBar(SB_HORZ, Message.ScrollCode, Message.Pos);
|
|
end;
|
|
|
|
// horizontal scroll
|
|
procedure TCustomComTerminal.WMVScroll(var Message: TWMVScroll);
|
|
begin
|
|
ModifyScrollBar(SB_VERT, Message.ScrollCode, Message.Pos);
|
|
end;
|
|
|
|
// set size to fit whole terminal screen
|
|
function TCustomComTerminal.CanAutoSize(var NewWidth,
|
|
NewHeight: Integer): Boolean;
|
|
var
|
|
Border: Integer;
|
|
begin
|
|
Result := True;
|
|
if Align in [alNone, alLeft, alRight] then
|
|
begin
|
|
NewWidth := FFontWidth * FColumns;
|
|
if BorderStyle = bsSingle then
|
|
begin
|
|
Border := SM_CXBORDER;
|
|
NewWidth := NewWidth + 2 * GetSystemMetrics(BORDER);
|
|
end;
|
|
end;
|
|
if Align in [alNone, alTop, alBottom] then
|
|
begin
|
|
NewHeight := FFontHeight * FRows;
|
|
if BorderStyle = bsSingle then
|
|
begin
|
|
Border := SM_CYBORDER;
|
|
NewHeight := NewHeight + 2 * GetSystemMetrics(Border);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
// set control parameters
|
|
procedure TCustomComTerminal.CreateParams(var Params: TCreateParams);
|
|
const
|
|
BorderStyles: array[TBorderStyle] of DWORD = (0, WS_BORDER);
|
|
begin
|
|
inherited CreateParams(Params);
|
|
with Params do
|
|
begin
|
|
Style := Style or BorderStyles[BorderStyle];
|
|
if NewStyleControls and (BorderStyle = bsSingle) then
|
|
begin
|
|
Style := Style and not WS_BORDER;
|
|
ExStyle := ExStyle or WS_EX_CLIENTEDGE;
|
|
end;
|
|
if FScrollBars in [ssVertical, ssBoth] then
|
|
Style := Style or WS_VSCROLL;
|
|
if FScrollBars in [ssHorizontal, ssBoth] then
|
|
Style := Style or WS_HSCROLL;
|
|
end;
|
|
ControlStyle := ControlStyle + [csOpaque];
|
|
end;
|
|
|
|
// key down
|
|
procedure TCustomComTerminal.KeyDown(var Key: Word; Shift: TShiftState);
|
|
var
|
|
Code: TEscapeCode;
|
|
begin
|
|
inherited KeyDown(Key, Shift);
|
|
|
|
if (Key in [VK_TAB, VK_ESCAPE]) then
|
|
begin
|
|
SendChar(Chr(Key));
|
|
Key:= 0;
|
|
Exit;
|
|
end;
|
|
|
|
if (Key = VK_BACK) then
|
|
begin
|
|
SendChar(#$7f);
|
|
Key:= 0;
|
|
Exit;
|
|
end;
|
|
|
|
if Key in [VK_F1..VK_F12] then
|
|
begin
|
|
Code := ecFuncKey;
|
|
FParams.Text:= IntToStr(Key - VK_F1);
|
|
SendCode(Code, FParams);
|
|
Exit;
|
|
end;
|
|
|
|
case Key of
|
|
VK_INSERT: Code := ecInsertKey;
|
|
VK_DELETE: Code := ecDeleteKey;
|
|
VK_PRIOR: Code := ecPageUpKey;
|
|
VK_NEXT: Code := ecPageDownKey;
|
|
else
|
|
Code := ecUnknown;
|
|
end;
|
|
|
|
if (Code <> ecUnknown) then
|
|
begin
|
|
SendCode(Code, nil);
|
|
Exit;
|
|
end;
|
|
|
|
case Key of
|
|
VK_UP: Code := ecCursorUp;
|
|
VK_DOWN: Code := ecCursorDown;
|
|
VK_LEFT: Code := ecCursorLeft;
|
|
VK_RIGHT: Code := ecCursorRight;
|
|
VK_HOME: Code := ecCursorHome;
|
|
VK_END: Code := ecCursorEnd;
|
|
else
|
|
Code := ecUnknown;
|
|
end;
|
|
if FTermMode.Keys = akTerminal then
|
|
begin
|
|
if Code <> ecUnknown then
|
|
if FArrowKeys = akTerminal then
|
|
SendCode(Code, nil)
|
|
else
|
|
PutEscapeCode(Code, nil);
|
|
end
|
|
else
|
|
case Code of
|
|
ecCursorUp: SendCode(ecAppCursorUp, nil);
|
|
ecCursorDown: SendCode(ecAppCursorDown, nil);
|
|
ecCursorLeft: SendCode(ecAppCursorLeft, nil);
|
|
ecCursorRight: SendCode(ecAppCursorRight, nil);
|
|
ecCursorHome: SendCode(ecAppCursorHome, nil);
|
|
ecCursorEnd: SendCode(ecAppCursorEnd, nil);
|
|
end;
|
|
{$IFDEF LCLGTK2}
|
|
if Key in [VK_UP, VK_DOWN] then
|
|
begin
|
|
Key:= 0;
|
|
end;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
// key pressed
|
|
procedure TCustomComTerminal.KeyPress(var Key: Char);
|
|
begin
|
|
inherited KeyPress(Key);
|
|
// SendChar(Key);
|
|
end;
|
|
|
|
procedure TCustomComTerminal.UTF8KeyPress(var UTF8Key: TUTF8Char);
|
|
begin
|
|
inherited UTF8KeyPress(UTF8Key);
|
|
SendChar(UTF8Key);
|
|
end;
|
|
|
|
procedure TCustomComTerminal.MouseDown(Button: TMouseButton;
|
|
Shift: TShiftState; X, Y: Integer);
|
|
begin
|
|
inherited MouseDown(Button, Shift, X, Y);
|
|
MouseEvent(ecMouseDown, Button, Shift, X, Y);
|
|
end;
|
|
|
|
procedure TCustomComTerminal.MouseUp(Button: TMouseButton; Shift: TShiftState;
|
|
X, Y: Integer);
|
|
begin
|
|
inherited MouseUp(Button, Shift, X, Y);
|
|
MouseEvent(ecMouseUp, Button, Shift, X, Y);
|
|
end;
|
|
|
|
procedure TCustomComTerminal.CreateWnd;
|
|
begin
|
|
inherited CreateWnd;
|
|
if FScrollBars in [ssVertical, ssBoth] then
|
|
ShowScrollBar(Handle, SB_VERT, True);
|
|
if FScrollBars in [ssHorizontal, ssBoth] then
|
|
ShowScrollBar(Handle, SB_HORZ, True);
|
|
end;
|
|
|
|
procedure TCustomComTerminal.Notification(AComponent: TComponent;
|
|
Operation: TOperation);
|
|
begin
|
|
inherited Notification(AComponent, Operation);
|
|
if (AComponent = FPtyDevice) and (Operation = opRemove) then
|
|
PtyDevice := nil;
|
|
end;
|
|
|
|
// paint characters
|
|
procedure TCustomComTerminal.PaintTerminal(Rect: TRect);
|
|
var
|
|
I, J, X, Y: Integer;
|
|
Ch: TComTermChar;
|
|
begin
|
|
HideCaret;
|
|
if (Rect.Bottom + FTopLeft.Y - 1) > FBuffer.Rows then
|
|
Dec(Rect.Bottom);
|
|
if (Rect.Right + FTopLeft.X - 1) > FBuffer.Columns then
|
|
Dec(Rect.Right);
|
|
for J := Rect.Top to Rect.Bottom do
|
|
begin
|
|
Y := J + FTopLeft.Y - 1;
|
|
for I := Rect.Left to Rect.Right do
|
|
begin
|
|
X := I + FTopLeft.X - 1;
|
|
Ch := FBuffer.GetChar(X, Y);
|
|
if Ch.Ch <> Chr(0) then
|
|
DrawChar(I, J, Ch);
|
|
end;
|
|
end;
|
|
ShowCaret;
|
|
end;
|
|
|
|
procedure TCustomComTerminal.PaintDesign;
|
|
begin
|
|
Canvas.TextOut(0, 0, 'Virtual Terminal Emulator');
|
|
end;
|
|
|
|
procedure TCustomComTerminal.Paint;
|
|
var
|
|
ARect: TRect;
|
|
begin
|
|
Canvas.Font := Font;
|
|
Canvas.Brush.Color := Color;
|
|
if csDesigning in ComponentState then
|
|
PaintDesign
|
|
else
|
|
begin
|
|
MoveCaret(FCaretPos.X, FCaretPos.Y);
|
|
// don't paint whole screen, but only the invalidated portion
|
|
ARect.Left := Canvas.ClipRect.Left div FFontWidth + 1;
|
|
ARect.Right := Min(Canvas.ClipRect.Right div FFontWidth + 1, FBuffer.Columns);
|
|
ARect.Top := Canvas.ClipRect.Top div FFontHeight + 1;
|
|
ARect.Bottom := Min(Canvas.ClipRect.Bottom div FFontHeight + 1, FBuffer.Rows);
|
|
PaintTerminal(ARect);
|
|
end;
|
|
end;
|
|
|
|
// creates caret
|
|
procedure TCustomComTerminal.CreateTerminalCaret;
|
|
begin
|
|
FCaretHeight := 0;
|
|
if FCaret = tcBlock then
|
|
FCaretHeight := FFontHeight
|
|
else
|
|
if FCaret = tcUnderline then
|
|
FCaretHeight := FFontHeight div 8;
|
|
if FCaretHeight > 0 then
|
|
begin
|
|
CreateCaret(Handle, 0, FFontWidth, FCaretHeight);
|
|
FCaretCreated := True;
|
|
end;
|
|
end;
|
|
|
|
// string received from com port
|
|
procedure TCustomComTerminal.StringReceived(Str: string);
|
|
begin
|
|
DoStrRecieved(Str);
|
|
WriteStr(Str);
|
|
end;
|
|
|
|
// draw one character on screen, but do not put it in buffer
|
|
procedure TCustomComTerminal.DrawChar(AColumn, ARow: Integer;
|
|
Ch: TComTermChar);
|
|
var
|
|
OldBackColor, OldFrontColor: Integer;
|
|
begin
|
|
OldBackColor := Canvas.Brush.Color;
|
|
OldFrontColor := Canvas.Font.Color;
|
|
Canvas.Brush.Color := Ch.BackColor;
|
|
Canvas.Font.Color := Ch.FrontColor;
|
|
if Ch.Bold then
|
|
Canvas.Font.Style := Canvas.Font.Style + [fsBold]
|
|
else begin
|
|
Canvas.Font.Style := Canvas.Font.Style - [fsBold];
|
|
end;
|
|
if Ch.Underline then
|
|
Canvas.Font.Style := Canvas.Font.Style + [fsUnderline]
|
|
else begin
|
|
Canvas.Font.Style := Canvas.Font.Style - [fsUnderline];
|
|
end;
|
|
Canvas.TextOut((AColumn - 1) * FFontWidth, (ARow - 1) * FFontHeight, Ch.Ch);
|
|
Canvas.Brush.Color := OldBackColor;
|
|
Canvas.Font.Color := OldFrontColor;
|
|
end;
|
|
|
|
procedure TCustomComTerminal.WrapLine(AWidth: Integer);
|
|
begin
|
|
if FCaretPos.X + AWidth > FBuffer.Columns + 1 then
|
|
begin
|
|
if FCaretPos.Y = FBuffer.Rows then
|
|
begin
|
|
FBuffer.ScrollDown;
|
|
MoveCaret(1, FCaretPos.Y);
|
|
end
|
|
else begin
|
|
MoveCaret(1, FCaretPos.Y + 1)
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
// move caret after new char is put on screen
|
|
procedure TCustomComTerminal.AdvanceCaret(Kind: TAdvanceCaret);
|
|
var
|
|
I: Integer;
|
|
begin
|
|
case Kind of
|
|
acChar:
|
|
begin
|
|
if (FCaretPos.X < FColumns) or FWrapLines then
|
|
MoveCaret(FCaretPos.X + 1, FCaretPos.Y);
|
|
end;
|
|
acReturn: MoveCaret(1, FCaretPos.Y);
|
|
acLineFeed:
|
|
begin
|
|
if FCaretPos.Y = FBuffer.FScrollRange.Bottom then
|
|
FBuffer.ScrollDown
|
|
else
|
|
MoveCaret(FCaretPos.X, FCaretPos.Y + 1);
|
|
end;
|
|
acReverseLineFeed:
|
|
begin
|
|
if FCaretPos.Y = FBuffer.FScrollRange.Top then
|
|
FBuffer.ScrollUp
|
|
else
|
|
MoveCaret(FCaretPos.X, FCaretPos.Y - 1);
|
|
end;
|
|
acBackSpace: MoveCaret(FCaretPos.X - 1, FCaretPos.Y);
|
|
acTab:
|
|
begin
|
|
I := FBuffer.NextTab(FCaretPos.X + 1);
|
|
if I > 0 then
|
|
MoveCaret(I, FCaretPos.Y);
|
|
end;
|
|
acPage:
|
|
ClearScreen;
|
|
end;
|
|
if FAutoFollow then
|
|
begin
|
|
if (FCaretPos.Y - FTopLeft.Y) >= FVisibleRows then
|
|
begin
|
|
I:= FCaretPos.Y - FVisibleRows + 1;
|
|
ModifyScrollBar(SB_Vert, SB_THUMBPOSITION, I);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
// set character attributes
|
|
procedure TCustomComTerminal.SetAttributes(AParams: TStrings);
|
|
var
|
|
I, Value: Integer;
|
|
|
|
procedure AllOff;
|
|
begin
|
|
FTermAttr.FrontColor := Font.Color;
|
|
FTermAttr.BackColor := Color;
|
|
FTermAttr.Invert := False;
|
|
FTermAttr.Bold := False;
|
|
FTermAttr.Underline := False;
|
|
end;
|
|
|
|
function GetExtendedColor(var Index: Integer): TColor;
|
|
var
|
|
RGB: Integer;
|
|
R, G, B: Byte;
|
|
AParam: Integer;
|
|
begin
|
|
AParam:= FEscapeCodes.GetParam(Index + 1, AParams);
|
|
// Color from RGB value
|
|
if AParam = 2 then
|
|
begin
|
|
R:= FEscapeCodes.GetParam(Index + 2, AParams);
|
|
G:= FEscapeCodes.GetParam(Index + 3, AParams);
|
|
B:= FEscapeCodes.GetParam(Index + 4, AParams);
|
|
Result:= RGBToColor(R, G, B);
|
|
Inc(Index, 4);
|
|
end
|
|
// Color from 256 color palette
|
|
else if (AParam = 5) then
|
|
begin
|
|
RGB:= FEscapeCodes.GetParam(Index + 2, AParams);
|
|
if (RGB >= 0) and (RGB < 256) then
|
|
begin
|
|
Result:= Color256Table[RGB];
|
|
end;
|
|
Inc(Index, 2);
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
I:= 1;
|
|
if AParams.Count = 0 then
|
|
AllOff;
|
|
while I <= AParams.Count do
|
|
begin
|
|
Value := FEscapeCodes.GetParam(I, AParams);
|
|
case Value of
|
|
0: AllOff;
|
|
1: FTermAttr.Bold := True;
|
|
4: FTermAttr.Underline := True;
|
|
7: FTermAttr.Invert := True;
|
|
22: FTermAttr.Bold := False;
|
|
24: FTermAttr.Underline := False;
|
|
27: FTermAttr.Invert := False;
|
|
|
|
// Extended foreground color
|
|
38: FTermAttr.FrontColor := GetExtendedColor(I);
|
|
// Default foreground color
|
|
39: FTermAttr.FrontColor := Font.Color;
|
|
// Extended background color
|
|
48: FTermAttr.BackColor := GetExtendedColor(I);
|
|
// Default background color
|
|
49: FTermAttr.BackColor := Color;
|
|
|
|
// NEW foreground colors
|
|
else if (Value in [30..37]) then
|
|
FTermAttr.FrontColor := Color256Table[Value - 30]
|
|
// NEW background colors
|
|
else if (Value in [40..47]) then
|
|
FTermAttr.BackColor := Color256Table[Value - 40]
|
|
|
|
// BRIGHT foreground colors
|
|
else if (Value in [90..97]) then
|
|
FTermAttr.FrontColor := Color256Table[Value - 90 + 8]
|
|
// BRIGHT background colors
|
|
else if (Value in [100..107]) then
|
|
FTermAttr.BackColor := Color256Table[Value - 100 + 8]
|
|
|
|
else begin
|
|
DoUnhandledCode(ecAttributes, IntToStr(Value));
|
|
end;
|
|
end;
|
|
Inc(I);
|
|
end;
|
|
end;
|
|
|
|
procedure TCustomComTerminal.SetMode(AParams: TStrings; OnOff: Boolean);
|
|
var
|
|
Str: string;
|
|
begin
|
|
if AParams.Count = 0 then
|
|
Exit;
|
|
Str := AParams[0];
|
|
if Str = '?1' then
|
|
begin
|
|
if OnOff then
|
|
FTermMode.Keys := akWindows
|
|
else
|
|
FTermMode.Keys := akTerminal;
|
|
end
|
|
else if Str = '?7' then
|
|
FWrapLines := OnOff
|
|
else if Str = '?3' then
|
|
begin
|
|
if OnOff then
|
|
Columns := 132
|
|
else
|
|
Columns := 80;
|
|
end
|
|
else if Str = '?1002' then
|
|
FTermMode.MouseTrack:= OnOff
|
|
else if Str = '?1006' then
|
|
FTermMode.MouseMode:= OnOff
|
|
else if Str = '?1049' then
|
|
begin
|
|
FBuffer.FTopLeft:= FTopLeft;
|
|
FBuffer.FCaretPos:= FCaretPos;
|
|
if OnOff then
|
|
FBuffer := FAlternateBuffer
|
|
else begin
|
|
FBuffer := FMainBuffer;
|
|
end;
|
|
FTopLeft:= FBuffer.FTopLeft;
|
|
FCaretPos:= FBuffer.FCaretPos;
|
|
UpdateScrollRange;
|
|
Invalidate;
|
|
end
|
|
else begin
|
|
DoUnhandledMode(Str, OnOff);
|
|
end;
|
|
end;
|
|
|
|
// invalidate portion of screen
|
|
procedure TCustomComTerminal.InvalidatePortion(ARect: TRect);
|
|
var
|
|
Rect: TRect;
|
|
begin
|
|
Rect.Left := Max((ARect.Left - FTopLeft.X) * FFontWidth, 0);
|
|
Rect.Right := Max((ARect.Right - FTopLeft.X + 1) * FFontWidth, 0);
|
|
Rect.Top := Max((ARect.Top - FTopLeft.Y) * FFontHeight, 0);
|
|
Rect.Bottom := Max((ARect.Bottom - FTopLeft.Y + 1) * FFontHeight, 0);
|
|
InvalidateRect(Handle, @Rect, True);
|
|
end;
|
|
|
|
// modify scroll bar
|
|
procedure TCustomComTerminal.ModifyScrollBar(ScrollBar, ScrollCode,
|
|
Pos: Integer);
|
|
var
|
|
CellSize, OldPos, APos, Dx, Dy: Integer;
|
|
begin
|
|
if (ScrollCode = SB_ENDSCROLL) or
|
|
((ScrollCode = SB_THUMBTRACK) and not FSmoothScroll)
|
|
then
|
|
Exit;
|
|
if ScrollBar = SB_HORZ then
|
|
CellSize := FFontWidth
|
|
else
|
|
CellSize := FFontHeight;
|
|
APos := GetScrollPos(Handle, ScrollBar);
|
|
OldPos := APos;
|
|
case ScrollCode of
|
|
SB_LINEUP: Dec(APos);
|
|
SB_LINEDOWN: Inc(APos);
|
|
SB_PAGEUP: Dec(APos, ClientHeight div CellSize);
|
|
SB_PAGEDOWN: Inc(APos, ClientHeight div CellSize);
|
|
SB_THUMBPOSITION,
|
|
SB_THUMBTRACK: APos := Pos;
|
|
end;
|
|
SetScrollPos(Handle, ScrollBar, APos, True);
|
|
APos := GetScrollPos(Handle, ScrollBar);
|
|
if ScrollBar = SB_HORZ then
|
|
begin
|
|
FTopLeft.X := APos + 1;
|
|
Dx := (OldPos - APos) * FFontWidth;
|
|
Dy := 0;
|
|
end else
|
|
begin
|
|
FTopLeft.Y := APos + 1;
|
|
Dx := 0;
|
|
Dy := (OldPos - APos) * FFontHeight;
|
|
end;
|
|
if DoubleBuffered then
|
|
Invalidate
|
|
else
|
|
ScrollWindowEx(Handle, Dx, Dy, nil, nil, 0, nil, SW_ERASE or SW_INVALIDATE);
|
|
end;
|
|
|
|
// calculate scroll position
|
|
procedure TCustomComTerminal.UpdateScrollPos;
|
|
begin
|
|
if FScrollBars in [ssBoth, ssHorizontal] then
|
|
begin
|
|
SetScrollPos(Handle, SB_HORZ, FTopLeft.X - 1, True);
|
|
end;
|
|
if FScrollBars in [ssBoth, ssVertical] then
|
|
begin
|
|
SetScrollPos(Handle, SB_VERT, FTopLeft.Y - 1, True);
|
|
end;
|
|
end;
|
|
|
|
// calculate scroll range
|
|
procedure TCustomComTerminal.UpdateScrollRange;
|
|
var
|
|
OldScrollBars: TScrollStyle;
|
|
AHeight, AWidth: Integer;
|
|
|
|
// is scroll bar visible?
|
|
function ScrollBarVisible(Code: Word): Boolean;
|
|
var
|
|
Min, Max: Integer;
|
|
begin
|
|
Result := False;
|
|
if (ScrollBars = ssBoth) or
|
|
((Code = SB_HORZ) and (ScrollBars = ssHorizontal)) or
|
|
((Code = SB_VERT) and (ScrollBars = ssVertical)) then
|
|
begin
|
|
GetScrollRange(Handle, Code, Min, Max);
|
|
Result := Min <> Max;
|
|
end;
|
|
end;
|
|
|
|
procedure SetRange(Code, Max: Integer);
|
|
var
|
|
Info: TScrollInfo;
|
|
begin
|
|
Info:= Default(TScrollInfo);
|
|
Info.fMask := SIF_RANGE or SIF_PAGE;
|
|
Info.nMax := Max;
|
|
Info.nPage := 1;
|
|
SetScrollInfo(Handle, Code, Info, False);
|
|
end;
|
|
|
|
// set horizontal range
|
|
procedure SetHorzRange;
|
|
var
|
|
Max: Integer;
|
|
AColumns: Integer;
|
|
begin
|
|
if OldScrollBars in [ssBoth, ssHorizontal] then
|
|
begin
|
|
AColumns := AWidth div FFontWidth;
|
|
if AColumns >= FBuffer.Columns then
|
|
SetRange(SB_HORZ, 1) // screen is wide enough, hide scroll bar
|
|
else
|
|
begin
|
|
Max := FBuffer.Columns - (AColumns - 1);
|
|
SetRange(SB_HORZ, Max);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
// set vertical range
|
|
procedure SetVertRange;
|
|
var
|
|
Max, ARows: Integer;
|
|
begin
|
|
if OldScrollBars in [ssBoth, ssVertical] then
|
|
begin
|
|
ARows := AHeight div FFontHeight;
|
|
if ARows >= FBuffer.Rows then
|
|
SetRange(SB_VERT, 1) // screen is high enough, hide scroll bar
|
|
else
|
|
begin
|
|
Max := FBuffer.Rows - (ARows - 1);
|
|
SetRange(SB_VERT, Max);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
if (FScrollBars = ssNone) or (FBuffer = nil) then
|
|
Exit;
|
|
AHeight := ClientHeight;
|
|
AWidth := ClientWidth;
|
|
if ScrollBarVisible(SB_HORZ) then
|
|
Inc(AHeight, GetSystemMetrics(SM_CYHSCROLL));
|
|
if ScrollBarVisible(SB_VERT) then
|
|
Inc(AWidth, GetSystemMetrics(SM_CXVSCROLL));
|
|
// Temporarily mark us as not having scroll bars to avoid recursion
|
|
OldScrollBars := FScrollBars;
|
|
FScrollBars := ssNone;
|
|
try
|
|
SetHorzRange;
|
|
AHeight := ClientHeight;
|
|
SetVertRange;
|
|
if AWidth <> ClientWidth then
|
|
begin
|
|
AWidth := ClientWidth;
|
|
SetHorzRange;
|
|
end;
|
|
finally
|
|
FScrollBars := OldScrollBars;
|
|
end;
|
|
// range changed, update scroll bar position
|
|
UpdateScrollPos;
|
|
end;
|
|
|
|
// hide caret
|
|
procedure TCustomComTerminal.HideCaret;
|
|
begin
|
|
if FCaretCreated then
|
|
LCLIntf.HideCaret(Handle);
|
|
end;
|
|
|
|
// show caret
|
|
procedure TCustomComTerminal.ShowCaret;
|
|
begin
|
|
if FCaretCreated then
|
|
LCLIntf.ShowCaret(Handle);
|
|
end;
|
|
|
|
// send character to com port
|
|
procedure TCustomComTerminal.SendChar(Ch: TUTF8Char);
|
|
begin
|
|
if (FPtyDevice <> nil) and (FPtyDevice.Connected) then
|
|
begin
|
|
FPtyDevice.WriteStr(Ch);
|
|
if FLocalEcho then
|
|
begin
|
|
// local echo is on, show character on screen
|
|
HideCaret;
|
|
PutChar(Ch);
|
|
ShowCaret;
|
|
end;
|
|
// send line feeds after carriage return
|
|
if (Ch = Chr(13)) and FSendLF then
|
|
SendChar(Chr(10));
|
|
end;
|
|
end;
|
|
|
|
// send escape code
|
|
procedure TCustomComTerminal.SendCode(Code: TEscapeCode; AParams: TStrings);
|
|
begin
|
|
if (FPtyDevice <> nil) and (FPtyDevice.Connected) and (FEscapeCodes <> nil) then
|
|
begin
|
|
FPtyDevice.WriteStr(FEscapeCodes.EscCodeToStr(Code, AParams));
|
|
if FLocalEcho then
|
|
begin
|
|
// local echo is on, show character on screen
|
|
HideCaret;
|
|
PutEscapeCode(Code, AParams);
|
|
ShowCaret;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
// send escape code to port
|
|
procedure TCustomComTerminal.SendCodeNoEcho(Code: TEscapeCode; AParams: TStrings);
|
|
begin
|
|
if (FPtyDevice <> nil) and (FPtyDevice.Connected) and (FEscapeCodes <> nil) then
|
|
FPtyDevice.WriteStr(FEscapeCodes.EscCodeToStr(Code, AParams));
|
|
end;
|
|
|
|
procedure TCustomComTerminal.MouseEvent(Code: TEscapeCode;
|
|
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
|
|
var
|
|
AButton: Integer;
|
|
begin
|
|
if (FTermMode.MouseMode and FTermMode.MouseTrack) then
|
|
begin
|
|
case Button of
|
|
mbLeft: AButton:= 0;
|
|
mbRight: AButton:= 2;
|
|
mbMiddle: AButton:= 1;
|
|
else AButton:= Ord(Button);
|
|
end;
|
|
FParams.Text:= IntToStr(AButton);
|
|
FParams.Add(IntToStr(X div FFontWidth + 1));
|
|
FParams.Add(IntToStr(Y div FFontHeight + 1));
|
|
SendCodeNoEcho(Code, FParams);
|
|
end;
|
|
end;
|
|
|
|
// process escape code on screen
|
|
function TCustomComTerminal.PutEscapeCode(ACode: TEscapeCode; AParams: TStrings): Boolean;
|
|
begin
|
|
Result := True;
|
|
with FEscapeCodes do
|
|
case ACode of
|
|
ecCursorUp: MoveCaret(FCaretPos.X, FCaretPos.Y - GetParam(1, AParams));
|
|
ecCursorDown: MoveCaret(FCaretPos.X, FCaretPos.Y + GetParam(1, AParams));
|
|
ecCursorRight: MoveCaret(FCaretPos.X + GetParam(1, AParams), FCaretPos.Y);
|
|
ecCursorLeft: MoveCaret(FCaretPos.X - GetParam(1, AParams), FCaretPos.Y);
|
|
ecCursorNextLine: MoveCaret(1, FCaretPos.Y + GetParam(1, AParams));
|
|
ecCursorPrevLine: MoveCaret(1, FCaretPos.Y - GetParam(1, AParams));
|
|
ecCursorMove: MoveCaret(GetParam(2, AParams), GetParam(1, AParams));
|
|
ecCursorMoveX: MoveCaret(GetParam(1, AParams), FCaretPos.Y);
|
|
ecCursorMoveY: MoveCaret(FCaretPos.X, GetParam(1, AParams));
|
|
ecReverseLineFeed: AdvanceCaret(acReverseLineFeed);
|
|
ecEraseLineLeft: FBuffer.EraseLineLeft(FCaretPos.X, FCaretPos.Y);
|
|
ecEraseLineRight: FBuffer.EraseLineRight(FCaretPos.X, FCaretPos.Y);
|
|
ecEraseLine:
|
|
begin
|
|
FBuffer.EraseLineRight(1, FCaretPos.Y);
|
|
MoveCaret(1, FCaretPos.Y)
|
|
end;
|
|
ecEraseScreenLeft: FBuffer.EraseScreenLeft(FCaretPos.X, FCaretPos.Y);
|
|
ecEraseScreenRight: FBuffer.EraseScreenRight(FCaretPos.X, FCaretPos.Y);
|
|
ecEraseScreen:
|
|
begin
|
|
FBuffer.EraseScreenRight(1, 1);
|
|
FTopLeft := Classes.Point(1, 1);
|
|
MoveCaret(1, 1);
|
|
UpdateScrollRange;
|
|
end;
|
|
ecEraseChar: FBuffer.EraseChar(FCaretPos.X, FCaretPos.Y, GetParam(1, AParams));
|
|
ecDeleteChar: FBuffer.DeleteChar(FCaretPos.X, FCaretPos.Y, GetParam(1, AParams));
|
|
ecIdentify:
|
|
begin
|
|
AParams.Clear;
|
|
AParams.Add('2');
|
|
SendCodeNoEcho(ecIdentResponse, AParams);
|
|
end;
|
|
ecSetTab: FBuffer.SetTab(FCaretPos.X, True);
|
|
ecClearTab: FBuffer.SetTab(FCaretPos.X, False);
|
|
ecClearAllTabs: FBuffer.ClearAllTabs;
|
|
ecAttributes: SetAttributes(AParams);
|
|
ecSetMode: SetMode(AParams, True);
|
|
ecResetMode: SetMode(AParams, False);
|
|
ecReset:
|
|
begin
|
|
AParams.Clear;
|
|
AParams.Add('0');
|
|
SetAttributes(AParams);
|
|
end;
|
|
ecSaveCaret: SaveCaretPos;
|
|
ecRestoreCaret: RestoreCaretPos;
|
|
ecSaveCaretAndAttr: begin SaveCaretPos; SaveAttr; end;
|
|
ecRestoreCaretAndAttr: begin RestoreCaretPos; RestoreAttr; end;
|
|
ecQueryCursorPos:
|
|
begin
|
|
AParams.Clear;
|
|
AParams.Add(IntToStr(FCaretPos.Y));
|
|
AParams.Add(IntToStr(FCaretPos.X));
|
|
SendCodeNoEcho(ecReportCursorPos, AParams);
|
|
end;
|
|
ecQueryDevice: SendCodeNoEcho(ecReportDeviceOK, nil);
|
|
ecTest: PerformTest('E');
|
|
ecScrollRegion:
|
|
begin
|
|
FBuffer.FScrollRange.Top:= GetParam(1, AParams);
|
|
FBuffer.FScrollRange.Bottom:= GetParam(2, AParams);
|
|
end;
|
|
ecScrollDown,
|
|
ecInsertLine: FBuffer.InsertLine(FCaretPos.Y, GetParam(1, AParams));
|
|
ecScrollUp,
|
|
ecDeleteLine: FBuffer.DeleteLine(FCaretPos.Y, GetParam(1, AParams));
|
|
ecSoftReset:
|
|
begin
|
|
FTermMode.CharSet:= False;
|
|
FBuffer.FScrollRange.Top:= 1;
|
|
FBuffer.FScrollRange.Bottom:= FBuffer.Rows;
|
|
end;
|
|
ecCharSet:
|
|
begin
|
|
// Designate Character Set
|
|
if (AParams.Count > 0) and (Length(AParams[0]) > 0) then
|
|
FTermMode.CharSet:= (AParams[0] = '0');
|
|
end
|
|
else
|
|
Result := False;
|
|
end;
|
|
end;
|
|
|
|
// calculate font height and width
|
|
function TCustomComTerminal.CalculateMetrics: Boolean;
|
|
var
|
|
Metrics: TTextMetric;
|
|
begin
|
|
GetTextMetrics(Canvas.Handle, Metrics);
|
|
FFontHeight := Metrics.tmHeight;
|
|
FFontWidth := Metrics.tmAveCharWidth;
|
|
// allow only fixed pitch fonts
|
|
Result := (Metrics.tmPitchAndFamily and TMPF_FIXED_PITCH) = 0;
|
|
end;
|
|
|
|
// visual character is appears on screen
|
|
procedure TCustomComTerminal.DoChar(Ch: TUTF8Char);
|
|
begin
|
|
if Assigned(FOnChar) then
|
|
FOnChar(Self, Ch);
|
|
end;
|
|
|
|
// get custom escape codes processor
|
|
procedure TCustomComTerminal.DoGetEscapeCodes(
|
|
var EscapeCodes: TEscapeCodes);
|
|
begin
|
|
if Assigned(FOnGetEscapeCodes) then
|
|
FOnGetEscapeCodes(Self, EscapeCodes);
|
|
end;
|
|
|
|
// string recieved
|
|
procedure TCustomComTerminal.DoStrRecieved(var Str: string);
|
|
begin
|
|
if Assigned(FOnStrRecieved) then
|
|
FOnStrRecieved(Self, Str);
|
|
end;
|
|
|
|
// let application handle unhandled escape code
|
|
procedure TCustomComTerminal.DoUnhandledCode(Code: TEscapeCode;
|
|
Data: string);
|
|
begin
|
|
if Assigned(FOnUnhandledCode) then
|
|
FOnUnhandledCode(Self, Code, Data);
|
|
end;
|
|
|
|
procedure TCustomComTerminal.DoUnhandledMode(const Data: string; OnOff: Boolean);
|
|
begin
|
|
if Assigned(FOnUnhandledMode) then
|
|
FOnUnhandledMode(Self, Data, OnOff);
|
|
end;
|
|
|
|
function TCustomComTerminal.DoMouseWheel(Shift: TShiftState;
|
|
WheelDelta: Integer; MousePos: TPoint): Boolean;
|
|
var
|
|
APos: Integer;
|
|
begin
|
|
Result:= True;
|
|
APos:= GetScrollPos(Handle, SB_VERT);
|
|
if WheelDelta < 0 then
|
|
APos:= APos + Mouse.WheelScrollLines
|
|
else begin
|
|
APos:= APos - Mouse.WheelScrollLines;
|
|
end;
|
|
ModifyScrollBar(SB_VERT, SB_THUMBPOSITION, APos);
|
|
end;
|
|
|
|
// create escape codes processor
|
|
procedure TCustomComTerminal.CreateEscapeCodes;
|
|
begin
|
|
if csDesigning in ComponentState then
|
|
Exit;
|
|
case FEmulation of
|
|
teVT52: FEscapeCodes := TEscapeCodesVT52.Create;
|
|
teVT100orANSI: FEscapeCodes := TEscapeCodesVT100.Create;
|
|
else
|
|
begin
|
|
FEscapeCodes := nil;
|
|
DoGetEscapeCodes(FEscapeCodes);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
// perform screen test
|
|
procedure TCustomComTerminal.PerformTest(ACh: Char);
|
|
var
|
|
I, J: Integer;
|
|
TermCh: TComTermChar;
|
|
begin
|
|
with TermCh do
|
|
begin
|
|
Ch := ACh;
|
|
FrontColor := Font.Color;
|
|
BackColor := Color;
|
|
Underline := False;
|
|
end;
|
|
for I := 1 to FBuffer.Columns do
|
|
for J := 1 to FBuffer.Rows do
|
|
FBuffer.SetChar(I, J, TermCh);
|
|
Invalidate;
|
|
end;
|
|
|
|
// get current character properties
|
|
function TCustomComTerminal.GetCharAttr: TComTermChar;
|
|
begin
|
|
if FTermAttr.Invert then
|
|
// Result.FrontColor := Color
|
|
Result.FrontColor := FTermAttr.BackColor
|
|
else
|
|
// Result.BackColor := Font.Color;
|
|
Result.FrontColor := FTermAttr.FrontColor;
|
|
if FTermAttr.Invert then
|
|
// Result.BackColor := Font.Color
|
|
Result.BackColor := FTermAttr.FrontColor
|
|
else
|
|
// Result.FrontColor := Color
|
|
Result.BackColor := FTermAttr.BackColor;
|
|
// NEW end changes
|
|
Result.Bold := FTermAttr.Bold;
|
|
Result.Underline := FTermAttr.Underline;
|
|
Result.Ch := #0;
|
|
end;
|
|
|
|
// put one character on screen
|
|
procedure TCustomComTerminal.PutChar(Ch: TUTF8Char);
|
|
var
|
|
AWidth: Integer;
|
|
TermCh: TComTermChar;
|
|
begin
|
|
case Ch[1] of
|
|
#8: AdvanceCaret(acBackspace);
|
|
#9: AdvanceCaret(acTab);
|
|
#10: AdvanceCaret(acLineFeed);
|
|
#12: AdvanceCaret(acPage);
|
|
#13: AdvanceCaret(acReturn);
|
|
#32..#255:
|
|
begin
|
|
TermCh := GetCharAttr;
|
|
if not FTermMode.CharSet then
|
|
TermCh.Ch := Ch
|
|
else begin
|
|
case Ch[1] of
|
|
'j': TermCh.Ch := '┘';
|
|
'k': TermCh.Ch := '┐';
|
|
'l': TermCh.Ch := '┌';
|
|
'm': TermCh.Ch := '└';
|
|
'n': TermCh.Ch := '┼';
|
|
'q': TermCh.Ch := '─';
|
|
't': TermCh.Ch := '├';
|
|
'u': TermCh.Ch := '┤';
|
|
'v': TermCh.Ch := '┴';
|
|
'w': TermCh.Ch := '┬';
|
|
'x': TermCh.Ch := '│';
|
|
else TermCh.Ch := Ch;
|
|
end;
|
|
end;
|
|
AWidth:= UTF8Width(Ch);
|
|
if AWidth <= 0 then Exit;
|
|
if FWrapLines then WrapLine(AWidth);
|
|
FBuffer.SetChar(FCaretPos.X, FCaretPos.Y, TermCh);
|
|
DrawChar(FCaretPos.X - FTopLeft.X + 1, FCaretPos.Y - FTopLeft.Y + 1, TermCh);
|
|
AdvanceCaret(acChar);
|
|
Dec(AWidth);
|
|
while (AWidth > 0) do
|
|
begin
|
|
TermCh.Ch := #0;
|
|
FBuffer.SetChar(FCaretPos.X, FCaretPos.Y, TermCh);
|
|
AdvanceCaret(acChar);
|
|
Dec(AWidth);
|
|
end;
|
|
end;
|
|
end;
|
|
DoChar(Ch);
|
|
end;
|
|
|
|
// init caret
|
|
procedure TCustomComTerminal.InitCaret;
|
|
begin
|
|
CreateTerminalCaret;
|
|
MoveCaret(FCaretPos.X, FCaretPos.Y);
|
|
ShowCaret;
|
|
end;
|
|
|
|
// restore caret position
|
|
procedure TCustomComTerminal.RestoreCaretPos;
|
|
begin
|
|
MoveCaret(FSaveCaret.X, FSaveCaret.Y);
|
|
end;
|
|
|
|
// save caret position
|
|
procedure TCustomComTerminal.SaveCaretPos;
|
|
begin
|
|
FSaveCaret := FCaretPos;
|
|
end;
|
|
|
|
// restore attributes
|
|
procedure TCustomComTerminal.RestoreAttr;
|
|
begin
|
|
FTermAttr := FSaveAttr;
|
|
end;
|
|
|
|
// save attributes
|
|
procedure TCustomComTerminal.SaveAttr;
|
|
begin
|
|
FSaveAttr := FTermAttr;
|
|
end;
|
|
|
|
procedure TCustomComTerminal.RxBuf(Sender: TObject; const Buffer; Count: Integer);
|
|
var
|
|
L: Integer;
|
|
Str: String;
|
|
|
|
// append line feeds to carriage return
|
|
procedure AppendLineFeeds;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
I := 1;
|
|
while I <= Length(Str) do
|
|
begin
|
|
if Str[I] = Chr(13) then
|
|
Str := Copy(Str, 1, I) + Chr(10) + Copy(Str, I + 1, Length(Str) - I);
|
|
Inc(I);
|
|
end;
|
|
end;
|
|
|
|
// convert to 7 bit data
|
|
procedure Force7BitData;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
for I := 1 to Length(Str) do
|
|
Str[I] := Char(Byte(Str[I]) and $0FFFFFFF);
|
|
end;
|
|
|
|
begin
|
|
if (Length(FPartChar) = 0) then
|
|
begin
|
|
SetLength(Str, Count);
|
|
Move(Buffer, Str[1], Count);
|
|
end
|
|
else begin
|
|
L:= Length(FPartChar);
|
|
SetLength(Str, Count + L);
|
|
Move(FPartChar[1], Str[1], L);
|
|
Move(Buffer, Str[L + 1], Count);
|
|
FPartChar:= EmptyStr;
|
|
end;
|
|
if FForce7Bit then
|
|
begin
|
|
Force7BitData;
|
|
end;
|
|
if FAppendLF then
|
|
begin
|
|
AppendLineFeeds;
|
|
end;
|
|
StringReceived(Str);
|
|
end;
|
|
|
|
function TCustomComTerminal.GetConnected: Boolean;
|
|
begin
|
|
Result := False;
|
|
if FPtyDevice <> nil then
|
|
Result := FPtyDevice.Connected;
|
|
end;
|
|
|
|
procedure TCustomComTerminal.SetConnected(const Value: Boolean);
|
|
begin
|
|
if FPtyDevice <> nil then
|
|
FPtyDevice.Connected := Value;
|
|
end;
|
|
|
|
procedure TCustomComTerminal.SetScrollBars(const Value: TScrollStyle);
|
|
begin
|
|
if FScrollBars <> Value then
|
|
begin
|
|
FScrollBars := Value;
|
|
RecreateWnd(Self);
|
|
end;
|
|
end;
|
|
|
|
procedure TCustomComTerminal.SetColumns(const Value: Integer);
|
|
begin
|
|
if Value <> FColumns then
|
|
begin
|
|
FColumns := Min(Max(2, Value), 256);
|
|
AdjustSize;
|
|
if not ((csLoading in ComponentState) or (csDesigning in ComponentState)) then
|
|
begin
|
|
FMainBuffer.Init(0, FColumns);
|
|
FAlternateBuffer.Init(0, FColumns);
|
|
if Assigned(FPtyDevice) then
|
|
FPtyDevice.SetScreenSize(FColumns, FVisibleRows);
|
|
Invalidate;
|
|
end;
|
|
UpdateScrollRange;
|
|
end;
|
|
end;
|
|
|
|
procedure TCustomComTerminal.SetRows(const Value: Integer);
|
|
var
|
|
ARows: Integer;
|
|
begin
|
|
ARows := Max(Value, FVisibleRows);
|
|
if ARows <> FRows then
|
|
begin
|
|
FRows := ARows;
|
|
if not ((csLoading in ComponentState) or (csDesigning in ComponentState)) then
|
|
begin
|
|
FMainBuffer.Init(FRows, 0);
|
|
end;
|
|
UpdateScrollRange;
|
|
end;
|
|
end;
|
|
|
|
procedure TCustomComTerminal.SetEmulation(const Value: TTermEmulation);
|
|
begin
|
|
if FEmulation <> Value then
|
|
begin
|
|
FEmulation := Value;
|
|
if not (csLoading in ComponentState) then
|
|
begin
|
|
FEscapeCodes.Free;
|
|
CreateEscapeCodes;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TCustomComTerminal.SetCaret(const Value: TTermCaret);
|
|
begin
|
|
if Value <> FCaret then
|
|
begin
|
|
FCaret := Value;
|
|
if Focused then
|
|
begin
|
|
DestroyCaret(Handle);
|
|
InitCaret;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TCustomComTerminal.SetPtyDevice(const Value: TCustomPtyDevice);
|
|
begin
|
|
if Value <> FPtyDevice then
|
|
begin
|
|
if FPtyDevice <> nil then
|
|
begin
|
|
FPtyDevice.OnRxBuf:= nil;
|
|
end;
|
|
FPtyDevice := Value;
|
|
if FPtyDevice <> nil then
|
|
begin
|
|
FPtyDevice.OnRxBuf:= RxBuf;
|
|
FPtyDevice.FreeNotification(Self);
|
|
FPtyDevice.SetScreenSize(FColumns, FVisibleRows);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
end.
|