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