Chip 2001 September/Chip_2001-09_cd1.bin/zkuste/delphi/nastroje/d5/MFTP.ZIP/src/FtpSock.pas

Pascal/Delphi Source File | 2001-01-03 | 15KB | 509 lines

unit FTPSock;

{Microsoft Windows Socket implementation of Monster FTP}
interface

uses Classes, Windows, Messages, SysUtils, WinSock;

{$I mftp.inc}

{$ifdef USE_WINSOCK2}
   const SockLibName = 'ws2_32.dll';
{$else}
   const SockLibName = 'wsock32.dll';
{$endif}

type
   sockaddr_in = record
      sin_family: SmallInt;
      sin_port: u_short;
      sin_addr: TInAddr;
      sin_zero: array[0..7] of Char;
   end;

  in6_addr = record
    case integer of
      0: (S_un_b: array[0..15] of Char);
      1: (S_un_w: array[0..7] of Word);
  end;
  TInAddr6 = in6_addr;

   sockaddr_in6 = record
      sin6_family: SmallInt;
      sin6_port: u_short;       { Transport level port number }
      sin6_flowinfo: Longword;  { IPv6 flow information }
      sin6_addr: TInAddr6;      { IPv6 address }
      sin6_scope_id: Longword;  { set of interfaces for a scope }
   end;

   sockaddr = record
      sa_family: u_short;
      sa_data: array[0..13] of Char; { should be 0..13 ?}
   end;

   PInteger = ^Integer;
   PSockAddr = ^SockAddr;

   function accept(s: TSocket; addr: PSockaddr; addrlen: PInteger): TSocket; stdcall; external SockLibName;
   function bind(s: TSocket; addr: Psockaddr; namelen: Integer): Integer; stdcall; external SockLibName;
   function closesocket(s: TSocket): Integer; stdcall; external SockLibName;
   function connect(s: TSocket; name: Psockaddr; namelen: Integer): Integer; stdcall; external SockLibName;
   function gethostname(name: PChar; len: Integer): Integer; stdcall; external SockLibName;
   function getsocketname(s: TSocket; name: Psockaddr; namelen: PInteger): Integer; stdcall; external SockLibName name 'getsockname';
   function htons(hostshort: u_short): u_short; stdcall; external SockLibName;
   function inet_addr(cp: PChar): u_long; stdcall; external SockLibName;
   function inet_ntoa(inaddr: TInAddr): PChar; stdcall; external SockLibName;
   function listen(s: TSocket; backlog: Integer): Integer; stdcall; external SockLibName;
   function ntohs(netshort: u_short): u_short; stdcall; external SockLibName;
   function recv(s: TSocket; buf: PChar; len, flags: Integer): Integer; stdcall; external SockLibName;
   function send(s: TSocket; buf: PChar; len, flags: Integer): Integer; stdcall; external SockLibName;
   function socket(af, tp, protocol: Integer): TSocket; stdcall; external SockLibName;
   function WSAAsyncGetHostByName(HWindow: HWND; wMsg: u_int; name, buf: PChar; buflen: Integer): THandle; stdcall; external SockLibName;
   function WSAAsyncSelect(s: TSocket; HWindow: HWND; wMsg: u_int; lEvent: longint): Integer; stdcall; external SockLibName;
   function WSACancelAsyncRequest(hAsyncTaskHandle: THandle): Integer; stdcall; external SockLibName;
   function WSACleanup: Integer; stdcall; external SockLibName;
   function WSAGetLastError: Integer; stdcall; external SockLibName;
   function WSAStartup(wVersionRequired: Word; var lpWSData: TWSAData): Integer; stdcall; external SockLibName;

const
   WM_ARPDONE = WM_USER;
   WM_SOCKMSG = WM_USER + 1;

type TSSWndMethod = procedure(var Message: TMessage) of object;

