On 2006-08-15 20:21, Alexandre Leclerc wrote:
Thank you for all this information Boguslaw. I'll have a look into
that. The moment it works, I don't care about usual warpers.
I created this little example some time ago. It will also show you how
to install/uninstall the service under win32.
Take care
Søren
program Service;
{$mode objfpc}{$H+}
uses
Classes, Windows, SysUtils;
VAR
MyServiceStatus : SERVICE_STATUS;
MyServiceStatusHandle : SERVICE_STATUS_HANDLE;
PROCEDURE SvcDebugOut(Msg: String; Status: Dword);
VAR
Buffer: ARRAY[0..1024] OF Char;
BEGIN
IF Length(Msg) < 1000 THEN
BEGIN
Buffer:=Format(Msg, [Status]);
OutputDebugStringA(Buffer);
END;
END;
FUNCTION MyServiceCtrlHandler(Opcode: DWord): LongBool; StdCall;
VAR
status: DWord;
BEGIN
case Opcode of
SERVICE_CONTROL_PAUSE:
BEGIN
// Do whatever it takes to pause here.
MyServiceStatus.dwCurrentState := SERVICE_PAUSED;
END;
SERVICE_CONTROL_CONTINUE:
BEGIN
// Do whatever it takes to continue here.
MyServiceStatus.dwCurrentState := SERVICE_RUNNING;
END;
SERVICE_CONTROL_STOP:
BEGIN
// Do whatever it takes to stop here.
MyServiceStatus.dwWin32ExitCode := 0;
MyServiceStatus.dwCurrentState := SERVICE_STOPPED;
MyServiceStatus.dwCheckPoint := 0;
MyServiceStatus.dwWaitHint := 0;
IF NOT SetServiceStatus(MyServiceStatusHandle, @MyServiceStatus) THEN
SvcDebugOut(' [SERVICE] SetServiceStatus error %ld\n', GetLastError());
SvcDebugOut(' [SERVICE] Leaving MyService \n',0);
exit;
END;
SERVICE_CONTROL_INTERROGATE: ;
// Fall through to send current status.
else
SvcDebugOut(' [SERVICE] Unrecognized opcode %ld\n', Opcode);
end;
// Send current status.
IF NOT SetServiceStatus (MyServiceStatusHandle, @MyServiceStatus) THEN
SvcDebugOut(' [MY_SERVICE] SetServiceStatus error %ld\n', GetLastError());
END;
// Stub initialization function.
FUNCTION MyServiceInitialization(argc: DWord; argv: LPTSTR; VAR specificError:
DWord): DWord;
BEGIN
MyServiceInitialization:=0;
END;
PROCEDURE MyServiceStart(argc: DWORD; argv: LPTSTR); StdCall;
VAR
status: DWord;
specificError: DWord;
BEGIN
MyServiceStatus.dwServiceType := SERVICE_WIN32;
MyServiceStatus.dwCurrentState := SERVICE_START_PENDING;
MyServiceStatus.dwControlsAccepted := SERVICE_ACCEPT_STOP OR
SERVICE_ACCEPT_PAUSE_CONTINUE;
MyServiceStatus.dwWin32ExitCode := 0;
MyServiceStatus.dwServiceSpecificExitCode := 0;
MyServiceStatus.dwCheckPoint := 0;
MyServiceStatus.dwWaitHint := 0;
MyServiceStatusHandle := RegisterServiceCtrlHandler('Service',
@MyServiceCtrlHandler);
IF (MyServiceStatusHandle = 0) THEN
BEGIN
SvcDebugOut(' [SERVICE] RegisterServiceCtrlHandler failed %d\n',
GetLastError());
exit;
END;
// Initialization code goes here.
status := MyServiceInitialization(argc,argv,specificError);
// Handle error condition
IF status <> NO_ERROR THEN
BEGIN
MyServiceStatus.dwCurrentState := SERVICE_STOPPED;
MyServiceStatus.dwCheckPoint := 0;
MyServiceStatus.dwWaitHint := 0;
MyServiceStatus.dwWin32ExitCode := status;
MyServiceStatus.dwServiceSpecificExitCode := specificError;
SetServiceStatus(MyServiceStatusHandle, @MyServiceStatus);
exit;
END;
// Initialization complete - report running status.
MyServiceStatus.dwCurrentState := SERVICE_RUNNING;
MyServiceStatus.dwCheckPoint := 0;
MyServiceStatus.dwWaitHint := 0;
IF NOT SetServiceStatus(MyServiceStatusHandle, @MyServiceStatus) THEN
BEGIN
status := GetLastError();
SvcDebugOut(' [SERVICE] SetServiceStatus error %ld\n',status);
END;
// This is where the service does its work.
while MyServiceStatus.dwCurrentState <> SERVICE_STOPPED do
begin
Sleep(2);
end;
SvcDebugOut(' [SERVICE] Returning the Main Thread \n',0);
END;
FUNCTION CreateSampleService: Boolean;
VAR
szPath: ARRAY[0..MAX_PATH] OF Char;
schSCManager: SC_HANDLE;
schService: SC_HANDLE;
BEGIN
IF GetModuleFileName(0, szPath, MAX_PATH)=0 THEN
BEGIN
WriteLn(Format('GetModuleFileName failed (%d)', [GetLastError()]));
Result:=False;
Exit;
END;
schSCManager := OpenSCManager(
nil, // local machine
nil, // ServicesActive database
SC_MANAGER_ALL_ACCESS); // full access rights
IF schSCManager=0 THEN
BEGIN
WriteLn(Format('OpenSCManager failed (%d)', [GetLastError()]));
Result:=False;
Exit;
END;
schService := CreateService(
schSCManager, // SCManager database
'Service', // name of service
'My test service', // service name to display
SERVICE_ALL_ACCESS, // desired access
SERVICE_WIN32_OWN_PROCESS, // service type
SERVICE_DEMAND_START, // start type
SERVICE_ERROR_NORMAL, // error control type
szPath, // path to service's binary
nil, // no load ordering group
nil, // no tag identifier
nil, // no dependencies
nil, // LocalSystem account
nil); // no password
IF schService=0 THEN
BEGIN
CloseServiceHandle(schSCManager);
WriteLn(Format('CreateService failed (%d)', [GetLastError()]));
Result:=False;
END ELSE
BEGIN
CloseServiceHandle(schService);
CloseServiceHandle(schSCManager);
WriteLn('CreateService sucessfull');
Result:=True;
END;
END;
FUNCTION DeleteSampleService: Boolean;
VAR
schSCManager: SC_HANDLE;
schService: SC_HANDLE;
BEGIN
schSCManager := OpenSCManager(
nil, // local machine
nil, // ServicesActive database
SC_MANAGER_ALL_ACCESS); // full access rights
IF schSCManager=0 THEN
BEGIN
WriteLn(Format('OpenSCManager failed (%d)', [GetLastError()]));
Result:=False;
Exit;
END;
schService := OpenService(
schSCManager, // SCManager database
'Service', // name of service
SERVICE_DELETE); // only need DELETE access
IF schService=0 THEN
BEGIN
CloseServiceHandle(schSCManager);
WriteLn(Format('OpenService failed (%d)', [GetLastError()]));
Result:=False;
END;
IF NOT DeleteService(schService) THEN
BEGIN
WriteLn(Format('DeleteService failed (%d)', [GetLastError()]));
Result:=False;
END ELSE
BEGIN
WriteLn('DeleteService succeeded');
CloseServiceHandle(schService);
CloseServiceHandle(schSCManager);
Result:=False;
END;
END;
VAR
DispatchTable: ARRAY[1..2] OF SERVICE_TABLE_ENTRY;
BEGIN
// TODO: Better parm handeling
IF ParamStr(1)='install' THEN
CreateSampleService
ELSE
IF ParamStr(1)='uninstall' THEN
DeleteSampleService
ELSE
BEGIN
FillChar(DispatchTable, SizeOf(DispatchTable), 0);
DispatchTable[1].lpServiceName:='Service';
DispatchTable[1].lpServiceProc:[EMAIL PROTECTED];
IF NOT StartServiceCtrlDispatcher(@DispatchTable) THEN
SvcDebugOut(' [SERVICE] StartServiceCtrlDispatcher
(%d)\n',GetLastError());
END;
END.
