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