Текущий архив: 2005.03.13;
Скачать: CL | DM;

Вниз

деректива message   Найти похожие ветки 

← →
JaDS ©   (2005-01-28 17:22) [0]

Опишу задачу:
Хочу создать свою библиотеку на подобии VCL (тортами не кидаться, знаю что идея попсовая, но мне надо не аналог VCL, а лишь несколько компонентов часто мною используемые).

Как я это делаю (пример):

TForm = object
public
 Create...
 Destroy...
end;


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

Теперь сам ворос:
если я допишу в своё определение типа строчку:

procedure WMPaint(var Message: TWMPaint); message WM_PAINT;

то как заставить её вызываться???

Наблюдения:
Если ту же самую строчку добавить в VCL"овский тип TForm, то вызов этой процедуры происходит из процедуры TControl.WndProc >>> TObject.Dispatch

PS:
вообще кто нибудь представляет механизм работы дерективы message???

---

← →
Digitman ©   (2005-01-28 17:28) [1]

> тортами не кидаться


чей-то сразу "тортами" ? а навозом в торцевую часть репы не желаете ли ?) .. гораздо ощутимей, скажу я Вам )..


> вообще кто нибудь представляет механизм работы дерективы
> message


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

и сводится он к call [РОН + оффсет]

---

← →
JaDS ©   (2005-01-28 17:36) [2]

2Digitman:
вообще то вопрос был "как заставить её вызываться???" а не про торты...

уточню проблему:

procedure TForm.Create;
var
 wc: TWndClassExW;
 ...
begin
 ...
 wc.lpfnWndProc:=???
 ...
end;

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

>оч многие ув.коллеги оч даже четко себе сей механизм предствляют
и они даже смогут привести рабочий пример?

---

← →
PVOzerski ©   (2005-01-28 18:08) [3]

>и они даже смогут привести рабочий пример?
Кидания тортом в репу? :^)

Если серьезно, посмотри описание tObject.Dispatch и tObject.DefaultHandler.

---

← →
PVOzerski ©   (2005-01-28 18:22) [4]

Уточняю: если вызвать Dispatch и передать ему tMessage, будет вызван соответствующий метод этого объекта. Когда я пытался написать сабж для FreePascal (где-то дома нечто недоделанное так и валяется), я вызывал Dispatch из WndProc своих винконтролов, а этот WndProc вызывал из оконного callback"а. Чтобы добраться до адреса объекта, загонял его в класс окошка через SetWindowLong по смещению GWL_USERDATA а при вызове CallBack"а извлекал обратно через GetWindowLong. Замечу, что в настоящей VCL это всё сделано не так. Но работал и такой способ. Правда, стОит подумать, как избежать возможных проблем с разными нитями в моменты "прикрепления" объекта к окну.

---

← →
PVOzerski ©   (2005-01-28 18:24) [5]

В догонку: забыл, как называется ветка, аоэтому под "сабжем" имел в виду "свою библиотеку наподобие VCL".

---

← →
JaDS ©   (2005-01-29 03:08) [6]

>Чтобы добраться до адреса объекта, загонял его в класс окошка
>через SetWindowLong по смещению GWL_USERDATA а при вызове
>CallBack"а извлекал обратно через GetWindowLong.

я сам хотел делать что-то похожее, только это как-то всё неправильно чтоли, не лежит "душа" к такому, вот поэтому и назрел вопрос - как тоже самое делается с помощью дерективы message - никак не пойму что она делает. Верней я понимаю что если добавить её к потомку TControl, то она попадёт в цикл обработки оконных сообщений, но как их туда делфи вставляет - непонимаю, если можно - механизм работы этой дерективы?!

---

← →
JaDS ©   (2005-01-29 03:33) [7]

хмммм, опять как то не так спросил:

вобщем код:


...
T_Form = object
public
 procedure Create;
end;
...
function T_Form_WndProc(hWnd: THandle; Msg: UINT; wParam: WPARAM;
                        lParam: LPARAM): LRESULT; stdcall;
begin

end;
...
procedure T_Form.Create;
var
 wc: TWndClassEx;
begin
 wc.lpfnWndProc:=T_Form_WndProc;
end;
...


Вобщем проблема относительно этого кода:
Как сделать (и можно ли это вообще, а если нельзя то как это обойти с наименьшими "жертвами") функцию T_Form_WndProc методом класса T_Form?

По всей видимости этого не добиться, тогда:


