tnemulvt.pas

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

{}
unit TnEmulvt;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, EmulVT, TnCnx, IniFiles, TnOptFrm, WSocket;

const
  TnEmultVTVersion = 207;
  CopyRight : String = ' TTnEmulVT';

type
  TTnEmulVTDataAvailable = procedure (Sender  : TObject;
                                      Buffer  : PChar;
                                      var Len : Integer) of object;
  TTnEmulVT = class(TEmulVT)
  public
    TnCnx               : TTnCnx;
  protected
    FError              : Word;
    FIniFilename        : String;
    FSectionName        : String;
    FKeyName            : String;
    FHostName           : String;
    FPort               : String;
    FTag                : LongInt;
    FUpperLock          : Boolean;
    FLocalEcho          : Boolean;
    FOnSessionClosed    : TNotifyEvent;
    FOnSessionConnected : TNotifyEvent;
    FOnNamesClick       : TNotifyEvent;
    FOnSendLoc          : TNotifyEvent;
    FOnTermType         : TNotifyEvent;
    FOnLocalEcho        : TNotifyEvent;
    FOnDataAvailable    : TTnEmulVTDataAvailable;
    FMouseDown          : Boolean;
    FMouseCaptured      : Boolean;
    FMouseTop           : Integer;
    FMouseLeft          : Integer;
    FFocusDrawn         : Boolean;
    FFocusRect          : TRect;
    procedure TriggerDataAvailable(Buffer: PChar; Len: Integer); virtual;
    procedure TnCnxDataAvailable(Sender: TTnCnx; Buffer: PChar; Len : Integer);
    procedure TnCnxSessionClosed(Sender: TTnCnx; Erc: Word);
    procedure TnCnxSessionConnected(Sender: TTnCnx; Erc: Word);
    procedure TnCnxSendLoc(Sender: TObject);
    procedure TnCnxTermType(Sender: TObject);
    procedure TnCnxLocalEcho(Sender: TObject);
    procedure Display(Msg : String);
    procedure KeyPress(var Key: Char); override;
    procedure DoKeyBuffer(Buffer : PChar; Len : Integer); 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;
    procedure   SetOnEndOfRecord(Value : TNotifyEvent);
    function    GetOnEndOfRecord : TNotifyEvent;
    procedure   SetLocation(Value : String);
    function    GetLocation : String;
    procedure   SetHostName(newValue : String);
  public
    procedure   RequestLocalEcho(newValue : Boolean);
    function    GetLocalEcho : Boolean;
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy; override;
    procedure   Connect;
    procedure   Disconnect;
    procedure   EditOptions;
    procedure   RestoreOptions;
    function    IsConnected : Boolean;
    function    Send(Data : Pointer; Len : Integer) : integer;
    function    SendStr(Data : String) : integer;
    function    GetSelTextBuf(Buffer: PChar; BufSize: Integer): Integer;
  published
    property IniFilename   : String  read FIniFileName write FIniFileName;
    property SectionName   : String  read FSectionName write FSectionName;
    property KeyName       : String  read FKeyName     write FKeyName;
    property Error         : Word    read FError       write FError;
    property HostName      : String  read FHostName    write SetHostName;
    property Port          : String  read FPort        write FPort;
    property Tag           : LongInt read FTag         write FTag;
    property Location      : String  read GetLocation  write SetLocation;
    property UpperLock     : Boolean read FUpperLock   write FUpperLock;
    property LocalEcho     : Boolean read FLocalEcho   write FLocalEcho;

    property OnKeyDown;
    property OnSessionClosed    : TNotifyEvent         read  FOnSessionClosed
                                                       write FOnSessionClosed;
    property OnSessionConnected : TNotifyEvent         read  FOnSessionConnected
                                                       write FOnSessionConnected;
    property OnEndOfRecord : TNotifyEvent              read  GetOnEndOfRecord
                                                       write SetOnEndOfRecord;
    property OnNamesClick : TNotifyEvent               read  FOnNamesClick
                                                       write FOnNamesClick;
    property OnSendLoc :    TNotifyEvent               read  FOnSendLoc
                                                       write FOnSendLoc;
    property OnTermType :    TNotifyEvent              read  FOnTermType
                                                       write FOnTermType;
    property OnLocalEcho :    TNotifyEvent             read  FOnLocalEcho
                                                       write FOnLocalEcho;
    property OnDataAvailable : TTnEmulVTDataAvailable  read  FOnDataAvailable
                                                       write FOnDataAvailable;
  end;

procedure Register;

implementation

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure Register;
begin
  RegisterComponents('FPiette', [TTnEmulVT]);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure FontToIni(Font : TFont; IniFile : TIniFile; Section : String);
var
    nBuf     : Integer;
begin
    IniFile.WriteString(Section,  'FontName',  Font.Name);
    IniFile.WriteInteger(Section, 'FontSize',  Font.Size);
    IniFile.WriteInteger(Section, 'FontPitch', ord(Font.Pitch));
    nBuf := 0;
    if fsBold in Font.Style then
        nBuf := nBuf or 1;
    if fsItalic in Font.Style then
        nBuf := nBuf or 2;
    if fsUnderline in Font.Style then
        nBuf := nBuf or 4;
    if fsStrikeOut in Font.Style then
        nBuf := nBuf or 8;
    IniFile.WriteInteger(Section, 'FontStyle', nBuf);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure IniToFont(Font : TFont; IniFile : TIniFile; Section : String);
