Поддержка обратного вызова TLS (Thread-Local-Storage) в Delphi 10 версиях

Question

Я читаю эту статью , в которой объясняется, как установить обратный вызов TLS в Delphi. Автор статьи говорит, что пример работает на «Delphi: 2007, 2010, XE4, XE10». Но я проверил на Delphi 10 Сиэтле, Берлине и Рио, и он не работает (обратный вызов TLS не выполняется), но когда я тестирую его на Delphi XE5, он отлично работает.

Я также отметил, что размер файла .map при компиляции проекта test_app в Delphi XE5 и Delphi 10 отличается. Файл .map в Delphi 10 в 5 раз больше, чем файл .map в Delphi XE5 (что-то около 25 КБ и 125 КБ соответственно).

Какие детали я здесь упускаю?

Ниже приведен код с разумным переводом на английский язык sh проекта add_tls и проекта test_app .

PS: Проект test_app необходимо настроить для создания файла .map. Проект> Параметры> Связывание> Файл карты => Подробно.

add_tls:

program add_tls;

{$APPTYPE CONSOLE}

{$R *.res}

uses
  Windows,
  Classes,
  SysUtils,
  Generics.Collections;

procedure ShowHelp;
begin
  Writeln('Usage: AddTls.exe "executable path"');
  Writeln('Return Codes:');
  Writeln('  - 0: TLS Callback successfully added');
  Writeln('  - 1: the path to the executable file is not specified');
  Writeln('  - 2: executable not found');
  Writeln('  - 3: MAP file not found matching the specified file');
  Writeln('  - 4: MAP file parsing error');
  Writeln('  - 5: error accessing executable file');
  Writeln('  - 6: there is no initialized TLS section in the executable file');
end;

type
  TSectionData = record
    Index: Integer;
    StartAddr: DWORD;
    SectionName: ShortString;
  end;
  TSectionDataList = TList<TSectionData>;

const
  HardcodeTLS32Offset = 12;

//
// This is an easy way to search for TLS BUT tables - only in projects,
// collected in XE and above
// If the executable is built by another compiler, it will not work naturally
// but the article is not about that :)
// so:
// =============================================================================
function GetTlsTableAddr(const FilePath: string): DWORD;
var
  F: TFileStream;
  DOS: TImageDosHeader;
  NT: TImageNtHeaders;
  I: Integer;
  Section: TImageSectionHeader;
begin
  Result := 0;
  // open the file for reading
  F := TFileStream.Create(FilePath, fmOpenRead or fmShareDenyWrite);
  try
    // read DOS header to go to NT
    F.ReadBuffer(DOS, SizeOf(TImageDosHeader));
    F.Position := DOS._lfanew;
    // We read the NT header to get the number of sections
    F.ReadBuffer(NT, SizeOf(TImageNtHeaders));
    // read sections and look for TLS
    for I := 0 to NT.FileHeader.NumberOfSections - 1 do
    begin
      F.ReadBuffer(Section, SizeOf(TImageSectionHeader));
      if PAnsiChar(@Section.Name[0]) = '.tls'  then
      begin
        // found IMAGE_TLS_DIRECTORY, we immediately correct the AddressOfCallback field
        Result := Section.PointerToRawData + HardcodeTLS32Offset;
        Break;
      end;
    end;
  finally
    F.Free;
  end;
end;

// just parse the map file and look for the addresses of the sections
function GetSectionDataList(const FilePath: string; var Index: Integer): TSectionDataList;
var
  S: TStringList;
  Line: string;
  Section: TSectionData;
begin
  Result := TSectionDataList.Create;
  try
    S := TStringList.Create;
    try
      S.LoadFromFile(FilePath);
      Index := 0;
      Writeln('I am looking for a table of sections...');
      while Copy(Trim(S[Index]), 1, 5) <> 'Start' do
        Inc(Index);
      Inc(Index);
      while Trim(S[Index]) <> '' do
      begin
        Line := Trim(S[Index]);
        Section.Index := StrToInt(Copy(Line, 1, 4));
        Delete(Line, 1, 5);
        Section.StartAddr := StrToInt('$' + Copy(Line, 1, 8));
        Delete(Line, 1, 19);
        Section.SectionName := ShortString(Trim(Copy(Line, 1, 8)));
        Result.Add(Section);
        Inc(Index);
      end;
      Writeln('Total sections found: ', Result.Count);
    finally
      S.Free;
    end;
  except
    // we suppress all exceptions. there are error codes
    on E: Exception do
      Writeln('GetSectionDataList: ' + E.ClassName + ': ' + E.Message);
  end;
