icqsock.pas

本程序是转载的

unit ICQSock;
{(C) Alex Demchenko}
{ Modified by NighTrader 02-04-2003 }

//{$DEFINE DEBUG} {Show debug errors}
//{$DEFINE PARSE} {Dump packets into file}

interface
uses
{$IFDEF DEBUGDC}
  dbugintf, Dialogs,
{$ENDIF}
  Windows, WinSock, Classes, ICQWorks, ICQLang, Sysutils;

const
  CNetPktLen = $FFFF; {Size of network packet}
  DefaultSockType = True; {True = non-blocking using blocking sockets architecture; False = blocking}

type
  PNetPacket = ^TNetPacket;
  TNetPacket = record
    Buf: array[0..CNetPktLen - 1] of Byte;
    BufLen: Word;
    Offset: Word;
    Next: PNetPacket;
  end;

  {Thread-safe implementation of software buffer}
  TNetBuffer = class(TObject)
  private
    FPkt: PNetPacket;
    Shared: Integer;
    CS: TRTLCriticalSection;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Enter;
    procedure Leave;
    procedure Clear;
    procedure AddPacket(Buffer: Pointer; BufLen: LongWord);
    procedure DelPacket;
    function GetPacket(Buffer: Pointer): LongWord;
    function SkipData(Len: Word): Boolean;
    procedure AddStr(const Value: String);
    function GetStr: String;
    function GetLength: LongWord;
  end;

  {Thread-safe implementation of Berkeley sockets}
  TCustomSocket = class(TThread)
  private
    FSocket: TSocket;
    FIp: Integer;
    FDoConnect: Boolean;
    FWorking: Boolean;
    FConnected: Boolean;
    FAssync: Boolean;
    FBuffer: TNetBuffer;
    FDataSentEvent: Boolean;
    FErrLang: TICQLangType;
    procedure ProcessBuffer;
  protected
    FHost: String;
    FPort: Word;
    FLastError: Word;
    FLastErrMsg: String;
    Buffer: Pointer;
    BufLen: LongWord;
    function Resolve(const Host: String): Integer;
    procedure Execute; override;
    procedure FreeSocket;
    procedure OnError; virtual;
    procedure OnConnect; virtual;
    procedure OnConnectError; virtual;
    procedure OnDisconnect; virtual;
    procedure OnReceive; virtual;
    procedure OnDataSent; virtual;
  public
    constructor Create;
    destructor Destroy; override;
    procedure StartWork(Socket: TSocket);
    procedure Connect;
    procedure SendData(Buffer: Pointer; Len: LongWord);
    procedure SendStr(const Value: String);
    property Host: String read FHost write FHost;
    property Port: Word read FPort write FPort;
    property Working: Boolean read FWorking write FWorking;
    property Connected: Boolean read FConnected write FConnected;
    property Assync: Boolean read FAssync write FAssync;
    property ErrorLanguage: TICQLangType read FErrLang write FErrLang;
  end;

  TProxySocket = class(TCustomSocket)
  private
    FDestHost: String;
    FDestIp: Integer;
    FDestPort: Word;
    FProxyUser: String;
    FProxyPass: String;
    FProxyAuth: Boolean;
    FProxyReady: Boolean;
    FProxyResolve: Boolean;
  protected
    procedure Execute; override;
  public
    property Host: String read FDestHost write FDestHost; {Real Host}
    property Port: Word read FDestPort write FDestPort;   {Real Port}

    property ProxyHost: String read FHost write FHost;
    property ProxyPort: Word read FPort write FPort;
    property ProxyUser: String read FProxyUser write FProxyUser;
    property ProxyPass: String read FProxyPass write FProxyPass;
    property ProxyAuth: Boolean read FProxyAuth write FProxyAuth default False;
    property ProxyResolve: Boolean read FProxyResolve write FProxyResolve default False;

    property ProxyReady: Boolean read FProxyReady write FProxyReady default False;
  end;

  TOnError = procedure(Sender: TObject; ErrorType: TErrorType; ErrorMsg: String) of object;
  TOnRecveive = procedure(Sender: TObject; Buffer: Pointer; BufLen: LongWord) of object;

  {Extends TProxySocket with events}
  TEventSocket = class(TProxySocket)
  private
    FOnConnect: TNotifyEvent;
    FOnError: TOnError;
    FOnDisconnect: TNotifyEvent;
    FOnConnectError: TNotifyEvent;
    FOnReceive: TOnRecveive;
    FOnDataSent: TNotifyEvent;
  protected
    procedure OnConnect; override;
    procedure OnError; override;
    procedure OnConnectError; override;
    procedure OnDisconnect; override;
    procedure OnReceive; override;
    procedure OnDataSent; override;
  published
    property _OnConnect: TNotifyEvent read FOnConnect write FOnConnect;
    property _OnError: TOnError read FOnError write FOnError;
    property _OnConnectError: TNotifyEvent read FOnConnectError write FOnConnectError;
    property _OnDisconnect: TNotifyEvent read FOnDisconnect write FOnDisconnect;
    property _OnReceive: TOnRecveive read FOnReceive write FOnReceive;
    property _OnDataSent: TNotifyEvent read FOnDataSent write FOnDataSent;
  end;

  TSOCKSSocket = class(TEventSocket)
  private
    FSrcBuf: array[0..255] of Byte;
    FSrcLen: Word;
  end;

  TSOCKS4Socket = class(TSOCKSSocket)
  protected
    procedure OnConnect; override;
    procedure OnReceive; override;
  end;

  TSOCKS5Socket = class(TSOCKSSocket)
  private
    FSocksProgress: Word;
  protected
    procedure OnConnect; override;
    procedure OnReceive; override;
  end;

  THTTPSocket = class(TEventSocket)
  private
    FBuf: array[0..$FFFE] of Byte;
    FCurLen, FLen: LongWord;
  protected
    procedure OnConnect; override;
    procedure OnReceive; override;
  end;

  THTTPSSocket = class(TEventSocket)
  private
    FBuf: array[0..8191] of Byte;
    FCurLen: Word;
  protected
    procedure OnConnect; override;
    procedure OnReceive; override;
  end;

  TMySocket = class;
  TOnClientConnected = procedure(Sender: TObject; Socket: TMySocket) of object;
  TOnSrvSockConnected = procedure(Sender: TObject; Socket: TSocket) of object;

  TTCPServer = class(TThread)
  private
    FSocket: TSocket;
    FPort: Word;
    FClient: TSocket;
    FLastError: Word;
    FLastErrMsg: String;
    FErrLang: TICQLangType;
    FOnError: TOnError;
    FOnClientConnected: TOnSrvSockConnected;
  protected
    procedure Execute; override;
    procedure WaitForConnection;
    procedure FreeSocket;
  public
    constructor Create;
    destructor Destroy; override;

    function Start: Boolean;
    procedure OnError; virtual;
    procedure OnClientConnected; 
    property Port: Word read FPort write FPort;
    property ErrorLanguage: TICQLangType read FErrLang write FErrLang;
    property _OnError: TOnError read FOnError write FOnError;
    property _OnClientConnected: TOnSrvSockConnected read FOnClientConnected write FOnClientConnected;
  end;

  TOnAdvPktParse = procedure(Sender: TObject; Buffer: Pointer; BufLen: LongWord; Incoming: Boolean) of object;
  TOnRecv = procedure(Sender: TObject; Socket: TSocket; Buffer: Pointer; BufLen: LongWord) of object;

  TServerSocket = class(TTCPServer)
    private
      fOnCliConn:TOnSrvSockConnected;
      procedure DoConnEvent;
    public

      procedure OnClientConnected; virtual;
      property OnConnected: TOnSrvSockConnected read fOnCliConn write fOnCliConn;
    End;

  { TSrvSock like in MyScoket.pas }
  TSrvSocket = class(TObject)
    private
      fSrv:TTCPServer;
      fPort:word;
      FOnClientConnected: TOnClientConnected;
      FOnError:TOnError;
      fIsListening:Boolean;

      procedure OnSrvConnProc(Sender: TObject; Socket: TSocket);
      procedure OnSrvErrProc(Sender: TObject; ErrorType: TErrorType; ErrorMsg: String);
      function GetPort:Word;
      procedure SetPort( aPort: Word);
    Public
      constructor Create;
      destructor Destroy; override;
      function StartServer(Port: Word): Boolean;
      function StopServer: Boolean;
      property Port: Word read GetPort write SetPort;
    published
      property OnError:TOnError read fOnError write fOnError;
      property OnClientConnected: TOnClientConnected read FOnClientConnected write FOnClientConnected;
  End;

  { TMySock like in MySocket.pas }
  TMySocket = class(TObject)
    private
      FHost:String;
      fPort:Word;
      // Threaded Socket
      FEventSocket:TEventSocket;
      FSocket:TSocket;
      //  Events
      FOnConnectError: TNotifyEvent;
      FOnDisconnect: TNotifyEvent;
      FOnPktParse: TOnAdvPktParse;
      FOnError: TOnError;
      FOnRecv: TOnRecv;
      FOnConnectProc: TNotifyEvent;
      FOnDataSent: TNotifyEvent;

      function GetClientSocket: TSocket;
      procedure SetClientSocket(Socket: TSocket);
      function IsConnected: Boolean;

      Procedure SetHost( aHost: String);
      Procedure SetPort( aPort: Word);
      Function  GetHost: String;
      Function  GetPort: Word;
      Procedure SetProxyType( aProxyType: TProxyType);
      Procedure SetProxyHost( aProxyHost: String);
      Procedure SetProxyPort( aProxyPort: Word);
      Procedure SetProxyAuth( aProxyAuth: Boolean);
      Procedure SetProxyPass( aProxyPass: String);
      Procedure SetProxyUser( aProxyUser: String);
      Procedure SetProxyRslv( aProxyRslv: Boolean);
      Function  GetProxyType: TProxyType;
      Function  GetProxyHost: String;
      Function  GetProxyPort: Word;
      Function  GetProxyAuth: Boolean;
      Function  GetProxyPass: String;
      Function  GetProxyUser: String;
      Function  GetProxyRslv: Boolean;

      Procedure OnConnectErrorProc(Sender: TObject);
      Procedure OnDisconnectProc(Sender: TObject);
      Procedure OnConnect(Sender: TObject);
      Procedure OnErrorProc(Sender: TObject; ErrorType: TErrorType; ErrorMsg: String);
      Procedure OnReceive(Sender: TObject; Buffer: Pointer; BufLen: LongWord);
      Procedure OnDataSentProc(Sender: TObject);
    public
      constructor Create;
      destructor Destroy; override;
      procedure Connect; dynamic;
      procedure Disconnect;
      procedure SendData(var Buf; BufLen: LongWord);
      property Host: String read fHost write fHost;
      property Port: Word read fPort write fPort;
      property ProxyType: TProxyType read GetProxyType write SetProxyType;
      property ProxyHost: String read GetProxyHost write SetProxyHost;
      property ProxyPort: Word read GetProxyPort write SetProxyPort;
      property ProxyUser: String read GetProxyUser write SetProxyUser;
      property ProxyAuth: Boolean read GetProxyAuth write SetProxyAuth;
      property ProxyPass: String read GetProxyPass write SetProxyPass;
      property ProxyResolve: Boolean read GetProxyRslv write SetProxyRslv default False;
