oopstelnet.pas

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

unit OopsTelnet;

{$R-}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, ScktComp, WinSock;

const
  TermMargins = 1;
  TempBufSize = 1024;
  MAX_ROW = 26;
  MAX_COL = 81;
  AnsiColorTable: array[0..15] of DWord = (
     $02000000, $02C00000, $0200C000, $02C0C000,   { Black, Blue, Green, Cyan }
     $020000C0, $02C000C0, $025480C0, $02C0C0C0,   { Red, Magenta, Brown, White }
     $02808080, $02FF0000, $0200FF00, $02FFFF00,   { Grey, Light Blue, Light Green, Light Cyan }
     $020000FF, $02FF00FF, $0200FFFF, $02FFFFFF ); { Light Red, Light Magenta Yellow, Bright White }
  { Telnet command characters }
  TNL_IAC       = #$FF; // IAC
  TNL_DONT      = #$FE; // Don't
  TNL_DO        = #$FD; // Do
  TNL_WONT      = #$FC; // Wont
  TNL_WILL      = #$FB; // Will
  TNL_SB        = #$FA; // Subnegociation
  TNL_GA        = #$F9; // Go ahead
  TNL_EL        = #$F8; // Erase line
  TNL_EC        = #$F7; // Erase character
  TNL_AYT       = #$F6; // Are you there
  TNL_AO        = #$F5; // Abort output
  TNL_IP        = #$F4; // Interrupt process
  TNL_BREAK     = #$F3; // charcater break
  TNL_DATA_MARK = #$F2; // Data stream portion of a Synch
  TNL_NOP       = #$F1; // No operation
  TNL_SE        = #$F0; // End of subnegociation parameters
  TNL_EOR       = #$EF; // End Of Record (preceded by IAC)
  { Telnet options, unlisted see RFC 991 }
  TNO_TRANSMIT_BINARY = #$00;
  TNO_ECHO            = #$01;
  TNO_RECONNECTION    = #$02;
  TNO_SUPPRESS_GA     = #$03;
  TNO_MSG_SZ_NEGOC    = #$04;
  TNO_STATUS          = #$05;
  TNO_TIMING_MARK     = #$06;
  TNO_RCTE            = #$07; { RFC 726 }
  TNO_NAOCRD          = #$0A; { RFC 652 }
  TNO_NAOHTS          = #$0B; { RFC 653 }
  TNO_NAOHTD          = #$0C; { RFC 654 }
  TNO_NAOFFD          = #$0D; { RFC 655 }
  TNO_NAOVTS          = #$0E; { RFC 656 }
  TNO_NAOVTD          = #$0F; { RFC 657 }
  TNO_NAOLFD          = #$10; { RFC 658 }
  TNO_EXTEND_ASCII    = #$11; { RFC 689 }
  TNO_BM              = #$13; { RFC 729 }
  TNO_DET             = #$14; { RFC 732 }
  TNO_SUPDUP_OUTPUT   = #$16; { RFC 749 }
  TNO_SEND_LOC        = #$17;
  TNO_TERMTYPE        = #$18;
  TNO_EOR             = #$19;
  TNO_OUTMRK          = #$1B; { RFC 933 }
  TNO_NAWS            = #$1F;
  TNO_TERMSPEED       = #$20;
  TNO_TF_CONTROL      = #$21; { RFC 1372 }
  TNO_XDISPLOC        = #$23;
  TNO_ENVIRON         = #$24; { RFC 1408 }
  TNO_AUTHENTICATION  = #$25; { RFC 1416 }
  TNO_NEW_ENVIRON     = #$27; { RFC 1572 }
  TNO_TN3270E         = #$28; { RFC 2355 }
  TNO_CHARSET         = #$2A; { RFC 2066 }
  TNO_EXOPL           = #$FF;
  { Telnet respond options for _TERMTYPE }
  TNTT_IS    = #0;
  TNTT_SEND  = #1;

