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

Contents of /trunk/lcoremessages.pas

Parent Directory Parent Directory | Revision Log Revision Log


Revision 39 - (show annotations)
Sun Feb 15 03:19:42 2009 UTC (11 years, 5 months ago) by plugwash
Original Path: trunk/lmessages.pas
File size: 22420 byte(s)
fix a small error 

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 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 baseunix,unix,lcore,unixutil;//,safewriteln;
103 {$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 {$i ltimevalstuff.inc}
139
140 //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 if window <> nil then begin
413 windowproc := window.windowproc;
414 end else begin
415 windowproc := nil;
416 end;
417 finally
418 structurelock.release;
419 end;
420 if assigned(windowproc) then begin
421 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 result := getmessageinternal(lpmsg,hwnd,wmsgfiltermin,wmsgfiltermax,PM_REMOVE,true);
498 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 end.

Properties

Name Value
svn:executable

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