emulvt.pas

Delphi 网络通信协议代码,是多种网络协议的实现代码

      #$BF, #$20, #$AC, #$BD, #$BC, #$A1, #$AB, #$BB,   { A8 - AF }
      #$A0, #$A0, #$A0, #$A6, #$A6, #$A6, #$A6, #$AD,   { B0 - B7 }
      #$2B, #$A6, #$A6, #$2B, #$2B, #$2B, #$2B, #$2B,   { B8 - BF }
      #$2B, #$AD, #$AD, #$AD, #$A6, #$AD, #$2B, #$A6,   { C0 - C7 }
      #$2B, #$2B, #$AD, #$AD, #$A6, #$AD, #$2B, #$AD,   { C8 - CF }
      #$AD, #$AD, #$AD, #$2B, #$2B, #$2B, #$2B, #$2B,   { D0 - D7 }
      #$2B, #$2B, #$2B, #$A0, #$A0, #$A0, #$A0, #$A0,   { D8 - DF }
      #$20, #$20, #$20, #$AD, #$20, #$20, #$B5, #$20,   { E0 - E7 }
      #$20, #$20, #$20, #$20, #$20, #$F8, #$20, #$20,   { E8 - EF }
      #$A0, #$B1, #$20, #$20, #$20, #$20, #$F7, #$20,   { F0 - F7 }
      #$B0, #$B0, #$B0, #$20, #$20, #$B2, #$A0, #$20);  { F8 - FF }

procedure Register;
procedure FKeysToFile(var FKeys : TFuncKeysTable; FName : String);
procedure FileToFKeys(var FKeys : TFuncKeysTable; FName : String);
function  AddFKey(var FKeys : TFuncKeysTable;
                  ScanCode  : Char;
                  Shift     : TShiftState;
                  Ext       : Boolean;
                  Value     : TFuncKeyValue) : Boolean;



implementation
{$DEFINE Debug}      { Add or remove minus sign before dollar sign to }
                     { generate code for debug message output         }
var
    FCharPos : array [0..MAX_COL + 1] of integer;
    FLinePos : array [0..MAX_ROW + 1] of integer;

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


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function ShiftStateToString(var State : TShiftState) : String;
begin
    Result := '';
    if ssShift in State then
        Result := Result + 'ssShift ';
    if ssAlt in State then
        Result := Result + 'ssAlt ';
    if ssCtrl in State then
        Result := Result + 'ssCtrl ';
    if ssLeft in State then
        Result := Result + 'ssLeft ';
    if ssRight in State then
        Result := Result + 'ssRight ';
    if ssMiddle in State then
        Result := Result + 'ssMiddle ';
    if ssDouble in State then
        Result := Result + 'ssDouble ';
    if Result = '' then
        Result := 'ssNormal';
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function StringToShiftState(var S : String) : TShiftState;
begin
    Result := [];
    if Pos('ssShift', S) <> 0 then
        Result := Result + [ssShift];
    if Pos('ssAlt', S) <> 0 then
        Result := Result + [ssAlt];
    if Pos('ssCtrl', S) <> 0 then
        Result := Result + [ssCtrl];
    if Pos('ssLeft', S) <> 0 then
        Result := Result + [ssLeft];
    if Pos('ssRight', S) <> 0 then
        Result := Result + [ssRight];
    if Pos('ssMiddle', S) <> 0 then
        Result := Result + [ssMiddle];
    if Pos('ssDouble', S) <> 0 then
        Result := Result + [ssDouble];
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function xdigit(Ch : char) : integer;
begin
    if ch in ['0'..'9'] then
        Result := Ord(ch) - ord('0')
    else if ch in ['A'..'Z'] then
        Result := Ord(ch) - Ord('A') + 10
    else if ch in ['a'..'z'] then
        Result := Ord(ch) - Ord('a') + 10
    else
        Result := 0;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function xdigit2(S : PChar) : integer;
begin
    Result := 16 * xdigit(S[0]) + xdigit(S[1]);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function FuncKeyValueToString(var S : TFuncKeyValue) : String;
var
    I : Integer;
