oopstelnet.pas

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

begin
  if (fromLine<0)or(fromLine>=FRowCount)or(Lines<1) then Exit;
  if Step>0 then for i:=(Lines-1) downto 0 do begin
    if (fromLine+Step+i) < FRowCount then begin
      Move(FBufAttr[fromLine+i], FBufAttr[fromLine+i+Step], FColCount*Sizeof(TCharAttr));
      Move(FBufText[fromLine+i], FBufText[fromLine+i+Step], FColCount) end;
  end;
  if Step<0 then for i:=0 to Lines-1 do begin
    if ((fromLine+Step+i)>=0)and((fromLine+i)<FRowCount) then begin
      Move(FBufAttr[fromLine+i], FBufAttr[fromLine+i+Step], FColCount*Sizeof(TCharAttr));
      Move(FBufText[fromLine+i], FBufText[fromLine+i+Step], FColCount) end;
  end;
end;

procedure TOopsTelnet.ProcessChar(Ch: Char);
const
  bIAC: Boolean=False;
  chVerb: Char=#0;
  strSubOption: string='';
  bSubNegoc: Boolean=False;
  EscFlag: Boolean=False;
var s: string;
  i: integer;
  bProcess: Boolean;

 procedure Answer(chAns, chOption: Char);
 begin
  s:=TNL_IAC + chAns + chOption;
  Socket.SendBuf(s[1], 3);
 end;

begin
  if chVerb<>#0 then begin
     case Ch of { Negociate Option }
     TNO_ECHO: case chVerb of
                TNL_WILL: begin Answer(TNL_DO,   Ch); FLocalEcho:=False end;
                TNL_WONT: begin Answer(TNL_DONT, Ch); FLocalEcho:=True end;
               end;
     TNO_SUPPRESS_GA: if chVerb=TNL_WILL then Answer(TNL_DO, Ch);
     TNO_TERMTYPE: if chVerb=TNL_DO then Answer(TNL_WILL, Ch);
     TNO_SEND_LOC: if chVerb=TNL_DO then begin
                     Answer(TNL_WILL, Ch);
                     s:=TNL_IAC+TNL_SB+TNO_SEND_LOC+'SinoTerm'+TNL_IAC+TNL_SE;
                     Socket.SendBuf(s[1], Length(s));
                   end;
     TNO_EOR:      if chVerb=TNL_DO then Answer(TNL_WILL, Ch);
     else if chVerb=TNL_WILL then Answer(TNL_DONT, Ch) else Answer(TNL_WONT, Ch);
    end;
    chVerb:=#0; strSubOption:=''; Exit end;
  if bSubNegoc then begin { Negociate SubOption }
    if Ch=TNL_SE then begin
      bSubNegoc:=False;
      if (strSubOption[1]=TNO_TERMTYPE)and(strSubOption[2]=TNTT_SEND) then begin
        s:=TNL_IAC+TNL_SB+TNO_TERMTYPE+TNTT_IS+FTermType+TNL_IAC+TNL_SE;
        Socket.SendBuf(s[1], Length(s)); end;
      strSubOption:='';
    end else strSubOption:=strSubOption+Ch;
    Exit;
  end;
  if bIAC then begin  { log all RFC854 control code }
   case Ch of
     TNL_IAC: WriteLiteralChar(Ch); { Double 0xFF means one. }
     TNL_DO, TNL_WILL, TNL_DONT, TNL_WONT: chVerb:=Ch;
     TNL_SB:  bSubNegoc:=True;
   end;
   bIAC:=False;
   Exit;
  end;

  if EscFlag then begin
    bProcess:=False;
    if (Length(FEscBuffer)=0)and(Ch in['H','c','7','8'])
    then bProcess:=True
    else if(Length(FEscBuffer)=1)and(FEscBuffer[1] in ['(',')','*','+'])
         then bProcess:=True
         else if(Ch in['0'..'9',';','?',' ','='])or
                ((Length(FEscBuffer)=0)and(Ch in['[','(',')','*','+']))
              then begin
                     FEscBuffer := FEscBuffer + Ch;
                     if Length(FEscBuffer)>=High(FEscBuffer) then begin
                       MessageBeep(MB_ICONASTERISK);
                       FEscBuffer:='';
                       EscFlag:=False; end;
              end else bProcess:=True;
    if bProcess then begin

      ProcessEscape(Ch);
      FEscBuffer := '';
      EscFlag := False;
    end;
    Exit;
  end;

  case Ch of
   #00: ;
   #07: MessageBeep(MB_ICONEXCLAMATION);
   #08: begin
          if FCol>0 then Dec(FCol);
          SetCaret;
        end;
   #09: begin
          repeat Inc(FCol) until(FCol Mod 8)=0;
          SetCaret;
        end;
   #10: begin
          CursorDown;
          if FAutoCR then FCol:=0;
        end;
   #13: begin
          FCol:=0;
          if FAutoLF then CursorDown;
        end;
   #27: begin
          FEscBuffer:='';
          EscFlag:=True;
        end;
   TNL_IAC: bIAC:=True;
   #32..#126: WriteLiteralChar(Ch);
   #$A1..#$FE: WriteLiteralChar(Ch);
  end;
