simplesocks.pas

由delphi实现的bt下载器示例程序

unit simplesocks;

//{$DEFINE DEBUGMSG}

interface

uses
  Windows, Messages, SysUtils, Classes, Winsock, ThreadTimer, SortLists, DelayLists{$IFDEF DEBUGMSG}, DebugUnit{$ENDIF};

const
  XM_SOCK        =  WM_USER + 3477;
  FD_ERROR       =  -1;
  THREAD_RW      =  True;

type
  TSimpleSock = class;
  TSockEvent = procedure (Sender: TSimpleSock; Code: Integer; const Buf; var Len: Integer) of object;

  TSimpleSock = class
  private
    FLock: TRTLCriticalSection;
    FOwner: TSimpleSock;
    FEventHandle: TSockEvent;
    FRecvBuffer: string;
    FSendBuffer: string;
    FClients: TSortedList;
    FSendBytes: Integer;
    FRecvBytes: Integer;
    FCurrRecv: Integer;
    FCurrSend: Integer;
    function GetCurrentRecv: Integer;
    function GetCurrentSend: Integer;
    procedure SetRecvBytes(const Value: Integer);
    procedure SetSendBytes(const Value: Integer);
    procedure DeleteSelf;
    function GetBufferUsed: Integer;
  public
    Handle: Integer;
    Addr: TSockAddrIn;
    LastRead: Cardinal;
    LastSend: Cardinal;
    WorkInThread: Boolean;
    Data: Pointer;
    constructor Create(AOwner: TSimpleSock; AHandle: Integer);
    destructor Destroy; override;
    procedure Close; virtual;
    procedure Send(const Buf; Len: Integer); overload;
    procedure Send(s: string); overload; virtual;
    procedure DoEvent(WParam, LParam: Integer); virtual;
    procedure Put(s: string); overload; virtual;
    procedure Put(const Buf; Len: Integer); overload;
    procedure Lock;
    procedure Unlock;
    function TryLock(TimeOut: Cardinal = 0): Boolean;

    property RecvBytes: Integer read FRecvBytes write SetRecvBytes;
    property SendBytes: Integer read FSendBytes write SetSendBytes;
    property CurrentRecv: Integer read GetCurrentRecv;
    property CurrentSend: Integer read GetCurrentSend;
    property EventHandle: TSockEvent read FEventHandle write FEventHandle;
    property Owner: TSimpleSock read FOwner;
    property BufferUsed: Integer read GetBufferUsed;
  end;

  TSockWnd = class
  public
    Wnd: HWND;
    constructor Create;
    destructor Destroy; override;
    procedure WndProc(var Message: TMessage);
    function CompareSocks(Key, Item: Pointer): Integer;
    procedure ReleaseSock(Data: Pointer);
  end;

function OpenSocket(APort: Word; AData: Pointer; AEvent: TSockEvent;
    WorkInThread: Boolean = True): TSimpleSock;
function ConnectSocket(AHost: string; APort: Word; AData: Pointer; AEvent: TSockEvent;
    WorkInThread: Boolean = True): TSimpleSock; overload;
function ConnectSocket(AIP: Integer; APort: Word; AData: Pointer; AEvent: TSockEvent;
    WorkInThread: Boolean = True): TSimpleSock; overload;
function ConnectSocket(AAddr: Pointer; AData: Pointer; AEvent: TSockEvent;
    WorkInThread: Boolean = True): TSimpleSock; overload;
procedure Traverse(ASock: TSimpleSock; Code: Integer; Para: Pointer; ParaLen: Integer);
procedure DropSocket(ASock: TSimpleSock);
function GetAcceptedSockets(ASock: TSimpleSock; List: TList): Boolean;

function HostToIP(AHost: string): Integer;
function IsLanIP(AIP: Integer): Boolean;
function GetLanIP: Integer;
function GetWanIP: Integer;
function IsSelfIP(AIP: Integer): Boolean;

implementation

var
  SockWnd: TSockWnd;
  SocksList: TLockList;

procedure InitSocks;
var
  wsaData: TWSAData;
begin
  WSAStartup($0101, wsaData);
  SockWnd := TSockWnd.Create;
  SocksList := TLockList.Create;
  SocksList.CompareKey := SockWnd.CompareSocks;
  SocksList.ReleaseData := SockWnd.ReleaseSock;
end;

procedure FinalSocks;
begin
  SocksList.Free;
  SockWnd.Free;
  WSACleanup;
end;

function OpenSocket(APort: Word; AData: Pointer; AEvent: TSockEvent;
  WorkInThread: Boolean = True): TSimpleSock;
var
  h: Integer;
  a: TSockAddrIn;
