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;//,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 {$i ltimevalstuff.inc}\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       windowproc := window.windowproc;\r
 413     finally\r
 414       structurelock.release;\r
 415     end;\r
 416     if window <> nil then begin\r
 417       result := windowproc(lpmsg.hwnd,lpmsg.message,lpmsg.wparam,lpmsg.lparam);\r
 418     end else begin\r
 419       result := -1;\r
 420     end;\r
 421   end;\r
 422 end;\r
 423 \r
 424 procedure processtimers;\r
 425 begin\r
 426 end;\r
 427 \r
 428 function GetMessageinternal(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax: UINT; wremovemsg : UINT;peek:boolean): WINBOOL;\r
 429 var\r
 430   tm : tthreadmanager;\r
 431   threaddata : tthreaddata;\r
 432   message : tmessageintransit;\r
 433   nowtv : ttimeval;\r
 434   timeouttv : ttimeval;\r
 435   timeoutms : int64;\r
 436 \r
 437 begin\r
 438   if hwnd <> 0 then raise exception.create('getting messages for an individual window is not supported');\r
 439   if (wmsgfiltermin <> 0) or (wmsgfiltermax <> 0) then raise exception.create('message filtering is not supported');\r
 440   structurelock.acquire;\r
 441   result := true;\r
 442   try\r
 443     getthreadmanager(tm);\r
 444     threaddata := findthreaddata(tm.GetCurrentThreadId);\r
 445     if threaddata.lcorethread then raise exception.create('get/peek message cannot be used in the lcore thread');\r
 446     message := threaddata.messagequeue;\r
 447     gettimeofday(nowtv);\r
 448     while (not peek) and (message=nil) and (not tv_compare(nowtv,threaddata.nexttimer)) do begin\r
 449       threaddata.waiting := true;\r
 450       structurelock.release;\r
 451       if (threaddata.nexttimer.tv_sec = TV_invalidtimebig.tv_sec) and (threaddata.nexttimer.tv_usec = TV_invalidtimebig.tv_usec) then begin\r
 452         threaddata.messageevent.waitfor(INFINITE);\r
 453       end else begin\r
 454 \r
 455         timeouttv := threaddata.nexttimer;\r
 456         timeoutms := (timeouttv.tv_sec * 1000)+(timeouttv.tv_usec div 1000);\r
 457         //i'm assuming the timeout is in milliseconds\r
 458         if (timeoutms > maxlongint) then timeoutms := maxlongint;\r
 459         threaddata.messageevent.waitfor(timeoutms);\r
 460 \r
 461       end;\r
 462       structurelock.acquire;\r
 463       threaddata.waiting := false;\r
 464       message := threaddata.messagequeue;\r
 465       gettimeofday(nowtv);\r
 466     end;\r
 467     if (message=nil) and tv_compare(nowtv,threaddata.nexttimer) then begin\r
 468       processtimers;\r
 469     end;\r
 470     message := threaddata.messagequeue;\r
 471     if message <> nil then begin\r
 472       lpmsg := message.msg;\r
 473       if wremovemsg=PM_REMOVE then begin\r
 474         threaddata.messagequeue := message.next;\r
 475         message.free;\r
 476       end;\r
 477     end else begin\r
 478       result :=false;\r
 479     end;\r
 480     deletethreaddataifunused(threaddata);\r
 481   finally\r
 482     structurelock.release;\r
 483   end;\r
 484 end;\r
 485 \r
 486 function GetMessage(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax: UINT): WINBOOL;\r
 487 begin\r
 488   result := getmessageinternal(lpmsg,hwnd,wmsgfiltermin,wmsgfiltermax,PM_REMOVE,false);\r
 489 end;\r
 490 \r
 491 function PeekMessage(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax, wRemoveMsg: UINT): WINBOOL;\r
 492 begin\r
 493   result := getmessageinternal(lpmsg,hwnd,wmsgfiltermin,wmsgfiltermax,PM_REMOVE,true);\r
 494 end;\r
 495 \r
 496 function SetEvent(hEvent:THevent):WINBOOL;\r
 497 begin\r
 498   hevent.setevent;\r
 499   result := true;\r
 500 end;\r
 501 \r
 502 function CreateEvent(lpEventAttributes:PSECURITYATTRIBUTES; bManualReset:WINBOOL; bInitialState:WINBOOL; lpName:pchar):tHevent;\r
 503 begin\r
 504   result := teventobject.create(lpeventattributes,bmanualreset,binitialstate,lpname);\r
 505 end;\r
 506 \r
 507 function terminatethread(threadhandle:tthreadid;dummy : integer) : boolean;\r
 508 var\r
 509   tm : tthreadmanager;\r
 510 begin\r
 511   getthreadmanager(tm);\r
 512   tm.killthread(threadhandle);\r
 513   result := true;\r
 514 end;\r
 515 \r
 516 function waitforsingleevent(event:thevent;timeout:cardinal) : twaitresult;\r
 517 begin\r
 518   result := event.waitfor(timeout);\r
 519 end;\r
 520 \r
 521 procedure removefrombuffer(n : integer; var buffer:string);\r
 522 begin\r
 523   if n=length(buffer) then begin\r
 524     buffer := '';\r
 525   end else begin\r
 526     uniquestring(buffer);\r
 527     move(buffer[n+1],buffer[1],length(buffer)-n);\r
 528     setlength(buffer,length(buffer)-n);\r
 529   end;\r
 530 end;\r
 531 \r
 532 type\r
 533   tsc=class\r
 534     procedure available(sender:tobject;error:word);\r
 535   end;\r
 536 \r
 537 var\r
 538   recvbuf : string;\r
 539 \r
 540 procedure tsc.available(sender:tobject;error:word);\r
 541 var\r
 542   message : tmessageintransit;\r
 543   messagebytes : array[1..sizeof(tmessageintransit)] of char absolute  message;\r
 544   i : integer;\r
 545 begin\r
 546   //swriteln('received data on lcorelinkpipe');\r
 547   recvbuf := recvbuf + lcorelinkpiperecv.receivestr;\r
 548   while length(recvbuf) >= sizeof(tmessageintransit) do begin\r
 549     for i := 1 to sizeof(tmessageintransit) do begin\r
 550       messagebytes[i] := recvbuf[i];\r
 551     end;\r
 552     dispatchmessage(message.msg);\r
 553     message.free;\r
 554     removefrombuffer(sizeof(tmessageintransit),recvbuf);\r
 555   end;\r
 556 end;\r
 557 \r
 558 procedure init;\r
 559 var\r
 560   tm : tthreadmanager;\r
 561   threaddata : tthreaddata;\r
 562   pipeends : tfildes;\r
 563   sc : tsc;\r
 564 begin\r
 565   structurelock := tcriticalsection.create;\r
 566   getthreadmanager(tm);\r
 567   threaddata := findthreaddata(tm.GetCurrentThreadId);\r
 568   threaddata.lcorethread := true;\r
 569   fppipe(pipeends);\r
 570   lcorelinkpipesend := pipeends[1];\r
 571   lcorelinkpiperecv := tlasio.create(nil);\r
 572   lcorelinkpiperecv.dup(pipeends[0]);\r
 573   lcorelinkpiperecv.ondataavailable := sc.available;\r
 574   recvbuf := '';\r
 575 end;\r
 576 \r
 577 var\r
 578   lcorethreadtimers : thashtable;\r
 579 type\r
 580   tltimerformsg = class(tltimer)\r
 581   public\r
 582     hwnd : hwnd;\r
 583     id : taddrint;\r
 584     procedure timer(sender : tobject);\r
 585   end;\r
 586 \r
 587 procedure tltimerformsg.timer(sender : tobject);\r
 588 var\r
 589   msg : tmsg;\r
 590 begin\r
 591   ////swriteln('in tltimerformsg.timer');\r
 592   fillchar(msg,sizeof(msg),0);\r
 593   msg.message := WM_TIMER;\r
 594   msg.hwnd := hwnd;\r
 595   msg.wparam := ID;\r
 596   msg.lparam := 0;\r
 597   dispatchmessage(msg);\r
 598 end;\r
 599 \r
 600 function SetTimer(ahWnd:HWND; nIDEvent:taddrint; uElapse:UINT; lpTimerFunc:tTIMERPROC):UINT;\r
 601 var\r
 602   threaddata : tthreaddata;\r
 603   ltimer : tltimerformsg;\r
 604   tm : tthreadmanager;\r
 605   window : twindow;\r
 606 begin\r
 607   structurelock.acquire;\r
 608   try\r
 609     window := findtree(@windows,inttostr(ahwnd));\r
 610     if window= nil then raise exception.create('invalid window');\r
 611     threaddata := findthreaddata(window.threadid);\r
 612   finally\r
 613     structurelock.release;\r
 614   end;\r
 615   if threaddata.lcorethread then begin\r
 616     getthreadmanager(tm);\r
 617     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
 618     if ahwnd = 0 then raise exception.create('timers on the lcore thread must be associated with a window handle');\r
 619     if @lptimerfunc <> nil then raise exception.create('seperate timer functions are not supported');\r
 620 \r
 621     //remove preexisting timer with same ID\r
 622     killtimer(ahwnd,nIDEvent);\r
 623 \r
 624     ltimer := tltimerformsg.create(nil);\r
 625     ltimer.interval := uelapse;\r
 626     ltimer.id := nidevent;\r
 627     ltimer.hwnd := ahwnd;\r
 628     ltimer.enabled := true;\r
 629     ltimer.ontimer := ltimer.timer;\r
 630 \r
 631     addtree(@lcorethreadtimers,inttostr(taddrint(ahwnd))+' '+inttostr(nIDEvent),ltimer);\r
 632 \r
 633     result := nidevent;\r
 634   end else begin\r
 635     raise exception.create('settimer not implemented for threads other than the lcore thread');\r
 636   end;\r
 637 end;\r
 638 \r
 639 function KillTimer(ahWnd:HWND; uIDEvent:taddrint):WINBOOL;\r
 640 var\r
 641   threaddata : tthreaddata;\r
 642   ltimer : tltimerformsg;\r
 643   tm : tthreadmanager;\r
 644   window : twindow;\r
 645 begin\r
 646   structurelock.acquire;\r
 647   try\r
 648     window := findtree(@windows,inttostr(ahwnd));\r
 649     if window= nil then raise exception.create('invalid window');\r
 650     threaddata := findthreaddata(window.threadid);\r
 651   finally\r
 652     structurelock.release;\r
 653   end;\r
 654   if threaddata.lcorethread then begin\r
 655     getthreadmanager(tm);\r
 656     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
 657     if ahwnd = 0 then raise exception.create('timers on the lcore thread must be associated with a window handle');\r
 658     ltimer := tltimerformsg(findtree(@lcorethreadtimers,inttostr(taddrint(ahwnd))+' '+inttostr(uIDEvent)));\r
 659     if ltimer <> nil then begin\r
 660       deltree(@lcorethreadtimers,inttostr(taddrint(ahwnd))+' '+inttostr(uIDEvent));\r
 661       ltimer.free;\r
 662       result := true;\r
 663     end else begin\r
 664       result := false;\r
 665     end;\r
 666   end else begin\r
 667     raise exception.create('settimer not implemented for threads other than the lcore thread');\r
 668   end;\r
 669 end;\r
 670 \r
 671 end.\r