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

{ ************************************************************************ 
 
   NetTime is copyrighted by Graham Mainwaring. Permission is hereby 
   granted to use, modify, redistribute and create derivative works 
   provided this attribution is not removed. I also request that if you 
   make any useful changes, please e-mail the diffs to graham@mhn.org 
   so that I can include them in an 'official' release. 
 
  ************************************************************************ } 
 
unit NetTimeIPC; 
 
interface 
 
uses Windows, Classes, SysUtils, NetTimeCommon, iswinnt, syncobjs; 
 
type 
 
  TServerStatusBlock = record 
    Config: TServerConfigBlock; 
    Server: boolean; 
    Active: boolean; 
    Status: TSyncStatus; 
    LastUpdateTime: TDateTime; 
  end; 
 
  // Whenever you change this, you have to increment ProtocolVersion 
  // in NetTimeCommon. 
  TShareMemBlock = record 
    // Section that anyone can write to 
    G_MagicCookie: longword; 
    G_ProtocolVersion: longword; 
    G_ExitNowFlag: boolean; 
    // Section that the SERVER writes to 
    S_ServerPID: longword; 
    S_StatusProvidedSerial: integer; 
    S_AdviseStatusFlag: boolean; 
    S_Status: TServerStatusBlock; 
    S_LargeAdjFlag: boolean; 
    S_ServerTime, S_StationTime: TDateTime; 
    S_LastUpdateGood: boolean; // only valid when C_WantUpdateNow called 
    // Section that the CLIENT writes to 
    C_ClientPID: longword; 
    C_ClientStatusChangeFlag: boolean; 
    C_StatusWantedSerial: integer; 
    C_LargeAdjReplyFlag: boolean; 
    C_LargeAdjReplyResult: boolean; 
    C_SetConfigFlag: boolean; 
    C_Config: TServerConfigBlock; 
    C_SetServerFlag: boolean; 
    C_Server: boolean; 
    C_WantUpdateNowFlag: boolean; 
  end; 
  PShareMemBlock = ^TShareMemBlock; 
 
  TExitNowCallback = procedure of object; 
  TUpdateNowCallback = function: boolean of object; 
 
  TNetTimeIPC = class 
  protected 
    ShareMemHandle: THandle; 
    ShareMem: PShareMemBlock; 
    ExitNowCallback: TExitNowCallback; 
  protected 
    HaveKilled: boolean; 
  public 
    procedure InitResources; virtual; 
    procedure FreeResources; virtual; 
    function CheckServerRunning: boolean; 
    function CheckClientRunning: boolean; 
    procedure KillEverything; 
    constructor Create(const enb: TExitNowCallback); 
    destructor Destroy; override; 
  end; 
 
  TGetServerStatusCallback = function: TServerStatusBlock of object; 
  TSetConfigCallback = procedure(const cfg: TServerConfigBlock) of object; 
  TSetServerCallback = procedure(const srv: boolean) of object; 
 
  TNetTimeServerThread = class; 
 
  TNetTimeIPCServer = class(TNetTimeIPC) 
  private 
    MyThread: TNetTimeServerThread; 
    ClientEvent: THandle; 
    GetServerStatusCallback: TGetServerStatusCallback; 
    SetConfigCallback: TSetConfigCallback; 
    SetServerCallback: TSetServerCallback; 
    UpdateNowCallback: TUpdateNowCallback; 
    procedure ClientHello; 
    procedure ClientGoodbye; 
    procedure SetServer; 
    procedure SetConfig; 
  public 
    procedure InitResources; override; 
    procedure FreeResources; override; 
    function LargeAdjustWarn(const ServerTime, StationTime: TDateTime): boolean; 
    procedure AdviseStatus; 
    constructor Create(const gsb: TGetServerStatusCallback; 
      const scb: TSetConfigCallback; const ssb: TSetServerCallback; 
      const enb: TExitNowCallback; const unb: TUpdateNowCallback); 
    destructor Destroy; override; 
  end; 
 
  TNetTimeServerThread = class(TThread) 
  protected 
    MyOwner: TNetTimeIPCServer; 
    MyEvent: THandle; 
    procedure Execute; override; 
  public 
    constructor Create(const Owner: TNetTimeIPCServer; 
      const Suspended: boolean = false); 
  end; 
 
  TAdviseStatusCallback = procedure(const stat: TServerStatusBlock) of object; 
  TLargeAdjCallback = function(const ServerTime, StationTime: TDateTime): boolean of object; 
 
  TNetTimeClientThread = class; 
 
  TNetTimeIPCClient = class(TNetTimeIPC) 
  private 
    MyThread: TNetTimeClientThread; 
    ServerEvent: THandle; 
    AdviseStatusCallback: TAdviseStatusCallback; 
    LargeAdjCallback: TLargeAdjCallback; 
    procedure RetrieveStatus; 
    procedure DoLargeAdj; 
  public 
    procedure InitResources; override; 
    procedure FreeResources; override; 
    function GetServerStatus: TServerStatusBlock; 
    procedure SetConfig(const cfg: TServerConfigBlock); 
    procedure SetServer(const srv: boolean); 
    constructor Create(const asb: TAdviseStatusCallback; 
      const lab: TLargeAdjCallback; const enb: TExitNowCallback); 
    function UpdateNow: boolean; 
    destructor Destroy; override; 
  end; 
 
  TNetTimeClientThread = class(TThread) 
  protected 
    MyOwner: TNetTimeIPCClient; 
    MyEvent: THandle; 
    procedure Execute; override; 
  public 
    constructor Create(const Owner: TNetTimeIPCClient; 
      const Suspended: boolean = false); 
  end; 
 