type
  TCaretStyle = (csLine, csBlock);
  TLogTypes = (ltLogInfo, ltLogRFC, ltLogControl, ltLogText, ltOverWrite);
  TLogType = Set of TLogTypes;

  TCharAttrs = (csUnderline, csReverse, csBlink, csIntensity, csBlod,
                csCtlchar, csTabluation);
  TCharAttr = packed record
    Attr : set of TCharAttrs;
    Color: Byte;
  end;

  TOopsTelnet = class(TWinControl)
  private
    FActive: Boolean;
    FAttr: TCharAttr;
    FAutoCR: Boolean;
    FAutoLF: Boolean;
    FAutoWrap: Boolean;
    FBufAttr: array[0..MAX_ROW-1, 0..MAX_COL-1] of TCharAttr;
    FBufText: array[0..MAX_ROW-1, 0..MAX_COL-1] of Char;
    FBufTemp: PChar;
    FCaretCreated: Boolean;
    FCaretOff: Boolean;
    FCaretShown: Boolean;
    FCaretStyle: TCaretStyle;
    FClientSocket: TClientWinSocket;
    FCol: Integer;
    FColBackup: Integer;
    FColCount: Integer;
    FEscBuffer: string[MAX_COL];
    FFontSize: TSize;
    FHasFocus: Boolean;
    FKeyboardLocked: Boolean;
    FLocalEcho: Boolean;
    FRow: Integer;
    FRowBackup: Integer;
    FRowCount: Integer;
    FRowSpacing: Byte;
    FSelected: Boolean;
    FSelectRect: TRect;
    FTermType: string;
    FTracking: Boolean;
    FOnConnect: TSocketNotifyEvent;
    FOnDisconnect: TSocketNotifyEvent;
    FOnError: TSocketErrorEvent;
    function GetActive: Boolean;
    procedure SetCaret;
    procedure SetCaretOff(Value: Boolean);
    procedure SetCaretStyle(Value: TCaretStyle);
    procedure SetRowSpacing(Value: Byte);
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    procedure WMKillFocus(var Message: TMessage); message WM_KILLFOCUS;
    procedure WMSetFocus(var Message: TMessage); message WM_SETFOCUS;
  protected
    procedure Clear;
    procedure ClearLines(fromLine, Lines: Integer);
    procedure ClearLn(Func: Char);
    procedure CursorDown;
    procedure Error(Sender: TObject; Socket: TCustomWinSocket; ErrorEvent: TErrorEvent; var ErrorCode: Integer);
    procedure Event(Sender: TObject; Socket: TCustomWinSocket; SocketEvent: TSocketEvent);
    function GetEscapeParam(From: Integer; var Value: Integer): Integer;
    procedure GotoXY(X, Y: Integer);
    procedure InvLine(RowID: Integer);
    procedure MoveLines(fromLine, Lines, Step: Integer);
    procedure PaintLine(DC: HDC; r: TRect; LineID: Integer);
    procedure ProcessChar(Ch: Char);
    procedure ProcessCSI_7;
    procedure ProcessCSI_8;
    procedure ProcessCSI_A;
    procedure ProcessCSI_B;
    procedure ProcessCSI_C;
    procedure ProcessCSI_D;
    procedure ProcessCSI_E;
    procedure ProcessCSI_F;
    procedure ProcessCSI_G;
    procedure ProcessCSI_H;
    procedure ProcessCSI_I;
    procedure ProcessCSI_J;
    procedure ProcessCSI_K;
    procedure ProcessCSI_L;
    procedure ProcessCSI_M;
    procedure ProcessCSI_P;
    procedure ProcessCSI_S;
    procedure ProcessCSI_T;
    procedure ProcessCSI_X;
    procedure ProcessCSI_Z;
    procedure ProcessCSI_at;
    procedure ProcessCSI_h_lc;
    procedure ProcessCSI_l_lc;
    procedure ProcessCSI_m_lc;
    procedure ProcessEscape(EscCmd: Char);
    procedure ScrollUp;
    procedure SetupFont;
    procedure WriteLiteralChar(Ch: Char);
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyPress(var Key: Char); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
    procedure Close;
    procedure Open(Host: string; Port: Word);
    procedure SelectAll;
    procedure CopyToClipboard;
    procedure PasteFromClipboard;
    property Active: Boolean read GetActive;
    property Selected: Boolean read FSelected;
    property Socket: TClientWinSocket read FClientSocket;
  published
    property CaretStyle: TCaretStyle read FCaretStyle write SetCaretStyle;
    property Font;
     property RowSpacing: Byte read FRowSpacing write SetRowSpacing;
    property TermType: string read FTermType write FTermType;
    property OnConnect: TSocketNotifyEvent read FOnConnect write FOnConnect;
    property OnDisconnect: TSocketNotifyEvent read FOnDisconnect write FOnDisconnect;
    property OnError: TSocketErrorEvent read FOnError write FOnError;
  end;

procedure Register;

implementation

uses ClipBrd;

