Программирование -> Delphi / Pascal -> Обработка абстрактных методов в Delphi

-- Вот, Гнид, скажи мне, где живет абстрактный червяк?
-- Нигде. Или наоборот, всюду, -- не задумываясь ответил Гнидыч.

А.С. Шленский, Вкрадчивое прикосновение смерти

Исходные тексты тестового приложения AbstractCalc.zip
Инструкция по использованию тестового приложения ReadMe.txt

Введение

В языке Object Pascal, используемом средой разработки Delphi, существует механизм виртуальных конструкторов. Поклонникам C++ это кажется ужасной ересью, но виртуальные конструкторы очень удобны для создания экземпляров классов, которые еще не определены на этапе компиляции создающего кода. Такая технология позволяет разрабатывать компонентный код без необходимости реализации фабрик классов.

Оборотной стороной этой гибкости является возможность случайно создать экземпляр абстрактного класса, что впоследствии почти неизбежно приведет к вызову одного из абстрактных методов. Если в C++ вызов чисто виртуальной функции требует изрядной ловкости, и практически невозможно произвести его нечаянно, то в Delphi это достигается одним неосторожным движением. К сожалению, встроенные в Delphi механизмы обнаружения и обработки абстрактных методов предоставляют лишь минимум информации об источнике ошибки.

Эта статья посвящена реализации улучшенных механизмов обнаружения абстрактных методов и обработки их вызовов.

Виртуальные конструкторы

Концепция виртуальных конструкторов в Delphi тесно связана с существованием специального типа <ссылка на класс>. Совместное их использование позволяет создавать объекты классов, которые еще не существуют в момент компиляции кода, создающего экземпляр класса. Например, в стандартном классе TComponent объявлен виртуальный конструктор Create:

type
  TComponent = class(TPersistent)
  // Остальные объявления пропущены
  public
    constructor Create(AOwner: TComponent); virtual;
  // Остальные объявления пропущены
  end;

В сочетании со ссылкой на класс компонента:

type
  TComponentClass = class of TComponent;

это позволяет создавать любые компоненты, имея ссылку на их класс, даже если он разработан после компиляции следующего кода:

function CreateAComponent(AClass: TComponentClass; AOwner: TComponent): TComponent;
begin
  result:= AClass.Create(AOwner);
end;

Такая возможность является ключевой для работы механизма чтения форм из DFM-файлов и ресурсов. Кроме того, она может быть полезной и для пользовательского кода, который не связан напрямую с VCL. Наиболее популярные области применения подобной функциональности - это сериализация объектов и регистрация plug-in. Кроме этого, на основе этого механизма и RTTI в Delphi 6 реализованы веб-сервисы.

Абстрактные методы

Рассмотрим теперь следующий код:

type
  TAbstractObject = class
    constructor Create; virtual;
    procedure DoSomeJob; virtual; abstract;
  end;
  TAbstractClass = class of TAbstractObject;
  TAbstractObjectImpl = class(TAbstractObject)
    constructor Create; override;
    procedure DoSomeJob; override;
  end;

На первый взгляд, все в порядке. Есть абстрактный класс, который декларирует некую функциональность, и есть его потомок, реализующий эту функциональность. Мы предполагаем использовать это примерно таким образом:

proсedure CreateAndUse(AbstractClass: TAbstractClass)
begin
  with AbstractClass.Create do 
  begin
     DoSomeJob;
     Free;
  end;
end;

(Реальный код, конечно, будет несколько сложнее. Скорее всего, объекты будут создаваться в одном месте, а использоваться в другом, но суть дела это не меняет.)

В чем же проблема? А в том, что нерадивый прикладной программист запросто может передать в нашу процедуру в качестве параметра ссылку на абстрактный класс:

CreateAndUse(TAbstractObject);

Такой код вполне удачно скомпилируется. Что же произойдет во время работы приложения? Простейший эксперимент покажет, что результатом будет выдача исключения EAbstractError в момент вызова метода DoSomeJob.