implementation 
 
const 
  ShareMemName = 'NetTimeGHJM_ShareMem'; 
  ServerEventName = 'NetTimeGHJM_ServerEvent'; 
  ClientEventName = 'NetTimeGHJM_ServerEvent'; 
 
{ TNetTimeIPC } 
 
procedure TNetTimeIPC.InitResources; 
 
var 
  sa: TSecurityAttributes; 
  sd: TSecurityDescriptor; 
  sp: PSecurityAttributes; 
  ae: boolean; 
 
begin 
  if IsWindowsNT then 
    begin 
      InitializeSecurityDescriptor(@sd,SECURITY_DESCRIPTOR_REVISION); 
      SetSecurityDescriptorDACL(@sd,true,nil,false); 
      sa.nLength := sizeof(sa); 
      sa.lpSecurityDescriptor := @sd; 
      sa.bInheritHandle := false; 
      sp := @sa; 
    end 
  else 
    sp := nil; 
  ShareMemHandle := CreateFileMapping($ffffffff,sp,PAGE_READWRITE,0, 
    sizeof(TShareMemBlock),pchar(ShareMemName)); 
  if ShareMemHandle = 0 then 
    raise exception.create('Could not open shared memory'); 
  ae := (GetLastError = ERROR_ALREADY_EXISTS); 
  ShareMem := MapViewOfFile(ShareMemHandle,FILE_MAP_ALL_ACCESS,0,0, 
    sizeof(TShareMemBlock)); 
  if ShareMem = nil then 
    raise exception.create('Could not map shared memory'); 
  if not ae then 
    FillChar(ShareMem^,sizeof(TShareMemBlock),0); 
end; 
 
procedure TNetTimeIPC.FreeResources; 
begin 
  if ShareMem <> nil then 
    begin 
      UnmapViewOfFile(ShareMem); 
      CloseHandle(ShareMemHandle); 
      ShareMem := nil; 
    end; 
end; 
 
function CheckProcessExists(const pid: longword): boolean; 
 
var 
  ph: THandle; 
  er: longword; 
 