begin
    Result := '';
    for I := 1 to Length(S) do begin
        if (Ord(S[I]) < 32) or (Ord(S[I]) >= 127) or
           (S[I] = '''') or (S[I] = '\') then
            Result := Result + '\x' + IntToHex(Ord(S[I]), 2)
        else
            Result := Result + S[I];
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function StringToFuncKeyValue(var S : String) : TFuncKeyValue;
var
    I : Integer;
begin
    Result := '';
    I := 1;
    while I <= Length(S) do begin
        if (S[I] = '\') and
           ((I + 3) <= Length(S)) and
           (S[I + 1] = 'x') then begin
            Result := Result + chr(xdigit2(@S[I + 2]));
            I := I + 3;
        end
        else
            Result := Result + S[I];
        Inc(I);
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function AddFKey(var FKeys : TFuncKeysTable;
                  ScanCode  : Char;
                  Shift     : TShiftState;
                  Ext       : Boolean;
                  Value     : TFuncKeyValue) : Boolean;
var
    I : Integer;
begin
    { Search for existing key definition to replace it }
    for I := Low(FKeys) to High(FKeys) do begin
        if (FKeys[I].ScanCode = ScanCode) and
           (FKeys[I].Shift    = Shift) and
           (FKeys[I].Ext      = Ext) then begin
            FKeys[I].Value := Value;
            Result         := TRUE;     { Success}
            Exit;
        end;
    end;

    { Key not existing, add in an empty space }
    for I := Low(FKeys) to High(FKeys) do begin
        if FKeys[I].ScanCode = #0 then begin
            FKeys[I].ScanCode := ScanCode;
            FKeys[I].Shift    := Shift;
            FKeys[I].Ext      := Ext;
            FKeys[I].Value    := Value;
            Result            := TRUE;     { Success}
            Exit;
        end;
    end;

    { Failure, no more space available }
    Result := FALSE;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure FKeysToFile(var FKeys : TFuncKeysTable; FName : String);
var
    I : Integer;
    F : TextFile;
begin
    AssignFile(F, FName);
    Rewrite(F);
    for I := Low(FKeys) to High(FKeys) do begin
        with FKeys[I] do begin
            if ScanCode <> chr(0) then
                WriteLn(F, IntToHex(Ord(ScanCode), 2), ', ',
                           ShiftStateToString(Shift), ', ',
                           Ext, ', ''',
                           FuncKeyValueToString(Value), '''');
        end;
    end;
    CloseFile(F);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function GetToken(var S : String; var I : Integer; Delim : Char) : String;
begin
    Result := '';
    while (I <= Length(S)) and (S[I] = ' ') do
        Inc(I);
    while (I <= Length(S)) and (S[I] <> Delim) do begin
        Result := Result + S[I];
        Inc(I);
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure FileToFKeys(var FKeys : TFuncKeysTable; FName : String);
var
    I, J : Integer;
    F : TextFile;
    S, T : String;
    sc   : Integer;
begin
    AssignFile(F, FName);
 {$I-}
    Reset(F);
    if IOResult <> 0 then begin
        { File do not exist, create default one }
        FKeysToFile(FKeys, FName);
        Exit;
    end;

    for I := Low(FKeys) to High(FKeys) do begin
        with FKeys[I] do begin
            ScanCode := chr(0);
            Shift    := [];
            Ext      := FALSE;
            Value    := '';
            if not Eof(F) then begin
                { 71, ssNormal, TRUE, '\x1B[H' }
                ReadLn(F, S);
                J  := 1;
                T  := GetToken(S, J, ',');
                if (Length(T) > 0) and (T[1] <> ';') then begin
                    sc := xdigit2(@T[1]);
                    if sc <> 0 then begin
                        ScanCode := chr(sc);
                        Inc(J);
                        T := GetToken(S, J, ',');
                        Shift := StringToShiftState(T);
                        Inc(J);
                        T := GetToken(S, J, ',');
                        Ext := UpperCase(T) = 'TRUE';
                        Inc(J);
                        T := GetToken(S, J, '''');
                        Inc(J);
                        T := GetToken(S, J, '''');
                        Value := StringToFuncKeyValue(T);
                    end;
                end;
            end;
        end;
    end;
    CloseFile(F);
{$I+}
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure DebugString(Msg : String);
const
    Cnt : Integer=0;
var
    Buf : String[20];
begin
{$IFDEF Debug}
    //Cnt := Cnt + 1;
    Buf := IntToHex(Cnt, 4) + ' ' + #0;
    OutputDebugString(@Buf[1]);

{$IFNDEF WIN32}
    if Length(Msg) < High(Msg) then
        Msg[Length(Msg) + 1] := #0;
{$ENDIF}

    OutputDebugString(@Msg[1]);
{$ENDIF}
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{$IFNDEF WIN32}
procedure SetLength(var S: string; NewLength: Integer);
begin
    S[0] := chr(NewLength);
end;
{$ENDIF}


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
constructor TLine.Create;
begin
    inherited Create;
    FillChar(Txt, SizeOf(Txt), ' ');
    FillChar(Att, SizeOf(Att), Chr(F_WHITE));
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TLine.Clear(Attr : Byte);
begin
    FillChar(Txt, SizeOF(Txt), ' ');
    FillChar(Att, SizeOf(Att), Attr);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
constructor TScreen.Create;
begin
    inherited Create;
    FRowCount        := 0;
    FBackRowCount    := 0;
    FBackEndRow      := 0;
    FBackColor       := vtsWhite;
    FOptions         := [vtoBackColor];
    SetRowCount(25);
    FColCount        := 80;
    FRowSaved        := -1;
    FColSaved        := -1;
    FScrollRowTop    := 0;
    FScrollRowBottom := FRowCount - 1;
    FAttribute       := F_WHITE;
    InvClear;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}