mysock.pas

< Delphi网络通信协议分析与应用实现>>一书的源代码。

        end;
        Close;
      End;
  ProcessMessages;
End;


Constructor TCustomServerSock.Create(AOwner : TComponent);
Begin
   Inherited Create(AOwner);
   FPortName := '';
   FSocket := INVALID_SOCKET;
   FActive := False;
   FClientList := TThreadList.Create;
End;

Destructor TCustomServerSock.Destroy;
Begin
   If FActive then
      Close;
   FClientlist.Free;
   Inherited Destroy;
End;

Procedure TCustomServerSock.Loaded;
Begin
   If Not (csDesigning In ComponentState) Then Begin
     If FActive Then Begin
       fActive:= False;
       SetListen(True);
     End;
   End;
End;


Procedure TCustomServerSock.OnSockMessage(Var Message : TMessage);
Var Event : Word;
    Error : Word;
    AcSck : TSocket;
    Addr  : TSockAddrIn;
    AddrL : Integer;
    CSock : TClientSockserv;
    Spawn : TSockThread;
Begin
   Event := WinSock.WSAGetSelectEvent(Message.LParam);
   Error := WinSock.WSAGetSelectError(Message.LParam);
   If Error > WSABASEERR Then
     exit
   Else
      // Messages Mean Different Things Depending On Whether You're Listening Or Not
      Case Event Of
         FD_ACCEPT  : Begin
                        AddrL := SizeOf(Addr);
                        FillChar(Addr, SizeOf(Addr), #0);
   {$IFDEF VER3ORABOVE}
                        AcSck := WinSock.Accept(FSocket, @Addr, @AddrL);
   {$ELSE}
                        AcSck := WinSock.Accept(FSocket, @Addr, @AddrL);
   {$ENDIF}
                        if AcSck=0 then begin

                        end;
//                               FRecvAddrIn := Addr;
                        if MaxClient<> 0 then begin
                          if getclientcount+1>maxclient then begin
                            if assigned(FOnMaxClient) then begin
                              CSock := TClientSockserv.CreateWithSocket(self, AcSck);
                              fonMaxClient(self, CSock);
                              CSock.Free;
                            end else begin
                              CSock := TClientSockserv.CreateWithSocket(self, AcSck);
                              CSock.Abort;
                              CSock.Free;
                            end;
                            exit;
                          end;
                        end;
                        Spawn := TSockThread.Create(True);
                        Spawn.RunThread(Self, AcSck, INet_NToA(Addr.SIn_Addr));
      End;
   else
     Message.Result := DefWindowProc(Handle, Message.Msg, message.Wparam, Message.Lparam);
   end;
End;


Function TCustomServerSock.PortLookup(Value : String) : U_Short;
Var PEnt : PServEnt;
Begin
   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
         PEnt := WinSock.GetServByName(PChar(Value), 'tcp');
         If PEnt <> Nil Then
            Result := PEnt^.S_Port
         Else
            Raise ESockException.Create('Port Lookup - Could Not Find Service Entry');
      End;
End;

// TServerSock
Procedure TServerSock.DoAutoAccept(Sender : TObject; NewSock : TClientSockserv);
begin
  if assigned(fonAutoAccept) then
    fonAutoAccept(sender, newsock);
end;
function LocalHostName : String;
begin
  result:=HostName;;
end;

Function WSDescription : String;
Begin
   Result := StrPas(WSAData.szDescription);
End;

Function WSSystemStatus : String;
Begin
   Result := StrPas(WSAData.szSystemStatus);
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;

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;

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;

Procedure Register;
Begin
  RegisterComponents('TSock', [TClientSock, TServerSock]);
End;

function IpAddress : string;
var
  p: pHostEnt;
  T : PInAddr;
begin
  p:=gethostbyname(pchar(hostname));
  if p=nil then begin
    result:='127.0.0.1';
    exit;
  end;
  t:=PInAddr(p.h_addr_list^);
  if t<>nil then begin
    result:=StrPas(inet_ntoa(t^));
  end;
end;

var
  Buffer : array [1..64] of char;

Initialization
   If WinSock.WSAStartup($0101, WSAData) <> 0 Then
      Raise ESockException.Create('WSAStartup - Could Not Initialize WinSock');
   IPCache := TStringList.Create;
  if gethostname(@Buffer, SizeOf(Buffer)) <> 0 then
    HostName:='127.0.0.1'
  else
    HostName:= StrPas(@Buffer);

Finalization
   IPCache.Free;
   WinSock.WSACleanup;
End.