wcore.pas

   1 unit wcore;\r
   2 \r
   3 {\r
   4 lcore compatible interface for windows\r
   5 \r
   6 - messageloop\r
   7 \r
   8 - tltimer\r
   9 \r
  10 }\r
  11 //note: events after release are normal and are the apps responsibility to deal with safely\r
  12 interface\r
  13 \r
  14   uses\r
  15     classes,windows,mmsystem;\r
  16 \r
  17   type\r
  18     float=double;\r
  19 \r
  20     tlcomponent = class(tcomponent)\r
  21     public\r
  22       released:boolean;\r
  23       procedure release;\r
  24       destructor destroy; override;\r
  25     end;\r
  26 \r
  27     tltimer=class(tlcomponent)\r
  28     private\r
  29       fenabled : boolean;\r
  30       procedure setenabled(newvalue : boolean);\r
  31     public\r
  32       ontimer:tnotifyevent;\r
  33       initialevent:boolean;\r
  34       initialdone:boolean;\r
  35       prevtimer:tltimer;\r
  36       nexttimer:tltimer;\r
  37       interval:integer;        {milliseconds, default 1000}\r
  38       nextts:integer;\r
  39       property enabled:boolean read fenabled write setenabled;\r
  40       constructor create(aowner:tcomponent);override;\r
  41       destructor destroy;override;\r
  42     end;\r
  43 \r
  44     ttaskevent=procedure(wparam,lparam:longint) of object;\r
  45 \r
  46     tltask=class(tobject)\r
  47     public\r
  48       handler  : ttaskevent;\r
  49       obj      : tobject;\r
  50       wparam   : longint;\r
  51       lparam   : longint;\r
  52       nexttask : tltask;\r
  53       constructor create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
  54     end;\r
  55 \r
  56 procedure messageloop;\r
  57 procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
  58 procedure disconnecttasks(aobj:tobject);\r
  59 procedure exitmessageloop;\r
  60 procedure processmessages;\r
  61 procedure wcoreinit;\r
  62 \r
  63 var\r
  64   onshutdown:procedure(s:ansistring);\r
  65 \r
  66 implementation\r
  67 \r
  68 uses\r
  69   {$ifdef fpc}\r
  70   bmessages;\r
  71   {$else}\r
  72   messages;\r
  73   {$endif}\r
  74 \r
  75 \r
  76 const\r
  77   WINMSG_TASK=WM_USER;\r
  78 \r
  79 var\r
  80   hwndwcore:hwnd;\r
  81   firsttimer:tltimer;\r
  82   timesubtract:integer;\r
  83   firsttask,lasttask,currenttask:tltask;\r
  84 \r
  85 procedure tlcomponent.release;\r
  86 begin\r
  87   released := true;\r
  88 end;\r
  89 \r
  90 destructor tlcomponent.destroy;\r
  91 begin\r
  92   disconnecttasks(self);\r
  93   inherited destroy;\r
  94 end;\r
  95 \r
  96 {------------------------------------------------------------------------------}\r
  97 \r
  98 procedure tltimer.setenabled(newvalue : boolean);\r
  99 begin\r
 100   fenabled := newvalue;\r
 101   nextts := 0;\r
 102   initialdone := false;\r
 103 end;\r
 104 \r
 105 constructor tltimer.create;\r
 106 begin\r
 107   inherited create(AOwner);\r
 108   nexttimer := firsttimer;\r
 109   prevtimer := nil;\r
 110 \r
 111   if assigned(nexttimer) then nexttimer.prevtimer := self;\r
 112   firsttimer := self;\r
 113 \r
 114   interval := 1000;\r
 115   enabled := true;\r
 116   released := false;\r
 117 end;\r
 118 \r
 119 destructor tltimer.destroy;\r
 120 begin\r
 121   if prevtimer <> nil then begin\r
 122     prevtimer.nexttimer := nexttimer;\r
 123   end else begin\r
 124     firsttimer := nexttimer;\r
 125   end;\r
 126   if nexttimer <> nil then begin\r
 127     nexttimer.prevtimer := prevtimer;\r
 128   end;\r
 129   inherited destroy;\r
 130 end;\r
 131 \r
 132 {------------------------------------------------------------------------------}\r
 133 \r
 134 function wcore_timehandler:integer;\r
 135 const\r
 136   rollover_bits=30;\r
 137 var\r
 138   tv,tvnow:integer;\r
 139   currenttimer,temptimer:tltimer;\r
 140 begin\r
 141   if not assigned(firsttimer) then begin\r
 142     result := 1000;\r
 143     exit;\r
 144   end;\r
 145 \r
 146   tvnow := timegettime;\r
 147   if (tvnow and ((-1) shl rollover_bits)) <> timesubtract then begin\r
 148     currenttimer := firsttimer;\r
 149     while assigned(currenttimer) do begin\r
 150       dec(currenttimer.nextts,(1 shl rollover_bits));\r
 151       currenttimer := currenttimer.nexttimer;\r
 152     end;\r
 153     timesubtract := tvnow and ((-1) shl rollover_bits);\r
 154   end;\r
 155   tvnow := tvnow and ((1 shl rollover_bits)-1);\r
 156 \r
 157   currenttimer := firsttimer;\r
 158   while assigned(currenttimer) do begin\r
 159     if tvnow >= currenttimer.nextts then begin\r
 160       if assigned(currenttimer.ontimer) then begin\r
 161         if currenttimer.enabled then begin\r
 162           if currenttimer.initialevent or currenttimer.initialdone then currenttimer.ontimer(currenttimer);\r
 163           currenttimer.initialdone := true;\r
 164         end;\r
 165       end;\r
 166       currenttimer.nextts := tvnow+currenttimer.interval;\r
 167     end;\r
 168     temptimer := currenttimer;\r
 169     currenttimer := currenttimer.nexttimer;\r
 170     if temptimer.released then temptimer.free;\r
 171   end;\r
 172 \r
 173   tv := maxlongint;\r
 174   currenttimer := firsttimer;\r
 175   while assigned(currenttimer) do begin\r
 176     if currenttimer.nextts < tv then tv := currenttimer.nextts;\r
 177     currenttimer := currenttimer.nexttimer;\r
 178   end;\r
 179   result := tv-tvnow;\r
 180   if result < 15 then result := 15;\r
 181 end;\r
 182 \r
 183 {------------------------------------------------------------------------------}\r
 184 \r
 185 constructor tltask.create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
 186 begin\r
 187   inherited create;\r
 188   handler   := ahandler;\r
 189   obj       := aobj;\r
 190   wparam    := awparam;\r
 191   lparam    := alparam;\r
 192   {nexttask  := firsttask;\r
 193   firsttask := self;}\r
 194   if assigned(lasttask) then begin\r
 195     lasttask.nexttask := self;\r
 196   end else begin\r
 197     firsttask := self;\r
 198     postmessage(hwndwcore,WINMSG_TASK,0,0);\r
 199   end;\r
 200   lasttask := self;\r
 201   //ahandler(wparam,lparam);\r
 202 end;\r
 203 \r
 204 procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
 205 begin\r
 206   tltask.create(ahandler,aobj,awparam,alparam);\r
 207 end;\r
 208 \r
 209 procedure disconnecttasks(aobj:tobject);\r
 210 var\r
 211   currenttasklocal : tltask ;\r
 212   counter          : byte   ;\r
 213 begin\r
 214   for counter := 0 to 1 do begin\r
 215     if counter = 0 then begin\r
 216       currenttasklocal := firsttask; //main list of tasks\r
 217     end else begin\r
 218       currenttasklocal := currenttask; //needed in case called from a task\r
 219     end;\r
 220     // note i don't bother to destroy the links here as that will happen when\r
 221     // the list of tasks is processed anyway\r
 222     while assigned(currenttasklocal) do begin\r
 223       if currenttasklocal.obj = aobj then begin\r
 224         currenttasklocal.obj := nil;\r
 225         currenttasklocal.handler := nil;\r
 226       end;\r
 227       currenttasklocal := currenttasklocal.nexttask;\r
 228     end;\r
 229   end;\r
 230 end;\r
 231 \r
 232 procedure dotasks;\r
 233 var\r
 234   temptask:tltask;\r
 235 begin\r
 236   if firsttask = nil then exit;\r
 237 \r
 238   currenttask := firsttask;\r
 239   firsttask := nil;\r
 240   lasttask  := nil;\r
 241   while assigned(currenttask) do begin\r
 242     if assigned(currenttask.handler) then currenttask.handler(currenttask.wparam,currenttask.lparam);\r
 243     temptask := currenttask;\r
 244     currenttask := currenttask.nexttask;\r
 245     temptask.free;\r
 246   end;\r
 247   currenttask := nil;\r
 248 end;\r
 249 \r
 250 {------------------------------------------------------------------------------}\r
 251 \r
 252 procedure exitmessageloop;\r
 253 begin\r
 254   postmessage(hwndwcore,WM_QUIT,0,0);\r
 255 end;\r
 256 \r
 257   {$ifdef threadtimer}\r
 258   'thread timer'\r
 259   {$else}\r
 260 const timerid_wcore=$1000;\r
 261   {$endif}\r
 262 \r
 263 function MyWindowProc(\r
 264     ahWnd   : HWND;\r
 265     auMsg   : Integer;\r
 266     awParam : WPARAM;\r
 267     alParam : LPARAM): Integer; stdcall;\r
 268 var\r
 269     MsgRec : TMessage;\r
 270     a:integer;\r
 271 begin\r
 272   Result := 0;  // This means we handled the message\r
 273 \r
 274   {MsgRec.hwnd    := ahWnd;}\r
 275   MsgRec.wParam  := awParam;\r
 276   MsgRec.lParam  := alParam;\r
 277 \r
 278   dotasks;\r
 279   case auMsg of\r
 280     {$ifndef threadtimer}\r
 281     WM_TIMER: begin\r
 282       if msgrec.wparam = timerid_wcore then begin\r
 283         a := wcore_timehandler;\r
 284         killtimer(hwndwcore,timerid_wcore);\r
 285         settimer(hwndwcore,timerid_wcore,a,nil);\r
 286       end;\r
 287     end;\r
 288     {$endif}\r
 289 \r
 290     {WINMSG_TASK:dotasks;}\r
 291 \r
 292     WM_CLOSE: begin\r
 293       {}\r
 294     end;\r
 295     WM_DESTROY: begin\r
 296       {}\r
 297     end;\r
 298   else\r
 299       Result := DefWindowProc(ahWnd, auMsg, awParam, alParam)\r
 300   end;\r
 301 end;\r
 302 \r
 303 \r
 304 var\r
 305   MyWindowClass : TWndClass = (style         : 0;\r
 306                                  lpfnWndProc   : @MyWindowProc;\r
 307                                  cbClsExtra    : 0;\r
 308                                  cbWndExtra    : 0;\r
 309                                  hInstance     : 0;\r
 310                                  hIcon         : 0;\r
 311                                  hCursor       : 0;\r
 312                                  hbrBackground : 0;\r
 313                                  lpszMenuName  : nil;\r
 314                                  lpszClassName : 'wcoreClass');\r
 315 \r
 316 procedure wcoreinit;\r
 317 begin\r
 318   if Windows.RegisterClass(MyWindowClass) = 0 then halt;\r
 319   //writeln('about to create wcore handle, hinstance=',hinstance);\r
 320   hwndwcore := CreateWindowEx(WS_EX_TOOLWINDOW,\r
 321                                MyWindowClass.lpszClassName,\r
 322                                '',        { Window name   }\r
 323                                WS_POPUP,  { Window Style  }\r
 324                                0, 0,      { X, Y          }\r
 325                                0, 0,      { Width, Height }\r
 326                                0,         { hWndParent    }\r
 327                                0,         { hMenu         }\r
 328                                HInstance, { hInstance     }\r
 329                                nil);      { CreateParam   }\r
 330 \r
 331   if hwndwcore = 0 then halt;\r
 332 \r
 333   {$ifdef threadtimer}\r
 334   'thread timer'\r
 335   {$else}\r
 336   if settimer(hwndwcore,timerid_wcore,15,nil) = 0 then halt;\r
 337   {$endif}\r
 338 \r
 339 \r
 340 end;\r
 341 \r
 342 procedure messageloop;\r
 343 var\r
 344   MsgRec : TMsg;\r
 345 \r
 346 begin\r
 347 \r
 348   while GetMessage(MsgRec, 0, 0, 0) do begin\r
 349     TranslateMessage(MsgRec);\r
 350     DispatchMessage(MsgRec);\r
 351     {if not peekmessage(msgrec,0,0,0,PM_NOREMOVE) then onidle}\r
 352   end;\r
 353 \r
 354   if hWndwcore <> 0 then begin\r
 355     DestroyWindow(hwndwcore);\r
 356     hWndwcore := 0;\r
 357   end;\r
 358 \r
 359   {$ifdef threadtimer}\r
 360   'thread timer'\r
 361   {$else}\r
 362   killtimer(hwndwcore,timerid_wcore);\r
 363   {$endif}\r
 364 end;\r
 365 \r
 366 function ProcessMessage : Boolean;\r
 367 var\r
 368     MsgRec : TMsg;\r
 369 begin\r
 370     Result := FALSE;\r
 371     if PeekMessage(MsgRec, 0, 0, 0, PM_REMOVE) then begin\r
 372       Result := TRUE;\r
 373       TranslateMessage(MsgRec);\r
 374       DispatchMessage(MsgRec);\r
 375     end;\r
 376 end;\r
 377 \r
 378 procedure processmessages;\r
 379 begin\r
 380   while processmessage do;\r
 381 end;\r
 382 \r
 383 \r
 384 end.\r
 385 \r