nettimeipc.pas

VC++实现的时间同步程序

  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.