type TMSocket = class(TComponent)
   private
      FHandle: HWND;
      FSocket: TSocket;
      FAddr: sockaddr_in;
      FConnected: boolean;
      FBytesSent: Integer;
      FDescription: String;
      FSystemStatus: String;
      FMaxSockets: Integer;
      FCustomMessage: TSSWndMethod;
      MyWSAData: TWSAData;
      FLookupNameDone, FOnConnected, FOnDisconnected, FTimeoutEvt: TNotifyEvent;
      FOnReadReady, FOnWriteReady, FOnAccept: TNotifyEvent;
      THostEntryBuf: array[1..MAXGETHOSTSTRUCT] of Byte;
      sa: TInAddr;
      ArpHandle: THandle;
      FTimeOut: LongInt;
      Timer: LongInt;
      TimerID: LongInt;
      dnsbuf: array[1..64] of Char;
      procedure SockWndProc(var Message: TMessage);
   protected
      FVersion: String;
      procedure LookupNameDone; virtual;
      procedure Connected;
      procedure Disconnected;
   public
      Address, Host, FServer: String;
      FPort: u_short;
      LastError: Word;
      WantBlockingErrors: Boolean;
      constructor Create(AOwner: TComponent); override;
      destructor Destroy; override;
      property Version: String read FVersion;

      procedure CreateTCPSocket;
      procedure ReCreateTCPSocket;
      procedure LookupName(host: String);
      procedure FillName;
      procedure FillAddress(address: String);
      procedure FillPort(port: Word);
      procedure Connect;
      procedure Disconnect;
      procedure Listen;
      procedure Accept(ListeningSocket: TMSocket);
      function GetAddressString: String;
      function GetLocalHost: String;
      function GetLocalAddress: String;
      function GetLocalPort: u_short;
      function SendBuf(buf: PChar; cnt: Integer): Integer;
      function SendBufOOB(buf: PChar; cnt: Integer): Integer;
      function RecvBuf(buf: PChar; cnt: Integer): Integer;
      procedure SetServer(s: String);
      procedure SetTimeout(seconds: LongInt);

      property Description: String read FDescription;
      property SystemStatus: String read FSystemStatus;
      property MaxSockets: Integer read FMaxSockets;
      property Handle: HWND read FHandle;
      property CustomMessage: TSSWndMethod read FCustomMessage write FCustomMessage;
      property IsConnected: Boolean read FConnected;
      property Socket: TSocket read FSocket;
      property OnLookupNameDone: TNotifyEvent read FLookupNameDone write FLookupNameDone;
      property OnConnected: TNotifyEvent read FOnConnected write FOnConnected;
      property OnDisconnected: TNotifyEvent read FOnDisconnected write FOnDisconnected;
      property OnReadReady: TNotifyEvent read FOnReadReady write FOnReadReady;
      property OnWriteReady: TNotifyEvent read FOnWriteReady write FOnWriteReady;
      property OnTimeOut: TNotifyEvent read FTimeOutEvt write FTimeOutEvt;
      property OnAccept: TNotifyEvent read FOnAccept write FOnAccept;
      property TimeOut: LongInt read FTimeOut write FTimeOut;

      property Server: String read FServer write SetServer;
      property Port: u_short read FPort write FPort;
   published
   end;

var
   S_un: TInAddr;

implementation

uses Forms;

constructor TMSocket.Create;
begin
   inherited Create(AOwner);

   FAddr.sin_family := PF_INET;
   FAddr.sin_addr.s_addr := INADDR_ANY;
   FAddr.sin_port := 0;
   FHandle := AllocateHWND(SockWndProc);
   FSocket := INVALID_SOCKET;
   FConnected := False;
   FBytesSent := 0;
   FTimeOut := 20;

   if WSAStartup($0002, myWSAData) = 0 then
   begin
       with myWSAData do
       begin
          FDescription := StrPas(szDescription);
          FSystemStatus := StrPas(szSystemStatus);
          FMaxSockets := iMaxSockets;
       end;
   end;

   WantBlockingErrors := False;
end;

destructor TMSocket.Destroy;
begin
   FSocket := -1;
   DeallocateHwnd(FHandle);
   WSACleanUp;

   inherited Destroy;
end;

procedure TMSocket.SockWndProc;
var phe: PHostEnt;
    evt: Word;