end;

procedure TOopsTelnet.ProcessCSI_7;
begin
  FColBackup:=FCol;
  FRowBackup:=FRow;
end;

procedure TOopsTelnet.ProcessCSI_8;
begin
  FCol:=FColBackup;
  FRow:=FRowBackup;
  SetCaret;
end;

procedure TOopsTelnet.ProcessCSI_A;
var Row: Integer;
begin
  if FEscBuffer[2]='=' then begin
   { ^[=cA Sets overscan color to color c.  c is a decimal value
     taken from 'Color table' (This sequence may not be
     supported on all hardware) }
  end else begin
    GetEscapeParam(2, Row);
    if Row<=0 then Row:=1;
    FRow:=FRow - Row;
    if FRow<0 then FRow:=0;
    SetCaret;
  end;
end;

procedure TOopsTelnet.ProcessCSI_B;
var Row: Integer;
begin
  if FEscBuffer[2]='=' then begin
   { ^[=p;dB Sets the bell parameter to the decimal values of p
     and d.  p is the period of the bell tone in units of
     840.3 nanoseconds, and d is the duration of the tone
     in units of 100 milliseconds }
  end else begin
    GetEscapeParam(2, Row);
    if Row<=0 then Row:=1;
    FRow:=FRow + Row;
    if FRow>=FRowCount then FRow:=FRowCount-1;
    SetCaret;
  end;
end;

procedure TOopsTelnet.ProcessCSI_C;
var Col: Integer;
begin
  if FEscBuffer[2]='=' then begin
    GetEscapeParam(3, Col);  { ^[=s;eC Sets the cursor to start on scanline s and end on scanline e }
    case Col of
      14: SetCaretOff(True);  { ^[14;12C  invisible caret }
      10: SetCaretOff(False); { ^[12;10C  visible caret }
    end;
  end else begin
    GetEscapeParam(2, Col);
    if Col<=0 then Col:=1;
    FCol:=FCol+Col;
    if FCol>=FColCount then begin
      if FAutoWrap then begin
        FCol:=FCol-FColCount;
        Inc(FRow);
        if FRow>=FRowCount then FRow:=FRowCount - 1;
      end else FCol:=FColCount - 1;
    end;
    SetCaret;
  end;
end;

procedure TOopsTelnet.ProcessCSI_D;
var Col: Integer;
begin
  if FEscBuffer[2]='=' then begin
    case FEscBuffer[3] of { ^[=xD Turns the intensity of the background color }
    '0': Exclude(FAttr.Attr, csIntensity);
    '1': Include(FAttr.Attr, csIntensity);
    end;
  end else begin
    GetEscapeParam(2, Col);
    if Col=0 then Col:=1;
    FCol:=FCol-Col;
    if FCol<0 then FCol:=0;
    SetCaret;
  end;
end;

procedure TOopsTelnet.ProcessCSI_E;
var Row: Integer;
begin
  if FEscBuffer[2]='=' then
    case FEscBuffer[3] of
    '0': Exclude(FAttr.Attr, csBlink); { Clears the Blink versus Bold background bit in the 6845 CRT controller }
    '1': Include(FAttr.Attr, csBlink); { Sets the Blink versus Bold background bit in the 6845 CRT controller }
    end
  else begin { Moves active position to beginning of line, n lines down }
    GetEscapeParam(2, Row);
    if Row=0 then Row:=1;
    FRow:=FRow + Row;
    if FRow>=FRowCount then FRow:=FRowCount-1;
    FCol:=0;
    SetCaret;
  end;
end;

procedure TOopsTelnet.ProcessCSI_F;
var ClIdx, Row: Integer;
begin
  if FEscBuffer[2]='=' then begin { Sets foreground }
    GetEscapeParam(3, ClIdx);
    AttrSetFColor(FAttr, ClIdx);
  end else begin { Moves active position to beginning of line, n lines up }
    GetEscapeParam(2, Row);
    if Row=0 then Row:=1;
    FRow:=FRow - Row;
    if FRow<0 then FRow:=0;
    FCol:=0;
    SetCaret;
  end;
end;

procedure TOopsTelnet.ProcessCSI_G;
var ClIdx, Col: Integer;
begin
  if FEscBuffer[2]='=' then begin { Sets background }
    GetEscapeParam(3, ClIdx);
    AttrSetGColor(FAttr, ClIdx);
  end else begin { ^[nG Move the active position in the same way as <HPA> }
    GetEscapeParam(2, Col);
    FCol:=Col+1;
    SetCaret;
  end;
end;

procedure TOopsTelnet.ProcessCSI_H;
var From, Row, Col : Integer;
begin
  if FEscBuffer[2]='=' then begin { Sets reverse foreground }
    FAttr.Color:=FAttr.Color xor $0F;
  end else begin
    From:=GetEscapeParam(2, Row); { ^[H  (Row=0)Cursor and selects graphic }
    if Row=0 then Row:=1;
  //  while (From<=Length(FEscBuffer))and(FEscBuffer[From]=' ') do Inc(From);
    if FEscBuffer[From]=';' then GetEscapeParam(From+1, Col) else Col:=1;
    GotoXY(Col-1, Row-1);
  end;
end;

procedure TOopsTelnet.ProcessCSI_I;
begin
  if FEscBuffer[2]='=' then begin { Sets reverse background }
    FAttr.Color:=FAttr.Color xor $F0;
  end;
end;

procedure TOopsTelnet.ProcessCSI_J;
begin { Clear display. }
  if FEscBuffer[2]='=' then begin { Sets reverse foreground }
    FAttr.Color:=FAttr.Color xor $0F;
  end else begin
    if Length(FEscBuffer)=2 then
      case FEscBuffer[2] of
      '0': ClearLines(FRow, FRowCount-FRow); { erases from active position Display to end of display. }
      '1': ClearLines(0, FRow+1); { erases from the beginning of display to active position. }
      '2': ClearLines(0, FRowCount); { erases entire display }
      end
    else ClearLines(FRow+1, FRowCount-FRow); { erases from active position Display to end of display. }
    Invalidate;
    end;
end;

procedure TOopsTelnet.ProcessCSI_K;
var r: TRect;
    func, ClIdx: Integer;
begin
  if FEscBuffer[2]='=' then begin { Sets graphic background. }
    GetEscapeParam(3, ClIdx);
    AttrSetGColor(FAttr, ClIdx);
  end else begin  { Erases all or part of a line. }
    GetEscapeParam(2, func);
    if func in [0, 1, 2] then ClearLn(Chr(Ord('0')+func)) else Exit;
    r.Left:=TermMargins;
    r.Right:=r.Left + FFontSize.cx * FColCount;
    r.Top:=TermMargins + FFontSize.cy * FRow;
    r.Bottom:=r.Top + FFontSize.cy;
    InvalidateRect(Handle, @r, False);
  end;
end;

procedure TOopsTelnet.ProcessCSI_L;
var iLine: Integer;
begin
  if FEscBuffer[2]='=' then begin
    { ^[=nL Fills new regions with current (n=0) or normal (n=1)
            color attributes.  Default fill behavior is 0.
            Disables (n=2) or enables (n=3; default) iBCS2
            compliance for the TBC (CSIng) sequence.  When iBCS2
            compliance is enabled, TBC may be used to clear tab stops.
            Disables (n=4; default) or enables (n=5) ANSI
            compliance for the SGR 0 (CSI0m) sequence on the
            selected font.  When disabled (the default), SGR 0
            has no effect on the font.  When enabled, SGR 0
            selects the primary font, equivalent to issuing SGR 10 }
  end else begin
    GetEscapeParam(2, iLine);
    if iLine=0 then iLine:=1;
    MoveLines(FRow, FRowCount-FRow, iLine);
    ClearLines(FRow, iLine);
    Invalidate;
  end;
end;

function IntToOct(t: Word): string;
var j, k: integer;
begin
  j:=0; k:=1;
  while k<1000000000 do begin
   j:=(t and $0007)*k + j;
   k:=k*10;
   t:=t shr 3;
  end;
  Result:=IntToStr(j);
end;

procedure TOopsTelnet.ProcessCSI_M;
var dLine: Integer;
    s: string;
begin
  if FEscBuffer[2]='=' then begin { Returns current foreground color attributes }
    case FEscBuffer[3] of
    '0': s:=IntToOct(AttrGetFColor(FAttr))+IntToOct(AttrGetGColor(FAttr))+#10; { normal }
    '1': s:=IntToOct(AttrGetGColor(FAttr))+IntToOct(AttrGetFColor(FAttr))+#10; { reverse }
    '2': s:=''; { graphic ?? }
    else s:='' end;
    if s<>'' then Socket.SendBuf(s[1], Length(s));
  end else begin { Deletes n lines }
    GetEscapeParam(2, dLine);
    if dLine=0 then dLine:=1;
    MoveLines(FRow+dLine, FRowCount-FRow-dLine, -dLine);
    ClearLines(FRowCount-dLine, dLine);
    Invalidate;
  end;
end;

procedure TOopsTelnet.ProcessCSI_P;
var nChar, nCol: Integer;
begin
  GetEscapeParam(2, nChar);
  if nChar<=0 then nChar:=1;
  for nCol:=FCol to FColCount-nChar-1 do begin
    FBufText[FRow, nCol]:=FBufText[FRow, nCol+nChar];
    FBufAttr[FRow, nCol]:=FBufAttr[FRow, nCol+nChar];
    InvLine(FRow);
  end;
  for nCol:=FColCount-nChar-1 to FColCount-1 do begin
    FBufText[FRow, nCol]:=#$20;
    FBufAttr[FRow, nCol]:=FAttr;
    InvLine(FRow);
  end;
end;

procedure TOopsTelnet.ProcessCSI_S;
var nLine: Integer;
begin { Scrolls screen up n lines }
  GetEscapeParam(2, nLine);
  if nLine=0 then nLine:=1;
  MoveLines(nLine, FRowCount-nLine, -nLine);
  ClearLines(FRowCount-nLine, nLine);
  Invalidate;
end;

procedure TOopsTelnet.ProcessCSI_T;
var nLine: Integer;
begin { Scrolls screen down n lines }
  GetEscapeParam(2, nLine);
  if nLine=0 then nLine:=1;
  MoveLines(0, FRowCount-nLine, nLine);
  ClearLines(0, nLine);
  Invalidate;
end;

procedure TOopsTelnet.ProcessCSI_X;
var nChar, i: Integer;
begin { Erases n characters }
  GetEscapeParam(2, nChar);
  if nChar=0 then nChar:=1;
  for i:=FCol to FCol+nChar-1 do
    if i<FColCount then begin
      FBufText[FRow, FCol]:=#$20;
      FBufAttr[FRow, FCol]:=FAttr;
      InvLine(FRow);
    end;
end;

procedure TOopsTelnet.ProcessCSI_Z;
var nTab, i: Integer;
begin { Moves active position back n tab stops }
  GetEscapeParam(2, nTab);
  if nTab=0 then nTab:=1;
  for i:=1 to nTab do begin
    repeat Dec(FCol) until (FCol Mod 8) = 0;
    if FCol<=0 then Break;
  end;
  if FCol<0 then FCol:=0;
  SetCaret;
end;

procedure TOopsTelnet.ProcessCSI_at;
var nChar, nCol: Integer;
begin
  GetEscapeParam(2, nChar);
  if nChar=0 then nChar:=1;