修复Delphi线程中TIdHTTP访问违规及线程安全问题问询

安全阿岳

2026-8-3

线程终止后TIdHTTP持续执行导致访问违规的解决方案

问题描述

线程终止后，TIdHTTP仍继续执行阻塞的Get请求（带30秒超时的长轮询），无法及时响应Terminated标记，最终引发访问违规（Access violation）错误。已尝试标记退出循环、手动断开组件等方法，均未解决问题，需调整代码实现线程安全并修复异常。

现有代码片段

线程构造函数与析构函数

constructor TTelegramListener.Create(Asyspended: Boolean);
begin
  FFlag := False;
  FreeOnTerminate := True;
  inherited Create(Asyspended);
end;

destructor TTelegramListener.Destroy;
begin
  FCallback := nil;
  inherited;
end;

线程调用与创建逻辑

procedure TTeleBot.StartListenMessages(CallProc: TCallbackProc);
begin
  if Assigned(FMessageListener) then
    FMessageListener.DoTerminate;
  FMessageListener := TTelegramListener.Create(False);
  FMessageListener.Priority := tpLowest;
  FMessageListener.FreeOnTerminate := True;
  FMessageListener.Callback :=  CallProc;
  FMessageListener.TelegramToken := FTelegramToken;
end;

线程终止代码

if Assigned(FMessageListener) then
  FMessageListener.Terminate;

线程执行逻辑

procedure TTelegramListener.Execute;
var
  LidHTTP: TIdHTTP;
  LSSLSocketHandler: TIdSSLIOHandlerSocketOpenSSL;
  Offset, PrevOffset: Integer;
  LJSONParser: TJSONObject;
  LResronseList: TStringList;
  LArrJSON: TJSONArray;
begin
  Offset := 0;
  PrevOffset := 0;
  //create a local indy http component
  try
    LidHTTP := TIdHTTP.Create;
    LidHTTP.HTTPOptions := LidHTTP.HTTPOptions + [hoNoProtocolErrorException];
    LidHTTP.Request.BasicAuthentication := False;
    LidHTTP.Request.CharSet := 'utf-8';
    LidHTTP.Request.UserAgent := 'Mozilla/5.0 (Windows NT 6.1; WOW64; rv:12.0) Gecko/20100101 Firefox/12.0';

    LSSLSocketHandler := TIdSSLIOHandlerSocketOpenSSL.Create(LidHTTP);
    LSSLSocketHandler.SSLOptions.Method := sslvTLSv1_2;
    LSSLSocketHandler.SSLOptions.SSLVersions := [sslvTLSv1_2];
    LSSLSocketHandler.SSLOptions.Mode := sslmUnassigned;
    LSSLSocketHandler.SSLOptions.VerifyMode := [];
    LSSLSocketHandler.SSLOptions.VerifyDepth := 0;

    LidHTTP.IOHandler := LSSLSocketHandler;

    LJSONParser := TJSONObject.Create;
    LResronseList := TStringList.Create;
  except
   on E: Exception do
   begin
    FLastError := 'Error of create objects';
    FreeAndNil(LidHTTP);
    FreeAndNil(LJSONParser);
    FreeAndNil(LResronseList);
   end;
  end;
  try
    while not Terminated do
    begin

      LJSONParser := TJSONObject.Create;
      if Assigned(LidHTTP) then
      begin
        FResponse := LidHTTP.Get(cBaseUrl + FTelegramToken + '/getUpdates?offset=' + IntToStr(Offset) + '&amp;timeout=30');
        if FResponse.Trim = '' then
          Continue;
        LArrJSON := ((TJSONObject.ParseJSONValue(FResponse) as TJSONObject).GetValue('result') as TJSONArray);

        if lArrJSON.Count <= 0 then Continue;

        LResronseList.Clear;
        for var I := 0 to LArrJSON.Count - 1 do
          LResronseList.Add(LArrJSON.Items[I].ToJSON);

        Offset := LResronseList.Count;
        if Offset > PrevOffset then
        begin
          LJSONParser := TJSONObject.ParseJSONValue(LResronseList[LResronseList.Count - 1], False, True) as TJSONObject;
          if (LJSONParser.FindValue('message.text') <> nil) and (LJSONParser.FindValue('message.text').Value.Trim <> '') then
          begin
            if LJSONParser.FindValue('message.from.id') <> nil then
              FUserID := LJSONParser.FindValue('message.from.id').Value; //Его ИД по которому можем ему написать

            if LJSONParser.FindValue('message.from.first_name') <> nil then
              FUserName := LJSONParser.FindValue('message.from.first_name').Value;

            if (LJSONParser.FindValue('message.from.first_name') <> nil) and (LJSONParser.FindValue('message.from.last_name') <> nil) then
              FUserName := LJSONParser.FindValue('message.from.first_name').Value + ' ' + LJSONParser.FindValue('message.from.last_name').Value; //Это имя написавшего боту

            if LJSONParser.FindValue('message.text') <> nil then
              FUserMessage :=  LJSONParser.FindValue('message.text').Value;  //Текст сообщения
            Synchronize(Status); // Сообщим что есть ответ
          end;

          if LJSONParser <> nil then
            LJSONParser.Free;
          PrevOffset := LResronseList.Count;
        end;
      end;
    end;
  finally
    FreeAndNil(LidHTTP);
    FreeAndNil(LJSONParser);
    FreeAndNil(LResronseList);
  end;
