idtcpserver.pas

Indy控件的使用源代码

end;

procedure TIdTCPServer.DoBeforeCommandHandler(AThread: TIdPeerThread; const ALine: string);
begin
  if Assigned(OnBeforeCommandHandler) then begin
    OnBeforeCommandHandler(Self, ALine, AThread);
  end;
end;

procedure TIdTCPServer.DoConnect(AThread: TIdPeerThread);
begin
  ReplyTexts.UpdateText(Greeting);
  AThread.Connection.WriteRFCReply(Greeting);
  if Assigned(OnConnect) then begin
    OnConnect(AThread);
  end;
end;

procedure TIdTCPServer.DoDisconnect(AThread: TIdPeerThread);
begin
  if Assigned(OnDisconnect) then begin
    OnDisconnect(AThread);
  end;
end;

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

function TIdTCPServer.DoExecute(AThread: TIdPeerThread): boolean;
var
  I,L: integer;
  LLine: string;
begin
  L := CommandHandlers.Count-1;
  if CommandHandlersEnabled and (L >= 0) then begin
    Result := TRUE;
    if AThread.Connection.Connected then begin //APR: was While, but user can disable handlers
      LLine := AThread.Connection.ReadLn;
      // OLX sends blank lines during reset groups and expects no response. Not sure
      // what the RFCs say about blank lines.
      // I telnetted to some newsservers, and they dont respond to blank lines.
      // This unit is core and not NNTP, but we should be consistent.
      if LLine <> '' then begin
        DoBeforeCommandHandler(AThread, LLine);
        try
          i := 0;
          while i<=L do begin
            with CommandHandlers.Items[i] do begin
              if Enabled and Check(LLine, AThread) then begin

                Break;
              end;
            end;
            inc(i);
          end;//while
          if i > L then begin
            DoOnNoCommandHandler(LLine, AThread);
          end;

        finally DoAfterCommandHandler(AThread); end;
      end;//if >''
    end;
  end else begin
    Result := Assigned(OnExecute);
    if Result then begin
      OnExecute(AThread);
    end;
  end;
end;

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

procedure TIdTCPServer.DoOnNoCommandHandler(const AData: string; AThread: TIdPeerThread);
begin
  if Assigned(OnNoCommandHandler) then begin
    OnNoCommandHandler(Self, AData, AThread);
  end else if ReplyUnknownCommand.ReplyExists then begin
    //Do not UpdateText here - in thread. Is done in constructor
    // TODO: wrong command name is frequently required
    AThread.Connection.WriteRFCReply(ReplyUnknownCommand);
  end else begin
    raise EIdTCPServerError.Create(RSNoCommandHandlerFound);
  end;
end;

function TIdTCPServer.GetDefaultPort: integer;
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 = FThreadMgr) then begin
      TerminateAllThreads;
      FThreadMgr := 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);
var
  i: Integer;
  LListenerThread: TIdListenerThread;
