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 Function  doSelect(timeOut:PTimeVal):longint;//inline;\r
 224 var\r
 225   localtimeval : ttimeval;\r
 226   maxslocal    : integer;\r
 227 begin\r
 228   //unblock signals\r
 229   //zeromemory(@sset,sizeof(sset));\r
 230   //sset[0] := ;\r
 231   fdsr := getfdsrmaster;\r
 232   fdsw := getfdswmaster;\r
 233 \r
 234   if assigned(firsttask) then begin\r
 235     localtimeval.tv_sec  := 0;\r
 236     localtimeval.tv_usec := 0;\r
 237     timeout := @localtimeval;\r
 238   end;\r
 239 \r
 240   maxslocal := maxs;\r
 241   mustrefreshfds := false;\r
 242 {  debugout('about to call select');}\r
 243   {$ifndef nosignal}\r
 244     sigprocmask(SIG_UNBLOCK,@blockset,nil);\r
 245   {$endif}\r
 246   result := select(maxslocal+1,@FDSR,@FDSW,nil,timeout);\r
 247   if result <= 0 then begin\r
 248     fd_zero(FDSR);\r
 249     fd_zero(FDSW);\r
 250     if result=-1 then begin\r
 251       if linuxerror = SYS_EINTR then begin\r
 252         // we received a signal it is not a problem\r
 253       end else begin\r
 254         raise esocketexception.create('select returned error '+inttostr(linuxerror));\r
 255       end;\r
 256     end;\r
 257   end;\r
 258   {$ifndef nosignal}\r
 259     sigprocmask(SIG_BLOCK,@blockset,nil);\r
 260   {$endif}\r
 261 {  debugout('select complete');}\r
 262 end;\r
 263 \r
 264 procedure tselecteventcore.exitmessageloop;\r
 265 begin\r
 266   exitloopflag := true\r
 267 end;\r
 268 \r
 269 \r
 270 \r
 271 procedure tselecteventcore.messageloop;\r
 272 var\r
 273   tv           ,tvnow     : ttimeval ;\r
 274   currenttimer            : tltimer  ;\r
 275   selectresult:integer;\r
 276 begin\r
 277   {$ifndef nosignal}\r
 278     prepsigpipe;\r
 279   {$endif}\r
 280   {currentsocket := firstasin;\r
 281   if not assigned(currentsocket) then exit; //the message loop will exit if all lsockets are destroyed\r
 282   repeat\r
 283 \r
 284     if currentsocket.state = wsconnected then currentsocket.sendflush;\r
 285     currentsocket := currentsocket.nextasin;\r
 286   until not assigned(currentsocket);}\r
 287 \r
 288 \r
 289   repeat\r
 290 \r
 291     //the message loop will exit if all lasios and ltimers and lsignals are destroyed\r
 292     processtasks;\r
 293     //currenttask := nil;\r
 294     {beware}\r
 295     //if assigned(firsttimer) then begin\r
 296     //  tv.tv_sec := maxlongint;\r
 297     tv := tv_invalidtimebig;\r
 298     currenttimer := firsttimer;\r
 299     while assigned(currenttimer) do begin\r
 300       if tv_compare(tv,currenttimer.nextts) and currenttimer.enabled then tv := currenttimer.nextts;\r
 301       currenttimer := currenttimer.nexttimer;\r
 302     end;\r
 303 \r
 304 \r
 305     if tv_compare(tv,tv_invalidtimebig) then begin    \r
 306       //writeln('no timers active');\r
 307       if exitloopflag then break;\r
 308 {    sleep(10);}\r
 309       selectresult := doselect(nil);\r
 310 \r
 311     end else begin\r
 312       gettimemonotonic(tvnow);\r
 313       tv_subtract(tv,tvnow);\r
 314 \r
 315       //writeln('timers active');\r
 316       if tv.tv_sec < 0 then begin\r
 317         tv.tv_sec := 0;\r
 318         tv.tv_usec := 0; {0.1 sec}\r
 319       end;\r
 320       if exitloopflag then break;\r
 321 {    sleep(10);}\r
 322       selectresult := doselect(@tv);\r
 323       processtimers;\r
 324 \r
 325     end;\r
 326     if selectresult > 0 then processasios(fdsr,fdsw);\r
 327     {!!!only call processasios if select has asio events -beware}\r
 328 \r
 329     {artificial delay to throttle the number of processasios per second possible and reduce cpu usage}\r
 330   until false;\r
 331 end;\r
 332 \r
 333 \r
 334 procedure tselecteventcore.rmasterset(fd : integer;islistensocket : boolean);\r
 335 begin\r
 336   //writeln('rmasterset called with fd ',fd);\r
 337   if fd > absolutemaxs then raise esocketexception.create('file descriptor out of range');\r
 338   if fd > maxs then maxs := fd;\r
 339   if fd_isset(fd,fdsrmaster) then exit;\r
 340   fd_set(fd,fdsrmaster);\r
 341 \r
 342 end;\r
 343 \r
 344 procedure tselecteventcore.rmasterclr(fd: integer);\r
 345 begin\r
 346   //writeln('rmasterclr called with fd ',fd);\r
 347   if not fd_isset(fd,fdsrmaster) then exit;\r
 348   fd_clr(fd,fdsrmaster);\r
 349 \r
 350 end;\r
 351 \r
 352 \r
 353 procedure tselecteventcore.wmasterset(fd : integer);\r
 354 begin\r
 355   //writeln('wmasterset called with fd ',fd);\r
 356   if fd > absolutemaxs then raise esocketexception.create('file descriptor out of range');\r
 357   if fd > maxs then maxs := fd;\r
 358 \r
 359   if fd_isset(fd,fdswmaster) then exit;\r
 360   fd_set(fd,fdswmaster);\r
 361 \r
 362 end;\r
 363 \r
 364 procedure tselecteventcore.wmasterclr(fd: integer);\r
 365 begin\r
 366   //writeln('wmasterclr called with fd ',fd);\r
 367   if not fd_isset(fd,fdswmaster) then exit;\r
 368   fd_clr(fd,fdswmaster);\r
 369 end;\r
 370 \r
 371 procedure tselecteventcore.setfdreverse(fd : integer;reverseto : tlasio);\r
 372 begin\r
 373   fdreverse[fd] := reverseto;\r
 374 end;\r
 375 \r
 376 var\r
 377   inited:boolean;\r
 378 \r
 379 procedure lcoreinit;\r
 380 begin\r
 381   if inited then exit;\r
 382   inited := true;\r
 383   eventcore := tselecteventcore.create;\r
 384 \r
 385   absolutemaxs := absolutemaxs_select;\r
 386 \r
 387   maxs := 0;\r
 388   fd_zero(fdsrmaster);\r
 389   fd_zero(fdswmaster);\r
 390 end;\r
 391 \r
 392 end.\r