const
  LF           = #13#10;
  UNPROC       = '(未处理)';
  LOG_START_AT = LF+'★ Telnet 日志开始于 %s'+LF;
  LOG_STOP_AT  = LF+'★ Telnet 日志停止于 %s'+LF+LF;
  DISCONNECT   = LF+LF+'★ 与主机“%s”的连接断开'+LF;
  CONNECT_TO   = LF+'★ 连接到主机“%s”'+LF;
  ANSI_TERMCTRL = LF+'※ <ESC>%s ※';
  { Telnet command characters text }
  TNLS_IAC      = LF+'☆ IAC';
  TNLS_DONT     = ' Don''t';
  TNLS_DO       = ' Do';
  TNLS_WONT     = ' Won''t';
  TNLS_WILL     = ' Will';
  TNLS_SB       = ' BeginSubNegociation';
  TNLS_SE       = ' EndSubNegociation';
  TNLS_EOR      = ' Error';
  { Telnet options text }
  TNOS_ECHO        = ' Echo';
  TNOS_SUPPRESS_GA = ' SuppressGoAhead';
  TNOS_SEND_LOC    = ' SendLocation';
  TNOS_TERMTYPE    = ' TerminalType';
  TNOS_EOR         = ' Error';

{ Char Attr Functions }

procedure AttrSetFColor(var aAttr: TCharAttr; ClorIdx: Integer);
begin aAttr.Color:=(aAttr.Color and $F0) or ClorIdx end;

procedure AttrSetGColor(var aAttr: TCharAttr; ClorIdx: Integer);
begin aAttr.Color:=(aAttr.Color and $0F) or (ClorIdx shl 4) end;

procedure AttrSetDefault(var aAttr: TCharAttr);
begin aAttr.Color:=$07; aAttr.Attr:=[] end;

function AttrGetFColor(aAttr: TCharAttr): Word;
begin Result:=Word(aAttr.Color and $000F) end;

function AttrGetGColor(aAttr: TCharAttr): Word;
begin Result:=Word((aAttr.Color and $00F0) shr 4) end;

{ TOopsTelnet }

constructor TOopsTelnet.Create(AOwner: TComponent);
begin
  //RPR;
  inherited Create(AOwner);
  ControlStyle := [csAcceptsControls, csOpaque, csReplicatable, csSetCaption];
  FBufTemp:=AllocMem(TempBufSize);
  FClientSocket := TClientWinSocket.Create(INVALID_SOCKET);
  FClientSocket.OnSocketEvent:=Event;
  FClientSocket.OnErrorEvent:=Error;
  AttrSetDefault(FAttr);
  FAutoWrap := True;
  FCaretStyle := csLine;
  FRowSpacing:=1;
  FColCount:=80;
  FRowCount:=25;
  ParentColor:=False;
  Color:=clBlack;
  TabStop:=True;
  ClearLines(0, FRowCount);
end;

destructor TOopsTelnet.Destroy;
begin
  FClientSocket.Free;
  FreeMem(FBufTemp);
  inherited Destroy;
end;

procedure TOopsTelnet.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
  inherited SetBounds(ALeft, ATop, FFontSize.cx*FColCount + 2*TermMargins, FFontSize.cy*FRowCount+TermMargins*2);
end;

procedure TOopsTelnet.Event(Sender: TObject; Socket: TCustomWinSocket; SocketEvent: TSocketEvent);
var BufSize, i: Integer;
begin
  case SocketEvent of
    seConnect: begin
                 FActive := True;
                 if Assigned(FOnConnect) then FOnConnect(Self, Socket);
                 ShowCaret(Handle);
                 FCaretShown := True;
                end;
  seDisconnect:begin
                 FActive := False;
                 if Assigned(FOnDisconnect) then FOnDisconnect(Self, Socket);
                 if FCaretShown then begin
                   HideCaret(Handle);
                   FCaretShown := False;
                   Clear;
                 end;
                end;
       seRead: begin
                 if FSelected then begin
                   FSelected:= False;
                   Invalidate;
                 end;
                 BufSize:=Socket.ReceiveBuf(FBufTemp^, TempBufSize);
                 for i:=0 to BufSize-1 do ProcessChar((FBufTemp+i)^);
               end;
  end;
end;

procedure TOopsTelnet.Error(Sender: TObject; Socket: TCustomWinSocket; ErrorEvent: TErrorEvent; var ErrorCode: Integer);
begin
  if Assigned(FOnError) then FOnError(Self, Socket, ErrorEvent, ErrorCode);
end;

procedure TOopsTelnet.Close;
begin
  if Active then FClientSocket.Close;
