{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *

Program:      TNCNX.PAS
Object:       Delphi component which implement the TCP/IP telnet protocol
              including some options negociations.
              RFC854, RFC885, RFC779, RFC1091
Author:       François PIETTE
EMail:        francois.piette@ping.be  http://www.rtfm.be/fpiette
              francois.piette@f2202.n293.z2.fidonet.org
              2:293/2202@fidonet.org, BBS +32-4-3651395
Support:      Please ask your question in the following newsgroup:
              news://forums.borland.com/borland.public.delphi.vcl.components.using
Creation:     April, 1996
Version:      2.04
Legal issues: Copyright (C) 1997 by François PIETTE <francois.piette@ping.be>

              This software is provided 'as-is', without any express or
  	      implied warranty.  In no event will the author be held liable
              for any  damages arising from the use of this software.

              Permission is granted to anyone to use this software for any
              purpose, including commercial applications, and to alter it
              and redistribute it freely, subject to the following
              restrictions:

              1. The origin of this software must not be misrepresented,
                 you must not claim that you wrote the original software.
                 If you use this software in a product, an acknowledgment
                 in the product documentation would be appreciated but is
                 not required.

              2. Altered source versions must be plainly marked as such, and
                 must not be misrepresented as being the original software.

              3. This notice may not be removed or altered from any source
                 distribution.

Updates:
Jul 22, 1997 Adapted to Delphi 3
Sep 5, 1997  Added version information, removed old code, added OnTermType
             Renamed some indentifier to be more standard.
Sep 24, 1997 V2.03 Added procedures to negociate options
May 12, 1998 V2.04 Changed NegociateOption to properly handle unwanted
             option as Jan Tomasek <xtomasej@feld.cvut.cz> suggested.
xxx xx, 1998 Modified for SSL, stoping coopearing on this class with F.P.
 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
unit SSLTnCnx;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages,
  Classes,  Controls, Forms,    WSocket,
  Winsock
  {$IFNDEF NOSSL},SSLWSock, SSLeay, LIBEAY
  {$ELSE},X509_free{$ENDIF};

const
  TnCnxVersion    = 203;

  { Telnet command characters                                             }
  TNCH_EOR        = #239;     { $EF End Of Record (preceded by IAC)       }
  TNCH_SE         = #240;     { $F0 End of subnegociation parameters      }
  TNCH_NOP        = #241;     { $F1 No operation                          }
  TNCH_DATA_MARK  = #242;     { $F2 Data stream portion of a Synch        }
  TNCH_BREAK      = #243;     { $F3 NVT charcater break                   }
  TNCH_IP         = #244;     { $F4 Interrupt process                     }
  TNCH_AO         = #245;     { $F5 Abort output                          }
  TNCH_AYT        = #246;     { $F6 Are you there                         }
  TNCH_EC         = #247;     { $F7 Erase character                       }
  TNCH_EL         = #248;     { $F8 Erase line                            }
  TNCH_GA         = #249;     { $F9 Go ahead                              }
  TNCH_SB         = #250;     { $FA Subnegociation                        }
  TNCH_WILL       = #251;     { $FB Will                                  }
  TNCH_WONT       = #252;     { $FC Wont                                  }
  TNCH_DO         = #253;     { $FD Do                                    }
  TNCH_DONT       = #254;     { $FE Dont                                  }
  TNCH_IAC        = #255;     { $FF IAC                                   }

  { Telnet options                                                        }
  TN_TRANSMIT_BINARY      = #0;   { $00 }
  TN_ECHO                 = #1;   { $01 }
  TN_RECONNECTION         = #2;   { $02 }
  TN_SUPPRESS_GA          = #3;   { $03 }
  TN_MSG_SZ_NEGOC         = #4;   { $04 }
  TN_STATUS               = #5;   { $05 }
  TN_TIMING_MARK          = #6;   { $06 }
  TN_NOPTIONS             = #6;   { $06 }
  TN_DET                  = #20;  { $14 }
  TN_SEND_LOC             = #23;  { $17 }
  TN_TERMTYPE             = #24;  { $18 }
  TN_EOR                  = #25;  { $19 }
  TN_NAWS                 = #31;  { $1F }
  TN_TERMSPEED            = #32;  { $20 }
  TN_TFC                  = #33;  { $21 }
  TN_XDISPLOC             = #35;  { $23 }
  TN_OLD_ENVIRON          = #36;  { $24 }     {Environment Option}
  TN_AUTHENTICATION       = #37;  { $25 }     {Authenticate}
  TN_NEW_ENVIRON          = #39;  { $27 }     {Environment Option}
  TN_EXOPL                = #255; { $FF }
  TN_END_SNG              = TNCH_IAC+TNCH_SE; {End of subnegoation}

  TN_TTYPE_IS		  = #0;
  TN_TTYPE_SEND		  = #1;
  TN_TTYPE_INFO           = #2;
  TN_TTYPE_REPLY          = #2;                { AUTHENTICATION: client version of IS }
  TN_TTYPE_NAME           = #3;                { AUTHENTICATION: client version of IS }

  TN_ENV_VAR              = #0;
  TN_ENV_VALUE            = #1;
  TN_ENV_ESC              = #2;
  TN_ENV_USERVAR          = #3;

  {
     ENCRYPTion suboptions
  }
  TN_ENCRYPT_IS           = #0;	{ I pick encryption type ... }
  TN_ENCRYPT_SUPPORT      = #1;	{ I support encryption types ... }
  TN_ENCRYPT_REPLY        = #2;	{ Initial setup response }
  TN_ENCRYPT_START        = #3;	{ Am starting to send encrypted }
  TN_ENCRYPT_END          = #4;	{ Am ending encrypted }
  TN_ENCRYPT_REQSTART     = #5;	{ Request you start encrypting }
  TN_ENCRYPT_REQEND       = #6;	{ Request you send encrypting }
  TN_ENCRYPT_ENC_KEYID    = #7;
  TN_ENCRYPT_DEC_KEYID    = #8;
  TN_ENCRYPT_CNT          = #9;

  TN_ENCTYPE_ANY          = 0;
  TN_ENCTYPE_DES_CFB64    = 1;
  TN_ENCTYPE_DES_OFB64    = 2;
  TN_ENCTYPE_CNT          = 3;

  seNoDDL                 = 50001;
  seNoSSLAvaiable         = 50002;

type
  TSSLTnCnx = class;

  TTnEnvironment = record
    USER            : String;
    USER_sent       : Boolean;
    JOB             : String;
    JOB_sent        : Boolean;
    ACCT            : String;
    ACCT_sent       : Boolean;
    PRINTER         : String;
    PRINTER_sent    : Boolean;
    SYSTEMTYPE      : String;
    SYSTEMTYPE_sent : Boolean;
    DISPLAY         : String;
    DISPLAY_sent    : Boolean;
    UserVars        : TStringList;
    UserVars_sent   : Boolean;
  End;
  TTnSessionConnected = procedure (Sender: TSSLTnCnx; Error : word) of object;
  TTnSessionClosed    = procedure (Sender: TSSLTnCnx; Error : word) of object;
  TTnDataAvailable    = procedure (Sender: TSSLTnCnx; Buffer : PChar; Len : Integer) of object;
  TTnDisplay          = procedure (Sender: TSSLTnCnx; Str : String) of object;
  TTnError            = procedure (Sender: TSSLTnCnx; Error : word) of object;

  TTnDebugLevel_      = (dlStandard, dlDetail);
  TTnDebugLevel       = set of TTnDebugLevel_;

  TSSLTnCnx= class(TComponent)
  public
    {$IFNDEF NOSSL}
    Socket                : TSSLSocket;
    {$ELSE}
    Socket                : TWSocket;
    {$ENDIF}
  private
    FPort                 : String;
    FHost                 : String;
    FLocation             : String;
    FTermType             : String;
    RemoteBinMode         : Boolean;
    LocalBinMode          : Boolean;
    FLocalEcho            : Boolean;
    Spga                  : Boolean;
    FTType                : Boolean;

    {-- Added by Semik --------------------------------------------------------}
    FWindowSize           : TPoint;   {....}
    FDoNaws               : Boolean;  {Must be set before connection start,
                                       says than user want do NAWS if is posible}
    FEnvironment          : TTnEnvironment;
    FEnvironmentSent      : Boolean;
    FDebugLevel           : TTnDebugLevel;
    FUseSSL               : Boolean;
    FRequireSSL           : Boolean;
    FDirectSSL            : Boolean;
    FStatus               : Array[#0..#$FF] of Char;
    wasSomeNeg            : Boolean;
    {--------------------------------------------------------------------------}

    FBuffer               : array [0..2048] of char;
    FBufferCnt            : Integer;
    FWindowHandle         : HWND;
    FOnSessionConnected   : TTnSessionConnected;
    FOnSSLSessionConnected: TTnSessionConnected;
    FOnSessionClosed      : TTnSessionClosed;
    FOnDataAvailable      : TTnDataAvailable;
    FOnDisplay            : TTnDisplay;
    {-- Added by Semik --------------------------------------------------------}
    FOnDebug              : TTnDisplay;
    FOnError              : TTnError;
    {--------------------------------------------------------------------------}
    FOnEOR                : TNotifyEvent;
    FOnSendLoc            : TNotifyEvent;
    FOnTermType           : TNotifyEvent;
    FOnLocalEcho          : TNotifyEvent;
    procedure WndProc(var MsgRec: TMessage);
    procedure SocketSessionConnected(Sender: TObject; Error : word);
    {$IFNDEF NOSSL}procedure SocketSSLSessionConnected(Sender: TObject; Error : word);{$ENDIF}
    procedure SocketSessionClosed(Sender: TObject; Error : word);
    procedure SocketDataAvailable(Sender: TObject; Error : word);
    procedure Display(Str : String);
    procedure AddChar(Ch : Char);
    procedure ReceiveChar(Ch : Char);
    procedure Answer(chAns : Char; chOption : Char);
    {-- Added by Semik --------------------------------------------------------}
    procedure AnswerSubOption(chAns: Char; Const t, AnsStr: String);
    procedure AnswerEnvironment(EnvVer, EnvID: Char; EnvStr: String);
    procedure TriggerOnDebug(Const S:String);
    procedure TriggerOnDetailDebug(Const StartS, S:String);
    procedure TriggerOnError(Error:Word);
    {--------------------------------------------------------------------------}
    procedure NegociateSubOption(strSubOption : String);
    procedure NegociateOption(chAction : Char; chOption : Char);
    procedure FlushBuffer;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    function  GetState : TSocketState;
    Procedure WWindowSize(P:TPoint);

  public
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy; override;
    function    Send(Data : Pointer; Len : Integer) : integer;
    function    SendStr(Data : String) : integer;
    procedure   Connect;
    function    IsConnected : Boolean;
    procedure   WillOption(chOption : Char);
    procedure   WontOption(chOption : Char);
    procedure   DontOption(chOption : Char);
    procedure   DoOption(chOption : Char);
    {$IFNDEF NOSSL}procedure   DisplaySSLConnectionDetails;{$ENDIF}
    procedure   Close;
    procedure   Pause;
    procedure   Resume;
    property    State : TSocketState                  read  GetState;
    property    Handle : HWND                         read  FWindowHandle;
    {-- Added by Semik --------------------------------------------------------}
    property WindowSize : TPoint                      read  FWindowSize
                                                      write WWindowSize;
    property Environment: TTnEnvironment              read  FEnvironment
                                                      write FEnvironment;
    {--------------------------------------------------------------------------}
  published
    property Port : String                            read  FPort
                                                      write FPort;
    property Host : String                            read  FHost
                                                      write FHost;
    property Location : String                        read  FLocation
                                                      write FLocation;
    property TermType : String                        read  FTermType
                                                      write FTermType;
    property LocalEcho : Boolean                      read  FLocalEcho
                                                      write FLocalEcho;
    {-- Added by Semik --------------------------------------------------------}
    property DoNaws : Boolean                         read  FDoNaws write FDoNaws;
    property DebugLevel : TTnDebugLevel               read  FDebugLevel write FDebugLevel;
    property UseSSL : Boolean                         read  FUseSSL write FUseSSL;
    property RequireSSL : Boolean                     read  FRequireSSL write FRequireSSL;
    property DirectSSL : Boolean                      read  FDirectSSL write FDirectSSL;
    {--------------------------------------------------------------------------}
    property OnSessionConnected : TTnSessionConnected read  FOnSessionConnected
                                                      write FOnSessionConnected;
    property OnSSLSessionConnected : TTnSessionConnected read  FOnSSLSessionConnected
                                                         write FOnSSLSessionConnected;
    property OnSessionClosed :    TTnSessionClosed    read  FOnSessionClosed
                                                      write FOnSessionClosed;
    property OnDataAvailable :    TTnDataAvailable    read  FOnDataAvailable
                                                      write FOnDataAvailable;
    property OnDisplay :          TTnDisplay          read  FOnDisplay
                                                      write FOnDisplay;
    property OnEndOfRecord :      TNotifyEvent        read  FOnEOR
                                                      write FOnEOR;
    property OnSendLoc :          TNotifyEvent        read  FOnSendLoc
                                                      write FOnSendLoc;
    property OnTermType :         TNotifyEvent        read  FOnTermType
                                                      write FOnTermType;
    property OnLocalEcho :        TNotifyEvent        read  FOnLocalEcho
                                                      write FOnLocalEcho;
    property OnDebug   :          TTnDisplay          read  FOnDebug
                                                      write FOnDebug;
    property OnError :            TTnError            read  FOnError
                                                      write FOnError;
  end;

procedure Register;

implementation
{-$DEFINE Debug}      { Add or remove minus sign before dollar sign to }
                     { generate code for debug message output         }

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure Register;
begin
  RegisterComponents('Semik', [TSSLTnCnx]);
end;


Const
  NewLine = #13#10;

Function EnvGetVariable(Const S:String):String;
Begin
  If Pos('=', S)>0 Then
    Result := Copy(S, 1, Pos('=', S)-1)
  Else
    Result := S;
End;

Function EnvGetValue(Const S:String):String;
Begin
  If Pos('=', S)>0 Then
    Result := Copy(S, Pos('=', S)+1, Length(S))
  Else
    Result := '';
End;

Function cmdChar2Str(cmd:Char):String;
Begin
  Case cmd of
    TNCH_EOR         : result:= 'EOR';
    TNCH_SE          : result:= 'SE';
    TNCH_NOP         : result:= 'NOP';
    TNCH_DATA_MARK   : result:= 'DATA_MARK';
    TNCH_BREAK       : result:= 'BREAK';
    TNCH_IP          : result:= 'IP';
    TNCH_AO          : result:= 'AO';
    TNCH_AYT         : result:= 'AYT';
    TNCH_EC          : result:= 'EC';
    TNCH_EL          : result:= 'EL';
    TNCH_GA          : result:= 'GA';
    TNCH_SB          : result:= 'SB';
    TNCH_WILL        : result:= 'WILL';
    TNCH_WONT        : result:= 'WONT';
    TNCH_DO          : result:= 'DO';
    TNCH_DONT        : result:= 'DONT';
    TNCH_IAC         : result:= 'IAC';
    Else               result:= 'Unknown(\0x'+IntToHex(ord(cmd),2)+')';
  End;
End;

Function Option2Str(opt:Char):String;
Begin
  Case opt of
    TN_TRANSMIT_BINARY  : result := 'TRANSMIT_BINARY';
    TN_ECHO             : result := 'ECHO';
    TN_RECONNECTION     : result := 'RECONNECTION';
    TN_SUPPRESS_GA      : result := 'SUPPRESS_GA';
    TN_MSG_SZ_NEGOC     : result := 'MSG_SZ_NEGOC';
    TN_STATUS           : result := 'STATUS';
    TN_TIMING_MARK      : result := 'TIMING_MARK';
    {TN_NOPTIONS         : result := 'NOPTIONS';}
    TN_DET              : result := 'DET';
    TN_SEND_LOC         : result := 'SEND_LOC';
    TN_TERMTYPE         : result := 'TERMTYPE';
    TN_EOR              : result := 'EOR';
    TN_NAWS             : result := 'NAWS';
    TN_TERMSPEED        : result := 'TERMSPEED';
    TN_TFC              : result := 'TFC';
    TN_XDISPLOC         : result := 'XDISPLOC';
    TN_OLD_ENVIRON      : result := 'OLD_ENVIRON';
    TN_AUTHENTICATION   : result := 'AUTHENTICATION';
    TN_NEW_ENVIRON      : result := 'NEW_ENVIRON';
    TN_EXOPL            : result := 'EXOPL';
    Else                  result := 'Unknown(\0x'+IntToHex(ord(opt),2)+')';
  End;
End;

Function Type2Str(t:Char):String;
Begin
  Case t of
    TN_TTYPE_IS	  : result :='IS';
    TN_TTYPE_SEND : result :='SEND';
    TN_TTYPE_INFO : result :='INFO';
    Else            result :='Unknown(\0x'+IntToHex(ord(t),2)+')';
  End
End;


Function FixAnswerStr(Const S:String):String;
Var
  I: Integer;
Begin
  Result:='';
  For I:=1 To Length(S) Do
    Case S[I] of
      #32..#91,
      #93..#127 : Result:=Result+S[I];
      #0..#31,
      #128..#255: Result:=Result+'\0x'+IntToHex(ord(S[I]),2);
      #92       : Result:=Result+'\\';
    End;
End;

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
(*procedure DebugString(Msg : String);
const
    Cnt : Integer = 0;
{$IFDEF Debug}
var
    Buf : String[20];
{$ENDIF}
begin
{$IFDEF Debug}
    Cnt := Cnt + 1;
    Buf := IntToHex(Cnt, 4) + ' ' + #0;
    OutputDebugString(@Buf[1]);

{$IFNDEF WIN32}
    if Length(Msg) < High(Msg) then
        Msg[Length(Msg) + 1] := #0;
{$ENDIF}

    OutputDebugString(@Msg[1]);
{$ENDIF}
end;*)


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSSLTnCnx.WndProc(var MsgRec: TMessage);
begin
     with MsgRec do
         Result := DefWindowProc(Handle, Msg, wParam, lParam);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
constructor TSSLTnCnx.Create(AOwner: TComponent);

begin
    inherited Create(AOwner);
    FWindowHandle             := AllocateHWnd(WndProc);
    FLocation                 := 'TNCNX';
    FTermType                 := 'VT100';
    FPort                     := '23';
{-- Added by Semik ---------------------------------------------------------}
    FWindowSize               := Point(80,24);
    FDoNaws                   := True;
    FEnvironmentSent          := False;
    FUseSSL                   := False;
    FRequireSSL               := False;
    FDirectSSL                := False;
    FDebugLevel               := [];
    FillChar(FStatus, SizeOf(FStatus), 0);
    FEnvironment.USER              := '';
    FEnvironment.USER_sent         := False;
    FEnvironment.JOB               := '';
    FEnvironment.JOB_sent          := False;
    FEnvironment.ACCT              := '';
    FEnvironment.ACCT_sent         := False;
    FEnvironment.PRINTER           := '';
    FEnvironment.PRINTER_sent      := False;
    FEnvironment.SYSTEMTYPE        := '';
    FEnvironment.SYSTEMTYPE_sent   := False;
    FEnvironment.DISPLAY           := '';
    FEnvironment.DISPLAY_sent      := False;
    FEnvironment.UserVars          := TStringList.Create;
    FEnvironment.UserVars_sent     := False;
    wasSomeNeg                     := False;
{---------------------------------------------------------------------------}
    {$IFNDEF NOSSL}
    Socket                         := TSSLSocket.Create(Self);
    Socket.OnSSLSessionConnected   := SocketSSLSessionConnected;
    {$ELSE}
    Socket                         := TWSocket.Create(Self);
    {$ENDIF}
    Socket.OnSessionConnected      := SocketSessionConnected;
    Socket.OnDataAvailable         := SocketDataAvailable;
    Socket.OnSessionClosed         := SocketSessionClosed;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
destructor TSSLTnCnx.Destroy;
begin
    if Assigned(Socket) then begin
        Socket.Free;
        Socket := nil;
    end;

    DeallocateHWnd(FWindowHandle);
    FEnvironment.UserVars.Free;
    inherited Destroy;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSSLTnCnx.Notification(AComponent: TComponent; Operation: TOperation);
begin
    inherited Notification(AComponent, Operation);
    if (AComponent = Socket) and (Operation = opRemove) then
        Socket := nil;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSSLTnCnx.Pause;
begin
    if not Assigned(Socket) then
        Exit;
    Socket.Pause;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSSLTnCnx.Resume;
begin
    if not Assigned(Socket) then
        Exit;
    Socket.Resume;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSSLTnCnx.Connect;
begin
    if not Assigned(Socket) then
        Exit;

    if Socket.State <> wsClosed then
        Socket.Close;

    FEnvironmentSent               := False;
    FEnvironment.USER_sent         := False;
    FEnvironment.JOB_sent          := False;
    FEnvironment.ACCT_sent         := False;
    FEnvironment.PRINTER_sent      := False;
    FEnvironment.SYSTEMTYPE_sent   := False;
    FEnvironment.DISPLAY_sent      := False;
    FEnvironment.UserVars_sent     := False;
    FillChar(FStatus, SizeOf(FStatus), 0);

    Socket.Proto   := 'tcp';
    Socket.Port    := FPort;
    Socket.Addr    := FHost;
    Socket.AutoSSL := FUseSSL and FDirectSSL;
    if Socket.AutoSSL then begin
      Display('[Loading SSL libraries]'+newline);
      if not SSLWSock.Init Then begin
        TriggerOnError(seNoDDL);
        Exit;
      end;
    end;
    Socket.Connect;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TSSLTnCnx.IsConnected : Boolean;
begin
    Result := Socket.State = wsConnected;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSSLTnCnx.Close;
begin
    if Assigned(Socket) then
        Socket.Close;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSSLTnCnx.Display(Str : String);
begin
    if Assigned(FOnDisplay) then
        FOnDisplay(Self, Str);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TSSLTnCnx.GetState : TSocketState;
begin
    if Assigned(Socket) then
        Result := Socket.State
    else
        Result := wsInvalidState;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSSLTnCnx.SocketSessionConnected(Sender: TObject; Error : word);
begin
  if (Socket.AutoSSL) and (Socket.SSLState=sslClosed) then
    Display('[SSL Starting]'+NewLine);
  if Assigned(FOnSessionConnected) then FOnSessionConnected(Self, Error);
end;

{$IFNDEF NOSSL}
procedure TSSLTnCnx.SocketSSLSessionConnected(Sender: TObject; Error : word);
Begin
  if Assigned(FOnSSLSessionConnected) then FOnSSLSessionConnected(Self, Error);
  DisplaySSLConnectionDetails;
End;

procedure   TSSLTnCnx.DisplaySSLConnectionDetails;
Var
  peer   : PX509;
  buf    : Array[0..256-1] of char;
Begin
  {Print info about server's cert - this will be rewriten!}
  peer := SSL_get_peer_certificate(Socket.SSLcon);
  X509_NAME_oneline(X509_get_subject_name(peer), buf, sizeof(buf));
  Display(Format('[SSL subject=%s]'+NewLine, [strPas(buf)]));
  X509_NAME_oneline(X509_get_issuer_name(peer), buf, sizeof(buf));
  Display(Format('[SSL issuer=%s]'+NewLine, [strPas(buf)]));
  X509_free(peer);
  {Print cipher name, length and version}
  Display(Format('[SSL Started - Cipher %s, %d bits, version %s]'+NewLine,
          [Socket.CipherName, Socket.CipherBits, Socket.CipherVersion]));
End;
{$ENDIF}



{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSSLTnCnx.SocketSessionClosed(Sender: TObject; Error : word);
begin
    if Socket.State <> wsClosed then
        Socket.Close;
    if Assigned(FOnSessionClosed) then
        FOnSessionClosed(Self, Error);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSSLTnCnx.SocketDataAvailable(Sender: TObject; Error : word);
var
    Len, I : Integer;
    Buffer : array [1..2048] of char;
    Socket : TSSLSocket;
begin
  Socket := Sender as TSSLSocket;
  Len := Socket.Receive(@Buffer[1], High(Buffer));

  for I := 1 to Len do ReceiveChar(Buffer[I]);
  FlushBuffer;
  { Server poslal nejakou telnet option lze tedy predpokladat ze na
    druhe strane je telnet deamon -> takze do nej projistotu narveme co
    umime }
  If FUseSSL and (not Socket.AutoSSL) and (FStatus[TN_AUTHENTICATION]=#0) Then Answer(TNCH_WILL,TN_AUTHENTICATION);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function  TSSLTnCnx.Send(Data : Pointer; Len : Integer) : integer;
begin
    if Assigned(Socket) then
        Result := Socket.Send(Data, Len)
    else
        Result := -1;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TSSLTnCnx.SendStr(Data : String) : integer;
begin
    Result := Send(@Data[1], Length(Data));
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

procedure TSSLTnCnx.Answer(chAns : Char; chOption : Char);
var
  Buf   : String[3];
begin
  {Set my state}
  FStatus[chOption]:=chAns;
  Buf := TNCH_IAC + chAns + chOption;
  Send(@Buf[1], Length(Buf));
  TriggerOnDebug(Format('send: %s %s%s', [cmdChar2Str(chAns), Option2Str(chOption), NewLine]));
  TriggerOnDetailDebug('send: ', Buf);
end;


{Added by Semik}
procedure TSSLTnCnx.AnswerSubOption(chAns: Char; Const t, AnsStr: String);
Var
  Buf : String;
Begin
  Buf := TNCH_IAC + TNCH_SB + chAns + t + AnsStr + TNCH_IAC + TNCH_SE;
  Send(@Buf[1], Length(Buf));
  TriggerOnDebug(Format('send suboption: %s %s%s', [Option2Str(chAns), FixAnswerStr(AnsStr), NewLine]));
  TriggerOnDetailDebug ('send suboption: ', Buf);
End;{-- AnswerSubOption -------------------------------------------------------}

{Added by Semik}
procedure TSSLTnCnx.AnswerEnvironment(EnvVer, EnvID: Char; EnvStr: String);
Var
  Value   : String;
  Buf     : String;
  envVAL  : Char;
  envVAR  : Char;
  I       : Integer;
Begin
  If EnvVer=TN_NEW_ENVIRON Then Begin
    envVAR := TN_ENV_VAR;
    envVAL := TN_ENV_VALUE;
  End Else Begin
    envVAL := TN_ENV_VAR;
    envVAR := TN_ENV_VALUE;
  End;

  Case EnvID of
    TN_ENV_VAR : Begin
      Buf := '';
      Value:= '';
      If EnvStr = 'USER'       Then Begin Value:=FEnvironment.USER;       FEnvironment.USER_sent      :=True; End;
      If EnvStr = 'JOB'        Then Begin Value:=FEnvironment.JOB;        FEnvironment.JOB_sent       :=True; End;
      If EnvStr = 'ACCT'       Then Begin Value:=FEnvironment.ACCT;       FEnvironment.ACCT_sent      :=True; End;
      If EnvStr = 'PRINTER'    Then Begin Value:=FEnvironment.PRINTER;    FEnvironment.PRINTER_sent   :=True; End;
      If EnvStr = 'SYSTEMTYPE' Then Begin Value:=FEnvironment.SYSTEMTYPE; FEnvironment.SYSTEMTYPE_sent:=True; End;
      If EnvStr = 'DISPLAY'    Then Begin Value:=FEnvironment.DISPLAY;    FEnvironment.DISPLAY_sent   :=True; End;

      If Value<>'' Then Buf := envVAR + EnvStr + envVAL + Value;
      SendStr(Buf); TriggerOnDebug(FixAnswerStr(Buf));
    End;{TN_ENV_VAR -----------------------------------------------------------}

    TN_ENV_USERVAR : Begin
      If FEnvironment.UserVars.Count>0 Then
        For I:=0 To FEnvironment.UserVars.Count-1 Do Begin
          Buf := TN_ENV_USERVAR + EnvGetVariable(FEnvironment.UserVars.Strings[I]) +
                 EnvVAL + EnvGetValue(FEnvironment.UserVars.Strings[I]);
          SendStr(Buf); TriggerOnDebug(FixAnswerStr(Buf));
        End
      Else Begin
        Buf := TN_ENV_USERVAR + envStr;
        SendStr(Buf); TriggerOnDebug(FixAnswerStr(Buf));
      End;
    End{TN_ENV_USERVAR --------------------------------------------------------}

    Else Begin {What is it!? Don't known how to handle.}
      Buf := envVar + envStr;
      SendStr(Buf); TriggerOnDebug(FixAnswerStr(Buf));
    End;

  End;
End;{-- AnswerNewEnvironment --------------------------------------------------}


procedure TSSLTnCnx.TriggerOnDebug(Const S:String);
Begin
  If Assigned(FOnDebug)and(dlStandard in FDebugLevel) Then FOnDebug(Self, S);
End;{-- TriggerOnDebug --------------------------------------------------------}

procedure TSSLTnCnx.TriggerOnDetailDebug(Const StartS, S:String);
Var
  I : Integer;
Begin
  If Assigned(FOnDebug)and(dlDetail in FDebugLevel) Then Begin
    FOnDebug(Self, StartS);
    For I:=1 To Length(S) Do FOnDebug(Self, IntToHex(Byte(S[I]), 2)+' ');
    FOnDebug(Self, NewLine);
  End;
End;{-- TriggerOnDebug --------------------------------------------------------}

procedure TSSLTnCnx.TriggerOnError(Error:Word);
Begin
  If Assigned(FOnError) Then FOnError(Self, Error);
End;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSSLTnCnx.WillOption(chOption : Char);
begin
    Answer(TNCH_WILL, chOption);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSSLTnCnx.WontOption(chOption : Char);
begin
    Answer(TNCH_WONT, chOption);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSSLTnCnx.DontOption(chOption : Char);
begin
    Answer(TNCH_DONT, chOption);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSSLTnCnx.DoOption(chOption : Char);
begin
    Answer(TNCH_DO, chOption);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSSLTnCnx.NegociateSubOption(strSubOption : String);
var
  Buf    : String;
  I      : Integer;
  EnvID  : Char;
  EnvStr : String;
begin
  TriggerOnDebug(Format('recv suboption: %s %s', [Option2Str(strSubOption[1]),
                 Type2Str(strSubOption[2])])+NewLine);
  TriggerOnDetailDebug('recv suboption: ', strSubOption);

  case strSubOption[1] of
    TN_TERMTYPE: begin
      if strSubOption[2] = TN_TTYPE_SEND then begin
        if Assigned(FOnTermType) then FOnTermType(Self);
        AnswerSubOption(strSubOption[1], TN_TTYPE_IS, FTermType{04.12.1999 +TN_END_SNG});
      end;
    end;

    TN_NEW_ENVIRON,
    TN_OLD_ENVIRON: Begin
      {Start of environment sequention}
      SendStr(TNCH_IAC + TNCH_SB + strSubOption[1] + TN_TTYPE_IS);
      TriggerOnDebug(FixAnswerStr('send suboption: '+Option2Str(strSubOption[1])));

      If strSubOption[2] = TN_TTYPE_SEND Then Begin
        {Answer all server's question about my environment}

        {This is COMPLETELY nonsens!!! deleted at 4.6.99
        I:=3; If strSubOption[I]<>TNCH_IAC Then Repeat
          EnvID := strSubOption[I]; Inc(I); EnvStr:= '';
          While (strSubOption[I]>=#32)and(strSubOption[I]<>TNCH_IAC)and
                (Length(strSubOption)<I) Do Begin
            EnvStr:= strSubOption[I];
            Inc(I);
          End;
          Buf:=EnvID+EnvStr; SendStr(Buf); TriggerOnDebug(FixAnswerStr(Buf));
        Until I>Length(strSubOption);}

        {Check if server request all informations witch we have,
         if not push it him!}
        With FEnvironment Do Begin
          if not USER_sent       and(USER      <>'')Then AnswerEnvironment(strSubOption[1], TN_ENV_VAR, 'USER'      );
          if not JOB_sent        and(JOB       <>'')Then AnswerEnvironment(strSubOption[1], TN_ENV_VAR, 'JOB'       );
          if not ACCT_sent       and(ACCT      <>'')Then AnswerEnvironment(strSubOption[1], TN_ENV_VAR, 'ACCT'      );
          if not PRINTER_sent    and(PRINTER   <>'')Then AnswerEnvironment(strSubOption[1], TN_ENV_VAR, 'PRINTER'   );
          if not SYSTEMTYPE_sent and(SYSTEMTYPE<>'')Then AnswerEnvironment(strSubOption[1], TN_ENV_VAR, 'SYSTEMTYPE');
          if not DISPLAY_sent    and(DISPLAY   <>'')Then AnswerEnvironment(strSubOption[1], TN_ENV_VAR, 'DISPLAY'   );
          if not UserVars_sent and(UserVars.Count>0)Then AnswerEnvironment(strSubOption[1], TN_ENV_USERVAR, '');
        End;
        SendStr(TN_END_SNG);
        TriggerOnDebug(FixAnswerStr(TN_END_SNG)+NewLine);
      End;
    End;
    {$IFNDEF NOSSL}
    TN_AUTHENTICATION: Begin
      Case strSubOption[2] of
        TN_TTYPE_IS   : ;
        TN_TTYPE_SEND : If strSubOption[3]=#7 Then Begin
          AnswerSubOption(TN_AUTHENTICATION, TN_TTYPE_IS, #7 + #0 + #1);
        End Else Begin
          If FRequireSSL Then Begin TriggerOnError(seNoSSLAvaiable); Close; End;
          AnswerSubOption(TN_AUTHENTICATION, TN_TTYPE_IS, #0 + #0 + #1);
        End;
        TN_TTYPE_REPLY: Begin
          Socket.ConnectSSL;
        End;
        TN_TTYPE_NAME : ;
      End;
    End;{$ENDIF}


    else
        TriggerOnDebug('Unknown suboption' + #13 + #10);
    end;
end;



{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSSLTnCnx.NegociateOption(chAction : Char; chOption : Char);
var
    Buf : String;
begin
    TriggerOnDebug(Format('recv: %s %s%s', [cmdChar2Str(chAction), Option2Str(chOption), NewLine]));
    TriggerOnDetailDebug('recv: ', TNCH_IAC+chAction+chOption);
    
    case chOption of
    TN_TRANSMIT_BINARY:
        begin
            if chAction = TNCH_WILL then begin
                Answer(TNCH_DO, chOption);
                RemoteBinMode := TRUE;
                LocalBinMode  := TRUE;
            end
            else if chAction = TNCH_WONT then begin
                if RemoteBinMode then begin
                    RemoteBinMode := FALSE;
                    LocalBinMode  := FALSE;
                end;
            end;
        end;
    TN_ECHO:
        begin
          If FLocalEcho Then Begin
            if chAction = TNCH_WILL then Answer(TNCH_DO, chOption)
            else                         Answer(TNCH_WONT, chOption);
          End Else Begin
            if chAction = TNCH_WILL then Answer(TNCH_DONT, chOption)
            else                         Answer(TNCH_WONT, chOption);
          End;
{            if chAction = TNCH_WILL then begin
                Answer(TNCH_DO, chOption);
                FLocalEcho := FALSE;
            end
            else if chAction = TNCH_WONT then begin
                FLocalEcho := TRUE;
            end;}
          if Assigned(FOnLocalEcho) then FOnLocalEcho(self);
        end;
    TN_SUPPRESS_GA:
        begin
            if chAction = TNCH_WILL then begin
                Answer(TNCH_DO, chOption);
                spga := TRUE;
            end;
        end;
    TN_TERMTYPE:
        begin
            if chAction = TNCH_DO then begin
                Answer(TNCH_WILL, chOption);
                FTType := TRUE;
            end;
        end;
    TN_SEND_LOC:
        begin
            if chAction = TNCH_DO then begin
                Answer(TNCH_WILL, chOption);
                if Assigned(FOnSendLoc) then
                    FOnSendLoc(Self);
                Buf := TNCH_IAC + TNCH_SB + TN_SEND_LOC + FLocation + TNCH_IAC + TNCH_SE;
                Send(@Buf[1], Length(Buf));
            end;
        end;
    TN_EOR:
        begin
            if chAction = TNCH_DO then begin
                Answer(TNCH_WILL, chOption);
                FTType := TRUE;
            end;
        end;
{-- Added by Semik ------------------------------------------------------------}
    {$IFNDEF NOSSL}
    TN_AUTHENTICATION: If chAction=TNCH_DO Then Begin {Server request AUTHENTICATION}
      If FUseSSL and (not Socket.AutoSSL) Then Begin {User wish to use SSL}
        Display('[Loading SSL libraries]'+newline);
        If {$IFDEF WIN32}SSLWSock.Init{$ELSE}False{$ENDIF} Then begin{SSL libs were loaded sucesfully}
          Answer(TNCH_WILL, chOption);
          Display('[SSL Starting]'+NewLine);
        end Else Begin {SSL libs aren't available}
          Answer(TNCH_WONT, chOption);
          If FRequireSSL and (not Socket.AutoSSL) Then Begin TriggerOnError(seNoDDL); Close; End;
        End;
      End Else Begin {User wish not use SSL}
        Answer(TNCH_WONT, chOption);
        If FRequireSSL and (not Socket.AutoSSL) Then Begin TriggerOnError(seNoSSLAvaiable); Close; End;
      End;
    End Else Begin {Server send <>DO}
      If FRequireSSL and (not Socket.AutoSSL) Then Begin TriggerOnError(seNoSSLAvaiable); Close; End;
    End;{$ENDIF}

    TN_NEW_ENVIRON,
    TN_OLD_ENVIRON: If (FEnvironment.USER='')and(FEnvironment.JOB='')and
                       (FEnvironment.ACCT='')and(FEnvironment.PRINTER='')and
                       (FEnvironment.SYSTEMTYPE='')and(FEnvironment.DISPLAY='')and
                       (FEnvironment.UserVars.Count=0)or(FEnvironmentSent)Then
      Answer(TNCH_WONT, chOption)
    Else Begin
      FEnvironmentSent:=True;
      Answer(TNCH_WILL, chOption);
    End;

    TN_NAWS:
      Begin
        if (chAction = TNCH_DO)and FDoNaws Then Begin
          WWindowSize(FWindowSize);
        End Else Begin
          DoNaws:=False;
          Answer(TNCH_WONT, chOption);
        End;
      End;
{------------------------------------------------------------------------------}
    else
{        Answer(TNCH_WONT, chOption); }
        { Jan Tomasek <xtomasej@feld.cvut.cz> }
        if chAction = TNCH_WILL then
            Answer(TNCH_DONT, chOption)
        else
            Answer(TNCH_WONT, chOption);
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSSLTnCnx.FlushBuffer;
var
    Buffer : PChar;
    Count  : Integer;
begin
    try
        if FBufferCnt > 0 then begin
            if Assigned(FOnDataAvailable) then begin
                { We need to make a copy for the data because we can reenter   }
                { during the event processing                                  }
                Count := FBufferCnt;             { How much we received        }
                try
                    GetMem(Buffer, Count + 1);       { Alloc memory for the copy   }
                except
                    Buffer := nil;
                end;
                if Buffer <> nil then begin
                    try
                        Move(FBuffer, Buffer^, Count);   { Actual copy             }
                        Buffer[Count] := #0;             { Add a nul byte          }
                        FBufferCnt := 0;                 { Reset receivecounter    }
                        FOnDataAvailable(Self, Buffer, Count); { Call event handler  }
                    finally
                        FreeMem(Buffer, Count + 1);      { Release the buffer      }
                    end;
                end;
            end
            else begin
                FBufferCnt := 0
            end;
        end;
    except
        raise;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSSLTnCnx.AddChar(Ch : Char);
begin
    FBuffer[FBufferCnt] := Ch;
    Inc(FBufferCnt);
    if FBufferCnt >= SizeOf(FBuffer) then
        FlushBuffer;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSSLTnCnx.ReceiveChar(Ch : Char);
const
    bIAC         : Boolean = FALSE;
    chVerb       : Char    = #0;
    strSubOption : String  = '';
    bSubNegoc    : Boolean = FALSE;
begin
    if chVerb <> #0 then begin
        NegociateOption(chVerb, Ch);
        chVerb       := #0;
        strSubOption := '';
        Exit;
    end;

    if bSubNegoc then begin
        if Ch = TNCH_SE then begin
            wasSomeNeg   := True;
            bSubNegoc    := FALSE;
            NegociateSubOption(strSubOption);
            {Added by Semik}
            strSubOption := '';
        end
        else
            strSubOption := strSubOption + Ch;
        Exit;
    end;

    if bIAC then begin
        case Ch of
        TNCH_IAC: begin
                      AddChar(Ch);
                      bIAC := FALSE;
                  end;
        TNCH_DO, TNCH_WILL, TNCH_DONT, TNCH_WONT:
                  begin
                      bIAC   := FALSE;
                      chVerb := Ch;
                  end;
        TNCH_EOR:
            begin
                TriggerOnDebug('TNCH_EOR' + #13 + #10);
                bIAC   := FALSE;
                if Assigned(FOnEOR) then
                    FOnEOR(Self);
            end;
        TNCH_SB:
            begin
                {TriggerOnDebug('Subnegociation' + #13 + #10);}
                bSubNegoc := TRUE;
                bIAC      := FALSE;
            end;
        else
            TriggerOnDebug('Unknown ' + IntToHex(ord(Ch), 2) + ' ''' + Ch + '''' + #13 + #10);
            bIAC := FALSE;
        end;

        Exit;
    end;

    case Ch of
    TNCH_EL:
        begin
            TriggerOnDebug('TNCH_EL' + #13 + #10);
            AddChar(Ch);
        end;
    TNCH_EC:
        begin
            TriggerOnDebug('TNCH_EC' + #13 + #10);
            AddChar(Ch);
        end;
    TNCH_AYT:
        begin
            TriggerOnDebug('TNCH_AYT' + #13 + #10);
            AddChar(Ch);
        end;
    TNCH_IP:
        begin
            TriggerOnDebug('TNCH_IP' + #13 + #10);
            AddChar(Ch);
        end;
    TNCH_AO:
        begin
            TriggerOnDebug('TNCH_AO' + #13 + #10);
            AddChar(Ch);
        end;
    TNCH_IAC:
        begin
            bIAC := TRUE
        end;
    else
        AddChar(Ch);
    end;
end;


{-- Added by Semik --------------------------------------------------------}
{This founction sets window size after connect}
Procedure TSSLTnCnx.WWindowSize(P:TPoint);
Var
  S     : String;
Begin
  FWindowSize := P;
  If FDoNaws and IsConnected Then Begin
    Answer(TNCH_WILL, TN_NAWS);
    S:={TNCH_IAC+TNCH_SB+TN_NAWS+}
       Char(Hi(FWindowSize.X)) + Char(Lo(FWindowSize.X)) +
       Char(Hi(FWindowSize.Y)) + Char(Lo(FWindowSize.Y)){04.12.199 +
       TN_END_SNG};
    AnswerSubOption(TN_NAWS, '', S);
  End;
End;
{--------------------------------------------------------------------------}

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

end.


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

