Форум: "KOL";
Текущий архив: 2003.07.21;
Скачать: [xml.tar.bz2];

Вниз

KOLActiveX   Найти похожие ветки 

← →
Fantasist   (2002-11-17 08:12) [0]

В связи с возникшим вопросом, предлагаю свое решение для обеспечения поддержки COM. Пока только основа.


unit KolActiveX;

interface
uses
windows,kol;

const
IUnknown_IID:TGUID="{00000000-0000-0000-C000-000000000046}";
IClassFactory_IID:TGUID="{00000001-0000-0000-C000-000000000046}";

type

//Interfaces

IUnknown = object
public
QueryInterface:function(const IID: TGUID; out Obj): HResult; stdcall;
AddRef:function:HResult; stdcall;
Release:function:HResult; stdcall;
end;
PIUnknown=^IUnknown;

InterfaceSet=packed record
_vmt:pointer; //таблица виртуальных методов для интерфейса
this:pointer; //указатель на экземпляр класса, которому интерфейс принадлежит
end;
PInterfaceSet=^InterfaceSet;


IClassFactory = object(IUnknown)
CreateInstance:function(const unkOuter: pointer; const iid: TGUID; out obj): HResult; stdcall;
LockServer:function(fLock: boolean): HResult; stdcall;
end;
PIClassFactory=^IClassFactory;

TInterfaceEntry=packed record
GUID:TGUID;
p:PInterfaceSet;
end;
PInterfaceEntry=^TInterfaceEntry;


TInterfacedObj=object(TObj)
private
//таблица интерфейсов. Фактически, динамический массив из TInterfaceEntry
fInterfaceTable:PInterfaceEntry;
fInterfaceCount:Integer;
//таблица для интерфейса IUnknown
fIUnknown:IUnknown;
fRefCount:Integer;
private
//IUnknown
function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
function AddRef:Longint; stdcall;
function Release:Longint; stdcall;
protected
procedure SetInterfaceTable; virtual;
public
procedure Init; virtual;
procedure AddInterface(IID:TGUID; Ifc:PIUnknown);
function GetInterface(IID:TGUID; out Obj):boolean;
end;
PInterfacedObj=^TInterfacedObj;



implementation

function GUIDComp(GUID1,GUID2:TGUID):boolean;
var
i:integer;
begin
for i:=0 to 7 do
if GUID1.D4[i]<>GUID2.D4[i] then
begin
Result:=false;
exit;
end;
Result:=True and (GUID1.D1=GUID2.D1) and (GUID1.D2=GUID2.D2) and (GUID1.D3=GUID2.D3);
end;

{ TInterfacedObj }

procedure TInterfacedObj.AddInterface(IID: TGUID; Ifc: PIUnknown);
var
tmp:PInterfaceEntry;
begin
if GetInterface(IID,tmp) then
exit;

Inc(fInterfaceCount);
//выделяем новый блок памяти(на один болше) и копируем в него содержимое старого
GetMem(tmp,SizeOf(TInterfaceEntry)*fInterfaceCount);
if fInterfaceTable<>nil then
begin
Move(fInterfaceTable^,tmp^,SizeOf(TInterfaceEntry)*(fInterfaceCount-1));
FreeMem(fInterfaceTable);
end;
fInterfaceTable:=tmp;
//в новую выделенную запись записываем новый интерфейс
inc(tmp,fInterfaceCount-1);
tmp^.GUID:=IID;
New(tmp^.p);
tmp^.p^._vmt:=Ifc;
tmp^.p^.this:=@self;
end;

function TInterfacedObj.AddRef: Longint;
begin
asm
mov eax,ebp
add eax,$08
mov edx,[eax]
add edx,$04
mov edx,[edx]
mov [eax],edx
end;
Result := InterlockedIncrement(FRefCount);
end;

function TInterfacedObj.GetInterface(IID: TGUID; out Obj): boolean;
var
Entry:PInterfaceEntry;
i:integer;
begin
Result:=false;
Entry:=fInterfaceTable;
for i:=1 to fInterfaceCount do
begin
if GUIDComp(Entry^.GUID,IID) then
begin
Result:=True;
Pointer(Obj):=Entry^.p;
exit;
end;
inc(Entry);
end;
end;

