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