mytelnet.pas

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

    FBufText[FRow, nCol]:=#$20;
    FBufAttr[FRow, nCol]:=FAttr;
    InvLine(Frow);
  end;
end;

procedure TMyTelnet.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 TMyTelnet.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 TMyTelnet.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 TMyTelnet.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 TMyTelnet.ScrollUp;
begin
  MoveLines(1, FRowCount-1, -1);
  ClearLines(FRowCount-1, 1);
  Invalidate;
end;

procedure TMyTelnet.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 TMyTelnet.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 TMyTelnet.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 TMyTelnet.SetRowSpacing(Value: Byte);
begin
  if FRowSpacing=Value then Exit;
  FRowSpacing := Value;
  SetupFont;
end;

procedure TMyTelnet.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 TMyTelnet.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 TMyTelnet.SelectAll;
begin
  FSelectRect:=Rect(0, 0, FColCount-1, FRowCount-1);
  FSelected:=True;
  Invalidate;
end;

procedure TMyTelnet.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 TMyTelnet.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 TMyTelnet.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 TMyTelnet.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 TMyTelnet.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 TMyTelnet.CMFontChanged(var Message: TMessage);
begin
  inherited;
  SetupFont;
end;

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

function TMyTelnet.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;

procedure TMyTelnet.PaintLine(DC: HDC; r: TRect; LineID: Integer);
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 TMyTelnet.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 TMyTelnet.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 TMyTelnet.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('MyInternet', [TMyTelnet]);
end;

end.