{$I M_OPS.PAS}

Unit m_Socket_Class;

Interface

Uses
  {$IFDEF OS2}
    WinSock,
  {$ENDIF}
  {$IFDEF WIN32}
    Windows,
    Winsock2,
  {$ENDIF}
  {$IFDEF UNIX}
    BaseUnix,
    cNetDB,
  {$ENDIF}
  Sockets,
  Classes,
  m_DateTime,
  m_Strings;

Const
  TSocketBufferSize = 8 * 1024 - 1;

Type
  TSocketBuffer = Array[0..TSocketBufferSize] of Char;

  TSocketClass = Class
    SocketStatus   : TStringList;
    StatusUpdated  : Boolean;
    FSocketHandle  : LongInt;
    FPort          : LongInt;
    FPeerName      : String;
    FPeerIP        : String;
    FHostIP        : String;
    FInBuf         : TSocketBuffer;
    FInBufPos      : LongInt;
    FInBufEnd      : LongInt;
    FOutBuf        : TSocketBuffer;
    FOutBufPos     : LongInt;
    FTelnetState   : Byte;
    FTelnetReply   : Array[1..14] of Char;
    FTelnetCmd     : Char;
    FTelnetSubCmd  : Char;
    FTelnetLen     : Byte;
    FTelnetEcho    : Boolean;
    FTelnetSubData : String;
    FTelnetClient  : Boolean;
    FTelnetServer  : Boolean;

    Constructor Create;
    Destructor  Destroy; Override;
    Procedure   Disconnect;
    Function    DataWaiting     : Boolean;
    Function    WriteBuf        (Var Buf; Len: LongInt) : LongInt;
    Procedure   BufFlush;
    Procedure   BufWriteChar    (Ch: Char);
    Procedure   BufWriteStr     (Str: String);
    Function    WriteLine       (Str: String) : LongInt;
    Function    WriteStr        (Str: String) : LongInt;
    Function    WriteFile       (Str: String) : Boolean;
    Procedure   ProcessBuf      (Var Buf: TSocketBuffer; Var Len: LongInt);
    Function    ReadBuf         (Var Buf; Len: LongInt) : LongInt;
    Function    ReadLine        (Var Str: String) : LongInt;
    Function    SetBlocking     (Block: Boolean): LongInt;
    Function    WaitForData     (TimeOut: LongInt) : LongInt;
    Function    Connect         (Address: String; Port: Word) : Boolean;
    Function    ResolveAddress  (Host: String) : LongInt;
    Procedure   WaitInit        (Port: Word);
    Function    WaitConnection  : TSocketClass;
    Procedure   PurgeInputData;
    Function    ReadChar        : Char;
    Function    WriteChar       (Ch: Char) : LongInt;
    Procedure   Status          (Str: String);

    Property SocketHandle : LongInt READ FSocketHandle WRITE FSocketHandle;
    Property PeerPort     : LongInt READ FPort         WRITE FPort;
    Property PeerName     : String  READ FPeerName     WRITE FPeerName;
    Property PeerIP       : String  READ FPeerIP       WRITE FPeerIP;
    Property HostIP       : String  READ FHostIP       WRITE FHostIP;
  End;

Implementation

{ TELNET NEGOTIATION CONSTANTS }

Const
  Telnet_IAC    = #255;
  Telnet_DONT   = #254;
  Telnet_DO     = #253;
  Telnet_WONT   = #252;
  Telnet_WILL   = #251;
  Telnet_SB     = #250;
  Telnet_BINARY = #000;
  Telnet_ECHO   = #001;
  Telnet_SE     = #240;
  Telnet_TERM   = #24;
  Telnet_SGA    = #003;

  FPSENDOPT     = 0;
  FPRECVOPT     = 0;

Constructor TSocketClass.Create;
Begin
  Inherited Create;

  FSocketHandle := -1;
  FPort         := 0;
  FPeerName     := 'Unknown';
  FPeerIP       := FPeerName;
  FInBufPos     := 0;
  FInBufEnd     := 0;
  FOutBufPos    := 0;
  FTelnetState  := 0;
  FTelnetEcho   := False;
  FTelnetClient := False;
  FTelnetServer := False;
{  FHostIP       := '127.0.0.1';}
  FHostIP       := '';
  StatusUpdated := False;

  SocketStatus := TStringList.Create;
End;

Destructor TSocketClass.Destroy;
Begin
  Disconnect;

  SocketStatus.Free;

  Inherited Destroy;
End;

Procedure TSocketClass.PurgeInputData;
Var
  Buf : Array[1..1024] of Char;