Казалось бы, все в порядке: нарушитель пойман, справедливость восстановлена. Ан нет. EAbstractError - на редкость неинформативный класс. Он не предоставляет никакой информации о контексте и причине ошибки. Если вы - разработчик, и приложение выдало соответствующее сообщение, то у вас есть шанс потратить некоторое время на общение с отладчиком и пошаговое выполнение, чтобы отловить класс-нарушитель. Но если вы скомпилировали свою библиотеку без отладочной информации и исходных текстов, то прикладной программист сможет только гадать, что же он сделал не так.

Есть, конечно, весьма простой способ <обойти> проблему - никогда не объявлять абстрактных методов. VCL использует <пустые> определения методов сплошь и рядом. Однако это не путь для настоящих программистов. Хотя бы по той причине, что <пустая> реализация процедуры еще имеет какой-то смысл, но любая функция должна возвращать какое-то значение.

Более естественным способом является запрет на создание экземпляров абстрактных классов, как это сделано, например, в C++. Увы, компилятор Delphi ограничится предупреждением: "constructing instance of class : containing abstract methods" . Вывод этого предупреждения можно подавить соответствующими опциями компилятора.

Как правило, аккуратные программисты внимательно следят за предупреждениями, выдаваемыми компилятором. Но в ситуации, которая описана выше, <гром не грянет> и причин креститься у программиста не будет.

Тестовое приложение

Проиллюстрируем технику использования особенностей объектной модели Object Pascal на примере несложного приложения.

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

Для этого мы будем использовать механизм пакетов времени выполнения (runtime packages). Разработчик дополнительных операторов должен будет реализовать свой класс-наследник и включить его в пакет. Наше приложение будет сканировать текущую папку в поисках файлов с расширением .bpl и динамически загружать их в свое адресное пространство.

Для проверки концепции мы создадим пакет расширения, в котором реализуем два класса сложных целочисленных операторов: TPowerOp - оператор возведения в степень и TCnkOp - оператор количества сочетаний.

В классе TCnkOp мы <забудем> перекрыть один из абстрактных методов, объявленных в базовом классе. Мы убедимся, что стандартная обработка таких ошибок не дает никакой информации о причинах возникновения ошибки, и построим свою обработку так, чтобы можно было сразу определить, в каком классе и какой метод был оставлен абстрактным.

Получение дополнительной информации

Чтобы узнать больше о том, что привело к абстрактному вызову, необходимо разобраться с тем, как Delphi реализует обработку абстрактных методов.

Стандартный обработчик

Если протрассировать вызов абстрактного метода TAbstractObject.DoSomeJob, то выяснится интересная подробность: управление передается в системную процедуру _AbstractError:

procedure       _AbstractError;
asm
        CMP     AbstractErrorProc, 0
        JE      @@NoAbstErrProc
        CALL    AbstractErrorProc
@@NoAbstErrProc:
        MOV     EAX,210
        JMP     _RunError
end;

Эта процедура объявлена в секции implementation модуля System, то есть является недокументированной подробностью реализации Object Pascal и VCL. В ней проверяется, присвоено ли значение указателю AbstractErrorProc, и, если это так, то управление передается по этому адресу. Иначе приложение аварийно завершается с ошибкой 210. Если в проект включен модуль SysUtils (как правило, это так), то этому указателю будет присвоен адрес процедуры SysUtils.AbstractErrorHandler. Эта процедура и выбрасывает исключение EAbstractError, которое так мало говорит об источнике проблем.

Усовершенствованный обработчик

Из предыдущего раздела можно сделать два вывода:

1. Существует документированный способ зарегистрировать свой обработчик абстрактных вызовов.
2. Несмотря на то, что среда не передает в этот обработчик никаких параметров, функции, которые вызывают наш обработчик, никак не воздействуют на контекст вызова.

