dxservercore.pas

Well known and usefull component for delphi 7

{$IFDEF LINUX}
                  TDXServerCoreThread(ListenerThreadObject).MyCriticalSection.StartingWrite;
                  Dec(TDXServerCoreThread(ListenerThreadObject).FActiveConnections);
                  TDXServerCoreThread(ListenerThreadObject).MyCriticalSection.FinishedWrite;
{$ELSE}
                  InterlockedDecrement(TDXServerCoreThread(ListenerThreadObject).FActiveConnections);
{$ENDIF}
               end;
            end;
         end
         else begin
            FreeOnTerminate := True;
            Break;
         end;
      // incase user destoryed my DXSock client object, test client.
         if Assigned(Client) then begin
            try
               if Client.IsUDPMode then
                  Client.Sock := INVALID_SOCKET
               else
                  if Client.Sock <> INVALID_SOCKET then Client.CloseGracefully;
            except
               try
                  Client.Free;
               finally
                  Client := nil;
               end;
            end;
         end;
         if FreeOnTerminate then Break;
         if not Terminated then Suspend;
         if Terminated then FreeOnTerminate := True;
      end;
   finally
      Terminate;
   end;
end;

{ Simple implementation of this "Thread" is to pass the Create
  the recently "Accept"ed Socket during the create. But, if you
  are producing speed by pre-creating the threads, this
  procedure will allow you to pre-create threads, and pass the
  "Socket" when the new accept is valid.                        }

procedure TDXClientThread.SetSocketLater(Socket: TDXSock);
begin
   if Assigned(Client) then begin
      Client.Free;
      Client := nil;
   end;
   Client := Socket;
   Client.PeerIPAddress := Socket.PeerIPAddress;
   Client.PeerPort := Socket.PeerPort;
end;

procedure TDXClientThreadObject.SetSocketLater(Socket: TDXSock);
begin
   if Assigned(Client) then begin
      Client.Free;
      Client := nil;
   end;
   Client := Socket;
   Client.PeerIPAddress := Socket.PeerIPAddress;
   Client.PeerPort := Socket.PeerPort;
end;

constructor TDXServerCoreThread.Create(CreateSuspended: Boolean);
begin
   inherited Create(CreateSuspended);
   FreeOnTerminate := False;
   ListenerSocket := TDXSock.Create(nil); // RC2
   fsBindTo := '';
   fiServerPort := 0;
   fiMaxConn := 200;
   FActiveConnections := 0;
   fbAnnouncedIdle := 0;
{$IFNDEF LINUX}
   fbBufferCreates := B3True;
{$ELSE}
   fbBufferCreates := B3False; // 2004-Jan (Kylix does not do this correct!
{$ENDIF}
   fThreadPool := TList.Create;
   MyCriticalSection := TDXCritical.Create;
   fSessionTracker := TDXSessionTracker.Create(nil);
end;

destructor TDXServerCoreThread.Destroy;
begin
{$WARNINGS OFF}
   if Assigned(fThreadPool) then begin
      MyCriticalSection.StartingWrite;
      while fThreadPool.Count > 0 do begin
         if Assigned(fThreadPool[0]) then begin
            try
               TDXClientThread(fThreadPool[0]).ListenerThreadObject := nil;
               fSessionTracker.UnRegisterSession(TDXClientThread(fThreadPool[0]));
            finally
               try
// this will raise an exception if it is already set "FreeOnTerminate"!
                  if TDXClientThread(fThreadPool[0]).Suspended then begin
                     TDXClientThread(fThreadPool[0]).FreeOnTerminate := True;
                     TDXClientThread(fThreadPool[0]).Terminate;
                     TDXClientThread(fThreadPool[0]).Resume;
                  end
                  else begin
                     TDXClientThread(fThreadPool[0]).FreeOnTerminate := True;
                     TDXClientThread(fThreadPool[0]).Terminate;
                  end;
               except
                  ;
               end;
            end;
         end;
         fThreadPool.Delete(0);
      end;
      fThreadPool.Free;
      fThreadPool := nil;
      MyCriticalSection.FinishedWrite;
   end;
   fSessionTracker.Free;
   fSessionTracker := nil;
{$WARNINGS ON}
   try
      if Assigned(ListenerSocket) then begin
         ListenerSocket.Free; // 13-Jan-2005 free calls CloseNow;
      end;
   finally
      ListenerSocket := nil;
   end;
   MyCriticalSection.Free;
   inherited Destroy;
end;

