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