function T_Form_WndProc(hWnd: THandle; Msg: UINT; wParam: WPARAM;
                        lParam: LPARAM): LRESULT; stdcall;
begin
 ...
 // каким то образом идентифицируем объект
 // например с помощью той же GetWindowLong
 ...
 case Msg of
   WM_CREATE:          T_Form(obj).OnCreate(hWnd);
   else Result:=       DefWindowProcW(hWnd, Msg, wParam, lParam);
 end;
end;


Но тогда сразу вопросы - а есть ли другие варианты сделать тоже самое? А как ещё можно идентифицировать объект? А если потом это переопределять, то заодно и как сразу идентифицировать класс? ...

PS:
вобщем хотелось бы увидеть или реально работающий код по сабжу, или более менее дельные рекомендации, чтобы я (довольно тупой человек%) понял как это всё заставить работать.

---

← →
Набережных С. ©   (2005-01-29 09:56) [8]

Я уже недавно тут выкладывал это в урезанном виде, и был обруган и обозван хакером:) Рискну однако еще раз. Может, у кого возникнет конструктивная критика, будет очень кстати.
unit MakeInstance;

interface

uses
 Windows, Messages;

function MakeInstanceStdCall(Obj: TObject; MethodAddr: Pointer): Pointer;
procedure FreeInstanceStdCall(Inst: Pointer);

type
 TMessageEvent =
   procedure(Sender: TObject; var Message: TMessage; var Handled: boolean) of Object;

 TWndObject = class
 private
   FHandle: HWND;
   FOnMessage: TMessageEvent;
   function ObjWindowProc(Wnd: HWND; AMsg: UINT; wPrm: WPARAM; lPrm: LPARAM): LRESULT; stdcall;
   function GetWindowName: string;
   procedure SetWindowName(const Value: string);
 protected
   procedure GetClassParams(var WndClass: TWndClass); virtual;
   procedure GetStyles(var Style, ExStyle: DWORD); virtual;
   procedure DoMessage(var Message: TMessage); virtual;
 public
   constructor Create(const AName: string = ""); virtual;
   destructor Destroy; override;
   property Handle: HWND read FHandle;
   property OnMessage: TMessageEvent read FOnMessage write FOnMessage;
   property WindowName: string read GetWindowName write SetWindowName;
 end;

implementation

var
 FCS: TRTLCriticalSection;

{ TWndObject }

const
 WndClassTemplate: TWndClass = (
   style: 0;
   lpfnWndProc: @DefWindowProc;
   cbClsExtra: 0;
   cbWndExtra: 0;
   hInstance: 0;
   hIcon: 0;
   hCursor: 0;
   hbrBackground: 0;
   lpszMenuName: nil;
   lpszClassName: "TSNUtilWindow");

constructor TWndObject.Create(const AName: string = "");
var
 WndClass, TempClass: TWndClass;
 Style, ExStyle: DWORD;
 ClassRegistered: Boolean;
begin
 GetClassParams(WndClass);
 GetStyles(Style, ExStyle);
 EnterCriticalSection(FCS);
 try
   ClassRegistered := GetClassInfo(HInstance, WndClass.lpszClassName,
     TempClass);
   if ClassRegistered then UnregisterClass(WndClass.lpszClassName, HInstance);
   RegisterClass(WndClass);
   FHandle := CreateWindowEx(ExStyle, WndClass.lpszClassName,
     "", Style, 0, 0, 0, 0, 0, 0, HInstance, nil);
   if WndClass.lpfnWndProc = @DefWindowProc then
     SetWindowLong(FHandle, GWL_WNDPROC,
       Longint(MakeInstanceStdCall(Self, @TWndObject.ObjWindowProc)));
 finally
   LeaveCriticalSection(FCS);
 end;
end;

destructor TWndObject.Destroy;
var
 Instance: Pointer;
begin
 Instance := Pointer(GetWindowLong(FHandle, GWL_WNDPROC));
 DestroyWindow(FHandle);
 if Instance <> @DefWindowProc then FreeInstanceStdCall(Instance);
 inherited;
end;

procedure TWndObject.DoMessage(var Message: TMessage);
var
 Handled: boolean;
begin
 Handled:=false;
 if Assigned(FOnMessage) then FOnMessage(Self, Message, Handled);
 if not Handled then with Message do
   Result:=DefWindowProc(FHandle, Msg, WParam, LParam);
end;

procedure TWndObject.GetClassParams(var WndClass: TWndClass);
begin
 WndClass:=WndClassTemplate;
 WndClass.hInstance:=HInstance;
