oopstelnet.pas

一个Delphi的Telnet程序示例

  if not Active then FClientSocket.Open(Host, '', '', Port);
end;

procedure TOopsTelnet.KeyDown(var Key: Word; Shift: TShiftState);
var KeyBuf: array[0..4]of Char;
    BufLen: Integer;
begin
  if Socket.Connected then begin
    BufLen:=0;
    KeyBuf[0]:=#$1B;
    KeyBuf[1]:='[';
    if Shift=[] then
     case Key of
      VK_UP    : begin KeyBuf[2]:='A'; BufLen:=3; end;
      VK_DOWN  : begin KeyBuf[2]:='B'; BufLen:=3; end;
      VK_RIGHT : begin KeyBuf[2]:='C'; BufLen:=3; end;
      VK_LEFT  : begin KeyBuf[2]:='D'; BufLen:=3; end;
      VK_PRIOR : begin KeyBuf[2]:='I'; BufLen:=3; end;
      VK_NEXT  : begin KeyBuf[2]:='G'; BufLen:=3; end;
      VK_HOME  : begin KeyBuf[2]:='H'; BufLen:=3; end;
      VK_END   : begin KeyBuf[2]:='F'; BufLen:=3; end;
      VK_INSERT: begin KeyBuf[2]:='L'; BufLen:=3; end;
      VK_DELETE: begin KeyBuf[0]:=#$7F; BufLen:=1; end;
      VK_F1..VK_F12: begin KeyBuf[2]:=Chr(Ord('M')+(Key-VK_F1)); BufLen:=3; end;
      end;
    if BufLen<>0 then Socket.SendBuf(KeyBuf[0], BufLen);
  end;
  inherited KeyDown(Key, Shift);
end;

