sockutils.pas

delphi完成端口Socks例子,纯Delphi做的

  FCriticalSection.Free;
  inherited;
end;

function TSiteInfos.GetCount: Integer;
begin
  Result := FList.Count;
end;

function TSiteInfos.GetItem(Index: Integer): PSiteInfo;
begin
  Result := FList[Index];
end;

function TSiteInfos.CompareSiteKey(Item: Pointer; const Key): Integer;
begin
  Result := PSiteInfo(Item)^.Key - Cardinal(Key);
end;

function TSiteInfos.CompareSiteClient(Item: Pointer; const Client): Integer;
begin
  Result := PSiteInfo(Item)^.AsClient - TSocket(Client);
end;

function TSiteInfos.CompareSiteServer(Item: Pointer; const Server): Integer;
begin
  Result := PSiteInfo(Item)^.AsServer - TSocket(Server);
end;

function TSiteInfos.Find(Key: Cardinal; var Index: Integer): Boolean;
begin
  Result := FList.BinarySearch(CompareSiteKey, Key, Index);
end;

function TSiteInfos.FindClient(Socket: TSocket; var Index: Integer): Boolean;
begin
  Result := FClients.BinarySearch(CompareSiteClient, Socket, Index);
end;

function TSiteInfos.FindServer(Socket: TSocket; var Index: Integer): Boolean;
begin
  Result := FServers.BinarySearch(CompareSiteServer, Socket, Index);
end;

procedure TSiteInfos.ConnectAsClient(Site: PSiteInfo);
var
  Index: Integer;
begin
  if not FindClient(Site^.AsClient, Index) then
    FClients.Insert(Index, Site);
end;

procedure TSiteInfos.DisconnectAsClient(Site: PSiteInfo);
var
  Index: Integer;
begin
  if FindClient(Site^.AsClient, Index) then
    FClients.Delete(Index);
  closesocket(Site^.AsClient);
  Site^.AsClient := INVALID_SOCKET;
end;

procedure TSiteInfos.ConnectAsServer(Site: PSiteInfo);
var
  Index: Integer;
begin
  if not FindServer(Site^.AsServer, Index) then
    FServers.Insert(Index, Site);
end;

procedure TSiteInfos.DisconnectAsServer(Site: PSiteInfo);
var
  Index: Integer;
begin
  if FindServer(Site^.AsServer, Index) then
    FServers.Delete(Index);
  closesocket(Site^.AsServer);
  Site^.AsServer := INVALID_SOCKET;
end;

function TSiteInfos.AddSite(const AName, AAddress: string): PSiteInfo;
begin
  Result := FindSite(AName, AAddress);
  if Result = nil then
  begin
    _NewAlloc(SizeOf(TSiteInfo), Pointer(Result));
    FillChar(Result^, SizeOf(TSiteInfo), 0); 
    StrPLCopy(Result^.HostName, AName, 128);
    StrPLCopy(Result^.Address, AAddress, 16);
    Result^.AsClient := INVALID_SOCKET;
    Result^.AsServer := INVALID_SOCKET;
    Result^.Data := nil;
    FCriticalSection.Enter;
    try
      Inc(FLastKey);
      Result^.Key := FLastKey;
      FList.Add(Result);
    finally
      FCriticalSection.Leave;
    end;
  end;
end;

procedure TSiteInfos.RemoveSite(ASite: PSiteInfo);
var
  Index: Integer;
begin
  if ASite <> nil then
    if Find(ASite^.Key, Index) then
      DeleteSite(Index);
end;

procedure TSiteInfos.DeleteSite(Index: Integer);
var
  Site: Pointer;
begin
  FCriticalSection.Enter;
  Site := FList[Index];
  try
    FList.Delete(Index);
  finally
    FCriticalSection.Leave;
    if PSiteInfo(Site)^.Data <> nil then
      PSiteInfo(Site)^.Data.Free;
    _Free(Site);
  end;
end;

function TSiteInfos.FindSite(Key: Integer): PSiteInfo;
var
  Index: Integer;
begin
  if Find(Key, Index) then
    Result := Items[Index]
  else
    Result := nil;
end;

function TSiteInfos.FindSite(const AName: string): PSiteInfo;
var
  I: Integer;
begin
  for I := 0 to Pred(Count) do
  begin
    Result := Items[I];
    if (AnsiCompareText(Result^.HostName, AName) = 0)
      or (AnsiCompareText(Result^.Address, AName) = 0) then
      Exit;
  end;
  Result := nil;
end;

