program SimpleServ;{$APPTYPE CONSOLE}uses Windows, WinSVC; //Не используем SysUtils и прочий хлам - размер екзешника у нас будет всего ~25 килобайт Function IsWin2KorHigher: BOOL; Var aVer: OSVERSIONINFO; Begin ZeroMemory(@aVer, SizeOf(aVer)); aVer.dwOSVersionInfoSize := SizeOf(aVer); GetVersionEx(aVer); Result := (aVer.dwPlatformId = VER_PLATFORM_WIN32_NT) And (aVer.dwMajorVersion >= 5); End;Const ServicesCount = 1; ServiceName = 'SimpleServ'; DisplayName = 'Simple Service'; ServiceType = SERVICE_WIN32_OWN_PROCESS; ServiceDescription = 'SimpleServ from Handlex ;-))) This simple program will help you to understand WinNT Services. Mail to alex_wh@mail.ru.';Var ServThrHndl: THandle = 0; StopEvent: THandle = 0; aServHndl: DWord = 0; aServStatus: SERVICE_STATUS; Function IntToStr(Value: Integer): String; //Included because we don't use SysUtils Var aSign: Bool; Begin Result := ''; aSign := Value >= 0; If Not aSign Then Value := -Value; Repeat Result := Char(Value - (Value Div 10) * 10 + Byte('0')) + Result; Value := Value Div 10; Until Value = 0; If Not aSign Then Result := '-' + Result; End; // Helper function for windows error strings function SysErrorMessage(ErrorCode: Integer): string; //Included because we don't use SysUtils var Len: Integer; Buffer: array[0..255] of Char; begin Len := FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_ARGUMENT_ARRAY, nil, ErrorCode, 0, Buffer, SizeOf(Buffer), nil); while (Len > 0) and (Buffer[Len - 1] in [#0..#32]) do Dec(Len); SetString(Result, Buffer, Len); UniqueString(Result); ANSItoOEM(PChar(Result), PChar(Result)); If Result <> '' Then Result := '(' + IntToStr(ErrorCode) + ') ' + Result; end; Procedure ShowInfo; Begin WriteLn; WriteLn(' -=* SIMPLE TRAINING SERVICE BY HandleX *=-'); End; Procedure ProcessStartupParams; //Реакция на install, uninstall Function SetServiceDescription(aSHndl: THandle; aDesc: String): Bool; //Устанавливает "описание" для службы, Win2k и выше Const SERVICE_CONFIG_DESCRIPTION: DWord = 1; Var DynChangeServiceConfig2: Function( hService: SC_HANDLE; // handle to service dwInfoLevel: DWORD; // information level lpInfo: Pointer): Bool; StdCall; // new data aLibHndl: THandle; TempP: PChar; Begin aLibHndl := GetModuleHandle(advapi32); Result := aLibHndl <> 0; If Not Result Then Exit; DynChangeServiceConfig2 := GetProcAddress(aLibHndl, 'ChangeServiceConfig2A'); Result := @DynChangeServiceConfig2 <> Nil; If Not Result Then Exit; TempP := PChar(aDesc); //ChangeServiceConfig2 хочет вместо строки указатель на указатель ;-) Result := DynChangeServiceConfig2(aSHndl, SERVICE_CONFIG_DESCRIPTION, @TempP); End; Type TToDo = (tdError, tdInstall, tdUninstall); TToDo_s = Set of TToDo; Const ParamStrings: Array[tdInstall..tdUninstall] of String = ('install', 'uninstall'); Function MapParam(aParam: String): TToDo; //Узнаёт из параметра о вашем желании ;-) Var J: TToDo; TempStr: String; Begin Result := tdError; TempStr := aParam; If TempStr[1] In ['/', '-'] Then TempStr := Copy(TempStr, 2, Length(TempStr) - 1); UniqueString(TempStr); CharLower(PChar(TempStr)); For J := Low(ParamStrings) to High(ParamStrings) Do If ParamStrings[J] = TempStr Then Begin Result := J; Exit; End; End; Var J: Integer; scHndl, sHndl: THandle; aStatus: TServiceStatus; toDo: TTodo_s; Begin toDo := []; For J := 1 to ParamCount Do Begin Include(ToDo, MapParam(ParamStr(J))); If tdError in toDo Then Begin ExitCode := ERROR_INVALID_PARAMETER; WriteLn('Unknown parameter - ' + ParamStr(J) + '. RTFM, please...'); Exit; End; End; If [tdInstall, tdUninstall] <= toDo Then Begin ExitCode := ERROR_INVALID_PARAMETER; WriteLn('Error: you can not install and uninstall service simultaniosly. Check params.'); Exit; End; If tdInstall in toDo Then //Устанавливаем сервис Begin Write('Connecting Service Control Manager...'); scHndl := OpenSCManager(Nil, Nil, SC_MANAGER_CREATE_SERVICE); If scHndl = 0 Then Begin ExitCode := GetLastError; WriteLn('Failed!'); WriteLn('Error: ', SysErrorMessage(ExitCode)); Exit; End; Try WriteLn('Ok'); Write('Creating service database record...'); sHndl := CreateService( SCHndl, ServiceName, DisplayName, SERVICE_QUERY_CONFIG Or SERVICE_CHANGE_CONFIG, ServiceType, SERVICE_DEMAND_START, SERVICE_ERROR_NORMAL, PChar(ParamStr(0)), Nil, Nil, Nil, Nil, Nil); If sHndl = 0 Then Begin ExitCode := GetLastError; WriteLn('Failed!'); WriteLn('Error: ', SysErrorMessage(ExitCode)); Exit; End; Try WriteLn('Ok'); If ServiceDescription <> '' Then Begin Write('Setting service description...'); If Not SetServiceDescription(sHndl, ServiceDescription) Then Begin WriteLn('Failed!'); WriteLn('Warning: ', SysErrorMessage(GetLastError)); WriteLn('Warning: SetServiceDesc() failed, but service is installed!'); End; WriteLn('Ok'); End; Finally CloseServiceHandle(sHndl); End; Finally CloseServiceHandle(SCHndl); End; WriteLn('Service "', DisplayName, '" install success.'); End; If tdUninstall in toDo Then //Удаляем сервис... Begin Write('Connecting Service Control Manager...'); scHndl := OpenSCManager(Nil, Nil, GENERIC_EXECUTE); If scHndl = 0 Then Begin ExitCode := GetLastError; WriteLn('Failed!'); WriteLn('Error: ', SysErrorMessage(ExitCode)); Exit; End; Try WriteLn('Ok'); Write('Opening and Quering Service...'); sHndl := OpenService(SCHndl, ServiceName, STANDARD_RIGHTS_REQUIRED Or SERVICE_QUERY_STATUS Or SERVICE_STOP); If sHndl = 0 Then Begin ExitCode := GetLastError; WriteLn('Failed!'); WriteLn('Error: ', SysErrorMessage(ExitCode)); Exit; End; Try If Not QueryServiceStatus(sHndl, aStatus) Then Begin ExitCode := GetLastError; WriteLn('Failed!'); WriteLn('Error: ', SysErrorMessage(ExitCode)); Exit; End; WriteLn('Ok'); If aStatus.dwCurrentState <> SERVICE_STOPPED Then Begin Write('Service is running, wait until stopped...'); If Not ControlService(sHndl, SERVICE_CONTROL_STOP, aStatus) Then Begin ExitCode := GetLastError; WriteLn('Failed!'); WriteLn('Error: ', SysErrorMessage(ExitCode)); Exit; End; While aStatus.dwCurrentState <> SERVICE_STOPPED Do Begin Sleep(250); Write('.'); If Not QueryServiceStatus(sHndl, aStatus) Then Begin ExitCode := GetLastError; WriteLn('Failed!'); WriteLn('Error: ', SysErrorMessage(ExitCode)); Exit; End; End; WriteLn('Stopped'); End; Write('Deleting Service...'); If Not DeleteService(sHndl) Then Begin ExitCode := GetLastError; WriteLn('Failed!'); WriteLn('Error: ', SysErrorMessage(ExitCode)); Exit; End; WriteLn('Ok'); Finally CloseServiceHandle(sHndl); End; Finally CloseServiceHandle(SCHndl); End; WriteLn('Service uninstall success.'); End; End; Function SetState(aState: DWORD): DWORD; Begin aServStatus.dwCurrentState := aState; If aServHndl <> 0 Then SetServiceStatus(aServHndl, aServStatus); Result := aServStatus.dwCurrentState; End; Procedure ServiceHandler(fdwControl: DWORD); StdCall; Begin Case fdwControl Of SERVICE_CONTROL_STOP: Begin //Requests the service to stop. SetState(SERVICE_STOP_PENDING); SetEvent(StopEvent); ResumeThread(ServThrHndl); //Если сервис был в паузе, то рабочий поток надо возобновить End; SERVICE_CONTROL_PAUSE: Begin //Requests the service to pause. SetState(SERVICE_PAUSE_PENDING); SuspendThread(ServThrHndl); //Останавливаем рабочий поток сервиса SetState(SERVICE_PAUSED); End; SERVICE_CONTROL_CONTINUE: Begin //Requests the paused service to resume. SetState(SERVICE_CONTINUE_PENDING); ResumeThread(ServThrHndl); //Восстанавливаем рабочий поток сервиса SetState(SERVICE_RUNNING); End; SERVICE_CONTROL_INTERROGATE: Begin //Requests the service to update immediately its current status information to the service control manager. SetState(aServStatus.dwCurrentState); //Говорим SCM о том, в каком состоянии находится наша служба End; 128..255: Begin //The service defines the action associated with the control code. SuspendThread(ServThrHndl); //Протяжно пищим в спикер, потому что кто-то послал USER DEFINED CONTROL CODE ;-) Windows.Beep(1000, 500); ResumeThread(ServThrHndl); End; End; End; Procedure MainServiceProc( // Каждая служба может иметь параметры своего запуска. У нас не используется ;-) dwArgc: DWORD; // number of arguments lpszArgv: Pointer); StdCall // array of arguments Begin aServHndl := RegisterServiceCtrlHandler(ServiceName, @ServiceHandler); If aServHndl = 0 Then Begin ExitCode := GetLastError; Exit; //Какая-то ошибка, срочно выходим, SCM будет ругаться, но сообщить мы ему ничего не можем... End; ZeroMemory(@aServStatus, SizeOf(aServStatus)); aServStatus.dwServiceType := ServiceType; aServStatus.dwControlsAccepted := SERVICE_ACCEPT_STOP Or SERVICE_ACCEPT_PAUSE_CONTINUE; //aServStatus.dwWaitHint := 500; //Здесь может быть подсказка для небыстрых служб о том, как долго она реагирует на команды SetState(SERVICE_START_PENDING); //Извещаем SCM, что мы начали стартовать именно этот сервис... // Тут идёт рутина инициализации... If Not DuplicateHandle(GetCurrentProcess, GetCurrentThread, GetCurrentProcess, @ServThrHndl, 0, FALSE, DUPLICATE_SAME_ACCESS) Then Begin //Нам нужен реальный дескриптор потока службы, делаем его... aServStatus.dwWin32ExitCode := GetLastError; SetState(SERVICE_STOPPED); Exit; End; //Нам нужен unnamed event для реагирования на останов из ControlHandler... StopEvent := CreateEvent(Nil, True, False, Nil); If StopEvent = 0 Then //Какая-то ошибка - срочно останавливаемся и выходим... Begin aServStatus.dwWin32ExitCode := GetLastError; SetState(SERVICE_STOPPED); Exit; End; // Инит прошёл, пошла работа сервиса... SetState(SERVICE_RUNNING); //Момент истины - извещаем SCM что мы работаем!!! While WaitForSingleObject(StopEvent, 500) = WAIT_TIMEOUT Do Windows.Beep(10000, 10); //Крутим цикл, бипаем по таймауту, иначе выходим... // Выполняем остановку сервиса - вычищаемся и выходим... CloseHandle(ServThrHndl); ServThrHndl := 0; CloseHandle(StopEvent); StopEvent := 0; SetState(SERVICE_STOPPED); // Работа сервиса закончена... End;Var ServTableEntryArray: Array[0..ServicesCount] Of TServiceTableEntryA;begin{$R *.res} //Старт программы... If ParamCount > 0 Then //От нас что-то хотят... Begin ShowInfo; ProcessStartupParams; //Выясняем что и выходим... Exit; End; //Готовимся к вызову StartServiceCtrlDispatcher ZeroMemory(@ServTableEntryArray, SizeOf(ServTableEntryArray)); ServTableEntryArray[0].lpServiceName := ServiceName; ServTableEntryArray[0].lpServiceProc := @MainServiceProc; If Not StartServiceCtrlDispatcher(ServTableEntryArray[0]) Then Begin ExitCode := GetLastError; ShowInfo; //Какой-то косяк, поэтому выводим в консоль сообщение и выходим... WriteLn('Error: ', SysErrorMessage(ExitCode)); WriteLn('This program is Windows NT Service, so it CAN NOT be run from command prompt.'); WriteLn('You can install it with "/install" parameter.'); Exit; End; // Все сервисы завершили свою работу, выходим...end.
