clsocket.pas

Clever_Internet_Suite_6.2的代码 Clever_Internet_Suite_6.2的代码 Clever_Internet_Suite_6.2的代码

{
  Clever Internet Suite Version 6.2
  Copyright (C) 1999 - 2006 Clever Components
  www.CleverComponents.com
}

unit clSocket;

interface

{$I clVer.inc}
{$IFDEF DELPHI7}
  {$WARN UNSAFE_CODE OFF}
  {$WARN UNSAFE_TYPE OFF}
  {$WARN UNSAFE_CAST OFF}
{$ENDIF}

uses
  Classes, SysUtils, Windows, WinSock, Messages, clWinSock2;

type
  TclSocketProgress64Event = procedure(Sender: TObject; ABytesProceed, ATotalBytes: Int64) of object;
  TclSocketProgressEvent = procedure(Sender: TObject; ABytesProceed, ATotalBytes: Integer) of object;

  EclSocketError = class(Exception)
  private
    FErrorCode: Integer;
  public
    constructor Create(const AErrorMsg: string; AErrorCode: Integer);
    property ErrorCode: Integer read FErrorCode;
  end;

  TclNetworkStreamAction = (saNone, saRead, saWrite);
  
  TclConnection = class;

  TclNetworkStream = class
  private
    FConnection: TclConnection;
    FSleepEvent: THandle;
    FNextAction: TclNetworkStreamAction;
    FListenPort: Integer;
    FPeerName: string;
    FPeerIP: string;
    FHasReadData: Boolean;
    FPort: Integer;
    FIP: string;
    FNeedClose: Boolean;
    procedure DoSleep(AMilliseconds: Integer);
    function DoRecv(s: TSocket; var Buf; len, flags: Integer): Integer;
    function DoSend(s: TSocket; var Buf; len, flags: Integer): Integer;
    function GetConnection: TclConnection;
    function NeedStop: Boolean;
  protected
    procedure UpdateProgress(ABytesProceed: Int64); virtual;
    procedure StreamReady; virtual;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Assign(ASource: TclNetworkStream); virtual;
    function Connect(const AIP: string; APort: Integer): Boolean; virtual;
    procedure Listen(APort: Integer); virtual;
    procedure Accept; virtual;
    procedure Close(ANotifyPeer: Boolean); virtual;
    function Read(AData: TStream): Boolean; virtual;
    function Write(AData: TStream): Boolean; virtual;
    function GetBatchSize: Integer; virtual;
    procedure OpenClientSession; virtual;
    procedure OpenServerSession; virtual;
    procedure ClearNextAction;
    procedure SetNextAction(Action: TclNetworkStreamAction);
    property Connection: TclConnection read GetConnection;
    property NextAction: TclNetworkStreamAction read FNextAction;
    property HasReadData: Boolean read FHasReadData write FHasReadData;
    property ListenPort: Integer read FListenPort;
    property PeerName: string read FPeerName;
    property PeerIP: string read FPeerIP;
    property IP: string read FIP;
    property Port: Integer read FPort;
    property NeedClose: Boolean read FNeedClose;
  end;
  
  TclConnection = class
  private
    FSocket: TSocket;
    FBatchSize: Integer;
    FIsAborted: Boolean;
    FNetworkStream: TclNetworkStream;
    FActive: Boolean;
    FBitsPerSec: Integer;
    FTotalBytesProceed: Int64;
    FBytesProceed: Int64;
    FTotalBytes: Int64;
    FBytesToProceed: Int64;
    FOnProgress: TclSocketProgress64Event;
    FOnReady: TNotifyEvent;
    function GetNetworkStream: TclNetworkStream;
    procedure SetNetworkStream(const Value: TclNetworkStream);
    procedure ShutdownSocket;
  protected
    function IsProceedLimit: Boolean;
    procedure DoDestroy; virtual;
    procedure DoProgress(ABytesProceed, ATotalBytes: Int64); virtual;
    procedure DoReady; virtual;
  public
    constructor Create;
    destructor Destroy; override;
    procedure DispatchNextAction; virtual; abstract;
    procedure InitProgress(ABytesProceed, ATotalBytes: Int64);
    procedure ReadData(AData: TStream); virtual; abstract;
    procedure WriteData(AData: TStream); virtual; abstract;
    procedure Close(ANotifyPeer: Boolean);
    procedure CloseSession(ANotifyPeer: Boolean);
    procedure Abort;
    property NetworkStream: TclNetworkStream read GetNetworkStream write SetNetworkStream;
    property IsAborted: Boolean read FIsAborted;
    property Active: Boolean read FActive;
    property BytesProceed: Int64 read FTotalBytesProceed;
    property Socket: TSocket read FSocket write FSocket;
    property BatchSize: Integer read FBatchSize write FBatchSize;
    property BitsPerSec: Integer read FBitsPerSec write FBitsPerSec;
    property BytesToProceed: Int64 read FBytesToProceed write FBytesToProceed;
    property OnProgress: TclSocketProgress64Event read FOnProgress write FOnProgress;
    property OnReady: TNotifyEvent read FOnReady write FOnReady;
  end;

  TclAsyncConnection = class(TclConnection)
  private
    FRefCount: Integer;
    function GetPeerIP: string;
    function GetPeerName: string;
  public
    constructor Create;
    procedure DispatchNextAction; override;
    procedure ReadData(AData: TStream); override;
    procedure WriteData(AData: TStream); override;
    procedure AcceptConnection;
    procedure AcceptConnectionDone;
    procedure OpenSession;
    function _AddRef: Integer;
    function _Release: Integer;
    property PeerName: string read GetPeerName;
    property PeerIP: string read GetPeerIP;
  end;

  TclSyncConnection = class(TclConnection)
  private
    FTimeOut: Integer;
    FSocketEvent: THandle;
    FIsReadUntilClose: Boolean;
    FTimeOutTicks: DWORD;
    procedure InitTimeOutTicks;
    procedure InternalReadData(AData: TStream);
    procedure InternalWriteData(AData: TStream);
  protected
    procedure CreateSocket(AStruct, AProtocol: Integer);
    procedure SelectSocketEvent(lNetworkEvents: DWORD);
    procedure DoDestroy; override;
  public
    constructor Create;
    procedure DispatchNextAction; override;
    procedure ReadData(AData: TStream); override;
    procedure WriteData(AData: TStream); override;
    procedure WriteString(const AString: string);
    property TimeOut: Integer read FTimeOut write FTimeOut;
    property SocketEvent: THandle read FSocketEvent;
    property IsReadUntilClose: Boolean read FIsReadUntilClose write FIsReadUntilClose;
  end;

  TclUdpClientConnection = class(TclSyncConnection)
  private
    function GetIP: string;
    function GetPort: Integer;
  public
    procedure Open(const AIP: string; APort: Integer);
    property IP: string read GetIP;
    property Port: Integer read GetPort;
  end;

  TclTcpClientConnection = class(TclSyncConnection)
  private
    function GetIP: string;
    function GetPort: Integer;
  public
    procedure Open(const AIP: string; APort: Integer);
    procedure OpenSession;
    property IP: string read GetIP;
    property Port: Integer read GetPort;
  end;

  TclTcpServerConnection = class(TclSyncConnection)
  public
    function Open(APort: Integer): Integer;
    procedure AcceptConnection;
    procedure OpenSession;
  end;

  TclHostIPResolver = class
  private
    FAsyncError: Integer;
    FLookupHandle: THandle;
    FCompleted: THandle;
    FIsAborted: Boolean;
    function GetHostEntry(const AHostName: string; ATimeOut: Integer): PHostEnt;
    procedure WndProc(var Message: TMessage);
    procedure DestroyWindowHandle(AWndHandle: HWND);
  public
    function GetHostIP(const AHostName: string; ATimeOut: Integer): string;
    procedure Abort;
  end;
  
