psock.pas

DELPHI里面一些常用的控件

    property OnHostResolved: TOnHostResolved read FOnHostResolved write FOnHostResolved;
    property OnStatus: TOnStatus read FOnStatus write FOnStatus;
    property OnConnectionFailed: TNotifyEvent read FOnConnectionFailed write FOnConnectionFailed;
  end;

  {*******************************************************************************************
  PowerSocket Server Class definition
  ********************************************************************************************}
  PTNMGeneralServer = ^TNMGeneralServer;

  TNMGeneralServer = class(TPowersock)
  private
    ATlist: TThreadList;
    FOnClientContact: TNotifyEvent;
    procedure DisPatchResponse(data: Pointer);
  protected
    Chief: TNMGeneralServer;
  public
    ItsThread: TThread;
    constructor Create(AOwner: TComponent); override;
    procedure Connect; override;
    procedure Loaded; override;
    procedure Serve; virtual;
    procedure Abort; override;
    destructor Destroy; override;
    procedure ServerAccept(Sender: TObject);
  published
    property OnClientContact: TNotifyEvent read FOnClientContact write FOnClientContact;
  end;

  {*******************************************************************************************
  Thread to Serve Client in Server Class definition
  ********************************************************************************************}
  TThreadMethod = procedure(data: Pointer) of object;
  TSimpleThread = class(TThread)
  public
    constructor CreateSimple(CreateSuspended: Boolean;
      _Action: TThreadMethod;
      _Data: Pointer);
    procedure AbortThread;
  protected
    ThreadMethod: TThreadMethod;
    data: Pointer;

  private
    procedure Execute; override;
  end;

function ExecuteInThread(Handler: TThreadMethod; data: Pointer): TSimpleThread;

{For Documentation of functions and procedures see implementation}
function NthWord(InputString: string; Delimiter: Char; Number: Integer): string;
function NthPos(InputString: string; Delimiter: Char; Number: Integer): Integer;
procedure StreamLn(AStream: TStream; AString: string);
function PsockAllocateHWnd(Obj: TObject): HWND;
function TmrAllocateHWnd(Obj: TObject): HWND;

implementation
uses
  Shellapi;

var
  SockAvailable: Boolean;
  MyWSAData: TWSAData; {Socket Information}

constructor TSimpleThread.CreateSimple(CreateSuspended: Boolean;
  _Action: TThreadMethod;
  _Data: Pointer);
begin
  ThreadMethod := _Action; // Set these BEFORE calling
  data := _Data; // inherited Create()!
  FreeOnTerminate := True;
  inherited Create(CreateSuspended);
end;

procedure TSimpleThread.Execute;
begin
  ThreadMethod(data);
end;

procedure TSimpleThread.AbortThread;
begin
  Suspend;
  Free; // Kills thread
end;

function ExecuteInThread(Handler: TThreadMethod;
  data: Pointer): TSimpleThread;
begin
  Result := TSimpleThread.CreateSimple(False, Handler, data);
end;

procedure WaitforSync(Handle: THandle);
begin
  repeat
    if MsgWaitForMultipleObjects(1, Handle, False, INFINITE, QS_ALLINPUT) = WAIT_OBJECT_0 + 1 then
      Application.ProcessMessages
    else
      Break;
  until True = False;
end;

{*******************************************************************************************
Create Power Socket
********************************************************************************************}

constructor TPowersock.Create(AOwner: TComponent);
begin
  StatusMessage(Status_Debug, sPSk_Cons_msg_create); {Inform Status}
  inherited Create(AOwner);

