Starting-Stoping-Detecting Interbase-FireBird

Mesaj gönderen **name** » 30 Ara 2003 01:30

Kesinlikle işe yarayacak bir unit. İçersinde yer alan bazı fonksiyonlar başka yerlerdede kullanılabilir.

Kullanım amacına göre kod biraz daha kısaltılabilir

Kod: Tümünü seç

unit IBSrvUnit;

interface

//uses SysUtils, Classes, Windows, FileCtrl, WinTypes, WinProcs, WinSvc;
uses Sysutils, Windows, Registry, ShellAPI, WinSvc;

const
  SECURITY_NT_AUTHORITY: TSIDIdentifierAuthority = (Value: (0, 0, 0, 0, 0, 5));
  SECURITY_BUILTIN_DOMAIN_RID = $00000020;
  DOMAIN_ALIAS_RID_ADMINS = $00000220;
  ENGINE_ID = 1;
  INDEX_SERVER_ID = 2;
  STOP_LISTS_ID = 21;
  NEUTRAL_STOP_LIST_ID = 211;
  ENGLISH_STOP_LIST_ID = 212;
  MORPHOLOGY_ID = 3;
  SOUNDEX_ID = 4;
  THESAURUS_ID = 5;
  THES_PROJ_ID = 51;
  THES_DIC_ID = 52;
  LOGIN_ID = 6;
  FILTER_ID = 7;
  THES_DIC_OFFSET = 10000;

function GetSysDirectory: string;
function GetIBRootDir: string;
function IsNT: boolean;
function IsAdmin: Boolean;
function ServiceCreate(sMachine, sService, sDisplayName, sBinFile: string; StartType: integer): boolean;
function ServiceDelete(sMachine, sService: string): boolean;
function ServiceStart(sMachine, sService: string): boolean;
function ServiceStop(sMachine, sService: string): boolean;
function GetInterbaseGuardianFile: string;
function InterbaseRunning: boolean;
function ShutDownInterbase: boolean;
function StartInterbase: boolean;
function InterbaseInstalled: boolean;

implementation

//uses registry;

//—————————————————————————————————————————————————————————————————————————————
// Returns the system directory for the current running OS
//—————————————————————————————————————————————————————————————————————————————

function GetSysDirectory: string;
var SysDir: Pchar;
begin
  SysDir := StrAlloc(255);
  try
    fillchar(SysDir^, 255, 0);
    GetSystemDirectory(SysDir, 255); // Get the "windows\system" directory
    result := SysDir;
  finally
    StrDispose(SysDir);
  end;
end;

//—————————————————————————————————————————————————————————————————————————————
// Returns the Interbase installation path
//—————————————————————————————————————————————————————————————————————————————

function GetIBRootDir: string;
var Reg: TRegistry;
begin
  Reg := TRegistry.Create(KEY_READ);
  try
    Reg.RootKey := HKEY_LOCAL_MACHINE;
    if Reg.KeyExists('\Software\Borland\InterBase\CurrentVersion') then begin
        if Reg.OpenKeyReadOnly('\Software\Borland\InterBase\CurrentVersion') then begin
            if Reg.ValueExists('RootDirectory') then begin
                result := Reg.ReadString('RootDirectory');
              end;
            Reg.CloseKey;
          end else result := '';
      end else result := '';
  finally
    Reg.free;
  end;
end;

//—————————————————————————————————————————————————————————————————————————————
// Returns true if applications runs on NT/2000
//—————————————————————————————————————————————————————————————————————————————

function IsNT: boolean;
var osv: TOSVERSIONINFO;
begin
  fillchar(osv, sizeof(TOSVERSIONINFO), 0);
  osv.dwOSVersionInfoSize := sizeof(TOSVERSIONINFO);
  GetVersionEx(osv);
  if (osv.dwPlatformId = VER_PLATFORM_WIN32_NT) then result := true else result := false;
end;

//—————————————————————————————————————————————————————————————————————————————
// Returns true if the current user is an administrator
//—————————————————————————————————————————————————————————————————————————————

function IsAdmin: Boolean;
var
  hAccessToken: THandle;
  ptgGroups: PTokenGroups;
  dwInfoBufferSize: DWORD;
  psidAdministrators: PSID;
  x: Integer;
  bSuccess: BOOL;