function GetLocalHost: string;
function GetHostIP(const AHostName: string; ATimeOut: Integer = 5000): string;
function GetWSAErrorText(AErrorCode: Integer): string;
procedure RaiseSocketError(AErrorCode: Integer); overload;
procedure RaiseSocketError(const AErrorMessage: string; AErrorCode: Integer); overload;

resourcestring
  cInvalidAddress = 'Invalid host address';
  cInvalidPort = 'Invalid port number';
  cTimeoutOccured = 'Timeout error occured';
  cBatchSizeInvalid = 'Invalid Batch Size';
  cNoNetworkStream = 'NetworkStream is required';

implementation

uses
  clUtils{$IFNDEF DELPHI6}, Forms{$ENDIF}{$IFDEF LOGGER}, clLogger{$ENDIF};

const
  CL_SOCKETEVENT = WM_USER + 2110;

function WaitForEvent(AEvent: THandle; ATimeOutTicks, ATimeOut: Integer): Boolean;
var
  res: DWORD;
  Msg: TMsg;
  events: array[0..0] of THandle;
begin
  events[0] := AEvent;
  res := MsgWaitForMultipleObjects(1, events, FALSE, DWORD(ATimeOut), QS_ALLEVENTS);
  case res of
    WAIT_FAILED:
      begin
        RaiseSocketError(WSAGetLastError());
      end;
    WAIT_TIMEOUT:
      begin
        RaiseSocketError(cTimeoutOccured, -1);
      end;
    WAIT_OBJECT_0 + 1:
      begin
        while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do
        begin
          TranslateMessage(Msg);
          DispatchMessage(Msg);
          if Integer(GetTickCount()) - ATimeOutTicks > ATimeOut then
          begin
            RaiseSocketError(cTimeoutOccured, -1);
          end;
        end;
        if Integer(GetTickCount()) - ATimeOutTicks > ATimeOut then
        begin
          RaiseSocketError(cTimeoutOccured, -1);
        end;
      end;
  end;
  Result := (res = WAIT_OBJECT_0);
