sock.pas

为Delphi2005做了改动 DSPack 2.3.3 (Sep 2004). DSPack is a set of Components and class to write Multimedia

unit Sock;

// *****************************************************************************
// Sock.Pas (TSock)
// Freeware Windows Socket Component For Delphi & C++ Builder
// Version 1.0k, tested with Delphi 2.0, 3.0 & 4.0
// Written By Tom Bradford
// Maintained By Ward van Wanrooij
//   ([e-mail], http://www.ward.nu)
//
// Copyright (C) 1997-2000, Beach Dog Software, Inc.
// Copyright (C) 2000-2003, Ward van Wanrooij
// All Rights Reserved
// Latest version can be obtained at http://www.ward.nu/computer/tsock
// *****************************************************************************

interface

uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  WinSock, BaseClass;

type
  TSocketInfo = (siLookUp, siConnect, siClose, siListen, siReceive, siSend,
    siAccept, siError);
  TSocketType = (stStream, stDatagram);
  TLineBreak = (lbCRLF, lbCR, lbLF, lbSmart);

const
  WM_SOCK = WM_USER + 75; // Hopefully, Your App Won't Use This Message

type
  TSock = class; // Forward Declared For Event Types

  ESockException = class(Exception);
  TNotifyReadEvent = procedure(Sender: TObject; Count: Integer) of object;
  TNotifyAutoEvent = procedure(Sender: TObject; NewSock: TSock) of object;
  TNotifyInfoEvent = procedure(sender: TObject; SocketInfo: TSocketInfo; Msg:
    string) of object;

  TSock = class(TCustomControl)
  private
    FSockAddrIn: TSockAddrIn; // Address Information Block
    FRecvAddrIn: TSockAddrIn; // Address Information Block For RecvFrom
    FLastChar: Char; // Last Character Read For Line-Input

    FPicture: TBitmap; // Holder For Design-Time Image
    FBmp_TCP: TBitmap; // TCP Bitmap
    FBmp_UDP: TBitmap; // UDP Bitmap
    FBmp_Listen: TBitmap; // Listening Bitmap

    // Character Buffer (Most WINSOCK.DLLs Max At 32k)
    //  FCharBuf    : Array[1..32768] Of Char;
    FCharBuf: array[1..750] of Char; // small buffer works more stable
    FSocketType: TSocketType; // Socket Type (Stream Or Datagram)
    FLineBreak: TLineBreak; // Line Break Style For Line Input
    FHostName: string; // Host Name Or IP Address
    FPortName: string; // Port Name Or Well-Known Number
    FLocalPortName: string;
      // Local Port Name Or Well-Known Number, Defaults To 1 (=FPortName) For Backward Compatibility
    FSocket: TSocket; // Socket Handle
    FInBuffer: string; // Input Buffer
    FOutBuffer: string; // Output Buffer For Non-Blocking
    FListen: Boolean; // Socket Listens?
    FBlocking: Boolean; // Do Blocking Calls?
    FAutoAccept: Boolean; // Automatically Accept Incomings
    FConnected: Boolean; // Are We Connected?
    FBlockTime: Integer; // How Long To Wait For Blocking Operation
    FStream: TStream; // Associated TSockStream Object
    FFreeOnClose: Boolean;
      // Free after closure of socket? (Non-blocking, auto-accepted sockets!)

    FOnConnect: TNotifyEvent;
    FOnDisconnect: TNotifyEvent;
    FOnInfo: TNotifyInfoEvent;
    FOnRead: TNotifyReadEvent;
    FOnWrite: TNotifyEvent;
    FOnAccept: TNotifyEvent;
    FOnAutoAccept: TNotifyAutoEvent;

    m_receiveForm: TForm;
    m_lock: TBCCritSec;

    // Property Set/Get Routines
    procedure SetHostName(Value: string);
    procedure SetPortName(Value: string);
    procedure SetLocalPortName(Value: string);
    function GetText: string;
    procedure SetText(Value: string);
    procedure SetListen(Value: Boolean);
    procedure SetBlocking(Value: Boolean);
    procedure SetAutoAccept(Value: Boolean);
    procedure SetConnected(Value: Boolean);
    function GetConnected: Boolean;
    procedure SetSocket(Value: TSocket);
    procedure SetSocketType(Value: TSocketType);
    function GetRemoteHost: string;
    function GetEOF: Boolean;

    // Private Support Methods
    procedure DoInfo(SocketInfo: TSocketInfo; Msg: string);
    procedure SetBitmap;
  protected
    // Event Handlers
    procedure WMSock(var Message: TMessage); message WM_SOCK;
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;

    // Loaded Handles Starting Listening Mode After Streaming The Properties
    procedure Loaded; override;

    // Protected Constructor Can Only Be Called By TSock Class
    constructor CreateWithSocket(AOwner: TComponent; NewSocket: TSocket);
      virtual;

  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    function Open: Boolean;
    function Close: Boolean;
    function Send(Value: string): Boolean;
    function SendLine(Value: string): Boolean;
    function ReceiveCount(Count: Integer): string;
    function Receive: string;
    function ReceiveLine: string;
    function SendDatagram(Value, HostName: string): Boolean;
    function ReceiveDatagram(var HostName: string): string;

    // The Accept Method Will Create NewSock, But User Must Free
    function Accept(var NewSock: TSock): Boolean;

    // Public Support Methods
    function HostLookup(Value: string): TInAddr;
    function PortLookup(Value: string): U_Short;

    // StartListen And StopListen Are A Robust Form Of Setting Listen
    function StartListen: Boolean;
    function StopListen: Boolean;

    property Text: string read GetText write SetText;
    property Connected: Boolean read GetConnected write SetConnected;
      // Used To Read FConnected

    property EndOfFile: Boolean read GetEOF;
    property Socket: TSocket read FSocket write SetSocket;

    property Stream: TStream read FStream;

    // RemoteHost Returns The Remote IP If SocketType=stStream
    // And Will Return The Most Recent Incoming Datagram IP If
    // SocketType=stDatagram
    property RemoteHost: string read GetRemoteHost;
    // RemoteHost = INet_NToA(RecvAddrIn.SIn_Addr); Provided as property for easy-of-use and backward compatibility
    property RecvAddrIn: TSockAddrIn read FRecvAddrIn;

  published
    property SocketType: TSocketType read FSocketType write SetSocketType;
    property HostName: string read FHostName write SetHostName;
    property PortName: string read FPortName write SetPortName;
    property LocalPortName: string read FLocalPortName write SetLocalPortName;
    property Blocking: Boolean read FBlocking write SetBlocking;
    property AutoAccept: Boolean read FAutoAccept write SetAutoAccept;
    property Listen: Boolean read FListen write SetListen;
    property LineBreak: TLineBreak read FLineBreak write FLineBreak;
    property BlockingTimeout: Integer read FBlockTime write FBlockTime;

    property OnConnect: TNotifyEvent read FOnConnect write FOnConnect;
    property OnDisconnect: TNotifyEvent read FOnDisconnect write FOnDisconnect;
    property OnInfo: TNotifyInfoEvent read FOnInfo write FOnInfo;
    property OnRead: TNotifyReadEvent read FOnRead write FOnRead;
    property OnWrite: TNotifyEvent read FOnWrite write FOnWrite;
    property OnAccept: TNotifyEvent read FOnAccept write FOnAccept;
    property OnAutoAccept: TNotifyAutoEvent read FOnAutoAccept write
      FOnAutoAccept;
  end;

  // Global IP Caching Mechanism.  Uses A String List That Stores The 32-Bit IP
  // Address Of It's Associated Hostname In The Object Property Of The List.  You
  // Should Never Have To Manipulate This Object Directly, But It Is Made Public
  // For The Purpose Of Calling The Clear Method To Empty It.
