lcoreselect.pas

   1 {lsocket.pas}\r
   2 \r
   3 {io and timer code by plugwash}\r
   4 \r
   5 { Copyright (C) 2005 Bas Steendijk and Peter Green\r
   6   For conditions of distribution and use, see copyright notice in zlib_license.txt\r
   7   which is included in the package\r
   8   ----------------------------------------------------------------------------- }\r
   9 \r
  10 {$ifdef fpc}\r
  11   {$ifndef ver1_0}\r
  12     {$define useinline}\r
  13   {$endif}\r
  14 {$endif}\r
  15 \r
  16 unit lcoreselect;\r
  17 \r
  18 \r
  19 interface\r
  20 uses\r
  21   {$ifdef VER1_0}\r
  22     linux,\r
  23   {$else}\r
  24     baseunix,unix,unixutil,sockets,\r
  25   {$endif}\r
  26   fd_utils;\r
  27 var\r
  28   maxs                                  : longint    ;\r
  29   exitloopflag                          : boolean    ; {if set by app, exit mainloop}\r
  30 \r
  31 function getfdsrmaster : fdset; {$ifdef useinline}inline;{$endif}\r
  32 function getfdswmaster : fdset; {$ifdef useinline}inline;{$endif}\r
  33 \r
  34 procedure lcoreinit;\r
  35 \r
  36 implementation\r
  37 uses\r
  38   lcore,sysutils,\r
  39   classes,pgtypes,bfifo,\r
  40   {$ifndef nosignal}\r
  41     lsignal,\r
  42   {$endif}\r
  43   ltimevalstuff;\r
  44 \r
  45 {$include unixstuff.inc}\r
  46 \r
  47 const\r
  48   absolutemaxs_select = (sizeof(fdset)*8)-1;\r
  49 \r
  50 var\r
  51   fdreverse:array[0..absolutemaxs_select] of tlasio;\r
  52 type\r
  53   tselecteventcore=class(teventcore)\r
  54     public\r
  55       procedure processmessages; override;\r
  56       procedure messageloop; override;\r
  57       procedure exitmessageloop;override;\r
  58       procedure setfdreverse(fd : integer;reverseto : tlasio); override;\r
  59       procedure rmasterset(fd : integer;islistensocket : boolean); override;\r
  60       procedure rmasterclr(fd: integer); override;\r
  61       procedure wmasterset(fd : integer); override;\r
  62       procedure wmasterclr(fd: integer); override;\r
  63     end;\r
  64 \r
  65 procedure processtimers;inline;\r
  66 var\r
  67   tvnow     : ttimeval ;\r
  68   currenttimer            : tltimer   ;\r
  69   temptimer               : tltimer  ;\r
  70 \r
  71 begin\r
  72   gettimemonotonic(tvnow);\r
  73   currenttimer := firsttimer;\r
  74   while assigned(currenttimer) do begin\r
  75     //writeln(currenttimer.enabled);\r
  76     if tv_compare(tvnow,ttimeval(currenttimer.nextts)) and currenttimer.enabled then begin\r
  77       //if assigned(currenttimer.ontimer) then begin\r
  78       //  if currenttimer.enabled then if currenttimer.initialevent or currenttimer.initialdone then currenttimer.ontimer(currenttimer);\r
  79       //  currenttimer.initialdone := true;\r
  80       //end;\r
  81       if assigned(currenttimer.ontimer) then currenttimer.ontimer(currenttimer);\r
  82       currenttimer.nextts := timeval(tvnow);\r
  83       tv_add(ttimeval(currenttimer.nextts),currenttimer.interval);\r
  84     end;\r
  85     temptimer := currenttimer;\r
  86     currenttimer := currenttimer.nexttimer;\r
  87   end;\r
  88 end;\r
  89 \r
  90 procedure processasios(var fdsr,fdsw:fdset);//inline;\r
  91 var\r
  92   currentsocket : tlasio  ;\r
  93   socketcount   : integer ; // for debugging purposes :)\r
  94   dw,bt:integer;\r
  95   currentfdword:fdword;\r
  96   fd : integer;\r
  97 begin\r
  98   //writeln('entering processasios');\r
  99 {  inc(lcoretestcount);}\r
 100 \r
 101     //the message loop will exit if all lasios and ltimers and lsignals are destroyed\r
 102     //if (not assigned(firstasin)) and (not assigned(firsttimer)) and (not assigned(firstsignal)) then exit;\r
 103 \r
 104 \r
 105   {------- test optimised loop}\r
 106   socketcount := 0;\r
 107   for dw := (maxs shr fdwordshift) downto 0 do if (fdsr[dw] or fdsw[dw]) <> 0 then begin\r
 108     currentfdword := (fdsr[dw] or fdsw[dw]);\r
 109     for bt := fdwordmaxbit downto 0 do if currentfdword and (1 shl bt) <> 0 then begin\r
 110       inc(socketcount);\r
 111       fd := dw shl fdwordshift or bt;\r
 112       //writeln('reversing fd ',fd);\r
 113       currentsocket := fdreverse[fd];\r
 114       {if not assigned(currentsocket) then raise exception.create('currentsocket not assigned');\r
 115       if currentsocket.fdhandlein < 0 then raise exception.create('currentsocket.fdhandlein out of range');}\r
 116       {i've seen the out of range case actually happening, so it can happen. test: just close the fd - beware}\r
 117       if not assigned(currentsocket) then begin\r
 118         fdclose(fd);\r
 119         continue\r
 120       end;\r
 121       if currentsocket.fdhandlein < 0 then begin\r
 122         fdclose(fd);\r
 123         continue\r
 124       end;\r
 125       try\r
 126         currentsocket.handlefdtrigger(fd_isset(fd,fdsr),fd_isset(fd,fdsw));\r
 127       except\r
 128         on E: exception do begin\r
 129           currentsocket.HandleBackGroundException(e);\r
 130         end;\r
 131       end;\r
 132 \r
 133       if mustrefreshfds then begin\r
 134         if select(maxs+1,@fdsr,@fdsw,nil,0) <= 0 then begin\r
 135           fd_zero(fdsr);\r
 136           fd_zero(fdsw);\r
 137         end;\r
 138       end;\r
 139     end;\r
 140   end;\r
 141 \r
 142   {\r
 143   !!! issues:\r
 144   - sockets which are released may not be freed because theyre never processed by the loop\r
 145   made new code for handling this, using asinreleaseflag\r
 146 \r
 147   - when/why does the mustrefreshfds select apply, check if i did it correctly?\r
 148 \r
 149   - what happens if calling handlefdtrigger for a socket which does not have an event\r
 150   }\r
 151   {------- original loop}\r
 152 \r
 153   (*\r
 154   currentsocket := firstasin;\r
 155   socketcount := 0;\r
 156   while assigned(currentsocket) do begin\r
 157     if mustrefreshfds then begin\r
 158       if select(maxs,@fdsr,@fdsw,nil,0) <= 0 then begin\r
 159         fd_zero(fdsr);\r
 160         fd_zero(fdsw);\r
 161       end;\r
 162     end;\r
 163     try\r
 164       if fd_isset(currentsocket.fdhandlein,fdsr) or fd_isset(currentsocket.fdhandleout,fdsw) then begin\r
 165         currentsocket.handlefdtrigger(fd_isset(currentsocket.fdhandlein,fdsr),fd_isset(currentsocket.fdhandleout,fdsw));\r
 166       end;\r
 167     except\r
 168       on E: exception do begin\r
 169         currentsocket.HandleBackGroundException(e);\r
 170       end;\r
 171     end;\r
 172     tempsocket := currentsocket;\r
 173     currentsocket := currentsocket.nextasin;\r
 174     inc(socketcount);\r
 175     if tempsocket.released then begin\r
 176       tempsocket.free;\r
 177     end;\r
 178   end; *)\r
 179 {  debugout('socketcount='+inttostr(socketcount));}\r
 180   //writeln('leaving processasios');\r
 181 end;\r
 182 \r
 183 procedure tselecteventcore.processmessages;\r
 184 var\r
 185   fdsr         , fdsw : fdset   ;\r
 186   selectresult        : longint ;\r
 187 begin\r
 188   mustrefreshfds := false;\r
 189   {$ifndef nosignal}\r
 190     prepsigpipe;\r
 191   {$endif}\r
 192   selectresult := select(maxs+1,@fdsr,@fdsw,nil,0);\r
 193   while (selectresult>0) or assigned(firsttask) do begin;\r
 194 \r
 195     processtasks;\r
 196     processtimers;\r
 197     if selectresult > 0 then begin\r
 198       processasios(fdsr,fdsw);\r
 199     end;\r
 200     selectresult := select(maxs+1,@fdsr,@fdsw,nil,0);\r
 201 \r
 202   end;\r
 203   mustrefreshfds := true;\r
 204 end;\r
 205 \r
 206 \r
 207 var\r
 208   FDSR , FDSW : fdset;\r
 209 \r
 210 var\r
 211   fdsrmaster , fdswmaster               : fdset      ;\r
 212 \r
 213 function getfdsrmaster : fdset; {$ifdef fpc}inline;{$endif}\r
 214 begin\r
 215   result := fdsrmaster;\r
 216 end;\r
 217 function getfdswmaster : fdset; {$ifdef fpc}inline;{$endif}\r
 218 begin\r
 219   result := fdswmaster;\r
 220 end;\r
 221 \r
 222 \r
 223 {\r
 224 select in linux/sysV subtracts from timeout for time spent in it, but in BSD it doesn't\r
 225 enabling select_no_autotv here makes doSelect mimic the decrement behavior, in case the caller needs it\r
 226 the caller here in lcoreselect does not need it, and enabling it would have a slight perf hit.\r
 227 it is safe for this to be enabled even if the OS does it too (it will not subtract twice)\r
 228 it is currently disabled but can be enabled if needed\r
 229 }\r
 230 {$ifndef linux}{-$define select_no_autotv}{$endif}\r
 231 \r
 232 Function  doSelect(timeOut:PTimeVal):longint;//inline;\r
 233 var\r
 234   localtimeval : ttimeval;\r
 235   maxslocal    : integer;\r
 236   {$ifdef select_no_autotv}\r
 237   timeoutcopy,tvstart,tvend : ttimeval;\r
 238   {$endif}\r
 239 begin\r
 240   //unblock signals\r
 241   //zeromemory(@sset,sizeof(sset));\r
 242   //sset[0] := ;\r
 243   fdsr := getfdsrmaster;\r
 244   fdsw := getfdswmaster;\r
 245 \r
 246   if assigned(firsttask) then begin\r
 247     localtimeval.tv_sec  := 0;\r
 248     localtimeval.tv_usec := 0;\r
 249     timeout := @localtimeval;\r
 250   end;\r
 251 \r
 252   maxslocal := maxs;\r
 253   mustrefreshfds := false;\r
 254 {  debugout('about to call select');}\r
 255   {$ifndef nosignal}\r
 256     sigprocmask(SIG_UNBLOCK,@blockset,nil);\r
 257   {$endif}\r
 258 \r
 259   {$ifdef select_no_autotv}\r
 260   if assigned(timeout) then begin\r
 261     timeoutcopy.tv_sec := timeOut.tv_sec;\r
 262     timeoutcopy.tv_usec := timeOut.tv_usec;\r
 263     gettimemonotonic(tvstart);\r
 264   end;\r
 265   {$endif}\r
 266 \r
 267   result := select(maxslocal+1,@FDSR,@FDSW,nil,timeout);\r
 268   if result <= 0 then begin\r
 269     fd_zero(FDSR);\r
 270     fd_zero(FDSW);\r
 271     if result=-1 then begin\r
 272       if linuxerror = SYS_EINTR then begin\r
 273         // we received a signal it is not a problem\r
 274       end else begin\r
 275         raise esocketexception.create('select returned error '+inttostr(linuxerror));\r
 276       end;\r
 277     end\r
 278   {$ifdef select_no_autotv}\r
 279     else if (result = 0) and assigned(timeout) then begin\r
 280       //timeout reached: zero the timeval\r
 281       timeout.tv_sec := 0;\r
 282       timeout.tv_usec := 0;\r
 283     end;\r
 284   end else if assigned(timeout) then begin\r
 285     //successful result: subtract elapsed time\r
 286     gettimemonotonic(tvend);\r
 287     tv_subtract(tvend,tvstart);\r
 288     tv_subtract(timeoutcopy,tvend);\r
 289     timeout.tv_sec := timeoutcopy.tv_sec;\r
 290     timeout.tv_usec := timeoutcopy.tv_usec;\r
 291     if (timeout.tv_sec < 0) then begin\r
 292       timeout.tv_sec := 0;\r
 293       timeout.tv_usec := 0;\r
 294     end;\r
 295   {$endif} //select_no_autotv\r
 296   end;\r
 297 \r
 298   {$ifndef nosignal}\r
 299     sigprocmask(SIG_BLOCK,@blockset,nil);\r
 300   {$endif}\r
 301 {  debugout('select complete');}\r
 302 end;\r
 303 \r
 304 procedure tselecteventcore.exitmessageloop;\r
 305 begin\r
 306   exitloopflag := true\r
 307 end;\r
 308 \r
 309 \r
 310 \r
 311 procedure tselecteventcore.messageloop;\r
 312 var\r
 313   tv           ,tvnow     : ttimeval ;\r
 314   currenttimer            : tltimer  ;\r
 315   selectresult:integer;\r
 316 begin\r
 317   {$ifndef nosignal}\r
 318     prepsigpipe;\r
 319   {$endif}\r
 320   {currentsocket := firstasin;\r
 321   if not assigned(currentsocket) then exit; //the message loop will exit if all lsockets are destroyed\r
 322   repeat\r
 323 \r
 324     if currentsocket.state = wsconnected then currentsocket.sendflush;\r
 325     currentsocket := currentsocket.nextasin;\r
 326   until not assigned(currentsocket);}\r
 327 \r
 328 \r
 329   repeat\r
 330 \r
 331     //the message loop will exit if all lasios and ltimers and lsignals are destroyed\r
 332     processtasks;\r
 333     //currenttask := nil;\r
 334     {beware}\r
 335     //if assigned(firsttimer) then begin\r
 336     //  tv.tv_sec := maxlongint;\r
 337     tv := tv_invalidtimebig;\r
 338     currenttimer := firsttimer;\r
 339     while assigned(currenttimer) do begin\r
 340       if tv_compare(tv,currenttimer.nextts) and currenttimer.enabled then tv := currenttimer.nextts;\r
 341       currenttimer := currenttimer.nexttimer;\r
 342     end;\r
 343 \r
 344 \r
 345     if tv_compare(tv,tv_invalidtimebig) then begin    \r
 346       //writeln('no timers active');\r
 347       if exitloopflag then break;\r
 348 {    sleep(10);}\r
 349       selectresult := doselect(nil);\r
 350 \r
 351     end else begin\r
 352       gettimemonotonic(tvnow);\r
 353       tv_subtract(tv,tvnow);\r
 354 \r
 355       //writeln('timers active');\r
 356       if tv.tv_sec < 0 then begin\r
 357         tv.tv_sec := 0;\r
 358         tv.tv_usec := 0; {0.1 sec}\r
 359       end;\r
 360       if exitloopflag then break;\r
 361 {    sleep(10);}\r
 362       selectresult := doselect(@tv);\r
 363       processtimers;\r
 364 \r
 365     end;\r
 366     if selectresult > 0 then processasios(fdsr,fdsw);\r
 367     {!!!only call processasios if select has asio events -beware}\r
 368 \r
 369     {artificial delay to throttle the number of processasios per second possible and reduce cpu usage}\r
 370   until false;\r
 371 end;\r
 372 \r
 373 \r
 374 procedure tselecteventcore.rmasterset(fd : integer;islistensocket : boolean);\r
 375 begin\r
 376   //writeln('rmasterset called with fd ',fd);\r
 377   if fd > absolutemaxs then raise esocketexception.create('file descriptor out of range');\r
 378   if fd > maxs then maxs := fd;\r
 379   if fd_isset(fd,fdsrmaster) then exit;\r
 380   fd_set(fd,fdsrmaster);\r
 381 \r
 382 end;\r
 383 \r
 384 procedure tselecteventcore.rmasterclr(fd: integer);\r
 385 begin\r
 386   //writeln('rmasterclr called with fd ',fd);\r
 387   if not fd_isset(fd,fdsrmaster) then exit;\r
 388   fd_clr(fd,fdsrmaster);\r
 389 \r
 390 end;\r
 391 \r
 392 \r
 393 procedure tselecteventcore.wmasterset(fd : integer);\r
 394 begin\r
 395   //writeln('wmasterset called with fd ',fd);\r
 396   if fd > absolutemaxs then raise esocketexception.create('file descriptor out of range');\r
 397   if fd > maxs then maxs := fd;\r
 398 \r
 399   if fd_isset(fd,fdswmaster) then exit;\r
 400   fd_set(fd,fdswmaster);\r
 401 \r
 402 end;\r
 403 \r
 404 procedure tselecteventcore.wmasterclr(fd: integer);\r
 405 begin\r
 406   //writeln('wmasterclr called with fd ',fd);\r
 407   if not fd_isset(fd,fdswmaster) then exit;\r
 408   fd_clr(fd,fdswmaster);\r
 409 end;\r
 410 \r
 411 procedure tselecteventcore.setfdreverse(fd : integer;reverseto : tlasio);\r
 412 begin\r
 413   fdreverse[fd] := reverseto;\r
 414 end;\r
 415 \r
 416 var\r
 417   inited:boolean;\r
 418 \r
 419 procedure lcoreinit;\r
 420 begin\r
 421   if inited then exit;\r
 422   inited := true;\r
 423   eventcore := tselecteventcore.create;\r
 424 \r
 425   absolutemaxs := absolutemaxs_select;\r
 426 \r
 427   maxs := 0;\r
 428   fd_zero(fdsrmaster);\r
 429   fd_zero(fdswmaster);\r
 430 end;\r
 431 \r
 432 end.\r