Delphi small windows NT Service program source code

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 waits es 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

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 );
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) = '/delete' 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.