среда, 22 февраля 2017 г.

Побрюзжу №6

http://www.risk.ru/blog/207821

Есть такой рецепт "пеммикан от Андрея Лебедева".

Мясо вываренное в свином сале. Реально сохраняется на жаре несколько месяцев без холодильника.

Так я что вспомнил. Мы ходили как-то в Турцию в горы.

И встретили там альпинистов турок.

Ну и мы посидели. Пообщались.

Хорошие ребята.

Накормили их нашей гречкой с пеммиканом.

Они сказали, что очень вкусно. Поинтересовались рецептом.

Я начал рассказывать и понял, что они же мусульмане. Свинина - нихт кошер. Или нихт халяль.

Ну я и сказал им, что это говядина в курдючном жире. Тем более, что такие рецепты - тоже имеют место быть.

Короче - взял грех на душу...

Побрюзжу №5

1. Пишу про Delphi. Приходит чувак и говорит - "Delphi говно, используй функциональные языки". А я блин не знал, что такие языки оленьи бывают.
2. Пишу про TDD. Приходят "адепты" и говорят "у тебя некошерный TDD".
2а. Пишу про UML и MDA. Муку. Это отстой. Сейчас в моде уже другие кунштюки. В однобортном сейчас уже никто не воюет.
3. Пишу про синглетоны на atomic-операциях. Приходят и говорят, что надо использовать критические секции. А то я блин не знаю про критические секции. Но я же изначально хотел без них и озвучил почему. Или начинают рассказывать, что собственные данные синглетона тоже надо защищать при многопоточности. А то я блин не знал.
4. Пишу про свои "задорновые" наблюдения про немецкий. Приходят и говорят - "не выноси это на всеобщее обозрение". Иначе что? Покажусь глупым? Так мне это не грозит. Я и так не слыву уж очень умным. И не стремлюсь умным показаться. Я ведь не на работу переводчиком нанимаюсь.
5. Пишу про "слабые ссылки". Приходит Штефан Глинка и говорит, что они могут ТЕОРЕТИЧЕСКИ вести к AV. А то Я блин не знаю. Но я ведь наверное не с бодуна их делал. И учитывал возможные ограничения области применения.
6. Боюсь про белорусский и ВКЛ ПИСАТЬ. Как бы "змагары" не пришли. И не сказали - не трожь своими грязными москальскими руками наше ридное.
7. Не боюсь только про турецкий какую-нибудь глупость написать. Они наверное русского не знают. Но правда и мне про турецкий что-то нечего написать.
8. Про историю положем ещё можно писать. Там кто первый надел халат - тот и Фоменко или Мурад Аджи.
9. Про айкидо и танцы - вот только ничего не писал, так как так и не смог остудить эти премудрости языка тела. Нечего сказать. В шоке.

И ведь главное - пишу вроде без оценочных суждений. Стараюсь никого не задеть.

Задаёшь вопрос - "что я не так сказал". Молчание...

Нашёл ошибку - скажи. Чётко и по делу. И без оценочных суждений. Так нет же...

А не писать - не могу. Графоман-с. Я ведь экстраверт, а профессия - для интравертов.

Да тут есть некий инфантилизм. Как ребёнок с растворённым сознанием. Узнал сам - хочется поделиться. Ну что поделаешь. И в школе со мной боролись. А у меня вон и дочка такая. Гены наверное...

Про что писать? Про горы? Ну так это глупо...

Побрюзжу №4

"Общались ли вы с носителями языка?"

Да общался. Как сейчас помню. Дело было на Памире. Мы немцев угостили арбузом и пивом. Они долго не могли поверить, что это подарок (das Geschenck) от чистого сердца.

Ну через перевал путешественников карнизы обычно пиво носят на продажу.

Да и какое пиво на четырёх тысячах.

Потом немного выпили и я им объяснял, что мы не взошли на пик Ленина, потому что у нас сломался примус и мы два дня питались холодной едой. Хорошо, что встреченные холлы пару раз горячим чаем напоили (хорошие ребята).

 В итоге примус оказался таки немецким словом.

А я им всё gas machine, да gas machine...

вторник, 21 февраля 2017 г.

Побрюзжу №3

Судя по блогу, сетевое общение почему-то скатывается примерно к такому:

- Давайте я вам расскажу, что я узнал.
- Эй ты криворукий, ты всё не так делаешь.
- А как надо?
- Надо не так как ты.

Побрюзжу №2

1. Пишу про Delphi. Приходит чувак и говорит - "Delphi говно, используй функциональные языки". А я блин не знал, что такие языки оленьи бывают.
2. Пишу про TDD. Приходят "адепты" и говорят "у тебя некошерный TDD".
2а. Пишу про UML и MDA. Муку. Это отстой. Сейчас в моде уже другие кунштюки. В однобортном сейчас уже никто не воюет.
3. Пишу про Синглетоны на atomic-операциях. Приходят и говорят, что надо использовать критические секции. А то Я блин не знаю про критические секции.
4. Пишу про свои "задорновые" наблюдения про немецкий. Приходят и говорят - "не выноси это на всеобщее обозрение". Иначе что? Покажусь глупым? Так мне это не грозит. Я и так не слыву уж очень умным. И не стремлюсь умным показаться. Я ведь не на работу переводчиком нанимаюсь.
5. Пишу про "слабые ссылки". Приходит Штефан Глинка и говорит, что они могут ТЕОРЕТИЧЕСКИ вести к AV. А то Я блин не знаю. Но я ведь наверное не с бодуна их делал. И учитывал возможные ограничения области применения.
6. Боюсь про белорусский и ВКЛ ПИСАТЬ. Как бы "змагары" не пришли. И не сказали - не трожь своими грязными москальскими руками наше ридное.
7. Не боюсь только про турецкий какую-нибудь глупость написать. Они наверное русского не знают. Но правда и мне про турецкий что-то нечего написать.

И ведь главное - пишу вроде без оценочных суждений. Стараюсь никого не задеть.

Задаёшь вопрос - "что я не так сказал". Молчание...

Нашёл ошибку - скажи. Чётко и по делу. И без оценочных суждений. Так нет же...

А не писать - не могу. Графоман-с. Я ведь экстраверт, а профессия - для интравертов.

Да тут есть некий инфантилизм. Как ребёнок с растворённым сознанием. Узнал сам - хочется поделиться. Ну что поделаешь. И в школе со мной боролись. А у меня вон и дочка такая. Гены наверное...

Про что писать? Про горы? Ну так это глупо...

Побрюзжу №1

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

Зато пригодились знание про коллинеарность векторов. Векторное и скалярное произведения. А также про площадь параллелограма и метрики пространств.

А также про умножение матриц и афинные пространства.

Не знаешь где найдёшь, а где потеряешь...

Зато вся та физика, что я учил - тоже не пригодились. Кроме пожалуй законов Кирхгофа, да и то для достаточно неожиданной области - расчёта вентиляторов и фильтров в элеваторе.

среда, 15 февраля 2017 г.

Для памяти

ToDo. Про следилку за утечками объектов

В следилке за объектами надо писать ещё и время создания объекта. Это должно помочь при разборе логов.

#1353. Вопрос. Как сделать потокобезопасный синглетон

Как на Delphi сделать потокобезопасный синглетон БЕЗ использования критических секций?

Ну скажем только с interlocked- операциями.

Но не так как TMonitor у Embarcadero.

У меня есть свой вариант, но я приведу его позже.

Есть такой эскиз:

Var instance : TMyClass = nil;
 Lock : Integer = 0; // - это глобальные переменные

Function getInstance: TMyClass;
Var LockValue : Integer; // - это локальная переменная
Begin
If instance = nil then
Begin
 LockValue := interlockedIncrement(lock);
 Try
 If lockValue = 1 then
 Begin
  If instance = nil then
   Instance := TMyClass.Create;
 End
 Else
 Begin
  While instance = nil do
   Sleep(0);
 End;
 Finally
  InterlockedDecrement(lock);
 End
End
Result := instance;
Assert(Result <> nil);
End;
Покатить?

(+) https://m.habrahabr.ru/post/147373/

Но там всё про C++ и C#.

Да ещё и со встроенным lock или static-переменой, которая удрвлетворяет "новому стандарту". Что по сути является критической секцией, только скрытой в потрохах языка.

 А меня интересует Delphi. И БЕЗ критических секций и TMonitor.

