mytelnet.~pas

telnet

    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 {协商选项}
        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 { 协商子选项 }
        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
        case Ch of
            TNL_IAC: WriteLiteralChar(Ch);
            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 TMyTelnet.ProcessCSI_7;
begin
  FColBackup:=FCol;
  FRowBackup:=FRow;
end;

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

procedure TMyTelnet.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 TMyTelnet.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 TMyTelnet.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 TMyTelnet.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 TMyTelnet.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 TMyTelnet.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 TMyTelnet.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 TMyTelnet.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 TMyTelnet.ProcessCSI_I;
begin
  if FEscBuffer[2]='=' then begin { Sets reverse background }
    FAttr.Color:=FAttr.Color xor $F0;
  end;
end;

procedure TMyTelnet.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 TMyTelnet.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 TMyTelnet.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 TMyTelnet.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 TMyTelnet.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 TMyTelnet.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 TMyTelnet.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 TMyTelnet.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 TMyTelnet.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 TMyTelnet.ProcessCSI_at;
var nChar, nCol: Integer;
begin
  GetEscapeParam(2, nChar);
  if nChar=0 then nChar:=1;
  if (FColCount-FCol-nChar)<=0 then begin ClearLn('0'); Exit end;
  for nCol:=FColCount-1 downto FCol+nChar do begin
    FBufText[FRow, nCol]:=FBufText[FRow, nCol-nChar];
    FBufAttr[FRow, nCol]:=FBufAttr[FRow, nCol-nChar];
    InvLine(Frow);
  end;
  for nCol:=FCol to FCol+nChar-1 do begin