/[lcore]/trunk/lcoremessages.pas
ViewVC logotype

Annotation of /trunk/lcoremessages.pas

Parent Directory Parent Directory | Revision Log Revision Log


Revision 149 - (hide annotations)
Sun Sep 10 20:02:13 2017 UTC (3 years ago) by plugwash
File size: 22504 byte(s)
Replace obsolete/broken lcoregtklaz with new lcorelazarus
Rename lmessages to lcoremessages due to unit name conflict with Lazarus


1 plugwash 26 { Copyright (C) 2005 Bas Steendijk and Peter Green
2     For conditions of distribution and use, see copyright notice in zlib_license.txt
3     which is included in the package
4     ----------------------------------------------------------------------------- }
5    
6 plugwash 32 //this unit provides a rough approximation of windows messages on linux
7 beware 136 //it is useful for multithreaded applications on linux to communicate back to
8 plugwash 32 //the main lcore thread
9     //This unit is *nix only, on windows you should use the real thing
10    
11 plugwash 149 unit lcoremessages;
12 plugwash 1 //windows messages like system based on lcore tasks
13     interface
14    
15     uses pgtypes,sysutils,bsearchtree,strings,syncobjs;
16    
17 plugwash 35
18     {$if (fpc_version < 2) or ((fpc_version=2) and ((fpc_release < 2) or ((fpc_release = 2) and (fpc_patch < 2)) ))}
19     {$error this code is only supported under fpc 2.2.2 and above due to bugs in the eventobject code in older versions}
20     {$endif}
21    
22 plugwash 1 type
23     lparam=taddrint;
24     wparam=taddrint;
25     thinstance=pointer;
26     hicon=pointer;
27     hcursor=pointer;
28     hbrush=pointer;
29     hwnd=qword; //window handles are monotonically increasing 64 bit integers,
30     //this should allow for a million windows per second for over half
31     //a million years!
32    
33     twndproc=function(ahWnd:HWND; auMsg:Integer; awParam:WPARAM; alParam:LPARAM):Integer; stdcall;
34    
35    
36     twndclass=record
37     style : dword;
38     lpfnwndproc : twndproc;
39     cbclsextra : integer;
40     cbwndextra : integer;
41     hinstance : thinstance;
42     hicon : hicon;
43     hcursor : hcursor;
44     hbrbackground : hbrush;
45     lpszmenuname : pchar;
46     lpszclassname : pchar;
47     end;
48     PWNDCLASS=^twndclass;
49    
50     UINT=dword;
51     WINBOOL = longbool;
52     tTIMERPROC = procedure (ahwnd:HWND; umsg:integer; idevent:taddrint;dwtime:taddrint);stdcall;
53     ATOM = pointer;
54     LPCSTR = pchar;
55     LPVOID = pointer;
56     HMENU = pointer;
57     HINST = pointer;
58    
59     TPOINT = record
60     x : LONGint;
61     y : LONGint;
62     end;
63    
64     TMSG = record
65     hwnd : HWND;
66     message : UINT;
67     wParam : WPARAM;
68     lParam : LPARAM;
69     time : DWORD;
70     pt : TPOINT;
71     end;
72     THevent=TEventObject;
73     const
74     WS_EX_TOOLWINDOW = $80;
75     WS_POPUP = longint($80000000);
76 beware 130 CW_USEDEFAULT=$80000000;
77 plugwash 1 hinstance=nil;
78     PM_REMOVE = 1;
79     WM_USER = 1024;
80     WM_TIMER = 275;
81     INFINITE = syncobjs.infinite;
82 plugwash 73
83 plugwash 1 function getwindowlongptr(ahwnd:hwnd;nindex:integer) : taddrint;
84     function setwindowlongptr(ahwnd:hwnd;nindex:integer;dwNewLong : taddrint) : taddrint;
85     function DefWindowProc(ahWnd:HWND; auMsg:Integer; awParam:WPARAM; alParam:LPARAM):Integer; stdcall;
86     function RegisterClass(const lpWndClass:TWNDCLASS):ATOM;
87     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;
88     function DestroyWindow(ahWnd:HWND):WINBOOL;
89     function PostMessage(hWnd:HWND; Msg:UINT; wParam:WPARAM; lParam:LPARAM):WINBOOL;
90     function PeekMessage(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax, wRemoveMsg: UINT): WINBOOL;
91     function DispatchMessage(const lpMsg: TMsg): Longint;
92     function GetMessage(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax: UINT): WINBOOL;
93     function SetEvent(hEvent:THevent):WINBOOL;
94     function CreateEvent(lpEventAttributes:PSECURITYATTRIBUTES; bManualReset:WINBOOL; bInitialState:WINBOOL; lpName:pchar):tHevent;
95     function terminatethread(threadhandle : tthreadid;dummy:integer) : boolean;
96     function waitforsingleevent(event:thevent;timeout:cardinal) : twaitresult;
97     function SetTimer(ahWnd:HWND; nIDEvent:taddrint; uElapse:UINT; lpTimerFunc:tTIMERPROC):UINT;
98     function KillTimer(ahWnd:HWND; uIDEvent:taddrint):WINBOOL;
99    
100     procedure init;
101    
102     implementation
103     uses
104 plugwash 60 baseunix,unix,lcore,unixutil,ltimevalstuff,sockets;//,safewriteln;
105 plugwash 1 {$i unixstuff.inc}
106    
107     type
108 plugwash 73
109 plugwash 1 tmessageintransit = class
110     msg : tmsg;
111     next : tmessageintransit;
112     end;
113    
114     tthreaddata = class
115     messagequeue : tmessageintransit;
116     messageevent : teventobject;
117     waiting : boolean;
118     lcorethread : boolean;
119     nexttimer : ttimeval;
120 plugwash 73 threadid : tthreadid;
121 plugwash 1 end;
122     twindow=class
123     hwnd : hwnd;
124     extrawindowmemory : pointer;
125     threadid : tthreadid;
126     windowproc : twndproc;
127     end;
128    
129     var
130     structurelock : tcriticalsection;
131     threaddata : thashtable;
132     windowclasses : thashtable;
133     lcorelinkpipesend : integer;
134     lcorelinkpiperecv : tlasio;
135     windows : thashtable;
136     //I would rather things crash immediately
137 beware 136 //if they use an insufficient size type
138 plugwash 1 //than crash after over four billion
139     //windows have been made ;)
140     nextwindowhandle : qword = $100000000;
141    
142 plugwash 59
143 plugwash 1 //findthreaddata should only be called while holding the structurelock
144 plugwash 73 function findthreaddata(threadid : tthreadid) : tthreaddata;
145 plugwash 1 begin
146 plugwash 73 result := tthreaddata(findtree(@threaddata,inttostr(taddrint(threadid))));
147 plugwash 1 if result = nil then begin
148     result := tthreaddata.create;
149     result.messageevent := teventobject.create(nil,false,false,inttostr(taddrint(result)));
150     result.nexttimer := tv_invalidtimebig;
151     result.threadid := threadid;
152 plugwash 73 addtree(@threaddata,inttostr(taddrint(threadid)),result);
153 plugwash 1 end;
154     end;
155    
156     //deletethreaddataifunused should only be called while holding the structurelock
157     procedure deletethreaddataifunused(athreaddata : tthreaddata);
158     begin
159     //writeln('in deletethreaddataifunused');
160     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
161     //writeln('threaddata is unused, freeing messageevent');
162     athreaddata.messageevent.free;
163     //writeln('freeing thread data object');
164     athreaddata.free;
165     //writeln('deleting thread data object from hashtable');
166 plugwash 73 deltree(@threaddata,inttostr(taddrint(athreaddata.threadid)));
167 plugwash 1 //writeln('finished deleting thread data');
168     end else begin
169     //writeln('thread data is not unused');
170     end;
171     end;
172    
173     function getwindowlongptr(ahwnd:hwnd;nindex:integer) : taddrint;
174     var
175     window : twindow;
176     begin
177     structurelock.acquire;
178     try
179     window := findtree(@windows,inttostr(ahwnd));
180     if window <> nil then begin
181     result := paddrint(taddrint(window.extrawindowmemory)+nindex)^;
182     end else begin
183     result := 0;
184     end;
185     finally
186     structurelock.release;
187     end;
188     end;
189    
190     function setwindowlongptr(ahwnd:hwnd;nindex:integer;dwNewLong : taddrint) : taddrint;
191     var
192     window : twindow;
193     begin
194     structurelock.acquire;
195     try
196     window := findtree(@windows,inttostr(ahwnd));
197     if window <> nil then begin
198     result := paddrint(taddrint(window.extrawindowmemory)+nindex)^;
199     paddrint(taddrint(window.extrawindowmemory)+nindex)^ := dwnewlong;
200     end else begin
201     result := 0;
202     end;
203     finally
204     structurelock.release;
205     end;
206    
207     end;
208    
209    
210     function DefWindowProc(ahWnd:HWND; auMsg:Integer; awParam:WPARAM; alParam:LPARAM):Integer; stdcall;
211     begin
212     result := 0;
213     end;
214    
215     function strdup(s:pchar) : pchar;
216     begin
217     //swriteln('in strdup, about to allocate memory');
218     result := getmem(strlen(s)+1);
219     //swriteln('about to copy string');
220     strcopy(s,result);
221     //swriteln('leaving strdup');
222     end;
223    
224     function RegisterClass(const lpWndClass:TWNDCLASS):ATOM;
225     var
226     storedwindowclass:pwndclass;
227     begin
228     structurelock.acquire;
229     try
230     //swriteln('in registerclass, about to check for duplicate window class');
231     storedwindowclass := findtree(@windowclasses, lpwndclass.lpszclassname);
232     if storedwindowclass <> nil then begin
233    
234     if comparebyte(storedwindowclass^,lpwndclass,sizeof(twndclass)-sizeof(pchar)-sizeof(pchar)) <> 0 then begin
235     //swriteln('duplicate window class registered with different settings');
236     raise exception.create('duplicate window class registered with different settings');
237     end else begin
238 beware 136 //swriteln('duplicate window class registered with same settings, tolerated');
239 plugwash 1 end;
240     end else begin
241     //swriteln('about to allocate memory for new windowclass');
242     storedwindowclass := getmem(sizeof(twndclass));
243     //swriteln('about to copy windowclass from parameter');
244     move(lpwndclass,storedwindowclass^,sizeof(twndclass));
245     //swriteln('about to copy strings');
246     if lpwndclass.lpszmenuname <> nil then storedwindowclass.lpszmenuname := strdup(lpwndclass.lpszmenuname);
247     if lpwndclass.lpszclassname <> nil then storedwindowclass.lpszclassname := strdup(lpwndclass.lpszclassname);
248     //swriteln('about to add result to list of windowclasses');
249     addtree(@windowclasses,lpwndclass.lpszclassname,storedwindowclass);
250     end;
251     //swriteln('about to return result');
252     result := storedwindowclass;
253     //swriteln('leaving registerclass');
254     finally
255     structurelock.release;
256     end;
257     end;
258    
259     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;
260     var
261     wndclass : pwndclass;
262     tm : tthreadmanager;
263     window : twindow;
264     begin
265     structurelock.acquire;
266     try
267     window := twindow.create;
268     window.hwnd := nextwindowhandle;
269     result := window.hwnd;
270     nextwindowhandle := nextwindowhandle + 1;
271     addtree(@windows,inttostr(window.hwnd),window);
272     wndclass := findtree(@windowclasses,lpclassname);
273     window.extrawindowmemory := getmem(wndclass.cbwndextra);
274    
275     getthreadmanager(tm);
276     window.threadid := tm.GetCurrentThreadId;
277     window.windowproc := wndclass.lpfnwndproc;
278     finally
279     structurelock.release;
280     end;
281     end;
282     function DestroyWindow(ahWnd:HWND):WINBOOL;
283     var
284     window : twindow;
285     windowthreaddata : tthreaddata;
286     currentmessage : tmessageintransit;
287     prevmessage : tmessageintransit;
288     begin
289     //writeln('started to destroy window');
290     structurelock.acquire;
291     try
292     window := twindow(findtree(@windows,inttostr(ahwnd)));
293     if window <> nil then begin
294     freemem(window.extrawindowmemory);
295 beware 136 //writeln('about to delete window from windows structure');
296 plugwash 1 deltree(@windows,inttostr(ahwnd));
297     //writeln('deleted window from windows structure');
298 plugwash 73 windowthreaddata := tthreaddata(findtree(@threaddata,inttostr(taddrint(window.threadid))));
299 plugwash 1
300     if windowthreaddata <> nil then begin
301     //writeln('found thread data scanning for messages to clean up');
302     currentmessage := windowthreaddata.messagequeue;
303     prevmessage := nil;
304     while currentmessage <> nil do begin
305     while (currentmessage <> nil) and (currentmessage.msg.hwnd = ahwnd) do begin
306     if prevmessage = nil then begin
307     windowthreaddata.messagequeue := currentmessage.next;
308     end else begin
309     prevmessage.next := currentmessage.next;
310     end;
311     currentmessage.free;
312     if prevmessage = nil then begin
313     currentmessage := windowthreaddata.messagequeue;
314     end else begin
315     currentmessage := prevmessage.next;
316     end;
317     end;
318     if currentmessage <> nil then begin
319     prevmessage := currentmessage;
320     currentmessage := currentmessage.next;
321     end;
322     end;
323     //writeln('deleting thread data structure if it is unused');
324     deletethreaddataifunused(windowthreaddata);
325     end else begin
326     //writeln('there is no thread data to search for messages to cleanup');
327     end;
328     //writeln('freeing window');
329     window.free;
330     result := true;
331     end else begin
332     result := false;
333     end;
334     finally
335     structurelock.release;
336     end;
337     //writeln('window destroyed');
338     end;
339    
340    
341    
342     function PostMessage(hWnd:HWND; Msg:UINT; wParam:WPARAM; lParam:LPARAM):WINBOOL;
343     var
344     threaddata : tthreaddata;
345     message : tmessageintransit;
346     messagequeueend : tmessageintransit;
347     window : twindow;
348     begin
349     structurelock.acquire;
350     try
351     window := findtree(@windows,inttostr(hwnd));
352     if window <> nil then begin
353     threaddata := findthreaddata(window.threadid);
354     message := tmessageintransit.create;
355     message.msg.hwnd := hwnd;
356     message.msg.message := msg;
357     message.msg.wparam := wparam;
358     message.msg.lparam := lparam;
359     if threaddata.lcorethread then begin
360     //swriteln('posting message to lcore thread');
361     fdwrite(lcorelinkpipesend,message,sizeof(message));
362     end else begin
363     //writeln('posting message to non lcore thread');
364     if threaddata.messagequeue = nil then begin
365     threaddata.messagequeue := message;
366     end else begin
367     messagequeueend := threaddata.messagequeue;
368     while messagequeueend.next <> nil do begin
369     messagequeueend := messagequeueend.next;
370     end;
371     messagequeueend.next := message;
372     end;
373    
374     //writeln('message added to queue');
375     if threaddata.waiting then threaddata.messageevent.setevent;
376     end;
377     result := true;
378     end else begin
379     result := false;
380     end;
381     finally
382     structurelock.release;
383     end;
384    
385     end;
386    
387     function gettickcount : dword;
388     var
389     result64: integer;
390     tv : ttimeval;
391     begin
392     gettimeofday(tv);
393     result64 := (tv.tv_sec*1000)+(tv.tv_usec div 1000);
394     result := result64;
395     end;
396    
397     function DispatchMessage(const lpMsg: TMsg): Longint;
398     var
399     timerproc : ttimerproc;
400     window : twindow;
401     windowproc : twndproc;
402     begin
403     ////swriteln('in dispatchmessage, msg.hwnd='+inttohex(taddrint(lpmsg.hwnd),16));
404     if (lpmsg.lparam <> 0) and (lpmsg.message = WM_TIMER) then begin
405     timerproc := ttimerproc(lpmsg.lparam);
406     timerproc(lpmsg.hwnd,lpmsg.message,lpmsg.wparam,gettickcount);
407     result := 0;
408     end else begin
409     structurelock.acquire;
410     try
411     window := findtree(@windows,inttostr(lpmsg.hwnd));
412     //we have to get the window procedure while the structurelock
413     //is still held as the window could be destroyed from another thread
414     //otherwise.
415 plugwash 41 if window <> nil then begin
416 plugwash 38 windowproc := window.windowproc;
417 plugwash 41 end else begin
418     windowproc := nil;
419     end;
420 plugwash 1 finally
421     structurelock.release;
422     end;
423 plugwash 39 if assigned(windowproc) then begin
424 plugwash 1 result := windowproc(lpmsg.hwnd,lpmsg.message,lpmsg.wparam,lpmsg.lparam);
425     end else begin
426     result := -1;
427     end;
428     end;
429     end;
430    
431     procedure processtimers;
432     begin
433     end;
434    
435     function GetMessageinternal(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax: UINT; wremovemsg : UINT;peek:boolean): WINBOOL;
436     var
437     tm : tthreadmanager;
438     threaddata : tthreaddata;
439     message : tmessageintransit;
440     nowtv : ttimeval;
441     timeouttv : ttimeval;
442     timeoutms : int64;
443    
444     begin
445     if hwnd <> 0 then raise exception.create('getting messages for an individual window is not supported');
446     if (wmsgfiltermin <> 0) or (wmsgfiltermax <> 0) then raise exception.create('message filtering is not supported');
447     structurelock.acquire;
448     result := true;
449     try
450     getthreadmanager(tm);
451     threaddata := findthreaddata(tm.GetCurrentThreadId);
452     if threaddata.lcorethread then raise exception.create('get/peek message cannot be used in the lcore thread');
453     message := threaddata.messagequeue;
454     gettimeofday(nowtv);
455     while (not peek) and (message=nil) and (not tv_compare(nowtv,threaddata.nexttimer)) do begin
456     threaddata.waiting := true;
457     structurelock.release;
458     if (threaddata.nexttimer.tv_sec = TV_invalidtimebig.tv_sec) and (threaddata.nexttimer.tv_usec = TV_invalidtimebig.tv_usec) then begin
459     threaddata.messageevent.waitfor(INFINITE);
460     end else begin
461    
462     timeouttv := threaddata.nexttimer;
463     timeoutms := (timeouttv.tv_sec * 1000)+(timeouttv.tv_usec div 1000);
464     //i'm assuming the timeout is in milliseconds
465     if (timeoutms > maxlongint) then timeoutms := maxlongint;
466     threaddata.messageevent.waitfor(timeoutms);
467    
468     end;
469     structurelock.acquire;
470     threaddata.waiting := false;
471     message := threaddata.messagequeue;
472     gettimeofday(nowtv);
473     end;
474     if (message=nil) and tv_compare(nowtv,threaddata.nexttimer) then begin
475     processtimers;
476     end;
477     message := threaddata.messagequeue;
478     if message <> nil then begin
479     lpmsg := message.msg;
480     if wremovemsg=PM_REMOVE then begin
481     threaddata.messagequeue := message.next;
482     message.free;
483     end;
484     end else begin
485     result :=false;
486     end;
487     deletethreaddataifunused(threaddata);
488     finally
489     structurelock.release;
490     end;
491     end;
492    
493     function GetMessage(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax: UINT): WINBOOL;
494     begin
495     result := getmessageinternal(lpmsg,hwnd,wmsgfiltermin,wmsgfiltermax,PM_REMOVE,false);
496     end;
497    
498     function PeekMessage(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax, wRemoveMsg: UINT): WINBOOL;
499     begin
500 plugwash 42 result := getmessageinternal(lpmsg,hwnd,wmsgfiltermin,wmsgfiltermax,wRemoveMsg,true);
501 plugwash 1 end;
502    
503     function SetEvent(hEvent:THevent):WINBOOL;
504     begin
505     hevent.setevent;
506     result := true;
507     end;
508    
509     function CreateEvent(lpEventAttributes:PSECURITYATTRIBUTES; bManualReset:WINBOOL; bInitialState:WINBOOL; lpName:pchar):tHevent;
510     begin
511     result := teventobject.create(lpeventattributes,bmanualreset,binitialstate,lpname);
512     end;
513    
514     function terminatethread(threadhandle:tthreadid;dummy : integer) : boolean;
515     var
516     tm : tthreadmanager;
517     begin
518     getthreadmanager(tm);
519     tm.killthread(threadhandle);
520     result := true;
521     end;
522    
523     function waitforsingleevent(event:thevent;timeout:cardinal) : twaitresult;
524     begin
525     result := event.waitfor(timeout);
526     end;
527    
528     procedure removefrombuffer(n : integer; var buffer:string);
529     begin
530     if n=length(buffer) then begin
531     buffer := '';
532     end else begin
533     uniquestring(buffer);
534     move(buffer[n+1],buffer[1],length(buffer)-n);
535     setlength(buffer,length(buffer)-n);
536     end;
537     end;
538    
539     type
540     tsc=class
541     procedure available(sender:tobject;error:word);
542     end;
543    
544     var
545     recvbuf : string;
546    
547     procedure tsc.available(sender:tobject;error:word);
548     var
549     message : tmessageintransit;
550     messagebytes : array[1..sizeof(tmessageintransit)] of char absolute message;
551     i : integer;
552     begin
553     //swriteln('received data on lcorelinkpipe');
554     recvbuf := recvbuf + lcorelinkpiperecv.receivestr;
555     while length(recvbuf) >= sizeof(tmessageintransit) do begin
556     for i := 1 to sizeof(tmessageintransit) do begin
557     messagebytes[i] := recvbuf[i];
558     end;
559     dispatchmessage(message.msg);
560     message.free;
561     removefrombuffer(sizeof(tmessageintransit),recvbuf);
562     end;
563     end;
564    
565     procedure init;
566     var
567     tm : tthreadmanager;
568     threaddata : tthreaddata;
569     pipeends : tfildes;
570     sc : tsc;
571     begin
572     structurelock := tcriticalsection.create;
573     getthreadmanager(tm);
574     threaddata := findthreaddata(tm.GetCurrentThreadId);
575     threaddata.lcorethread := true;
576     fppipe(pipeends);
577     lcorelinkpipesend := pipeends[1];
578     lcorelinkpiperecv := tlasio.create(nil);
579     lcorelinkpiperecv.dup(pipeends[0]);
580     lcorelinkpiperecv.ondataavailable := sc.available;
581     recvbuf := '';
582     end;
583    
584     var
585     lcorethreadtimers : thashtable;
586     type
587     tltimerformsg = class(tltimer)
588     public
589     hwnd : hwnd;
590     id : taddrint;
591     procedure timer(sender : tobject);
592     end;
593    
594     procedure tltimerformsg.timer(sender : tobject);
595     var
596     msg : tmsg;
597     begin
598     ////swriteln('in tltimerformsg.timer');
599     fillchar(msg,sizeof(msg),0);
600     msg.message := WM_TIMER;
601     msg.hwnd := hwnd;
602     msg.wparam := ID;
603     msg.lparam := 0;
604     dispatchmessage(msg);
605     end;
606    
607     function SetTimer(ahWnd:HWND; nIDEvent:taddrint; uElapse:UINT; lpTimerFunc:tTIMERPROC):UINT;
608     var
609     threaddata : tthreaddata;
610     ltimer : tltimerformsg;
611     tm : tthreadmanager;
612     window : twindow;
613     begin
614     structurelock.acquire;
615     try
616     window := findtree(@windows,inttostr(ahwnd));
617     if window= nil then raise exception.create('invalid window');
618     threaddata := findthreaddata(window.threadid);
619     finally
620     structurelock.release;
621     end;
622     if threaddata.lcorethread then begin
623     getthreadmanager(tm);
624     if tm.GetCurrentThreadId <> window.threadid then raise exception.create('timers on the lcore thread may only be added and removed from the lcore thread');
625     if ahwnd = 0 then raise exception.create('timers on the lcore thread must be associated with a window handle');
626     if @lptimerfunc <> nil then raise exception.create('seperate timer functions are not supported');
627    
628     //remove preexisting timer with same ID
629     killtimer(ahwnd,nIDEvent);
630    
631     ltimer := tltimerformsg.create(nil);
632     ltimer.interval := uelapse;
633     ltimer.id := nidevent;
634     ltimer.hwnd := ahwnd;
635     ltimer.enabled := true;
636     ltimer.ontimer := ltimer.timer;
637    
638     addtree(@lcorethreadtimers,inttostr(taddrint(ahwnd))+' '+inttostr(nIDEvent),ltimer);
639    
640     result := nidevent;
641     end else begin
642     raise exception.create('settimer not implemented for threads other than the lcore thread');
643     end;
644     end;
645    
646     function KillTimer(ahWnd:HWND; uIDEvent:taddrint):WINBOOL;
647     var
648     threaddata : tthreaddata;
649     ltimer : tltimerformsg;
650     tm : tthreadmanager;
651     window : twindow;
652     begin
653     structurelock.acquire;
654     try
655     window := findtree(@windows,inttostr(ahwnd));
656     if window= nil then raise exception.create('invalid window');
657     threaddata := findthreaddata(window.threadid);
658     finally
659     structurelock.release;
660     end;
661     if threaddata.lcorethread then begin
662     getthreadmanager(tm);
663     if tm.GetCurrentThreadId <> window.threadid then raise exception.create('timers on the lcore thread may only be added and remove from the lcore thread');
664     if ahwnd = 0 then raise exception.create('timers on the lcore thread must be associated with a window handle');
665     ltimer := tltimerformsg(findtree(@lcorethreadtimers,inttostr(taddrint(ahwnd))+' '+inttostr(uIDEvent)));
666     if ltimer <> nil then begin
667     deltree(@lcorethreadtimers,inttostr(taddrint(ahwnd))+' '+inttostr(uIDEvent));
668     ltimer.free;
669     result := true;
670     end else begin
671     result := false;
672     end;
673     end else begin
674     raise exception.create('settimer not implemented for threads other than the lcore thread');
675     end;
676     end;
677    
678 beware 19 end.

Properties

Name Value
svn:eol-style CRLF

No admin address has been configured">No admin address has been configured
ViewVC Help
Powered by ViewVC 1.1.22