dm5314_usimpletcp.pas

DarkMoon v4.11 (远程控制) 国外收集的代码,控件下载: http://www.winio.cn/Blogs/jishuwenzhang/200712/20071208230135.

{*************************************************************}
{            SimpleTCP components for Delphi and C++ Builder  }
{ Version:   2.0                                              }
{ E-Mail:    [e-mail]                                }
{ WWW:       http://www.utilmind.com                          }
{ Created:   July 8, 2000                                     }
{ Modified:  January 17, 2002                                 }
{ Legal:     Copyright (c) 2000-2002, UtilMind Solutions      }
{*************************************************************}
{ SimpleTCP is pack of two components (TSimpleTCPServer and   }
{ TSimpleTCPClient) for working with Asynchronous TCP sockets.}
{*************************************************************}
{ Please see demo program for more information.               }
{*************************************************************}
{                     IMPORTANT NOTE:                         }
{ This software is provided 'as-is', without any express or   }
{ implied warranty. In no event will the author be held       }
{ liable for any damages arising from the use of this         }
{ software.                                                   }
{ Permission is granted to anyone to use this software for    }
{ any purpose, including commercial applications, and to      }
{ alter it and redistribute it freely, subject to the         }
{ following restrictions:                                     }
{ 1. The origin of this software must not be misrepresented,  }
{    you must not claim that you wrote the original software. }
{    If you use this software in a product, an acknowledgment }
{    in the product documentation would be appreciated but is }
{    not required.                                            }
{ 2. Altered source versions must be plainly marked as such,  }
{    and must not be misrepresented as being the original     }
{    software.                                                }
{ 3. This notice may not be removed or altered from any       }
{    source distribution.                                     }
{*************************************************************}
{$IFNDEF VER80}          {Delphi 1}
 {$IFNDEF VER90}         {Delphi 2}
  {$IFNDEF VER93}        {BCB 1}
   {$DEFINE D3}          {* Delphi 3 or higher}
   {$IFNDEF VER100}      {Delphi 3}
    {$IFNDEF VER110}     {BCB 3}
     {$DEFINE D4}        {* Delphi 4 or higher}
    {$ENDIF}
   {$ENDIF}
  {$ENDIF}
 {$ENDIF}
{$ENDIF}

unit DM5314_USimpleTCP;

interface

uses
  Windows, Messages, Classes, WinSock;

const
  UM_TCPASYNCSELECT = WM_USER + $0001;

type
  TSimpleTCPClient = class;

  TSimpleTCPAcceptEvent = procedure(Sender: TObject; Client: TSimpleTCPClient; var Accept: Boolean) of object;
  TSimpleTCPServerEvent = procedure(Sender: TObject; Client: TSimpleTCPClient) of object;
  TSimpleTCPServerDataAvailEvent = procedure(Sender: TObject; Client: TSimpleTCPClient; DataSize: Integer) of object;
  TSimpleTCPClientDataAvailEvent = procedure(Sender: TObject; DataSize: Integer) of object;
  TSimpleTCPServerIOEvent = procedure(Sender: TObject; Client: TSimpleTCPClient; Stream: TStream) of object;
  TSimpleTCPClientIOEvent = procedure(Sender: TObject; Stream: TStream) of object;
  TSimpleTCPErrorEvent = procedure(Sender: TObject; Socket: TSocket; ErrorCode: Integer; ErrorMsg: String) of object;

  TCustomSimpleSocket = class(TComponent)
  private
    FAllowChangeHostAndPortOnConnection: Boolean;
    FHost: String;
    FPort: Word;
    FSocket: TSocket;

    FOnError: TSimpleTCPErrorEvent;

    // For internal use
    FConnections: TList;

    SockAddrIn: TSockAddrIn;
    HostEnt: PHostEnt;
    WSAData: TWSAData;
    WindowHandle: hWnd;

    procedure WndProc(var Message: TMessage); virtual;
    procedure UMTCPSelect(var Msg: TMessage); message UM_TCPASYNCSELECT;

    function  SendBufferTo(Socket: TSocket; Buffer: PChar; BufLength: Integer): Integer; // returns N of bytes sent
    function  SendStreamTo(Socket: TSocket; Stream: TStream): Integer; // returns N of bytes sent
    function  ReceiveFrom(Socket: TSocket; Buffer: PChar; BufLength: Integer; ReceiveCompletely: Boolean): Integer; // returns N of bytes read
    function  ReceiveStreamFrom(Socket: TSocket; Stream: TStream; DataSize: Integer; ReceiveCompletely: Boolean): Integer; // returns N of bytes read
  protected
    procedure SocketError(Socket: TSocket; ErrorCode: Integer); virtual;

    procedure SetHost(Value: String); virtual; abstract;
    procedure SetPort(Value: Word); virtual; abstract;

    procedure DoAccept; virtual; abstract;
    procedure DoConnect; virtual; abstract;
    procedure DoClose(Socket: TSocket); virtual; abstract;
    procedure DoDataAvailable(Client: TSimpleTCPClient; DataSize: Integer; var Handled: Boolean); virtual; abstract;
    procedure DoRead(Client: TSimpleTCPClient; Stream: TStream); virtual; abstract;
  public
    constructor Create(aOwner: TComponent); override;
    destructor Destroy; override;

    property AllowChangeHostAndPortOnConnection: Boolean read FAllowChangeHostAndPortOnConnection write FAllowChangeHostAndPortOnConnection default False;
    property Host: String read FHost write SetHost;
    property Port: Word read FPort write SetPort default 0;
    property Socket: TSocket read FSocket write FSocket;

    property OnError: TSimpleTCPErrorEvent read FOnError write FOnError;
  end;

  { TSimpleTCPServer }
  TSimpleTCPServer = class(TCustomSimpleSocket)
  private
    FListen: Boolean;

    FOnAccept: TSimpleTCPAcceptEvent;
    FOnClientConnected: TSimpleTCPServerEvent;
    FOnClientDisconnected: TSimpleTCPServerEvent;
    FOnClientDataAvailable: TSimpleTCPServerDataAvailEvent;
    FOnClientRead: TSimpleTCPServerIOEvent;

    function GetLocalHostName: String;
    function GetLocalIP: String;
    procedure SetNoneStr(Value: String);
  protected
    procedure SocketError(Socket: TSocket; ErrorCode: Integer); override;

    procedure SetListen(Value: Boolean); virtual;
    procedure SetPort(Value: Word); override;

    procedure DoAccept; override;
    procedure DoClose(Socket: TSocket); override;
    procedure DoDataAvailable(Client: TSimpleTCPClient; DataSize: Integer; var Handled: Boolean); override;    
    procedure DoRead(Client: TSimpleTCPClient; Stream: TStream); override;
  public
    constructor Create(aOwner: TComponent); override;
    destructor Destroy; override;

    function  Send(Client: TSimpleTCPClient; Buffer: PChar; BufLength: Integer): Integer; // returns N of bytes sent
    function  SendStream(Client: TSimpleTCPClient; Stream: TStream): Integer; // returns N of bytes sent
    procedure Broadcast(Buffer: PChar; BufLength: Integer);
    procedure BroadcastStream(Stream: TStream);
    function  Receive(Client: TSimpleTCPClient; Buffer: PChar; BufLength: Integer; ReceiveCompletely: Boolean): Integer;
    function  ReceiveStream(Client: TSimpleTCPClient; Stream: TStream; DataSize: Integer; ReceiveCompletely: Boolean): Integer;

    property Connections: TList read FConnections;
  published
    property Listen: Boolean read FListen write SetListen stored False;
    property LocalHostName: String read GetLocalHostName write SetNoneStr stored False;
    property LocalIP: String read GetLocalIP write SetNoneStr stored False;    

    property OnAccept: TSimpleTCPAcceptEvent read FOnAccept write FOnAccept;
    property OnClientConnected: TSimpleTCPServerEvent read FOnClientConnected write FOnClientConnected;
    property OnClientDisconnected: TSimpleTCPServerEvent read FOnClientDisconnected write FOnClientDisconnected;
    property OnClientDataAvailable: TSimpleTCPServerDataAvailEvent read FOnClientDataAvailable write FOnClientDataAvailable;
    property OnClientRead: TSimpleTCPServerIOEvent read FOnClientRead write FOnClientRead;

    property AllowChangeHostAndPortOnConnection;
    property Port;
    property OnError;
  end;

  TSimpleTCPClient = class(TCustomSimpleSocket)
  private
    FAutoTryReconnect: Boolean;
    FConditionallyConnected, FConnected: Boolean;

    FOnConnected: TNotifyEvent;
    FOnDisconnected: TNotifyEvent;
    FOnDataAvailable: TSimpleTCPClientDataAvailEvent;
    FOnRead: TSimpleTCPClientIOEvent;

    function  GetIP: LongInt;
    procedure SetIP(Value: LongInt);
  protected
//    procedure WndProc(var Message: TMessage); override;
    procedure SocketError(Socket: TSocket; ErrorCode: Integer); override;

    procedure SetConnected(Value: Boolean); virtual;    
    procedure SetHost(Value: String); override;
    procedure SetPort(Value: Word); override;

    procedure DoConnect; override;
    procedure DoClose(Socket: TSocket); override;
    procedure DoDataAvailable(Client: TSimpleTCPClient; DataSize: Integer; var Handled: Boolean); override;    
    procedure DoRead(Client: TSimpleTCPClient; Stream: TStream); override;
  public
    destructor Destroy; override;

    function Send(Buffer: PChar; BufLength: Integer): Integer; // returns N of bytes sent
    function SendStream(Stream: TStream): Integer; // returns N of bytes sent
    function Receive(Buffer: PChar; BufLength: Integer; ReceiveCompletely: Boolean): Integer;
    function ReceiveStream(Stream: TStream; DataSize: Integer; ReceiveCompletely: Boolean): Integer;

    property IP: LongInt read GetIP write SetIP;
  published
    property AutoTryReconnect: Boolean read FAutoTryReconnect write FAutoTryReconnect default False;
    property Connected: Boolean read FConnected write SetConnected stored False;

    property OnConnected: TNotifyEvent read FOnConnected write FOnConnected;
    property OnDisconnected: TNotifyEvent read FOnDisconnected write FOnDisconnected;
    property OnDataAvailable: TSimpleTCPClientDataAvailEvent read FOnDataAvailable write FOnDataAvailable;
    property OnRead: TSimpleTCPClientIOEvent read FOnRead write FOnRead;

    property AllowChangeHostAndPortOnConnection;
    property Host;
    property Port;
    property OnError;
  end;

procedure Register;

implementation

uses SysUtils, Forms;

const
  PROTO_TCP = 'tcp';

{$IFNDEF D4}
type
  SunB = packed record
    s_b1, s_b2, s_b3, s_b4: Char;
  end;

  SunW = packed record
    s_w1, s_w2: Word;
  end;

  in_addr = record
    case Integer of
      0: (S_un_b: SunB);
      1: (S_un_w: SunW);
      2: (S_addr: LongInt);
  end;
{$ENDIF}

{ Internal utilities }
function IPToStr(IP: Integer): String;
var
  Addr: in_addr;
begin
  Addr.S_addr := IP;
  Result := IntToStr(Byte(Addr.S_un_b.s_b1)) + '.' +
            IntToStr(Byte(Addr.S_un_b.s_b2)) + '.' +
            IntToStr(Byte(Addr.S_un_b.s_b3)) + '.' +
            IntToStr(Byte(Addr.S_un_b.s_b4));
end;

function StrToIP(Host: String): LongInt;
begin
  Result := inet_addr(PChar(Host))  
end;


{ TCustomSimpleSocket }
constructor TCustomSimpleSocket.Create(aOwner: TComponent);
begin
  inherited Create(aOwner);

  FSocket := INVALID_SOCKET;
  WindowHandle := AllocateHWnd(WndProc);

  if WSAStartup($0101, WSAData) <> 0 then
    raise Exception.Create('Can not start socket session');
end;

destructor TCustomSimpleSocket.Destroy;
begin
  if WSACleanup <> 0 then
    raise Exception.Create('Can not clean socket session');

  DeallocateHWnd(WindowHandle);

  inherited Destroy;
end;

procedure TCustomSimpleSocket.WndProc(var Message: TMessage);
begin
  with Message do
   try
     if Msg = WM_QUERYENDSESSION then
       Result := 1 // Correct shutdown
     else
       Dispatch(Msg);
   except
     Application.HandleException(Self);
   end;
end;

procedure TCustomSimpleSocket.UMTCPSelect(var Msg: TMessage);
var
  tmpSocket: TSocket;
  tmpTCPClient: TSimpleTCPClient;
  SelectEvent, I: Integer;
  MS: TMemoryStream;

  Handled: Boolean;
  DataAvail: LongInt;
begin
  I := WSAGetSelectError(Msg.LParam);
  if I > WSABASEERR then
    SocketError(Msg.wParam, I)
  else
   begin
    SelectEvent := WSAGetSelectEvent(Msg.lParam);
    case SelectEvent of
      FD_READ: begin
                tmpSocket := Msg.wParam;

                { if this is the server }
                tmpTCPClient := nil;
                if Assigned(FConnections) then
                 begin
                  I := FConnections.Count;
                  if I <> 0 then
                   for I := 0 to I - 1 do
                    begin
                     tmpTCPClient := FConnections[I];
                     if tmpTCPClient.FSocket = tmpSocket then Break;
                    end;
                 end;

                MS := TMemoryStream.Create;
                with MS do
                 try
                   while True do
                    begin