{$IFDEF DEMOVER}
  if not (csDesigning in ComponentState) then
    ShowMessage('This uses the Demo Version of the Netmasters Componnents. Please Register');
{$ENDIF}

  FSocketWindow := PsockAllocateHWnd(self); {Create Window handle to receive message notification}
  WaitSignal := TEvent.Create(nil, True, False, '');

  if not (csDesigning in ComponentState) then
    FifoQ := TNMFifoBuffer.Create;

  FProxy := ''; {Default - No Proxy}

  {Initialize memory }
  GetMem(RemoteHost, MAXGETHOSTSTRUCT); {Initialize memory for host address structure}

  Timer := TThreadTimer.Create(self); {Create timer}
  Timer.Enabled := False; {Timer Disabled}
  Timer.OnTimer := TimerFired; {Set Function to execcute on TimeOut}
  FTimeOut := 0;

  FWSAInfo := TStringList.Create;

  if SockAvailable then
  begin
    FWSAInfo.Add(sPSk_Cons_winfo_ver + IntToStr(HiByte(MyWSAData.wVersion)) + '.' + IntToStr(LoByte(MyWSAData.wVersion)));
    FWSAInfo.Add(sPSk_Cons_winfo_Hiver + IntToStr(HiByte(MyWSAData.wHighVersion)) + '.' + IntToStr(LoByte(MyWSAData.wHighVersion)));
    FWSAInfo.Add(sPSk_Cons_winfo_Descr + MyWSAData.szDescription);
    FWSAInfo.Add(sPSk_Cons_winfo_Sys + MyWSAData.szSystemStatus);
    FWSAInfo.Add(sPSk_Cons_winfo_MaxSoc + IntToStr(MyWSAData.iMaxSockets));
    FWSAInfo.Add(sPSk_Cons_winfo_MaxUdp + IntToStr(MyWSAData.iMaxUdpDg));
  end;

  Canceled := False; {Cancelled flag off}
  DestroySocket := False; {Socket is active}
  FConnected := False; {Socket is not connected}

  {Call Initialization functions }
  InitWinsock;
  {Turn on Messaging.... }
end;

{*******************************************************************************************
Destroy Power Socket
********************************************************************************************}

destructor TPowersock.Destroy;
begin
  StatusMessage(Status_Debug, sPSk_Cons_msg_Dest); {Inform Status}
  try
    Abort;
    Cancel;
    FWSAInfo.Free;
    Timer.Free;
    FreeMem(RemoteHost, MAXGETHOSTSTRUCT); {Free memory for fetching Host Entity}
    DestroyWindow(FSocketWindow); {Release window handle for Winsock messages}
    WaitSignal.Destroy;
    FifoQ.Free;
    DestroySocket := True; {set flag to destoy socket}
    if not (csDesigning in ComponentState) then
      RequestCloseSocket; {close socket}
  finally
    inherited Destroy;
  end
end;

{*******************************************************************************************
Connect Power Socket to Remote
********************************************************************************************}

procedure TPowersock.Connect;
var
  CT, I: Integer;
  Handled: Boolean;
begin
  StatusMessage(Status_Debug, sPSk_Cons_msg_Conning); {Inform Status}
  Canceled := False; {Turn Canceled off}
  FifoQ.Clear;
  if FConnected then {If already connected raise exception}
    raise ESockError.Create(sPSk_Cons_msg_Conn);
  CT := 0;
  repeat
    try
      ResolveRemoteHost; {Resolve the IP address of remote host}
    except
      on E: ESockError do
        if (E.message = sPSk_Cons_msg_host_to) or (E.message = sPSk_Cons_msg_host_Can) then
          raise;
    end;

    if RemoteAddress.sin_addr.S_addr = 0 then
      if CT > 0 then
        raise ESockError.Create(sPSk_Cons_msg_add_null) {If Resolving failed raise exception}
      else if not Assigned(OnInvalidHost) then
        raise ESockError.Create(sPSk_Cons_msg_add_null)
      else
      begin
        Handled := False;
        OnInvalidHost(Handled);
        if not Handled then
          raise ESockError.Create(sPSk_Cons_msg_add_null);
        CT := CT + 1;
      end;
  until RemoteAddress.sin_addr.S_addr <> 0;
  RemoteAddress.sin_family := AF_INET; {Make connected true}

{$R-}
  if Proxy = '' then
    RemoteAddress.sin_port := htons(PORT) {If no proxy get port from Port property}
  else
    RemoteAddress.sin_port := htons(FProxyPort); {else get port from ProxyPort property}
{$R+}

  Wait_Flag := False; { Wait for synchronous response}
  I := SizeOf(RemoteAddress); { get size of remoteaddress structure}

  {Connect to remote host}
  Succeed := True;
  I := Winsock.Connect(ThisSocket, RemoteAddress, I);
  if (I = INVALID_SOCKET) then
    ErrorManager(WSAEWOULDBLOCK); {If error handle error}

  TimerOn; {Enable Timer on for TimeOuts}
  try
    while not (FConnected or TimedOut or Canceled or (not Succeed)) do
      Wait;
  finally
    TimerOff; {Disable Timer}
  end;

  CloseAfterData;
  if (TimedOut or Canceled or not Succeed) then
  begin
    if Assigned(FOnConnectionFailed) then
      FOnConnectionFailed(self);

    if TimedOut then
    begin
      try
        Disconnect;
      except
      end;
      raise ESockError.Create(Cons_Msg_ConnectionTimedOut);
    end;
    if Canceled then
      raise ESockError.Create(sPSk_Cons_msg_Conn_can);
    if Succeed = False then
      raise ESockError.Create(sPSk_Cons_msg_Conn_fai);
  end;