Последствия, вытекающие из второго вывода, значительно менее <безопасны>. Однако из него следует, что можно получить некоторую информацию о контексте, в котором произошла ошибка. Проще говоря, вывод 2 заявляет, что значение псевдопеременной self не изменилось и все еще доступно. Благодаря этому, мы можем произвести <подмену класса>. То есть, для того, чтобы отвлечься от способа, которым Delphi передает в методы указатель на объект, мы просто зарегистрируем в качестве обработчика адрес метода объекта:

type
  TAbstractHandler = class
  private
    procedure HandleAbstract; 
  end;
procedure TAbstractHandler.HandleAbstract;
begin
    raise EAbstractError.Create(self.ClassName);
end;
initialization
  AbstractErrorProc:= @TAbstractHandler.HandleAbstract;
end.

Обратите внимание на код процедуры TAbstractHandler.HandleAbstract - он генерирует исключение с именем класса в качестве текста сообщения. На первый взгляд кажется, что он всегда будет возвращать строку "TAbstractHandler", но это не так. Дело в том, что мы вызвали метод TAbstractHandler.HandleAbstract на объекте совсем другого класса! Фактически выполняющийся код очень похож на вот такой:

var
  A: TAbstractObject;
begin
  A:= TAbstractObject.Create;
  TAbstractHandler(A).HandleAbstract;
end;

В таком примере текст исключения будет содержать "TAbstractObject". Обычно подобные вызовы приводят к ошибкам, но при соблюдении некоторых правил они вполне безопасны. <Пессимистическая> версия этих правил такова: вызывать <чужой> метод можно только в том случае, если он пользуется только полями и методами общего предка <своего> и <чужого> класса. На практике свободы больше, но для нашего случая ее уже вполне достаточно. Метод HandleAbstract пользуется только методом ClassName, доступным в TObject, который гарантированно является предком всех классов Delphi.

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

Раннее упреждение

Чтобы предотвратить создание экземпляров абстрактных классов, надо, прежде всего, ответить на вопрос: <является ли данный класс абстрактным?>. Ответ на этот вопрос прост: <класс является абстрактным, если он содержит абстрактные методы>. Сама Delphi не содержит встроенных средств для проверки методов на абстрактность, поэтому такие средства придется изобрести самостоятельно.

Чтобы узнать, абстрактен ли метод класса, придется немного покопаться в темных глубинах модуля System при помощи пошаговой отладки. Как мы уже знаем из предыдущего раздела, попытка вызвать абстрактный метод приводит нас в процедуру _AbstractError. Теперь нам необходимо проследить путь, ведущий в эту процедуру.

Исследования структуры таблицы виртуальных методов (VMT), создаваемой компилятором, и RTTI вообще, являются интереснейшим процессом, который может доставить любознательному разработчику массу удовольствия. Для тех же, кто не хочет терять время на препарирование системного кода Delphi, я привожу необходимую информацию в готовом к употреблению виде.

Структура классов Delphi

Устройство данных, размещенных по адресу, задаваемому TClass, является деталью реализации, скрытой от программиста. Относительно безопасно можно делать следующее:

• Сравнивать ссылки на класс для проверки типа объекта.
• Вызывать методы класса.
• Вызывать конструкторы.

К сожалению, этой функциональности недостаточно для поиска абстрактных методов. Для такого поиска нам придется заглянуть <под капот> класса, а именно - посмотреть, как работает метод TObject.ClassType. Реализация, конечно, может меняться от версии к версии. В Delphi 5 код предельно лаконичен:

function TObject.ClassType: TClass;
asm
        mov     eax,[eax]
end;

Delphi 6 не вносит ничего нового, хотя тот же код на Паскале читается легче, чем на ассемблере:

function TObject.ClassType: TClass;
begin
  Pointer(Result) := PPointer(Self)^;
end;

