Delphi com сервер в сервисных проблемах - PullRequest
Новая
       44

Delphi com сервер в сервисных проблемах

2 голосов
/ 16 июня 2020

Несколько лет go Я размещал здесь вопрос о COM-серверах в службах без использования библиотеки SvCom для Delphi XE2. Тогда я пошел дальше и использовал SvCom, чтобы сэкономить время. Теперь я снова пытаюсь заставить этот макет работать без SvCom в 10.2.3 Tokyo.

Я создал минимальное служебное приложение и добавил к нему минимальный объект автоматизации COM с методом SendText, который вызывает клиентское событие. Сервис устанавливается, запускается и работает нормально. Затем я создал небольшое клиентское приложение, импортировал библиотеку типов и добавил обработчик событий. Но когда тестовое приложение пытается подключиться к серверу, я получаю ошибку Server Execution Failed. Я предполагаю, что что-то пропустил при регистрации, но масса документации от MS и других источников, которую я нашел, по меньшей мере неоднозначна. Я надеялся, что будет какой-то лаконичный do c, в котором перечислены определенные записи реестра c и т.д. c. для настройки, но я его не нашел.

Это моя регистрация и соответствующий код в службе. Может кто-нибудь сказать мне, что мне здесь не хватает? 


procedure TTestServiceObj.ServiceAfterInstall(Sender: TService);
var
  Key: String;
begin
  DbgLog('Processing AfterInstall');
  //have ComServer add all its entries
  ComServer.UpdateRegistry(True);

  with TRegistry.Create do try
    //in the HKCR hive...
    RootKey := HKEY_CLASSES_ROOT;
    //add our LocalService entry
    Key := '\APPID\'+GUIDToString(CLASS_BWSvcTest);
    if OpenKey(Key, True) then begin
      WriteString('', Self.DisplayName);
      WriteString('LocalService', Self.Name);
      WriteString('ServiceParameters', '');
      CloseKey;
    end;

    //in the HKLM hive...
    RootKey := HKEY_LOCAL_MACHINE;
    //add the Description value
    Key := '\SYSTEM\CurrentControlSet\Services\' + Self.Name;
    if OpenKey(Key, False) then try
      WriteString('Description', 'Test service for COM server');
    finally
      CloseKey;
    end;

    //add the values for the Windows Application EventLog handling
    Key := '\SYSTEM\CurrentControlSet\Services\EventLog\Application\' + Self.Name;
    if OpenKey(Key, True) then try
      WriteString('EventMessageFile', ParamStr(0));
      WriteInteger('TypesSupported', 7);
    finally
      CloseKey;
    end;
  finally
    Free;
  end;
end;

procedure TTestServiceObj.ServiceBeforeUninstall(Sender: TService);
var
  Key: String;
begin
  DbgLog('Processing BeforeUninstall');
  with TRegistry.Create do try
    //in the HKCR hive...
    RootKey := HKEY_CLASSES_ROOT;
    //delete the localservice-related stuff
    Key := '\APPID\'+GUIDToString(CLASS_BWSvcTest);
    if KeyExists(Key) then
      DeleteKey(Key);

    //in the HKLM hive...
    RootKey := HKEY_LOCAL_MACHINE;
    //remove the Description
    Key := '\SYSTEM\CurrentControlSet\Services\' + Self.Name;
    if KeyExists(Key) then
      DeleteKey(Key);
    //delete the key for the Application EventLog handling
    Key := '\SYSTEM\CurrentControlSet\Services\EventLog\Application\' + Self.Name;
    if KeyExists(Key) then
      DeleteKey(Key);
  finally
    Free;
  end;

  //have ComServer remove the other entries
  ComServer.UpdateRegistry(False);
end;

procedure TTestServiceObj.ServiceCreate(Sender: TObject);
begin
  CoInitialize(nil);
end;

procedure TTestServiceObj.ServiceDestroy(Sender: TObject);
begin
  Svr := nil;
  CoUninitialize;
end;