end;

type
  TclLookupComplete = record
    Msg: Cardinal;
    LookupHandle: THandle;
    AsyncBufLen: Word;
    AsyncError: Word;
    Result: Longint;
  end;

{ TclHostIPResolver }

procedure TclHostIPResolver.WndProc(var Message: TMessage);
begin
  if (Message.Msg = CL_SOCKETEVENT)
    and (TclLookupComplete(Message).LookupHandle = FLookupHandle) then
  begin
    FAsyncError := TclLookupComplete(Message).AsyncError;
    SetEvent(FCompleted);
  end;
end;

procedure TclHostIPResolver.DestroyWindowHandle(AWndHandle: HWND);
var
  lpMsg: TMsg;
begin
  while PeekMessage(lpMsg, AWndHandle, 0, 0, PM_REMOVE) do;
  DeallocateHWnd(AWndHandle);
end;

function TclHostIPResolver.GetHostEntry(const AHostName: string; ATimeOut: Integer): PHostEnt;
var
  wndHandle: HWND;
  hostData: PChar;
begin
  Result := AllocMem(MAXGETHOSTSTRUCT);
  try
    FCompleted := CreateEvent(nil, False, False, nil);
    wndHandle := AllocateHWnd(WndProc);
    try
      FAsyncError := 0;
      hostData := PChar(Result);
      FLookupHandle := WSAAsyncGetHostByName(wndHandle, CL_SOCKETEVENT, PChar(AHostName), hostData, MAXGETHOSTSTRUCT);
      if (FLookupHandle = 0) then
      begin
        RaiseSocketError(WSAGetLastError());
      end;

      FIsAborted := False;
      repeat
        try
          if WaitForEvent(FCompleted, GetTickCount(), ATimeOut) then Break;
        except
          WSACancelAsyncRequest(FLookupHandle);
          FLookupHandle := 0;
          raise;
        end;
      until FIsAborted;
      FLookupHandle := 0;

      if (FAsyncError <> 0) then
      begin
        RaiseSocketError(FAsyncError);
      end;
    finally
      DestroyWindowHandle(wndHandle);
      CloseHandle(FCompleted);
    end;
  except
    FreeMem(Result);
    raise;
  end;