end;

procedure TWndObject.GetStyles(var Style, ExStyle: DWORD);
begin
 Style:=WS_POPUP;
 ExStyle:=WS_EX_TOOLWINDOW;
end;

function TWndObject.GetWindowName: string;
var
 n: DWORD;
begin
 n:=GetWindowTextLength(FHandle);
 if n = 0 then Exit;
 SetLength(Result, n);
 GetWindowText(FHandle, @Result[1], n);
end;

function TWndObject.ObjWindowProc(Wnd: HWND; AMsg: UINT; wPrm: WPARAM;
 lPrm: LPARAM): LRESULT;
var
 Message: TMessage;
begin
{
 WM_CREATE           = $0001;
 WM_NCCREATE         = $0081;
 WM_NCCALCSIZE       = $0083;
}
 with Message do
 begin
   Msg:=AMsg;
   WParam:=wPrm;
   LParam:=lPrm;
   Result:=0;
 end;
 DoMessage(Message);
 Result:=Message.Result;
end;

procedure TWndObject.SetWindowName(const Value: string);
begin
 SetWindowText(FHandle, PChar(Value));
end;

{ /TWndObject }

type
 PInstanceBlock = ^TInstanceBlock;
 TInstanceBlock = packed record
   Code:  array[0..31 - SizeOf(PInstanceBlock)] of Byte;
   Next:  PInstanceBlock;
 end;

var
 BlockList: PInstanceBlock = nil;
 Region: Pointer = nil;
 NextPage: pointer = nil;
 BlockCount: integer = 0;

const
 Page_Size = 4096;
 BlocksOnPage = Page_Size div SizeOf(TInstanceBlock);

type
 TBlockList = array[0..BlocksOnPage - 1] of TInstanceBlock;
 PBlockList = ^TBlockList;

function GetAllocGran: DWORD;
var
 Info: TSystemInfo;
begin
 GetSystemInfo(Info);
 Result:=Info.dwAllocationGranularity;
end;

procedure FreeInstanceStdCall(Inst: Pointer);
begin
 if Inst = nil then Exit;
 EnterCriticalSection(FCS);
 PInstanceBlock(Inst).Next:=BlockList;
 BlockList:=Inst;
 Dec(BlockCount);
 if BlockCount = 0 then
 begin
   VirtualFree(Region, 0, MEM_RELEASE);
   Region:=nil;
   NextPage:=nil;
   BlockList:=nil;
 end;
 LeaveCriticalSection(FCS);
end;

function MakeInstanceStdCall(Obj: TObject; MethodAddr: Pointer): Pointer;
const
 CodeBlock: array [0..12] of Byte =
   (
    $58,             // POP EAX
    $68,             // PUSH DWORD_Const <= Obj
     0, 0, 0, 0,
    $50,             // PUSH EAX
    $68,             // PUSH DWORD_Const <= MethodAddr
     0, 0, 0, 0,
    $C3              // RET
    );

type
 PCodeBlock = ^TCodeBlock;
 TCodeBlock = packed record
   Code1:     Word;
   Self:      TObject;
   Code2:     Word;
   MtdAddr:   Pointer;
   Code3:     Byte;
 end;

var
 n: integer;
begin
 EnterCriticalSection(FCS);

 if BlockList = nil then
 begin
   if Region = nil then
   begin
     Region:=VirtualAlloc(nil, GetAllocGran, MEM_RESERVE or MEM_TOP_DOWN,
                                                    PAGE_EXECUTE_READWRITE);
     NextPage:=Region;
   end;
   BlockList:=VirtualAlloc(NextPage, Page_Size, MEM_COMMIT,
                                      PAGE_EXECUTE_READWRITE);
   Inc(Cardinal(NextPage), Page_Size);
   for n:=0 to BlocksOnPage - 2 do
     PBlockList(BlockList)[n].Next:=@PBlockList(BlockList)[n + 1];
   PBlockList(BlockList)[BlocksOnPage - 1].Next:=nil;
 end;
 Result:=BlockList;
 BlockList:=BlockList.Next;
 Inc(BlockCount);

 LeaveCriticalSection(FCS);

 Move(CodeBlock, Result^, SizeOf(CodeBlock));
 with PCodeBlock(Result)^ do
 begin
   Self:=Obj;
   MtdAddr:=MethodAddr;
 end;
end;

procedure InitProc;
begin
 InitializeCriticalSection(FCS);
end;