//      property WndHandle: THandle read GetWndHandle;
    published
      property OnConnectError: TNotifyEvent read FOnConnectError write FOnConnectError;
      property OnDisconnect: TNotifyEvent read FOnDisconnect write FOnDisconnect;
      property OnPktParseA: TOnAdvPktParse read FOnPktParse write FOnPktParse;
      property OnError: TOnError read FOnError write FOnError;
      property OnReceiveProc: TOnRecv read FOnRecv write FOnRecv;
      property OnConnectProc: TNotifyEvent read FOnConnectProc write FOnConnectProc;
      property OnDataSent: TNotifyEvent read FOnDataSent write FOnDataSent;
      property ClientSocket: TSocket read GetClientSocket write SetClientSocket;
      property Connected: Boolean read IsConnected;
  End;

var
  WSAData: TWSAData;
  WSAStarted: Boolean;

function WaitForRead(Sock: TSocket; Timeout: DWord): Boolean;
function GetHTTPStatus(List: TStringList): String;

function WSockAddrToIp(Value: LongWord): String;
function WSAErrorToStr(ErrorNo: Integer): String;
function GetLocalIP: Integer;
function FindBindPort: Word;



implementation

const
  b64alphabet: PChar = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';

function EncodeBase64(Value: String): String;
const
  pad: PChar = '====';

  function EncodeChunk(const Chunk: String): String;
  var
    W: LongWord;
    i, n: Byte;
  begin
    n := Length(Chunk); W := 0;
    for i := 0 to n - 1 do
      W := W + Ord(Chunk[i + 1]) shl ((2 - i) * 8);
    Result := b64alphabet[(W shr 18) and $3f] +
              b64alphabet[(W shr 12) and $3f] +
              b64alphabet[(W shr 06) and $3f] +
              b64alphabet[(W shr 00) and $3f];
    if n <> 3 then
      Result := Copy(Result, 0, n + 1) + Copy(pad, 0, 3 - n);   //add padding when out len isn't 24 bits
  end;