var
  IPCache: TStringList;

function WSDescription: string; // Returns A Description Of The WinSock Driver
function WSSystemStatus: string; // Returns System Status From The WinSock Driver
function GetLocalHostname: string; // Return Local Hostname
function SocketInfoText(Value: TSocketInfo): string;
  // Converts TSocketInfo Values To Text
function ErrToStr(Value: Integer): string; // Converts A WinSock Error To Text
function Base64Encode(Value: string): string;
  // Converts Passed Value To MIME Base64
function Base64Decode(Value: string): string;
  // Converts Passed Value From MIME Base64
function URLEncode(Value: string): string;
  // Converts String To A URLEncoded String
function URLDecode(Value: string): string;
  // Converts String From A URLEncoded String

procedure Register;

implementation

uses config;

const
  Base64Table =
    'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
  ValidURLChars = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789$-_@.&+-!*"''(),;/#?:';
  SocketInfoMsg: array[siLookUp..siError] of string = ('Lookup', 'Connect',
    'Close', 'Listen', 'Receive', 'Send', 'Accept', 'Error');

type
  TSockStream = class(TStream)
  private
    Sock: TSock;
  public
    function Read(var Buffer; Count: Longint): Longint; override;
    function Write(const Buffer; Count: Longint): Longint; override;
    function Seek(Offset: Longint; Origin: Word): Longint; override;

    constructor Create(Sock: TSock); virtual;
  end;

