emulvt.pas

< Delphi网络通信协议分析与应用实现>>一书的源代码。

unit Emulvt;

{$B-}    { Partial boolean evaluation }

interface

{$DEFINE SINGLE_CHAR_PAINT}
{$DEFINE CHAR_ZOOM}

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, ClipBrd;

const
  EmulVTVersion      = 212;
  CopyRight : String = 'TEmulVT';
  MAX_ROW            = 50;
  MAX_COL            = 132;
  TopMargin          = 0;
  LeftMargin         = 0;
  RightMargin        = 0;
  BottomMargin       = 0;
  NumPaletteEntries  = 16;

type
  TBackColors     = (vtsBlack, vtsRed,     vtsGreen, vtsYellow,
                     vtsBlue,  vtsMagenta, vtsCyan,  vtsWhite);

  TScreenOption   = (vtoBackColor, vtoCopyBackOnClear);
  TScreenOptions  = set of TScreenOption;
  TXlatTable      = array [0..255] of char;
  PXlatTable      = ^TXlatTable;
  TFuncKeyValue   = String[50];
  PFuncKeyValue   = ^TFuncKeyValue;
  TFuncKey        = record
                        ScanCode : Char;
                        Shift    : TShiftState;
                        Ext      : Boolean;
                        Value    : TFuncKeyValue;
                    end;
  TFuncKeysTable  = array [0..63] of TFuncKey;
  PFuncKeysTable  = ^TFuncKeysTable;
  TKeyBufferEvent = procedure (Sender : TObject; Buffer : PChar; Len : Integer) of object;
  TKeyDownEvent   = procedure (Sender        : TObject;
                               var VirtKey   : Integer;
                               var Shift     : TShiftState;
                               var ShiftLock : Boolean;
                               var ScanCode  : Char;
                               var Ext       : Boolean) of object;


