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