end;

{*******************************************************************************************
DisConnect Socket From Remote
********************************************************************************************}

procedure TPowersock.Disconnect;
begin
  StatusMessage(Status_Debug, sPSk_Cons_msg_Disconn); {Status Message}
  if FConnected then
    RequestCloseSocket; {Close socket and open new one}
end;

procedure TPowersock.Wait;
begin
  WaitforSync(WaitSignal.Handle);
  WaitSignal.ResetEvent;
end;

procedure TPowersock.CertifyConnect;
var
  TryCt: Integer;
  Handled: Boolean;
begin
  StatusMessage(Status_Debug, sPSk_Cons_msg_CertConn); {Status Message}
  TryCt := 0;
  while not Connected do
  begin
    if TryCt > 0 then
      raise Exception.Create(sPSk_Cons_err_NotConn)
    else if not Assigned(FOnConnectionRequired) then
      raise Exception.Create(sPSk_Cons_err_NotConn)
    else
    begin
      Handled := False;
      FOnConnectionRequired(Handled);
      if not Handled then
        raise Exception.Create(sPSk_Cons_err_NotConn);
      TryCt := TryCt + 1;
    end;
  end;
end;

{*******************************************************************************************
Canel current transaction
********************************************************************************************}

procedure TPowersock.Cancel;
begin
  StatusMessage(Status_Debug, sPSk_Cons_msg_Cancel); {Status Message}
  Canceled := True;
  WaitSignal.SetEvent;
end;

{*******************************************************************************************
Send at value of length buflen
********************************************************************************************}

procedure TPowersock.SendBuffer(Value: PChar; BufLen: Word);
var
  rc2, LeftB: Integer;
begin
  StatusMessage(Status_Routines, sPSk_Cons_msg_SBuff); {Status Message}
  TimerOn;
  try
    if not Canceled then
    begin
        {If explicit buffer length given use it else get it from string length}
      if BufLen = 0 then
        BufLen := StrLen(Value);
      LeftB := BufLen;
      repeat
        rc2 := Winsock.send(ThisSocket, Value[BufLen - LeftB], LeftB, 0);
        if rc2 = 0 then
          Break;

        if rc2 > -1 then
        begin
          LeftB := LeftB - rc2;
        end
        else
          ErrorManager(WSAEWOULDBLOCK);
      until (LeftB = 0) or Canceled or TimedOut;
    end;

    if Canceled then
    begin
      Canceled := False;
      raise EAbortError.Create(sPSk_Cons_msg_send_a);
      if Assigned(OnAbortrestart) then
        OnAbortrestart(self);
    end;
  finally
    TimerOff;
  end;
end;

{*******************************************************************************************
Write String To Socket
********************************************************************************************}

procedure TPowersock.Write(Value: string);
var
  MyStringStream: TStringStream;
begin
  StatusMessage(Status_Debug, sPSk_Cons_msg_write); {Report Status}
  if Length(Value) > MAX_RECV_BUF then
  begin
    MyStringStream := TStringStream.Create(Value);
    try
      SendStream(MyStringStream);
    finally
      MyStringStream.Free;
    end;
  end
  else
  begin
    StrPLCopy(Buf, Value, MAX_RECV_BUF); {Copy string to buffer}
    SendBuffer(Buf, 0); {Send the buffer}
  end;
end;

{*******************************************************************************************
Write Line ending with Carriage Return and Line Feed To Socket
********************************************************************************************}

procedure TPowersock.Writeln(Value: string);
begin
  StatusMessage(Status_Debug, sPSk_Cons_msg_writeln); {Inform Status}
  Value := Value + CRLF;
  Write(Value);
end;

{*******************************************************************************************
Read Given Number of bytes from Socket
********************************************************************************************}

function TPowersock.Read(Value: Word): string;
begin
  StatusMessage(Status_Debug, sPSk_Cons_msg_read + IntToStr(Value) + ' )'); {Inform status}
  if Value = 0 then
    Value := FifoQ.BufferSize;
  TimerOn;
  while (FifoQ.BufferSize < Value) and (not Canceled) and (not TimedOut) do
    Wait;
  TimerOff;
  if Value = 0 then
    Result := ''
  else
  begin
    SetLength(Result, Value);