begin
   if (Message.Msg > WM_SOCKMSG) and Assigned(FCustomMessage) then
   begin
      FCustomMessage(Message);
      Exit;
   end;
   case Message.Msg of
      {custom messages}
      WM_ARPDONE: {received after WSAAsyncGetHostByName}
      begin
         SetTimeout(0);
         LastError := HIWORD(Message.lParam);
         if LastError = 0 then
         begin
            phe := PHostEnt(@THostEntryBuf);
            with sa, phe^ do
            begin
               S_un_b.s_b1 := h_addr^[0];
               S_un_b.s_b2 := h_addr^[1];
               S_un_b.s_b3 := h_addr^[2];
               S_un_b.s_b4 := h_addr^[3];
            end;
         end;
         ArpHandle := 0;
         LookupNameDone;
      end;
      WM_SOCKMSG:  {received after connect, read, write, disconnect notification}
      begin
         evt := LOWORD(Message.lParam);
         LastError := HIWORD(Message.lParam);
         case evt of
            FD_CONNECT:
            begin
               FConnected := (LastError = 0);
               SetTimeOut(0);
               Connected;
            end;
            FD_CLOSE:
            begin
               if FConnected then
               begin
                  if Assigned(FOnReadReady) then FOnReadReady(Self);
                  if Assigned(FOnWriteReady) then FOnWriteReady(Self);
                  ShutDown(FSocket, 2);
                  CloseSocket(FSocket);
               end;
               FConnected := False;
               FSocket := INVALID_SOCKET;
               Disconnected;
            end;
            FD_READ:
            begin
               if Assigned(FOnReadReady) then FOnReadReady(Self);
               SetTimeOut(0);
            end;
            FD_WRITE: if Assigned(FOnWriteReady) then FOnWriteReady(Self);
            FD_ACCEPT: if Assigned(FOnAccept) then FOnAccept(Self);
         end;
      end;
      {end custom messages}
      WM_TIMER:
      begin
         Dec(Timer);
         if Timer = 0 then
         begin
            if Assigned(FTimeoutEvt) then
               FTimeoutEvt(Self)
            else
               Disconnect;
         end;
      end;
      WM_QUERYENDSESSION: Message.Result := 1; {end session bug}
      else DefWindowProc(FHandle, Message.Msg, Message.wParam, Message.lParam);
   end;
end;

procedure TMSocket.SetTimeout;
begin
   if TimerID <> 0 then KillTimer(FHandle, TimerID);
   if seconds <= 0 then
      TimerId := 0
   else
   begin
      Timer := seconds;
      TimerID := SetTimer(FHandle, 1, 1000, nil);
   end;
end;

procedure TMSocket.CreateTCPSocket;
begin
   if FSocket <> INVALID_SOCKET then Exit;
   FSocket := FTPSock.socket(PF_INET, SOCK_STREAM, IPPROTO_IP);
   LastError := WSAGetLastError
end;

procedure TMSocket.ReCreateTCPSocket;
begin
   CloseSocket(FSocket);
   FSocket := INVALID_SOCKET;
   CreateTCPSocket;
end;

function TMSocket.GetAddressString;
begin
   Result := StrPas(inet_ntoa(FAddr.sin_addr));
end;

procedure TMSocket.LookupName;
begin
   if ArpHandle <> 0 then Exit;
   StrPCopy(@dnsbuf, host);
   ArpHandle := WSAAsyncGetHostByName(FHandle, WM_ARPDONE, @dnsbuf, @THostEntryBuf, MAXGETHOSTSTRUCT);
   LastError := WSAGetLastError;
   if LastError = 0 then SetTimeout(FTimeOut);
end;

procedure TMSocket.FillName;
begin
   FAddr.sin_addr := sa;
end;

procedure TMSocket.FillAddress;
var
   s: array [1..32] of Char;
begin
   StrPCopy(@s, address);
   FAddr.sin_addr.s_addr := inet_addr(@s);
end;

procedure TMSocket.FillPort;
begin
   FAddr.sin_port := htons(port);
end;

procedure TMSocket.LookupNameDone;
begin
   if Assigned(FLookupNameDone) then FLookupNameDone(Self);
end;

procedure TMSocket.Connected;
begin
   if Assigned(FOnConnected) then FOnConnected(Self);
end;

procedure TMSocket.Disconnected;
begin
   if Assigned(FOnDisconnected) then FOnDisconnected(Self);
end;

procedure TMSocket.Connect;
begin
   WSAAsyncSelect(FSocket, FHandle, WM_SOCKMSG, FD_CONNECT or FD_CLOSE or FD_READ or FD_WRITE);
   if FTPSock.connect(FSocket, Psockaddr(@FAddr), SizeOf(FAddr)) <> 0 then
   begin
      LastError := WSAGetLastError;
      if not WantBlockingErrors then
         if LastError = WSAEWOULDBLOCK then LastError := 0;
   end;
   if LastError = 0 then SetTimeout(FTimeOut);
