emulvt.pas

BaiduMp3 search baidu mp3

    { 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;
{$IFDEF DEBUG_OUTPUT}
var
    Buf : String[20];
{$ENDIF}
begin
{$IFDEF DEBUG_OUTPUT}
    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; // WM + SE 09/08/00 }
    FAttribute       := F_WHITE;
    InvClear;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
destructor TScreen.Destroy;
var
    nRow : Integer;
begin
    for nRow := 0 to FRowCount + FBackRowCount - 1 do
        FLines^[nRow].Free;
    FreeMem (FLines, (FRowCount + FBackRowCount) * SizeOf(TObject));
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TScreen.AdjustFLines(NewCount : Integer);
var
    NewLines        : PLineArray;
    CurrCount       : Integer;
    nRow            : Integer;
begin
    CurrCount := FRowCount + FBackRowCount;
    if  (NewCount <> CurrCount) and (NewCount > 0) then begin
        GetMem(NewLines, NewCount * SizeOf(TObject));
        if NewCount > CurrCount then begin
            if CurrCount <> 0 then
                Move(FLines^, NewLines^, CurrCount * SizeOf(TObject));
            for nRow := CurrCount to NewCount - 1 do
                NewLines^[nRow] := TLine.Create;
            if CurrCount <> 0 then
                FreeMem(FLines, CurrCount * SizeOf(TObject));
        end
        else begin
            Move (FLines^, NewLines^, NewCount * SizeOf(TObject));
            for nRow := NewCount to CurrCount - 1 do
                FLines^[nRow].Free;
            FreeMem(FLines, CurrCount * SizeOf(TObject));
        end;
        FLines := NewLines;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TScreen.SetRowCount(NewCount : Integer);
begin
    if NewCount <> FRowCount then begin
        AdjustFLines(NewCount + FBackRowCount);
        FRowCount := NewCount;
        FScrollRowBottom := FRowCount - 1; { WM + SE 09/08/00 }
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TScreen.SetBackRowCount(NewCount : Integer);
begin
    if NewCount <> FBackRowCount then begin
        AdjustFLines(FRowCount + NewCount);
        FBackRowCount := NewCount;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TScreen.CopyScreenToBack;
{ Copies the current host screen into the scrollback buffer. }
var
    Temp : TLine;
    Row  : Integer;
    Pass : Integer;
    nCol : Integer;
begin
    if FBackRowCount >= FRowCount then begin
        Dec (FBackEndRow, FRowCount);
        if (0 - FBackEndRow) >= FBackRowCount then
            FBackEndRow := 1 - FBackRowCount;
        { We have to make  FRowCount  lines available at the head of the
          scrollback buffer.  These will come from the end of the scrollback
          buffer.  We'll make  FRowCount  passes through the scrollback buffer
          moving the available lines up to the top and the existing lines
          down a page at a time.
          Net result is that we only move each line once. }
        For Pass := 0 To FRowCount - 1 Do begin
            Row := FBackEndRow + Pass;
            Temp := Lines[Row];
            Inc (Row, FRowCount);
            While Row < 0 Do begin
                Lines[Row - FRowCount] := Lines[Row];
                Inc (Row, FRowCount);
            end;
            Lines[Row - FRowCount] := Temp;
        end;

        { Now, copy the host screen lines to the ones we made available. }
        For Row := 0 To FRowCount - 1 Do begin
            Move (Lines[Row].Txt, Lines[Row - FRowCount].Txt, FColCount);
            Move (Lines[Row].Att, Lines[Row - FRowCount].Att, FColCount);
            if vtoBackColor in FOptions then begin
                with Lines[Row - FRowCount] do begin
                    for nCol := 0 to FColCount - 1 do begin
                        Att[nCol] := Att[nCol] And $8F Or (Ord (FBackColor) shl 4);
                    end;
                end;
            end;
        end;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TScreen.ScrollUp;
var
    Temp : TLine;
    Row  : Integer;
    nCol : Integer;
begin
    if FBackRowCount > 0 then begin
        if (0 - FBackEndRow) < (FBackRowCount - 1) then
            Dec (FBackEndRow);
        Temp := Lines[FBackEndRow];
        For Row := FBackEndRow + 1 To -1 Do begin
            Lines[Row - 1] := Lines[Row];
        end;
        Lines[-1] := Lines[FScrollRowTop];
            if vtoBackColor in FOptions then begin
                with Lines[-1] do begin
                    for nCol := 0 to FColCount - 1 do begin
                        Att[nCol] := Att[nCol] And $8F Or (Ord (FBackColor) shl 4);
                    end;
                end;
            end;

    end
    else
        Temp := Lines[FScrollRowTop];

    for Row := FScrollRowTop + 1 to FScrollRowBottom do
        Lines[Row - 1] := Lines[Row];
    Lines[FScrollRowBottom] := Temp;
    Temp.Clear(F_WHITE {FAttribute});
    FAllInvalid := TRUE;