{lsocket.pas}

{io and timer code by plugwash}

{ Copyright (C) 2005 Bas Steendijk and Peter Green
  For conditions of distribution and use, see copyright notice in zlib_license.txt
  which is included in the package
  ----------------------------------------------------------------------------- }

{$ifdef fpc}
  {$ifndef ver1_0}
    {$define useinline}
  {$endif}
{$endif}

unit lcoreselect;


interface
uses
  {$ifdef VER1_0}
    linux,
  {$else}
    baseunix,unix,unixutil,sockets,
  {$endif}
  fd_utils;
var
  maxs                                  : longint    ;
  exitloopflag                          : boolean    ; {if set by app, exit mainloop}

function getfdsrmaster : fdset; {$ifdef useinline}inline;{$endif}
function getfdswmaster : fdset; {$ifdef useinline}inline;{$endif}

procedure lcoreinit;

implementation
uses
  lcore,sysutils,
  classes,pgtypes,bfifo,
  {$ifndef nosignal}
    lsignal,
  {$endif}
  ltimevalstuff;

{$include unixstuff.inc}

const
  absolutemaxs_select = (sizeof(fdset)*8)-1;

var
  fdreverse:array[0..absolutemaxs_select] of tlasio;
type
  tselecteventcore=class(teventcore)
    public
      procedure processmessages; override;
      procedure messageloop; override;
      procedure exitmessageloop;override;
      procedure setfdreverse(fd : integer;reverseto : tlasio); override;
      procedure rmasterset(fd : integer;islistensocket : boolean); override;
      procedure rmasterclr(fd: integer); override;
      procedure wmasterset(fd : integer); override;
      procedure wmasterclr(fd: integer); override;
    end;

procedure processtimers;inline;
var
  tvnow     : ttimeval ;
  currenttimer            : tltimer   ;
  temptimer               : tltimer  ;

begin
  gettimemonotonic(tvnow);
  currenttimer := firsttimer;
  while assigned(currenttimer) do begin
    //writeln(currenttimer.enabled);
    if tv_compare(tvnow,ttimeval(currenttimer.nextts)) and currenttimer.enabled then begin
      //if assigned(currenttimer.ontimer) then begin
      //  if currenttimer.enabled then if currenttimer.initialevent or currenttimer.initialdone then currenttimer.ontimer(currenttimer);
      //  currenttimer.initialdone := true;
      //end;
      if assigned(currenttimer.ontimer) then currenttimer.ontimer(currenttimer);
      currenttimer.nextts := timeval(tvnow);
      tv_add(ttimeval(currenttimer.nextts),currenttimer.interval);
    end;
    temptimer := currenttimer;
    currenttimer := currenttimer.nexttimer;
  end;
end;

procedure processasios(var fdsr,fdsw:fdset);//inline;
var
  currentsocket : tlasio  ;
  socketcount   : integer ; // for debugging purposes :)
  dw,bt:integer;
  currentfdword:fdword;
  fd : integer;
