PureBasic Forums - English

http://www.purebasic.com
https://www.purebasic.fr/english/

Modular alternative for SetWindowCallback

https://www.purebasic.fr/english/viewtopic.php?t=78118

Page 1 of 1

Modular alternative for SetWindowCallback

Posted: Sun Oct 24, 2021 5:04 am
by Rinzwind

Code: Select all

EnableExplicit

#MSG_CallWindowProc = #PB_ProcessPureBasicEvents
#MSG_All = -1

Prototype MessageHandler(Gadget, hwnd, msg, wp, lp)
Global NewMap Properties()

Macro SetIDProp(ID, Name, Value)
  Properties(Str(ID) + ":" + Name) = Value
EndMacro

Macro IDPropExists(ID, Name)
  FindMapElement(Properties(), Str(ID) + ":" + Name)
EndMacro

Macro DeleteIDProp(ID, Name)
  DeleteMapElement(Properties(), Str(ID) + ":" + Name)
EndMacro

Procedure GetIDProp(ID, Name.s)
  If FindMapElement(Properties(), Str(ID) + ":" + Name)
    ProcedureReturn Properties()
  EndIf
EndProcedure

Procedure FreeIDProp(ID)
  Protected sID.s = Str(ID) + ":"
  Protected l = Len(sID)
  ForEach Properties()
    If Left(MapKey(Properties()), l) = sID
      DeleteMapElement(Properties())
    EndIf
  Next
EndProcedure

