Delphi小巧的Windows NT服務程式源碼

program DemoSrv;

// Windows NT Service Demo Program for Delphi 3
// By Tom Lee , Taiwan , Repubilc of China ( Tomm.bbs@csie.nctu.edu.tw )
// JUL 8 1997
// ver 1.01
// The service will beep every 10 second .

uses SysUtils, Windows, WinSvc;

const
ServiceName = 'TomDemoService';
ServiceDisplayName = 'd99 test Service';
SERVICE_WIN32_OWN_PROCESS = $00000010;
SERVICE_DEMAND_START = $00000003;
SERVICE_ERROR_NORMAL = $00000001;
EVENTLOG_ERROR_TYPE = $0001;

// declare global variable
var
ServiceStatusHandle: SERVICE_STATUS_HANDLE;
ssStatus: TServiceStatus;
dwErr: DWORD;
ServiceTableEntry: array[0..1] of TServiceTableEntry;
hServerStopEvent: THandle;

// Get error message

function GetLastErrorText: string;
var
dwSize: DWORD;
lpszTemp: LPSTR;
begin
dwSize := 512;
lpszTemp := nil;
try
GetMem(lpszTemp, dwSize);
FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_ARGUMENT_ARRAY,
nil, GetLastError, LANG_NEUTRAL, lpszTemp, dwSize, nil);
finally
Result := StrPas(lpszTemp);
FreeMem(lpszTemp);
end;
end;

// Write error message to Windows NT Event Log

procedure AddToMessageLog(sMsg: string);
var
sString: array[0..1] of string;
hEventSource: THandle;
begin
hEventSource := RegisterEventSource(nil, ServiceName);

if hEventSource > 0 then
begin
sString[0] := ServiceName + ' error: ' + IntToStr(dwErr);
sString[1] := sMsg;
ReportEvent(hEventSource, EVENTLOG_ERROR_TYPE, 0, 0, nil, 2, 0, @sString, nil);
DeregisterEventSource(hEventSource);
end;
end;

function ReportStatusToSCMgr(dwState, dwExitCode, dwWait: DWORD): BOOL;
begin
Result := True;
with ssStatus do
begin
if (dwState = SERVICE_START_PENDING) then
dwControlsAccepted := 0
else
dwControlsAccepted := SERVICE_ACCEPT_STOP;

dwCurrentState := dwState;
dwWin32ExitCode := dwExitCode;
dwWaitHint := dwWait;

if (dwState = SERVICE_RUNNING) or (dwState = SERVICE_STOPPED) then
dwCheckPoint := 0
else
inc(dwCheckPoint);
end;

Result := SetServiceStatus(ServiceStatusHandle, ssStatus);
if not Result then AddToMessageLog('SetServiceStauts');
end;

procedure ServiceStop;
begin
if (hServerStopEvent > 0) then
begin
SetEvent(hServerStopEvent);
end;
end;

procedure ServiceStart;
var
dwWait: DWORD;
begin
// Report Status
if not ReportStatusToSCMgr(SERVICE_START_PENDING, NO_ERROR, 3000) then exit;

// this event when it receives the "stop" control code.
hServerStopEvent := createEvent(nil, TRUE, False, nil);
if hServerStopEvent = 0 then
begin
AddToMessageLog('createEvent');
exit;
end;

if not ReportStatusToSCMgr(SERVICE_RUNNING, NO_ERROR, 0) then
begin
CloseHandle(hServerStopEvent);
exit;
end;

// Service now running , perform work until shutdown
while True do
begin
// Wait for Terminate
MessageBeep(1);
dwWait := WaitforSingleObject(hServerStopEvent, 1);
if dwWait = WAIT_OBJECT_0 then
begin
CloseHandle(hServerStopEvent);
exit;
end;
Sleep(1000 * 10);
end;
end;

procedure Handler(dwCtrlCode: DWORD); stdcall;
begin
// Handle the requested control code.
case dwCtrlCode of

SERVICE_CONTROL_STOP:
begin
ReportStatusToSCMgr(SERVICE_STOP_PENDING, NO_ERROR, 0);
ServiceStop;
ReportStatusToSCMgr(SERVICE_STOPPED, GetLastError, 0);
exit;
end;

SERVICE_CONTROL_INTERROGATE:
begin
end;

SERVICE_CONTROL_PAUSE:
begin
end;

SERVICE_CONTROL_CONTINUE:
begin
end;

SERVICE_CONTROL_SHUTDOWN:
begin
end;

// invalid control code
else
end;

// update the service status.
ReportStatusToSCMgr(ssStatus.dwCurrentState, NO_ERROR, 0);
end;

