idtcpserver.pas

photo.163.com 相册下载器 多线程下载

  if (FIOHandler <> nil) and FImplicitIOHandler then begin
    FreeAndNil(FIOHandler);
  end;

  // Destroy bindings first
  FreeAndNil(FBindings);
  //
  FreeAndNil(FContexts);
  inherited;
end;

procedure TIdTCPServer.DoAfterBind;
begin
  if Assigned(FOnAfterBind) then begin
    FOnAfterBind(Self);
  end;
end;

procedure TIdTCPServer.SendGreeting(AContext: TIdContext; AGreeting: TIdReply);
begin
  AContext.Connection.IOHandler.Write(AGreeting.FormattedReply);
end;

procedure TIdTCPServer.DoConnect(AContext: TIdContext);
begin
  if Assigned(Intercept) then begin
    AContext.Connection.IOHandler.Intercept := Intercept.Accept(
      AContext.Connection);
    if Assigned(AContext.Connection.IOHandler.Intercept) then begin
      AContext.Connection.IOHandler.Intercept.Connect(AContext.Connection);
   end;
  end;
  if Assigned(OnConnect) then begin
    OnConnect(AContext);
  end;
end;

procedure TIdTCPServer.DoDisconnect(AContext: TIdContext);
begin
  if Assigned(OnDisconnect) then begin
    OnDisconnect(AContext);
  end;
  if Assigned(Intercept) then begin
    if Assigned(AContext.Connection.IOHandler) then begin
      if Assigned(AContext.Connection.IOHandler.Intercept) then begin
        AContext.Connection.IOHandler.Intercept.DisConnect;
        AContext.Connection.IOHandler.Intercept.free;
        AContext.Connection.IOHandler.Intercept:=nil;
      end;
    end;
  end;
end;

procedure TIdTCPServer.DoException(AContext: TIdContext; AException: Exception);
begin
  if Assigned(OnException) then begin
    OnException(AContext, AException);
  end;
end;

function TIdTCPServer.DoExecute(AContext: TIdContext): Boolean;
begin
  if Assigned(OnExecute) then begin
    OnExecute(AContext);
  end;
  Result := False;
  if AContext <> nil then begin
    if AContext.Connection <> nil then begin
      Result := AContext.Connection.Connected;
    end;
  end;
end;

procedure TIdTCPServer.DoListenException(AThread: TIdListenerThread; AException: Exception);
begin
  if Assigned(FOnListenException) then begin
    FOnListenException(AThread, AException);
  end;
end;

function TIdTCPServer.GetDefaultPort: TIdPort;
begin
  Result := FBindings.DefaultPort;
end;

procedure TIdTCPServer.Loaded;
begin
  inherited Loaded;
  // Active = True must not be performed before all other props are loaded
  if Active then begin
    FActive := False;
    Active := True;
  end;
end;