function TDXServerCoreThread.ActiveNumberOfConnections: Integer;
begin
   Result := fActiveConnections;
end;

procedure TDXServerCoreThread.SetBlocking(value: Boolean);
begin
   fUseBlocking := Value;
   if ListenerSocket.ValidSocket then
      ListenerSocket.SetBlocking(Value);
end;

procedure TDXServerCoreThread.SetNagle(value: Boolean);
begin
   fUseNagle := Value;
   if ListenerSocket.ValidSocket then
      ListenerSocket.SetNagle(Value);
end;

procedure TDXServerCoreThread.SetBufferCreates(value: TDXThreePointBoolean{Boolean});
begin
   if fActiveConnections > 0 then Exit;
   fbBufferCreates := Value;
   if Value<>B3True then
      if fiMaxConn < 1 then fiMaxConn := 100;
end;

procedure TDXServerCoreThread.SetSuspend(value: Boolean);
begin
   fbSuspend := Value;
end;

function TDXServerCoreThread.GetSocket: TDXSock;
begin
   Result := ListenerSocket;
end;

///////////////////////////////////////////////////////////////////////////////
//EXECUTE:
//        This is the "Loop" for the server. It listens on the specified port and
//        IP address(es). As a connection comes in, it creates a DXServerThread
//        and gives it a new instance of the client socket. At that point the new
//        DXServerThread runs independant of this thread. If you wish to have a
//        pool of DXServerThreads suspended this is the section to change! When
//        a new DXServerThread is created, all of the "Events" are passed to it,
//        which means you "Server" events better be threadsafe!
//
//        Events: OnIdle is fired one the server has stopped receiving connection
//        requests. It is fired everytime the server goes idle from connection(s)
//        OnSleep is fired every two seconds after this loop has gone Idle.
///////////////////////////////////////////////////////////////////////////////

procedure TDXServerCoreThread.Execute;
var
   toggleSleep: Integer;
   DXClientThread: TDXClientThread;
   newClient: TDXSock;

   function InitializeThreading(UDP: Boolean): Boolean;
   var
      NewListen: PNewListen;
      Ws: string;

   begin
      toggleSleep := 0;
      Result := False;
      if (Length(fsBindTo) > 7) then ListenerSocket.BindTo := fsBindTo;
      New(NewListen);
      with NewListen^ do begin
         Port := fiServerPort;
         UseNAGLE := fUseNagle;
         UseBlocking := fUseBlocking;
         UseUDP := UDP;
         WinsockQueue := fListenerQueueSize;
         ConnectionLess := UDP;
      end;
      if not ListenerSocket.Listen(NewListen) then begin
         Dispose(NewListen);
         if Assigned(feListenerFailed) then begin
            feListenerFailed(ListenerSocket.LastCommandStatus);
//            ProcessWindowsMessageQueue;// have to do incase event was GUI based.
         end
         else begin
            Str(fiServerPort, Ws);
{$IFNDEF LINUX}
            if IsConsole then begin
               Beep;
               Beep;
               Beep;
               Writeln('Listener on port ' + Ws + ', ' +
                  ListenerSocket.GetErrorDesc(ListenerSocket.LastCommandStatus));
               DoSleepEx(1000);
            end
            else
{$ENDIF}
               ShowMessageWindow('Listener on port ' + Ws,
                  ListenerSocket.GetErrorDesc(ListenerSocket.LastCommandStatus));
         end;
         FreeonTerminate := True;
         TDXServerCore(fServerCore).fbActive := False;
         Exit;
      end;
      Dispose(NewListen);
      Result := True;
      if Assigned(feListenerStarted) then begin
         feListenerStarted(Self);
//         ProcessWindowsMessageQueue;// have to do incase event was GUI based.
      end;
   end;

   procedure EventsOrSleep;
   begin
      if toggleSleep < 2000 then begin
         Inc(toggleSleep);
         if (toggleSleep > 1000) and (fbAnnouncedIdle < 1) then begin
            fbAnnouncedIdle := 1;
            if assigned(feIdle) then begin
               feIdle(Self);
//               ProcessWindowsMessageQueue;// have to do incase event was GUI based.
            end;
         end;
         DoSleepEx(1); // 4RC2
      end
      else begin
         if fbAnnouncedIdle = 1 then begin
            if assigned(feSleep) then begin
               feSleep(Self);
