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