суббота, 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;
...

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



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

понедельник, 21 ноября 2022 г.

TStringList vs. THashedStringList vs. TDictionary

 Пет-проект это называется или просто делать нечего, но надо мне список слов хранить, чтобы проверить слово новое - не значится ли там. Конечно, я слыхал, что THashedStringList ищет вхождение на много быстрее, чем простой TStringList. Но насколько? А ещё, говорят, TDictionary - очень быстрая штука и модная (стильная, молодёжная..). Надо посмотреть.


Взял два списка. В первый список положу слова, которые искать буду во втором. 


  1. procedure TformMain.btnGenerateClick(Sender: TObject);
  2. //
  3.   procedure FillList( AStr: TStrings );
  4.   begin
  5.     AStr.Clear;
  6.     AStr.BeginUpdate;
  7.     try
  8.       var R := Word('Я') - Word( 'А' );
  9.       for var N := 1 to 20000 do begin
  10.         var W := '1234567';
  11.         for var I := 1 to 7 do W[I] := Char( Word( WideChar( 'А' ) ) + Random( R ) );
  12.         AStr.Add( W )
  13.       end;
  14.     finally AStr.EndUpdate;
  15.     end;
  16.   end;
  17. //
  18. begin
  19.   FillList( ListBox1.Items );
  20.   FillList( ListBox2.Items );
  21. end;
Мне, так уж складывается, 7 букв в слове достаточно.
Число 20000 подобрал опытным путём. Теперь буду каждое слово помечать "=Yes|No" в зависимости от того найдётся ли оно, и засекать время. Разные способы - разные кнопки:


Прошу прощения, что не использую модные TStopwatch.
  1. procedure TformMain.btnIndexOfClick(Sender: TObject);
  2. //
  3.   procedure ClearMarks( AStr: TStrings );
  4.   begin
  5.     AStr.BeginUpdate;
  6.     try
  7.       for var I := 0 to AStr.Count-1 do begin
  8.         var S := AStr[I];
  9.         var P := Pos( '=', S );
  10.         if P > 0 then
  11.           AStr[I] := Copy( S, 1, P-1 );
  12.       end;
  13.     finally AStr.EndUpdate;
  14.     end;
  15.   end;
  16. //
  17.   procedure Mark1In2( AStr1, AStr2: TStrings );...
  18. //
  19.   procedure Mark1In2Hashed( AStr1, AStr2: TStrings );...
  20. //
  21.   procedure Mark1In2Sorted( AStr1, AStr2: TStrings );...
  22. //
  23.   procedure Mark1In2Dictio( AStr1, AStr2: TStrings );...
  24. //
  25. begin  //  TForm16.btnIndexOfClick(Sender: TObject);
  26.   Screen.Cursor := crHourGlass;
  27.   try
  28.     ClearMarks( ListBox1.Items );
  29.     var dt := Now;
  30.     case TControl( Sender ).Tag of
  31.       1: Mark1In2Hashed( ListBox1.Items, ListBox2.Items );
  32.       2: Mark1In2Sorted( ListBox1.Items, ListBox2.Items );
  33.       3: Mark1In2Dictio( ListBox1.Items, ListBox2.Items );
  34.       else Mark1In2    ( ListBox1.Items, ListBox2.Items )
  35.     end;
  36.     dt := Now - dt;
  37.     Caption := FormatDateTime( 'hh:nn:ss.zzz', dt );
  38.   finally Screen.Cursor := crDefault;
  39.   end;
  40. end;
Начнём с простого (тут подходит поговорка "Простота - хуже воровства") Mark1In2:
  1.   procedure Mark1In2( AStr1, AStr2: TStrings );
  2.   begin
  3.     AStr1.BeginUpdate;
  4.     try
  5.       for var I := 0 to AStr1.Count-1 do begin
  6.         var S := AStr1[I];
  7.         AStr1[I] := S + '=' + IfThen( AStr2.IndexOf( S ) >= 0, 'Yes', 'No' );
  8.       end;
  9.     finally AStr1.EndUpdate;
  10.     end;
  11.   end;