begin
  // SG 28/11/01: removed the "try..finally FActive := AValue; end;" wrapper
  // SG 28/11/01: It cause the component to be locked in the "active" state, even if
  // SG 28/11/01: the socket couldn't be bound.
    if (not (csDesigning in ComponentState)) and (FActive <> AValue)
      and (not (csLoading in ComponentState)) then begin
      if AValue then begin
        // InitializeCommandHandlers must be called only at runtime, and only after streaming
        // has occured. This used to be in .Loaded and that worked for forms. It failed
        // for dynamically created instances and also for descendant classes.
        if not FCommandHandlersInitialized then begin
          FCommandHandlersInitialized := True;
          InitializeCommandHandlers;
        end;
        // Set up bindings
        if Bindings.Count = 0 then begin
          Bindings.Add;
        end;

        // Set up ThreadMgr
        ThreadMgr.ThreadClass := ThreadClass;

        // Setup IOHandler

        if not Assigned(FIOHandler) then begin
          IOHandler := TIdServerIOHandlerSocket.Create(self);
          FImplicitIOHandler := true;
        end;
        // Update reply texts for "global" replies
        ReplyTexts.UpdateText(ReplyUnknownCommand);
        ReplyTexts.UpdateText(MaxConnectionReply);
        // Set up listener threads

        IOHandler.Init;
        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, PChar(@Id_SO_True), SizeOf(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;
        FListenerThreads := TThreadList.Create;
        for i := 0 to Bindings.Count - 1 do begin
          Bindings[i].Listen(FListenQueue);
          LListenerThread := TIdListenerThread.Create(Self, Bindings[i]);
          FListenerThreads.Add(LListenerThread);
          LListenerThread.Start;
        end;

      end else begin
        TerminateListenerThreads; 
        // Tear down ThreadMgr
        try
          TerminateAllThreads;
        finally
          if ImplicitThreadMgr and TIdThreadSafeList(Threads).IsCountLessThan(1) then begin // DONE -oAPR: BUG! Threads still live, Mgr dead ;-(
            FreeAndNil(FThreadMgr);
            FImplicitThreadMgr := False;
          end;
        end;//tryf
      end;
    end;
  FActive := AValue;
end;

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

procedure TIdTCPServer.SetDefaultPort(const AValue: integer);
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.SetThreadMgr(const AValue: TIdThreadMgr);
begin
  if ImplicitThreadMgr then
  begin
    // Free the default Thread manager
    FreeAndNil(FThreadMgr);
    FImplicitThreadMgr := false;
  end;

  FThreadMgr := 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;
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;
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 Assigned(FListenerThreads) 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;//if
End;//TerminateListenerThreads

procedure TIdTCPServer.TerminateAllThreads;
const
  LSleepTime: Integer = 250;
var
  i: Integer;
  LThreads: TList;
  LTimedOut: Boolean;
begin
  // Threads will be nil if exception happens during start up, such as trying to bind to a port
  // that is already in use.
  if Assigned(Threads) then begin
    // This will provide us with posibility to call AThread.Notification in OnDisconnect event handler
    // in order to access visual components. They can add notifications after the list has been
    // unlocked, and before/while TerminateThreads is called
    LThreads := Threads.LockList; try
      for i := 0 to LThreads.Count - 1 do begin
        with TIdPeerThread(LThreads[i]) do begin
          Connection.DisconnectSocket;
        end;
      end;
    finally Threads.UnlockList; end;
    // Must wait for all threads to terminate, as they access the server and bindings. If this
    // routine is being called from the destructor, this can cause AVs
    //
    // This method is used instead of:
    //  -Threads.WaitFor. Since they are being destroyed thread. WaitFor could AV. And Waiting for
    //   Handle produces different code for different OSs, and using common code has troubles
    //   as the handles are quite different.
    //  -Last thread signaling
    // ThreadMgr.TerminateThreads(TerminateWaitTime);

    LTimedOut := True;
    for i := 1 to (TerminateWaitTime div LSleepTime) do begin
      if TIdThreadSafeList(Threads).IsCountLessThan(1) then begin
        LTimedOut := False;
        Break;
      end;
      Sleep(LSleepTime); // moved here so not sleeping if no threads
    end;
    if LTimedOut then begin
      raise EIdTerminateThreadTimeout.Create(RSTerminateThreadTimeout);
    end;
  end;
End;//TerminateAllThreads

function TIdTCPServer.GetThreadMgr: TIdThreadMgr;
begin
  if (not (csDesigning in ComponentState)) and (not Assigned(FThreadMgr)) then
  begin
    // Set up ThreadMgr
    ThreadMgr := TIdThreadMgrDefault.Create(Self);
    FImplicitThreadMgr := true;
  end;
  Result := FThreadMgr;
end;

procedure TIdTCPServer.InitializeCommandHandlers;
begin
end;

{ TIdListenerThread }

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

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

procedure TIdListenerThread.Run;
var
  LIOHandler: TIdIOHandler;
  LPeer: TIdTCPServerConnection;