procedure TIdTCPServer.Notification(AComponent: TComponent; Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  // Remove the reference to the linked components if they are deleted
  if (Operation = opRemove) then begin
    if AComponent = Scheduler then begin
      TerminateAllThreads;
      Scheduler := nil;
    end else if AComponent = FIntercept then begin
      FIntercept := nil;
    end else if AComponent = FIOHandler then begin
      FIOHandler := nil;
    end;
  end;
end;

procedure TIdTCPServer.SetActive(AValue: Boolean);
begin
   // At design time we just set the value and save it for run time
  if (csDesigning in ComponentState)
   // During loading we ignore it till all other properties are set. Loaded
   // will recall it to toggle it
   or (csLoading in ComponentState)
   then begin
    FActive := AValue;
  end else if FActive <> AValue then begin
    if AValue then begin
      Startup;
    end else begin
      Shutdown;
    end;
  end;
end;

procedure TIdTCPServer.SetBindings(const AValue: TIdSocketHandles);
begin
  FBindings.Assign(AValue);
end;

procedure TIdTCPServer.SetDefaultPort(const AValue: TIdPort);
begin
  FBindings.DefaultPort := AValue;
end;

procedure TIdTCPServer.SetIntercept(const AValue: TIdServerIntercept);
begin
  FIntercept := AValue;
  // Add self to the intercept's notification list
  if Assigned(FIntercept) then begin
    FIntercept.FreeNotification(Self);
  end;
end;

procedure TIdTCPServer.SetScheduler(const AValue: TIdScheduler);
var
  LScheduler: TIdScheduler;
begin
  EIdException.IfTrue(Active, RSTCPServerSchedulerAlreadyActive);

  // If implicit one already exists free it
  // Free the default Thread manager
  if ImplicitScheduler then begin
    // Under D8 notification gets called after .Free of FreeAndNil, but before
    // its set to nil with a side effect of IDisposable. To counteract this we
    // set it to nil first.
    // -Kudzu
    LScheduler := FScheduler;
    FScheduler := nil;
    FreeAndNil(LScheduler);
    //
    FImplicitScheduler := False;
  end;

  FScheduler := AValue;
  // Ensure we will be notified when the component is freed, even is it's on
  // another form
  if AValue <> nil then begin
    AValue.FreeNotification(self);
  end;
  if FIOHandler <> nil then begin
    FIOHandler.SetScheduler(FScheduler);
  end;
end;

procedure TIdTCPServer.SetIOHandler(const AValue: TIdServerIOHandler);
begin
  if Assigned(FIOHandler) and FImplicitIOHandler then begin
    FImplicitIOHandler := false;
    FreeAndNil(FIOHandler);
  end;
  FIOHandler := AValue;
  if AValue <> nil then begin
    AValue.FreeNotification(self);
  end;
  if FIOHandler <> nil then begin
    FIOHandler.SetScheduler(FScheduler);
  end;
end;

//APR-011207: for safe-close Ex: SQL Server ShutDown 1) stop listen 2) wait until all clients go out
procedure TIdTCPServer.TerminateListenerThreads;
var
  i: Integer;
  LListenerThread: TIdListenerThread;
  LListenerThreads: TList;
Begin
  if FListenerThreads <> nil then begin
    LListenerThreads := FListenerThreads.LockList; try
      for i:= 0 to LListenerThreads.Count - 1 do begin
        LListenerThread := TIdListenerThread(LListenerThreads[i]);
        with LListenerThread do begin
          // Stop listening
          Terminate;
          Binding.CloseSocket;
          // Tear down Listener thread
          WaitFor;
          Free;
        end;
      end;
    finally FListenerThreads.UnlockList; end;
    FreeAndNil(FListenerThreads);
  end;
end;

procedure TIdTCPServer.TerminateAllThreads;
var
  i: Integer;
begin
  // TODO:  reimplement support for TerminateWaitTimeout

  //BGO: find out why TerminateAllThreads is sometimes called multiple times
  //Kudzu: Its because of notifications. It calls shutdown when the Scheduler is
  // set to nil and then again on destroy.
  if Contexts <> nil then begin
    with Contexts.LockList do try
      for i := 0 to Count - 1 do begin
        // Dont call disconnect with true. Otheriwse it frees the IOHandler and the thread
        // is still running which often causes AVs and other.
        TIdContext(Items[i]).Connection.Disconnect(False);
      end;
    finally Contexts.UnLockList; end;
  end;

  // Scheduler may be nil during destroy which calls TerminateAllThreads
  // This happens with explicit schedulers
  if Scheduler <> nil then begin
    Scheduler.TerminateAllYarns;
  end;
end;

procedure TIdTCPServer.DoBeforeConnect(AContext: TIdContext);
begin
  if Assigned(OnBeforeConnect) then begin
    OnBeforeConnect(AContext);
  end;
end;

procedure TIdTCPServer.DoMaxConnectionsExceeded(
  AIOHandler: TIdIOHandler
  );
begin
end;

procedure TIdTCPServer.InitComponent;
begin
  inherited;
  FBindings := TIdSocketHandles.Create(Self);
  FContexts := TThreadList.Create;
  FContextClass := TIdContext;
  //
  FTerminateWaitTime := 5000;
  FListenQueue := IdListenQueueDefault;
  //TODO: When reestablished, use a sleeping thread instead
//  fSessionTimer := TTimer.Create(self);
end;

procedure TIdTCPServer.Shutdown;
begin
  // Must set to False here. SetScheduler checks this
  FActive := False;
  //
  TerminateListenerThreads;
  // Tear down ThreadMgr
  try
    TerminateAllThreads;
  finally
    {//bgo TODO: fix this: and TIdThreadSafeList(Threads).IsCountLessThan(1)}
    // DONE -oAPR: BUG! Threads still live, Mgr dead ;-(
    if ImplicitScheduler then begin
      Scheduler := nil;
    end;
  end;
end;

procedure TIdTCPServer.Startup;
var
  i: Integer;
  LListenerThread: TIdListenerThread;
begin
  // Set up bindings
  if Bindings.Count = 0 then begin
    Bindings.Add; // IPv4
    if GStack.SupportsIPv6 then begin // maybe add a property too, so
      with Bindings.Add do begin      // the developer can switch it on/off
        IPVersion := Id_IPv6;
      end;
    end;
  end;
  // Setup IOHandler
  if not Assigned(FIOHandler) then begin
    IOHandler := TIdServerIOHandlerStack.Create(self);  {TIdServerIOHandlerStack.Create(self);}
    FImplicitIOHandler := True;
  end;
  //
  IOHandler.Init;
  //
  // Set up scheduler
  if Scheduler = nil then begin
    Scheduler := TIdSchedulerOfThreadDefault.Create(Self);
    // Useful in debugging and for thread names
    Scheduler.Name := Name + 'Scheduler';   {do not localize}
    FImplicitScheduler := true;
  end;
  Scheduler.Init;
  // Set up listener threads
  i := 0;
  try
    while i < Bindings.Count do begin
      with Bindings[i] do begin
        AllocateSocket;
        if (FReuseSocket = rsTrue) or ((FReuseSocket = rsOSDependent) and (GOSType = otLinux))
          then begin
             SetSockOpt(Id_SOL_SOCKET, Id_SO_REUSEADDR,Id_SO_True);
        end;
        Bind;
      end;
      Inc(i);
    end;
  except
    Dec(i); // the one that failed doesn't need to be closed
    while i >= 0 do begin
      Bindings[i].CloseSocket;
      Dec(i);
    end;
    FActive := True;
    SetActive(False); // allow descendants to clean up
    raise;
  end;
  DoAfterBind;
  FListenerThreads := TThreadList.Create;
  for i := 0 to Bindings.Count - 1 do begin
    Bindings[i].Listen(FListenQueue);
    LListenerThread := TIdListenerThread.Create(Self, Bindings[i]);
    LListenerThread.Name := Name + ' Listener #' + IntToStr(i + 1); {do not localize}
    LListenerThread.OnBeforeRun := OnBeforeListenerRun;
    //Todo: Implement proper priority handling for Linux
    //http://www.midnightbeach.com/jon/pubs/2002/BorCon.London/Sidebar.3.html
    LListenerThread.Priority := tpListener;
    FListenerThreads.Add(LListenerThread);
    LListenerThread.Start;
  end;
  FActive := True;
end;

{ TIdListenerThread }

procedure TIdListenerThread.AfterRun;
begin
  inherited;
  // Close just own binding. The rest will be closed from their coresponding
  // threads
  FBinding.CloseSocket;
end;

procedure TIdListenerThread.BeforeRun;
begin
  inherited;
  if Assigned(FOnBeforeRun) then begin
    FOnBeforeRun(Self);
  end;
end;

constructor TIdListenerThread.Create(AServer: TIdTCPServer; ABinding: TIdSocketHandle);
begin
  inherited Create;
  FBinding := ABinding;
  FServer := AServer;
end;

procedure TIdListenerThread.Run;
var
  LContext: TIdContext;
  LIOHandler: TIdIOHandler;
  LPeer: TIdTCPConnection;
  LYarn: TIdYarn;
begin
  LContext := nil;
  LPeer := nil;
  LYarn := nil;
  try
    // GetYarn can raise exceptions
    LYarn := Server.Scheduler.AcquireYarn;

    LIOHandler := Server.IOHandler.Accept(Binding, Self, LYarn);
    if LIOHandler = nil then begin
      // Listening has finished
      Stop;
      Abort;
    end else begin
      // We have accepted the connection and need to handle it
      LPeer := TIdTCPConnection.Create(nil);
      LPeer.IOHandler := LIOHandler;
      LPeer.ManagedIOHandler := True;
    end;

    // LastRcvTimeStamp := Now;  // Added for session timeout support
    // ProcessingTimeout := False;
    if (Server.MaxConnections > 0) // Check MaxConnections
     and (TIdThreadSafeList(Server.Contexts).IsCountLessThan(Server.MaxConnections) = False)
     then begin
      FServer.DoMaxConnectionsExceeded(LIOHandler);
      LPeer.Disconnect;
      Abort;
    end;
    // Create and init context
    LContext := Server.FContextClass.Create(LPeer, LYarn, Server.Contexts);
    // We set these instead of having the context call them directly
    // because they are protected methods. Also its good to keep
    // Context indepent of the server as well.
    LContext.OnBeforeRun := Server.DoConnect;
    LContext.OnRun := Server.DoExecute;
    LContext.OnAfterRun := Server.DoDisconnect;
    //
    Server.ContextCreated(LContext);
    //
    // If all ok, lets start the yarn
    Server.Scheduler.StartYarn(LYarn, LContext);
  except
    on E: Exception do begin
      FreeAndNil(LContext);
      FreeAndNil(LPeer);
      // Must terminate - likely has not started yet
      if LYarn <> nil then begin
        Server.Scheduler.TerminateYarn(LYarn);
      end;
      // EAbort is used to kick out above and destroy yarns and other, but
      // we dont want to show the user
      if not (E is EAbort) then begin
        Server.DoListenException(Self, E);
      end;
    end;
  end;
end;

end.