Итак, этот метод возвращает адрес, на который указывают самые первые четыре байта в теле объекта. Нам это вряд ли помогло бы, если бы не знание о совместимости Delphi с COM. Как известно, структура COM-объектов строго стандартизована. В начале объекта должен быть расположен указатель на VMT. Дополнительным подтверждением этому служат константы с именами, начинающимися на vmt*, определенные в модуле System:

{Virtual method table entries }

  vmtSelfPtr           = -76;
  vmtIntfTable         = -72;
  vmtAutoTable         = -68;
  vmtInitTable         = -64;
  vmtTypeInfo          = -60;
  vmtFieldTable        = -56;
  vmtMethodTable       = -52;
  vmtDynamicTable      = -48;
  vmtClassName         = -44;
  vmtInstanceSize      = -40;
  vmtParent            = -36;
  vmtSafeCallException = -32;
  vmtAfterConstruction = -28;
  vmtBeforeDestruction = -24;
  vmtDispatch          = -20;
  vmtDefaultHandler    = -16;
  vmtNewInstance       = -12;
  vmtFreeInstance      = -8;
  vmtDestroy           = -4;

  vmtQueryInterface    = 0;
  vmtAddRef            = 4;
  vmtRelease           = 8;
  vmtCreateObject      = 12;

Как интересно! Часть из них меньше нуля. Судя по именам констант, вплоть до vmtAfterConstruction (смещение -28) расположены указатели на различные интересные данные. Затем идут указатели на виртуальные методы, декларированные в самом TObject: AfterConstruction, BeforeDestruction, Dispatch, DefaultHandler, NewInstance, FreeInstance, Destroy. Затем идут методы с неотрицательными смещениями. Таким образом, указатель, расположенный в начале объекта, ссылается куда-то <в середину> VMT. И эта середина - ровно то место, с которого будут располагаться виртуальные методы, объявленные в классах-потомках. Из названий констант vmtQueryInterface, vmtAddRef и vmtRelease ясно, зачем так сделано - иначе в потомках TObject было бы невозможно реализовать интерфейс IUnknown.

Итак, 4 байта, полученных при вызове TObject.ClassType, указывают в начало таблицы виртуальных методов, декларированных в потомках TObject. Этот вывод можно считать <безопасным> до тех пор, пока Delphi поддерживает совместимость с COM.

Абстрактные методы

Как нам уже известно, выполнение абстрактного вызова приводит нас в магическую процедуру System._AbstractError. Осталось понять, как это происходит. Внимательная трассировка покажет нам со всей неизбежностью, что адрес этой процедуры записывается в те позиции VMT, которые соответствуют абстрактным методам. Таким образом, для любой заданной позиции в VMT можно узнать, реализован ли соответствующий ей метод, сравнив ее значение с адресом процедуры _AbstractError.

К сожалению, авторы Delphi позаботились поместить эту процедуру в секцию implementation модуля System, запретив, таким образом, явное получение ее адреса.

Конечно, такая мелочь не может остановить настоящих программистов. Получить адрес этой процедуры можно при помощи любого абстрактного метода. Чтобы не зависеть ни от кого, достаточно объявить свой класс с абстрактным методом, и взять адрес метода из VMT. Чтобы не умножать сущностей, разместим весь требуемый код в одном классе:

type
  TAbstractHandler = class
  private
    class procedure AbstractProc; virtual;abstract;
  public
    class function AbsProcAddress: Pointer;
  end;
class function TAbstractHandler.AbsProcAddress: Pointer;
var
  TAP: procedure of object;
begin
    TAP:= self.AbstractProc;
    Result:= TMethod(TAP).Code;
end;

Этот код требует некоторых пояснений.

Во-первых, наша процедура AbstractProc объявлена методом класса - это сделано для того, чтобы получить ее адрес без создания экземпляра класса TAbstractHandler. Это не влияет на структуру VMT - методы класса устроены точно так же, только у них self указывает на класс, а не на объект.