procedure TInterfacedObj.Init;
begin
fInterfaceTable:=nil;
fInterfaceCount:=0;

fRefCount:=0;
SetInterfaceTable;
end;

function TInterfacedObj.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
asm
mov eax,ebp
add eax,$08
mov edx,[eax]
add edx,$04
mov edx,[edx]
mov [eax],edx
end;
if GetInterface(IID,Obj) then
begin
InterlockedIncrement(FRefCount);
Result:=S_OK;
end
else
Result:=E_NOINTERFACE;
end;

function TInterfacedObj.Release: Longint;
begin
asm
mov eax,ebp
add eax,$08
mov edx,[eax]
add edx,$04
mov edx,[edx]
mov [eax],edx
end;
Result := InterlockedDecrement(FRefCount);
if Result = 0 then
Dispose(@self);
end;

procedure TInterfacedObj.SetInterfaceTable;
begin
//заполняем таблицу
with fIUnknown do
begin
QueryInterface:=@TInterfacedObj.QueryInterface;
AddRef:=@TInterfacedObj.Addref;
Release:=@TInterfacedObj.Release;
end;
AddInterface(IUnknown_IID,@fIUnknown);
end;

end.


---

← →
Fantasist   (2002-11-17 08:46) [1]

Итак. Идея такая: для каждого интерфейса, который мы хотим поддерживать, заводим переменную (пока у нас только IUnknown), в которую заносим указатели на методы нашего класса. Метод SetInterfaceTable служит для этого. Он сделан виртуальным, чтобы каждый потомок мог проинициализировать свои интерфейсы. С помощью метода AddInterface адрес переменной заноситься в таблицу интерфейсов, вместе с ассоциированным с ним GUID. Метод GetInterface находит соответсвующую таблицу по GUID.

В чем ключевая проблема? Проблема в том, что по стандарту интерфейс должен выглядить так:

<Объект>
_vmt -> Method1
Method2
Method3

Клиент получает указатель на <Объект>.Положим, что он вызывает
IUnknown.AddRef. Метод вызывается так:


var
vmt:pointer;
AddRef:function (Self:pointer):HResult;
begin
vmt:=IUnknown^; //получаем значение указателя на таблицу методов
AddRef:=Pointer(Integer(vmt^)+4)) //+4 смещение для метода AddRef
AddRef(IUnknown); //в качестве указателя на экземпляр передаем указатель на интерфейс.
end;


В моем методе, в качестве указателя на интерфейс мы передаем указатель на объект-подставу, искуственно созданный объект в котором мы сами сделали указатель на таблицу виртуальных методов (этот обект у меня типа TInterfaceEntry). Понятно, что когда вызовется объект AddRef, ему в качестве self передастся указатель на этот фиктивный объект. Тут-то и хитрость, что нам надо перезаписать self правильным значением. Для этого, фиктивный объект содержит содержит переменную this, в которую мы предусмотрительно записали правильное значение self. Код на асме в каждом методе как раз и занимается тем, что перезаписывает self этим значением, чтобы далее метод мог работать нормально.
Вот это самый кривой момент. В асме я ноль точка, еше много нулей с завершаю где-то еденицей, так что код наверняка на нем написан плохо. Но это не столь важно, главное то, что в каждом методе, который принадлежит интерфейсу, придется вставлять такой код. В паскале нет даже макроподстановок, чтобы можно было записать такую вещь в одну простую строчку. Более того, эти методы можно будет вызывать ТОЛЬКО через интерфейсы, иначе получиться непойми что.
Надеюсь, что талантливый народ сможет чего-нибудь придумать по этому поводу. :) У меня и у самого есть идейка, но не продуманная пока.

---

← →
Fantasist   (2002-11-17 10:24) [2]

Тьфу! Совсем забыл записать освобождение памяти из под таблицы интерфейсов. Но это не тяжело, суть не в этом.

---

Страницы: 1 вся ветка

Форум: "KOL";
Текущий архив: 2003.07.21;
Скачать: [xml.tar.bz2];

Наверх

Память: 0.47 MB
Время: 0.007 c