www.pudn.com > shijiantongbu.zip > NetTimeCommon.pas

unit NetTimeCommon; 
 
interface 
 
uses Windows, Messages, Classes, SysUtils; 
 
const 
  RFC868_Port = 37; 
  NTP_Port = 123; 
  MaxServers = 5; 
  MaxServerList = 1000; 
  MagicCookie = $1A34450B; 
  ProtocolVersion = 4; 
  ms = 1.0 / (24 * 60 * 60 * 1000); 
  IPCSleepTime = 10; 
  GUISleepTime = 100; 
  PollSleepTime = 1000; 
 
type 
 
  TTimeProto = (ttpNTP, ttpRFC868_TCP, ttpRFC868_UDP); 
 
  TServerDef = record 
    hostname: Shortstring; 
    protocol: TTimeProto; 
    Port: integer; 
  end; 
 
  TServerDefArray = array[0..MaxServers-1] of TServerDef; 
 
  TServerConfigBlock = record 
    ServerCount: integer; 
    Servers: TServerDefArray; 
    SyncFreq: integer; 
    LostSync: integer; 
    WarnAdj: integer; 
    Retry: integer; 
    Protocol: TTimeProto; 
  end; 
 
  TWarnAdjEvent = function(const Sender: TObject; 
    const ServerTime, StationTime: TDateTime): boolean of object; 
 
  TSyncServerStatus = (ssGood, ssFailed, ssWrong, ssUnconfigured); 
  TSyncStatus = record 
    Synchronized: boolean; 
    ss: array[0..MaxServers-1] of TSyncServerStatus; 
  end; 
 
  TNetTimeServerBase = class 
  public 
    function GetActive: boolean; virtual; abstract; 
    function GetStatus: TSyncStatus; virtual; abstract; 
    function GetSynchronized: boolean; virtual; 
    function GetLastUpdateTime: TDateTime; virtual; abstract; 
    function GetStateChange: TNotifyEvent; virtual; abstract; 
    procedure SetStateChange(const sc: TNotifyEvent); virtual; abstract; 
    function GetWarnAdj: TWarnAdjEvent; virtual; abstract; 
    procedure SetWarnAdj(const wa: TWarnAdjEvent); virtual; abstract; 
    function GetOnExit: TNotifyEvent; virtual; abstract; 
    procedure SetOnExit(const ex: TNotifyEvent); virtual; abstract; 
    function GetServer: boolean; virtual; abstract; 
    procedure SetServer(const sv: boolean); virtual; abstract; 
    procedure SetConfig(const cfg: TServerConfigBlock); virtual; abstract; 
    function GetConfig: TServerConfigBlock; virtual; abstract; 
    procedure ForceUpdate; virtual; abstract; // forces a CONFIGURATION update 
    function UpdateNow: boolean; virtual; abstract; // forces a TIME update 
    procedure KillEverything; virtual; abstract; 
    property Active: boolean read GetActive; 
    property Status: TSyncStatus read GetStatus; 
    property LastUpdateTime: TDateTime read GetLastUpdateTime; 
    property OnStateChange: TNotifyEvent read GetStateChange write SetStateChange; 
    property OnWarnAdj: TWarnAdjEvent read GetWarnAdj write SetWarnAdj; 
    property OnExitNow: TNotifyEvent read GetOnExit write SetOnExit; 
    property Server: boolean read GetServer write SetServer; 
    property Config: TServerConfigBlock read GetConfig write SetConfig; 
  end; 
 
  EServerRunning = class(Exception) 
  end; 
 
const 
  DefaultSyncFreq = 600; 
  DefaultLostSync = 7500; 
  DefaultRetry = 600; 
  DefaultWarnAdj = 120; 
  DefaultProtocol = ttpNTP; 
 
  ExNameUI = 'NetTimeGHJM_UI'; 
  ExNameServer = 'NetTimeGHJM_Server'; 
 
