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