procedure TTestServiceObj.ServiceStart(Sender: TService; var Started: Boolean);
begin
  try
    DbgLog('Getting server instance');
    Svr := CreateComObject(CLASS_BWSvcTest) as IBWSvcTest;
    DbgLog(IFF(Assigned(Svr), 'Server connected', 'Server NOT connected'));
  except
    on E:Exception do begin
      Svr := nil;
      DbgLogFmt('%s initializing COM service: %s', [E.ClassName, E.Message]);
    end;
  end;
end;

procedure TTestServiceObj.ServiceExecute(Sender: TService);
var
  LastS,H,M,S,mS: Word;
begin
  DbgLog('Processing ServiceExecute');
  //init COM
  CoInitialize(nil);
  try
    try
      //get our starting time values
      DecodeTime(Now, H,M,LastS,mS);
      //loop until stopped
      while not Terminated do begin
        Sleep(50);
        Self.ServiceThread.ProcessRequests(False);
        if (not Terminated) then begin
          //once a second, have the server send the time to the client
          DecodeTime(Now, H,M,S,mS);
          if S <> LastS then begin
            LastS := S;
            if Assigned(Svr) then try
              Svr.SendText(FormatDateTime('hh:nn:ss', Now));
            except
              on E:Exception do
                DbgLogExcept(E, 'Sending text to client');
            end;
          end;
        end;
      end;
    except
    end;
  finally
    CoUninitialize;
  end;
end;

1 Ответ

3 голосов
/ 16 июня 2020

Оказывается, что в модуле ComObj есть процедура RegisterAsService(const ClassID, ServiceName: String);, которая устанавливает значение APPID {classID} \ LocalService и значение CLSID {classID} \ AppID - с этими двумя установленными ключами сервер может быть подключен.

Однако не существует соответствующей процедуры UnregisterAsService (), поэтому при удалении службы необходимо вручную удалить оба этих ключа в событии BeforeUninstall. 


procedure TTestServiceObj.ServiceAfterInstall(Sender: TService);
var
  Key: String;
begin
  DbgLog('Processing AfterInstall');
  //have ComServer add all its entries
  ComServer.UpdateRegistry(True);
  //add the two entries necessary for COM server in a service
  RegisterAsService(GUIDToString(CLASS_BWSvcTest), Self.Name);

  //add our other registry entries
  with TRegistry.Create do try
    //in the HKLM hive...
    RootKey := HKEY_LOCAL_MACHINE;
    //add the Description value
    Key := '\SYSTEM\CurrentControlSet\Services\' + Self.Name;
    if OpenKey(Key, False) then try
      WriteString('Description', 'Test service for COM server');
    finally
      CloseKey;
    end;

    //add the values for the Windows Application EventLog handling
    Key := '\SYSTEM\CurrentControlSet\Services\EventLog\Application\' + Self.Name;
    if OpenKey(Key, True) then try
      WriteString('EventMessageFile', ParamStr(0));
      WriteInteger('TypesSupported', 7);
    finally
      CloseKey;
    end;
  finally
    Free;
  end;
end;

procedure TTestServiceObj.ServiceBeforeUninstall(Sender: TService);
var
  Key: String;
begin
  DbgLog('Processing BeforeUninstall');
  with TRegistry.Create do try
    //in the HKCR hive...
    RootKey := HKEY_CLASSES_ROOT;
    //these are the two keys added by the ComObj.RegisterAsService call
    //above, but there's no matching UnregisterXxx procedure so these
    //must be removed manually here
    Key := '\APPID\'+GUIDToString(CLASS_BWSvcTest);
    if KeyExists(Key) then
      DeleteKey(Key);
    Key := '\CLSID\'+GUIDToString(CLASS_BWSvcTest);
    if KeyExists(Key) then
      DeleteKey(Key);

    //have ComServer remove the other entries
    ComServer.UpdateRegistry(False);

    //in the HKLM hive...
    RootKey := HKEY_LOCAL_MACHINE;
    //remove the Description
    Key := '\SYSTEM\CurrentControlSet\Services\' + Self.Name;
    if KeyExists(Key) then
      DeleteKey(Key);
    //delete the key for the Application EventLog handling
    Key := '\SYSTEM\CurrentControlSet\Services\EventLog\Application\' + Self.Name;
    if KeyExists(Key) then
      DeleteKey(Key);
  finally
    Free;
  end;
end;
...