sock.pas

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

    Result := ReceiveDatagram(HostN);
end;

function TSock.ReceiveLine: string;
var
  CPos, CLen: LongInt;
  Temp: string;
begin
  CPos := 0;
  Result := '';
  if FSocketType = stStream then
  begin
    if (FBlocking and FConnected) then
    begin
      Temp := FInBuffer;
      FInBuffer := '';
      Temp := Temp + Receive;
      FInBuffer := Temp;
    end;
    if (FLastChar = #13) and (FLineBreak = lbSmart) and (FInBuffer[1] = #10)
      then
    begin
      Delete(FInBuffer, 1, 1);
      FLastChar := #0;
    end;
    case FLineBreak of
      lbCR: CPos := Pos(#13, FInBuffer);
      lbLF: CPos := Pos(#10, FInBuffer);
      lbCRLF: CPos := Pos(#13#10, FInBuffer);
      lbSmart:
        begin
          CPos := Pos(#13, FInBuffer);
          if (CPos = 0) or (Pos(#10, FInBuffer) < CPos) then
            CPos := Pos(#10, FInBuffer);
          if CPos > 0 then
            FLastChar := FInBuffer[CPos]
          else
            FLastChar := #0;
        end;
    end;
    if FLineBreak = lbCRLF then
      CLen := 2
    else
      CLen := 1;
    if (CPos > 0) or (not FConnected) then
    begin
      if CPos > 0 then
      begin
        Result := Copy(FInBuffer, 1, CPos - 1);
        Delete(FInBuffer, 1, CPos + (CLen - 1));
      end
      else
      begin
        Result := FInBuffer;
        FInBuffer := '';
      end;
    end;
  end
  else
    Result := Receive;
end;

function TSock.SendDatagram(Value, HostName: string): Boolean;
begin
  if FSocket = INVALID_SOCKET then
    raise ESockException.Create('SendDatagram - Socket Not Connected');
  if FSocketType = stStream then
    raise
      ESockException.Create('SendDatagram - Datagram Send Not Supported On Stream Sockets');
  Result := True;
  SetHostName(HostName);
  if Value = '' then
    Exit;
  WinSock.SendTo(FSocket, Value[1], Length(Value), 0, FSockAddrIn,
    SizeOf(TSockAddrIn));
end;

function TSock.ReceiveDatagram(var HostName: string): string;
var
  Res: Integer;
  FDSet: PFDSet;
  TV: PTimeVal;
  FLen: Integer;
begin
  if FSocket = INVALID_SOCKET then
    raise ESockException.Create('ReceiveDatagram - Socket Not Connected');
  if FSocketType = stStream then
    raise
      ESockException.Create('ReceiveDatagram - Datagram Receive Not Supported On Stream Sockets');
  FDSet := New(PFDSet);
  FDSet^.FD_Count := 1;
  FDSet^.FD_Array[0] := FSocket;
  Result := '';
  HostName := '';
  if FBlockTime >= 0 then
  begin
    TV := New(PTimeVal);
    TV^.tv_sec := FBlockTime;
  end
  else
    TV := nil;
  if WinSock.Select(FSocket, FDSet, nil, nil, TV) > 0 then
  begin
    FLen := Sizeof(FRecvAddrIn);
    Res := WinSock.RecvFrom(FSocket, FCharBuf, SizeOf(FCharBuf), 0, FRecvAddrIn,
      FLen);
    if Res > 0 then
    begin
      Result := Copy(FCharBuf, 1, Res);
      HostName := GetRemoteHost;
    end
    else
      raise ESockException.Create('Socket Error while Receiving Datagram:' +
        IntToStr(WSAGetLastError));
  end;
  Dispose(FDSet);
  Dispose(TV);
end;

function TSock.Accept(var NewSock: TSock): Boolean;
var
  AcSck: TSocket;
  AddrL: Integer;
  Addr: TSockAddrIn;
begin
  // Accept Creates A New Instance Of A TSock Component And Returns It To The
  // User Application.  The User Is Responsible For Freeing The Component.
  if not FListen then
    raise ESockException.Create('Accept - Socket Not In Listening Mode');
  if FBlocking then
    DoInfo(SiAccept, 'Blocking Accept');
  AddrL := SizeOf(Addr);
{$IFDEF VER93}
  AcSck := WinSock.Accept(FSocket, Addr, AddrL);
{$ELSE}
{$IFDEF WIN32}
  AcSck := WinSock.Accept(FSocket, @Addr, @AddrL);
{$ELSE}
  AcSck := WinSock.Accept(FSocket, Addr, AddrL);
{$ENDIF}
{$ENDIF}
  FRecvAddrIn := Addr;
  if AcSck <> INVALID_SOCKET then
  begin
    NewSock := TSock.CreateWithSocket(Self, AcSck);
    NewSock.PortName := FPortName;
    NewSock.LocalPortName := FLocalPortName;
    NewSock.HostName := INet_NToA(Addr.SIn_Addr);
    Result := True;
    DoInfo(SiAccept, 'Created New TSock Structure');
  end
  else
  begin
    Result := False;
    DoInfo(SiAccept, 'Could Not Accept Connection');
  end;
end;

function TSock.HostLookup(Value: string): TInAddr;
type
  PLongInt = ^LongInt;
var
  PHost: PHostEnt;
  Res, I: Integer;
  AllNumeric: Boolean;
begin
  if Value = '' then
    Exit;
  DoInfo(SiLookUp, 'Lookup Of Host ' + Value);
  FillChar(Result, SizeOf(TInAddr), #0);
  AllNumeric := True;
  for I := 1 to Length(Value) do
    if not (Value[I] in ['0'..'9', '.']) then
    begin
      AllNumeric := False;
      Break;
    end;
  if AllNumeric then
    Result := TInAddr(WinSock.Inet_Addr(PChar(Value)))
      // If It's Dot-Notation, Just Convert It From An IP Address
  else
  begin
    Res := IPCache.IndexOf(Value);
    if Res >= 0 then
      // It's Cached... Don't Bother Doing A Lookup
      Result.S_Addr := U_Long(IPCache.Objects[Res])
    else
    begin
      // Isn't Cached, Have To Do A GetHostByName
      if Value <> '' then
      begin
        PHost := WinSock.GetHostByName(PChar(Value));
        if PHost <> nil then
        begin
          Result.S_Addr := LongInt(PLongInt(PHost^.H_Addr_List^)^);
          IPCache.AddObject(Value, Pointer(Result.S_Addr));
        end
        else
        begin
          // If Assigned(FOnInfo) then   // added by [e-mail]
            //       FOnInfo(self,siError,'Host Lookup - Could Not Find Host Entry');
           //Raise ESockException.Create('Host Lookup - Could Not Find Host Entry');
        end;
      end
      else
        Result.S_Addr := HToNL(INADDR_ANY);
    end;
  end;
end;

function TSock.PortLookup(Value: string): U_Short;
var
  PEnt: PServEnt;
  Prot: string;
begin
  DoInfo(SiLookUp, 'Lookup Of Port ' + Value);
  if Pos(Value[1], '0123456789') > 0 then
    // It's Numeric, Just Convert It To A Network Byte Order Integer
    Result := HToNS(StrToInt(Value))
  else
  begin
    // Otherwise, Perform A GetServByName Based On The Protocol
    if FSocketType = stStream then
      Prot := 'tcp'
    else
      Prot := 'udp';
    PEnt := WinSock.GetServByName(PChar(Value), PChar(Prot));
    if PEnt <> nil then
      Result := PEnt^.S_Port
    else
      raise ESockException.Create('Port Lookup - Could Not Find Service Entry');
  end;
end;

function TSock.StartListen: Boolean;
begin
  SetListen(True);
  Result := FListen;
end;

function TSock.StopListen: Boolean;
begin
  Result := True;
  SetListen(False);
end;

//*** Additional General-Purpose Support Functions *****************************

function WSDescription: string;
begin
  Result := StrPas(WSAData.szDescription);
end;

function WSSystemStatus: string;
begin
  Result := StrPas(WSAData.szSystemStatus);
end;

function GetLocalHostname: string;
var
  CharHostname: array[0..255] of Char;
begin
  Result := 'localhost';
  if WinSock.GetHostname(CharHostname, SizeOf(CharHostname)) = 0 then
    Result := CharHostname
  else
    raise
      ESockException.Create('GetLocalHostname - Could Not Retrieve Hostname');
end;

function SocketInfoText(Value: TSocketInfo): string;
begin
  Result := SocketInfoMsg[Value];
end;

function ErrToStr(Value: Integer): string;
begin
  Result := 'UNKNOWN ERROR';
  case Value of
    WSABASEERR + 4: Result := 'WSAEINTR';
    WSABASEERR + 9: Result := 'WSAEBADF';
    WSABASEERR + 13: Result := 'WSAEACCES';
    WSABASEERR + 14: Result := 'WSAEFAULT';
    WSABASEERR + 22: Result := 'WSAEINVAL';
    WSABASEERR + 24: Result := 'WSAEMFILE';
    WSABASEERR + 35: Result := 'WSAEWOULDBLOCK';
    WSABASEERR + 36: Result := 'WSAEINPROGRESS';
    WSABASEERR + 37: Result := 'WSAEALREADY';
    WSABASEERR + 38: Result := 'WSAENOTSOCK';
    WSABASEERR + 39: Result := 'WSAEDESTADDRREQ';
    WSABASEERR + 40: Result := 'WSAEMSGSIZE';
    WSABASEERR + 41: Result := 'WSAEPROTOTYPE';
    WSABASEERR + 42: Result := 'WSAENOPROTOOPT';
    WSABASEERR + 43: Result := 'WSAEPROTONOSUPPORT';
    WSABASEERR + 44: Result := 'WSAESOCKTNOSUPPORT';
    WSABASEERR + 45: Result := 'WSAEOPNOTSUPP';
    WSABASEERR + 46: Result := 'WSAEPFNOSUPPORT';
    WSABASEERR + 47: Result := 'WSAEAFNOSUPPORT';
    WSABASEERR + 48: Result := 'WSAEADDRINUSE';
    WSABASEERR + 49: Result := 'WSAEADDRNOTAVAIL';
    WSABASEERR + 50: Result := 'WSAENETDOWN';
    WSABASEERR + 51: Result := 'WSAENETUNREACH';
    WSABASEERR + 52: Result := 'WSAENETRESET';
    WSABASEERR + 53: Result := 'WSAECONNABORTED';
    WSABASEERR + 54: Result := 'WSAECONNRESET';
    WSABASEERR + 55: Result := 'WSAENOBUFS';
    WSABASEERR + 56: Result := 'WSAEISCONN';
    WSABASEERR + 57: Result := 'WSAENOTCONN';
    WSABASEERR + 58: Result := 'WSAESHUTDOWN';
    WSABASEERR + 59: Result := 'WSAETOOMANYREFS';
    WSABASEERR + 60: Result := 'WSAETIMEDOUT';
    WSABASEERR + 61: Result := 'WSAECONNREFUSED';
    WSABASEERR + 62: Result := 'WSAELOOP';
    WSABASEERR + 63: Result := 'WSAENAMETOOLONG';
    WSABASEERR + 64: Result := 'WSAEHOSTDOWN';
    WSABASEERR + 65: Result := 'WSAEHOSTUNREACH';
    WSABASEERR + 66: Result := 'WSAENOTEMPTY';
    WSABASEERR + 67: Result := 'WSAEPROCLIM';
    WSABASEERR + 68: Result := 'WSAEUSERS';
    WSABASEERR + 69: Result := 'WSAEDQUOT';
    WSABASEERR + 70: Result := 'WSAESTALE';
    WSABASEERR + 71: Result := 'WSAEREMOTE';
    WSABASEERR + 91: Result := 'WSASYSNOTREADY';
    WSABASEERR + 92: Result := 'WSAVERNOTSUPPORTED';
    WSABASEERR + 93: Result := 'WSANOTINITIALISED';
    WSABASEERR + 101: Result := 'WSAEDISCON';
    WSABASEERR + 1001: Result := 'WSAHOST_NOT_FOUND';
    WSABASEERR + 1002: Result := 'WSATRY_AGAIN';
    WSABASEERR + 1003: Result := 'WSANO_RECOVERY';
    WSABASEERR + 1004: Result := 'WSANO_DATA';
  end;
end;

// Base-64 Encoding Is The Process Of Taking An Input Stream And Converting
// Every 3 Bytes Into 4 Bytes, Each Of Which Whose ASCII Value Fits Within
// A 64-Bit Range.  Base-64 Is Often Used For Encoding Binary Streams For
// Attaching To Email, But Is Perfect For Converting Binary To A Character
// Set That Can Be Used For URL-Encoding.  The Base-64 Character Set Does Not
// Include Characters That URLs Use For Delimiting Such As '=', '&', Carriage
// Returns, Etc...

function Base64Encode(Value: string): string;
var
  AIn: array[1..3] of Byte;
  AOut: array[1..4] of Byte;
  AWork: array[1..3] of Byte;
  I: Integer;
  O: LongInt;
begin
  Result := '';
  I := 1;
  O := Length(Value);
  case Length(Value) mod 3 of
    1: Value := Value + #0 + #0;
    2: Value := Value + #0;
  end;
  while I < Length(Value) do
  begin
    AIn[1] := Byte(Value[I]);
    AIn[2] := Byte(Value[I + 1]);
    AIn[3] := Byte(Value[I + 2]);

    AOut[1] := Byte(AIn[1] shr 2);
    AWork[1] := Byte(AIn[1] shl 4);
    AWork[2] := Byte(AWork[1] and $30);
    AWork[3] := Byte(AIn[2] shr 4);
    AOut[2] := Byte(AWork[2] or AWork[3]);
    AWork[1] := Byte(AIn[2] shl 2);
    AWork[2] := Byte(AWork[1] and $3C);
    AWork[3] := Byte(AIn[3] shr 6);
    AOut[3] := Byte(AWork[2] or AWork[3]);
    AOut[4] := Byte(AIn[3] and $3F);

    Inc(I, 3);
    Result := Result + Base64Table[AOut[1] + 1] + Base64Table[AOut[2] + 1] +
      Base64Table[AOut[3] + 1] + Base64Table[AOut[4] + 1];
  end;
  if O mod 3 > 0 then
    Result[Length(Result)] := '=';
  if O mod 3 = 1 then
    Result[Length(Result) - 1] := '=';
end;

function Base64Decode(Value: string): string;
var
  AIn: array[1..4] of Byte;
  AOut: array[1..3] of Byte;
  AWork: array[1..3] of Byte;
  I: Integer;
  C: Integer;
begin
  Result := '';
  I := 1;
  while I < Length(Value) do
  begin
    C := 3;
    FillChar(AWork, SizeOf(AWork), #0);
    FillChar(AOut, SizeOf(AWork), #0);
    AIn[1] := Byte(Pos(Value[I], Base64Table) - 1);
    AIn[2] := Byte(Pos(Value[I + 1], Base64Table) - 1);
    AIn[3] := Byte(Pos(Value[I + 2], Base64Table) - 1);
    AIn[4] := Byte(Pos(Value[I + 3], Base64Table) - 1);
    if Value[I + 3] = '=' then
    begin
      C := 2;
      AIn[4] := 0;
      if Value[I + 2] = '=' then
      begin
        C := 1;
        AIn[3] := 0;
      end;
    end;
    AWork[2] := Byte(AIn[1] shl 2);
    AWork[3] := Byte(AIn[2] shr 4);
    AOut[1] := Byte(AWork[2] or AWork[3]);
    AWork[2] := Byte(AIn[2] shl 4);
    AWork[3] := Byte(AIn[3] shr 2);
    AOut[2] := Byte(AWork[2] or AWork[3]);
    AWork[2] := Byte(AIn[3] shl 6);
    AOut[3] := Byte(AWork[2] or AIn[4]);
    Result := Result + Char(AOut[1]);
    if C > 1 then
      Result := Result + Char(AOut[2]);
    if C > 2 then
      Result := Result + Char(AOut[3]);
    Inc(I, 4);
  end;
end;

// This function converts a string into a RFC 1630 compliant URL,
// provided that the string does not contain illegal characters at illegal
// places, for example this URL is invalid because of the ! sign in the password:
// ftp://ward:pass![e-mail]/my_documents/ward@mymail?

function URLEncode(Value: string): string;
var
  I: Integer;
begin
  Result := '';
  for I := 1 to Length(Value) do
  begin
    if Pos(UpperCase(Value[I]), ValidURLChars) > 0 then
      Result := Result + Value[I]
    else
    begin
      if Value[I] = ' ' then
        Result := Result + '+'
      else
      begin
        Result := Result + '%';
        Result := Result + IntToHex(Byte(Value[I]), 2);
      end;
    end;
  end;
end;

function URLDecode(Value: string): string;
const
  HexChars = '0123456789ABCDEF';
var
  I: Integer;
  Ch, H1, H2: Char;
begin
  Result := '';
  I := 1;
  while I <= Length(Value) do
  begin
    Ch := Value[I];
    case Ch of
      '%':
        begin
          H1 := Value[I + 1];
          H2 := Value[I + 2];
          Inc(I, 2);
          Result := Result + Chr(((Pos(H1, HexChars) - 1) * 16) + (Pos(H2,
            HexChars) - 1));
        end;
      '+': Result := Result + ' ';
      '&': Result := Result + #13 + #10;
    else
      Result := Result + Ch;
    end;
    Inc(I);
  end;
end;

//*** Registration And Initialization ******************************************

procedure Register;
begin
  RegisterComponents('Ward', [TSock]);
end;

initialization // (moved to create)
  // We're Looking To Use Version 1.1 Of WinSock Here
{  If WinSock.WSAStartup($0101, WSAData) <> 0 Then
     Raise ESockException.Create('WSAStartup - Could Not Initialize WinSock');
  IPCache := TStringList.Create;
  IPCache.Clear; }
finalization // moved to destroy
  { IPCache.Free;
   WinSock.WSACleanup;  }
end.