//               ProcessWindowsMessageQueue;// have to do - incase event was GUI based.
            end;
            fbAnnouncedIdle := 2;
         end;
         if toggleSleep < 5000 {3.0 - was 50} then begin
            Inc(toggleSleep);
            DoSleepEx(1); // 4RC2
         end
         else begin
            DoSleepEx(1);
            ProcessWindowsMessageQueue;
         end;
      end;
   end;

{$IFNDEF LINUX}
   procedure UseMessageQueue;
   var
      Allowed: Boolean;
      TmpObject:TDXClientThreadObject;

   begin
      TmpObject:=TDXClientThreadObject.Create(Nil);
      TmpObject.OnNewConnect := feNewConnect;
      TmpObject.fBlockSizeFlags := fBlockSizeFlags;
      TmpObject.ListenerThreadObject := Self;
      while not Terminated do begin
         if (FActiveConnections < fiMaxConn) then begin
            if fbSuspend then DoSleepEx(20)
            else
               if ListenerSocket.Accept(TmpObject.Client) then begin
                  if assigned(feAccept) then begin
                     Allowed := True;
                     feAccept(TmpObject.Client.PeerIPAddress,
                        TmpObject.Client.PeerPort,
                        TmpObject.Client, Allowed);
                     if not Allowed then begin
                        TmpObject.Client.CloseNow;
                        TmpObject.Client.Free;
                        Continue;
                     end;
                  end;
                  feNewConnect(TDXClientThread(tmpObject));
                  InterlockedIncrement(FActiveConnections);
                  if (fbAnnouncedIdle > 0) then begin
                     if Assigned(feWakeUp) then begin
                        feWakeUp(Self);
                     end;
                  end;
                  TmpObject:=TDXClientThreadObject.Create(Nil);
                  TmpObject.OnNewConnect := feNewConnect;
                  TmpObject.fBlockSizeFlags := fBlockSizeFlags;
                  TmpObject.ListenerThreadObject := Self;
                  fbAnnouncedIdle := 0;
                  toggleSleep := 0;
               end
               else
                  EventsOrSleep;
         end
         else begin
            if assigned(feMaxConnects) then begin
               feMaxConnects(Self);
            end
            else
               DoSleepEx(1);
         end;
      end;
      ListenerSocket.CloseNow;
      tmpObject.Free;
   end;
{$ENDIF}

   procedure ThreadAtATime;
   var
      Allowed: Boolean;

   begin
      DXClientThread := TDXClientThread.Create(True);
      DXClientThread.Client := TDXSock.Create(nil); // RC2
{$IFNDEF LINUX}
      DXClientThread.Priority := fstPriority;
{$ENDIF}
      DXClientThread.OnNewConnect := feNewConnect;
      DXClientThread.fBlockSizeFlags := fBlockSizeFlags;
      DXClientThread.ListenerThreadObject := Self;
      while not Terminated do begin
         if (FActiveConnections < fiMaxConn) then begin
            if fbSuspend then
               DoSleepEx(20)
            else
               if ListenerSocket.Accept(DXClientThread.Client) then begin
                  if assigned(feAccept) then begin
                     Allowed := True;
                     feAccept(DXClientThread.Client.PeerIPAddress,
                        DXClientThread.Client.PeerPort,
                        DXClientThread.Client, Allowed);
                     if not Allowed then begin
                        DXClientThread.Client.CloseNow;
                        Continue;
                     end;
                  end;
                  DXClientThread.Resume;
{$IFDEF LINUX}
                  MyCriticalSection.StartingWrite;
                  Inc(FActiveConnections);
                  MyCriticalSection.FinishedWrite;
{$ELSE}
                  InterlockedIncrement(FActiveConnections);
{$ENDIF}
                  if (fbAnnouncedIdle > 0) then begin
                     if Assigned(feWakeUp) then begin
                        feWakeUp(Self);
//                        ProcessWindowsMessageQueue;// have to do incase event was GUI based.
                     end;
                  end;
                  DXClientThread := TDXClientThread.Create(True);
                  DXClientThread.Client := TDXSock.Create(nil); // RC2
{$IFNDEF LINUX}
                  DXClientThread.Priority := fstPriority;
{$ENDIF}
                  DXClientThread.OnNewConnect := feNewConnect;
                  DXClientThread.fBlockSizeFlags := fBlockSizeFlags;
                  DXClientThread.ListenerThreadObject := Self;
                  fbAnnouncedIdle := 0;
                  toggleSleep := 0;
               end
               else
                  EventsOrSleep;
         end
         else begin
            if assigned(feMaxConnects) then begin
               feMaxConnects(Self);