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