Procedure _EventHandler(hwnd, msg, wp, lp)
  Protected gc.MessageHandler, r = #MSG_CallWindowProc, proc = GetWindowLongPtr_(hwnd, #GWL_USERDATA); = GetIDProp(hwnd, "proc")
  ;Debug "" + hwnd + #TAB$ + msg

  gc = GetIDProp(hwnd, Str(#MSG_All))
  If Not gc
    gc = GetIDProp(hwnd, Str(msg))
  EndIf
  If gc  
    r = gc(GetDlgCtrlID_(hwnd), hwnd, msg, wp, lp)
  EndIf
  If msg = #WM_DESTROY
    SetWindowLongPtr_(hwnd, #GWL_WNDPROC, proc)
    FreeIDProp(hwnd)
  EndIf
  If r = #MSG_CallWindowProc
    r = CallWindowProc_(proc, hwnd, msg, wp, lp)
  EndIf
  ProcedureReturn r
EndProcedure

Procedure BindWindowMessage(window, msg, callback.MessageHandler)
  Protected wid = WindowID(window), proc = GetWindowLongPtr_(wid, #GWL_USERDATA)
  
  ;If Not IDPropExists(wid, "proc")
  If Not proc
    proc = SetWindowLongPtr_(wid, #GWL_WNDPROC, @_EventHandler())
    SetWindowLongPtr_(wid, #GWL_USERDATA, proc)
    ;SetIDProp(wid, "proc", proc)
  EndIf
  SetIDProp(wid, msg, callback)  
EndProcedure

Procedure UnbindWindowMessage(window, msg)
  Protected wid = WindowID(window)
  
  DeleteIDProp(wid, msg)
EndProcedure

Procedure BindMessage(gadget, msg, callback.MessageHandler)
  Protected gid = GadgetID(gadget), proc = GetWindowLongPtr_(gid, #GWL_USERDATA)
  
  ;If Not IDPropExists(gid, "proc")
  If Not proc
    proc = SetWindowLongPtr_(gid, #GWL_WNDPROC, @_EventHandler())
    SetWindowLongPtr_(gid, #GWL_USERDATA, proc)
    ;SetIDProp(gid, "proc", proc)
  EndIf
  SetIDProp(gid, msg, callback)
EndProcedure

Procedure UnbindMessage(gadget, msg)
  Protected gid = GadgetID(gadget)
  
  DeleteIDProp(gid, msg)
EndProcedure

; //
; // Small demo
; //

Define e, i, c
OpenWindow(0, 0, 0, 400, 300, "Test")

ButtonGadget(0, 10, 10, 80, 40, "Test")
ButtonGadget(1, 100, 10, 80, 40, "Test2")
Procedure MyButtonMessage(g, hwnd, msg, wp, lp)
  Debug "" + g + #TAB$ + hwnd + #TAB$ + msg + #TAB$ + wp + #TAB$ + lp
  ;UnbindMessage(g, #WM_RBUTTONDOWN)
  ProcedureReturn #MSG_CallWindowProc
EndProcedure

Procedure MyWindowMessage(g, hwnd, msg, wp, lp)
  Debug "" + g + #TAB$ + hwnd + #TAB$ + msg + #TAB$ + wp + #TAB$ + lp
  If IsGadget(0)
    ;FreeGadget(0)
  EndIf
  ;UnbindWindowMessage(g, #WM_LBUTTONDOWN)
  ProcedureReturn #MSG_CallWindowProc
EndProcedure

;BindMessage(0, #MSG_All, @MyTest())
BindMessage(0, #WM_RBUTTONDOWN, @MyButtonMessage())
BindWindowMessage(0, #WM_LBUTTONDOWN, @MyWindowMessage())

Repeat
  e = WaitWindowEvent()
Until e = #PB_Event_CloseWindow

Re: Modular alternative for SetWindowCallback

Posted: Sun Oct 24, 2021 9:45 am
by mk-soft
Works so well,
but FreeIDProp(ID) can randomly lead to an error. For example, ID's 1234 and 12345 would both be deleted.

Should therefore be FreeIDProp(ID, Name.s)

Re: Modular alternative for SetWindowCallback

Posted: Sun Oct 24, 2021 10:00 am
by Rinzwind
Thanks, made small tweaks to first post.
I wanted to avoid ProcedureReturn #MSG_CallWindowProc from custom event handlers because that part can easily be forgotten by mistake, but I guess that's the way it is because sometimes you want to return 0 from the window proc and skip calling the prev proc.

Re: Modular alternative for SetWindowCallback

Posted: Sun Oct 24, 2021 11:37 am
by mk-soft
Perhaps is better to set "#MSG_CallWindowProc = -1"
It is very unwarranted that a message expects a "-1" as a result.

Re: Modular alternative for SetWindowCallback

Posted: Sun Oct 24, 2021 12:16 pm
by mk-soft
In order to avoid conflicts with the Retval, the MessageHandler would have to be adapted.
Also used a lot in API for return values.

Code: Select all

Prototype MessageHandler(Gadget, hWnd, Msg, wParam, lParam, *Retval.integer)
Send you a PM with complete code

Re: Modular alternative for SetWindowCallback

Posted: Sun Oct 24, 2021 2:27 pm
by mk-soft
Now complete code with additional parameter Retval (ByRef)

Update 2

Code: Select all

;-TOP by mk-soft (Base from Rinzwind)

Prototype MessageCallback(ID, hWnd, Msg, wParam, lParam, *Retval.integer)

Structure udtMessageData
  ID.i
  *WindowProc
  Map *MessageCallback()
EndStructure

Global NewMap mapMessageData.udtMessageData()

Procedure DispatchMessage(hWnd, Msg, wParam, lParam)
  Protected r1, *MessageData.udtMessageData, *Callback.MessageCallback
  
  *MessageData = mapMessageData(Str(hWnd))
  If Msg = #WM_DESTROY
    SetWindowLongPtr_(hWnd, #GWL_WNDPROC, *MessageData\WindowProc)
    DeleteMapElement(mapMessageData())
  Else
    If FindMapElement(*MessageData\MessageCallback(), Str(Msg))
      *Callback = *MessageData\MessageCallback()
      If *Callback(*MessageData\ID, hWnd, Msg, wParam, lParam, @r1)
        ProcedureReturn r1
      EndIf  
    EndIf
  EndIf
  ProcedureReturn CallWindowProc_(*MessageData\WindowProc, hWnd, Msg, wParam, lParam)
EndProcedure

Procedure BindWindowMessage(Window, Msg, *Callback.MessageCallback)
  Protected hWnd = WindowID(Window)
  If Not FindMapElement(mapMessageData(), Str(hWnd))
    AddMapElement(mapMessageData(), Str(hWnd))
    mapMessageData()\WindowProc = SetWindowLongPtr_(hWnd, #GWL_WNDPROC, @DispatchMessage())
    mapMessageData()\ID = Window
  EndIf
  mapMessageData()\MessageCallback(Str(Msg)) = *Callback
EndProcedure

Procedure UnbindWindowMessage(Window, Msg)
  Protected hWnd = WindowID(Window)
  If FindMapElement(mapMessageData(), Str(hWnd))
    If Msg = #PB_All
      SetWindowLongPtr_(hWnd, #GWL_WNDPROC, mapMessageData()\WindowProc)
      DeleteMapElement(mapMessageData())
    Else
      DeleteMapElement(mapMessageData()\MessageCallback(), Str(Msg))
      If MapSize(mapMessageData()\MessageCallback()) = 0
        SetWindowLongPtr_(hWnd, #GWL_WNDPROC, mapMessageData()\WindowProc)
        DeleteMapElement(mapMessageData())
      EndIf
    EndIf
  EndIf
EndProcedure

Procedure BindMessage(Gadget, Msg, *Callback.MessageCallback)
  Protected hWnd = GadgetID(Gadget)
  If Not FindMapElement(mapMessageData(), Str(hWnd))
    AddMapElement(mapMessageData(), Str(hWnd))
    mapMessageData()\WindowProc = SetWindowLongPtr_(hWnd, #GWL_WNDPROC, @DispatchMessage())
    mapMessageData()\ID = Window
  EndIf
  mapMessageData()\MessageCallback(Str(Msg)) = *Callback
EndProcedure

Procedure UnbindMessage(Gadget, Msg)
  Protected hWnd = GadgetID(Gadget)
  If FindMapElement(mapMessageData(), Str(hWnd))
    If Msg = #PB_All
      SetWindowLongPtr_(hWnd, #GWL_WNDPROC, mapMessageData()\WindowProc)
      DeleteMapElement(mapMessageData())
    Else
      DeleteMapElement(mapMessageData()\MessageCallback(), Str(Msg))
      If MapSize(mapMessageData()\MessageCallback()) = 0
        SetWindowLongPtr_(hWnd, #GWL_WNDPROC, mapMessageData()\WindowProc)
        DeleteMapElement(mapMessageData())
      EndIf
    EndIf
  EndIf
EndProcedure

; ****

;- Example

CompilerIf #PB_Compiler_IsMainFile
  
  Define e, i, c
  OpenWindow(0, 0, 0, 400, 300, "Bind Message Example")
  ButtonGadget(0, 10, 10, 120, 40, "Click me")
  ButtonGadget(1, 140, 10, 120, 40, "Remove all")
  
  
  Procedure MyButtonMessageLeftClick(Gadget, hWnd, Msg, wParam, lParam, *Retval.Integer)
    Debug "CB Button LeftClick: " + #TAB$ + Gadget + #TAB$ + hWnd + #TAB$ + Msg + #TAB$ + wParam + #TAB$ + lParam
  EndProcedure
  
  Procedure MyButtonMessageLeftDoubleClick(Gadget, hWnd, Msg, wParam, lParam, *Retval.Integer)
    Debug "CB Button DBL-Click" + #TAB$ + Gadget + #TAB$ + hWnd + #TAB$ + Msg + #TAB$ + wParam + #TAB$ + lParam
    *Retval\i = 0
    ProcedureReturn #True
  EndProcedure
  
  Procedure MyButtonMessageRightClick(Gadget, hWnd, Msg, wParam, lParam, *Retval.Integer)
    Debug "CB Button RightClick: " + #TAB$ + Gadget + #TAB$ + hWnd + #TAB$ + Msg + #TAB$ + wParam + #TAB$ + lParam
    *Retval\i = 0
    ProcedureReturn #True
  EndProcedure
  
  Procedure MyWindowMessage(Gadget, hWnd, Msg, wParam, lParam, *Retval.Integer)
    Debug "CB Window LeftClick: " + #TAB$ + Gadget + #TAB$ + hWnd + #TAB$ + Msg + #TAB$ + wParam + #TAB$ + lParam
  EndProcedure
  
  BindMessage(0, #WM_LBUTTONDOWN, @MyButtonMessageLeftClick())
  BindMessage(0, #WM_LBUTTONDBLCLK, @MyButtonMessageLeftDoubleClick())
  BindMessage(0, #WM_RBUTTONDOWN, @MyButtonMessageRightClick())
  
  BindWindowMessage(0, #WM_LBUTTONDOWN, @MyWindowMessage())
  
  Repeat
    Select WaitWindowEvent()
      Case #PB_Event_CloseWindow
        Break
        
      Case #PB_Event_LeftClick
        Debug "#PB_Event_LeftClick"
        
      Case #PB_Event_Gadget
        Select EventGadget()
          Case 0
            Debug "#PB_Event_Gadget 0"
            
          Case 1
            UnbindMessage(0, #PB_All)
            UnbindWindowMessage(0, #WM_LBUTTONDOWN)
            
        EndSelect
        
    EndSelect
    
  ForEver
  
CompilerEndIf

Re: Modular alternative for SetWindowCallback

Posted: Mon Oct 25, 2021 7:08 am
by Rinzwind
btw you can store the original windows proc instead in #GWL_USERDATA:
SetWindowLongPtr_(gid, #GWL_USERDATA, proc)
proc = GetWindowLongPtr_(hwnd, #GWL_USERDATA)

one less map lookup. Updated first post. Or even let it point to a structure that contains the proc and a simple linked list lookup per control. Probably not worth it though.

Re: Modular alternative for SetWindowCallback

Posted: Mon Oct 25, 2021 7:51 am
by Denis
perhaps the following set of functions can be used to sub-unsub/class windows instead of SetWindowLongPtr:

DefSubclassProc
GetWindowSubclass
SetWindowSubclass
RemoveWindowSubclass

Blog from Raymond Chen about these functions
https://devblogs.microsoft.com/oldnewth ... 0/?p=41883

Re: Modular alternative for SetWindowCallback

Posted: Mon Oct 25, 2021 8:54 am
by Rinzwind
Yup, possible too. Weird how old the Windows lib files are that come with PB...

Code: Select all

EnableExplicit

Global _Comctl32 = OpenLibrary(#PB_Any, "Comctl32.dll")
If _Comctl32
  Prototype SetWindowSubclass(hWnd, pfnSubclass, uIdSubclass, dwRefData)
  Prototype GetWindowSubclass(hWnd, pfnSubclass, uIdSubclass, *dwRefData)
  Prototype RemoveWindowSubclass(hWnd, pfnSubclass, uIdSubclass)
  Prototype DefSubclassProc(hWnd, uMsg, wParam, lParam)
  Global SetWindowSubclass_.SetWindowSubclass = GetFunction(_Comctl32, "SetWindowSubclass")
  Global GetWindowSubclass_.GetWindowSubclass = GetFunction(_Comctl32, "GetWindowSubclass")
  Global RemoveWindowSubclass_.RemoveWindowSubclass = GetFunction(_Comctl32, "RemoveWindowSubclass")
  Global DefSubclassProc_.DefSubclassProc = GetFunction(_Comctl32, "DefSubclassProc")  
EndIf

#MSG_CallWindowProc = #PB_ProcessPureBasicEvents
#MSG_All = -1

Prototype MessageHandler(Gadget, hwnd, msg, wp, lp)
Global NewMap Properties()

Macro SetIDProp(ID, Name, Value)
  Properties(Str(ID) + ":" + Name) = Value
EndMacro

Macro IDPropExists(ID, Name)
  FindMapElement(Properties(), Str(ID) + ":" + Name)
EndMacro

Macro DeleteIDProp(ID, Name)
  DeleteMapElement(Properties(), Str(ID) + ":" + Name)
EndMacro

Procedure GetIDProp(ID, Name.s)
  If FindMapElement(Properties(), Str(ID) + ":" + Name)
    ProcedureReturn Properties()
  EndIf
EndProcedure

Procedure FreeIDProp(ID)
  Protected sID.s = Str(ID) + ":"
  Protected l = Len(sID)
  ForEach Properties()
    If Left(MapKey(Properties()), l) = sID
      DeleteMapElement(Properties())
    EndIf
  Next
EndProcedure

Procedure _EventHandler(hwnd, msg, wp, lp, uIdSubclass, dwRefData)
  Protected gc.MessageHandler, r = #MSG_CallWindowProc
  ;Debug "" + hwnd + #TAB$ + msg

  gc = GetIDProp(hwnd, Str(#MSG_All))
  If Not gc
    gc = GetIDProp(hwnd, Str(msg))
  EndIf
  If gc  
    r = gc(GetDlgCtrlID_(hwnd), hwnd, msg, wp, lp)
  EndIf
  If r = #MSG_CallWindowProc
    r = DefSubclassProc_(hwnd, msg, wp, lp)
  EndIf
  If msg = #WM_DESTROY
    RemoveWindowSubclass_(hwnd, @_EventHandler(), 0)
    FreeIDProp(hwnd)
  EndIf  
  ProcedureReturn r
EndProcedure

Procedure BindWindowMessage(window, msg, callback.MessageHandler)
  Protected wid = WindowID(window)
  
  If Not GetWindowSubclass_(wid, @_EventHandler(), 0, 0)
    SetWindowSubclass_(wid, @_EventHandler(), 0, 0)
  EndIf
  SetIDProp(wid, msg, callback)  
EndProcedure

Procedure UnbindWindowMessage(window, msg)
  Protected wid = WindowID(window)
  
  DeleteIDProp(wid, msg)
EndProcedure

Procedure BindMessage(gadget, msg, callback.MessageHandler)
  Protected gid = GadgetID(gadget)
  
  If Not GetWindowSubclass_(gid, @_EventHandler(), 0, 0)
    SetWindowSubclass_(gid, @_EventHandler(), 0, 0)
  EndIf
  SetIDProp(gid, msg, callback)
EndProcedure

Procedure UnbindMessage(gadget, msg)
  Protected gid = GadgetID(gadget)
  
  DeleteIDProp(gid, msg)
EndProcedure

; //
; // Small demo
; //

Define e, i, c
OpenWindow(0, 0, 0, 400, 300, "Test")

ButtonGadget(0, 10, 10, 80, 40, "Test")
ButtonGadget(1, 100, 10, 80, 40, "Test2")
Procedure MyButtonMessage(g, hwnd, msg, wp, lp)
  Debug "" + g + #TAB$ + hwnd + #TAB$ + msg + #TAB$ + wp + #TAB$ + lp
  ;UnbindMessage(g, #WM_RBUTTONDOWN)
  ProcedureReturn #MSG_CallWindowProc
EndProcedure

Procedure MyWindowMessage(g, hwnd, msg, wp, lp)
  Debug "" + g + #TAB$ + hwnd + #TAB$ + msg + #TAB$ + wp + #TAB$ + lp
  If IsGadget(0)
    ;FreeGadget(0)
  EndIf
  ;UnbindWindowMessage(g, #WM_LBUTTONDOWN)
  ProcedureReturn #MSG_CallWindowProc
EndProcedure

;BindMessage(0, #MSG_All, @MyTest())
BindMessage(0, #WM_RBUTTONDOWN, @MyButtonMessage())
BindWindowMessage(0, #WM_LBUTTONDOWN, @MyWindowMessage())

Repeat
  e = WaitWindowEvent()
Until e = #PB_Event_CloseWindow
ps archive of 'the old new thing'.. http://bytepointer.com/resources/old_ne ... /index.htm

Re: Modular alternative for SetWindowCallback

Posted: Mon Oct 25, 2021 9:47 am
by Rinzwind
Little bonus example that shows how to drag a window the right mouse button:

Code: Select all

OpenWindow(0, 200, 200, 400, 200, "Move window with mouse while holding right mouse button")

Procedure EventWindowMouse(w, h, msg, wp, lp)
  Static p1.POINT, wr1.RECT
  Protected p2.POINT
  
  Select msg
    Case #WM_MOUSEMOVE      
      If GetCapture_() = h
        GetCursorPos_(p2)
        SetWindowPos_(h, 0, wr1\left + (p2\x - p1\x), wr1\top + (p2\y - p1\y), 0, 0, #SWP_NOSIZE | #SWP_NOZORDER | #SWP_NOREDRAW)        
      EndIf
    Case #WM_RBUTTONDOWN
      SetCapture_(h)
      GetCursorPos_(p1)
      GetWindowRect_(h, wr1)
    Case #WM_RBUTTONUP
      ReleaseCapture_()
  EndSelect
  
  ProcedureReturn #MSG_CallWindowProc
EndProcedure

BindWindowMessage(0, #WM_RBUTTONDOWN, @EventWindowMouse())
BindWindowMessage(0, #WM_RBUTTONUP, @EventWindowMouse())
BindWindowMessage(0, #WM_MOUSEMOVE, @EventWindowMouse())

Define e

Repeat
  e = WaitWindowEvent()
Until e = #PB_Event_CloseWindow
Ok not a big difference here, the advantage of using these bind procedures shine when binding many messages and controls. Instead of one giant callback, it is functionally separated and also "multi include file and module" friendly.

ps if only PB had inline array initialization... (when coming?) aka BindWindowMessage(0, [#WM_MOUSEMOVE, #WM_RBUTTONUP, #WM_MOUSEMOVE], @EventWindowMouse())

Re: Modular alternative for SetWindowCallback

Posted: Mon Oct 25, 2021 8:04 pm
by mk-soft
I have revised my code. Basic idea from Rinzwind

Code: viewtopic.php?p=576225#p576225
All times are UTC+01:00
Page 1 of 1

Powered by phpBB® Forum Software © phpBB Limited