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