begin
  //writeln('entering processasios');
{  inc(lcoretestcount);}

    //the message loop will exit if all lasios and ltimers and lsignals are destroyed
    //if (not assigned(firstasin)) and (not assigned(firsttimer)) and (not assigned(firstsignal)) then exit;


  {------- test optimised loop}
  socketcount := 0;
  for dw := (maxs shr fdwordshift) downto 0 do if (fdsr[dw] or fdsw[dw]) <> 0 then begin
    currentfdword := (fdsr[dw] or fdsw[dw]);
    for bt := fdwordmaxbit downto 0 do if currentfdword and (1 shl bt) <> 0 then begin
      inc(socketcount);
      fd := dw shl fdwordshift or bt;
      //writeln('reversing fd ',fd);
      currentsocket := fdreverse[fd];
      {if not assigned(currentsocket) then raise exception.create('currentsocket not assigned');
      if currentsocket.fdhandlein < 0 then raise exception.create('currentsocket.fdhandlein out of range');}
      {i've seen the out of range case actually happening, so it can happen. test: just close the fd - beware}
      if not assigned(currentsocket) then begin
        fdclose(fd);
        continue
      end;
      if currentsocket.fdhandlein < 0 then begin
        fdclose(fd);
        continue
      end;
      try
        currentsocket.handlefdtrigger(fd_isset(fd,fdsr),fd_isset(fd,fdsw));
      except
        on E: exception do begin
          currentsocket.HandleBackGroundException(e);
        end;
      end;

      if mustrefreshfds then begin
        if select(maxs+1,@fdsr,@fdsw,nil,0) <= 0 then begin
          fd_zero(fdsr);
          fd_zero(fdsw);
        end;
      end;
    end;
  end;

  {
  !!! issues:
  - sockets which are released may not be freed because theyre never processed by the loop
  made new code for handling this, using asinreleaseflag

  - when/why does the mustrefreshfds select apply, check if i did it correctly?

  - what happens if calling handlefdtrigger for a socket which does not have an event
  }
  {------- original loop}

  (*
  currentsocket := firstasin;
  socketcount := 0;
  while assigned(currentsocket) do begin
    if mustrefreshfds then begin
      if select(maxs,@fdsr,@fdsw,nil,0) <= 0 then begin
        fd_zero(fdsr);
        fd_zero(fdsw);
      end;
    end;
    try
      if fd_isset(currentsocket.fdhandlein,fdsr) or fd_isset(currentsocket.fdhandleout,fdsw) then begin
        currentsocket.handlefdtrigger(fd_isset(currentsocket.fdhandlein,fdsr),fd_isset(currentsocket.fdhandleout,fdsw));
      end;
    except
      on E: exception do begin
        currentsocket.HandleBackGroundException(e);
      end;
    end;
    tempsocket := currentsocket;
    currentsocket := currentsocket.nextasin;
    inc(socketcount);
    if tempsocket.released then begin
      tempsocket.free;
    end;
  end; *)
{  debugout('socketcount='+inttostr(socketcount));}
  //writeln('leaving processasios');
end;

procedure tselecteventcore.processmessages;
var
  fdsr         , fdsw : fdset   ;
  selectresult        : longint ;
begin
  mustrefreshfds := false;
  {$ifndef nosignal}
    prepsigpipe;
  {$endif}
  selectresult := select(maxs+1,@fdsr,@fdsw,nil,0);
  while (selectresult>0) or assigned(firsttask) do begin;

    processtasks;
    processtimers;
    if selectresult > 0 then begin
      processasios(fdsr,fdsw);
    end;
    selectresult := select(maxs+1,@fdsr,@fdsw,nil,0);

  end;
  mustrefreshfds := true;
end;


var
  FDSR , FDSW : fdset;

var
  fdsrmaster , fdswmaster               : fdset      ;

function getfdsrmaster : fdset; {$ifdef fpc}inline;{$endif}
begin
  result := fdsrmaster;
end;
function getfdswmaster : fdset; {$ifdef fpc}inline;{$endif}
begin
  result := fdswmaster;
end;


{
select in linux/sysV subtracts from timeout for time spent in it, but in BSD it doesn't
enabling select_no_autotv here makes doSelect mimic the decrement behavior, in case the caller needs it
the caller here in lcoreselect does not need it, and enabling it would have a slight perf hit.
it is safe for this to be enabled even if the OS does it too (it will not subtract twice)
it is currently disabled but can be enabled if needed
}
{$ifndef linux}{-$define select_no_autotv}{$endif}

Function  doSelect(timeOut:PTimeVal):longint;//inline;
var
  localtimeval : ttimeval;
  maxslocal    : integer;
  {$ifdef select_no_autotv}
  timeoutcopy,tvstart,tvend : ttimeval;
  {$endif}
begin
  //unblock signals
  //zeromemory(@sset,sizeof(sset));
  //sset[0] := ;
  fdsr := getfdsrmaster;
  fdsw := getfdswmaster;

  if assigned(firsttask) then begin
    localtimeval.tv_sec  := 0;
    localtimeval.tv_usec := 0;
    timeout := @localtimeval;
  end;

  maxslocal := maxs;
  mustrefreshfds := false;
{  debugout('about to call select');}
  {$ifndef nosignal}
    sigprocmask(SIG_UNBLOCK,@blockset,nil);
  {$endif}

  {$ifdef select_no_autotv}
  if assigned(timeout) then begin
    timeoutcopy.tv_sec := timeOut.tv_sec;
    timeoutcopy.tv_usec := timeOut.tv_usec;
    gettimemonotonic(tvstart);
  end;
  {$endif}

  result := select(maxslocal+1,@FDSR,@FDSW,nil,timeout);
  if result <= 0 then begin
    fd_zero(FDSR);
    fd_zero(FDSW);
    if result=-1 then begin
      if linuxerror = SYS_EINTR then begin
        // we received a signal it is not a problem
      end else begin
        raise esocketexception.create('select returned error '+inttostr(linuxerror));
      end;
    end
  {$ifdef select_no_autotv}
    else if (result = 0) and assigned(timeout) then begin
      //timeout reached: zero the timeval
      timeout.tv_sec := 0;
      timeout.tv_usec := 0;
    end;
  end else if assigned(timeout) then begin
    //successful result: subtract elapsed time
    gettimemonotonic(tvend);
    tv_subtract(tvend,tvstart);
    tv_subtract(timeoutcopy,tvend);
    timeout.tv_sec := timeoutcopy.tv_sec;
    timeout.tv_usec := timeoutcopy.tv_usec;
    if (timeout.tv_sec < 0) then begin
      timeout.tv_sec := 0;
      timeout.tv_usec := 0;
    end;
  {$endif} //select_no_autotv
  end;

  {$ifndef nosignal}
    sigprocmask(SIG_BLOCK,@blockset,nil);
  {$endif}
{  debugout('select complete');}
end;

procedure tselecteventcore.exitmessageloop;
begin
  exitloopflag := true
end;



procedure tselecteventcore.messageloop;
var
  tv           ,tvnow     : ttimeval ;
  currenttimer            : tltimer  ;
  selectresult:integer;
begin
  {$ifndef nosignal}
    prepsigpipe;
  {$endif}
  {currentsocket := firstasin;
  if not assigned(currentsocket) then exit; //the message loop will exit if all lsockets are destroyed
  repeat

    if currentsocket.state = wsconnected then currentsocket.sendflush;
    currentsocket := currentsocket.nextasin;
  until not assigned(currentsocket);}


  repeat

    //the message loop will exit if all lasios and ltimers and lsignals are destroyed
    processtasks;
    //currenttask := nil;
    {beware}
    //if assigned(firsttimer) then begin
    //  tv.tv_sec := maxlongint;
    tv := tv_invalidtimebig;
    currenttimer := firsttimer;
    while assigned(currenttimer) do begin
      if tv_compare(tv,currenttimer.nextts) and currenttimer.enabled then tv := currenttimer.nextts;
      currenttimer := currenttimer.nexttimer;
    end;


    if tv_compare(tv,tv_invalidtimebig) then begin    
      //writeln('no timers active');
      if exitloopflag then break;
{    sleep(10);}
      selectresult := doselect(nil);

    end else begin
      gettimemonotonic(tvnow);
      tv_subtract(tv,tvnow);

      //writeln('timers active');
      if tv.tv_sec < 0 then begin
        tv.tv_sec := 0;
        tv.tv_usec := 0; {0.1 sec}
      end;
      if exitloopflag then break;
{    sleep(10);}
      selectresult := doselect(@tv);
      processtimers;

    end;
    if selectresult > 0 then processasios(fdsr,fdsw);
    {!!!only call processasios if select has asio events -beware}

    {artificial delay to throttle the number of processasios per second possible and reduce cpu usage}
  until false;
end;


procedure tselecteventcore.rmasterset(fd : integer;islistensocket : boolean);
begin
  //writeln('rmasterset called with fd ',fd);
  if fd > absolutemaxs then raise esocketexception.create('file descriptor out of range');
  if fd > maxs then maxs := fd;
  if fd_isset(fd,fdsrmaster) then exit;
  fd_set(fd,fdsrmaster);

end;

procedure tselecteventcore.rmasterclr(fd: integer);
begin
  //writeln('rmasterclr called with fd ',fd);
  if not fd_isset(fd,fdsrmaster) then exit;
  fd_clr(fd,fdsrmaster);

end;


procedure tselecteventcore.wmasterset(fd : integer);
begin
  //writeln('wmasterset called with fd ',fd);
  if fd > absolutemaxs then raise esocketexception.create('file descriptor out of range');
  if fd > maxs then maxs := fd;

  if fd_isset(fd,fdswmaster) then exit;
  fd_set(fd,fdswmaster);

end;

procedure tselecteventcore.wmasterclr(fd: integer);
begin
  //writeln('wmasterclr called with fd ',fd);
  if not fd_isset(fd,fdswmaster) then exit;
  fd_clr(fd,fdswmaster);
end;

procedure tselecteventcore.setfdreverse(fd : integer;reverseto : tlasio);
begin
  fdreverse[fd] := reverseto;
end;

var
  inited:boolean;

procedure lcoreinit;
begin
  if inited then exit;
  inited := true;
  eventcore := tselecteventcore.create;

  absolutemaxs := absolutemaxs_select;

  maxs := 0;
  fd_zero(fdsrmaster);
  fd_zero(fdswmaster);
end;

end.