begin
  if IsNT then begin
      Result := False;
      bSuccess := OpenThreadToken(GetCurrentThread, TOKEN_QUERY, True, hAccessToken);
      if not bSuccess then begin
          if GetLastError = ERROR_NO_TOKEN then
            bSuccess := OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, hAccessToken);
        end;
      if bSuccess then begin
          GetMem(ptgGroups, 1024);
          bSuccess := GetTokenInformation(hAccessToken, TokenGroups, ptgGroups, 1024, dwInfoBufferSize);
          CloseHandle(hAccessToken);
          if bSuccess then begin
              AllocateAndInitializeSid(SECURITY_NT_AUTHORITY, 2, SECURITY_BUILTIN_DOMAIN_RID,
                DOMAIN_ALIAS_RID_ADMINS, 0, 0, 0, 0, 0, 0, psidAdministrators);
{$R-}
              for x := 0 to ptgGroups.GroupCount - 1 do begin
                  if EqualSid(psidAdministrators, ptgGroups.Groups[x].Sid) then begin
                      Result := True;
                      Break;
                    end;
                end;
{$R+}
              FreeSid(psidAdministrators);
            end;
          FreeMem(ptgGroups);
        end;
    end else result := true; // If not running on Windows NT then admin = ok
end;

//—————————————————————————————————————————————————————————————————————————————
// Creates an NT Service
//—————————————————————————————————————————————————————————————————————————————

function ServiceCreate(sMachine, sService, sDisplayName, sBinFile: string; StartType: integer): boolean;
var schm, schs: SC_Handle;
begin
  schm := OpenSCManager(PChar(sMachine), nil, SC_MANAGER_CREATE_SERVICE);
  if (schm > 0) then begin
      schs := CreateService(schm, PChar(sService), pchar(sDisplayName), SERVICE_ALL_ACCESS,
        SERVICE_INTERACTIVE_PROCESS or SERVICE_WIN32_OWN_PROCESS, StartType,
        SERVICE_ERROR_NORMAL, pchar(sBinFile), nil, nil, nil, nil, nil);
      if (schs > 0) then begin
          result := true;
          CloseServiceHandle(schs);
        end else result := false;
      CloseServiceHandle(schm);
    end else result := false;
end;

//—————————————————————————————————————————————————————————————————————————————
// Removes an NT Service
//—————————————————————————————————————————————————————————————————————————————

function ServiceDelete(sMachine, sService: string): boolean;
var schm, schs: SC_Handle;
begin
  schm := OpenSCManager(PChar(sMachine), nil, SC_MANAGER_CREATE_SERVICE);
  if (schm > 0) then begin
      schs := OpenService(schm, pchar(sService), SERVICE_ALL_ACCESS);
      if (schs > 0) then begin
          result := DeleteService(schs);
          CloseServiceHandle(schs);
        end else result := false;
      CloseServiceHandle(schm);
    end else result := false;
end;

//—————————————————————————————————————————————————————————————————————————————
// Starts an NT service
//—————————————————————————————————————————————————————————————————————————————

function ServiceStart(sMachine, sService: string): boolean;
var
  schm, schs: SC_Handle;
  ss: TServiceStatus;
  psTemp: PChar;
  dwChkP: DWord;
begin
  ss.dwCurrentState := 0;
  schm := OpenSCManager(PChar(sMachine), nil, SC_MANAGER_CONNECT);
  if (schm > 0) then begin
      schs := OpenService(schm, PChar(sService), SERVICE_START or SERVICE_QUERY_STATUS);
      if (schs > 0) then begin
          psTemp := nil;
          if (StartService(schs, 0, psTemp)) then begin
              if (QueryServiceStatus(schs, ss)) then begin
                  while (SERVICE_RUNNING <> ss.dwCurrentState) do begin
                      dwChkP := ss.dwCheckPoint;
                      Sleep(ss.dwWaitHint);
                      if (not QueryServiceStatus(schs, ss)) then begin
                          break;
                        end;
                      if (ss.dwCheckPoint < dwChkP) then begin
                          break;
                        end;
                    end;
                end;
            end;
          CloseServiceHandle(schs);
        end;
      CloseServiceHandle(schm);
    end;
  Result := SERVICE_RUNNING = ss.dwCurrentState;
end;

//—————————————————————————————————————————————————————————————————————————————
// Stops an NT service
//—————————————————————————————————————————————————————————————————————————————

function ServiceStop(sMachine, sService: string): boolean;
var
  schm, schs: SC_Handle;
  ss: TServiceStatus;
  dwChkP: DWord;
begin
  schm := OpenSCManager(PChar(sMachine), nil, SC_MANAGER_CONNECT);
  if (schm > 0) then begin
      schs := OpenService(schm, PChar(sService), SERVICE_STOP or SERVICE_QUERY_STATUS);
      if (schs > 0) then begin
          if (ControlService(schs, SERVICE_CONTROL_STOP, ss)) then begin
              if (QueryServiceStatus(schs, ss)) then begin
                  while (SERVICE_STOPPED <> ss.dwCurrentState) do begin
                      dwChkP := ss.dwCheckPoint;
                      Sleep(ss.dwWaitHint);
                      if (not QueryServiceStatus(schs, ss)) then begin
                          break;
                        end;
                      if (ss.dwCheckPoint < dwChkP) then begin
                          break;
                        end;
                    end;
                end;
            end;
          CloseServiceHandle(schs);
        end;
      CloseServiceHandle(schm);
    end;
  Result := (SERVICE_STOPPED = ss.dwCurrentState);
