VPF::ShellExecute из сервиса - Форум программистов

Cashey

Дата 21.7.2008, 16:34 (ссылка)

(нет голосов)

Загрузка ...

Бессмертный

Профиль
Группа: Завсегдатай
Сообщений: 3441
Регистрация: 13.11.2002
Где: в столице

Репутация: нет
Всего: 60

смысл примерно такой

Код


procedure TRunAgent.ServiceStart(Sender: TService; var Started: Boolean);
begin
  ThrTimer := TThreadTimer.Create(True);
  ThrTimer.FreeOnTerminate := True;
  try
    Started := True;
  except
    ThrTimer.Terminate;
    Started := False;
  end;
  ThrTimer.Resume;
end;

procedure TThreadTimer.Execute;
var
nExe : Cardinal;
begin
  while not Terminated do
  begin
  nExe := 0;
    try
      nExe := ShellExecute({ThrTimer.Handle}0,nil,'<путь к файлу>.exe',nil,nil,SW_RESTORE);
      Sleep(5000);
    except
 //   MessageBox(0, pchar('Ошибка запуска № '+inttostr(nExe)), 'Ошибка сервиса', MB_OK);
    end;
  end;
end;

но при запуске из менеджера сервисов генерится ошибка - Неизвестное программное исключение.
предпологаю, что не нравится хэндл для ShellExecute.
И паралельно вопрос, есть ли в Дельфи команда для запуска на исполнение внешнего файла, иная чем апишная ShellExecute?

--------------------

библия учит любить ближнего, а камасутра обучает как именно

Qu1nt

Дата 21.7.2008, 16:51 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 602
Регистрация: 13.1.2007

Репутация: 5
Всего: 50

WinExec, CreateProcess...

CodeMonkey

Дата 21.7.2008, 18:31 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Завсегдатай
Сообщений: 1839
Регистрация: 24.6.2008
Где: Россия, Тверь

Репутация: 16
Всего: 89

А чего вы хотите достичь такой странной конструкцией?

--------------------

Опытный программист на C++ легко решает любые не существующие в Паскале проблемы.

Virtuals

Дата 22.7.2008, 05:39 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 476
Регистрация: 27.11.2006

Репутация: 4
Всего: 11

Код


//------------------------------------------------------------------------------
function Start(const CmdLine: string; Visibility : integer;winsta,dsk:pchar): integer;
var
   zCmdLine:array[0..512] of char;
   zCurDir:array[0..255] of char;
   WorkDir:String;
   StartupInfo:TStartupInfo;
   ProcessInfo:TProcessInformation;
