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

Contents of /trunk/lcoremessages.pas

Parent Directory Parent Directory | Revision Log Revision Log


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

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

Properties

Name Value
svn:eol-style CRLF

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