Во-вторых, для получения адреса используется временная переменная типа procedure of object - указатель на метод. Это самый простой способ вынудить Delphi реально прочитать адрес метода из VMT - попытки взять адрес метода при помощи оператора @ не приведут к желаемому результату. Вместо адреса _AbstractProc будет получен адрес специально сгенерированного псевдометода, который состоит только из инструкции JMP на все тот же адрес _AbstractProc. Судя по всему, этот псевдометод нужен для того, чтобы компилятор мог встроить его вызов в случаях, когда он точно знает класс объекта. В таких ситуациях Delphi не делает косвенного вызова, а подставляет сразу абсолютный адрес метода.

Получив указатель на метод класса в переменной TAP, мы выделяем из него указатель на код при помощи документированного приведения к типу SysUtils.TMethod.

Однако эти эксперименты мы проводили над классом, который скомпилирован, как часть нашего приложения. В нашем же примере часть классов расположена в отдельном пакете, который компилируется в отдельный файл-библиотеку. Будет ли происходить вызов той же _AbstractProc из таких классов? И если будет, то как?

Для получения ответа на эти вопросы необходимо знать о том, как Delphi реализует динамически подключаемые пакеты компонентов. Подробное рассмотрение этой темы выходит за пределы данной статьи. Поэтому я сразу предоставлю здесь результат, пропустив описание своих исследований .bpl-файлов.

Да, Delphi строго следит за тем, чтобы в приложение нельзя было загрузить две версии одного и того же модуля в разных пакетах. То есть мы можем быть уверены, что любой абстрактный вызов приведет нас в единственную _AbstractProc. Для этого он пользуется механизмом таблиц импорта, предоставленным форматом PE-файлов Windows. На практике это означает, что соответствующая позиция в VMT будет указывать на фрагмент кода (thunk) следующего вида:

jmp dword ptr[addr];

Здесь addr - это адрес слота в таблице импорта. По этому адресу лежит настоящий адрес метода. Данная информация позволяет написать код, который сможет отличать указатели на <настоящие> методы от указателей на импортированные методы. Вот этот код:

class function TAbstractHandler.UnThunkImport(Addr: pointer): pointer;
begin
  Result:=Addr;
  if Word(Addr^) = $25FF // это команда косвенного перехода (jmp)
    then Result:= PPointer(PPointer(Integer(Addr)+2)^)^;
end;

Соответственно этому, мы все указатели на код, который потенциально может быть импортирован, будем прогонять через этот метод. В частности, придется слегка модифицировать TAbstractHandler.AbsProcAddress:

class function TAbstractHandler.AbsProcAddress: Pointer;
var
  TAP: procedure of object;
begin
    TAP:= self.AbstractProc;
    Result:= UnThunkImport(TMethod(TAP).Code);
end;

Итак, у нас есть образец позиции в VMT, которая соответствует абстрактным методам.

Теперь можно оборудовать наш класс методом проверки на абстрактность:

class function TAbstractHandler.IsMethodAbstract(Method: Pointer): Boolean;
begin
  result := UnThunkImport(Method) = AbsProcAddress;
end;

Абстрактные классы

Теперь мы легко можем проверить любой указатель на предмет совпадения с адресом абстрактного метода. Однако эта возможность мало поможет в ловле ошибок, т.к. нам придется явно проверять все подозрительные методы. Возникает естественное желание реализовать способ проверки всего класса на абстрактность.

Идея такой проверки кажется очевидной: мы уже умеем получать адрес первой позиции в VMT, и достаточно пройти по всей таблице в поисках магического адреса.

Чтобы это сделать, нужно как-то определить адрес конца VMT. Никаких стандартных способов это сделать не существует. Я потратил довольно много времени на анализ окрестностей VMT, но обнаружил только то, что в Delphi 5 различные RTTI-данные, относящиеся к классу, расположены в непосредственной близости от VMT. В частности, таблица имен полей, таблица имен методов, таблица динамических методов, имя класса, и информация о типе идут после VMT именно в порядке перечисления. А таблица интерфейсов, реализуемых классом, обычно расположена до начала VMT.