var
    FontName : String;
    nBuf     : Integer;
begin
    FontName := IniFile.ReadString(Section, 'FontName', '*');
    if FontName <> '*' then begin
        Font.Name  := FontName;
        Font.Size  := IniFile.ReadInteger(Section, 'FontSize', 9);
        Font.Pitch := TFontPitch(IniFile.ReadInteger(Section, 'FontPitch', 12));
        nBuf       := IniFile.ReadInteger(Section, 'FontStyle', 0);
        Font.Style := [];
        if (nBuf and 1) <> 0 then
            Font.Style := Font.Style + [fsBold];
        if (nBuf and 2) <> 0 then
            Font.Style := Font.Style + [fsItalic];
        if (nBuf and 4) <> 0 then
            Font.Style := Font.Style + [fsUnderline];
        if (nBuf and 8) <> 0 then
            Font.Style := Font.Style + [fsStrikeOut];
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
constructor TTnEmulVT.Create(AOwner: TComponent);
var
    Rect : TRect;
begin
    inherited Create(AOwner);

    if TnCnxVersion < 203 then
        raise Exception.Create('TTnEmulVT need TTnCnx version 2.03 or higher ' +
                               'Please download last release from ' +
                               'http://www.rtfm.be/fpiette/indexuk.htm');

    TnCnx                    := TTnCnx.Create(Self);
    TnCnx.OnDataAvailable    := TnCnxDataAvailable;
    TnCnx.OnSessionClosed    := TnCnxSessionClosed;
    TnCnx.OnSessionConnected := TnCnxSessionConnected;
    TnCnx.OnSendLoc          := TnCnxSendLoc;
    TnCnx.OnTermType         := TnCnxTermType;
    TnCnx.OnLocalEcho        := TnCnxLocalEcho;

    FIniFileName := 'TNEMULVT.INI';
    FSectionName := 'Windows';
    FKeyName     := 'TnEmulVT';
    FPort        := 'telnet';
    Rect.Top     := -1;
    SelectRect   := Rect;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
destructor  TTnEmulVT.Destroy;
begin
    TnCnx.Free;
    inherited Destroy;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TTnEmulVT.SetHostName(newValue : String);
begin
    FHostName := newValue;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TTnEmulVT.GetLocalEcho : Boolean;
begin
    Result := TnCnx.LocalEcho;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TTnEmulVT.RequestLocalEcho(newValue : Boolean);
begin
    if newValue then
        TnCnx.DontOption(TN_ECHO)
    else
        TnCnx.DoOption(TN_ECHO);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TTnEmulVT.SetLocation(Value : String);
begin
    TnCnx.Location := Value;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TTnEmulVT.GetLocation : String;
begin
    Result := TnCnx.Location;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TTnEmulVT.Display(Msg : String);
begin
    WriteStr(Msg);
    Repaint;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TTnEmulVT.SetOnEndOfRecord(Value : TNotifyEvent);
begin
    TnCnx.OnEndOfRecord := Value;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TTnEmulVT.GetOnEndOfRecord : TNotifyEvent;
begin
    Result := TnCnx.OnEndOfRecord;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TTnEmulVT.TnCnxSendLoc(Sender: TObject);
begin
    if Assigned(FOnSendLoc) then
        FOnSendLoc(Self);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TTnEmulVT.TnCnxTermType(Sender: TObject);
begin
    if Assigned(FOnTermType) then
        FOnTermType(Self);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TTnEmulVT.TnCnxLocalEcho(Sender: TObject);
begin
    if Assigned(FOnLocalEcho) then
        FOnLocalEcho(Self);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TTnEmulVT.TriggerDataAvailable(Buffer: PChar; Len: Integer);
begin
    if Assigned(FOnDataAvailable) then
        FOnDataAvailable(Self, Buffer, Len);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TTnEmulVT.TnCnxDataAvailable(Sender: TTnCnx; Buffer: PChar;
  Len: Integer);
var
    I : Integer;
begin
    TriggerDataAvailable(Buffer, Len);

    if Len <= 0 then
        Exit;

    for I := 0 to Len - 1 do begin
        try
            WriteChar((Buffer + I)^);
        except
            Break;
        end;
    end;
    UpdateScreen;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TTnEmulVT.TnCnxSessionClosed(Sender: TTnCnx; Erc: Word);
begin
    Display(#13 + #10 + '*** Server has closed ***' + #13 + #10);
    MessageBeep(MB_ICONASTERISK);
    FError := Erc;
    if Assigned(FOnSessionClosed) then
        FOnSessionClosed(Self);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TTnEmulVT.TnCnxSessionConnected(Sender: TTnCnx; Erc: Word);
begin
    if Erc = 0 then begin
        Display('Connected' + #13 + #10);
    end
    else begin
        Display('Connection failed: ' +
{$IFDEF DELPHI}
                TnCnx.Socket.SocketErrorDesc(Error) +
{$ELSE}
                WSocketErrorDesc(Error) +
{$ENDIF}
                #13 + #10);
        MessageBeep(MB_ICONASTERISK);
    end;
    FError := Erc;
    if Assigned(FOnSessionConnected) then
        FOnSessionConnected(Self);
end;