Или всё проще и достаточно критической секции, но ОДНОЙ. ГЛОБАЛЬНОЙ. А как там с вероятностью deadLock'ов? Когда создаваемый синглетон в своём конструкторе обращается к другому синглетону, который ещё не создан.

ToDo. Для себя

Подумать на тему передачи задач на сервер в виде скриптов.

Вместо EVD - гонять скрипты.

Или точнее - ВМЕСТЕ с EVD - гонять скрипты.

#1352. Ссылка. Странный вопрос, если честно

понедельник, 13 февраля 2017 г.

Вопрос. Может кто чего посоветует

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

Ну чтобы сидишь на работе, одел наушники и словарь трындит тебе в фоне. Вместо музыки.

Ну типа:
Ein - один
Wife geht's - как дела
Pronomen - местоимение
Betriebswirtschaft - управление бизнесом
Auf keinen Fall - никак
Spass machen -  забавлять
Es gibt - существовать
Selbststaendig - независимый
Sicher - уверенно
Eigentlich - на самом деле

Ну и т.д. и т.п.

Существительные хорошо бы чтобы с артиклями проговаривались и с формой множественного числа и родительного падежа.

А то ведь когда музыку (со словами) слушаешь - многое запоминается. Даже то, что не надо.

А хотелось бы нужное запоминать. Так сказать - не тратить время даром.

Мне кажется, что люди уже должны были сделать что-то подобное. Или я ошибаюсь?

Интересует именно немецкий. Ну и белорусский. Если вдруг... (там ещё приставные буквы крайне интересны)

Ну и неплохо было бы чтобы склонения и спряжения также умело начитывать.

Типа:
Ich - will
During - willst
Eric/sie/es/man - will
Wir - wollen
Ihr - wollt
sie - wollen
Sie - wollen

Ich - wollte
Du - wolltest
We/sie/es/man - wollte
Wir - wollten
Ihr - wolltet
sie - wollten
Sie - wollten

Nominativ - der neue Freund
Akkusativ - den neuen Freund
Dativ - mit dem neuen Freund
Genitiv - des neues Freundes

Ну и отделяемые приставки отдельно хотелось бы. Как меняют форму глагола. И какие падежи.

Если такого нет - дарю идею. Илона Давыдова "the next generation".

Для памяти. Спряжение немецких глаголов

Искал тут словарь.

Не помню куда я его засунул при переезде.

Потом "вспомнил", что 21й век на дворе и есть интернет.

Оказалось, что теперь и без словаря можно легко жить.

Вот:

http://www.babla.ru/спряжения/немецкий/wollen
http://www.babla.ru/спряжения/немецкий/
http://www.babla.ru/немецкий-русский/anzeige

вторник, 7 февраля 2017 г.

#1349. Ссылка. Статья про MVC

Статья про MVC. С разбором ошибок, отсылками к классике, выводами и рекомендациями.

Охота на мифический MVC. Обзор, возвращение к первоисточникам и про то, как анализировать и выводить шаблоны самому


— Не понимаю, почему люди так восхищаются этим Карузо? Косноязычен, гугнив, поёт — ничего не разберешь!
— А вы слышали, как поёт Карузо?
— Да, мне тут кое-что из его репертуара Рабинович напел по телефону.

https://habrahabr.ru/post/321050/

#1348. Ссылки на статьи про стековые фреймы

Связано вот с чем - http://programmingmindstream.blogspot.ru/2017/02/1346.html

http://www.gunsmoker.ru/2015/02/stack-frames.html

https://habrahabr.ru/company/smart_soft/blog/234239/

http://dic.academic.ru/dic.nsf/ruwiki/216673

https://ru.wikipedia.org/wiki/%D0%A1%D1%82%D0%B5%D0%BA%D0%BE%D0%B2%D1%8B%D0%B9_%D0%BA%D0%B0%D0%B4%D1%80

При таком обилии материала хочу всё же вскоре опубликовать свою статью. Такую "с объяснением на пальцах". Пока в процессе.

Там вообще "всё просто" - пара (EBP, ESP), но есть "детали".

четверг, 2 февраля 2017 г.

chkdsk in win10

#1347. Ссылка. TVirtualInterface

http://docwiki.embarcadero.com/CodeExamples/XE8/en/Rtti.TVirtualInterface_(Delphi)

Чудесная штука. На ней можно делать свои интерфейсы на стороне собственных скриптов. Ну или другой мета-информации. Сами они его для SOAP используют.