function TSiteInfos.FindSite(const AName, AAddress: string): PSiteInfo;
var
  I: Integer;
begin
  for I := 0 to Pred(Count) do
  begin
    Result := Items[I];
    if (AnsiCompareText(Result^.Address, AAddress) = 0)
      or (AnsiCompareText(Result^.HostName, AName) = 0)
      or (AnsiCompareText(Result^.Address, Aname) = 0)
      or (AnsiCompareText(Result^.HostName, AAddress) = 0) then
      Exit;
  end;
  Result := nil;
end;

function TSiteInfos.FindClient(Socket: TSocket): PSiteInfo;
var
  Index: Integer;
begin
  if FindClient(Socket, Index) then
    Result := FClients[Index]
  else
    Result := nil;
end;

function TSiteInfos.FindServer(Socket: TSocket): PSiteInfo;
var
  Index: Integer;
begin
  if FindServer(Socket, Index) then
    Result := FServers[Index]
  else
    Result := nil;
end;

procedure TSiteInfos.InsertSite(const SiteName: string);
var
  Addr: string;
begin
  if AnsiCompareText(SiteName, LocalHostName) <> 0 then
    if AnsiCompareText(SiteName, LocalAddress) <> 0 then
      if FindSite(SiteName) = nil then
        if GetSiteAddress(SiteName, Addr) then
          if AnsiCompareText(Addr, LocalAddress) <> 0 then
            AddSite(SiteName, Addr);
end;

procedure TSiteInfos.RemoveSite(const SiteName: string);
var
  Site: PSiteInfo;
begin
  Site := FindSite(SiteName);
  if Site <> nil then
    RemoveSite(Site);
end;

{ TAsyncAction }

constructor TAsyncAction.Create(Site: PSiteInfo);
begin
  FCriticalSection := TCriticalSection.Create;
  FSite := Site;
  FID := 0;
  _NewAlloc(SizeOf(TPerHandleIOData), Pointer(FIOData));
end;

destructor TAsyncAction.Destroy;
begin
  _Free(Pointer(FIOData));
  FCriticalSection.Free;
  inherited;
end;

function TAsyncAction.GetClientState: Boolean;
begin
  if FSite <> nil then
    Result := FSite^.AsClient <> INVALID_SOCKET
  else
    Result := False;
end;

function TAsyncAction.GetServerState: Boolean;
begin
  if FSite <> nil then
    Result := FSite^.AsServer <> INVALID_SOCKET
  else
    Result := False;
end;

procedure TAsyncAction.Enter;
begin
  FCriticalSection.Enter;
end;

procedure TAsyncAction.Leave;
begin
  FCriticalSection.Leave;
end;

procedure TAsyncAction.DoAbandon;
begin
end;

procedure TAsyncAction.SetBuffer(Buf: Pointer; Size: Integer);
begin
end;

function TAsyncAction.Execute: Boolean;
begin
  Enter;
  try
    Result := DoExecute;
  finally
    Leave;
  end;
end;

procedure TAsyncAction.Complete(Bytes: Integer);
begin
  Enter;
  try
    DoComplete(Bytes);
  finally
    Leave;
  end;
end;

procedure TAsyncAction.Abandon;
begin
  Actions.Abandon(FID);
  DoAbandon;
end;

procedure TAsyncAction.Queueing;
begin
  Actions.Queue(Self);
end;

procedure TAsyncAction.Queueing(Milliseconds: Integer);
begin
  Actions.QueueDelay(Self, Milliseconds);
end;

{ TAsyncActionQueue }

constructor TAsyncActionQueue.Create;
begin
  FCriticalSection := TCriticalSection.Create;
  FEvent := CreateEvent(nil, False, False, nil);
  FHead := nil;
  FTail := nil;
  FEmpty := True;
end;

destructor TAsyncActionQueue.Destroy;
var
  Entry: PActionEntry;
  OldEntry: Pointer;
begin
  Entry := FHead;
  while Entry <> nil do
  begin
    OldEntry := Entry;
    Entry := Entry.Next;
    _Free(OldEntry);
  end;
  FCriticalSection.Free;
  CloseHandle(FEvent);
  inherited;
end;

procedure TAsyncActionQueue.Queue(Action: TAsyncAction);
var
  Entry: PActionEntry;
begin
  FCriticalSection.Enter;
  try
    _NewAlloc(SizeOf(TActionEntry), Pointer(Entry));
    Entry.Action := Action;
    Entry.Next := nil;
    if FTail = nil then
      FHead := Entry
    else
      FTail.Next := Entry;
    FTail := Entry;
    if FEmpty then
    begin
      FEmpty := False;
      SetEvent(FEvent);
    end;
  finally
    FCriticalSection.Leave;
  end;
