oopstelnet.pas

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

  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
    FBufText[FRow, nCol]:=#$20;
    FBufAttr[FRow, nCol]:=FAttr;
    InvLine(Frow);
  end;
end;

procedure TOopsTelnet.ProcessCSI_h_lc;
var Mode: Integer;
begin
  if FEscBuffer[1]<>'[' then Exit;
  case FEscBuffer[2] of
  '2': FKeyboardLocked:=True; { Locks keyboard.  Ignores keyboard input until unlocked. }
  '?': begin { Set Term Options }
        GetEscapeParam(3, Mode);
        case Mode of
         7: FAutoWrap:=True; { Auto-wrap ON }
        25: SetCaretOff(True); { Caret visible }
        end;
       end;
  end;
end;

procedure TOopsTelnet.ProcessCSI_l_lc;
var Mode: Integer;
begin
  if FEscBuffer[1]<>'[' then Exit;
  case FEscBuffer[2] of
  '2': FKeyboardLocked:=True; { Unlocks keyboard.  Re-enables keyboard input }
  '?': begin { Set Term Options }
        GetEscapeParam(3, Mode);
        case Mode of
         7: FAutoWrap:=False; { Auto-wrap OFF }
        25: SetCaretOff(False); { Caret invisible }
        end;
       end;
  end;
end;