begin
  Result := '';
  while Length(Value) > 0 do
  begin
    Result := Result + EncodeChunk(Copy(Value, 0, 3));
    Delete(Value, 1, 3);
  end;
end;

function DecodeBase64(Value: String): String;
  function DecodeChunk(const Chunk: String): String;
  var
    W: LongWord;
    i: Byte;
  begin
    W := 0; Result := '';
    for i := 1 to 4 do
      if Pos(Chunk[i], b64alphabet) <> 0 then
        W := W + Word((Pos(Chunk[i], b64alphabet) - 1)) shl ((4 - i) * 6);
    for i := 1 to 3 do
      Result := Result + Chr(W shr ((3 - i) * 8) and $ff);
  end;
begin
  Result := '';
  if Length(Value) mod 4 <> 0 then Exit;
  while Length(Value) > 0 do
  begin
    Result := Result + DecodeChunk(Copy(Value, 0, 4));
    Delete(Value, 1, 4);
  end;
end;

procedure ShowMessage(const Msg: String);
begin
  MessageBox(0, PChar(Msg), 'Message', 0);
end;

function WaitForRead(Sock: TSocket; Timeout: DWord): Boolean;
var
  readfd: TFDSet;
  tv: TimeVal;
begin
  tv.tv_sec := 0; tv.tv_usec := Timeout;
  FD_ZERO(readfd); FD_SET(Sock, readfd);
  if select(0, @readfd, nil, nil, @tv) < 1 then
    Result := False
  else
    Result := True;
end;

function GetHTTPStatus(List: TStringList): String;
var
  i, c: Word;
  S: String;
begin
  Result := '';
  if List.Count < 1 then Exit;
  S := List.Strings[0]; c := 0;
  for i := 1 to Length(S) do
    if c = 1 then
      Result := Result + S[i]
    else