type
  TSockThread = class(TThread)
  private
    ParentSock: TSock;
    ClientSock: TSock;
  public
    procedure Execute; override;
    procedure ThreadTerminate(Sender: TObject);
    procedure RunThread(ParentSock, ClientSock: TSock);
  end;

  // WinSock Initialization Data
var
  WSAData: TWSAData;

  //*** TSockStream Methods ******************************************************

constructor TSockStream.Create(Sock: TSock);
begin
  Self.Sock := Sock;
end;

function TSockStream.Read(var Buffer; Count: Longint): Longint;
var
  Temp: string;
begin
  Temp := Sock.ReceiveCount(Count);
  Move(Temp[1], Buffer, Length(Temp));
  Result := Length(Temp);
end;

function TSockStream.Write(const Buffer; Count: Longint): Longint;
var
  Temp: string;
begin
  SetLength(Temp, Count);
  Move(Buffer, Temp[1], Count);
  Sock.Send(Temp);
  Result := Count;
end;

function TSockStream.Seek(Offset: Longint; Origin: Word): Longint;
begin
  Result := 0;
end;

//*** TSockThread Methods ******************************************************

procedure TSockThread.Execute;
begin
  FreeOnTerminate := True;
  OnTerminate := ThreadTerminate;
  ParentSock.OnAutoAccept(ParentSock, ClientSock);
  Terminate;
end;

procedure TSockThread.ThreadTerminate(Sender: TObject);
begin
  ClientSock.Free;
end;

procedure TSockThread.RunThread(ParentSock, ClientSock: TSock);
begin
  Self.ParentSock := ParentSock;
  Self.ClientSock := ClientSock;
  Resume;
end;

//*** Property Set/Get Procedures **********************************************

procedure TSock.SetHostName(Value: string);
begin
  if (FSocketType = stStream) and FConnected then
    DoInfo(SiLookup, 'Setting HostName While Connected Has No Effect');
  FHostName := Value;
  if (FSocketType = stDatagram) and FConnected then
    FSockAddrIn.SIn_Addr := HostLookup(Value);
end;

procedure TSock.SetPortName(Value: string);
begin
  if FConnected then
    DoInfo(SiLookup, 'Setting PortName While Connected Has No Effect');
  FPortName := Value;
end;

procedure TSock.SetLocalPortName(Value: string);
begin
  if FConnected then
    DoInfo(SiLookup, 'Setting LocalPortName While Connected Has No Effect');
  FLocalPortName := Value;
end;

function TSock.GetText: string;
begin
  // Just Call The Receive Method
  Result := Receive;
end;

procedure TSock.SetText(Value: string);
begin
  // Just Call The Send Method And Ignore The Boolean Result
  Send(Value);
end;

procedure TSock.SetListen(Value: Boolean);
var
  WasListen: Boolean;
  Addr: TSockAddr;
  Res: Integer;