А мне рассказывали про собственную реализацию интерфейсов для Delphi на стороне Python'а.

(+) http://docwiki.embarcadero.com/Libraries/XE8/en/System.Rtti.TRawVirtualClass

Интересный такой код:

constructor TVirtualInterface.Create(PIID: PTypeInfo);
var
  Methods: TArray<TRttiMethod>;
  Method: TRttiMethod;
  Typ: TRttiType;
  MaxIndex, I: Integer;
begin
  FIntercepts := TObjectList<TImplInfo>.Create(True);
  Typ := FContext.GetType(PIID);
  FIID := TRttiInterfaceType(Typ).GUID;
                              
  Methods := Typ.GetMethods;
  MaxIndex := 2;  // Is this the best way to do this?
  for Method in Methods do
  begin
    if MaxIndex < Method.VirtualIndex then
      MaxIndex := Method.VirtualIndex;
    FIntercepts.Add(TImplInfo.Create(Method, RawCallBack));
  end;

  VTable := AllocMem(SizeOf(Pointer)* (MaxIndex+1));
  PVtablePtr(VTable)[0] := @TVirtualInterface._QIFromIntf;
  PVtablePtr(VTable)[1] := @TVirtualInterface._AddRefFromIntf;
  PVtablePtr(VTable)[2] := @TVirtualInterface._ReleaseFromIntf;
  for I := 0 to FIntercepts.Count-1 do
    PVtablePtr(VTable)[FIntercepts[I].VirtualIndex] := FIntercepts[I].CodeAddress;
  for I := 3 to MaxIndex do
    if PVtablePtr(VTable)[I] = nil then
      PVtablePtr(VTable)[I] := @TVirtualInterface.ErrorProc;
end;

constructor TVirtualInterface.Create(PIID: PTypeInfo;
  InvokeEvent: TVirtualInterfaceInvokeEvent);
begin
  Create(PIID);
  FOnInvoke := InvokeEvent;
end;

destructor TVirtualInterface.Destroy;
begin
  if VTable <> nil then
    FreeMem(VTable);
  FIntercepts.Free;
  inherited;
end;

procedure TVirtualInterface.RawCallback(UserData: Pointer;
  const Args: TArray<TValue>; out Result: TValue);
begin
  if Assigned(FOnInvoke) then
    FOnInvoke(TImplInfo(UserData).FMethod, Args, Result);
end;

procedure TVirtualInterface.ErrorProc;
begin
  raise InsufficientRtti;
end;

function TVirtualInterface._AddRefFromIntf: Integer;
begin
  Result := TVirtualInterface(PByte(Self) -
    (PByte(@Self.VTable) - PByte(Self)))._AddRef;
end;

function TVirtualInterface._ReleaseFromIntf: Integer;
begin
  Result := TVirtualInterface(PByte(Self) -
    (PByte(@Self.VTable) - PByte(Self)))._Release;
end;

function TVirtualInterface._QIFromIntf(const IID: TGUID; out Obj): HResult;
begin
  Result := TVirtualInterface(PByte(Self) -
    (PByte(@Self.VTable) - PByte(Self))).QueryInterface(IID, Obj);
end;

function TVIrtualInterface._AddRef: Integer;
begin
  Result := inherited
end;

function TVIrtualInterface._Release: Integer;
begin
  Result := inherited
end;

function TVirtualInterface.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
  if iid = FIID then
  begin
    _AddRef;
    Pointer(Obj) := @VTable;
    Result := S_OK;
  end
  else
    Result := inherited
end;

Прям руки чешутся это в реальных условиях попробовать.

А в SOAP оно используется тут:

  TRIO = class(TComponent, IInterface, IRIOAccess)
  private type
    TRioVirtualInterface = class(TVirtualInterface)
    private
      FRio: TRio;
    protected
//{$IFNDEF AUTOREFCOUNT}
      function _AddRef: Integer; override; stdcall;
      function _Release: Integer; override; stdcall;
//{$ENDIF !AUTOREFCOUNT}
    public
      constructor Create(ARio: TRio; AInterface: Pointer);
//{$IFNDEF AUTOREFCOUNT}
      function QueryInterface(const IID: TGUID; out Obj): HRESULT; override; stdcall;