procedure TOopsTelnet.KeyPress(var Key: Char);
begin
  if (Key<>#$FF) and Socket.Connected then Socket.SendBuf(Key, 1);
  inherited KeyPress(Key);
end;

procedure TOopsTelnet.StartLog(LogFileName: string);
begin
  if FLogging then Exit;
  if (not FileExists(LogFileName))or(ltOverWrite in LogType) then begin
    FLogStream:=TFileStream.Create(LogFileName, fmCreate);
    FLogStream.Free;
  end;
  FLogStream:=TFileStream.Create(LogFileName, fmOpenReadWrite+fmShareDenyWrite);
  FLogStream.Seek(0, soFromEnd);
  FLogging:=True;
  if ltLogInfo in LogType then LogString(Format(LOG_START_AT, [DateTimeToStr(Now)]));
end;

procedure TOopsTelnet.StopLog;
begin
  if FLogging then begin
    if ltLogInfo in LogType then LogString(Format(LOG_STOP_AT, [DateTimeToStr(Now)]));
    FLogStream.Free;
    FLogging:=False;
  end;
end;

procedure TOopsTelnet.Clear;
begin
  ClearLines(0, FRowCount);
  GotoXY(0, 0);
  Invalidate;
end;

procedure TOopsTelnet.ClearLines(fromLine, Lines: Integer);
var i, j: Integer;
begin
  for i:=fromLine to fromLine+Lines-1 do
    if (i>=0) and (i<FRowCount) then
      for j:=0 to FColCount-1 do begin
        FBufText[i, j]:=#$20;
        FBufAttr[i, j]:=FAttr;
      end;
end;

procedure TOopsTelnet.ClearLn(Func: Char);
var sCol, eCol, i: Integer;
begin
  case Func of
  '0': begin sCol:=FCol; eCol:=FColCount-1; end;
  '1': begin sCol:=0; eCol:=FCol; end;
  '2': begin sCol:=0; eCol:=FColCount-1; end;
  else Exit;
  end;
  for i:=sCol to eCol do begin
    FBufText[FRow, i]:=#$20;
    FBufAttr[FRow, i]:=FAttr;
  end;
end;

procedure TOopsTelnet.CursorDown;
begin
  Inc(FRow);
  if FRow > (FRowCount-1) then begin
    FRow := (FRowCount-1);
    ScrollUp;
  end;
  SetCaret;
end;

function TOopsTelnet.GetActive: Boolean;
begin
  Result:=Socket.Connected;
end;

function TOopsTelnet.GetEscapeParam(From: Integer; var Value: Integer): Integer;
begin
  Value := 0;
//  while (From<=Length(FEscBuffer))and(FEscBuffer[From]=' ')do Inc(From);
  while (From<=Length(FEscBuffer))and(FEscBuffer[From]in['0'..'9'])do begin
    Value:=Value*10+Ord(FEscBuffer[From])-Ord('0'); Inc(From); end;
  Result:=From;
end;

procedure TOopsTelnet.GotoXY(X, Y: Integer);
begin
  if X<0 then FCol:=0 else if X>=FColCount then FCol:=FColCount - 1 else FCol:=X;
  if Y<0 then FRow:=0 else if Y>=FRowCount then FRow:=FRowCount - 1 else FRow:=Y;
  SetCaret;
end;

procedure TOopsTelnet.InvLine(RowID: Integer);
var r: TRect;
begin
  r.Left:=0;
  r.Right:=Width;
  r.Top:=RowID * FFontSize.cy + TermMargins;
  r.Bottom:=r.Top + FFontSize.cy;
  InvalidateRect(Handle, @r, False);
end;

procedure TOopsTelnet.LogChar(Ch: Char);
begin
  if not FLogging then Exit;
  if Ch in [#9,#10,#13,#32..#126,#$A1..#$FE]
   then FLogStream.WriteBuffer(Ch, 1)
   else LogHex(Ch);
end;

procedure TOopsTelnet.LogHex(Ch: Char);
var s: string;
begin
  if not FLogging then Exit;
  s:='\x'+IntToHex(Ord(Ch), 2);
  FLogStream.WriteBuffer(s[1], 4);
end;

procedure TOopsTelnet.LogString(Logs: string);
begin
  if not FLogging then Exit;
  FLogStream.WriteBuffer(Logs[1], Length(Logs));
end;

procedure TOopsTelnet.MoveLines(fromLine, Lines, Step: Integer);
var i: Integer;
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
    if ltLogRFC in LogType then case Ch of { log RFC854 option code }
     TNO_ECHO       : LogString(TNOS_ECHO);
     TNO_SUPPRESS_GA: LogString(TNOS_SUPPRESS_GA);
     TNO_TERMTYPE   : LogString(TNOS_TERMTYPE);
     TNO_SEND_LOC   : LogString(TNOS_SEND_LOC);
     TNO_EOR        : LogString(TNOS_EOR);
    else LogString(' \x'+IntToHex(Ord(Ch), 2)+UNPROC) end;
    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
      if ltLogRFC in LogType then begin { log RFC SubOptions }
        if Length(strSubOption)>0 then
         case strSubOption[1] of
          TNO_TERMTYPE: for i:=1 to Length(strSubOption) do
                         case strSubOption[i] of
                          #$01: LogString(' NeedSend');
                          #$18: LogString(TNOS_TERMTYPE);
                          #$FF: LogString(' IAC');
                         else LogHex(strSubOption[i]) end;
          else for i:=1 to Length(strSubOption) do LogHex(strSubOption[i]);
         end;
        LogString(TNLS_SE);
      end;
      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 }
   if ltLogRFC in LogType then case Ch of
     TNL_IAC :;
     TNL_DO  : LogString(TNLS_IAC+TNLS_DO);
     TNL_DONT: LogString(TNLS_IAC+TNLS_DONT);
     TNL_WILL: LogString(TNLS_IAC+TNLS_WILL);
     TNL_WONT: LogString(TNLS_IAC+TNLS_WONT);
     TNL_EOR : LogString(TNLS_IAC+TNLS_EOR);
     TNL_SB  : LogString(TNLS_IAC+TNLS_SB);
     else LogString(TNLS_IAC+' \x'+IntToHex(Ord(Ch), 2)+UNPROC) end;
   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
      if ltLogControl in FLogType then LogString(Format(ANSI_TERMCTRL, [FEscBuffer+Ch]));
      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;
          if ltLogText in LogType then LogChar(Ch);
          SetCaret;
        end;
   #10: begin
          CursorDown;
          if FAutoCR then FCol:=0;
          if ltLogText in LogType then LogChar(Ch);
        end;
   #13: begin
          FCol:=0;
          if FAutoLF then CursorDown;
          if ltLogText in LogType then LogChar(Ch);
        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;