end;

// again, parse the mapfile and look for the address of the function called tls_callback
// which (if found) we summarize with the address of the section in which it is located
function GetTlsCallbackAddr(const FilePath: string;
  SectionDataList: TSectionDataList; Index: Integer): DWORD;
var
  S: TStringList;
  Line: string;
  SectionIndex, TlsAddr: Integer;
begin
  Result := 0;
  try
    S := TStringList.Create;
    try
      S.LoadFromFile(FilePath);
      Writeln('Looking for tls_callback...');
      repeat
        Line := Trim(S[Index]);
        Inc(Index);
        if Index = S.Count then Break;
      until Pos('.tls_callback', Line) <> 0;
      if Pos('.tls_callback', Line) = 0 then
      begin
        Writeln('No tls_callback entry found in MAP file');
        Exit;
      end;
      SectionIndex := StrToInt(Copy(Line, 1, 4));
      Delete(Line, 1, 5);
      TlsAddr := StrToInt('$' + Copy(Line, 1, 8));
      Writeln('tls_callback found, offset: ', IntToHex(TlsAddr, 8), ', section: ', SectionIndex);
      Writeln('Looking for a record about the section...');
      for Index := 0 to SectionDataList.Count - 1 do
        if SectionDataList[Index].Index = SectionIndex then
        begin
          Result := SectionDataList[Index].StartAddr + DWORD(TlsAddr);
          Writeln('TLS Callback, found in section "', SectionDataList[Index].SectionName,
            '", offset sections: ', IntToHex(SectionDataList[Index].StartAddr, 8),
            ', calculated addressc: ', IntToHex(Result, 8));
          Break;
        end;
      if Result = 0 then
        Writeln('Section containing tls_callback not found')
    finally
      S.Free;
    end;
  except
    // we suppress all exceptions. there are error codes
    on E: Exception do
      Writeln('GetTlsCallbackAddr: ' + E.ClassName + ': ' + E.Message);
  end;
end;

// directly patch file
function Patch(const FilePath, MapPath: string; TlsTable, CallbackAddr: DWORD): Boolean;
var
  F: TFileStream;
  NewFilePath, BackUpFilePath: string;
  OldCallbackTableAddr: DWORD;
begin
  Result := False;
  try
    NewFilePath := ExtractFilePath(FilePath) + 'tls_aded_' +
      ExtractFileName(FilePath);
    Writeln('I create a copy of the file, the path: ', NewFilePath);
    CopyFile(PChar(FilePath), PChar(NewFilePath), False);
    F := TFileStream.Create(NewFilePath, fmOpenReadWrite);
    try
      Writeln('File open');
      F.Position := TlsTable;
      // read the address where the previous callback referred
      F.ReadBuffer(OldCallbackTableAddr, 4);
      // in a delphi image, it refers to the SizeOfZeroFill structure of IMAGE_TLS_DIRECTORY
      // in which both last fields are filled with zeros (supposedly there is no callback chain)
      // Therefore, we will not spoil the working structure and make it refer to the address
      // immediately outside of this structure (plus 2 yards in 32 bit, in 64 bit)
      Inc(OldCallbackTableAddr, SizeOf(DWORD) * 2);
      F.Position := TlsTable;
      // write a new address to the old place
      F.WriteBuffer(OldCallbackTableAddr, 4);
      Writeln('Assigned a new address to the chain of processors, offset: ', IntToHex(TlsTable, 8),
        ', new value: ', IntToHex(OldCallbackTableAddr, 8));
      // now we jump to the place where the VA address of the handler (not RVA) should be written
      // skip SizeOfZeroFill and Characteristics and get right behind them
      F.Position := TlsTable + SizeOf(DWORD) * 3;
      // and now write the address of our callback
      F.WriteBuffer(CallbackAddr, 4);
      Writeln('Callback address set, offset: ', IntToHex(TlsTable + SizeOf(DWORD) * 3, 8));
      // after which we write zero to indicate the end of the callback chain
      CallbackAddr := 0;
      F.WriteBuffer(CallbackAddr, 4);
    finally
      F.Free;
    end;
    // if everything is fine, then rename back
    Writeln('I create a backup');
    BackUpFilePath := FilePath + '.bak';
    DeleteFile(BackUpFilePath);
    RenameFile(FilePath, BackUpFilePath);
    Writeln('I keep the result');
    RenameFile(NewFilePath, FilePath);
    Writeln('All tasks completed');
    Result := True;
  except
    // we suppress all exceptions. there are error codes
    on E: Exception do
    begin
      // in the event of an error, we clean ourselves up - returning everything back
      DeleteFile(NewFilePath);
      RenameFile(BackUpFilePath, FilePath);
      Writeln('Patch: ' + E.ClassName + ': ' + E.Message);
    end;
  end;