//{$ENDIF !AUTOREFCOUNT}
    end;
  private
    FInterface: IInterface;

{$IFNDEF AUTOREFCOUNT}
    FRefCount: Integer;
{$ENDIF !AUTOREFCOUNT}

    { Headers }
    FSOAPHeaders: TSOAPHeaders;
    FHeadersOutBound: THeaderList;
    FHeadersInbound: THeaderList;

    FOnAfterExecute: TAfterExecuteEvent;
    FOnBeforeExecute: TBeforeExecuteEvent;
    FOnSendAttachment: TOnSendAttachmentEvent;
    FOnGetAttachment: TOnGetAttachmentEvent;

    procedure Generic(Method: TRttiMethod;
      const Args: TArray; out Result: TValue);

{$IFNDEF AUTOREFCOUNT}
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
{$ENDIF !AUTOREFCOUNT}

    { IRIOAccess }
    function GetRIO: TRIO;

  protected
    FIID: TGUID;
    IntfMD: TIntfMetaData;
    FConverter: IOPConvert;
    FWebNode: IWebNode;

    procedure DoDispatch(const Context: TInvContext; MethNum: Integer; const MethMD: TIntfMethEntry);
    function InternalQI(const IID: TGUID; out Obj): HResult; stdcall;

    { Routines that derived RIOs may override }
    procedure DoAfterExecute(const MethodName: string; Response: TStream); virtual;
    procedure DoBeforeExecute(const MethodName: string; Request: TStream); virtual;
    function  GetResponseStream(BindingType: TWebServiceBindingType): TStream; virtual;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    function QueryInterface(const IID: TGUID; out Obj): HResult; override; stdcall;
    { Behave like a TInterfacedObject, (only when Owner = nil) }
{$IFNDEF AUTOREFCOUNT}
    procedure AfterConstruction; override;
    procedure BeforeDestruction; override;
    class function NewInstance: TObject; override;

    property RefCount: Integer read FRefCount;
{$ENDIF !AUTOREFCOUNT}
    property Converter: IOPConvert read FConverter write FConverter;
    property WebNode: IWebNode read FWebNode write FWebNode;
    property SOAPHeaders: TSOAPHeaders read FSOAPHeaders;
  published
    property OnAfterExecute: TAfterExecuteEvent read FOnAfterExecute write FOnAfterExecute;
    property OnBeforeExecute: TBeforeExecuteEvent read FOnBeforeExecute write FOnBeforeExecute;
    property OnSendAttachment: TOnSendAttachmentEvent read FOnSendAttachment write FOnSendAttachment;
    property OnGetAttachment: TOnGetAttachmentEvent read FOnGetAttachment write FOnGetAttachment;
  end;

Тоже крайне забавно.

Самое, что смешное, что оно только там и используется. Хотя возможности для использования данного подхода - огромны.

Для всяческого "собственного маршалинга".

Ну и для ORM например. Хотя есть и другой путь. Несколько обратный:
http://18delphi.blogspot.ru/2013/07/blog-post.html
http://roman.yankovsky.me/?p=740

среда, 1 февраля 2017 г.

#1346. Draft of objects spy. Размышления. Заготовочка для следилки за объектами

https://bitbucket.org/lulinalex/mindstream/src/c3db0b6368040992e0f4eae64854d6e4ea34844a/Lab/RefCount/l3ObjectsSpy.pas?at=B284_Inheritance_Try&fileviewer=file-view-default

unit l3ObjectsSpy;

interface

procedure Test;

implementation

uses
 System.SysUtils
 , System.Classes
 , System.Generics.Collections
 , WinApi.Windows
 ;

type
 Tl3SpiedObjects = class(TList<Pointer>)
 end;//Tl3SpiedObjects

 Tl3ObjectsSpy = class(Tl3SpiedObjects)
  strict private
   class var g_Instance: Tl3ObjectsSpy;
  public
   class procedure LogNew(anObject: TObject);
   class procedure LogFree(anObject: TObject);
   class procedure HookClasses;
   class procedure CheckUnfreed;
 end;//Tl3ObjectsSpy

class procedure Tl3ObjectsSpy.LogNew(anObject: TObject);
begin
 if (g_Instance = nil) then
  g_Instance := Tl3ObjectsSpy.Create;
 g_Instance.Add(anObject);