begin 
  if pid = 0 then 
    begin 
      result := false; 
      exit; 
    end; 
  ph := OpenProcess(PROCESS_QUERY_INFORMATION,false,pid); 
  if ph = 0 then 
    begin 
      er := GetLastError; 
      if (er = ERROR_ACCESS_DENIED) or (er = ERROR_NETWORK_ACCESS_DENIED) or 
        (er = ERROR_EA_ACCESS_DENIED) then 
        result := true 
      else 
        result := false; 
    end 
  else 
    begin 
      result := true; 
      CloseHandle(ph); 
    end; 
end; 
 
function TNetTimeIPC.CheckServerRunning: boolean; 
begin 
  if ShareMem = nil then 
    result := false 
  else 
    result := CheckProcessExists(ShareMem^.S_ServerPID); 
end; 
 
function TNetTimeIPC.CheckClientRunning: boolean; 
begin 
  if ShareMem = nil then 
    result := false 
  else 
    result := CheckProcessExists(ShareMem^.C_ClientPID); 
end; 
 
procedure SignalEventByName(const Name: string); 
 
var 
  EventHandle: THandle; 
 
begin 
  EventHandle := OpenEvent(EVENT_ALL_ACCESS,false,pchar(Name)); 
  if EventHandle <> 0 then 
    begin 
      SetEvent(EventHandle); 
      CloseHandle(EventHandle); 
    end; 
end; 
 
procedure TNetTimeIPC.KillEverything; 
begin 
  if ShareMem <> nil then 
    begin 
      ShareMem^.G_ExitNowFlag := true; 
      SignalEventByName(ClientEventName); 
      SignalEventByName(ServerEventName); 
    end; 
  if Assigned(ExitNowCallback) then 
    ExitNowCallback; 
end; 
 
constructor TNetTimeIPC.Create(const enb: TExitNowCallback); 
begin 
  inherited Create; 
  ExitNowCallback := enb; 
  HaveKilled := false; 
  ShareMem := nil; 
end; 
 
destructor TNetTimeIPC.Destroy; 
begin 
  FreeResources; 
  inherited; 
end; 
 
{TNetTimeIPCServer} 
 
procedure TNetTimeIPCServer.ClientHello; 
begin 
  ClientEvent := OpenEvent(EVENT_ALL_ACCESS,false,ClientEventName); 
end; 
 
procedure TNetTimeIPCServer.ClientGoodbye; 
begin 
  ClientEvent := 0; 
end; 
 
function TNetTimeIPCServer.LargeAdjustWarn(const ServerTime, StationTime: TDateTime): boolean; 
begin 
  if (ClientEvent = 0) or (ShareMem = nil) or (not CheckClientRunning) then 
    begin 
      result := true; 
      exit; 
    end; 
  ShareMem^.S_ServerTime := ServerTime; 
  ShareMem^.S_StationTime := StationTime; 
  ShareMem^.C_LargeAdjReplyFlag := false; 
  ShareMem^.S_LargeAdjFlag := true; 
  SetEvent(ClientEvent); 
  repeat 
    Sleep(IPCSleepTime); 
  until ShareMem^.C_LargeAdjReplyFlag; 
  ShareMem^.C_LargeAdjReplyFlag := false; 
  result := ShareMem^.C_LargeAdjReplyResult; 
end; 
 
procedure TNetTimeIPCServer.AdviseStatus; 
begin 
  if ShareMem = nil then 
    exit; 
  ShareMem^.S_Status := GetServerStatusCallback; 
  ShareMem^.S_AdviseStatusFlag := true; 
  if (ClientEvent <> 0) then 
    SetEvent(ClientEvent); 
end; 
 
procedure TNetTimeIPCServer.InitResources; 
begin 
  inherited; 
  ShareMem^.G_MagicCookie := MagicCookie; 
  ShareMem^.G_ProtocolVersion := ProtocolVersion; 
  ShareMem^.S_ServerPID := GetCurrentProcessID; 
  MyThread := TNetTimeServerThread.Create(Self); 
