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