[Delphi]检查上网线路的DNS性能

说明：近期发现某个电信运营商上网宽带的DNS服务的一个问题：DNS查询频率有限制,  而且使用其他DNS服务器不解决问题。如果这种宽带只是在家庭里面使用，DNS的查询频度还没达到上限，但如果是在单位里面使用，当使用人数较多时，DNS查询频率会大于限制的频率，造成上网卡顿的问题。在遇到上网卡顿，但Ping又正常时，可以用此程序检查上网线路的DNS性能。需用运营商提供的DNS服务器的ip地址替换上图中的DNS服务器ip地址。让查询次数达到1万次以上，看看有没有超时的现象。如果超时较多，就应该联系运营商解决了。 

 uMain.pas:

unit uMain;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
  Vcl.StdCtrls, Vcl.ComCtrls, Vcl.ExtCtrls, RzPrgres;

type
  TForm1 = class(TForm)
    ButtonQuery: TButton;
    EditCount: TLabeledEdit;
    EditDNS: TLabeledEdit;
    EditFreq: TLabeledEdit;
    ProgressBar: TRzProgressBar;
    EditTimeOut: TLabeledEdit;
    procedure ButtonQueryClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    TotalCnt, TimeOutCnt: Integer;
    StartTime: TDateTime;
    procedure WmProc(var Msg: TMessage); message WM_User;
  public
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

uses uDNSQueryThread;

procedure TForm1.FormCreate(Sender: TObject);
begin
  ReportMemoryLeaksOnShutDown := True;
end;

procedure TForm1.ButtonQueryClick(Sender: TObject);
begin
  if ButtonQuery.Caption = '查询' then
  begin
    TotalCnt := 0;
    TimeOutCnt := 0;

    EditCount.Text := '';
    EditFreq.Text  := '';
    EditTimeOut.Text := '0';

    StartTime := Now;
    ProgressBar.PartsComplete := 0;
    DNSQueryThread := TDNSQueryThread.Create(EditDNS.Text);
    ButtonQuery.Caption := '停止'
  end
  else
  begin
    DNSQueryThread.Terminate;
    ButtonQuery.Caption := '查询';
  end;
end;

procedure TForm1.WmProc(var Msg: TMessage);
var
  P: Integer;
  Seconds: Real;
begin
  Inc(TotalCnt);
  EditCount.Text := TotalCnt.ToString;

  Seconds := 86400 * (Now - StartTime);
  if Seconds <> 0 then
    EditFreq.Text := Round(TotalCnt/Seconds).ToString;

  if Msg.LParam = -1 then
  begin
    Inc(TimeOutCnt);
    EditTimeOut.Text := TimeOutCnt.ToString;
  end;

  P := TotalCnt mod 1000;
  if P = 0 then P := 1000;
  ProgressBar.PartsComplete := P;
end;

end.

uMain.dfm: 

object Form1: TForm1
  Left = 0
  Top = 0
  BorderStyle = bsDialog
  Caption = #26816#26597#19978#32593#32447#36335#30340'DNS'#24615#33021
  ClientHeight = 120
  ClientWidth = 521
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  Position = poScreenCenter
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object ProgressBar: TRzProgressBar
    Left = 22
    Top = 72
    Width = 478
    BorderWidth = 0
    InteriorOffset = 0
    PartsComplete = 0
    Percent = 0
    ShowParts = True
    TotalParts = 1000
  end
  object ButtonQuery: TButton
    Left = 425
    Top = 26
    Width = 75
    Height = 25
    Caption = #26597#35810
    TabOrder = 0
    OnClick = ButtonQueryClick
  end
  object EditCount: TLabeledEdit
    Left = 143
    Top = 33
    Width = 65
    Height = 21
    Alignment = taCenter
    EditLabel.Width = 60
    EditLabel.Height = 13
    EditLabel.Caption = #26597#35810#24635#27425#25968
    ReadOnly = True
    TabOrder = 1
  end
  object EditDNS: TLabeledEdit
    Left = 22
    Top = 33
    Width = 96
    Height = 21
    Alignment = taCenter
    EditLabel.Width = 56
    EditLabel.Height = 13
    EditLabel.Caption = 'DNS'#26381#21153#22120
    EditLabel.Font.Charset = DEFAULT_CHARSET
    EditLabel.Font.Color = clNavy
    EditLabel.Font.Height = -11
    EditLabel.Font.Name = 'Tahoma'
    EditLabel.Font.Style = []
    EditLabel.ParentFont = False
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clNavy
    Font.Height = -11
    Font.Name = 'Tahoma'
    Font.Style = []
    ParentFont = False
    TabOrder = 3
    Text = '114.114.114.114'
  end
  object EditFreq: TLabeledEdit
    Left = 235
    Top = 33
    Width = 65
    Height = 21
    Alignment = taCenter
    EditLabel.Width = 84
    EditLabel.Height = 13
    EditLabel.Caption = #24179#22343#39057#29575'('#27425'/'#31186')'
    ReadOnly = True
    TabOrder = 2
  end
  object EditTimeOut: TLabeledEdit
    Left = 327
    Top = 33
    Width = 65
    Height = 21
    Alignment = taCenter
    EditLabel.Width = 48
    EditLabel.Height = 13
    EditLabel.Caption = #36229#26102#27425#25968
    ReadOnly = True
    TabOrder = 4
  end
