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.