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