[dim302004]

Всем добрый день! Нужна помощь в устранении ошибки . Имеется исходник старой скада системы написанной на Delphi под х32.
Система клиент-сервер. После установки клиентской программы на вин 10 х64 начались проблемы. а именно при отправке запроса на сервер виснет наглухо. Анализ ошибок вин 10 выявил зависание named pipes. Клиентская программа компилирует скрипты на языке Tcl и отправляет и получает данные с сервера linux. Вот кусок кода с Pipes. Может что подправить для работы с вин 10?

Код:

procedure ThreadLoop;
  var
    WiteObj: Cardinal;
  begin
    // Создаем сокет-клиент
    fSocketClnt := TWSocket.Create(nil);
    with fSocketClnt do begin
      MultiThreaded   := False;
      OnBgException   := SocketClntBgException;
      OnError         := SocketClntError;
    end;
    // Создаем сокет-сервер
    fSocketSrv := TWSocket.Create(nil);
    with fSocketSrv do begin
      Proto := 'tcp';
      Port := '0';
      Addr := '127.0.0.1';
      LineMode := False;
      LineEnd := #0;
      MultiThreaded := False;
      OnSessionAvailable := SocketSrvSessionAvailable;
      OnBgException := SocketSrvBgException;
      OnError := SocketSrvError;
      Listen;
    end;
    fServerPort := GetAssignedPortBySocket_ntohs(fSocketSrv);
    SendLog(petInfo, [], 0, Format(LOG_SRVSTART, [ThreadID, fSocketSrv.Proto, fSocketSrv.Addr, GetAssignedPortBySocket_htons(fSocketSrv),
      fServerPort]));
    fReconnecting := False;
    // Стартуем скриптер и зацикливаем сервер
    if Start and not (fSIState in [sisStoping, sisTerminating]) then begin
      SendLog(petInfo, [], 0, 'Запуск скриптового движка...');
      FPipeHandle := CreateNamedPipe(
        PWideChar('\\.\pipe\pipe_server_' + IntToStr(fProcessInfo.dwProcessId)),
        PIPE_ACCESS_DUPLEX or FILE_FLAG_OVERLAPPED,
        PIPE_TYPE_MESSAGE or PIPE_READMODE_MESSAGE or PIPE_WAIT,
        PIPE_UNLIMITED_INSTANCES,
        SizeOf(Integer),
        SizeOf(Integer),
        NMPWAIT_USE_DEFAULT_WAIT,
        nil
      );
      if FPipeHandle <> INVALID_HANDLE_VALUE then
      begin
        FPipeDataEvent := TEvent.Create(nil, False, False, '');
        RegisterWaitForSingleObject(WiteObj, FPipeDataEvent.Handle, WaitCallback, Self, INFINITE, WT_EXECUTEDEFAULT);
        FillMemory(@FOPData, SizeOf(TOverlapped), 0);
        FOPData.hEvent := FPipeDataEvent.Handle;
        ConnectNamedPipe(FPipeHandle, @FOPData);
        fSocketSrv.MessageLoop;
        UnregisterWait(WiteObj);
        CloseHandle(FPipeHandle);
        FreeAndNil(FPipeDataEvent);
      end;
    end;
    // Отключаем и уничтожаем клиента
    fSocketClnt.Abort;
    FreeAndNil(fSocketClnt);
    // Отключаем и уничтожаем сервер
    fSocketSrv.Abort;
    FreeAndNil(fSocketSrv);
    if fReconnecting then ThreadLoop;
  end;
 
begin
  for i := 0 to High(fSoundAlarmList) do
  begin
    fSoundAlarmList[i] := TSountAlarmListItem.Create;
    with fSoundAlarmList[i] do
    begin
      DevStr := 'alarm_' + IntToStr(i) + '_' + IntToStr(Integer(Pointer(Self)));
      DevID := 0;
      IsPlay := False;
    end;
  end;
  fThreadMsgWindow := CreateWindowEx(0, 'Message', PChar('MsgWindow_' + IntToStr(Integer(Pointer(Self)))), 0, 0, 0, 1, 1, HWND_MESSAGE, 0, 0, nil);
  fThreadMsgWindowProc:= Classes.MakeObjectInstance(ThreadWndProc);
  SetWindowLong(fThreadMsgWindow, GWL_WNDPROC, LongInt(fThreadMsgWindowProc));
  fDTEStream := TXDRStream.Create;
 
  ThreadLoop;
 
  fDTEStream.Clear;
  FreeAndNil(fDTEStream);
  for i := 0 to High(fSoundAlarmList) do
  begin
    DoSoundAlarm('', False, 0, i);
    fSoundAlarmList[i].Free;
  end;
  DestroyWindow(fThreadMsgWindow);
  Classes.FreeObjectInstance(fThreadMsgWindowProc);
  SendLog(petInfo, [], 0, SCR_STOP);
  ReturnValue := 0;
end;
dim302004 вне форума Обратить внимание администрации на это сообщение	0