Begin
  If FSocketHandle = -1 Then Exit;

  If DataWaiting Then
    Repeat
    Until ReadBuf(Buf, SizeOf(Buf)) <> 1024;
End;

Procedure TSocketClass.Disconnect;
Begin
  If FSocketHandle <> -1 Then Begin
    fpShutdown(FSocketHandle, 2);
    CloseSocket(FSocketHandle);

    FSocketHandle := -1;
  End;
End;

Function TSocketClass.DataWaiting : Boolean;
Begin
  Result := (FInBufPos < FInBufEnd) or (WaitForData(0) > 0);
End;

Function TSocketClass.WriteBuf (Var Buf; Len: LongInt) : LongInt;
Begin
  Result := fpSend(FSocketHandle, @Buf, Len, FPSENDOPT);
End;

Procedure TSocketClass.BufFlush;
Begin
  If FOutBufPos > 0 Then Begin
    WriteBuf (FOutBuf, FOutBufPos);

    FOutBufPos := 0;
  End;
End;

Procedure TSocketClass.BufWriteChar (Ch: Char);
Begin
  FOutBuf[FOutBufPos] := Ch;
  Inc(FOutBufPos);

  If FOutBufPos > TSocketBufferSize Then Begin
    WriteBuf (FOutBuf, FOutBufPos - 1);

    FOutBufPos := 0;
  End;
End;

Procedure TSocketClass.BufWriteStr (Str: String);
Var
  Count : LongInt;
Begin
  For Count := 1 to Length(Str) Do
    BufWriteChar(Str[Count]);
End;

Function TSocketClass.WriteLine (Str: String) : LongInt;
Begin
  Str    := Str + #13#10;
  Result := fpSend(FSocketHandle, @Str[1], Length(Str), FPSENDOPT);
End;

Function TSocketClass.WriteChar (Ch: Char) : LongInt;
Begin
  Result := fpSend(FSocketHandle, @Ch, 1, FPSENDOPT);
End;

Function TSocketClass.WriteStr (Str: String) : LongInt;
Begin
  Result := fpSend(FSocketHandle, @Str[1], Length(Str), FPSENDOPT);
End;

Function TSocketClass.WriteFile (Str: String) : Boolean;
Var
  Buf  : Array[1..4096] of Char;
  Size : LongInt;
  F    : File;
Begin
  Result := False;

  FileMode := 66;

  Assign (F, Str);
  Reset  (F, 1);

  If IoResult <> 0 Then Exit;

  Repeat
    BlockRead (F, Buf, SizeOf(Buf), Size);

    If Size = 0 Then Break;

    If Buf[Size] = #26 Then Dec(Size);

    WriteBuf (Buf, Size);
  Until Size <> SizeOf(Buf);

  Result := True;
End;

Procedure TSocketClass.ProcessBuf (Var Buf: TSocketBuffer; Var Len: LongInt);

  Procedure SendCommand (YesNo, CmdType: Char);
  Var
    Reply : String[3];
  Begin
    Reply[1] := Telnet_IAC;
    Reply[2] := Char(YesNo); {DO/DONT, WILL/WONT}
    Reply[3] := CmdType;

    fpSend (FSocketHandle, @Reply[1], 3, FPSENDOPT);
  End;

  Procedure SendData (CmdType: Char; Data: String);
  Var
    Reply   : String;
    DataLen : Byte;
  Begin
    DataLen  := Length(Data);
    Reply[1] := Telnet_IAC;
    Reply[2] := Telnet_SB;
    Reply[3] := CmdType;
    Reply[4] := #0;

    Move (Data[1], Reply[5], DataLen);

    Reply[5 + DataLen] := #0;
    Reply[6 + DataLen] := Telnet_IAC;
    Reply[7 + DataLen] := Telnet_SE;

    fpSend (FSocketHandle, @Reply[1], 7 + DataLen, FPSENDOPT);
  End;

Var
  Count     : LongInt;
  TempPos   : LongInt;
  Temp      : TSocketBuffer;
  ReplyGood : Char;
  ReplyBad  : Char;
Begin
  TempPos := 0;

  For Count := 0 to Len - 1 Do Begin
    Case FTelnetState of
      1 : If Buf[Count] = Telnet_IAC Then Begin
            FTelnetState := 0;
            Temp[TempPos] := Telnet_IAC;
            Inc (TempPos);
          End Else Begin
            Inc (FTelnetState);
            FTelnetCmd := Buf[Count];
          End;
      2 : Begin
            FTelnetState := 0;

            Case FTelnetCmd of
              Telnet_WONT : Begin
//                              FTelnetSubCmd := Telnet_DONT;
//                              SockSend(FSocketHandle, FTelnetSubCmd, 1, 0);
                            End;
              Telnet_DONT : Begin