end; 
 
procedure TNetTimeIPCServer.FreeResources; 
begin 
  if ShareMem <> nil then 
    ShareMem^.S_ServerPID := 0; 
  if MyThread <> nil then 
    begin 
      MyThread.Terminate; 
      SetEvent(MyThread.MyEvent); 
      MyThread.WaitFor; 
      MyThread.Free; 
      MyThread := nil; 
    end; 
  inherited; 
end; 
 
constructor TNetTimeIPCServer.Create(const gsb: TGetServerStatusCallback; 
  const scb: TSetConfigCallback; const ssb: TSetServerCallback; 
  const enb: TExitNowCallback; const unb: TUpdateNowCallback); 
begin 
  inherited Create(enb); 
  MyThread := nil; 
  GetServerStatusCallback := gsb; 
  SetConfigCallback := scb; 
  SetServerCallback := ssb; 
  UpdateNowCallback := unb; 
end; 
 
destructor TNetTimeIPCServer.Destroy; 
begin 
  FreeResources; 
  inherited; 
end; 
 
procedure TNetTimeIPCServer.SetServer; 
begin 
  if ShareMem <> nil then 
    SetServerCallback(ShareMem^.C_Server); 
end; 
 
procedure TNetTimeIPCServer.SetConfig; 
begin 
  if ShareMem <> nil then 
    SetConfigCallback(ShareMem^.C_Config); 
end; 
 
{ TNetTimeServerThread } 
 
constructor TNetTimeServerThread.Create(const Owner: TNetTimeIPCServer; 
  const Suspended: boolean = false); 
 
var 
  sa: TSecurityAttributes; 
  sd: TSecurityDescriptor; 
  sp: PSecurityAttributes; 
 
begin 
  inherited Create(true); 
  MyOwner := Owner; 
  if IsWindowsNT then 
    begin 
      InitializeSecurityDescriptor(@sd,SECURITY_DESCRIPTOR_REVISION); 
      SetSecurityDescriptorDACL(@sd,true,nil,false); 
      sa.nLength := sizeof(sa); 
      sa.lpSecurityDescriptor := @sd; 
      sa.bInheritHandle := false; 
      sp := @sa; 
    end 
  else 
    sp := nil; 
  MyEvent := CreateEvent(sp,true,false,ServerEventName); 
  if MyEvent = 0 then 
    raise exception.create('Could not create server event'); 
  if not Suspended then 
    Resume; 
end; 
 
procedure TNetTimeServerThread.Execute; 
begin 
  repeat 
    ResetEvent(MyEvent); 
    WaitForSingleObject(MyEvent,INFINITE); 
    if MyOwner.ShareMem <> nil then 
      with MyOwner.ShareMem^ do 
        begin 
          if (C_StatusWantedSerial > S_StatusProvidedSerial) then 
            begin 
              S_Status := MyOwner.GetServerStatusCallback; 
              S_StatusProvidedSerial := C_StatusWantedSerial; 
            end; 
          if C_SetConfigFlag then 
            begin 
              MyOwner.SetConfig; 
              C_SetConfigFlag := false; 
            end; 
          if C_SetServerFlag then 
            begin 
              MyOwner.SetServer; 
              C_SetServerFlag := false; 
            end; 
          if C_ClientStatusChangeFlag then 
            begin 
              if C_ClientPID <> 0 then 
                MyOwner.ClientHello 
              else 
                MyOwner.ClientGoodbye; 
              C_ClientStatusChangeFlag := false; 
            end; 
          if C_WantUpdateNowFlag then 
            begin 
              if Assigned(MyOwner.UpdateNowCallback) then 
                S_LastUpdateGood := MyOwner.UpdateNowCallback; 
              C_WantUpdateNowFlag := false; 
            end; 
          if G_ExitNowFlag then 
            begin 
              if not MyOwner.HaveKilled then 
                begin 
                  MyOwner.HaveKilled := true; 
                  if Assigned(MyOwner.ExitNowCallback) then 
                    Synchronize(MyOwner.ExitNowCallback); 
                end; 
            end; 
        end; 
  until Terminated; 