end

uDNSQueryThread.pas: 

unit uDNSQueryThread;

interface

uses System.Classes, Vcl.Forms, Winapi.Windows, Winapi.Messages,
     IdBaseComponent, IdComponent, IdTCPConnection, IdDNSResolver,
     uBaseThread;

type
  TDNSQueryThread = class(TBaseThread)
  private
    DNS: TIdDNSResolver;
    DNList: TStringList;
  protected
    procedure Execute; override;
  public
    constructor Create(aHost: String);
    destructor  Destroy; override;
  end;

var
  DNSQueryThread: TDNSQueryThread;

implementation

constructor TDNSQueryThread.Create(aHost: String);
begin
  inherited Create;
  DNS := TIdDNSResolver.Create(nil);
  DNS.QueryType := [qtA];
  DNS.Host := aHost;
  DNList := TStringList.Create;
  with DNList do
  begin
    Add('news.sina.com.cn');
    Add('news.sohu.com');
    Add('www.163.com');
    Add('www.pconline.com.cn');
    Add('www.taobao.com');
    Add('www.xcar.com.cn');
    Add('www.autohome.com.cn');
  end;
end;

destructor TDNSQueryThread.Destroy;
begin
  DNList.Free;
  DNS.Free;
  inherited;
end;

procedure TDNSQueryThread.Execute;
var
  DN: String;
begin
  while not Terminated do
  begin
    for DN in DNList do
    begin
      try
        DNS.Resolve(DN);
        {for I := 0 to DNS.QueryResult.Count - 1 do
        begin
          if DNS.QueryResult[I].RecType = qtA then
          begin
            S := DNS.QueryResult[I].Name;
            S := S + '  ' + TARecord(DNS.QueryResult[I]).IPAddress;
            RichEdit1.Lines.Add(S);
          end;
        end;}
        PostMessage(Application.MainForm.Handle, WM_User, 0, 1);
      except
        PostMessage(Application.MainForm.Handle, WM_User, 0, -1);
      end;
      if Terminated then Break;
    end;
  end;
end;

end.

uBaseThread.pas: 

unit uBaseThread;  //此单元为通用单元，不需要修改

//实现主Form关闭时，程序自动先关闭继承于此类的全部线程, 然后才关闭主Form
//注意：此单元中，线程数>0时重载了主Form的OnCloseQuery事件

interface

uses System.Classes, Generics.Collections, System.SysUtils,
     Winapi.Windows, Vcl.Forms, Winapi.Messages, System.SyncObjs;

type
  TBaseThread = class(TThread)
  private
    class procedure NewCloseQuery(Sender: TObject; var CanClose: Boolean);
  public
    constructor Create(aCreateSuspended: Boolean = False); overload;
    constructor Create(aForm: TForm; aCreateSuspended: Boolean = False); overload;
    destructor Destroy; override;
  end;

implementation //=============================================================