end;

procedure TMSocket.Listen;
begin
   bind(FSocket, Psockaddr(@FAddr), SizeOf(FAddr));
   LastError := WSAGetLastError;

   if LastError = 0 then
   begin
      WSAAsyncSelect(FSocket, FHandle, WM_SOCKMSG, FD_ACCEPT);
      FTPSock.listen(FSocket, 2);
      LastError := WSAGetLastError;
   end;
end;

procedure TMSocket.Accept;
var
   nl: Integer;
begin
   nl := sizeof(sockaddr_in);
   FSocket := FTPSock.accept(ListeningSocket.Socket, PSockaddr(@FAddr), @nl);
   LastError := WSAGetLastError;

   if LastError = 0 then
   begin
      FConnected := True;
      WSAAsyncSelect(FSocket, FHandle, WM_SOCKMSG, FD_CLOSE or FD_READ or FD_WRITE);
   end;
end;

procedure TMSocket.Disconnect;
begin
   if ArpHandle <> 0 then WSACancelAsyncRequest(ArpHandle);
   SetTimeout(0);
   if FSocket <> INVALID_SOCKET then
   begin
      WSAAsyncSelect(FSocket, FHandle, WM_SOCKMSG, FD_CLOSE);
      CloseSocket(FSocket);
      LastError := WSAGetLastError;
      FSocket := INVALID_SOCKET;
      FConnected := False;
      Disconnected;
   end;
end;

function TMSocket.SendBuf;
var
   n: Integer;
begin
   Result := 0;
   n := send(FSocket, buf, cnt, 0);
   if n > 0 then
   begin
      Result := n;
      LastError := 0;
   end
   else if (n = SOCKET_ERROR) then
   begin
      LastError := WSAGetLastError;
      if not WantBlockingErrors then
         if LastError = WSAEWOULDBLOCK then LastError := 0;
   end;
end;

function TMSocket.SendBufOOB;
var
   n: Integer;
begin
   Result := 0;
   n := send(FSocket, buf, cnt, MSG_OOB);
   if n > 0 then
   begin
      Result := n;
      LastError := 0;
   end
   else if (n = SOCKET_ERROR) then
   begin
      LastError := WSAGetLastError;
      if not WantBlockingErrors then
         if LastError = WSAEWOULDBLOCK then LastError := 0;
   end;
end;

function TMSocket.RecvBuf;
var
   n: Integer;
begin
   Result := 0;
   n := recv(FSocket, buf, cnt, 0);
   if n > 0 then
   begin
      Result := n;
      LastError := 0;
   end
   else if (n = SOCKET_ERROR) then
   begin
      LastError := WSAGetLastError;
      if not WantBlockingErrors then
         if LastError = WSAEWOULDBLOCK then LastError := 0;
   end;
end;

function TMSocket.GetLocalHost;
var
   sh: array [0..255] of Char;
begin
   if gethostname(sh, 255) = 0 then Result := StrPas(sh)
   else Result := '';
   LastError := WSAGetLastError;
end;

function TMSocket.GetLocalAddress: String;
var
   sa: sockaddr_in;
   nl: Integer;
begin
   Result := '';
   nl := SizeOf(sa);
   if FSocket = INVALID_SOCKET then exit;
   if geTSocketname(FSocket, PSockaddr(@sa), @nl) = 0 then Result := StrPas(inet_ntoa(sa.sin_addr));
   LastError := WSAGetLastError;
end;

function TMSocket.GetLocalPort;
var
   sa: sockaddr_in;
   nl: Integer;
begin
   Result := 0;
   nl := Sizeof(sa);
   if FSocket = INVALID_SOCKET then exit;
   if geTSocketname(FSocket, PSockaddr(@sa), @nl) = 0 then Result := ntohs(sa.sin_port);
   LastError := WSAGetLastError;
end;

procedure TMSocket.SetServer;
begin
   FServer := Trim(S);
   if FServer <> '' then
   begin
      if (FServer[1] >= '0') and (FServer[1] <= '9') then
      begin
         Address := FServer;
         Host := '';
      end
      else
      begin
         Host := FServer;
         Address := '';
      end;
   end;
end;

end.