--- /dev/null
+{ Copyright (C) 2005 Bas Steendijk and Peter Green\r
+ For conditions of distribution and use, see copyright notice in zlib_license.txt\r
+ which is included in the package\r
+ ----------------------------------------------------------------------------- }\r
+\r
+//this unit provides a rough approximation of windows messages on linux\r
+//it is useful for multithreaded applications on linux to communicate back to\r
+//the main lcore thread\r
+//This unit is *nix only, on windows you should use the real thing\r
+\r
+unit lcoremessages;\r
+//windows messages like system based on lcore tasks\r
+interface\r
+\r
+uses pgtypes,sysutils,bsearchtree,strings,syncobjs;\r
+\r
+\r
+{$if (fpc_version < 2) or ((fpc_version=2) and ((fpc_release < 2) or ((fpc_release = 2) and (fpc_patch < 2)) ))}\r
+ {$error this code is only supported under fpc 2.2.2 and above due to bugs in the eventobject code in older versions}\r
+{$endif}\r
+\r
+type\r
+ lparam=taddrint;\r
+ wparam=taddrint;\r
+ thinstance=pointer;\r
+ hicon=pointer;\r
+ hcursor=pointer;\r
+ hbrush=pointer;\r
+ hwnd=qword; //window handles are monotonically increasing 64 bit integers,\r
+ //this should allow for a million windows per second for over half\r
+ //a million years!\r
+\r
+ twndproc=function(ahWnd:HWND; auMsg:Integer; awParam:WPARAM; alParam:LPARAM):Integer; stdcall;\r
+\r
+\r
+ twndclass=record\r
+ style : dword;\r
+ lpfnwndproc : twndproc;\r
+ cbclsextra : integer;\r
+ cbwndextra : integer;\r
+ hinstance : thinstance;\r
+ hicon : hicon;\r
+ hcursor : hcursor;\r
+ hbrbackground : hbrush;\r
+ lpszmenuname : pchar;\r
+ lpszclassname : pchar;\r
+ end;\r
+ PWNDCLASS=^twndclass;\r
+ \r
+ UINT=dword;\r
+ WINBOOL = longbool;\r
+ tTIMERPROC = procedure (ahwnd:HWND; umsg:integer; idevent:taddrint;dwtime:taddrint);stdcall;\r
+ ATOM = pointer;\r
+ LPCSTR = pchar;\r
+ LPVOID = pointer;\r
+ HMENU = pointer;\r
+ HINST = pointer;\r
+\r
+ TPOINT = record \r
+ x : LONGint; \r
+ y : LONGint; \r
+ end; \r
+ \r
+ TMSG = record \r
+ hwnd : HWND; \r
+ message : UINT; \r
+ wParam : WPARAM; \r
+ lParam : LPARAM; \r
+ time : DWORD; \r
+ pt : TPOINT;\r
+ end; \r
+ THevent=TEventObject;\r
+const\r
+ WS_EX_TOOLWINDOW = $80;\r
+ WS_POPUP = longint($80000000);\r
+ CW_USEDEFAULT=$80000000;\r
+ hinstance=nil;\r
+ PM_REMOVE = 1;\r
+ WM_USER = 1024;\r
+ WM_TIMER = 275;\r
+ INFINITE = syncobjs.infinite;\r
+\r
+function getwindowlongptr(ahwnd:hwnd;nindex:integer) : taddrint;\r
+function setwindowlongptr(ahwnd:hwnd;nindex:integer;dwNewLong : taddrint) : taddrint;\r
+function DefWindowProc(ahWnd:HWND; auMsg:Integer; awParam:WPARAM; alParam:LPARAM):Integer; stdcall;\r
+function RegisterClass(const lpWndClass:TWNDCLASS):ATOM;\r
+function CreateWindowEx(dwExStyle:DWORD; lpClassName:LPCSTR; lpWindowName:LPCSTR; dwStyle:DWORD; X:longint;Y:longint; nWidth:longint; nHeight:longint; hWndParent:HWND; hMenu:HMENU;hInstance:HINST; lpParam:LPVOID):HWND;\r
+function DestroyWindow(ahWnd:HWND):WINBOOL;\r
+function PostMessage(hWnd:HWND; Msg:UINT; wParam:WPARAM; lParam:LPARAM):WINBOOL;\r
+function PeekMessage(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax, wRemoveMsg: UINT): WINBOOL;\r
+function DispatchMessage(const lpMsg: TMsg): Longint;\r
+function GetMessage(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax: UINT): WINBOOL;\r
+function SetEvent(hEvent:THevent):WINBOOL;\r
+function CreateEvent(lpEventAttributes:PSECURITYATTRIBUTES; bManualReset:WINBOOL; bInitialState:WINBOOL; lpName:pchar):tHevent;\r
+function terminatethread(threadhandle : tthreadid;dummy:integer) : boolean;\r
+function waitforsingleevent(event:thevent;timeout:cardinal) : twaitresult;\r
+function SetTimer(ahWnd:HWND; nIDEvent:taddrint; uElapse:UINT; lpTimerFunc:tTIMERPROC):UINT;\r
+function KillTimer(ahWnd:HWND; uIDEvent:taddrint):WINBOOL;\r
+\r
+procedure init;\r
+\r
+implementation\r
+uses\r
+ baseunix,unix,lcore,unixutil,ltimevalstuff,sockets;//,safewriteln;\r
+{$i unixstuff.inc}\r
+\r
+type\r
+ \r
+ tmessageintransit = class\r
+ msg : tmsg;\r
+ next : tmessageintransit;\r
+ end;\r
+\r
+ tthreaddata = class\r
+ messagequeue : tmessageintransit;\r
+ messageevent : teventobject;\r
+ waiting : boolean;\r
+ lcorethread : boolean;\r
+ nexttimer : ttimeval;\r
+ threadid : tthreadid;\r
+ end;\r
+ twindow=class\r
+ hwnd : hwnd;\r
+ extrawindowmemory : pointer;\r
+ threadid : tthreadid;\r
+ windowproc : twndproc;\r
+ end;\r
+\r
+var\r
+ structurelock : tcriticalsection;\r
+ threaddata : thashtable;\r
+ windowclasses : thashtable;\r
+ lcorelinkpipesend : integer;\r
+ lcorelinkpiperecv : tlasio;\r
+ windows : thashtable;\r
+ //I would rather things crash immediately\r
+ //if they use an insufficient size type\r
+ //than crash after over four billion\r
+ //windows have been made ;)\r
+ nextwindowhandle : qword = $100000000;\r
+\r
+\r
+//findthreaddata should only be called while holding the structurelock\r
+function findthreaddata(threadid : tthreadid) : tthreaddata;\r
+begin\r
+ result := tthreaddata(findtree(@threaddata,inttostr(taddrint(threadid))));\r
+ if result = nil then begin\r
+ result := tthreaddata.create;\r
+ result.messageevent := teventobject.create(nil,false,false,inttostr(taddrint(result)));\r
+ result.nexttimer := tv_invalidtimebig;\r
+ result.threadid := threadid;\r
+ addtree(@threaddata,inttostr(taddrint(threadid)),result);\r
+ end;\r
+end;\r
+\r
+//deletethreaddataifunused should only be called while holding the structurelock\r
+procedure deletethreaddataifunused(athreaddata : tthreaddata);\r
+begin\r
+ //writeln('in deletethreaddataifunused');\r
+ if (athreaddata <> nil) then if (athreaddata.waiting=false) and (athreaddata.messagequeue=nil) and (athreaddata.lcorethread=false) and (athreaddata.nexttimer.tv_sec=tv_invalidtimebig.tv_sec) and (athreaddata.nexttimer.tv_usec=tv_invalidtimebig.tv_usec) then begin\r
+ //writeln('threaddata is unused, freeing messageevent');\r
+ athreaddata.messageevent.free;\r
+ //writeln('freeing thread data object');\r
+ athreaddata.free;\r
+ //writeln('deleting thread data object from hashtable');\r
+ deltree(@threaddata,inttostr(taddrint(athreaddata.threadid)));\r
+ //writeln('finished deleting thread data');\r
+ end else begin\r
+ //writeln('thread data is not unused');\r
+ end;\r
+end;\r
+\r
+function getwindowlongptr(ahwnd:hwnd;nindex:integer) : taddrint;\r
+var\r
+ window : twindow;\r
+begin\r
+ structurelock.acquire;\r
+ try\r
+ window := findtree(@windows,inttostr(ahwnd));\r
+ if window <> nil then begin\r
+ result := paddrint(taddrint(window.extrawindowmemory)+nindex)^;\r
+ end else begin\r
+ result := 0;\r
+ end;\r
+ finally\r
+ structurelock.release;\r
+ end;\r
+end;\r
+\r
+function setwindowlongptr(ahwnd:hwnd;nindex:integer;dwNewLong : taddrint) : taddrint;\r
+var\r
+ window : twindow;\r
+begin\r
+ structurelock.acquire;\r
+ try\r
+ window := findtree(@windows,inttostr(ahwnd));\r
+ if window <> nil then begin\r
+ result := paddrint(taddrint(window.extrawindowmemory)+nindex)^;\r
+ paddrint(taddrint(window.extrawindowmemory)+nindex)^ := dwnewlong;\r
+ end else begin\r
+ result := 0;\r
+ end;\r
+ finally\r
+ structurelock.release;\r
+ end;\r
+\r
+end;\r
+\r
+\r
+function DefWindowProc(ahWnd:HWND; auMsg:Integer; awParam:WPARAM; alParam:LPARAM):Integer; stdcall;\r
+begin\r
+ result := 0;\r
+end;\r
+\r
+function strdup(s:pchar) : pchar;\r
+begin\r
+ //swriteln('in strdup, about to allocate memory');\r
+ result := getmem(strlen(s)+1);\r
+ //swriteln('about to copy string');\r
+ strcopy(s,result);\r
+ //swriteln('leaving strdup');\r
+end;\r
+\r
+function RegisterClass(const lpWndClass:TWNDCLASS):ATOM;\r
+var\r
+ storedwindowclass:pwndclass;\r
+begin\r
+ structurelock.acquire;\r
+ try\r
+ //swriteln('in registerclass, about to check for duplicate window class');\r
+ storedwindowclass := findtree(@windowclasses, lpwndclass.lpszclassname);\r
+ if storedwindowclass <> nil then begin\r
+\r
+ if comparebyte(storedwindowclass^,lpwndclass,sizeof(twndclass)-sizeof(pchar)-sizeof(pchar)) <> 0 then begin\r
+ //swriteln('duplicate window class registered with different settings');\r
+ raise exception.create('duplicate window class registered with different settings');\r
+ end else begin\r
+ //swriteln('duplicate window class registered with same settings, tolerated');\r
+ end;\r
+ end else begin\r
+ //swriteln('about to allocate memory for new windowclass');\r
+ storedwindowclass := getmem(sizeof(twndclass));\r
+ //swriteln('about to copy windowclass from parameter');\r
+ move(lpwndclass,storedwindowclass^,sizeof(twndclass));\r
+ //swriteln('about to copy strings');\r
+ if lpwndclass.lpszmenuname <> nil then storedwindowclass.lpszmenuname := strdup(lpwndclass.lpszmenuname);\r
+ if lpwndclass.lpszclassname <> nil then storedwindowclass.lpszclassname := strdup(lpwndclass.lpszclassname);\r
+ //swriteln('about to add result to list of windowclasses');\r
+ addtree(@windowclasses,lpwndclass.lpszclassname,storedwindowclass);\r
+ end;\r
+ //swriteln('about to return result');\r
+ result := storedwindowclass;\r
+ //swriteln('leaving registerclass');\r
+ finally\r
+ structurelock.release;\r
+ end;\r
+end;\r
+\r
+function CreateWindowEx(dwExStyle:DWORD; lpClassName:LPCSTR; lpWindowName:LPCSTR; dwStyle:DWORD; X:longint;Y:longint; nWidth:longint; nHeight:longint; hWndParent:HWND; hMenu:HMENU;hInstance:HINST; lpParam:LPVOID):HWND;\r
+var\r
+ wndclass : pwndclass;\r
+ tm : tthreadmanager;\r
+ window : twindow;\r
+begin\r
+ structurelock.acquire;\r
+ try\r
+ window := twindow.create;\r
+ window.hwnd := nextwindowhandle;\r
+ result := window.hwnd;\r
+ nextwindowhandle := nextwindowhandle + 1;\r
+ addtree(@windows,inttostr(window.hwnd),window);\r
+ wndclass := findtree(@windowclasses,lpclassname);\r
+ window.extrawindowmemory := getmem(wndclass.cbwndextra);\r
+\r
+ getthreadmanager(tm);\r
+ window.threadid := tm.GetCurrentThreadId;\r
+ window.windowproc := wndclass.lpfnwndproc;\r
+ finally\r
+ structurelock.release;\r
+ end;\r
+end;\r
+function DestroyWindow(ahWnd:HWND):WINBOOL;\r
+var\r
+ window : twindow;\r
+ windowthreaddata : tthreaddata;\r
+ currentmessage : tmessageintransit;\r
+ prevmessage : tmessageintransit;\r
+begin\r
+ //writeln('started to destroy window');\r
+ structurelock.acquire;\r
+ try\r
+ window := twindow(findtree(@windows,inttostr(ahwnd)));\r
+ if window <> nil then begin\r
+ freemem(window.extrawindowmemory);\r
+ //writeln('about to delete window from windows structure');\r
+ deltree(@windows,inttostr(ahwnd));\r
+ //writeln('deleted window from windows structure');\r
+ windowthreaddata := tthreaddata(findtree(@threaddata,inttostr(taddrint(window.threadid))));\r
+\r
+ if windowthreaddata <> nil then begin\r
+ //writeln('found thread data scanning for messages to clean up');\r
+ currentmessage := windowthreaddata.messagequeue;\r
+ prevmessage := nil;\r
+ while currentmessage <> nil do begin\r
+ while (currentmessage <> nil) and (currentmessage.msg.hwnd = ahwnd) do begin\r
+ if prevmessage = nil then begin\r
+ windowthreaddata.messagequeue := currentmessage.next;\r
+ end else begin\r
+ prevmessage.next := currentmessage.next;\r
+ end;\r
+ currentmessage.free;\r
+ if prevmessage = nil then begin\r
+ currentmessage := windowthreaddata.messagequeue;\r
+ end else begin\r
+ currentmessage := prevmessage.next;\r
+ end;\r
+ end;\r
+ if currentmessage <> nil then begin\r
+ prevmessage := currentmessage;\r
+ currentmessage := currentmessage.next;\r
+ end;\r
+ end;\r
+ //writeln('deleting thread data structure if it is unused');\r
+ deletethreaddataifunused(windowthreaddata);\r
+ end else begin\r
+ //writeln('there is no thread data to search for messages to cleanup');\r
+ end;\r
+ //writeln('freeing window');\r
+ window.free;\r
+ result := true;\r
+ end else begin\r
+ result := false;\r
+ end;\r
+ finally\r
+ structurelock.release;\r
+ end;\r
+ //writeln('window destroyed');\r
+end;\r
+\r
+\r
+\r
+function PostMessage(hWnd:HWND; Msg:UINT; wParam:WPARAM; lParam:LPARAM):WINBOOL;\r
+var\r
+ threaddata : tthreaddata;\r
+ message : tmessageintransit;\r
+ messagequeueend : tmessageintransit;\r
+ window : twindow;\r
+begin\r
+ structurelock.acquire;\r
+ try\r
+ window := findtree(@windows,inttostr(hwnd));\r
+ if window <> nil then begin\r
+ threaddata := findthreaddata(window.threadid);\r
+ message := tmessageintransit.create;\r
+ message.msg.hwnd := hwnd;\r
+ message.msg.message := msg;\r
+ message.msg.wparam := wparam;\r
+ message.msg.lparam := lparam;\r
+ if threaddata.lcorethread then begin\r
+ //swriteln('posting message to lcore thread');\r
+ fdwrite(lcorelinkpipesend,message,sizeof(message));\r
+ end else begin\r
+ //writeln('posting message to non lcore thread');\r
+ if threaddata.messagequeue = nil then begin\r
+ threaddata.messagequeue := message;\r
+ end else begin\r
+ messagequeueend := threaddata.messagequeue;\r
+ while messagequeueend.next <> nil do begin\r
+ messagequeueend := messagequeueend.next;\r
+ end;\r
+ messagequeueend.next := message;\r
+ end;\r
+\r
+ //writeln('message added to queue');\r
+ if threaddata.waiting then threaddata.messageevent.setevent;\r
+ end;\r
+ result := true;\r
+ end else begin\r
+ result := false;\r
+ end;\r
+ finally\r
+ structurelock.release;\r
+ end;\r
+\r
+end;\r
+\r
+function gettickcount : dword;\r
+var\r
+ result64: integer;\r
+ tv : ttimeval;\r
+begin\r
+ gettimeofday(tv);\r
+ result64 := (tv.tv_sec*1000)+(tv.tv_usec div 1000);\r
+ result := result64;\r
+end;\r
+\r
+function DispatchMessage(const lpMsg: TMsg): Longint;\r
+var\r
+ timerproc : ttimerproc;\r
+ window : twindow;\r
+ windowproc : twndproc;\r
+begin\r
+ ////swriteln('in dispatchmessage, msg.hwnd='+inttohex(taddrint(lpmsg.hwnd),16));\r
+ if (lpmsg.lparam <> 0) and (lpmsg.message = WM_TIMER) then begin\r
+ timerproc := ttimerproc(lpmsg.lparam);\r
+ timerproc(lpmsg.hwnd,lpmsg.message,lpmsg.wparam,gettickcount);\r
+ result := 0;\r
+ end else begin\r
+ structurelock.acquire;\r
+ try\r
+ window := findtree(@windows,inttostr(lpmsg.hwnd));\r
+ //we have to get the window procedure while the structurelock\r
+ //is still held as the window could be destroyed from another thread\r
+ //otherwise.\r
+ if window <> nil then begin\r
+ windowproc := window.windowproc;\r
+ end else begin\r
+ windowproc := nil;\r
+ end;\r
+ finally\r
+ structurelock.release;\r
+ end;\r
+ if assigned(windowproc) then begin\r
+ result := windowproc(lpmsg.hwnd,lpmsg.message,lpmsg.wparam,lpmsg.lparam);\r
+ end else begin\r
+ result := -1;\r
+ end;\r
+ end;\r
+end;\r
+\r
+procedure processtimers;\r
+begin\r
+end;\r
+\r
+function GetMessageinternal(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax: UINT; wremovemsg : UINT;peek:boolean): WINBOOL;\r
+var\r
+ tm : tthreadmanager;\r
+ threaddata : tthreaddata;\r
+ message : tmessageintransit;\r
+ nowtv : ttimeval;\r
+ timeouttv : ttimeval;\r
+ timeoutms : int64;\r
+\r
+begin\r
+ if hwnd <> 0 then raise exception.create('getting messages for an individual window is not supported');\r
+ if (wmsgfiltermin <> 0) or (wmsgfiltermax <> 0) then raise exception.create('message filtering is not supported');\r
+ structurelock.acquire;\r
+ result := true;\r
+ try\r
+ getthreadmanager(tm);\r
+ threaddata := findthreaddata(tm.GetCurrentThreadId);\r
+ if threaddata.lcorethread then raise exception.create('get/peek message cannot be used in the lcore thread');\r
+ message := threaddata.messagequeue;\r
+ gettimeofday(nowtv);\r
+ while (not peek) and (message=nil) and (not tv_compare(nowtv,threaddata.nexttimer)) do begin\r
+ threaddata.waiting := true;\r
+ structurelock.release;\r
+ if (threaddata.nexttimer.tv_sec = TV_invalidtimebig.tv_sec) and (threaddata.nexttimer.tv_usec = TV_invalidtimebig.tv_usec) then begin\r
+ threaddata.messageevent.waitfor(INFINITE);\r
+ end else begin\r
+\r
+ timeouttv := threaddata.nexttimer;\r
+ timeoutms := (timeouttv.tv_sec * 1000)+(timeouttv.tv_usec div 1000);\r
+ //i'm assuming the timeout is in milliseconds\r
+ if (timeoutms > maxlongint) then timeoutms := maxlongint;\r
+ threaddata.messageevent.waitfor(timeoutms);\r
+\r
+ end;\r
+ structurelock.acquire;\r
+ threaddata.waiting := false;\r
+ message := threaddata.messagequeue;\r
+ gettimeofday(nowtv);\r
+ end;\r
+ if (message=nil) and tv_compare(nowtv,threaddata.nexttimer) then begin\r
+ processtimers;\r
+ end;\r
+ message := threaddata.messagequeue;\r
+ if message <> nil then begin\r
+ lpmsg := message.msg;\r
+ if wremovemsg=PM_REMOVE then begin\r
+ threaddata.messagequeue := message.next;\r
+ message.free;\r
+ end;\r
+ end else begin\r
+ result :=false;\r
+ end;\r
+ deletethreaddataifunused(threaddata);\r
+ finally\r
+ structurelock.release;\r
+ end;\r
+end;\r
+\r
+function GetMessage(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax: UINT): WINBOOL;\r
+begin\r
+ result := getmessageinternal(lpmsg,hwnd,wmsgfiltermin,wmsgfiltermax,PM_REMOVE,false);\r
+end;\r
+\r
+function PeekMessage(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax, wRemoveMsg: UINT): WINBOOL;\r
+begin\r
+ result := getmessageinternal(lpmsg,hwnd,wmsgfiltermin,wmsgfiltermax,wRemoveMsg,true);\r
+end;\r
+\r
+function SetEvent(hEvent:THevent):WINBOOL;\r
+begin\r
+ hevent.setevent;\r
+ result := true;\r
+end;\r
+\r
+function CreateEvent(lpEventAttributes:PSECURITYATTRIBUTES; bManualReset:WINBOOL; bInitialState:WINBOOL; lpName:pchar):tHevent;\r
+begin\r
+ result := teventobject.create(lpeventattributes,bmanualreset,binitialstate,lpname);\r
+end;\r
+\r
+function terminatethread(threadhandle:tthreadid;dummy : integer) : boolean;\r
+var\r
+ tm : tthreadmanager;\r
+begin\r
+ getthreadmanager(tm);\r
+ tm.killthread(threadhandle);\r
+ result := true;\r
+end;\r
+\r
+function waitforsingleevent(event:thevent;timeout:cardinal) : twaitresult;\r
+begin\r
+ result := event.waitfor(timeout);\r
+end;\r
+\r
+procedure removefrombuffer(n : integer; var buffer:string);\r
+begin\r
+ if n=length(buffer) then begin\r
+ buffer := '';\r
+ end else begin\r
+ uniquestring(buffer);\r
+ move(buffer[n+1],buffer[1],length(buffer)-n);\r
+ setlength(buffer,length(buffer)-n);\r
+ end;\r
+end;\r
+\r
+type\r
+ tsc=class\r
+ procedure available(sender:tobject;error:word);\r
+ end;\r
+\r
+var\r
+ recvbuf : string;\r
+\r
+procedure tsc.available(sender:tobject;error:word);\r
+var\r
+ message : tmessageintransit;\r
+ messagebytes : array[1..sizeof(tmessageintransit)] of char absolute message;\r
+ i : integer;\r
+begin\r
+ //swriteln('received data on lcorelinkpipe');\r
+ recvbuf := recvbuf + lcorelinkpiperecv.receivestr;\r
+ while length(recvbuf) >= sizeof(tmessageintransit) do begin\r
+ for i := 1 to sizeof(tmessageintransit) do begin\r
+ messagebytes[i] := recvbuf[i];\r
+ end;\r
+ dispatchmessage(message.msg);\r
+ message.free;\r
+ removefrombuffer(sizeof(tmessageintransit),recvbuf);\r
+ end;\r
+end;\r
+\r
+procedure init;\r
+var\r
+ tm : tthreadmanager;\r
+ threaddata : tthreaddata;\r
+ pipeends : tfildes;\r
+ sc : tsc;\r
+begin\r
+ structurelock := tcriticalsection.create;\r
+ getthreadmanager(tm);\r
+ threaddata := findthreaddata(tm.GetCurrentThreadId);\r
+ threaddata.lcorethread := true;\r
+ fppipe(pipeends);\r
+ lcorelinkpipesend := pipeends[1];\r
+ lcorelinkpiperecv := tlasio.create(nil);\r
+ lcorelinkpiperecv.dup(pipeends[0]);\r
+ lcorelinkpiperecv.ondataavailable := sc.available;\r
+ recvbuf := '';\r
+end;\r
+\r
+var\r
+ lcorethreadtimers : thashtable;\r
+type\r
+ tltimerformsg = class(tltimer)\r
+ public\r
+ hwnd : hwnd;\r
+ id : taddrint;\r
+ procedure timer(sender : tobject);\r
+ end;\r
+\r
+procedure tltimerformsg.timer(sender : tobject);\r
+var\r
+ msg : tmsg;\r
+begin\r
+ ////swriteln('in tltimerformsg.timer');\r
+ fillchar(msg,sizeof(msg),0);\r
+ msg.message := WM_TIMER;\r
+ msg.hwnd := hwnd;\r
+ msg.wparam := ID;\r
+ msg.lparam := 0;\r
+ dispatchmessage(msg);\r
+end;\r
+\r
+function SetTimer(ahWnd:HWND; nIDEvent:taddrint; uElapse:UINT; lpTimerFunc:tTIMERPROC):UINT;\r
+var\r
+ threaddata : tthreaddata;\r
+ ltimer : tltimerformsg;\r
+ tm : tthreadmanager;\r
+ window : twindow;\r
+begin\r
+ structurelock.acquire;\r
+ try\r
+ window := findtree(@windows,inttostr(ahwnd));\r
+ if window= nil then raise exception.create('invalid window');\r
+ threaddata := findthreaddata(window.threadid);\r
+ finally\r
+ structurelock.release;\r
+ end;\r
+ if threaddata.lcorethread then begin\r
+ getthreadmanager(tm);\r
+ if tm.GetCurrentThreadId <> window.threadid then raise exception.create('timers on the lcore thread may only be added and removed from the lcore thread');\r
+ if ahwnd = 0 then raise exception.create('timers on the lcore thread must be associated with a window handle');\r
+ if @lptimerfunc <> nil then raise exception.create('seperate timer functions are not supported');\r
+\r
+ //remove preexisting timer with same ID\r
+ killtimer(ahwnd,nIDEvent);\r
+\r
+ ltimer := tltimerformsg.create(nil);\r
+ ltimer.interval := uelapse;\r
+ ltimer.id := nidevent;\r
+ ltimer.hwnd := ahwnd;\r
+ ltimer.enabled := true;\r
+ ltimer.ontimer := ltimer.timer;\r
+\r
+ addtree(@lcorethreadtimers,inttostr(taddrint(ahwnd))+' '+inttostr(nIDEvent),ltimer);\r
+\r
+ result := nidevent;\r
+ end else begin\r
+ raise exception.create('settimer not implemented for threads other than the lcore thread');\r
+ end;\r
+end;\r
+\r
+function KillTimer(ahWnd:HWND; uIDEvent:taddrint):WINBOOL;\r
+var\r
+ threaddata : tthreaddata;\r
+ ltimer : tltimerformsg;\r
+ tm : tthreadmanager;\r
+ window : twindow;\r
+begin\r
+ structurelock.acquire;\r
+ try\r
+ window := findtree(@windows,inttostr(ahwnd));\r
+ if window= nil then raise exception.create('invalid window');\r
+ threaddata := findthreaddata(window.threadid);\r
+ finally\r
+ structurelock.release;\r
+ end;\r
+ if threaddata.lcorethread then begin\r
+ getthreadmanager(tm);\r
+ if tm.GetCurrentThreadId <> window.threadid then raise exception.create('timers on the lcore thread may only be added and remove from the lcore thread');\r
+ if ahwnd = 0 then raise exception.create('timers on the lcore thread must be associated with a window handle');\r
+ ltimer := tltimerformsg(findtree(@lcorethreadtimers,inttostr(taddrint(ahwnd))+' '+inttostr(uIDEvent)));\r
+ if ltimer <> nil then begin\r
+ deltree(@lcorethreadtimers,inttostr(taddrint(ahwnd))+' '+inttostr(uIDEvent));\r
+ ltimer.free;\r
+ result := true;\r
+ end else begin\r
+ result := false;\r
+ end;\r
+ end else begin\r
+ raise exception.create('settimer not implemented for threads other than the lcore thread');\r
+ end;\r
+end;\r
+\r
+end.\r
lcore.org gitweb / lcore.git / blobdiff