Это не слишком-то надежные предположения, так что для определения конца VMT мы будем использовать наименьший из указателей, хранящихся в документированных полях VMT:

vmtIntfTable
vmtAutoTable
vmtInitTable
vmtTypeInfo
vmtFieldTable
vmtMethodTable
vmtDynamicTable
vmtClassName

При этом мы будем проверять, что значения этого указателя больше адреса VMT:

function GetVMTEnd(AClass: TClass): Pointer;
var
  VMT, Start, Finish: PPointer;
begin
  TClass(VMT):= AClass;
  Start:= VMT; Inc(Start, vmtIntfTable);
  Finish:= VMT; Inc(Finish,vmtClassName);
  Result:= Ptr($7FFFFFFF);
  while Integer(Finish) > Integer(Start) do
  begin
    if (Integer(Start^) > Integer(VMT)) 
        and (Integer(Start^) < Integer(Result))
      then Result:= Start^;
    Inc(Start);
  end;
end;

После определения адресов начала и конца VMT проверка всех методов класса на абстрактность является тривиальной задачей. Осталось только добавить в наш код различные украшения типа определения класса-предка, в котором был декларирован абстрактный метод, форматирования текстов исключений по вкусу и так далее.

Заключение

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

Во-первых, мы получаем интерфейс для явной проверки методов и классов на абстрактность. Я рекомендую встраивать вызов проверки класса на абстрактность в конструкторы пользовательских классов, которые предполагается создавать динамически (например, компонентов).

Во-вторых, наш класс зарегистрирует обработчик, который будет не только определять имя класса, на объекте которого был произведен абстрактный вызов, но и выполнять поиск абстрактных методов в этом классе.

Полный исходный код модуля приведен в файле