//                              FTelnetSubCmd := Telnet_WONT;
//                              SockSend(FSocketHandle, FTelnetSubCmd, 1, 0);
                            End;
              Telnet_SB   : Begin
                              FTelnetState  := 3;
                              FTelnetSubCmd := Buf[Count];
                            End;
              Telnet_WILL,
              Telnet_DO   : Begin
                              If FTelnetCmd = Telnet_DO Then Begin
                                ReplyGood := Telnet_WILL;
                                ReplyBad  := Telnet_WONT;
                              End Else Begin
                                ReplyGood := Telnet_DO;
                                ReplyBad  := Telnet_DONT;
                              End;

                              If FTelnetClient Then Begin
                                Case Buf[Count] of
                                  Telnet_BINARY,
                                  Telnet_ECHO,
                                  Telnet_SGA,
                                  Telnet_TERM : SendCommand(ReplyGood, Buf[Count])
                                Else
                                  SendCommand(ReplyBad, Buf[Count]);
                                End;

                                If Buf[Count] = Telnet_Echo Then
                                  FTelnetEcho := (FTelnetCmd = Telnet_DO);
                              End Else Begin
                                Case Buf[Count] of
                                  Telnet_ECHO : FTelnetEcho := True;
                                  Telnet_SGA  : ;
                                Else
                                  SendCommand(ReplyBad, Buf[Count]);
                                End;
                              End;
                            End;
            End;
          End;
      3 : If Buf[Count] = Telnet_SE Then Begin
            If FTelnetClient Then
              Case FTelnetSubCmd of
                Telnet_TERM : SendData(Telnet_TERM, 'vt100');
              End;

            FTelnetState   := 0;
            FTelnetSubData := '';
          End Else
            FTelnetSubData := FTelnetSubData + Buf[Count];
    Else
      If Buf[Count] = Telnet_IAC Then Begin
        Inc (FTelnetState);
      End Else Begin
        Temp[TempPos] := Buf[Count];
        Inc (TempPos);
      End;
    End;
  End;

  Buf := Temp;
  Len := TempPos;
End;

Function TSocketClass.ReadChar : Char;
Var
  Ch : Char;
Begin
  ReadBuf(Ch, 1);
  Result := Ch;
End;

Function TSocketClass.ReadBuf (Var Buf; Len: LongInt) : LongInt;
Begin
  If FInBufPos = FInBufEnd Then Begin
    FInBufEnd := fpRecv(FSocketHandle, @FInBuf, TSocketBufferSize, FPRECVOPT);
    FInBufPos := 0;
    If FInBufEnd <= 0 Then Begin
      FInBufEnd := 0;
      Result    := -1;
      Exit;
    End;

    If FTelnetClient or FTelnetServer Then ProcessBuf(FInBuf, FInBufEnd);
  End;

  If Len > FInBufEnd - FInBufPos Then Len := FInBufEnd - FInBufPos;

  Move (FInBuf[FInBufPos], Buf, Len);
  Inc  (FInBufPos, Len);

  Result := Len;
End;

Function TSocketClass.ReadLine (Var Str: String) : LongInt;
Var
  Ch  : Char;
  Res : LongInt;