//   r: DWord;
begin
   StrPCopy(zCmdLine,CmdLine);
   GetDir(0,WorkDir);
   StrPCopy(zCurDir,WorkDir);
   FillChar(StartupInfo,Sizeof(StartupInfo),#0);
   StartupInfo.cb := Sizeof(StartupInfo);
   StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
   StartupInfo.wShowWindow := Visibility;
   StartupInfo.lpDesktop:=PChar(WinSta+'\'+dsk);
   StartupInfo.lpTitle:= PChar('SYSTEM');
   if not CreateProcess(
      nil,
      zCmdLine,                      { pointer to command line string }
      nil,                           { pointer to process security attributes}
      nil,                           { pointer to thread security attributes }
      false,                         { handle inheritance flag }
      {CREATE_NEW_CONSOLE or}          { creation flags }
      NORMAL_PRIORITY_CLASS,
      nil,                           { pointer to new environment block }
      nil,                           { pointer to current directory name }
      StartupInfo,                   { pointer to STARTUPINFO }
      ProcessInfo) then Result := -1 { pointer to PROCESS_INF }
   else
   begin

//исправленно по просьбе Riply, для будущих поколений  :crazy 
      CloseHandle(ProcessInfo.hThread);
      CloseHandle(ProcessInfo.hProcess);
      Result := 0;

{      CloseHandle(ProcessInfo.hThread);
      WaitforSingleObject(ProcessInfo.hProcess,INFINITE);
      CloseHandle(ProcessInfo.hProcess);
      GetExitCodeProcess(ProcessInfo.hProcess,r);}
//      Result := ProcessInfo.hProcess;
   end;
end;
//------------------------
procedure CreateX;
begin
 Start(cMmd, SW_SHOWNORMAL,CreateProcDEFWINSTATION,CreateProcDEFDESKTOP);
end;

//================
function MainServiceThread(p:Pointer):DWORD;stdcall;
begin
SleepEx(500,ServiceStatus.dwCurrentState = SERVICE_STOPPED);
CreateX;
repeat
SleepEx(100,ServiceStatus.dwCurrentState = SERVICE_STOPPED);
until ServiceStatus.dwCurrentState = SERVICE_STOPPED;
result:=0;
ExitThread(0);
end;

//================
procedure ServiceCtrlHandler(Opcode : Cardinal);stdcall;
//var
// Status : Cardinal;
begin
 case Opcode of
  SERVICE_CONTROL_PAUSE    :
   begin
    ServiceStatus.dwCurrentState := SERVICE_PAUSED;
    SuspendThread(hThread); // приостанавливаем поток
   end;
  SERVICE_CONTROL_CONTINUE :
   begin
    ServiceStatus.dwCurrentState := SERVICE_RUNNING;
    ResumeThread(hThread); // возобновляем поток
   end;
  SERVICE_CONTROL_STOP     :
   begin
    ServiceStatus.dwWin32ExitCode:=0;
    ServiceStatus.dwCurrentState := SERVICE_STOPPED;
    ServiceStatus.dwCheckPoint   :=0;
    ServiceStatus.dwWaitHint     :=0;

    if not SetServiceStatus (ServiceStatusHandle,ServiceStatus)
     then begin
   ERRLog('*'+SysErrorMessage(GetLastError));
      Exit;
     end;
     exit;
   end;

  SERVICE_CONTROL_INTERROGATE : ;
 end;

 if not SetServiceStatus (ServiceStatusHandle, ServiceStatus)
  then begin
   ERRLog('*'+SysErrorMessage(GetLastError));
   Exit;
  end;
end;
//================
procedure ServiceProc(argc : DWORD;var argv : array of PChar);stdcall;

begin
  ServiceStatus.dwServiceType      := SERVICE_WIN32;
  ServiceStatus.dwCurrentState     := SERVICE_START_PENDING;
  ServiceStatus.dwControlsAccepted := SERVICE_ACCEPT_STOP
    or SERVICE_ACCEPT_PAUSE_CONTINUE;
  ServiceStatus.dwWin32ExitCode           := 0;
  ServiceStatus.dwServiceSpecificExitCode := 0;
  ServiceStatus.dwCheckPoint              := 0;
  ServiceStatus.dwWaitHint                := 0;

  ServiceStatusHandle := 
           RegisterServiceCtrlHandler(ServiceName,@ServiceCtrlHandler);
  if ServiceStatusHandle = 0 then WriteLn('RegisterServiceCtrlHandler Error');

   ServiceStatus.dwCurrentState :=SERVICE_RUNNING;
   ServiceStatus.dwCheckPoint   :=0;
   ServiceStatus.dwWaitHint     :=0;

   if not SetServiceStatus (ServiceStatusHandle,ServiceStatus)
    then begin
   ERRLog('*'+SysErrorMessage(GetLastError));
     exit;
    end;

hThread:=CreateThread(nil,0,@MainServiceThread,nil,0,ThID);

WaitForSingleObject(hThread,INFINITE);
//закрывая после этого его дескриптор
CloseHandle(hThread);

end;
var NDR:string;
begin
NDR:='0mliackiserv';
if ParamCount=1 then
if pos('INSTAL',UpperCase(ParamStr(1)) )>0 then
 begin
 if not Installdrv(NDR, '"'+ParamStr(0)+'"',SERVICE_WIN32_OWN_PROCESS
                                            or SERVICE_INTERACTIVE_PROCESS,SERVICE_AUTO_START)
 then ERRLog('*'+SysErrorMessage(GetLastError));
 end else
if pos('START',UpperCase(ParamStr(1)) )>0 then
 begin
 if not Startdrv(NDR)
 then ERRLog('*'+SysErrorMessage(GetLastError));
 end else
if pos('STOP',UpperCase(ParamStr(1)) )>0 then
 begin
if not Stopdrv(NDR)
 then ERRLog('*'+SysErrorMessage(GetLastError));
 end else
if pos('DELETE',UpperCase(ParamStr(1)) )>0 then
 begin
if not DeInstalldrv(NDR)
 then ERRLog('*'+SysErrorMessage(GetLastError));
 end else
 begin
 DispatchTable[0].lpServiceName:=ServiceName;
 DispatchTable[0].lpServiceProc:=@ServiceProc;
 DispatchTable[1].lpServiceName:=nil;
 DispatchTable[1].lpServiceProc:=nil;
 if not StartServiceCtrlDispatcher(DispatchTable[0])
  then ERRLog('StartServiceCtrlDispatcher Error');
 end else
  begin
 DispatchTable[0].lpServiceName:=ServiceName;
 DispatchTable[0].lpServiceProc:=@ServiceProc;
 DispatchTable[1].lpServiceName:=nil;
 DispatchTable[1].lpServiceProc:=nil;
 if not StartServiceCtrlDispatcher(DispatchTable[0])
  then ERRLog('StartServiceCtrlDispatcher Error');
 end;
end.

ну вот так работать будет, почему так? ... ну что вспомню:
а. важно:
SleepEx(500,ServiceStatus.dwCurrentState = SERVICE_STOPPED);
CreateX;

Это сообщение отредактировал(а) Virtuals - 22.7.2008, 12:27

Riply

Дата 22.7.2008, 09:48 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Комодератор
Сообщений: 572
Регистрация: 27.3.2007
Где: St. Petersburg

Репутация: 21
Всего: 32

Цитата(Virtuals @ 22.7.2008, 05:39

)

ну вот так работать будет

Я бы воздержалась от столь сомнительного утверждения smile

P.S.
Начала смотреть код, и как только увидела, что процедура CreateX исключает всякую возможность
закрыть после нее открытые Handl`ы, поняла, что дальше можно не смотреть,
ибо будущий баг профессионально заложен в первых же строчках. smile

P.P.S.
А потом еще спрашивают: "как такое модет быть ? Мой сервис стабильно работает,
но через (час, день, неделю падает). Ошибок в нем нет, ведь первый час работает !"

--------------------

Решение задач под заказ

Virtuals

Дата 22.7.2008, 10:27 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 476
Регистрация: 27.11.2006

Репутация: 4
Всего: 11

Riply,
это не сомнительное утверждение, а кусок кода из рабочего проекта

smile

а мне и ненужно было стабильной работы сервиса, в данном примере реализованно только запустить процесс с правами систем smile

и открытые Handl`ы мне побарабану были, этож только пример а не готовое прилизанное решение, и в нем хорошо просматриваются многие грабли, на которые нестоит наступать.
ну для примера вот про это многие забывают, почемуто...

Код


CreateProcDEFWINSTATION = 'WinSta0';
CreateProcDEFDESKTOP    = 'winlogon';


StartupInfo.lpDesktop:=PChar(WinSta+'\'+dsk);

а при старте из сервиса, это ой как важно

ЗЫ хотя если честно сервис стабилен и невылетает., имхо у мну принцип - отлаживаю куски в маненьких демках и только после этого переписываю все в проект. smile

Это сообщение отредактировал(а) Virtuals - 22.7.2008, 10:33

Riply

Дата 22.7.2008, 10:43 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Комодератор
Сообщений: 572
Регистрация: 27.3.2007
Где: St. Petersburg

Репутация: 21
Всего: 32

Цитата(Virtuals @ 22.7.2008, 10:27

)

а мне и ненужно было стабильной работы сервиса, в данном примере реализованно только запустить процесс с правами систем
и открытые Handl`ы мне побарабану были, этож только пример а не готовое прилизанное решение

Но надо учитывать, что выложенный тобой пример, кто-то будет использовать при помощи тупого копи/пайста,
поэтому , тогда уж предупреждай: "ребята, мне было лень заниматься уборкой, сделайте это сами".

И еще:
Мне совершенно непонятно почему все боятся утечки памяти (ловят ее, тратят на это силы),
и в то же время наплевательски относятся к утечке Handl`ов ?
Она не менее страшна чем утечка памяти, а может даже и более.
Просто для получения эффекта от нее должно пройти больше "итераций",
а память может "переполнится" довольно быстро, если большими кусками smile

--------------------

Решение задач под заказ

Virtuals

Дата 22.7.2008, 11:53 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 476
Регистрация: 27.11.2006

Репутация: 4
Всего: 11

Riply,
так лучше? smile

Код


...
   else
   begin
      CloseHandle(ProcessInfo.hThread);
      CloseHandle(ProcessInfo.hProcess);
      Result := 0;
   end;
...

Riply

Дата 22.7.2008, 12:06 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Комодератор
Сообщений: 572
Регистрация: 27.3.2007
Где: St. Petersburg

Репутация: 21
Всего: 32

Цитата(Virtuals @ 22.7.2008, 11:53

)

так лучше?

Угу. Только пусть функция возвращает Boolean (что и получила от CreateProcess), меньше путаницы будет smile

--------------------

Решение задач под заказ

Virtuals

Дата 22.7.2008, 12:29 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 476
Регистрация: 27.11.2006

Репутация: 4
Всего: 11

Riply, фиг мне так больше нравится smile

кстати дополнил примерчик ради полноты картины

Cashey

Дата 22.7.2008, 15:00 (ссылка)

(нет голосов)

Загрузка ...

Бессмертный

Профиль
Группа: Завсегдатай
Сообщений: 3441
Регистрация: 13.11.2002
Где: в столице

Репутация: нет
Всего: 60

Цитата(Riply @ 22.7.2008, 11:43

)

Но надо учитывать, что выложенный тобой пример, кто-то будет использовать при помощи тупого копи/пайста,

я лично всегда разбираю код, а не использую тупое капи\паст smile

Virtuals, не поверишь, но по факту не работает smile

я так понял ты создавал сервис вручную, я же использую TService.

возможно, не отрабатывается Start, а возможно NOD блочит запуск файла из сервиса. самое противное, что не удается службу отрейсить....

--------------------

библия учит любить ближнего, а камасутра обучает как именно

Virtuals

Дата 22.7.2008, 15:13 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 476
Регистрация: 27.11.2006

Репутация: 4
Всего: 11

Cashey, а файл точно не запускается? может бонально пути неправильные?
и как это не получается отрейсить? ну понятно что дебуг здесь не в помощь но посмотри внимательно мой пример, и вот те недостающая но нужная часть
smile

Код


function SysErrorMessage(ErrorCode: Integer): string;
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);
end;
function FileIsThere(FileName: string): Boolean;
{ Boolean function that returns True if the file exists; otherwise,
  it returns False. Closes the file if it exists. }
 var
  F: file;
begin
  {$I-}
  AssignFile(F, FileName);
  FileMode := 0;  {Set file access to read only }
  Reset(F);
  CloseFile(F);
  {$I+}
  FileIsThere := (IOResult = 0) and (FileName <> '');
end;  { FileIsThere }

 procedure ERRLog(S:String);
  Var Ft:TextFile;
  begin
    AssignFile(Ft,'c:\LogSSR.log');
if FileIsThere('c:\LogSSR.log')
  then Append(Ft)
  else ReWrite(Ft);
  Writeln(Ft,S);
  close(Ft);
 end;
//==================

ЗЫ если нужно могу весь код скинуть позже...

Cashey

Дата 22.7.2008, 15:59 (ссылка)

(нет голосов)

Загрузка ...

Бессмертный

Профиль
Группа: Завсегдатай
Сообщений: 3441
Регистрация: 13.11.2002
Где: в столице

Репутация: нет
Всего: 60

Цитата(Virtuals @ 22.7.2008, 16:13

)

Cashey, а файл точно не запускается? может бонально пути неправильные?

пытаюсь разобратся
про файловый трейсинг я с самого начало подумал, но тогда служба отказывается запускатся. Пишет не получен вовремя отзыв

--------------------

библия учит любить ближнего, а камасутра обучает как именно

Riply

Дата 22.7.2008, 16:12 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Комодератор
Сообщений: 572
Регистрация: 27.3.2007
Где: St. Petersburg

Репутация: 21
Всего: 32

Цитата(Cashey @ 22.7.2008, 15:00

)

я лично всегда разбираю код, а не использую тупое капи\паст

Cashey, а я тебя и не имела ввиду, ветка то открыта для всех. Мало ли кто сюда забредет smile

--------------------

Решение задач под заказ

CodeMonkey

Дата 22.7.2008, 16:21 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Завсегдатай
Сообщений: 1839
Регистрация: 24.6.2008
Где: Россия, Тверь

Репутация: 16
Всего: 89

Цитата(Virtuals @ 22.7.2008, 15:13

)

ну понятно что дебуг здесь не в помощь

Да ладно.
Компилируем службу с включенной отладочной информацией, включая инфу TD32. Устанавливаем Output Directory в свойствах проекта в ту папку, где у вас лежит установленная служба (C:\Windows\System32?). Отбилдили, службу запустили. Далее в меню Delphi: Run/Attach to Process. Всё. Ставим на паузу, расставляем бряки, потом возобновляем процесс и отлаживаемся.
Вроде ничего не забыл.

Cashey, может быть вы прокомментируете, что вы хотите добиться? Просто запустить процесс из службы? Запустить процесс из службы для какого-то пользователя? Запустить процесс из службы для интерактивного пользователя? Может быть уведомить пользователя о каком-то событии (у меня вызвал подозрение флаг SW_RESTORE)? Что из этого? Или ещё что-то?
Какая у вас служба? Интерактивная или нет? Под XP или под Vista? Дайте же информацию.

Если это не является слишком уж большим секретом, то расскажите про свою задачу. Возможно, в этом случае Вы получите более толковый ответ. А то белиберда может получиться. Грубо говоря, если играешь в рулетку, то иметь 36 различных рекомендаций по тому, на какой номер ставить, -- это все равно, что не иметь ни одной © Geo.

--------------------

Опытный программист на C++ легко решает любые не существующие в Паскале проблемы.

0 Пользователей читают эту тему (0 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема \| Delphi: WinAPI и системное программирование \| Следующая тема »