end;

var
  MapPath: string;
  TlsTable, CallbackAddr: DWORD;
  SectionDataList: TSectionDataList;
  Index: Integer;
begin
  ExitCode := 0;
  if ParamCount = 0 then
  begin
    ShowHelp;
    ExitCode := 1;
    ExitProcess(ExitCode);
  end;
  if not FileExists(ParamStr(1)) then
  begin
    Writeln('No executable found: ', ParamStr(1));
    ExitCode := 2;
    ExitProcess(ExitCode);
  end;
  TlsTable := GetTlsTableAddr(ParamStr(1));
  if TlsTable = 0 then
  begin
    ExitCode := 6;
    ExitProcess(ExitCode);
  end;
  MapPath := ChangeFileExt(ParamStr(1), '.map');
  if not FileExists(MapPath) then
  begin
    Writeln('MAP file not found: ', MapPath);
    ExitCode := 3;
    ExitProcess(ExitCode);
  end;
  Index := 0;
  SectionDataList := GetSectionDataList(MapPath, Index);
  try
    if SectionDataList.Count = 0 then
    begin
      Writeln('Could not build partition table');
      ExitCode := 9;
      ExitProcess(ExitCode);
    end;
    CallbackAddr := GetTlsCallbackAddr(MapPath, SectionDataList, Index);
    if CallbackAddr = 0 then
    begin
      ExitCode := 4;
      ExitProcess(ExitCode);
    end;
    if not Patch(ParamStr(1), MapPath, TlsTable, CallbackAddr) then
      ExitCode := 5;
  finally
    SectionDataList.Free;
  end;
  ExitProcess(ExitCode);
end.

test_app:

program test_app;

{$APPTYPE CONSOLE}

{$R *.res}

uses
  Windows;

// this callback will be called if the file is correctly patched
procedure tls_callback(hModule: HMODULE;
  ul_reason_for_call: DWORD; lpReserved: Pointer); stdcall;
begin
  if ul_reason_for_call = DLL_PROCESS_ATTACH then
    MessageBox(0, 'TLS Callback Message', nil, 0);
end;

const
  ptls_callback: Pointer = @tls_callback;

begin
  // so that the tls_callback procedure appears in the MAP file
  // you need a link to it, it’s corny like this:
  if ptls_callback <> nil then
    MessageBox(0, 'Entry Point Message', nil, 0);
end.

Answer 1

Если ваша цель состоит в том, чтобы какой-то код выполнялся как можно быстрее, вот что работает на любой ревизии Delphi и на любой платформе (не только Windows).

Создание небольшого кода модуль без зависимости (вообще не uses).

unit FirstLoaded;

interface

// NO "uses" clause!

implementation

procedure SomeThingToDoEarly;
begin
end;

initialization
  SomeThingToDoEarly;
end.

Затем поместите его в качестве первого модуля в предложении uses вашего проекта .dpr - прежде всего.

program Project1;

uses
  FirstLoaded, // before anything!
  Forms,
  Unit1 in 'Unit1.pas' {Form1};

{$R *.res}

begin
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.

Код в initialization части вашего устройства будет вызываться сразу после system.pas.

Имейте в виду, что если вы добавите что-то в предложение uses вашего подразделения, эти подразделения (и их зависимости) будут инициализированы первыми.