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

Annotation of /trunk/lcoremessages.pas

Parent Directory Parent Directory | Revision Log Revision Log


Revision 61 - (hide annotations)
Thu Feb 4 22:47:07 2010 UTC (10 years, 6 months ago) by plugwash
Original Path: trunk/lmessages.pas
File size: 22425 byte(s)
set line ending property on files to hopefully avoid line ending problems in future

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