end;

Status回调逻辑

procedure TTelegramListener.Status;
begin
  if Assigned(FCallback) then
    FCallback(FUserID, FUserName, FUserMessage);
end;

修复方案与代码调整

1. 让线程终止时主动中断TIdHTTP请求

TIdHTTP的Get方法是阻塞的（尤其是30秒超时的长轮询），仅调用Terminate无法让线程跳出循环。需要重写Terminate方法，主动断开HTTP连接：

procedure TTelegramListener.Terminate;
begin
  inherited Terminate;
  // 中断阻塞的HTTP请求，让Get方法立即返回
  if Assigned(LidHTTP) then
    LidHTTP.Disconnect;
end;

2. 修正线程启动与终止的安全逻辑

原代码中直接替换线程对象会导致旧线程未完全销毁就被覆盖，引发野指针。需等待旧线程终止后再创建新线程：

procedure TTeleBot.StartListenMessages(CallProc: TCallbackProc);
var
  OldListener: TTelegramListener;
begin
  OldListener := FMessageListener;
  if Assigned(OldListener) then
  begin
    OldListener.Terminate;
    // 等待旧线程完全终止（因FreeOnTerminate=True，避免野指针）
    while OldListener.Terminated and not OldListener.Finished do
      Sleep(10);
    FMessageListener := nil;
  end;

  FMessageListener := TTelegramListener.Create(False);
  FMessageListener.Priority := tpLowest;
  FMessageListener.FreeOnTerminate := True;
  FMessageListener.Callback := CallProc;
  FMessageListener.TelegramToken := FTelegramToken;
end;

3. 修复Execute方法的内存泄漏与线程安全问题

原代码存在重复创建对象、offset计算错误、同步时竞态条件等问题，调整后的Execute方法：

procedure TTelegramListener.Execute;
var
  LidHTTP: TIdHTTP;
  LSSLSocketHandler: TIdSSLIOHandlerSocketOpenSSL;
  Offset, PrevOffset: Integer;
  LJSONParser: TJSONObject;
  LResponseList: TStringList;
  LArrJSON: TJSONArray;
  LResponse: string;
