controls/listedit/objects.pas

   1 unit objects;
   2
   3 interface
   4 uses KOL, Windows, Messages;
   5
   6 type
   7   TWndMethod = procedure(var Message: TMessage) of object;
   8
   9 function MakeObjectInstance(Method: TWndMethod): Pointer;
  10 procedure FreeObjectInstance(ObjectInstance: Pointer);
  11 function AllocateHWnd(Method: TWndMethod): HWND;
  12 procedure DeallocateHWnd(Wnd: HWND);
  13
  14 implementation
  15
  16 type
  17   PObjectInstance = ^TObjectInstance;
  18   TObjectInstance = packed record
  19     Code: Byte;
  20     Offset: Integer;
  21     case Integer of
  22       0: (Next: PObjectInstance);
  23       1: (Method: TWndMethod);
  24   end;
  25
  26 type
  27   PInstanceBlock = ^TInstanceBlock;
  28   TInstanceBlock = packed record
  29     Next: PInstanceBlock;
  30     Code: array[1..2] of Byte;
  31     WndProcPtr: Pointer;
  32     Instances: array[0..100] of TObjectInstance;
  33   end;
  34
  35 var
  36   InstBlockList: PInstanceBlock;
  37   InstFreeList: PObjectInstance;
  38
  39 { Standard window procedure }
  40 { In    ECX = Address of method pointer }
  41 { Out   EAX = Result }
  42
  43 function StdWndProc(Window: HWND; Message, WParam: Longint;
  44   LParam: Longint): Longint; stdcall; assembler;
  45 asm
  46         XOR     EAX,EAX
  47         PUSH    EAX
  48         PUSH    LParam
  49         PUSH    WParam
  50         PUSH    Message
  51         MOV     EDX,ESP
  52         MOV     EAX,[ECX].Longint[4]
  53         CALL    [ECX].Pointer
  54         ADD     ESP,12
  55         POP     EAX
  56 end;
  57
  58 { Allocate an object instance }
  59
  60 function CalcJmpOffset(Src, Dest: Pointer): Longint;
  61 begin
  62   Result := Longint(Dest) - (Longint(Src) + 5);
  63 end;
  64
  65 function MakeObjectInstance(Method: TWndMethod): Pointer;
  66 const
  67   BlockCode: array[1..2] of Byte = (
  68     $59,       { POP ECX }
  69     $E9);      { JMP StdWndProc }
  70   PageSize = 4096;
  71 var
  72   Block: PInstanceBlock;
  73   Instance: PObjectInstance;
  74 begin
  75   if InstFreeList = nil then
  76   begin
  77     Block := VirtualAlloc(nil, PageSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE);
  78     Block^.Next := InstBlockList;
  79     Move(BlockCode, Block^.Code, SizeOf(BlockCode));
  80     Block^.WndProcPtr := Pointer(CalcJmpOffset(@Block^.Code[2], @StdWndProc));
  81     Instance := @Block^.Instances;
  82     repeat
  83       Instance^.Code := $E8;  { CALL NEAR PTR Offset }
  84       Instance^.Offset := CalcJmpOffset(Instance, @Block^.Code);
  85       Instance^.Next := InstFreeList;
  86       InstFreeList := Instance;
  87       Inc(Longint(Instance), SizeOf(TObjectInstance));
  88     until Longint(Instance) - Longint(Block) >= SizeOf(TInstanceBlock);
  89     InstBlockList := Block;
  90   end;
  91   Result := InstFreeList;
  92   Instance := InstFreeList;
  93   InstFreeList := Instance^.Next;
  94   Instance^.Method := Method;
  95 end;
  96
  97 { Free an object instance }
  98
  99 procedure FreeObjectInstance(ObjectInstance: Pointer);
 100 begin
 101   if ObjectInstance <> nil then
 102   begin
 103     PObjectInstance(ObjectInstance)^.Next := InstFreeList;
 104     InstFreeList := ObjectInstance;
 105   end;
 106 end;
 107
 108 var
 109   UtilWindowClass: TWndClass = (
 110     style: 0;
 111     lpfnWndProc: @DefWindowProc;
 112     cbClsExtra: 0;
 113     cbWndExtra: 0;
 114     hInstance: 0;
 115     hIcon: 0;
 116     hCursor: 0;
 117     hbrBackground: 0;
 118     lpszMenuName: nil;
 119     lpszClassName: 'KOLFakeUtilWindow');
 120
 121 function AllocateHWnd(Method: TWndMethod): HWND;
 122 var
 123   TempClass: TWndClass;
 124   ClassRegistered: Boolean;
 125 begin
 126   UtilWindowClass.hInstance := HInstance;
 127   ClassRegistered := GetClassInfo(HInstance, UtilWindowClass.lpszClassName,
 128     TempClass);
 129   if not ClassRegistered or (TempClass.lpfnWndProc <> @DefWindowProc) then
 130   begin
 131     if ClassRegistered then
 132       Windows.UnregisterClass(UtilWindowClass.lpszClassName, HInstance);
 133     Windows.RegisterClass(UtilWindowClass);
 134   end;
 135   Result := CreateWindowEx(WS_EX_TOOLWINDOW, UtilWindowClass.lpszClassName,
 136     '', WS_POPUP {!0}, 0, 0, 0, 0, 0, 0, HInstance, nil);
 137   if Assigned(Method) then
 138     SetWindowLong(Result, GWL_WNDPROC, Longint(MakeObjectInstance(Method)));
 139 end;
 140
 141 procedure DeallocateHWnd(Wnd: HWND);
 142 var
 143   Instance: Pointer;
 144 begin
 145   Instance := Pointer(GetWindowLong(Wnd, GWL_WNDPROC));
 146   DestroyWindow(Wnd);
 147   if Instance <> @DefWindowProc then FreeObjectInstance(Instance);
 148 end;
 149
 150 begin
 151   InstBlockList := nil;
 152   InstFreeList := nil;
 153 end.