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