begin
  Offset := 0;
  PrevOffset := 0;
  LidHTTP := nil;
  LJSONParser := nil;
  LResponseList := nil;

  try
    // 资源仅初始化一次，避免循环内重复创建
    LidHTTP := TIdHTTP.Create(nil);
    LidHTTP.HTTPOptions := LidHTTP.HTTPOptions + [hoNoProtocolErrorException];
    LidHTTP.Request.BasicAuthentication := False;
    LidHTTP.Request.CharSet := 'utf-8';
    LidHTTP.Request.UserAgent := 'Mozilla/5.0 (Windows NT 6.1; WOW64; rv:12.0) Gecko/20100101 Firefox/12.0';

    LSSLSocketHandler := TIdSSLIOHandlerSocketOpenSSL.Create(LidHTTP);
    LSSLSocketHandler.SSLOptions.Method := sslvTLSv1_2;
    LSSLSocketHandler.SSLOptions.SSLVersions := [sslvTLSv1_2];
    LSSLSocketHandler.SSLOptions.Mode := sslmUnassigned;
    LSSLSocketHandler.SSLOptions.VerifyMode := [];
    LSSLSocketHandler.SSLOptions.VerifyDepth := 0;

    LidHTTP.IOHandler := LSSLSocketHandler;
    LResponseList := TStringList.Create;

    while not Terminated do
    begin
      if not Assigned(LidHTTP) then Break;

      try
        // 请求前先检查终止标记，避免进入阻塞请求
        if Terminated then Break;
        LResponse := LidHTTP.Get(cBaseUrl + FTelegramToken + '/getUpdates?offset=' + IntToStr(Offset) + '&timeout=30');
      except
        on E: Exception do
        begin
          // 捕获Disconnect引发的中断异常，直接退出循环
          if Terminated then Break;
          FLastError := 'HTTP请求错误: ' + E.Message;
          Sleep(1000); // 出错后延迟重试
          Continue;
        end;
      end;

      if Terminated then Break;
      if LResponse.Trim = '' then
      begin
        Sleep(100);
        Continue;
      end;

      try
        LJSONParser := TJSONObject.ParseJSONValue(LResponse) as TJSONObject;
        if not Assigned(LJSONParser) then Continue;

        LArrJSON := LJSONParser.GetValue('result') as TJSONArray;
        if not Assigned(LArrJSON) or (LArrJSON.Count <= 0) then Continue;

        LResponseList.Clear;
        for var I := 0 to LArrJSON.Count - 1 do
          LResponseList.Add(LArrJSON.Items[I].ToJSON);

        // 修正offset计算：Telegram要求用最后一个update_id+1来获取新消息
        Offset := (LArrJSON.Items[LArrJSON.Count-1] as TJSONObject).GetValue<Integer>('update_id') + 1;
        if Offset > PrevOffset then
        begin
          var LastMsgJSON := TJSONObject.ParseJSONValue(LResponseList[LResponseList.Count-1]) as TJSONObject;
          try
            if Assigned(LastMsgJSON) then
            begin
              var MsgText := LastMsgJSON.GetValue<string>('message.text', '');
              if MsgText.Trim <> '' then
              begin
                // 用临时变量存储数据，避免同步时成员变量被修改引发竞态
                var UserID := LastMsgJSON.GetValue<string>('message.from.id', '');
                var FirstName := LastMsgJSON.GetValue<string>('message.from.first_name', '');
                var LastName := LastMsgJSON.GetValue<string>('message.from.last_name', '');
                var UserName := FirstName;
                if LastName <> '' then UserName := UserName + ' ' + LastName;

                // 直接在Synchronize中使用匿名方法，避免依赖线程成员变量
                Synchronize(procedure
                begin
                  if Assigned(FCallback) then
                    FCallback(UserID, UserName, MsgText);
                end);
              end;
            end;
          finally
            LastMsgJSON.Free;
          end;
          PrevOffset := Offset;
        end;
      finally
        LJSONParser.Free; // 确保每次Parse后释放对象，避免内存泄漏
      end;
    end;
  finally
    // 按顺序释放资源，LidHTTP会自动释放其拥有的LSSLSocketHandler
    FreeAndNil(LResponseList);
    FreeAndNil(LidHTTP);
  end;
end;

4. 移除冗余的Status方法

调整后无需单独的Status方法，直接在Synchronize中调用回调，减少中间环节的线程安全风险。

修复说明

中断HTTP请求：解决了阻塞请求无法响应线程终止的核心问题，让线程能及时跳出循环。
线程生命周期管理：等待旧线程完全销毁后再创建新线程，避免野指针和资源冲突。
内存泄漏修复：修正了重复创建JSON对象未释放的问题，确保资源正确回收。
线程安全同步：使用临时变量存储用户数据，避免主线程与工作线程同时访问成员变量引发的访问违规。
业务逻辑修正：修复了Telegram offset的计算逻辑，确保正确获取新消息。

内容的提问来源于stack exchange，提问作者Yaroslav

修复Delphi线程中TIdHTTP访问违规及线程安全问题问询

问题描述 #

现有代码片段 #

线程构造函数与析构函数 #

线程调用与创建逻辑 #

线程终止代码 #

线程执行逻辑 #

Status回调逻辑 #

修复方案与代码调整 #

1. 让线程终止时主动中断TIdHTTP请求 #

2. 修正线程启动与终止的安全逻辑 #

3. 修复Execute方法的内存泄漏与线程安全问题 #

4. 移除冗余的Status方法 #

修复说明 #