end;

procedure TOopsTelnet.Open(Host: string; Port: Word);
begin
  if not Active then FClientSocket.Open(Host, '', '', Port);
end;

procedure TOopsTelnet.KeyDown(var Key: Word; Shift: TShiftState);
var KeyBuf: array[0..4]of Char;
    BufLen: Integer;
begin
  if Socket.Connected then begin
    BufLen:=0;
    KeyBuf[0]:=#$1B;
    KeyBuf[1]:='[';
    if Shift=[] then
     case Key of
      VK_UP    : begin KeyBuf[2]:='A'; BufLen:=3; end;
      VK_DOWN  : begin KeyBuf[2]:='B'; BufLen:=3; end;
      VK_RIGHT : begin KeyBuf[2]:='C'; BufLen:=3; end;
      VK_LEFT  : begin KeyBuf[2]:='D'; BufLen:=3; end;
      VK_PRIOR : begin KeyBuf[2]:='I'; BufLen:=3; end;
      VK_NEXT  : begin KeyBuf[2]:='G'; BufLen:=3; end;
      VK_HOME  : begin KeyBuf[2]:='H'; BufLen:=3; end;
      VK_END   : begin KeyBuf[2]:='F'; BufLen:=3; end;
      VK_INSERT: begin KeyBuf[2]:='L'; BufLen:=3; end;
      VK_DELETE: begin KeyBuf[0]:=#$7F; BufLen:=1; end;
      VK_F1..VK_F12: begin KeyBuf[2]:=Chr(Ord('M')+(Key-VK_F1)); BufLen:=3; end;
      end;
    if BufLen<>0 then Socket.SendBuf(KeyBuf[0], BufLen);
  end;
  inherited KeyDown(Key, Shift);
end;

procedure TOopsTelnet.KeyPress(var Key: Char);
begin
  if (Key<>#$FF) and Socket.Connected then Socket.SendBuf(Key, 1);
  inherited KeyPress(Key);
end;

procedure TOopsTelnet.Clear;
begin
  ClearLines(0, FRowCount);
  GotoXY(0, 0);
  Invalidate;
end;

procedure TOopsTelnet.ClearLines(fromLine, Lines: Integer);
var i, j: Integer;
begin
  for i:=fromLine to fromLine+Lines-1 do
    if (i>=0) and (i<FRowCount) then
      for j:=0 to FColCount-1 do begin
        FBufText[i, j]:=#$20;
        FBufAttr[i, j]:=FAttr;
      end;
end;

procedure TOopsTelnet.ClearLn(Func: Char);
var sCol, eCol, i: Integer;
begin
  case Func of
  '0': begin sCol:=FCol; eCol:=FColCount-1; end;
  '1': begin sCol:=0; eCol:=FCol; end;
  '2': begin sCol:=0; eCol:=FColCount-1; end;
  else Exit;
  end;
  for i:=sCol to eCol do begin
    FBufText[FRow, i]:=#$20;
    FBufAttr[FRow, i]:=FAttr;
  end;
end;

procedure TOopsTelnet.CursorDown;
begin
  Inc(FRow);
  if FRow > (FRowCount-1) then begin
    FRow := (FRowCount-1);
    ScrollUp;
  end;
  SetCaret;
end;

function TOopsTelnet.GetActive: Boolean;
begin
  Result:=Socket.Connected;
end;

function TOopsTelnet.GetEscapeParam(From: Integer; var Value: Integer): Integer;
begin
  Value := 0;
  while (From<=Length(FEscBuffer))and(FEscBuffer[From]in['0'..'9'])do begin
    Value:=Value*10+Ord(FEscBuffer[From])-Ord('0'); Inc(From); end;
  Result:=From;
end;

procedure TOopsTelnet.GotoXY(X, Y: Integer);
begin
  if X<0 then FCol:=0 else if X>=FColCount then FCol:=FColCount - 1 else FCol:=X;
  if Y<0 then FRow:=0 else if Y>=FRowCount then FRow:=FRowCount - 1 else FRow:=Y;
  SetCaret;
end;

procedure TOopsTelnet.InvLine(RowID: Integer);
var r: TRect;
begin
  r.Left:=0;
  r.Right:=Width;
  r.Top:=RowID * FFontSize.cy + TermMargins;
  r.Bottom:=r.Top + FFontSize.cy;
  InvalidateRect(Handle, @r, False);
end;

procedure TOopsTelnet.MoveLines(fromLine, Lines, Step: Integer);
var i: Integer;