суббота, 29 марта 2025 г.

Как универсально передать параметры из подпрограммы в подпрограмму

    Имеется набор ф-й, который надо запротоколировать, завести в критическую секцию и ещё что-нибудь. Набор ф-й не нов и не наш. Т.е. желательно не ломать свои исходники, и не получится ломать чужие или как-то договориться с хозяином. Ситуация не частая, но интересная. Особенно, когда речь о компиляторе D6. Речь, конечно, о нём (да, спустя четверть века он применяется в производстве программных продуктов). Но сильно ли  приятнее использовать способности нового компилятора?

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
type
  ...
  // Динамическое связывание с библиотекой
  Tsuit_InitCargoFrontal = function(var CargoFrontal: Pointer): Integer; stdcall;
  Tsuit_StartCollectShildImages = procedure(CargoFrontal: pointer; hwndShow:
    HWND; bShow: boolean; cColor: ColorRef); stdcall;
  Tsuit_IsCollectionComplete = procedure(CargoFrontal: pointer; var
    isCollectionReady: boolean; var stoppedCollecting: boolean); stdcall;
  Tsuit_GetFrontalShildImageCollection = function(CargoFrontal: pointer; cnt:
    Integer; var selectedIndex: Integer; var pixels: TPByteArr; var nWidth,
    nHeight, stride: TPIntArr;
    var pixels2: TPByteArr; var nWidth2, nHeight2, stride2: TPIntArr; var
    isAlert: TBoolArr): integer; stdcall;
  ...	
var
  InitCargoFrontal: Tsuit_InitCargoFrontal = nil;
  StartCollectShildImages: Tsuit_StartCollectShildImages = nil;
  FsIsCollectionComplete: Tsuit_IsCollectionComplete = nil;
  GetFrontalShildImageCollection: Tsuit_GetFrontalShildImageCollection = nil;
  ...
  libHandle: THandle;
  dllPath: string;
  ...  
  libHandle := LoadLibrary(PChar(dllPath));
  if libHandle > 0 then begin
    @InitCargoFrontal := Windows.GetProcAddress(libHandle, 'InitCargoFrontal');
    @StartCollectShildImages := Windows.GetProcAddress(libHandle, 'StartCollectShildImages');
    @FsIsCollectionComplete := Windows.GetProcAddress(libHandle, 'FsIsCollectionComplete');
    @GetFrontalShildImageCollection := Windows.GetProcAddress(libHandle, 'GetFrontalShildImageCollection');
  ...

    Поскольку внешний оригинальный набор обычно кучкуется в одном модуле, то просто меняем этот модуль на свой, где всё интерфейсно продублировано с внутренним вызовом оригинальной подпрограммы для сохранения функционала. А если внешний набор из загружаемой DLL, то меняем при загрузке методов адрес библиотечной ф-ии на адрес соответствующей нашей, в которой уже вызовем адрес оригинальный. Не сильно важно - замена будет идти в основном модуле-потребителе ф-й или в заменяющей DLL-перехватчике. До и после вызова оригинала можно делать свои входы в критическую секцию, логирование и ещё что-нибудь. 

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
  ...
  function GetProcAddress(AName: string): Pointer;
  begin
    Result := Windows.GetProcAddress(libHandle, PChar(AName));
    if not Assigned(Result)
      then Log._Error('Не удалось загрузить ' + ExtractFileName(dllPath) + ': ' + AName)
      else Result := suit_func_interceptor.Intercept( Result, AName );
  end;
  ...  
  libHandle := LoadLibrary(PChar(dllPath));
  if libHandle > 0 then begin
    @InitCargoFrontal := GetProcAddress('InitCargoFrontal');
    @StartCollectShildImages := GetProcAddress('StartCollectShildImages');
    @FsIsCollectionComplete := GetProcAddress('FsIsCollectionComplete');
    @GetFrontalShildImageCollection := GetProcAddress('GetFrontalShildImageCollection');
  ...

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
unit suit_func_interceptor;
{$O-} // This is how we prevent the deletion of procedures that are not explicitly called.
interface

  function Intercept( AProc: Pointer; AName: string ): Pointer;
  
implementation
uses
...
function my_InitCargoFrontal( var CargoFrontal: Pointer): Integer; stdcall;
begin
  ...
end;

function my_...; stdcall;
begin
  ...
end;

function my_...; stdcall;
begin
  ...
end;
...
type
  TInterception = record Lib, My: Pointer; Name: String end;
  Pinterception = ^TInterception;
const
  InterceptionTableCount = 33;