end;

class procedure Tl3ObjectsSpy.LogFree(anObject: TObject);
begin
 if (g_Instance <> nil) then
  g_Instance.Remove(anObject);
end;

procedure DoHookClasses; forward;

class procedure Tl3ObjectsSpy.HookClasses;
begin
 DoHookClasses;
end;

class procedure Tl3ObjectsSpy.CheckUnfreed;
begin
 if (g_Instance <> nil) then
  if (g_Instance.Count > 0) then
   WriteLn(g_Instance.Count);
end;

type
 PMem = PAnsiChar;

function NewInstancePtr(aClass: TClass): PPointer;
begin
 Result := PPointer(PMem(aClass) + vmtNewInstance);
end;

function FreeInstancePtr(aClass: TClass): PPointer;
begin
 Result := PPointer(PMem(aClass) + vmtFreeInstance);
end;

procedure LogNew(anObject: TObject);
begin
 Tl3ObjectsSpy.LogNew(anObject);
end;

procedure LogFree(anObject: TObject);
begin
 Tl3ObjectsSpy.LogFree(anObject);
end;

type
 THackObject = class(TObject)
  public
   class function NewInstance: TObject; override;
   procedure FreeInstance; override;
 end;//THackObject

class function THackObject.NewInstance: TObject;
begin
 Result := inherited NewInstance;
 LogNew(Result);
end;

procedure THackObject.FreeInstance;
begin
 LogFree(Self);
 inherited FreeInstance;
end;

type
 THackInterfacedObject = class(TInterfacedObject)
  public
   class function NewInstance: TObject; override;
   procedure FreeInstance; override;
 end;//THackInterfacedObject

class function THackInterfacedObject.NewInstance: TObject;
begin
 Result := inherited NewInstance;
 LogNew(Result);
end;

procedure THackInterfacedObject.FreeInstance;
begin
 LogFree(Self);
 inherited FreeInstance;
end;

procedure HookPtr(aPointer: PPointer; aValue: Pointer);
var
 l_Old : DWORD;
 l_New : DWORD;
begin
 VirtualProtect(aPointer, SizeOf(Pointer), PAGE_EXECUTE_READWRITE, l_Old);
 try
  aPointer^ := aValue;
 finally
  VirtualProtect(aPointer, SizeOf(Pointer), l_Old, l_New);
 end;
end;

function HookPtrDone(aPointer: PPointer; aFrom: Pointer; aTo: Pointer): Boolean;
begin
 Result := (aPointer^ = aFrom);
 if Result then
  HookPtr(aPointer, aTo);
end;

function HookNew(aClass: TClass): Boolean;
var
 l_Ptr : PPointer;
begin
 Result := true;
 l_Ptr := NewInstancePtr(aClass);
 if HookPtrDone(l_Ptr, @TObject.NewInstance, @THackObject.NewInstance) then
  Exit;
 if HookPtrDone(l_Ptr, @TInterfacedObject.NewInstance, @THackInterfacedObject.NewInstance) then
  Exit;
 Result := false;
end;

function HookFree(aClass: TClass): Boolean;
var
 l_Ptr : PPointer;
begin
 Result := true;
 l_Ptr := FreeInstancePtr(aClass);
 if HookPtrDone(l_Ptr, @TObject.FreeInstance, @THackObject.FreeInstance) then
  Exit;
 if HookPtrDone(l_Ptr, @TInterfacedObject.FreeInstance, @THackInterfacedObject.FreeInstance) then
  Exit;
 Result := false;
end;

function HookClassPrim(aClass: TClass): Boolean;
begin
 Result := false;
 if HookNew(aClass) then
  Result := true;
 if HookFree(aClass) then
  Result := true;
end;

procedure HookClass(aClass: TClass);
var
 l_Class : TClass;
begin
 l_Class := aClass;
 while (l_Class <> nil) do
 begin
  if not HookClassPrim(l_Class) then
   Exit;
  l_Class := l_Class.ClassParent;
 end;//l_Class <> nil
end;

procedure DoHookClasses;
begin
 HookClass(TObject);
 HookClass(TStream);
 HookClass(TInterfacedObject);
 HookClass(TThread);
 HookClass(TComponent);
 //HookClass(TExternalThread);
end;

