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

Contents of /trunk/lmessages.pas

Parent Directory Parent Directory | Revision Log Revision Log


Revision 73 - (show annotations)
Fri Feb 12 00:51:00 2010 UTC (10 years 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 { 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 //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 unit lmessages;
12 //windows messages like system based on lcore tasks
13 interface
14
15 uses pgtypes,sysutils,bsearchtree,strings,syncobjs;
16
17
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 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
82 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 baseunix,unix,lcore,unixutil,ltimevalstuff,sockets;//,safewriteln;
104 {$i unixstuff.inc}
105
106 type
107
108 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 threadid : tthreadid;
120 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
142 //findthreaddata should only be called while holding the structurelock
143 function findthreaddata(threadid : tthreadid) : tthreaddata;
144 begin
145 result := tthreaddata(findtree(@threaddata,inttostr(taddrint(threadid))));
146 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 addtree(@threaddata,inttostr(taddrint(threadid)),result);
152 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 deltree(@threaddata,inttostr(taddrint(athreaddata.threadid)));
166 //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 windowthreaddata := tthreaddata(findtree(@threaddata,inttostr(taddrint(window.threadid))));
298
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 if window <> nil then begin
415 windowproc := window.windowproc;
416 end else begin
417 windowproc := nil;
418 end;
419 finally
420 structurelock.release;
421 end;
422 if assigned(windowproc) then begin
423 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 result := getmessageinternal(lpmsg,hwnd,wmsgfiltermin,wmsgfiltermax,wRemoveMsg,true);
500 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 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