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 var\r
  45   fdreverse:array[0..absoloutemaxs] of tlasio;\r
  46 type\r
  47   tselecteventcore=class(teventcore)\r
  48     public\r
  49       procedure processmessages; override;\r
  50       procedure messageloop; override;\r
  51       procedure exitmessageloop;override;\r
  52       procedure setfdreverse(fd : integer;reverseto : tlasio); override;\r
  53       procedure rmasterset(fd : integer;islistensocket : boolean); override;\r
  54       procedure rmasterclr(fd: integer); override;\r
  55       procedure wmasterset(fd : integer); override;\r
  56       procedure wmasterclr(fd: integer); override;\r
  57     end;\r
  58 \r
  59 procedure processtimers;inline;\r
  60 var\r
  61   tv           ,tvnow     : ttimeval ;\r
  62   currenttimer            : tltimer   ;\r
  63   temptimer               : tltimer  ;\r
  64 \r
  65 begin\r
  66   gettimeofday(tvnow);\r
  67   currenttimer := firsttimer;\r
  68   while assigned(currenttimer) do begin\r
  69     //writeln(currenttimer.enabled);\r
  70     if tv_compare(tvnow,ttimeval(currenttimer.nextts)) and currenttimer.enabled then begin\r
  71       //if assigned(currenttimer.ontimer) then begin\r
  72       //  if currenttimer.enabled then if currenttimer.initialevent or currenttimer.initialdone then currenttimer.ontimer(currenttimer);\r
  73       //  currenttimer.initialdone := true;\r
  74       //end;\r
  75       if assigned(currenttimer.ontimer) then currenttimer.ontimer(currenttimer);\r
  76       currenttimer.nextts := timeval(tvnow);\r
  77       tv_add(ttimeval(currenttimer.nextts),currenttimer.interval);\r
  78     end;\r
  79     temptimer := currenttimer;\r
  80     currenttimer := currenttimer.nexttimer;\r
  81     if temptimer.released then temptimer.free;\r
  82   end;\r
  83 end;\r
  84 \r
  85 procedure processasios(var fdsr,fdsw:fdset);//inline;\r
  86 var\r
  87   currentsocket : tlasio  ;\r
  88   tempsocket    : tlasio  ;\r
  89   socketcount   : integer ; // for debugging perposes :)\r
  90   dw,bt:integer;\r
  91 begin\r
  92 {  inc(lcoretestcount);}\r
  93 \r
  94     //the message loop will exit if all lasio's and ltimer's and lsignal's are destroyed\r
  95     //if (not assigned(firstasin)) and (not assigned(firsttimer)) and (not assigned(firstsignal)) then exit;\r
  96 \r
  97 \r
  98   {------- test optimised loop}\r
  99   socketcount := 0;\r
 100   for dw := (maxs shr 5) downto 0 do if (fdsr[dw] or fdsw[dw]) <> 0 then begin\r
 101     for bt := 0 to 31 do if (fdsr[dw] or fdsw[dw]) and (1 shl bt) <> 0 then begin\r
 102       inc(socketcount);\r
 103       currentsocket := fdreverse[dw shl 5 or bt];\r
 104       {if not assigned(currentsocket) then raise exception.create('currentsocket not assigned');\r
 105       if currentsocket.fdhandlein < 0 then raise exception.create('currentsocket.fdhandlein out of range');}\r
 106       {i've seen the out of range case actually happening, so it can happen. test: just close the fd - beware}\r
 107       if not assigned(currentsocket) then begin\r
 108         fdclose(dw shl 5 or bt);\r
 109         continue\r
 110       end;\r
 111       if currentsocket.fdhandlein < 0 then begin\r
 112         fdclose(dw shl 5 or bt);\r
 113         continue\r
 114       end;\r
 115       try\r
 116         currentsocket.handlefdtrigger(fd_isset(currentsocket.fdhandlein,fdsr),fd_isset(currentsocket.fdhandleout,fdsw));\r
 117       except\r
 118         on E: exception do begin\r
 119           currentsocket.HandleBackGroundException(e);\r
 120         end;\r
 121       end;\r
 122 \r
 123       if mustrefreshfds then begin\r
 124         if select(maxs+1,@fdsr,@fdsw,nil,0) <= 0 then begin\r
 125           fd_zero(fdsr);\r
 126           fd_zero(fdsw);\r
 127         end;\r
 128       end;\r
 129     end;\r
 130   end;\r
 131 \r
 132   if asinreleaseflag then begin\r
 133     asinreleaseflag := false;\r
 134     currentsocket := firstasin;\r
 135     while assigned(currentsocket) do begin\r
 136       tempsocket := currentsocket;\r
 137       currentsocket := currentsocket.nextasin;\r
 138       if tempsocket.released then begin\r
 139         tempsocket.free;\r
 140       end;\r
 141     end;\r
 142   end;\r
 143   {\r
 144   !!! issues:\r
 145   - sockets which are released may not be freed because theyre never processed by the loop\r
 146   made new code for handling this, using asinreleaseflag\r
 147 \r
 148   - when/why does the mustrefreshfds select apply, sheck if i did it correctly?\r
 149 \r
 150   - what happens if calling handlefdtrigger for a socket which does not have an event\r
 151   }\r
 152   {------- original loop}\r
 153 \r
 154   (*\r
 155   currentsocket := firstasin;\r
 156   socketcount := 0;\r
 157   while assigned(currentsocket) do begin\r
 158     if mustrefreshfds then begin\r
 159       if select(maxs,@fdsr,@fdsw,nil,0) <= 0 then begin\r
 160         fd_zero(fdsr);\r
 161         fd_zero(fdsw);\r
 162       end;\r
 163     end;\r
 164     try\r
 165       if fd_isset(currentsocket.fdhandlein,fdsr) or fd_isset(currentsocket.fdhandleout,fdsw) then begin\r
 166         currentsocket.handlefdtrigger(fd_isset(currentsocket.fdhandlein,fdsr),fd_isset(currentsocket.fdhandleout,fdsw));\r
 167       end;\r
 168     except\r
 169       on E: exception do begin\r
 170         currentsocket.HandleBackGroundException(e);\r
 171       end;\r
 172     end;\r
 173     tempsocket := currentsocket;\r
 174     currentsocket := currentsocket.nextasin;\r
 175     inc(socketcount);\r
 176     if tempsocket.released then begin\r
 177       tempsocket.free;\r
 178     end;\r
 179   end; *)\r
 180 {  debugout('socketcount='+inttostr(socketcount));}\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) or assigned(currenttask) 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
 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
 222
 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's 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 lasio's and ltimer's and lsignal's are destroyed\r
 292     if (not assigned(firstasin)) and (not assigned(firsttimer)) {$ifndef nosignal} and (not assigned(firstsignal)){$endif} then exit;\r
 293     {fd_zero(FDSR);\r
 294     fd_zero(FDSW);\r
 295     currentsocket := firstasin;\r
 296     if not assigned(currentsocket) then exit; //the message loop will exit if all lsockets are destroyed\r
 297 \r
 298     repeat\r
 299       if (not currentsocket.released) and (currentsocket.state<>wsclosed) then fd_set(currentsocket.fdhandlein,fdsr);\r
 300       if (not currentsocket.released) and (currentsocket.state=wsconnecting) then fd_set(currentsocket.fdhandleout,fdsw);\r
 301       if currentsocket is tlsocket then begin\r
 302          if (not currentsocket.released) and (currentsocket.state=wsconnected) and(tlsocket(currentsocket).sendq <> '') then fd_set(currentsocket.fdhandleout,fdsw);\r
 303       end;\r
 304       tempsocket := currentsocket;\r
 305       currentsocket := currentsocket.nextasin;\r
 306       if tempsocket.released then begin\r
 307         tempsocket.free;\r
 308       end;\r
 309     until not assigned(currentsocket);\r
 310     }\r
 311     processtasks;\r
 312     //currenttask := nil;\r
 313     {beware}\r
 314     //if assigned(firsttimer) then begin\r
 315     //  tv.tv_sec := maxlongint;\r
 316     tv := tv_invalidtimebig;\r
 317     currenttimer := firsttimer;\r
 318     while assigned(currenttimer) do begin\r
 319       if tv_compare(tv,currenttimer.nextts) and currenttimer.enabled then tv := currenttimer.nextts;\r
 320       currenttimer := currenttimer.nexttimer;\r
 321     end;\r
 322 \r
 323 \r
 324     if tv_compare(tv,tv_invalidtimebig) then begin    \r
 325       //writeln('no timers active');\r
 326       if exitloopflag then break;\r
 327 {    sleep(10);}\r
 328       selectresult := doselect(nil);\r
 329 \r
 330     end else begin\r
 331       gettimeofday(tvnow);\r
 332       tv_substract(tv,tvnow);\r
 333 \r
 334       //writeln('timers active');\r
 335       if tv.tv_sec < 0 then begin\r
 336         tv.tv_sec := 0;\r
 337         tv.tv_usec := 0; {0.1 sec}\r
 338       end;\r
 339       if exitloopflag then break;\r
 340 {    sleep(10);}\r
 341       selectresult := doselect(@tv);\r
 342       processtimers;\r
 343 \r
 344     end;\r
 345     if selectresult > 0 then processasios(fdsr,fdsw);\r
 346     {!!!only call processasios if select has asio events -beware}\r
 347 \r
 348     {artificial delay to throttle the number of processasios per second possible and reduce cpu usage}\r
 349   until false;\r
 350 end;\r
 351 \r
 352 \r
 353 procedure tselecteventcore.rmasterset(fd : integer;islistensocket : boolean);\r
 354 begin\r
 355   if fd > absoloutemaxs then raise esocketexception.create('file discriptor out of range');\r
 356   if fd > maxs then maxs := fd;\r
 357   if fd_isset(fd,fdsrmaster) then exit;\r
 358   fd_set(fd,fdsrmaster);\r
 359 \r
 360 end;\r
 361 \r
 362 procedure tselecteventcore.rmasterclr(fd: integer);\r
 363 begin\r
 364   if not fd_isset(fd,fdsrmaster) then exit;\r
 365   fd_clr(fd,fdsrmaster);\r
 366 \r
 367 end;\r
 368 \r
 369 \r
 370 procedure tselecteventcore.wmasterset(fd : integer);\r
 371 begin\r
 372   if fd > absoloutemaxs then raise esocketexception.create('file discriptor out of range');\r
 373   if fd > maxs then maxs := fd;\r
 374 \r
 375   if fd_isset(fd,fdswmaster) then exit;\r
 376   fd_set(fd,fdswmaster);\r
 377 \r
 378 end;\r
 379 \r
 380 procedure tselecteventcore.wmasterclr(fd: integer);\r
 381 begin\r
 382   if not fd_isset(fd,fdswmaster) then exit;\r
 383   fd_clr(fd,fdswmaster);\r
 384 end;\r
 385 \r
 386 procedure tselecteventcore.setfdreverse(fd : integer;reverseto : tlasio);\r
 387 begin\r
 388   fdreverse[fd] := reverseto;\r
 389 end;\r
 390 \r
 391 \r
 392 \r
 393 begin\r
 394   eventcore := tselecteventcore.create;\r
 395 \r
 396   maxs := 0;\r
 397   fd_zero(fdsrmaster);\r
 398   fd_zero(fdswmaster);\r
 399 end.\r