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

Annotation of /trunk/lmessages.pas

Parent Directory Parent Directory | Revision Log Revision Log


Revision 73 - (hide annotations)
Fri Feb 12 00:51:00 2010 UTC (10 years, 8 months ago) by plugwash
File size: 22475 byte(s)
make some os-x related fixes to lmessages

force bindv6only to 0 to make things behave with debian squeeze+  (note: this 
is likely to break on some operating systems but I suspect said operating 
systems were broken already)


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

Properties

Name Value
svn:eol-style CRLF
svn:executable

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