end; 
 
{ TNetTimeIPCClient } 
 
function TNetTimeIPCClient.GetServerStatus: TServerStatusBlock; 
 
var 
  sws: integer; 
  crit: TCriticalSection; 
 
begin 
  if ShareMem = nil then 
    raise exception.create('Shared memory not mapped'); 
  if not CheckServerRunning then 
    raise exception.create('Server died'); 
  ShareMem^.S_AdviseStatusFlag := false; 
  crit := TCriticalSection.Create; 
  try 
    crit.Acquire; 
    sws := ShareMem^.C_StatusWantedSerial + 1; 
    ShareMem^.C_StatusWantedSerial := sws; 
    crit.Release; 
  finally 
    crit.Free; 
  end; 
  SetEvent(ServerEvent); 
  repeat 
    Sleep(IPCSleepTime); 
  until ShareMem^.S_StatusProvidedSerial >= sws; 
  result := ShareMem^.S_Status; 
end; 
 
procedure TNetTimeIPCClient.RetrieveStatus; 
begin 
  if ShareMem = nil then 
    raise exception.create('Shared memory not mapped'); 
  AdviseStatusCallback(ShareMem^.S_Status); 
end; 
 
procedure TNetTimeIPCClient.DoLargeAdj; 
begin 
  if ShareMem = nil then 
    raise exception.create('Shared memory not mapped'); 
  ShareMem^.C_LargeAdjReplyResult := LargeAdjCallback(ShareMem^.S_ServerTime, 
    ShareMem^.S_StationTime); 
  Sharemem^.C_LargeAdjReplyFlag := true; 
end; 
 
procedure TNetTimeIPCClient.SetConfig(const cfg: TServerConfigBlock); 
begin 
  if ShareMem = nil then 
    raise exception.create('Shared memory not mapped'); 
  if not CheckServerRunning then 
    raise exception.create('Server died'); 
  ShareMem^.C_Config := cfg; 
  ShareMem^.C_SetConfigFlag := true; 
  SetEvent(ServerEvent); 
  repeat 
    Sleep(IPCSleepTime); 
  until ShareMem^.C_SetConfigFlag = false; 
end; 
 
procedure TNetTimeIPCClient.SetServer(const srv: boolean); 
begin 
  if ShareMem = nil then 
    raise exception.create('Shared memory not mapped'); 
  if not CheckServerRunning then 
    raise exception.create('Server died'); 
  ShareMem^.C_Server := srv; 
  ShareMem^.C_SetServerFlag := true; 
  SetEvent(ServerEvent); 
  repeat 
    Sleep(IPCSleepTime); 
  until ShareMem^.C_SetServerFlag = false; 
end; 
 
function TNetTimeIPCClient.UpdateNow: boolean; 
begin 
  if ShareMem = nil then 
    raise exception.create('Shared memory not mapped'); 
  if not CheckServerRunning then 
    raise exception.create('Server died'); 
  ShareMem^.C_WantUpdateNowFlag := true; 
  SetEvent(ServerEvent); 
  repeat 
    Sleep(IPCSleepTime); 
  until ShareMem^.C_WantUpdateNowFlag = false; 
  result := ShareMem^.S_LastUpdateGood; 
end; 
 
procedure TNetTimeIPCClient.InitResources; 
begin 
  inherited; 
  if (ShareMem^.G_MagicCookie <> MagicCookie) or 
    (ShareMem^.G_ProtocolVersion <> ProtocolVersion) then 
    raise exception.create('Could not connect to server: Server is running a different version of NetTime.'); 
  ServerEvent := OpenEvent(EVENT_ALL_ACCESS,false,ClientEventName); 
  if ServerEvent = 0 then 
    raise exception.create('Could not open server event: error '+inttostr(GetLastError)); 
  MyThread := TNetTimeClientThread.Create(Self); 
  ShareMem^.C_ClientPID := GetCurrentProcessID; 
  ShareMem^.C_ClientStatusChangeFlag := true; 
  SetEvent(ServerEvent); 
