mytelnet.pas

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

unit MyTelnet;

{$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;

  TMyTelnet = 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);
    function  isHan(x, y: Integer):Boolean;
    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;


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;

{ TMyTelnet }

constructor TMyTelnet.Create(AOwner: TComponent);
begin
    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 TMyTelnet.Destroy;
begin
    FClientSocket.Free;
    FreeMem(FBufTemp);
    inherited Destroy;
end;

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

procedure TMyTelnet.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 TMyTelnet.Error(Sender: TObject; Socket: TCustomWinSocket; ErrorEvent: TErrorEvent; var ErrorCode: Integer);
begin
    if Assigned(FOnError) then FOnError(Self, Socket, ErrorEvent, ErrorCode);
end;

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

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

procedure TMyTelnet.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 TMyTelnet.KeyPress(var Key: Char);
begin
    if (Key<>#$FF) and Socket.Connected then
        Socket.SendBuf(Key, 1);
    inherited KeyPress(Key);
end;

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

procedure TMyTelnet.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 TMyTelnet.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 TMyTelnet.CursorDown;
begin
  Inc(FRow);
  if FRow > (FRowCount-1) then begin
    FRow := (FRowCount-1);
    ScrollUp;
  end;
  SetCaret;
end;

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

function TMyTelnet.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 TMyTelnet.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 TMyTelnet.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 TMyTelnet.MoveLines(fromLine, Lines, Step: Integer);
var i: Integer;
begin
  if (fromLine<0)or(fromLine>=FRowCount)or(Lines<1) then Exit;
  if Step>0 then for i:=(Lines-1) downto 0 do begin
    if (fromLine+Step+i) < FRowCount then begin
      Move(FBufAttr[fromLine+i], FBufAttr[fromLine+i+Step], FColCount*Sizeof(TCharAttr));
      Move(FBufText[fromLine+i], FBufText[fromLine+i+Step], FColCount) end;
  end;
  if Step<0 then for i:=0 to Lines-1 do begin
    if ((fromLine+Step+i)>=0)and((fromLine+i)<FRowCount) then begin
      Move(FBufAttr[fromLine+i], FBufAttr[fromLine+i+Step], FColCount*Sizeof(TCharAttr));
      Move(FBufText[fromLine+i], FBufText[fromLine+i+Step], FColCount) end;
  end;
end;

procedure TMyTelnet.ProcessChar(Ch: Char);
const