type 
  TServerData = record 
    Host: ShortString; 
    Time: TDateTime; 
    NetLag: TDateTime; 
    RetrievalTime: TDateTime; 
    Status: TSyncServerStatus; 
    Done: boolean; 
  end; 
  TServerDataArray = array[0..MaxServerList-1] of TServerData; 
  PServerDataArray = ^TServerDataArray; 
  TServerDataSort = (sdsByTime, sdsByNetlag); 
 
procedure SortServerData(const Arr: PServerDataArray; const Count: integer; 
  const WhichSort: TServerDataSort; const Ascending: boolean); 
procedure NormalizeTimes(const Arr: PServerDataArray; const Count: integer); 
 
function DefaultPortForProtocol(const Proto: TTimeProto): integer; 
function WinExecAndWait(Path: PChar; Visibility: Word): integer; 
 
implementation 
 
function DefaultPortForProtocol(const Proto: TTimeProto): integer; 
begin 
  case Proto of 
    ttpRFC868_UDP, ttpRFC868_TCP: result := RFC868_Port; 
    ttpNTP: result := NTP_Port; 
  else 
    result := 0; 
  end; 
end; 
 
function WinExecAndWait(Path: PChar; Visibility: Word): integer; 
 
var 
  Msg: TMsg; 
  lpExitCode: cardinal; 
  StartupInfo: TStartupInfo; 
  ProcessInfo: TProcessInformation; 
 
begin 
  FillChar(StartupInfo, SizeOf(TStartupInfo), 0); 
  with StartupInfo do 
  begin 
    cb := SizeOf(TStartupInfo); 
    dwFlags := STARTF_USESHOWWINDOW or STARTF_FORCEONFEEDBACK; 
    wShowWindow := visibility; 
  end; 
  if CreateProcess(nil, path, nil, nil, False, NORMAL_PRIORITY_CLASS, nil, 
    nil, StartupInfo, ProcessInfo) then 
    begin 
      repeat 
        while PeekMessage(Msg, 0, 0, 0, pm_Remove) do 
          begin 
            if Msg.Message = wm_Quit then Halt(Msg.WParam); 
            TranslateMessage(Msg); 
            DispatchMessage(Msg); 
          end; 
        GetExitCodeProcess(ProcessInfo.hProcess,lpExitCode); 
      until lpExitCode <> Still_Active; 
      with ProcessInfo do 
        begin 
          CloseHandle(hThread); 
          CloseHandle(hProcess); 
        end; 
      Result := 0; 
    end 
  else 
    Result := GetLastError; 
end; 
 
procedure NormalizeTimes(const Arr: PServerDataArray; const Count: integer); 
 
var 
  CalcNow: TDateTime; 
  i: integer; 
 
begin 
  if Count = 0 then 
    raise exception.create('Cannot normalize a list of zero length'); 
  CalcNow := Now; 
  for i := 0 to Count-1 do 
    Arr[i].Time := Arr[i].Time + (CalcNow - Arr[i].RetrievalTime); 
end; 
 
procedure SortServerData(const Arr: PServerDataArray; const Count: integer; 
  const WhichSort: TServerDataSort; const Ascending: boolean); 
 
var 
  done: boolean; 
  i: integer; 
  OutOfOrder: boolean; 
  TmpData: TServerData; 
 
begin 
  repeat 
    done := true; 
    for i := 0 to Count-2 do 
      begin 
        if Ascending then 
          if WhichSort = sdsByTime then 
            OutOfOrder := Arr[i].Time > Arr[i+1].Time 
          else 
            OutOfOrder := Arr[i].NetLag > Arr[i+1].NetLag 
        else 
          if WhichSort = sdsByTime then 
            OutOfOrder := Arr[i+1].Time > Arr[i].Time 
          else 
            OutOfOrder := Arr[i+1].NetLag > Arr[i].NetLag; 
        if OutOfOrder then 
          begin 
            TmpData := Arr[i]; 
            Arr[i] := Arr[i+1]; 
            Arr[i+1] := TmpData; 
            done := false; 
          end; 
      end; 
  until done; 
end; 
 
function TNetTimeServerBase.GetSynchronized: boolean; 
begin 
  result := GetStatus.Synchronized; 
end; 
 
end.