begin
  result := nil;
  a.sin_family := AF_INET;
  a.sin_port := htons(aport);
  a.sin_addr.S_addr := INADDR_ANY;
  h := socket(AF_INET, SOCK_STREAM, IPPROTO_TCP);
  if h > 0 then
    if bind(h, a, sizeof(a)) < 0 then
      closesocket(h)
    else begin
      result := TSimpleSock.Create(nil, h);
      result.Data := AData;
      result.WorkInThread := WorkInThread;
      result.EventHandle := aevent;
      result.FClients := TSortedList.Create;
      result.FClients.CompareKey := sockwnd.CompareSocks;
      move(a, result.Addr, sizeof(a));
      wsaasyncselect(h, sockwnd.Wnd, XM_SOCK, FD_ACCEPT or FD_CLOSE);
      listen(h, 5);
    end;
end;

function ConnectSocket(AHost: string; APort: Word; AData: Pointer; AEvent: TSockEvent;
  WorkInThread: Boolean = True): TSimpleSock; overload;
var
  ip: Integer;
begin
  ip := hosttoip(ahost);
  result := connectsocket(ip, aport, adata, aevent, workInThread);
end;

function ConnectSocket(AIP: Integer; APort: Word; AData: Pointer; AEvent: TSockEvent;
  WorkInThread: Boolean = True): TSimpleSock; overload;
var
  a: TSockAddrIn;
begin
  result := nil;
  if aip <> 0 then
  begin
    a.sin_family := AF_INET;
    a.sin_port := htons(aport);
    a.sin_addr.S_addr := aip;
    result := connectsocket(@a, adata, aevent, WorkInThread);
  end;
end;

function ConnectSocket(AAddr: Pointer; AData: Pointer; AEvent: TSockEvent;
  WorkInThread: Boolean = True): TSimpleSock; overload;
var
  h: Integer;
begin
  result := nil;
  if aaddr <> nil then
  begin
    h := socket(AF_INET, SOCK_STREAM, IPPROTO_TCP);
    if h > 0 then
    begin
      wsaasyncselect(h, sockwnd.Wnd, XM_SOCK, FD_READ or FD_WRITE or FD_CONNECT or FD_CLOSE);
      result := TSimpleSock.Create(nil, h);
      result.WorkInThread := WorkInThread;
      move(aaddr^, result.Addr, sizeof(TSockAddrIn));
      result.Data := adata;
      result.EventHandle := AEvent;
      if (connect(h, result.addr, sizeof(TSockAddrIn)) < 0) and (wsagetlasterror <> WSAEWOULDBLOCK) then
      begin
        dropsocket(result);
        result := nil;
      end;
    end;
  end;
end;

function GetAcceptedSockets(ASock: TSimpleSock; List: TList): Boolean;
begin
  result := false;
  try
    if asock <> nil then
    asock.Lock;
    try
      if asock.FClients <> nil then
      begin
        List.Count := asock.FClients.count;
        if list.Count > 0 then
          system.Move(asock.fclients.list^, list.list^, list.Count * 4);
        result := true;
      end;
    finally
      asock.Unlock;
    end;
  except
  {$IFDEF DEBUGMSG}
    on e: exception do
      LogDbgMsg('GetAcceptedSockets error: '+e.message);
  {$ENDIF}
  end;
end;

procedure Traverse(ASock: TSimpleSock; Code: Integer; Para: Pointer; ParaLen: Integer);
var
  lst: TList;
  i: Integer;
begin
  lst := TList.Create;
  if getacceptedsockets(asock, lst) then
    for i := 0 to lst.Count - 1 do
      with TSimpleSock(lst.items[i]) do
      try
        if assigned(FEventHandle) then
          if para <> nil then
            feventhandle(TSimpleSock(lst.items[i]), Code, para^, paralen)
          else
            feventhandle(TSimpleSock(lst.items[i]), code, i, paralen);
      except
      {$IFDEF DEBUGMSG}
        on e: exception do
          LogDbgMsg('Traverse sockets ('+inttostr(i)+') error: '+e.message);
      {$ENDIF}
      end;
  lst.Free;
end;

procedure DropSocket(ASock: TSimpleSock);
begin
  try
    sockslist.DeleteItem(pointer(asock.Handle));
  except
  end;
end;

function HostToIP(AHost: string): Integer;
var
  hosts: PHostEnt;
  a: In_Addr;
begin
  result := 0;
  a.S_addr := inet_addr(pchar(ahost));
  if a.S_addr = -1 then
  begin
    hosts := gethostbyname(pchar(ahost));
    if (hosts <> nil) and (hosts.h_addr_list <> nil) and (PPointer(hosts.h_addr_list)^ <> nil) then
      result := PInteger(PPointerList(hosts.h_addr_list)[0])^;
  end
  else result := a.S_addr;
