oopstelnet.pas

一个Delphi的Telnet程序示例

{ ****************************************************** }
{ * TOopstelnet:          version 1.1, Jan 11, 2001.   * }
{ *                                                    * }
{ *   fixed up TOopsConsole and add TClientSocked in.  * }
{ *   Add StartLog, StopLog methord.                   * }
{ *   Add ClipBoard methords.                          * }
{ *   fixed up some Chinese display bug                * }
{ *                                                    * }
{ * Copyright (C)1995-2001,OopsWare Corp,China. Oops!  * }
{ * E-mail: [e-mail]               * }
{ *   Web : oopsware.qzone.com                         * }
{ ****************************************************** }

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;
    FLogging: Boolean;
    FLogStream: TStream;
    FLogType: TLogType;
    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);
    procedure LogChar(Ch: Char);
    procedure LogHex(Ch: Char);
    procedure LogString(Logs: string);
    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;
    procedure StartLog(LogFileName: string);
    procedure StopLog;
    property Active: Boolean read GetActive;
    property Logging: Boolean read FLogging;
    property Selected: Boolean read FSelected;
    property Socket: TClientWinSocket read FClientSocket;
  published
    property CaretStyle: TCaretStyle read FCaretStyle write SetCaretStyle;
    property Font;
    property LogType: TLogType read FLogType write FLogType;
    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;
  FLogType := [ltLogInfo, ltLogRFC, ltLogControl, ltLogText, ltOverWrite];
  FRowSpacing:=1;
  FColCount:=80;
  FRowCount:=25;
  ParentColor:=False;
  Color:=clBlack;
  TabStop:=True;
  ClearLines(0, FRowCount);
end;

destructor TOopsTelnet.Destroy;
begin
  FClientSocket.Free;
  StopLog;
  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;
                 if ltLogInfo in LogType then
                   LogString(Format(CONNECT_TO, [Socket.RemoteAddress]));
               end;
  seDisconnect:begin
                 FActive := False;
                 if Assigned(FOnDisconnect) then FOnDisconnect(Self, Socket);
                 if FCaretShown then begin
                   HideCaret(Handle);
                   FCaretShown := False;
                   Clear;
                 end;
                 if ltLogInfo in LogType then
                   LogString(Format(DISCONNECT, [Socket.RemoteAddress]));
               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