procedure Test;
var
 l_O : TObject;
 l_S : TStream;
 l_IO : TInterfacedObject;
 l_T : TThread;
begin
 //HookClasses;
 l_O := TObject.Create;
 FreeAndNil(l_O);

 l_S := TStream.Create;
 FreeAndNil(l_S);

 l_IO := TInterfacedObject.Create;
 FreeAndNil(l_IO);

 l_T := TThread.Create;
 FreeAndNil(l_T);
end;

initialization
 Tl3ObjectsSpy.HookClasses;
finalization
 Tl3ObjectsSpy.CheckUnfreed;
end.

(+) http://edn.embarcadero.com/article/28344

Вызывать CheckUnfreed в секции финализации на самом деле бессмысленно, т.к. могли ещё не вызваться другие секции финализации, в которых ещё не были освобождены объекты. И следилка покажет утечку, которой на самом деле нет.

Надо встраиваться в NotifyUnloadModule, который вызывается после всех секций инициализации. Я над этим сейчас работаю.

Ну и потокозащищённость надо конечно добавить.

Ну и ещё надо запоминать адрес места аллокации. Чтобы потом можно было найти по коду проблемное место. Это тоже делается достаточно просто.

Можно даже стек снять, но это сильно скажется на производительности.

Вскорости опубликую доработанную версию данного класса.

Ещё появилась мысль, что можно поставить Hook на классы своего приложения и включать его в ini-файле и в хуке звать методы из скриптов, которые можно править не останавливая приложения. Таким образом через подобные "разьёмы" снимать диагностику с классов реализации не останавливая и не перекомпилируя приложение.

Над этим я тоже работаю.

Update. Опробовал сегодня следилку "в боевых условиях".Даже с раскруткой стека. Удобно. Нашёл пару утечек. Скоро выложу обновлённый вариант.

#1345. Ни о чём. Размышления пока

Есть определённые мысли.
Пока изучаю:

TPrivateHeap
CodeHeap

function CodeHeap: TPrivateHeap;
var
  Temp: TPrivateHeap;
begin
  if FCodeHeap = nil then
  begin
    Temp := TPrivateHeap.Create;
    if AtomicCmpExchange(Pointer(FCodeHeap), Pointer(Temp), nil) = nil then
    // - интересный метод создания потокозащищённого синглетона. Если я правильно понял
      Pointer(Temp) := nil // For ARC-based platforms this will ensure the local var doesn't affect the refcount
      // - интересный "хак"
    else
      Temp.Free;
  end;
  Result := FCodeHeap;
end;

TMethodImplementation
TRttiMethod

Жаль не работает вот это:

type
 Tl3ObjectSpy<T: TObject> = class(T)

 end;//Tl3ObjectSpy

Интересно - почему написано так:

  ObjectAppearance := TCommonObjectAppearance(AppearanceClass.NewInstance);
  ObjectAppearance.Create;

А не так:

type
 RCommonObjectAppearance = clas of TCommonObjectAppearance;
  ObjectAppearance := RCommonObjectAppearance(AppearanceClass).Create;

{$IFDEF FireDAC_DEBUG}
class function TFDDatSRow.NewInstance: TObject {$IFDEF AUTOREFCOUNT} unsafe {$ENDIF};
begin
  Result := inherited NewInstance;
  Inc(GRowsAlive);
end;

{-------------------------------------------------------------------------------}
procedure TFDDatSRow.FreeInstance;
begin
  inherited FreeInstance;
  Dec(GRowsAlive);
end;
{$ENDIF}

vmtNewInstance
unit l3ObjectsSpy;

interface

procedure Test;

implementation

uses
 System.Classes
 ;

type
 PMem = PAnsiChar;

function NewInstancePtr(aClass: TClass): PPointer;
begin
 Result := PPointer(PMem(aClass) + vmtNewInstance);

end;
function FreeInstancePtr(aClass: TClass): PPointer;
begin
 Result := PPointer(PMem(aClass) + vmtFreeInstance);
end;

procedure TestClass(aClass: TClass);
begin
 WriteLn(NativeInt(NewInstancePtr(aClass)^));
 WriteLn(NativeInt(FreeInstancePtr(aClass)^));
end;

procedure Test;
begin
 TestClass(TObject);
 TestClass(TStream);
 WriteLn(vmtNewInstance);
end;

end.