lmessages.pas

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