procedure ServiceMain;
begin
// Register the handler function with dispatcher;
ServiceStatusHandle := RegisterServiceCtrlHandler(ServiceName, ThandlerFunction(@Handler));
if ServiceStatusHandle = 0 then
begin
ReportStatusToSCMgr(SERVICE_STOPPED, GetLastError, 0);
exit;
end;

ssStatus.dwServiceType := SERVICE_WIN32_OWN_PROCESS;
ssStatus.dwServiceSpecificExitCode := 0;
ssStatus.dwCheckPoint := 1;

// Report current status to SCM (Service Control Manager)
if not ReportStatusToSCMgr(SERVICE_START_PENDING, NO_ERROR, 3000) then
begin
ReportStatusToSCMgr(SERVICE_STOPPED, GetLastError, 0);
exit;
end;

// Start Service
ServiceStart;
end;

procedure InstallService;
var
schService: SC_HANDLE;
schSCManager: SC_HANDLE;
lpszPath: LPSTR;
dwSize: DWORD;
begin
dwSize := 512;
GetMem(lpszPath, dwSize);
if GetModuleFileName(0, lpszPath, dwSize) = 0 then
begin
FreeMem(lpszPath);
Writeln('Unable to install ' + ServiceName + ',GetModuleFileName Fail.');
exit;
end;
FreeMem(lpszPath);

schSCManager := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
if (schSCManager > 0) then
begin
schService := createService(schSCManager, ServiceName, ServiceDisplayName,
SERVICE_ALL_ACCESS, SERVICE_WIN32_OWN_PROCESS, SERVICE_DEMAND_START,
SERVICE_ERROR_NORMAL, pchar(ParamStr(0)), nil, nil, nil, nil, nil);
if (schService > 0) then
begin
Writeln('Install Ok.');
CloseServiceHandle(schService);
end
else
Writeln('Unable to install ' + ServiceName + ',createService Fail.');
end
else
Writeln('Unable to install ' + ServiceName + ',OpenSCManager Fail.');

end;

procedure UnInstallService;
var
schService: SC_HANDLE;
schSCManager: SC_HANDLE;
begin
schSCManager := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
if (schSCManager > 0) then
begin
schService := OpenService(schSCManager, ServiceName, SERVICE_ALL_ACCESS);
if (schService > 0) then
begin
// Try to stop service at first
if ControlService(schService, SERVICE_CONTROL_STOP, ssStatus) then
begin
Write('Stopping Service ');
Sleep(1000);
while (QueryServiceStatus(schService, ssStatus)) do
begin
if ssStatus.dwCurrentState = SERVICE_STOP_PENDING then
begin
Write('.');
Sleep(1000);
end
else
break;
end;
writeln;

if ssStatus.dwCurrentState = SERVICE_STOPPED then
Writeln('Service Stop Now')
else
begin
CloseServiceHandle(schService);
CloseServiceHandle(schSCManager);
Writeln('Service Stop Fail');
exit;
end;
end;

// Remove the service
if (deleteService(schService)) then
Writeln('Service Uninstall Ok.')
else
Writeln('deleteService fail (' + GetLastErrorText + ').');

CloseServiceHandle(schService);
end
else
Writeln('OpenService fail (' + GetLastErrorText + ').');

CloseServiceHandle(schSCManager);
end
else
Writeln('OpenSCManager fail (' + GetLastErrorText + ').');
end;

// Main Program Begin
begin
if (ParamCount = 1) then
begin
if ParamStr(1) = '/?' then
begin
Writeln('----------------------------------------');
Writeln('DEMOSRV usage help');
Writeln('----------------------------------------');
Writeln('DEMOSRV /install to install the service');
Writeln('DEMOSRV /remove to uninstall the service');
Writeln('DEMOSRV /? Help');
Halt;
end;

if Uppercase(ParamStr(1)) = '/INSTALL' then
begin
InstallService;
Halt;
end;

if Uppercase(ParamStr(1)) = '/REMOVE' then
begin
UnInstallService;
Halt;
end;
end;

// Setup service table which define all services in this process
with ServiceTableEntry[0] do
begin
lpServiceName := ServiceName;
lpServiceProc := @ServiceMain;
end;

// Last entry in the table must have nil values to designate the end of the table
with ServiceTableEntry[1] do
begin
lpServiceName := nil;
lpServiceProc := nil;
end;

if not StartServiceCtrlDispatcher(ServiceTableEntry[0]) then
begin
AddToMessageLog('StartServiceCtrlDispatcher Error!');
Halt;
end;
end.