type
  TThreadList = TList<TThread>;
  TFormInfo = record
    Form: TForm;
    Closing: Boolean;
    ThreadList: TThreadList;
    OriginalCloseQuery: procedure(Sender: TObject; var CanClose: Boolean) of Object;
  end;
  TFormList = TList<TFormInfo>;

var
  FormList: TFormList;
  FCritSect: TCriticalSection;


function GetFormIndex(aForm: TForm): Integer; overload;
var
  I: Integer;
begin
  Result := -1;
  for I := 0 to FormList.Count-1 do
  begin
    if FormList[I].Form = aForm then
    begin
      Result := I;
      Break;
    end;
  end;
end;

function GetFormIndex(aThread: TThread): Integer; overload;
var
  I, J: Integer;
  ThreadList: TThreadList;
begin
  Result := -1;
  begin
    for I := 0 to FormList.Count - 1 do
    begin
      ThreadList := FormList[I].ThreadList;
      for J := 0 to ThreadList.Count - 1 do
      begin
        if ThreadList[J] = aThread then
        begin
          Result := I;
          Break;
        end;
      end;
    end;
  end;
end;

//============================================================================

class procedure TBaseThread.NewCloseQuery(Sender: TObject; var CanClose: Boolean);
var
  Index: Integer;
  Thread: TThread;
  FormInfo: TFormInfo;
begin
  FCritSect.Enter;
    Index := GetFormIndex(TForm(Sender));
    if Index <> -1 then
    begin
      FormInfo := FormList[Index];
      if FormInfo.ThreadList.Count > 0 then
      begin
        CanClose := False; //还有线程没释放的情况下，暂时不关闭主Form
        FormInfo.Closing := True;
        FormList[Index] := FormInfo;
        for Thread in FormInfo.ThreadList do
        begin
          Thread.Terminate;
        end;
      end;
    end;
  FCritSect.Leave;
end;

//============================================================================

constructor TBaseThread.Create(aCreateSuspended: Boolean);
begin
  Create(Application.MainForm, aCreateSuspended);
end;

constructor TBaseThread.Create(aForm: TForm; aCreateSuspended: Boolean);
var
  FormIndex: Integer;
  FormInfo : TFormInfo;
begin
  FCritSect.Enter;
    if aForm = nil then aForm := Application.MainForm;
    FormIndex := GetFormIndex(aForm);
    if FormIndex = -1 then
    begin
      with FormInfo do
      begin
        Form := aForm;
        Closing := False;
        OriginalCloseQuery := Form.OnCloseQuery;
        Form.OnCloseQuery  := NewCloseQuery;
        ThreadList := TThreadList.Create;
        ThreadList.Add(Self);
      end;
      FormList.Add(FormInfo);
    end
    else
    begin
      FormList[FormIndex].ThreadList.Add(Self);
    end;
  FCritSect.Leave;

  inherited Create(aCreateSuspended);
  FreeOnTerminate := True;
end;

destructor TBaseThread.Destroy;
var
  FormIndex: Integer;
  FormInfo : TFormInfo;
begin
  //在FreeOnTerminate := True的情况下，Destroy的执行实际上是在线程里面进行的
  FCritSect.Enter;  //对ThreadList的操作需要在临界保护区里完成
    FormIndex := GetFormIndex(Self);
    if FormIndex <> -1 then
    begin
      FormInfo := FormList[FormIndex];
      with FormInfo do
      begin
        ThreadList.Remove(Self);
        if ThreadList.Count = 0 then
        begin
          //一旦线程释放完毕，主Form的OnCloseQuery恢复使用原来定义的FormCloseQuery
          Form.OnCloseQuery := OriginalCloseQuery;
          ThreadList.Free;
          FormList.Delete(FormIndex);
          if Closing then   //线程已经释放完毕，发消息关闭主Form
            PostMessage(Form.Handle, WM_CLOSE, 0, 0);
        end;
      end;
    end;
  FCritSect.Leave;
  inherited;
end;

initialization
  FormList  := TFormList.Create;
  FCritSect := TCriticalSection.Create;

finalization
  FormList.Free;
  FCritSect.Free;

end.