+++ /dev/null
-unit lmessages;\r
-//windows messages like system based on lcore tasks\r
-interface\r
-\r
-uses pgtypes,sysutils,bsearchtree,strings,syncobjs;\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
- hinstance=nil;\r
- PM_REMOVE = 1;\r
- WM_USER = 1024;\r
- WM_TIMER = 275;\r
- INFINITE = syncobjs.infinite;\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;//,safewriteln;\r
-{$i unixstuff.inc}\r
-\r
-type\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 : integer;\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 insufficiant size type\r
- //than crash after over four billion\r
- //windows have been made ;)\r
- nextwindowhandle : qword = $100000000;\r
-{$i ltimevalstuff.inc}\r
-\r
-//findthreaddata should only be called while holding the structurelock\r
-function findthreaddata(threadid : integer) : tthreaddata;\r
-begin\r
- result := tthreaddata(findtree(@threaddata,inttostr(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(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(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, tollerated');\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('aboute to delete window from windows structure');\r
- deltree(@windows,inttostr(ahwnd));\r
- //writeln('deleted window from windows structure');\r
- windowthreaddata := tthreaddata(findtree(@threaddata,inttostr(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
- windowproc := window.windowproc;\r
- finally\r
- structurelock.release;\r
- end;\r
- if window <> nil 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,PM_REMOVE,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.
\ No newline at end of file
lcore.org gitweb / lcore.git / blobdiff