lmessages.pas

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