end;

function IsLanIP(AIP: Integer): Boolean;
var
  l: Cardinal;
begin
  l := ntohl(aip);
  result := (l <> $7F000001) and (((l>=$0A000000) and (l <= $0AFFFFFF))
            or ((l>=$C0A80000) and (l<=$C0A8FFFF))
            or ((l>=$A9000000) and (l<=$A9FFFFFF)));
end;

function GetLanIP: Integer;
var
  nm: array [0..255] of char;
  i, l: Integer;
  hosts: PHostEnt;
  pa: PPointerList;
begin
  result := 0;
  l := gethostname(pchar(@nm), 255);
  if l = 0 then
  begin
    hosts := gethostbyname(pchar(@nm));
    if (hosts <> nil) and (hosts.h_addr_list <> nil) and (PPointer(hosts.h_addr_list)^ <> nil) then
    begin
      i := 0;
      pa := pointer(hosts.h_addr_list);
      while pa[i] <> nil do
      begin
        result := PInteger(pa[i])^;
        if islanip(result) then
          break;
        inc(i);
      end;
    end;
  end;
end;

function IsSelfIP(AIP: Integer): Boolean;
var
  nm: array [0..255] of char;
  i, l: Integer;
  hosts: PHostEnt;
  pa: PPointerList;
begin
  result := false;
  l := gethostname(pchar(@nm), 255);
  if l = 0 then
  begin
    hosts := gethostbyname(pchar(@nm));
    if (hosts <> nil) and (hosts.h_addr_list <> nil) and (PPointer(hosts.h_addr_list)^ <> nil) then
    begin
      i := 0;
      pa := pointer(hosts.h_addr_list);
      while pa[i] <> nil do
      begin
        result := PInteger(pa[i])^=aip;
        if result then break;
        inc(i);
      end;
    end;
  end;
end;

function GetWanIP: Integer;
var
  nm: array [0..255] of char;
  i, l: Integer;
  hosts: PHostEnt;
  pa: PPointerList;
begin
  result := 0;
  l := gethostname(pchar(@nm), 255);
  if l = 0 then
  begin
    hosts := gethostbyname(pchar(@nm));
    if (hosts <> nil) and (hosts.h_addr_list <> nil) and (PPointer(hosts.h_addr_list)^ <> nil) then
    begin
      i := 0;
      pa := pointer(hosts.h_addr_list);
      while pa[i] <> nil do
      begin
        result := PInteger(pa[i])^;
        if not islanip(result) then
          break;
        inc(i);
      end;
    end;
  end;
end;

{ TSockWnd }

constructor TSockWnd.Create;
begin
  wnd := allocatehwnd(WndProc);
end;

destructor TSockWnd.Destroy;
begin
  deallocatehwnd(wnd);
  inherited;
end;

function TSockWnd.CompareSocks(Key, Item: Pointer): Integer;
begin
  result := Integer(Key) - TSimpleSock(Item).Handle;
end;

procedure TSockWnd.ReleaseSock(Data: Pointer);
begin
  TSimpleSock(Data).DeleteSelf;
end;

procedure TSockWnd.WndProc(var Message: TMessage);
var
  s: TSimpleSock;
begin
  Message.Result := 0;
  if Message.Msg = XM_SOCK then
  begin
    s := TSimpleSock(SocksList.GetItem(pointer(Message.WParam)));
    if s <> nil then
      if Message.LParamHi <> 0 then
        if s.WorkInThread then
          globaltimer.AddJob(FD_ERROR, Message.LParamHi, 0, s.DoEvent, true, true)
        else
          s.DoEvent(FD_ERROR, Message.LParamHi)
      else begin
        if Message.LParamLo = FD_READ then
          wsaasyncselect(s.Handle, wnd, XM_SOCK, FD_WRITE or FD_CLOSE);
        if s.WorkInThread and (Message.LParamLo <> FD_ACCEPT) then
          globaltimer.AddJob(Message.LParamLo, 0, 0, s.DoEvent, true, true)
        else
          s.DoEvent(Message.LParamLo, 0);
      end;
  end;
end;

{ TSimpleSock }

constructor TSimpleSock.Create(AOwner: TSimpleSock; AHandle: Integer);
begin
  InitializeCriticalSection(FLock);
  handle := ahandle;
  lastread := gettickcount;
  lastsend := lastread;
  sockslist.InsertItem(pointer(handle), pointer(self), true);
  if (AOwner<>nil) and (AOwner.FClients <> nil) then
  begin
    FOwner := AOwner;
    try