end;

//—————————————————————————————————————————————————————————————————————————————
// Returns the full name to the Interbase guardian EXE file
//—————————————————————————————————————————————————————————————————————————————

function GetInterbaseGuardianFile: string;
var
  Filename: string;
  Reg: TRegistry;
begin
  Filename := '';
  Reg := TRegistry.Create(KEY_READ);
  try
    Reg.RootKey := HKEY_LOCAL_MACHINE;
    if Reg.KeyExists('Software\InterBase Corp\InterBase\CurrentVersion') then begin
        if Reg.OpenKeyReadOnly('Software\InterBase Corp\InterBase\CurrentVersion') then begin
            Filename := Reg.ReadString('ServerDirectory') + 'ibguard.exe';
            Reg.CloseKey;
          end;
      end else begin
        if Reg.KeyExists('Software\Borland\InterBase\CurrentVersion') then begin
            if Reg.OpenKeyReadOnly('Software\Borland\InterBase\CurrentVersion') then begin
                Filename := Reg.ReadString('ServerDirectory') + 'ibguard.exe';
                Reg.CloseKey;
              end;
          end;
      end;
  finally
    Reg.free;
  end;
  result := filename;
end;

//—————————————————————————————————————————————————————————————————————————————
// returns true if Interbase is running
//—————————————————————————————————————————————————————————————————————————————

function InterbaseRunning: boolean;
begin
  result := boolean(FindWindow('IB_Server', 'InterBase Server')
    or FindWindow('IB_Guard', 'InterBase Guardian'));
end;

//—————————————————————————————————————————————————————————————————————————————
// Shuts down Interbase
//—————————————————————————————————————————————————————————————————————————————

function ShutDownInterbase: boolean;
var IBSRVHandle, IBGARHandle: THandle;
begin
  if IsNT then begin
      result := ServiceStop('', 'InterBaseGuardian');
    end else begin
      IBGARHandle := FindWindow('IB_Guard', 'InterBase Guardian');
      if IBGARHandle > 0 then begin
          PostMessage(IBGARHandle, 31, 0, 0);
          PostMessage(IBGARHandle, 16, 0, 0);
        end;
      IBSRVHandle := FindWindow('IB_Server', 'InterBase Server');
      if IBSRVHandle > 0 then begin
          PostMessage(IBSRVHandle, 31, 0, 0);
          PostMessage(IBSRVHandle, 16, 0, 0);
        end;
      result := InterbaseRunning;
    end;
end;

//—————————————————————————————————————————————————————————————————————————————
// Starts Interbase
//—————————————————————————————————————————————————————————————————————————————

function StartInterbase: boolean;
var
  Filename: string;
  StartupInfo: TStartupInfo;
  ProcessInformation: TProcessInformation;
begin
  filename := GetInterbaseGuardianFile;
  if FileExists(Filename) then begin
      if IsNT then begin result := ServiceStart('', 'InterBaseGuardian');
        end else begin
          Fillchar(StartupInfo, Sizeof(TStartupInfo), 0);
          StartupInfo.cb := sizeof(StartupInfo);
          StartupInfo.lpReserved := nil;
          StartupInfo.lpTitle := nil;
          StartupInfo.lpDesktop := nil;
          StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
          StartupInfo.wShowWindow := SW_SHOWNA;
          StartupInfo.cbReserved2 := 0;
          StartupInfo.lpReserved2 := nil;
          result := CreateProcess(nil, PChar(filename), nil, nil, False, NORMAL_PRIORITY_CLASS,
            nil, PChar(ExtractFilePath(filename)), StartupInfo, ProcessInformation);
        end;
    end else result := false;
end;

//—————————————————————————————————————————————————————————————————————————————
// Returns TRUE if Interbase is installed
//—————————————————————————————————————————————————————————————————————————————

function InterbaseInstalled: boolean;
var
  Filename: string;
  Running: boolean;
  Reg: TRegistry;
begin
  Running := InterbaseRunning;
  if Running = false then begin
      filename := GetInterbaseGuardianFile;
      if FileExists(Filename) then begin
          if FileExists(GetSysDirectory + '\gds32.dll') then result := true else result := false;
        end else result := false;
    end else result := true;
end;

end.

Mesaj gönderen **husonet** » 30 Ara 2003 03:03

Arkadaşım kodların içine biraz Türkçe açıklama serpiştirseydin anlaşılması daha kolay olurdu. Eline Sağlık.

Mesaj gönderen **name** » 30 Ara 2003 03:40

Yanlış anlaşılma olmasın. Bu kodları ben yazmadım (delphide yeni sayılırım). Sadece güzel bir şey bulduğum için paylaşmak istedim.
Aslında kod o kadarda karışık değil, sadece yeni bir çok windows api komutu (benimde yeni gördüğüm) var.