procedure TOopsTelnet.ProcessCSI_m_lc;
  procedure ProcessCSI_Sub_m_lc(i: Integer);
  begin
    case i of
     0: FAttr.Attr:=[];                      { All attributes off }
     1: Include(FAttr.Attr, csBlod);         { Bold intensity }
     4: Include(FAttr.Attr, csUnderline);    { Underscore on }
     5: Include(FAttr.Attr, csBlink);        { Blink on }
     7: Include(FAttr.Attr, csReverse);      { Reverse video }
     8: FAttr.Attr:=[];                      { Sets blank }
     10: begin                               { Selects the primary font }
           Exclude(FAttr.Attr, csCtlchar);
           EXclude(FAttr.Attr, csTabluation)
         end;
     11: Include(FAttr.Attr, csCtlchar);     { Selects the first alternate font, lets #$xx < #32 be displayed as ROM characters. }
     12: Include(FAttr.Attr, csTabluation);  { Selects a second alternate font, toggles high bit of extended ASCII code before displaying as ROM characters. }
     30..37: AttrSetFColor(FAttr, i-30);     { foreground }
     38: Include(FAttr.Attr, csUnderline);   { Enables underline option; white foreground with white underscore }
     39: Exclude(FAttr.Attr, csUnderline);   { Disables underline option }
     40..47: AttrSetGColor(FAttr, i-40);     { background }
    end;
  end;
var From, n: Integer;
begin
  if Length(FEscBuffer)<2 then begin AttrSetDefault(FAttr); Exit end;
  From:=GetEscapeParam(2, n);
  ProcessCSI_Sub_m_lc(n);
  if (From<=Length(FEscBuffer))and(FEscBuffer[From]=';') then begin
    From:=GetEscapeParam(From+1, n);
    ProcessCSI_Sub_m_lc(n);
    if (From<=Length(FEscBuffer))and(FEscBuffer[From]=';') then begin
      GetEscapeParam(From+1, n);
      ProcessCSI_Sub_m_lc(n);
    end;
  end;
end;

procedure TOopsTelnet.ProcessEscape(EscCmd: Char);
begin
  if Length(FEscBuffer)=0 then begin
    case EscCmd of
     '7': ProcessCSI_7;     { Save cursor }
     '8': ProcessCSI_8;     { Restore Cursor }
     'H': Include(FAttr.Attr, csTabluation); { Tabulation set }
     'c': Clear; { Clear Screen }
    end;
    Exit;
  end;
  case FEscBuffer[1] of
  '[': case EscCmd of
       'A': ProcessCSI_A;    { ^[nA  Moves active position up n number of lines }
       'B': ProcessCSI_B;    { ^[nB  Moves active position down n number of lines }
       'C': ProcessCSI_C;    { ^[nC  Moves active position n spaces to the right }
       'D': ProcessCSI_D;    { ^[nD  Moves active position n spaces backward }
       'E': ProcessCSI_E;    { ^[nE  Moves active position to beginning of line, n lines down }
       'F': ProcessCSI_F;    { ^[nF  Moves active position to beginning of line, n lines up }
       'G': ProcessCSI_G;    { ^[=cG  Sets normal background }
       'H': ProcessCSI_H;    { ^[m;nH  Moves active position to location m (vertical) and n (horizontal) }
       'I': ProcessCSI_I;    { ^[=cI Sets reverse background. }
       'J': ProcessCSI_J;    { ^[nJ  Erases all or part of a display. }
       'K': ProcessCSI_K;    { ^[nK  Erases all or part of a line }
       'L': ProcessCSI_L;    { ^[nL  Inserts n new, blank lines }
       'M': ProcessCSI_M;    { ^[nM  Deletes n Lines }
       'P': ProcessCSI_P;    { ^[nP  Deletes n number of characters }
       'S': ProcessCSI_S;    { ^[nS  Scrolls screen up n lines }
       'T': ProcessCSI_T;    { ^[nT  Scrolls screen down n lines }
       'X': ProcessCSI_X;    { ^[nX  Erases n characters }
       'Z': ProcessCSI_Z;    { ^[nZ  Moves active position back n tab stops }
       '@': ProcessCSI_at;   { ^[n@ Inserts n blank places for n characters }
       'a': ProcessCSI_C;    { ^[na  Moves active position n spaces to the right }
       'e': ProcessCSI_B;    { ^[ne  Moves active position down n number of lines }
       'f': ProcessCSI_H;    { Set Cursor Position }
       'h': ProcessCSI_h_lc; { Terminal mode set }
       'l': ProcessCSI_l_lc; { Terminal mode reset }
       'm': ProcessCSI_m_lc; { Select Attributes }
       'n': ;                { Cursor position report }
       's': ProcessCSI_7;    { Save cursor position }
       'u': ProcessCSI_8;    { Restore Cursor position }
       end;
  end;
end;

procedure TOopsTelnet.ScrollUp;
begin
  MoveLines(1, FRowCount-1, -1);
  ClearLines(FRowCount-1, 1);
  Invalidate;
end;

procedure TOopsTelnet.SetCaret;
begin
  if FCaretShown then HideCaret(Handle);
  case CaretStyle of
    csLine: SetCaretPos(FCol*FFontSize.cx+TermMargins, FRow*FFontSize.cy+FFontSize.cy+TermMargins-2);
    csBlock: SetCaretPos(FCol*FFontSize.cx+TermMargins, FRow*FFontSize.cy+TermMargins);
  end;
  if FCaretShown and Active then ShowCaret(Handle);
end;

procedure TOopsTelnet.SetCaretOff(Value: Boolean);
begin
  if FCaretOff<>Value then FCaretOff:=Value;
  if FCaretOff then begin
   if FCaretShown then begin
      HideCaret(Handle);
      FCaretShown:=False;
   end
  end else begin
   if FCaretCreated and not(FCaretShown) then begin
     ShowCaret(Handle);
     FCaretShown:=True;
   end;
  end;
end;

procedure TOopsTelnet.SetCaretStyle(Value: TCaretStyle);
begin
  if FCaretStyle<>Value then FCaretStyle:=Value;
  if FCaretCreated then DestroyCaret;
  case FCaretStyle of
   csLine: CreateCaret(Handle, 0, FFontSize.cx, 2);
   csBlock: CreateCaret(Handle, 0, FFontSize.cx, FFontSize.cy);
  end;
  if FCaretShown then ShowCaret(Handle);
  SetCaret;
end;

procedure TOopsTelnet.SetRowSpacing(Value: Byte);
begin
  if FRowSpacing=Value then Exit;
  FRowSpacing := Value;
  SetupFont;
end;

procedure TOopsTelnet.SetupFont;
var
  DC: HDC;
  Metrics: TTextMetric;
  hObject: THandle;
begin
  DC := GetDC(0);
  hObject := SelectObject(DC, Font.Handle);
  GetTextMetrics(DC, Metrics);
  SelectObject(DC, hOBject);
  ReleaseDC(0, DC);
  FFontSize.cx := Metrics.tmAveCharWidth;
  FFontSize.cy := Metrics.tmHeight + FRowSpacing;
  if FCaretCreated then begin
    DestroyCaret;
    case FCaretStyle of
     csLine: CreateCaret(Handle, 0, FFontSize.cx, 2);
     csBlock: CreateCaret(Handle, 0, FFontSize.cx, FFontSize.cy);
    end;
    if FCaretShown then begin
      ShowCaret(Handle);
      FCaretShown:=True;
    end;
  end;
  Height:=0;
end;

procedure TOopsTelnet.WriteLiteralChar(Ch: Char);
begin
  if (FCol>=FColCount)and FAutoWrap then begin
    FCol:=0; Inc(FRow);
    if FRow>=FRowCount then begin Dec(FRow); ScrollUp end;
  end;
  FBufText[FRow, FCol]:=Ch;
  FBufAttr[FRow, FCol]:=FAttr;
  InvLine(FRow);
  if FCol<(FColCount-1) then Inc(FCol) else
    if FAutoWrap then begin FCol := 0; Inc(FRow);
      if FRow >= FRowCount then begin Dec(FRow); ScrollUp; end;
    end;
  SetCaret;
end;

procedure TOopsTelnet.SelectAll;
begin
  FSelectRect:=Rect(0, 0, FColCount-1, FRowCount-1);
  FSelected:=True;
  Invalidate;
end;

procedure TOopsTelnet.CopyToClipboard;
var s: string;
    i: Integer;
begin
  if not FSelected then Exit;
  if (FSelectRect.Right<0)or(FSelectRect.Bottom<0)or(FSelectRect.Left<0)or(FSelectRect.Right<0) then Exit;
  if FSelectRect.Right>=FColCount then FSelectRect.Right:=FColCount-1;
  if FSelectRect.Bottom>=FRowCount then FSelectRect.Bottom:=FRowCount-1;
  s:='';
  for i:=FSelectRect.Top to FSelectRect.Bottom do begin
    s:=s+Copy(FBufText[i], FSelectRect.Left+1, FSelectRect.Right-FSelectRect.Left+1)+#13#10;
  end;
  if Length(s)>0 then begin
    Clipboard.Open;
    Clipboard.SetTextBuf(@s[1]);
    Clipboard.Close;
    s:='';
  end;
end;

procedure TOopsTelnet.PasteFromClipboard;
var s: string;
  i: Integer;
begin
  if not Clipboard.HasFormat(CF_TEXT) then Exit;
  if not Active then Exit;
  Clipboard.Open;
  s:=Trim(Clipboard.AsText);
  Clipboard.Close;
  for i:=1 to Length(s) do
   if s[i] in [#9,#13,#$20..#$7E,#$A1..#$FE]
    then Socket.SendBuf(s[i], 1);
end;

procedure TOopsTelnet.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var pt: TPoint;
begin
  FSelectRect:=Rect(-1, -1, -1, -1);
  if Button = mbLeft then begin {begin tracking monse}
    FSelected:=True;
    MouseCapture := True;
    FTracking := True;
    pt:=Point((X-TermMargins) div FFontSize.cx, (Y-TermMargins) div FFontSize.cy);
    if (FSelectRect.Left<>pt.X)or(FSelectRect.Top<>pt.Y) then begin
      FSelectRect.TopLeft:=pt;
      Invalidate;
    end;
  end;
  inherited MouseDown(Button, Shift, X, Y);
end;

procedure TOopsTelnet.MouseMove(Shift: TShiftState; X, Y: Integer);
var pt: TPoint;
begin  {Tracking monse position}
  if FTracking then begin
    pt:=Point((X-TermMargins) div FFontSize.cx, (Y-TermMargins) div FFontSize.cy);
    if ((FSelectRect.Right<>pt.X)or(FSelectRect.Bottom<>pt.Y)) then begin
      FSelectRect.BottomRight:=pt;
      Invalidate;
    end;
  end;
  inherited MouseMove(Shift, X, Y);
end;

procedure TOopsTelnet.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var pt: TPoint;
begin
  if FTracking then begin
    pt:=Point((X-TermMargins) div FFontSize.cx, (Y-TermMargins) div FFontSize.cy);
    if ((FSelectRect.Right<>pt.X)or(FSelectRect.Bottom<>pt.Y))
      then FSelectRect.BottomRight:=pt;
    if ((FSelectRect.Right-FSelectRect.Left)<=0)and((FSelectRect.Bottom-FSelectRect.Top)<=0)
     then FSelected:=False;
    Invalidate;
    FTracking := False;
    MouseCapture := False;
  end;
  inherited MouseUp(Button, Shift, X, Y);
end;

procedure TOopsTelnet.CMFontChanged(var Message: TMessage);
begin
  inherited;
  SetupFont;
end;

procedure TOopsTelnet.WMGetDlgCode(var Message: TWMGetDlgCode);
begin
  inherited;
  Message.Result := DLGC_WANTARROWS or DLGC_WANTTAB or DLGC_WANTCHARS or DLGC_WANTALLKEYS;
end;

procedure TOopsTelnet.PaintLine(DC: HDC; r: TRect; LineID: Integer);

 function isHan(x, y: Integer):Boolean;
 var isH: integer;
 begin
   isH:=0;
   repeat
     if not(FBufText[y, x] in [#$A1..#$FE]) then Break;
     Inc(isH); Dec(x);
     if x<0 then begin x:=FColCount-1; Dec(y) end;
   until (y<0);
   Result:=((isH mod 2)=0);
 end;

var i: integer;
  fc, gc, tmp: Byte;
  s: string[2];
begin
  for i:=0 to FColCount-1 do begin
    fc:=AttrGetFColor(FBufAttr[LineID, i]);
    gc:=AttrGetGColor(FBufAttr[LineID, i]);
    if csReverse in FBufAttr[LineID, i].Attr then
      begin tmp:=fc; fc:=gc; gc:=tmp end;
    if csIntensity in FBufAttr[LineID, i].Attr then gc:=gc or $8;
    if csBlod in FBufAttr[LineID, i].Attr then fc:=fc or $8;
    if FSelected and(FSelectRect.Left<=i)and(FSelectRect.Right>=i)and(FSelectRect.Top<=LineID)and(FSelectRect.Bottom>=LineID)
      then begin fc:=fc xor $7; gc:=gc xor $7; end;
    SetTextColor(DC, AnsiColorTable[fc]);
    SetBkColor(DC, AnsiColorTable[gc]);
    if (FBufText[LineID, i] in [#$A1..#$FE])and isHan(i, LineID) then begin
      r.Left:=r.Left-FFontSize.cx;
      ExtTextOut(DC, r.Left, r.Top, ETO_OPAQUE or ETO_CLIPPED, @r, @FBufText[LineID, i-1], 2, nil);
      r.Left:=r.Left+FFontSize.cx;
    end else
      if not(csTabluation in FBufAttr[LineID, i].Attr)
        then ExtTextOut(DC, r.Left, r.Top, ETO_OPAQUE or ETO_CLIPPED, @r, @FBufText[LineID, i], 1, nil)
        else begin
               case FBufText[LineID, i] of
                'M': s:='━'; ':': s:='┃'; 'I': s:='┏'; ';': s:='┓'; 'H': s:='┗'; '<': s:='┛';
                'D': s:='─'; '3': s:='│'; 'Z': s:='┌'; '?': s:='┐'; '@': s:='└'; 'Y': s:='┘';
                'T': s:='┕'; '7': s:='┒';
               else s:='  ' end;
               ExtTextOut(DC, r.Left-(FFontSize.cx div 2), r.Top, ETO_OPAQUE or ETO_CLIPPED, @r, @s[1], 2, nil);
        end;
    Inc(r.Left, FFontSize.cx);
    Inc(r.Right, FFontSize.cx);
  end;
end;

procedure TOopsTelnet.WMPaint(var Message: TWMPaint);
var
  DC: HDC;
  PS: TPaintStruct;
  rc, pr: TRect;
  OldFont: THandle;
  i: integer;
begin
  if not GetUpdateRect(WindowHandle, rc, False) then Exit;
  DC:=Message.DC;
  if DC=0 then DC:=BeginPaint(WindowHandle, PS);
  try
    OldFont := SelectObject(DC, Font.Handle);
    pr:=Rect(TermMargins, TermMargins-FFontSize.cy, TermMargins+FFontSize.cx, TermMargins);
    for i:=0 to FRowCount-1 do begin
      Inc(pr.Top, FFontSize.cy);
      Inc(pr.Bottom, FFontSize.cy);
      if (pr.Top>rc.Bottom)or(pr.Bottom<rc.Top) then Continue;
      PaintLine(DC, pr, i);
    end;
    SelectObject(DC, OldFont);
  finally
    if Message.DC=0 then EndPaint(WindowHandle, PS);
  end;
end;

procedure TOopsTelnet.WMKillFocus(var Message: TMessage);
begin
  if FCaretShown then begin
    HideCaret(Handle);
    FCaretShown := False;
  end;
  if FCaretCreated then begin
    FCaretCreated:=False;
    DestroyCaret;
  end;
  FHasFocus := False;
  inherited;
end;

procedure TOopsTelnet.WMSetFocus(var Message: TMessage);
begin
  inherited;
  case FCaretStyle of
   csLine: CreateCaret(Handle, 0, FFontSize.cx, 2);
   csBlock: CreateCaret(Handle, 0, FFontSize.cx, FFontSize.cy);
  end;
  FCaretCreated:=True;
  SetCaret;
  if (not FCaretOff)and Active then begin
    ShowCaret(Handle);
    FCaretShown := True;
  end;
  FHasFocus := True;
end;

procedure Register;
begin
  RegisterComponents('OopsWare', [TOopsTelnet]);
end;

end.