emulvt.pas

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

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;
    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 ons 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;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TScreen.ScrollDown;
var
    Temp : TLine;
    Row  : Integer;
begin
    Temp := Lines[FScrollRowBottom];
    for Row := FScrollRowBottom DownTo FScrollRowTop + 1 do
        Lines[Row] := Lines[Row - 1];
    Lines[FScrollRowTop] := Temp;
    Temp.Clear(F_WHITE {FAttribute});
    FAllInvalid := TRUE;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TScreen.CursorDown;
begin
    Inc(FRow);
    if FRow > FScrollRowBottom then begin
        FRow := FScrollRowBottom;
        ScrollUp;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TScreen.CursorUp;
begin
    Dec(FRow);
    if FRow < 0 then begin
        Inc(FRow);
        ScrollDown;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TScreen.CursorRight;
begin
    Inc(FCol);
    if FCol >= FColCount then begin
        FCol := 0;
        CursorDown;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TScreen.CursorLeft;
begin
    Dec(FCol);
    if FCol < 0 then begin
        FCol := FColCount - 1;
        CursorUp;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TScreen.CarriageReturn;
begin
    FCol := 0;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TScreen.GetEscapeParam(From : Integer; var Value : Integer) : Integer;
begin
    while (From <= Length(FEscBuffer)) and (FEscBuffer[From] = ' ') do
        From := From + 1;

    Value := 0;
    while (From <= Length(FEscBuffer)) and (FEscBuffer[From] in ['0'..'9']) do begin
        Value := Value * 10 + Ord(FEscBuffer[From]) - Ord('0');
        From := From + 1;
    end;

    Result := From;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TScreen.UnimplementedEscape(EscCmd : Char);
{var
    Buf : String;}
begin
    DebugString('Unimplemented Escape Sequence: ' + FEscBuffer + EscCmd + #13 + #10);
{   Buf := FEscBuffer + EscCmd + #0;
    MessageBox(0, @Buf[1], 'Unimplemented Escape Sequence', MB_OK); }
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TScreen.InvalidEscape(EscCmd : Char);
{var
    Buf : String;}
begin
    DebugString('Invalid Escape Sequence: ' + FEscBuffer + EscCmd + #13 + #10);
{   Buf := FEscBuffer + EscCmd + #0;
    MessageBox(0, @Buf[1], 'Invalid Escape Sequence', MB_OK); }
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TScreen.ProcessESC_D;                   { Index                   }
begin
    UnimplementedEscape('D');
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ Move cursor Up, scroll down if necessary                                  }
procedure TScreen.ProcessESC_M;                   { Reverse index           }
begin
    Dec(FRow);
    if FRow < FScrollRowTop then begin
        FRow := FScrollRowTop;
        ScrollDown;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TScreen.ProcessESC_E;                   { Next line               }
begin
    UnimplementedEscape('E');
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TScreen.ProcessCSI_u;                  { Restore Cursor          }
begin
    UnimplementedEscape('u');
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ IBM character set operation (not part of the ANSI standard)		    }
{ <ESC>[0I		=> Set IBM character set			    }
{ <ESC>[1;nnnI		=> Literal mode for nnn next characters		    }
{ <ESC>[2;onoffI	=> Switch carbon mode on (1) or off (0)		    }
{ <ESC>[3;ch;cl;sh;slI	=> Receive carbon mode keyboard code		    }
{ <ESC>[4I              => Select ANSI character set                        }
procedure TScreen.ProcessCSI_I;
var
    From, mode, nnn : Integer;
    ch, cl, sh, sl  : Integer;
begin
    From := GetEscapeParam(2, Mode);

    case Mode of
    0:  begin                { Select IBM character set                     }
            FNoXlat := TRUE;
        end;
    1:	begin                { Set literal mode for next N characters       }
            if FEscBuffer[From] = ';' then
                GetEscapeParam(From + 1, FCntLiteral)
            else
                FCntLiteral := 1;
        end;
    2:	begin		     { Switch carbon mode on or off                 }
            if FEscBuffer[From] = ';' then
                GetEscapeParam(From + 1, nnn)
            else
                nnn := 0;
            FCarbonMode := (nnn <> 0);
        end;
    3:	begin		     { Receive carbon mode key code                 }
            ch := 0; cl := 0; sh := 0; sl := 0;
            if FEscBuffer[From] = ';' then begin
                From := GetEscapeParam(From + 1, cl);
                if FEscBuffer[From] = ';' then begin
                    From := GetEscapeParam(From + 1, ch);
                    if FEscBuffer[From] = ';' then begin
                        From := GetEscapeParam(From + 1, sl);
                        if FEscBuffer[From] = ';' then begin
                            GetEscapeParam(From + 1, sh);
                        end;
                    end;
                end;
            end;
            DebugString('Special key ' +
                        IntToHex(ch, 2) + IntToHex(cl, 2) + ' ' +
                        IntToHex(sh, 2) + IntToHex(sl, 2));
        end;
    4:	begin		     { Select ANSI character set                    }
            FNoXlat := FALSE;
        end;
    else
        UnimplementedEscape('I');
    end;