type
  { TLine is an object used to hold one line of text on screen }
  TLine = class(TObject)
  public
    Txt : array [0..MAX_COL] of char;
    Att : array [0..MAX_COL] of Byte;
    constructor Create;
    procedure   Clear(Attr : Byte);
  end;
  TLineArray      = array [0..16382] of TLine;
  PLineArray      = ^TLineArray;

  { TScreen is an object to hold an entire screen of line and handle }
  { Ansi escape sequences to update this virtual screen              }
  TScreen = class(TObject)
  public
    FLines           : PLineArray;
    FRow             : Integer;
    FCol             : Integer;
    FRowSaved        : Integer;
    FColSaved        : Integer;
    FScrollRowTop    : Integer;
    FScrollRowBottom : Integer;
    FAttribute       : Byte;
    FForceHighBit    : Boolean;
    FReverseVideo    : Boolean;
    FUnderLine       : Boolean;
    FRowCount        : Integer;
    FColCount        : Integer;
    FBackRowCount    : Integer;
    FBackEndRow      : Integer;
    FBackColor       : TBackColors;
    FOptions         : TScreenOptions;
    FEscBuffer       : String[80];
    FEscFlag         : Boolean;
    Focused          : Boolean;
    FAutoLF          : Boolean;
    FAutoCR          : Boolean;
    FAutoWrap        : Boolean;
    FCursorOff       : Boolean;
    FCKeyMode        : Boolean;
    FNoXlat          : Boolean;
    FNoXlatInitial   : Boolean;
    FCntLiteral      : Integer;
    FCarbonMode      : Boolean;
    FXlatInputTable  : PXlatTable;
    FXlatOutputTable : PXlatTable;
    FCharSetG0       : Char;
    FCharSetG1       : Char;
    FCharSetG2       : Char;
    FCharSetG3       : Char;
    FAllInvalid      : Boolean;
    FInvRect         : TRect;
    FOnCursorVisible : TNotifyEvent;
    constructor Create;
    destructor  Destroy; override;
    procedure   AdjustFLines(NewCount : Integer);
    procedure   CopyScreenToBack;
    procedure   SetRowCount(NewCount : Integer);
    procedure   SetBackRowCount(NewCount : Integer);
    procedure   InvRect(nRow, nCol : Integer);
    procedure   InvClear;
    procedure   SetLines(I : Integer; Value : TLine);
    function    GetLines(I : Integer) : TLine;
    procedure   WriteChar(Ch : Char);
    procedure   WriteStr(Str : String);
    function    ReadStr : String;
    procedure   GotoXY(X, Y : Integer);
    procedure   WriteLiteralChar(Ch : Char);
    procedure   ProcessEscape(EscCmd : Char);
    procedure   SetAttr(Att : Char);
    procedure   CursorRight;
    procedure   CursorLeft;
    procedure   CursorDown;
    procedure   CursorUp;
    procedure   CarriageReturn;
    procedure   ScrollUp;
    procedure   ScrollDown;
    procedure   ClearScreen;
    procedure   BackSpace;
    procedure   Eol;
    procedure   Eop;
    procedure   ProcessESC_D;                { Index                   }
    procedure   ProcessESC_M;                { Reverse index           }
    procedure   ProcessESC_E;                { Next line               }
    procedure   ProcessCSI_u;                { Restore Cursor          }
    procedure   ProcessCSI_I;                { Select IBM char set     }
    procedure   ProcessCSI_J;                { Clear the screen        }
    procedure   ProcessCSI_K;                { Erase to End of Line    }
    procedure   ProcessCSI_L;                { Insert Line             }
    procedure   ProcessCSI_M;                { Delete Line             }
    procedure   ProcessCSI_m_lc;             { Select Attributes       }
    procedure   ProcessCSI_n_lc;             { Cursor position report  }
    procedure   ProcessCSI_at;               { Insert character        }
    procedure   ProcessCSI_r_lc;             { Scrolling margins       }
    procedure   ProcessCSI_s_lc;             { Save cursor location    }
    procedure   ProcessCSI_u_lc;             { Restore cursor location }
    procedure   ProcessCSI_7;                { Save cursor location    }
    procedure   ProcessCSI_8;                { Restore cursor location }
    procedure   ProcessCSI_H;                { Set Cursor Position     }
    procedure   ProcessCSI_h_lc;             { Terminal mode set       }
    procedure   ProcessCSI_l_lc;             { Terminal mode reset     }
    procedure   ProcessCSI_A;                { Cursor Up               }
    procedure   ProcessCSI_B;                { Cursor Down             }
    procedure   ProcessCSI_C;                { Cursor Right            }
    procedure   ProcessCSI_D;                { Cursor Left             }
    procedure   ProcessCSI_P;                { Delete Character        }
    procedure   ProcessCSI_S;                { Scroll up               }
    procedure   ProcessCSI_T;                { Scroll down             }
    procedure   process_charset_G0(EscCmd : Char);{ G0 character set   }
    procedure   process_charset_G1(EscCmd : Char);{ G1 character set   }
    procedure   process_charset_G2(EscCmd : Char);{ G2 character set   }
    procedure   process_charset_G3(EscCmd : Char);{ G3 character set   }
    procedure   UnimplementedEscape(EscCmd : Char);
    procedure   InvalidEscape(EscCmd : Char);
    function    GetEscapeParam(From : Integer; var Value : Integer) : Integer;
    property    OnCursorVisible : TNotifyEvent read  FonCursorVisible
                                               write FOnCursorVisible;
    property    Lines[I : Integer] : TLine read GetLines write SetLines;
  end;

  { TCustomEmulVT is an visual component wich does the actual display }
  { of a TScreen object wich is the virtual screen                    }
  { No property is published. See TEmulVT class                       }
  TCustomEmulVT = class(TCustomControl)
  private
    FScreen          : TScreen;
    FFileHandle      : TextFile;
    FCursorVisible   : Boolean;
    FCaretShown      : Boolean;
    FCaretCreated    : Boolean;
    FLineHeight      : Integer;
    FLineZoom        : Single;
    FCharWidth       : Integer;
    FCharZoom        : Single;
    FGraphicDraw     : Boolean;
    FInternalLeading : Integer;
    FBorderStyle     : TBorderStyle;
    FBorderWidth     : Integer;
    FAutoRepaint     : Boolean;
    FFont            : TFont;
    FVScrollBar      : TScrollBar;
    FTopLine         : Integer;
    FLocalEcho       : Boolean;
    FOnKeyBuffer     : TKeyBufferEvent;
    FOnKeyDown       : TKeyDownEvent;
    FFKeys           : Integer;
    FMonoChrome      : Boolean;
    FLog             : Boolean;
    FAppOnMessage    : TMessageEvent;
    FFlagCirconflexe : Boolean;
    FFlagTrema       : Boolean;
    FSelectRect      : TRect;
    FPal             : HPalette;
    FPaletteEntries  : array[0..NumPaletteEntries - 1] of TPaletteEntry;
    procedure   WMPaint(var Message: TWMPaint); message WM_PAINT;
    procedure   WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
    procedure   WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
    procedure   WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
    procedure   WMPaletteChanged(var Message : TMessage); message WM_PALETTECHANGED;
    procedure   VScrollBarScroll(Sender: TObject; ScrollCode: TScrollCode; var ScrollPos: Integer);
    procedure   SetCaret;
    procedure   AdjustScrollBar;
    procedure   KeyPress(var Key: Char); override;
    function    ProcessFKeys(ScanCode: Char; Shift: TShiftState; Ext: Boolean) : Boolean;
    function    FindFKeys(ScanCode: Char; Shift: TShiftState;
                          Ext: Boolean) : PFuncKeyValue;
    procedure   CursorVisibleEvent(Sender : TObject);
    procedure   SetFont(Value : TFont);
    procedure   SetAutoLF(Value : Boolean);
    procedure   SetAutoCR(Value : Boolean);
    procedure   SetXlat(Value : Boolean);
    procedure   SetLog(Value : Boolean);
    procedure   SetRows(Value : Integer);
    procedure   SetCols(Value : Integer);
    procedure   SetBackRows(Value : Integer);
    procedure   SetTopLine(Value : Integer);
    procedure   SetBackColor(Value : TBackColors);
    procedure   SetOptions(Value : TScreenOptions);
    procedure   SetLineHeight(Value : Integer);
    function    GetAutoLF : Boolean;
    function    GetAutoCR : Boolean;
    function    GetXlat : Boolean;
    function    GetRows : Integer;
    function    GetCols : Integer;
    function    GetBackRows : Integer;
    function    GetBackColor : TBackColors;
    function    GetOptions : TScreenOptions;
  protected
    procedure   AppMessageHandler(var Msg: TMsg; var Handled: Boolean);
    procedure   DoKeyBuffer(Buffer : PChar; Len : Integer); virtual;
    procedure   PaintGraphicChar(DC   : HDC;
                                 X, Y : Integer;
                                 rc   : PRect;
                                 ch   : Char);
  public
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy; override;
    procedure   ShowCursor;
    procedure   SetCursor(Row, Col : Integer);
    procedure   WriteChar(Ch : Char);
    procedure   WriteStr(Str : String);
    procedure   WriteBuffer(Buffer : Pointer; Len : Integer);
    function    ReadStr : String;
    procedure   CopyHostScreen;
    procedure   Clear;
    procedure   UpdateScreen;
    function    SnapPixelToRow(Y : Integer) : Integer;
    function    SnapPixelToCol(X : Integer) : Integer;
    function    PixelToRow(Y : Integer) : Integer;
    function    PixelToCol(X : Integer) : Integer;
    procedure   MouseToCell(X, Y: Integer; var ACol, ARow: Longint);
    procedure   SetLineZoom(newValue : Single);
    procedure   SetCharWidth(newValue : Integer);
    procedure   SetCharZoom(newValue : Single);
    property    LineZoom  : Single        read FLineZoom    write SetLineZoom;
    property    CharWidth : Integer       read FCharWidth   write SetCharWidth;
    property    CharZoom  : Single        read FCharZoom    write SetCharZoom;
    property    GraphicDraw : Boolean     read FGraphicDraw write FGraphicDraw;
    property    TopLine     : Integer     read FTopLine     write SetTopLine;
    property    VScrollBar  : TScrollBar  read FVScrollBar;
  private
    procedure   PaintOneLine(DC: HDC; Y, Y1 : Integer; const Line : TLine;
                             nColFrom : Integer; nColTo : Integer);
    procedure   SetupFont;
    property Text : String read ReadStr write WriteStr;
    property OnMouseMove;
    property OnMouseDown;
    property OnMouseUp;
    property OnClick;
    property OnKeyPress;
    property OnKeyBuffer : TKeyBufferEvent read FOnKeyBuffer write FOnKeyBuffer;
    property OnKeyDown   : TKeyDownEvent   read FOnKeyDown   write FOnKeyDown;
    property Ctl3D;
    property Align;
    property TabStop;
    property TabOrder;
    property BorderStyle: TBorderStyle read FBorderStyle write FBorderStyle;
    property AutoRepaint : Boolean     read FAutoRepaint write FAutoRepaint;
    property Font : TFont              read FFont        write SetFont;
    property LocalEcho : Boolean       read FLocalEcho   write FLocalEcho;
    property AutoLF : Boolean          read GetAutoLF    write SetAutoLF;
    property AutoCR : Boolean          read GetAutoCR    write SetAutoCR;
    property Xlat : Boolean            read GetXlat      write SetXlat;
    property MonoChrome : Boolean      read FMonoChrome  write FMonoChrome;
    property Log : Boolean             read FLog         write SetLog;
    property Rows : Integer            read GetRows      write SetRows;
    property Cols : Integer            read GetCols      write SetCols;
    property LineHeight : Integer      read FLineHeight  write SetLineHeight;
    property FKeys : Integer           read FFKeys       write FFKeys;
    property SelectRect : TRect        read FSelectRect  write FSelectRect;
    property BackRows : Integer        read GetBackRows  write SetBackRows;
    property BackColor : TBackColors   read GetBackColor write SetBackColor;
    property Options : TScreenOptions  read GetOptions   write SetOptions;
  end;

  { Same as TCustomEmulVT, but with published properties }
  TEmulVT = class(TCustomEmulVT)
  public
    property Screen : TScreen read FScreen;
    property SelectRect;
    property Text;
  published
    property OnMouseMove;
    property OnMouseDown;
    property OnMouseUp;
    property OnClick;
    property OnKeyPress;
    property OnKeyDown;
    property OnKeyBuffer;
    property Ctl3D;
    property Align;
    property BorderStyle;
    property AutoRepaint;
    property Font;
    property LocalEcho;
    property AutoLF;
    property AutoCR;
    property Xlat;
    property MonoChrome;