procedure FinalProc;
begin
 DeleteCriticalSection(FCS);
end;

initialization
 InitProc;

finalization
 FinalProc;

end.


---

← →
JaDS ©   (2005-01-29 19:26) [9]

>был обруган и обозван хакером:)
а те кто ругали и обзывали вообще видели функцию Classes.MakeObjectInstance???

а вообще - давольно занятный код, уже почти что я хотел, только я хочу сделать не на базе class  а на базе object - так ресурсов меньше требуется (вроде) и ГЛАВНОЕ - я хочу чтобы деректива message работала так же как и при использовании VCL (если это вообще возможно).

---

← →
JaDS ©   (2005-01-29 23:34) [10]

а, всё, догнал - спарить message и object не удасться... обидно... прийдётся искать обходные пути...

---

← →
i-s-v ©   (2005-01-30 01:53) [11]

> а, всё, догнал - спарить message и object не удасться...
> обидно... прийдётся искать обходные пути...

А хотелось спарить? А что в результате получилось-бы? Мутант?:)

---

← →
GrayFace ©   (2005-01-30 05:05) [12]

А за что был обруган и обозван?

---

← →
Набережных С. ©   (2005-01-30 10:23) [13]

GrayFace ©   (30.01.05 05:05) [12]

А кто его знает? Он не уточнил, а спрашивать не стал. Да не стоит на это внимание обращать, зря я упомянул.

---

← →
Набережных С. ©   (2005-01-30 10:37) [14]

>JaDS ©

Если требуется, можно вызвать Dispatch в обработчике OnMessage. Просто мне это чаще не требуется.

---

← →
jack128 ©   (2005-01-30 12:19) [15]

JaDS ©   (29.01.05 19:26) [9]
а на базе object - так ресурсов меньше требуется (вроде)
Ну если создашь объект в стеке, то действительно меньше. А если в дин памяти, то ИМХО без разницы. А для чего создовать оконные объекты с стеке я себе слабо представляю..

---

← →
Набережных С. ©   (2005-01-30 13:04) [16]

>jack128 ©   (30.01.05 12:19) [15]

Сюда заглядывал?
http://delphimaster.net/view/1-1106921084/

---

← →
default ©   (2005-01-30 13:06) [17]

Набережных С. ©   (30.01.05 13:04) [16]
это всё хорошо, но пример надуманный
представьте что компиллер не включает в код бессмысленные конструкции типа A := A
пример бы реальный

---

← →
Набережных С. ©   (2005-01-30 13:21) [18]

>default ©   (30.01.05 13:06) [17]
>представьте что компиллер не включает

Не могу представить:) Обязательно включит. Компилятор не может не включать этот код именно в силу автоматического подсчета ссылок. Но об этом лучше в той ветке.

---

← →
GrayFace ©   (2005-01-31 19:46) [19]

jack128 ©   (30.01.05 12:19) [15]
А как создавать объекты в стеке?

---

← →
jack128 ©   (2005-01-31 22:23) [20]

GrayFace ©   (31.01.05 19:46) [19]
type
 TSameObj = object
   i: Integer;
 end;

procedure Test;
var
 o: TSameObj; // Объект создается в стеке
begin

end;

---

← →
GrayFace ©   (2005-02-01 02:05) [21]

jack128 ©   (31.01.05 22:23) [20]
Круто. Вот только почему "Object types are supported for backward compatibility only. Their use is not recommended."? Чем это Borland"у такая хорошая фича не понравилась?...

---

← →
GuAV ©   (2005-02-01 13:13) [22]

GrayFace ©   (01.02.05 2:05) [21]

У объектов по умолчанию нет никаких конструкторов/деструкторов и классовых методов, что оказалось не очень хорошо.

В стеке особого смысла размещать нет, всё равно поля других объектов - не объекты а указатели на них, всё равно неплохо бы вызвать конструктор...
Или вот в случае исключения в конструкторе последует вызов деструктора, а если объект в стеке, или там часть массива, то что ?

Короче, ничего хорошего в них не вижу.

---

← →
GrayFace ©   (2005-02-01 17:13) [23]

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

---

← →
GuAV ©   (2005-02-01 20:15) [24]

Согласен, лучший пример - TRect раньше был объектом.
Однако решили что морочится с ними не стоит.
А комплескные числа - VarCmplx рулит.

---

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

Текущий архив: 2005.03.13;
Скачать: CL | DM;

Наверх

Память: 0.55 MB
Время: 0.027 c