Begin
  Str := '';
  Res := 0;

  Repeat
    If FInBufPos = FInBufEnd Then Res := ReadBuf(Ch, 0);

    Ch := FInBuf[FInBufPos];
    Inc (FInBufPos);
    If (Ch <> #10) And (Ch <> #13) And (FInBufEnd > 0) Then Str := Str + Ch;
  Until (Ch = #10) Or (Res < 0) Or (FInBufEnd = 0);

  If Res < 0 Then Result := -1 Else Result := Length(Str);
End;

Function TSocketClass.SetBlocking (Block: Boolean): LongInt;
//Var
//  Data : DWord;
Begin
  If FSocketHandle = -1 Then Begin
    Result := FSocketHandle;
    Exit;
  End;

//  Data   := Ord(Not Block);
//  Result := ioctlSocket(FSocketHandle, FIONBIO, Data);
End;

Function TSocketClass.WaitForData (TimeOut: LongInt) : LongInt;
Var
  T      : TTimeVal;
  rFDSET,
  wFDSET,
  eFDSET : TFDSet;
Begin
  T.tv_sec  := 0;
  T.tv_usec := TimeOut * 1000;

  {$IFDEF UNIX}
    fpFD_Zero(rFDSET);
    fpFD_Zero(wFDSET);
    fpFD_Zero(eFDSET);
    fpFD_Set(FSocketHandle, rFDSET);
    Result := fpSelect(FSocketHandle + 1, @rFDSET, @wFDSET, @eFDSET, @T);
  {$ELSE}
    FD_Zero(rFDSET);
    FD_Zero(wFDSET);
    FD_Zero(eFDSET);
    FD_Set(FSocketHandle, rFDSET);
    Result := Select(FSocketHandle + 1, @rFDSET, @wFDSET, @eFDSET, @T);
  {$ENDIF}
End;

Function TSocketClass.ResolveAddress (Host: String) : LongInt;
Var
  HostEnt : PHostEnt;
Begin
  Host    := Host + #0;
  HostEnt := GetHostByName(@Host[1]);

  If Assigned(HostEnt) Then
    Result := PInAddr(HostEnt^.h_addr_list^)^.S_addr
  Else
    Result := LongInt(StrToNetAddr(Host));
//    Result := NetAddrToStr(@Host[1]);
End;

Function TSocketClass.Connect (Address: String; Port: Word) : Boolean;
Var
  Sin : TINetSockAddr;
Begin
  Result        := False;
  FSocketHandle := fpSocket(PF_INET, SOCK_STREAM, 0);

  If FSocketHandle = -1 Then Exit;

  FPeerName := Address;

  FillChar(Sin, SizeOf(Sin), 0);

  Sin.sin_Family      := PF_INET;
  Sin.sin_Port        := htons(Port);
  Sin.sin_Addr.S_Addr := ResolveAddress(Address);

  FPeerIP   := NetAddrToStr(Sin.Sin_Addr);
  Result    := fpConnect(FSocketHandle, @Sin, SizeOf(Sin)) = 0;
End;

Procedure TSocketClass.WaitInit (Port: Word);
Var
  SIN : TINetSockAddr;
  Opt : LongInt;
Begin
  FSocketHandle := fpSocket(PF_INET, SOCK_STREAM, 0);

  Opt := 1;

  fpSetSockOpt (FSocketHandle, SOL_SOCKET, SO_REUSEADDR, @Opt, SizeOf(Opt));

  SIN.sin_family      := PF_INET;
  SIN.sin_addr.s_addr := 0;
  SIN.sin_port        := htons(Port);

  fpBind(FSocketHandle, @SIN, SizeOf(SIN));

  SetBlocking(True);
End;

Function TSocketClass.WaitConnection : TSocketClass;
Var
  Sock   : LongInt;
  Client : TSocketClass;
  PHE    : PHostEnt;
  SIN    : TINetSockAddr;
  Temp   : LongInt;
  SL     : TSockLen;
Begin
  Result := NIL;

  If fpListen(FSocketHandle, 5) = -1 Then Exit;

  Temp := SizeOf(SIN);
  Sock := fpAccept(FSocketHandle, @SIN, @Temp);

  If Sock = -1 Then Exit;

  FPeerIP := NetAddrToStr(SIN.sin_addr);

  PHE := GetHostByAddr(@SIN.sin_addr, 4, PF_INET);
  If Not Assigned(PHE) Then
    FPeerName := 'Unknown'
  Else
    FPeerName := StrPas(PHE^.h_name);

  SL := SizeOf(SIN);

  fpGetSockName(FSocketHandle, @SIN, @SL);

  FHostIP := NetAddrToStr(SIN.sin_addr);
  Client  := TSocketClass.Create;

  Client.SocketHandle  := Sock;
  Client.PeerName      := FPeerName;
  Client.PeerIP        := FPeerIP;
  Client.PeerPort      := FPort;
  Client.HostIP        := FHostIP;
  Client.FTelnetServer := FTelnetServer;
  Client.FTelnetClient := FTelnetClient;

  If FTelnetServer Then
    Client.WriteStr(#255#251#001#255#251#003);  // IAC WILL ECHO

  Result := Client;
End;

Procedure TSocketClass.Status (Str: String);
Var
  Res : String;
Begin
  If SocketStatus = NIL Then Exit;

  Try
    If SocketStatus.Count > 20 Then
      SocketStatus.Delete(0);

    Res := '(' + Copy(DateDos2Str(CurDateDos, 1), 1, 5) + ' ' + TimeDos2Str(CurDateDos, False) + ') ' + Str;

    If Length(Res) > 74 Then Begin
      SocketStatus.Add(Copy(Res, 1, 74));

      If SocketStatus.Count > 20 Then
        SocketStatus.Delete(0);

      SocketStatus.Add(strRep(' ', 14) + Copy(Res, 75, 255));
    End Else
      SocketStatus.Add(Res);
  Except
    { ignore exceptions here -- happens when socketstatus is NIL}
    { need to review criticals now that they are in FP's RTL}
  End;

  StatusUpdated := True;
End;

End.