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.