end;

function TAsyncActionQueue.Dequeue(var Action: TAsyncAction): Boolean;
var
  Entry: PActionEntry;
begin
  FCriticalSection.Enter;
  try
    Entry := FHead;
    if FHead <> nil then
    begin
      FHead := FHead^.Next;
      if FHead = nil then
        FTail := nil;
    end
    else
      FEmpty := True;
  finally
    FCriticalSection.Leave;
  end;
  Result := Entry <> nil;
  if Result then
  begin
    Action := Entry^.Action;
    _Free(Pointer(Entry));
  end;
end;

{ TAsyncActionDelayQueue }

function CompareQWord(const Q1, Q2: TQWORD): Integer;
asm
  PUSH ESI
  PUSH EDI
  MOV ESI, EAX
  MOV EDI, EDX
  MOV EAX, (TQWORD PTR[ESI]).Hi
  SUB EAX, (TQWORD PTR[EDI]).Hi
  JE @@1
  MOV EAX, (TQWORD PTR[ESI]).Lo
  SUB EAX, (TQWORD PTR[EDI]).Lo
@@1:
  POP EDI
  POP ESI
end;

procedure BuildQWord(const Value: TQWORD; Base: Cardinal; Delta: Integer; Round: Integer);
asm
  PUSH EBX
  MOV EBX, EAX
  MOV EAX, EDX
  XOR EDX, EDX
  ADD EAX, ECX
  ADC EDX, [EBP+8]
  MOV (TQWORD PTR[EBX]).Lo, EAX
  MOV (TQWORD PTR[EBX]).Hi, EDX
  POP EBX
end;

function GetQWordDelta(const Value: TQWORD; Delta: Cardinal; Round: Integer): Integer;
asm
  PUSH EBX
  MOV EBX, EAX
  MOV EAX, (TQWORD PTR[EBX]).Lo
  SUB EAX, EDX
  MOV EDX, (TQWORD PTR[EBX]).Hi
  SBB EDX, ECX
  POP EBX
end;

constructor TAsyncActionDelayQueue.Create;
begin
  FCriticalSection := TCriticalSection.Create;
  FTimer := CreateWaitableTimer(nil, False, nil);
  FList := TList.Create;
  FTickCount := GetTickCount;
  FRound := 0;
  // 定时器至少每天被触发一次
  SetTimer(MSecsPerDay);
end;

destructor TAsyncActionDelayQueue.Destroy;
var
  Entry: Pointer;
  I: Integer;
begin
  CancelWaitableTimer(FTimer);
  I := FList.Count;
  while I > 0 do
  begin
    Dec(I);
    Entry := FList[I];
    _Free(Entry);
  end;
  FList.Free;
  FCriticalSection.Free;
  CloseHandle(FTimer);
  inherited;
end;

function TAsyncActionDelayQueue.GetCurrentTicks: Cardinal;
begin
  Result := GetTickCount;
  if Result < FTickCount then
    Inc(FRound);
  FTickCount := Result;
end;

procedure TAsyncActionDelayQueue.SetTimer(Milliseconds: Integer);
var
  Due: Int64;
begin
  // 更新滴答计数器
  Due := - 10000 * Milliseconds;
  SetWaitableTimer(FTimer, Due, 0, nil, nil, False);
end;

function TAsyncActionDelayQueue.Compare(Item: Pointer; const Key): Integer;
var
  Entry: PActionDelayEntry;
begin
  Entry := Item;
  Result := CompareQWord(Entry^.Delay, TQWord(Key));
end;

procedure TAsyncActionDelayQueue.Fire;
var
  Entry: PActionDelayEntry;
  Delta: Integer;
begin
  if FList.Count > 0 then
  begin
    Entry := FList[0];
    Delta := GetQWordDelta(Entry^.Delay, GetCurrentTicks, FRound);
    if Delta <= 0 then
    begin
      // 从备份队列中取出加入主队列
      FList.Delete(0);
      Entry^.Action.Queueing;
      _Free(Pointer(Entry));
      Fire;
    end
    else
      // 重新触发计时器
      SetTimer(Delta);
  end
  else
  begin
    // 仅仅更新滴答计数器
    GetCurrentTicks;
    SetTimer(MSecsPerDay);
  end;
end;

procedure TAsyncActionDelayQueue.Queue(Action: TAsyncAction; Milliseconds: Integer);
var
  Entry: PActionDelayEntry;