unit AbstractHandler;
// версия 2.0 - добавлена поддержка классов в DLL
// version 1.01b - исправлена реализация GetVMTEnd
interface
type
  // информация о виртуальном методе
  TMethodInfoRec = record
    ClassType: TClass; // класс, в котором декларирован метод
    VMTIndex: cardinal; // номер слота в VMT
  end;
  TMIRArray = array of TMethodInfoRec;

  TAbstractHandler = class
  private
    // замена стандартному обработчику абстрактных вызовов
    procedure HandleAbstract;
    // используем для получения адреса, хранящегося в VMT
    class procedure AbstractProc; virtual;abstract;
    // поиск класса-предка, в котором был декларирован заданный абстрактный метод
    class function GetFirstDeclarator(AClass: TClass; VMTIndex: integer): TClass;
  protected
    // вспомогательная функция для подготовки текста исключения
    // при форматировании для каждого метода в FormatStr подставляются:
    // - строка: имя класса
    // - число: номер слота VMT
    // полученные строки конкатенируются.
    class function FormatAbstractInfos(const Abstracts: Array of TMethodInfoRec;
      const FormatStr: String = 'Introduced in: %s; VMT: %d'#10#13): String;
  public
    // возвращает имя пакета, в котором декларирован указанный класс
    class function GetClassPackageName(AClass: TClass): String;
    // возвращает имя юнита, в котором декларирован указанный класс
    // возвращает Unknown, если в классе нет RTTI информации (см. доку по $M)
    class function GetClassUnitName(AClass: TClass): String;
    // возвращает истинный адрес функции, импортированной из DLL/BPL
    // Если Addr указывает на код, а не на импорт, то возвращаем Addr без изменений
    class function UnThunkImport(Addr: pointer): pointer;
    // возвращает адрес, записываемый в VMT для абстрактных методов
    class function AbsProcAddress: Pointer;
    // проверяет, является ли указанный метод абстрактным
    class function IsMethodAbstract(Method: Pointer): Boolean;
    // ищет абстрактные методы в VMT заданного класса. Возвращает истину,
    // если хоть один найден. Список найденных методов записывается в Abstracts
    class function DetectAbstracts(AClass: TClass; out Abstracts: TMIRArray): boolean;
    // бросает исключение, если в классе есть абстрактные методы
    class procedure AssertNonAbstract(AClass: TClass);
  end;


implementation
uses SysUtils, TypInfo, Windows;
var
  AbsProc: Pointer;
type PPointer = ^Pointer;

class function TAbstractHandler.AbsProcAddress: Pointer;
var
  TAP: procedure of object;
begin
  if not Assigned(AbsProc)
  then begin
    TAP:= self.AbstractProc;
    AbsProc:= UnThunkImport(TMethod(TAP).Code);
  end;
  Result:= AbsProc;
end;

class procedure TAbstractHandler.AssertNonAbstract(AClass: TClass);
var
  Abstracts: TMIRArray;
begin
   if DetectAbstracts(AClass, Abstracts)
    then raise EAbstractError.CreateFMT('Class %s (Unit: %s; package: %s) contains the following abstract methods:'#10#13
     +FormatAbstractInfos(Abstracts), [AClass.ClassName, GetClassUnitName(AClass), GetClassPackageName(AClass)]);
end;

// ищет адрес последней позиции в VMT
function GetVMTEnd(AClass: TClass): Pointer;
var
  VMT, Start, Finish: PPointer;
begin
  TClass(VMT):= AClass;
  Start:= VMT; Inc(Start, vmtIntfTable shr 2);
  Finish:= VMT; Inc(Finish,vmtClassName shr 2);
  Result:= Ptr($7FFFFFFF);

  while Integer(Start) <= Integer(Finish) do
  begin
    if (Integer(Start^)>Integer(VMT)) and (Integer(Start^) < Integer(Result))
      then Result:=Start^;
    Inc(Start);
  end;
end;
// Ищет класс-предок, в котором впервые заполнен заданный слот VMT
class function TAbstractHandler.GetFirstDeclarator(AClass: TClass; VMTIndex: integer): TClass;
var
  VMTEntry: PPointer;
begin
  Result:= AClass;
  while True do
  begin
    TClass(VMTEntry):= Result.ClassParent;
    Inc(VMTEntry, VMTIndex);
    // Если в предке этот слот уже заполнен, то он тоже
    // содержит AbsProcAddress:
    if (VMTEntry^)=AbsProcAddress
      then Result:= Result.ClassParent
      else Exit;
  end;
end;

class function TAbstractHandler.DetectAbstracts(AClass: TClass;
  out Abstracts: TMIRArray): boolean;
var
  VMT: PPointer;
  VMTEnd: Pointer;
begin
  TClass(VMT):= AClass;
  VMTEnd:=GetVMTEnd(AClass);

  SetLength(Abstracts, 0);
  while (VMT<>VMTEnd) // Сканируем VMT
  do begin
    if IsMethodAbstract(VMT^)
    then begin
      SetLength(Abstracts, Length(Abstracts)+1); // Добавляем запись
      with Abstracts[High(Abstracts)] do
      begin
        VMTIndex:= (Integer(VMT)-Integer(AClass)) shr 2; // размер слота - 4 байта
        ClassType:= GetFirstDeclarator(AClass, VMTIndex);
      end;
    end;
    Inc(VMT);
  end;
  Result:= Length(Abstracts)>0; // Сигнализируем, успешен ли поиск.
end;

class function TAbstractHandler.FormatAbstractInfos(
  const Abstracts: array of TMethodInfoRec;
  const FormatStr: String): String;
var
  i: integer;
begin
  Result:='';
  for i:= Low(Abstracts) to High(Abstracts) do
    with Abstracts[i] do
      Result:= Result+Format(FormatStr, [ClassType.ClassName, VMTIndex]);
end;
// наш обработчик выполняет детектирование всех абстрактных методов
procedure TAbstractHandler.HandleAbstract;
begin
  AssertNonAbstract(ClassType);
end;

class function TAbstractHandler.IsMethodAbstract(Method: Pointer): Boolean;
begin
  result:= UnThunkImport(Method)=AbsProcAddress;
end;

class function TAbstractHandler.UnThunkImport(Addr: pointer): pointer;
begin
  Result:=Addr;
  if Word(Addr^) = $25FF // это команда косвенного jmp
    then Result:= PPointer(PPointer(Integer(Addr)+2)^)^;
end;

class function TAbstractHandler.GetClassPackageName(
  AClass: TClass): String;
var
  M: TMemoryBasicInformation;
begin
  // Определяем хэндл DLL, которая владеет классом
  VirtualQuery(AClass, M, sizeof(M));
  SetLength(Result, MAX_PATH+1);
  if HMODULE(M.AllocationBase) <> HInstance // Если это не главная программа
  then begin
    GetModuleFileName(HMODULE(M.AllocationBase), PChar(Result), MAX_PATH);
    SetLength(Result, StrLen(Pchar(Result)));
    Result:= ExtractFileName(Result);
  end
  else
    Result:= 'Main Program';
end;

class function TAbstractHandler.GetClassUnitName(AClass: TClass): String;
var
  C: Pointer;
begin
  Result:= 'Unknown';
  C:= AClass.ClassInfo;
  if Assigned(C)
    then Result:= GetTypeData(C).UnitName;
end;

initialization
  AbsProc:= Nil; // Эта переменная использется для назначительной оптимизации
  // Устанавливаем наш обработчик:
  AbstractErrorProc:= Addr(TAbstractHandler.HandleAbstract);
  // Инициализируем указатель - иначе будет плохо
  TAbstractHandler.AbsProcAddress;
end.

Достаточно добавить его в любой проект, и сообщения об абстрактных вызовах станут значительно более информативными.

Единственным улучшением, которое я бы внес в код обработчика абстрактных вызовов, является корректировка обработки абстрактных методов класса. Как я уже говорил, данная методика предполагает, что в переменной self хранится указатель на объект, и скорее всего приведет к AV, если на самом деле там хранится указатель на класс. Есть идея реализовать пару функций:

function IsClassReference(Pointer): Boolean;
function IsObjectReference(Pointer): Boolean;

основываясь на предположении о том, что в корректной VMT по смещению vmtSelfPtr должен лежать адрес ее начала:

(VMT + vmtSelfPtr)^ = VMT

Проверку этой гипотезы и усовершенствование кода я оставляю читателям.

Проверка боем

Проверим работоспособность созданного обработчика на нашем примере. Архив AbstractCalc.zip содержит две версии приложения: SuperCalc.dpr - это первоначальный вариант. SmartCalc.dpr получен из него путем добавления AbstractHandler.pas.

При запуске первой версии калькулятора попытка выбрать из списка оператор количества сочетаний приводит к появлению следующего сообщения:

Рисунок 1: Краткость - сестра таланта

Улучшенная версия сможет рассказать об ошибке более подробно:

Рисунок 2: Действие 'сыворотки правды' на приложение-пример

Из этого сообщения сразу видно, что виноват класс TCnkOp, содержащийся в пакете Power.bpl. В нем не переопределен один абстрактный метод, декларированный в классе TAbstractCalcPlugin. Этот метод был декларирован третьим (нумерация слотов у нас начинается с нуля). От моего представления об идеале это сообщение отличает только отсутствие ссылки на строку исходного файла, в которой был задекларирован данный метод, и имени метода. Увы, в Delphi вплоть до седьмой версии такую информацию получить невозможно.

Автор: Антон Злыгостев
Источник: www.rsdn.ru