var
  InterceptionTable: array [ 0..InterceptionTableCount-1 ] of TInterception = (
    (Lib:nil; My:@my_InitCargoFrontal; Name:'InitCargoFrontal' ),
...
function GetInterceptionByName( AName: string ): PInterception;
var
  I: Integer;
begin
  for I := 0 to InterceptionTableCount-1 do begin
    Result := @InterceptionTable[ I ];
    if Result^.Name = AName then
      Exit;
  end;
  raise Exception.CreateFmt( 'Ошибка GetInterceptionByName - "%s" не найдено', [ AName ] );
end;
...
function Intercept( AProc: Pointer; AName: string ): Pointer;
begin
  with GetInterceptionByName( AName )^ do begin
    Lib := AProc;
    Result := My;
  end;
end;
...

    Это всё куча копипасты, где до вызова оригинала и после его вызова в каждой (а их может быть десятки) нашей подпрограмме-перехватчике твориться одно и то же. Разница в основном лишь в вызове оригинала - свой набор параметров и своё возвращение результата.

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
...
function my_GetFrontalShildImageCollection(CargoFrontal: pointer; cnt:
    Integer; var selectedIndex: Integer; var pixels: TPByteArr; var nWidth,
    nHeight, stride: TPIntArr;
    var pixels2: TPByteArr; var nWidth2, nHeight2, stride2: TPIntArr; var
    isAlert: TBoolArr): integer; stdcall;
var
  i: PInterception;
begin
  Result := 0;
  i := GetInterceptionByProc( @my_GetFrontalShildImageCollection );
  BeginOfInterception( i );
  try
    try  Result := Tsuit_GetFrontalShildImageCollection( i^.Lib )(
      CargoFrontal, cnt, selectedIndex, pixels, nWidth, nHeight, stride,
      pixels2, nWidth2, nHeight2, stride2, isAlert );
    except on e: Exception do begin LogError( i, e ); raise end
    end;
  finally EndOfInterception( i );
  end;
end;
...
function my_...
...
function my_...
...

    Как упростить тело перехватчика? Надо отдать в некий общий перехватчик анонимный метод с вызовом оригинала и возвратом результата, снабдив таблицу перехвата индексом-перечислением, чтобы без лишних циклов брать адрес оригинала и его имя для логирования. Ну, или использовать что-то более "OOP&Generic". Но в D6 анонимные методы не предусмотрены. Поэтому - либо толстые копипасты с несущими баги изменениями в середине каждой штуки, либо.. Либо какой-то "хакерский залом". Вот об этом "хакерском заломе" я и напишу.

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
type
  TInterceptionIdx = ( InitCargoFrontal, StartCollectShildImages, FsIsCollectionComplete,
    GetFrontalShildImageCollection {..} );
  TInterception = record Lib, My: Pointer; Name: String end;

procedure ProcessCall( CallOfLib: TProc; AInterceptionIdx: TInterceptionIdx );
begin
  BeginOfInterception( AInterceptionIdx );
  try
    try CallOfLib;
    except on e: Exception do begin LogError( AInterceptionIdx, e ); raise end
    end;
  finally EndOfInterception( AInterceptionIdx );
  end;
end;

function GetLib( AInterceptionIdx: TInterceptionIdx ): Pointer; forward;
...
function my_GetFrontalShildImageCollection(CargoFrontal: pointer; cnt:
    Integer; var selectedIndex: Integer; var pixels: TPByteArr; var nWidth,
    nHeight, stride: TPIntArr;
    var pixels2: TPByteArr; var nWidth2, nHeight2, stride2: TPIntArr; var
    isAlert: TBoolArr): integer; stdcall;
begin
  var LibIdx := TInterceptionIdx.GetFrontalShildImageCollection;
  ProcessCall( 
    procedure begin
      Result := Tsuit_GetFrontalShildImageCollection( GetLib( LibIdx ) ) (
        CargoFrontal, cnt, selectedIndex, pixels, nWidth, nHeight, stride,
        pixels2, nWidth2, nHeight2, stride2, isAlert );
    end,
    LibIdx );
end;
...
var
  InterceptionTable: array [ TInterceptionIdx ] of TInterception = (
    (Lib:nil; My:@my_InitCargoFrontal; Name:'InitCargoFrontal' ),

function GetLib( AInterceptionIdx: TInterceptionIdx ): Pointer;
begin
  Result := InterceptionTable[ AInterceptionIdx ].Lib;
end;

    Оставив абстрактные рассуждения, перейдём к конкретному примеру. Есть DLL, есть юнит с типизированными переменными процедурного типа. Надо поставить блокировку на одновременный вызов из DLL. Вот и сделаем перехватчики на каждый вызов.

    В нашем случае все вызовы - stdcall(да, это Win32), где параметры все в стеке, а результат вызова - это или указатели или целые числа или логические флаги - возвращается в регистре EAX. Можно предусмотреть ещё возврат в EDX для 64 битов, но это кому не повезёт, а у нас всё помещается в 32 бита. И чем кроме передачи параметров в стеке замечательно соглашение stdcall - очистка стека происходит инструкцией возврата. Значит, то, что в принципе нужно сделать перехватчику для вызова адреса из DLL - это взять область стека  со своими параметрами, положить в стек перед вызовом оригинального адреса, а после вызова преобразовать регистр EAX к нужному типу Паскаля. Или проигнорировать EAX, если вызывалась процедура.


    Все эти действия может сделать общее ядро - ф-я, которая получит адрес перехватчика для нахождения данных об оригинале (мы же не забыли при загрузке DLL положить себе в табличку соответствие оригинала и перехватчика) и вернёт универсальное значение Cardinal для преобразования в возвращаемый тип. Адрес перехватчика вставить в параметр "ядерной" ф-ии легко и просто, скопировав в каждом перехватчике сверху даблкликом имя перехватчика и вставив его после "собаки" в скобках. И тело перехватчика (каждого из десятков) станет лёгким и стройным как кипарис, всего из одной строчки.

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
...
function ProcessCall( MyProc: Pointer ): Cardinal; forward

function my_InitCargoFrontal( var CargoFrontal: Pointer): Integer; stdcall;
begin
  Result := ProcessCall( @my_InitCargoFrontal );
end;

function my_GetFrontalShildImageCollection( CargoFrontal: pointer; cnt:
    Integer; var selectedIndex: Integer; var pixels: TPByteArr; var nWidth,
    nHeight, stride: TPIntArr;
    var pixels2: TPByteArr; var nWidth2, nHeight2, stride2: TPIntArr; var
    isAlert: TBoolArr): integer; stdcall;
begin
  Result := ProcessCall( @my_GetFrontalShildImageCollection );
end;

function my_ShowAnimalShot4( ppCargoFrontal: Pointer): PAnimalStruct4; stdcall;
begin
  Result := PAnimalStruct4( ProcessCall( @my_ShowFrmManualShot4 ) );
end;
...

    Конечно, имя перехватчика, которое, как правило, базируется на имени оригинальной подпрограммы, может быть очень длинным и не влезать в одну строчку. Особенно с учётом того, что при длинных названиях и имя возвращаемого типа может быть длинным, даже более длинным. Но если сравнивать передачу во всех случаях одного(!) параметра без(!) изменения скопированного просто даблкликом из строчки выше(!) (и, как правило, вместе с именем перехватчика тут же подсвеченного(!) редактором кода), с передачей переменного, возможно, длинного, после копипасты из определения требующего редактирования для удаления типов с двоеточиями, всяких var и const и замены ";" на ",", списка параметров для расположенного где-то в другом месте другого идентификатора, то становится трудно удержаться, чтобы не повторить трюк c копированием стека и на более поздних версиях компилятора.

    Но. Чтобы копировать параметры нужно иметь адрес и длину. Адрес понятен - отсчёт от регистра EBP, в котором в текущей подпрограмме содержится указатель на EBP родительской подпрограммы - не проблема. А длины-то области параметров до компиляции и нет нигде. Но - есть после. Наша задача - добыть эту информацию. Находится она в инструкции ret, которая генерируется компилятором в конце каждой подпрограммы stdcall для возврата стека в исходное состояние, которое было у стека до помещения в него параметров подпрограммы.

    Я не предлагаю дизассемблировать машинный код. Но что будет, если вызвать процедуру, не поместив в стек параметров? Разумеется, для безопасности при полном описании параметров она ничего с параметрами делать не должна, просто должна быть пустой, чтобы ничего не сломать внутренними действиями. Но она сломает. Стек, благодаря сгенерированной для списка параметров инструкции ret, будет не возвращён в прежнее состояние, а изменён. Причём - на искомую нами длину. Нам надо просто сравнить значение регистра ESP "до" и "после" (а потом, конечно, вернуть в исходное состояние) - и дело в шляпе!

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
type
  TInterception = record Lib, My, Dump: Pointer; Stack: Cardinal; Name: String end;
  Pinterception = ^TInterception;
const
  InterceptionTableCount = 33;
var
  InterceptionTable: array [ 0..InterceptionTableCount-1 ] of TInterception = (
    (Lib:nil; My:@my_InitCargoFrontall; Dump:@dump_InitCargoFrontal; Stack:0; Name:'InitCargoFrontal' ),
...
function Intercept( AProc: Pointer; AName: string ): Pointer;
//
  function GetStackSizeForParameters( Dump: Pointer ): Cardinal; stdcall; assembler;
  asm
    mov EBX, ESP; // save stack
    call [Dump]; // change stack
    mov EAX, ESP; // has new stack
    sub EAX, EBX; // return difference
    mov ESP, EBX; // restore stack
  end;
//
begin
  with GetInterceptionByName( AName )^ do begin
    Lib := AProc;
    Stack := GetStackSizeForParameters( Dump );
    Result := My;
  end;
end;
...

    Конечно, для вычисления длины отводимого под параметры стека требуется на каждый перехватчик сгенерить соответствующую пустую процедуру. Тут, увы, требуется копипаста. Но несложная, с минимальными правками. Тем более несложная, что объявив процедуру ассемблерной, мы даже не обязаны будем описывать присвоение значения результату -  компилятор здесь уже даёт нам полное право действовать самостоятельно и не выдаёт лишних предупреждений.

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
...
function dump_InitCheckupShild( var CheckupShild: pointer): integer; stdcall; assembler; asm end;
function my_InitCheckupShild( var CheckupShild: pointer): integer; stdcall;
begin
  Result := ProcessCall( @my_InitCheckupShild );
end;

procedure dump_DestroyCheckupShild( CheckupShild: pointer); stdcall; assembler; asm end;
procedure my_DestroyCheckupShild( CheckupShild: pointer); stdcall;
begin
  ProcessCall( @my_DestroyCheckupShild );
end;

procedure dump_DetectShildsV( CheckupShild: pointer; ShildCountMax:integer;
    SrcIm1: TBitmap; var ShildCount1: integer; ArrayShildRect1: PRect;
    SrcIm2: TBitmap; var ShildCount2: integer; ArrayShildRect2: PRect); stdcall; assembler; asm end;
procedure my_DetectShildsV( CheckupShild: pointer; ShildCountMax:integer;
    SrcIm1: TBitmap; var ShildCount1: integer; ArrayShildRect1: PRect;
    SrcIm2: TBitmap; var ShildCount2: integer; ArrayShildRect2: PRect); stdcall;
begin
  ProcessCall( @my_DetectShildsV );
end;

function dump_VerifyShildsByItemIndex( CheckupShild: pointer;
    ItemIndex1, ItemIndex2: integer; var pfMera: single): integer; stdcall; assembler; asm end;
function my_VerifyShildsByItemIndex( CheckupShild: pointer;
    ItemIndex1, ItemIndex2: integer; var pfMera: single): integer; stdcall;
begin
  Result := ProcessCall( @my_VerifyShildsByItemIndex );
end;
...

    Вот, собственно, и всё. Почти. Оптимизация - компиляторная или линковочная - может привести к тому, что процедуры, которые не имеют явного вызова, будут выброшены из исполняемого файла даже не смотря на то, что изначальные адреса их останутся где-то в таблице констант. Вероятно, это можно считать багой. Поэтому - отключаем оптимизацию в юните с перехватчиками ({$O-}).

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
...
function ProcessCall( MyProc: Pointer ): Cardinal;
var
  i: PInterception;
//
  procedure BeginOfInterception;
  begin
...
  end;
//
  procedure EndOfInterception;
  begin
...
  end;
//
begin   //  ProcessCall
  i := GetInterceptionByProc( MyProc );
  BeginOfInterception;
  try
    try
      asm // copy parameters from parent stack to child stack and call procedure in DLL
        mov EAX, [i] // with i^ do..
        mov ECX, TInterception(EAX).Stack // size of parameter area in bytes
        mov ESI, [EBP] // base pointer of stack of calling proc
        lea ESI, [ESI + 8] // offset of parameter area of calling proc
        sub ESP, ECX // allocate space for parameters
        mov EDI, ESP // destination in current stack
        shr ECX, 2 // div 4 - count of doublewords
        rep movsd
        call [TInterception(EAX).Lib] // procedure in DLL
        mov @Result, EAX
      end;
    except on e: Exception do begin LogError( i, e ); raise end
    end;
  finally EndOfInterception;
  end;
end;
...

    Вместо постскриптума. В новых, ещё не созданных (точнее - не изученных) компиляторах, мне рассказывали, не исключена вероятность того, что чуть-ли не прямо в рантайме может произойти что-нибудь с исполняемым кодом для изменения вызова процедур, не использующих свои параметры внутри. Страшно. Да и потом вообще - все такие манипуляции ассемблерного уровня слишком привязаны к платформе и к архитектуре. Что сказать? Ожидать всё время будущего - не жить настоящим. Мы знаем, что мы смертны, смертны наверняка, но это не обязывает нас сразу искать гроб на колёсиках и выбирать место упокоения. Пока можно позволить себе что-нибудь более приятное.



Автор: на
Ярлыки: , , , , ,

Комментариев нет:

Отправить комментарий

Подписаться на: Комментарии к сообщению (Atom)