begin
  if (csDesigning in ComponentState) then
  begin
    FListen := Value;
    if Value and (FSocketType = stDatagram) then
      // Listening Sockets Must Be Stream Sockets
      SetSocketType(stStream)
    else
      SetBitmap;
    Exit;
  end
  else if (csReading in ComponentState) then
  begin
    // If We Haven't Loaded Yet, Just Set The Value And Exit
    FListen := Value;
    Exit;
  end;
  WasListen := FListen;
  if (FSocket <> INVALID_SOCKET) and (not WasListen) then
  begin
    FListen := False;
    raise ESockException.Create('Listen - Socket Already In Use');
  end;
  if (FSocketType = stDatagram) and Value then
  begin
    FListen := False;
    raise ESockException.Create('Listen - Cannot Listen On A Datagram Socket');
  end;
  FListen := Value;
  if FListen then
  begin
    if not WasListen then
    begin
      // Have To Create A Socket Start Asynchronous Listening
      FListen := True;
      FSocket := WinSock.Socket(AF_INET, SOCK_STREAM, IPPROTO_IP);
      FillChar(Addr, SizeOf(Addr), #0);
      Addr.SIn_Family := AF_INET;
      Addr.SIn_Port := PortLookup(FPortName);
      Addr.SIn_Addr.S_Addr := HToNL(INADDR_ANY);
      // SetBlocking Will Set The Asynchronous Mode
      SetBlocking(FBlocking);
      FListen := False;
      Res := WinSock.Bind(FSocket, Addr, SizeOf(Addr));
      if Res <> 0 then
        raise ESockException.Create('Listen - Error Binding Socket');
      Res := WinSock.Listen(FSocket, 5);
      if Res <> 0 then
        raise ESockException.Create('Listen - Error Starting Listen');
      FListen := True;
      DoInfo(SiListen, 'Listening Started');
    end
    else
      DoInfo(SiListen, 'Listening Already Running');
  end
  else
  begin
    Close;
    DoInfo(SiListen, 'Listening Stopped');
  end;
end;

procedure TSock.SetBlocking(Value: Boolean);
var
  Il: U_Long;
  Ev: U_Long;
begin
  if (not (csDesigning in ComponentState)) and (csReading in ComponentState)
    then
  begin
    // If We Haven't Fully Loaded Yet, Just Set The Value And Exit
    FBlocking := Value;
    Exit;
  end;
  if FSocket = INVALID_SOCKET then
    FBlocking := Value
  else
  begin
    Ev := 0;
    FBlocking := Value;
    if (Parent = nil) then
    begin
      // If The Component Has No Parent (Dynamically Created) We Adopt It
      Parent := Screen.Forms[0];
      HandleNeeded;
    end;
    if FBlocking and (not FListen) then
    begin
      Il := 0;
      // Turn Off Async Checking And Set Blocking On
      WinSock.WSAAsyncSelect(FSocket, Handle, WM_SOCK, Ev);
      WinSock.IOCtlSocket(FSocket, FIONBIO, Il);
    end
    else
    begin
      if FListen then
        // If We're Listening, We Only Care About Accept Messages
        Ev := FD_ACCEPT
      else
      begin
        Ev := FD_READ; // Datagram Sockets Only Care About Read Messages
        if FSocketType = stStream then
          Ev := Ev or FD_CLOSE or FD_CONNECT or FD_WRITE or FD_READ;
      end;
      WinSock.WSAAsyncSelect(FSocket, Handle, WM_SOCK, Ev);
    end;
  end;
end;

procedure TSock.SetAutoAccept(Value: Boolean);
begin
  FAutoAccept := Value;
end;

procedure TSock.SetConnected(Value: Boolean);
begin
  if Value then
    Open
  else
    Close;
end;

function TSock.GetConnected: Boolean;
begin
  if FSocket = INVALID_SOCKET then
    FConnected := False;
  Result := FConnected;
end;

function TSock.GetEOF: Boolean;
begin
  Result := (FInBuffer = '') and (not FConnected);
end;

procedure TSock.SetSocket(Value: TSocket);
var
  Buf: array[1..10] of Char;
  Len: Integer;
  Res: Integer;
begin
  FSocket := Value;
  if FSocket = INVALID_SOCKET then
  begin
    // If The Socket Is Unassigned Then Who Cares
    FConnected := False;
    FListen := False;
  end
  else
  begin
    // Otherwise, We Need To Check To See If It's Already Listening
    Len := SizeOf(Buf);
    Res := WinSock.GetSockOpt(FSocket, IPPROTO_TCP, SO_ACCEPTCONN, PChar(@Buf),
      Len);
    if (Res = 0) and (Buf[1] <> #0) then
    begin
      FSocket := INVALID_SOCKET;
      raise ESockException.Create('Socket - Can''t Assign A Listening Socket');
    end
    else
      FConnected := True;
  end;
end;

procedure TSock.SetSocketType(Value: TSocketType);
begin
  if csDesigning in ComponentState then
  begin
    // At Design-Time, stDatagram And Listen Are Mutually Exclusive
    if (Value = stDatagram) and FListen then
      SetListen(False);
    FSocketType := Value;
    SetBitmap;
  end
  else