end;

function TclHostIPResolver.GetHostIP(const AHostName: string; ATimeOut: Integer): string;
var
  hostEnt: PHostEnt;
  addrList: PChar;
begin
  hostEnt := GetHostEntry(AHostName, ATimeOut);
  try
    addrList := hostEnt^.h_addr_list^;
    Result := Format('%d.%d.%d.%d',
      [Ord(addrList[0]), Ord(addrList[1]), Ord(addrList[2]), Ord(addrList[3])]);
  finally
    FreeMem(hostEnt);
  end;
end;

function GetLocalHost: string;
var
  LocalName: array[0..255] of Char;
begin
  Result := '';
  if gethostname(LocalName, SizeOf(LocalName)) = 0 then
    Result := LocalName;
end;

function GetHostIP(const AHostName: string; ATimeOut: Integer): string;
var
  resolver: TclHostIPResolver;
begin
  resolver := TclHostIPResolver.Create();
  try
    Result := resolver.GetHostIP(AHostName, ATimeOut);
  finally
    resolver.Free();
  end;
end;

function GetWSAErrorText(AErrorCode: Integer): string;
var
  Buffer: array[0..255] of Char;
begin
  FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, nil, AErrorCode, 0, Buffer, SizeOf(Buffer), nil);
  Result := Trim(Buffer);
end;

procedure RaiseSocketError(AErrorCode: Integer);
begin
  raise EclSocketError.Create(GetWSAErrorText(AErrorCode), AErrorCode);
end;

procedure RaiseSocketError(const AErrorMessage: string; AErrorCode: Integer);
begin
  raise EclSocketError.Create(AErrorMessage, AErrorCode);
end;

procedure TclHostIPResolver.Abort;
begin
  FIsAborted := True;
  if (FLookupHandle <> 0) then
  begin
    WSACancelAsyncRequest(FLookupHandle);
  end;
end;

{ TclConnection }

constructor TclConnection.Create;
begin
  inherited Create();
  FSocket := INVALID_SOCKET;
  FBatchSize := 8192;
  FBytesToProceed := -1;
end;

destructor TclConnection.Destroy;
begin
  try
    Close(False);
  except
    on EclSocketError do ;
  end;
  DoDestroy();
  inherited Destroy();
end;

procedure TclConnection.ShutdownSocket;
begin
  FActive := False;
  if (FSocket <> INVALID_SOCKET) then
  begin
    shutdown(FSocket, SD_BOTH);
    closesocket(FSocket);
    FSocket := INVALID_SOCKET;
  end;
end;

procedure TclConnection.CloseSession(ANotifyPeer: Boolean);
begin
  NetworkStream.Close(ANotifyPeer);
  if ANotifyPeer then
  begin
    DispatchNextAction();
  end;
end;

procedure TclConnection.Close(ANotifyPeer: Boolean);
begin
{$IFDEF LOGGER}clPutLogMessage(Self, edInside, 'Close');{$ENDIF}
  try
    if Active then
    begin
      CloseSession(ANotifyPeer);
    end;
  finally
    ShutdownSocket();
  end;
end;

procedure TclConnection.Abort;
begin
  FIsAborted := True;
end;

procedure TclConnection.DoDestroy;
begin
  NetworkStream := nil;
end;

procedure TclConnection.DoProgress(ABytesProceed, ATotalBytes: Int64);
begin
  if Assigned(OnProgress) then
  begin