end; 
 
procedure TNetTimeIPCClient.FreeResources; 
begin 
  if ShareMem <> nil then 
    begin 
      ShareMem^.C_ClientPID := 0; 
      ShareMem^.C_ClientStatusChangeFlag := true; 
      if ServerEvent <> 0 then 
        SetEvent(ServerEvent); 
    end; 
  if MyThread <> nil then 
    begin 
      MyThread.Terminate; 
      SetEvent(MyThread.MyEvent); 
      MyThread.WaitFor; 
      MyThread.Free; 
      MyThread := nil; 
    end; 
  inherited; 
end; 
 
constructor TNetTimeIPCClient.Create(const asb: TAdviseStatusCallback; 
  const lab: TLargeAdjCallback; const enb: TExitNowCallback); 
begin 
  inherited Create(enb); 
  AdviseStatusCallback := asb; 
  LargeAdjCallback := lab; 
  ServerEvent := 0; 
  MyThread := nil; 
end; 
 
destructor TNetTimeIPCClient.Destroy; 
begin 
  if ShareMem <> nil then 
    begin 
      ShareMem^.C_ClientPID := 0; 
      ShareMem^.C_ClientStatusChangeFlag := true; 
      SetEvent(ServerEvent); 
    end; 
  if ServerEvent <> 0 then 
    CloseHandle(ServerEvent); 
  MyThread.Terminate; 
  if MyThread.MyEvent <> 0 then 
    SetEvent(MyThread.MyEvent); 
  inherited; 
end; 
 
{ TNetTimeClientThread } 
 
constructor TNetTimeClientThread.Create(const Owner: TNetTimeIPCClient; 
  const Suspended: boolean = false); 
 
var 
{ 
  sa: TSecurityAttributes; 
  sd: TSecurityDescriptor; 
} 
  sp: PSecurityAttributes; 
 
begin 
  inherited Create(true); 
  MyOwner := Owner; 
//  if IsWindowsNT then 
//    begin 
//      InitializeSecurityDescriptor(@sd,SECURITY_DESCRIPTOR_REVISION); 
//      sa.nLength := sizeof(sa); 
//      sa.lpSecurityDescriptor := @sd; 
//      sa.bInheritHandle := false; 
//      sp := @sa; 
//    end 
//  else 
    sp := nil; 
  MyEvent := CreateEvent(sp,true,false,ClientEventName); 
  if MyEvent = 0 then 
    raise exception.create('Could not create client event'); 
  if not Suspended then 
    Resume; 
end; 
 
procedure TNetTimeClientThread.Execute; 
begin 
  repeat 
    ResetEvent(MyEvent); 
    WaitForSingleObject(MyEvent,INFINITE); 
    if MyOwner.ShareMem <> nil then 
      with MyOwner.ShareMem^ do 
        begin 
          if S_AdviseStatusFlag then 
            begin 
              Synchronize(MyOwner.RetrieveStatus); 
              S_AdviseStatusFlag := false; 
            end; 
          if S_LargeAdjFlag then 
            begin 
              Synchronize(MyOwner.DoLargeAdj); 
              S_LargeAdjFlag := false; 
            end; 
          if G_ExitNowFlag then 
            begin 
              if not MyOwner.HaveKilled then 
                begin 
                  MyOwner.HaveKilled := true; 
                  if Assigned(MyOwner.ExitNowCallback) then 
                    Synchronize(MyOwner.ExitNowCallback); 
                end; 
            end; 
        end; 
  until Terminated; 
end; 
 
end.