Mega Code Archive
StartingStopingDetecting Interbase installedrunning
<![CDATA[
Title: Starting/Stoping/Detecting Interbase installed/running
Question: How can I control Interbase better?
Is there anyway to start Interbase from my application if it's not running? Can I also stop Interbase when my application is done?
(not recommended since other applications might use it)
Answer:
Here comes some useful functions/procedures for controlling Interbase...
//
// Declarations
//
unit IBSrvUnit;
uses SysUtils, Classes, Windows, FileCtrl, WinTypes, WinProcs, 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;
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 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 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 := FixPath(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 := FixPath(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(FixPath(GetSysDirectory)+'gds32.dll') then result := true else result := false;
end else result := false;
end else result := true;
end;
end.
]]>