Остальные методы размножаются копипастой с некоторыми изменениями и дополнениями.
Мой фаворит Mark1In2Hashed достанет из System.IniFiles старый (Delphi 6, если не ошибаюсь) добрый THashedStringList:
  1.   procedure Mark1In2Hashed( AStr1, AStr2: TStrings );
  2.   begin
  3.     AStr1.BeginUpdate;
  4.     try
  5.       var HSL := THashedStringList.Create;
  6.       try
  7.         HSL.AddStrings( AStr2 );
  8.         for var I := 0 to AStr1.Count-1 do begin
  9.           var S := AStr1[I];
  10.           AStr1[I] := S + '=' + IfThen( HSL.IndexOf( S ) >= 0, 'Yes', 'No' );
  11.         end;
  12.       finally HSL.Free;
  13.       end;
  14.     finally AStr1.EndUpdate;
  15.     end;
  16.   end;
Но не будем забывать, что и простой TStringList не лыком шит, имеет в рукаве кое-что:
если его упорядочить, то можно использовать метод половинного деления, а не простой перебор.
И это уже совсем другая история.
  1.   procedure Mark1In2Sorted( AStr1, AStr2: TStrings );
  2.   begin
  3.     AStr1.BeginUpdate;
  4.     try
  5.       var SL := TStringList.Create( dupIgnore, True, False );
  6.       try
  7.         SL.AddStrings( AStr2 );
  8.         for var I := 0 to AStr1.Count-1 do begin
  9.           var S := AStr1[I];
  10.           AStr1[I] := S + '=' + IfThen( SL.IndexOf( S ) >= 0, 'Yes', 'No' );
  11.         end;
  12.       finally SL.Free;
  13.       end;
  14.     finally AStr1.EndUpdate;
  15.     end;
  16.   end;
И напоследок рассмотрим данный нам в Generics.Collections список TDictionary.
  1.   procedure Mark1In2Dictio( AStr1, AStr2: TStrings );
  2.   begin
  3.     AStr1.BeginUpdate;
  4.     try
  5.       var D := TDictionary<string,TObject>.Create;
  6.       try
  7.         for var I := 0 to AStr2.Count-1 do
  8.           D.TryAdd( AStr2[I], nil );
  9.         for var I := 0 to AStr1.Count-1 do begin
  10.           var S := AStr1[I];
  11.           AStr1[I] := S + '=' + IfThen( D.ContainsKey( S ), 'Yes', 'No' );
  12.         end;
  13.       finally D.Free;
  14.       end;
  15.     finally AStr1.EndUpdate;
  16.     end;
  17.   end;
Для тестирования я использовал Embarcadero® Delphi 11 Version 28.0.46481.1287. 
Компьютер у меня не новый, но хороший:
Прежде, чем перейти к результатам тестирования, должен рассказать, что про замечательную
скорость словаря я прочитал в
Программа немецкого товарища, скачанная с его сайта, у меня показывает такие результаты:

TStringList
676: Add: 00:00:08.0883633
676: IndexOf: 00:00:08.0856404
THashedStringList
676: Add: 00:00:08.0273955
676: IndexOf: 00:00:01.6376979
TDictionary
676: Add: 00:00:00.9561740
676: IndexOf: 00:00:00.9005278

Не вдаваясь в детали можно заметить, что словарь прямо таки "рулит"! Но, увы, мои собственные опыты не подтверждают лидерство новых технологий, скорее наоборот.

Я запускал на трёх генерациях списков конкурирующие процедуры  Mark1In2Hashed, Mark1In2Sorted и Mark1In2Dictio одну за одной по три раза, чтобы, не смотря на изменчивую вычислительную среду, видны были чёткие тенденции. 

Замер времени поиска в списке
Среднее
THashedStringList3,1583,1513,1683,2193,0833,1673,1763,0813,1423,149444444
TStringList3,3413,2253,2943,3383,283,2753,2143,3083,2913,285111111
TDictionary3,2393,263,2773,33,253,333,3843,2673,3083,290555556


Как видно, использование всех трёх компонентов приводит к результату от трёх до трёх с половиной секунд. И сверхбыстрый THashedStringList выигрывает у TStringList менее 5%. Хвалёный же TDictionary оказался последним, а не первым. Вот и верь после этого людям!

Но что с "простым" методом Mark1In2? Он работал почти минуту - 58,335 секунд! Я, понятно, не стал его включать в серию испытаний. Но какая это прекрасная иллюстрация  беззаботности - почти минута вместо 3 с хвостиком секунд - разница почти в 20 раз!

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

Автор: на Комментариев нет:
Ярлыки: , , ,
Подписаться на: Сообщения (Atom)