Jump to content

Hafedh TRIMECHE

Members
 View Profile  See their activity

  • Content Count

    27

  • Joined

  • Last visited

Posts posted by Hafedh TRIMECHE

  2. Posted 

    object Form1: TForm1
  Left = 0
  Top = 0
  Caption = 'Form1'
  ClientHeight = 441
  ClientWidth = 624
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -12
  Font.Name = 'Segoe UI'
  Font.Style = []
  PixelsPerInch = 96
  TextHeight = 15
  object Panel1: TPanel
    Left = 96
    Top = 32
    Width = 185
    Height = 41
    AutoSize = True
    Caption = 'Panel1'
    TabOrder = 0
  end
end

     

    bds_CUKVPgahRs.png

  4. Posted

    Is there a way to disable control resizing at design time?

     

    I tried this but Message.Result is always set to 1 (HTCLIENT) 

    procedure TUFrame.WMNCHitTest(var Message:TWMNCHitTest);
begin
  inherited;
  if Message.Result in [HTLEFT,HTRIGHT,HTBOTTOM,HTBOTTOMRIGHT,HTBOTTOMLEFT,HTTOP,HTTOPRIGHT,HTTOPLEFT] then Message.Result := Windows.HTNOWHERE;
end;

     

    Thanks.

  6. Posted

    It's already done: 

    procedure TUButton.Click;
begin
  FlushInput;
  if MilliSecondsBetween(Now,FLastClicked)<600 then Exit;
  FLastClicked := Now;
  inherited;
end;

    No need to set a timer. Any click invoked within 600 milliseconds interval will be discarded.

     

    Thanks.

    • Like 1

  8. Posted

    I guess that more than one message events are already queued before TUbutton.Click starts executing. So, This approach is applicable only if previous messages are removed from the Queue ; otherwise,  OnClick events will continue processing.

     

    Removing messages is done using FlushInput defined into my reply above.

  9. Posted

    Thanks for your reply.

     

    Tried this solution but not solved the issue.

     

    Disabling and Enabling the button itself is only valid for OnClick handler which takes a time larger than the one elapsed between 2 clicks.

     

    I modified the code:

      

    procedure EmptyKeyQueue;
var
  Msg : TMsg;
begin
  while PeekMessage(Msg,0,WM_KEYFIRST,WM_KEYLAST,PM_REMOVE or PM_NOYIELD) do;
end;

procedure EmptyMouseQueue;
var
  Msg : TMsg;
begin
  while PeekMessage(Msg,0,WM_MOUSEFIRST, WM_MOUSELAST,PM_REMOVE or PM_NOYIELD) do;
end;

procedure FlushInput;
begin
  EmptyKeyQueue;
  EmptyMouseQueue;
end;


procedure TUButton.Click;
begin
  FlushInput;
  if MilliSecondsBetween(Now,FLastClicked)<600 then Exit;
  FLastClicked := Now;
  inherited;
end;

     

     

  10. Posted

    This overridden procedure wont prevent multiple clicks

      

    procedure TUButton.Click;
var
  CanGo : Boolean;
begin
  FLock.Lock;
  CanGo := (not FBusy);
  if CanGo then FBusy := True;
  Flock.Unlock;
  if (not CanGo) then Exit;
  inherited;
  FLock.Lock;
  FBusy := False;
  Flock.Unlock;
end;

    Any possible solution?

     

    Thanks.

  11. Posted

    This code raised an EIdNotASocket exception.
      

    function PortInUse(const APort:Integer;const Address:string='localhost'):Boolean;
var
  LTcpClient : TIdTCPClient;
begin
  LTcpClient := TIdTCPClient.Create(nil);
  try
    try
      LTcpClient.Host           := Address;
      LTcpClient.Port           := APort;
      LTcpClient.ConnectTimeout := 200;
      LTcpClient.Connect;
      Result := True;
    except
      Result := False;
    end;
  finally
    freeAndNil(LTcpClient);
  end;
end;

      

     
    ===============================================================================
Application Name      : DSFInterface.exe
Memory manager        : FastMM
Compiler Version      : Delphi: 34
Indy Version          : 10.6.2.0
Zeos Version          : 7.2.14-release
Report Unique ID      : {9E064C95-AA3D-4658-BF59-FFE405865C5C}
Start Time            : 2021-08-05 11:45:18.843
Exception Time        : 2021-08-05 11:46:20.381
Application up time   :  1 minute 1 second 538 milliseconds
===============================================================================
Processor             : LENOVO, LNVNB161216, AMD64 Family 21 Model 112 Stepping 0, AMD A4-9125 RADEON R3, 4 COMPUTE CORES 2C+2G   , 2.3 GHz
System                : Windows 10 (Version 10.0, Build 19043, 64-bit Edition)
Display               : 1680x1050 pixels, 96 bpp
Total Physical Memory :   6.608 GB
Free Physical Memory  :   2.137 GB
Max used Memory       :   201.594 MB
===============================================================================
Exception class       : EIdNotASocket
Socket Error # 10038
Socket operation on non-socket.
Exception address     : 000000000095CAD1
Exception trigger     : ExceptionAcquired
-------------------------------------------------------------------------------
Module                : JclDebug
Command Line          : D:\Applications-Folder\DSFInterface\DSFInterface.exe
Procedure             : JclDebug.TJclStackInfoList.Create
Unit                  : JclDebug.pas
Line                  : 5509
-------------------------------------------------------------------------------
[00000000009075B1] JclDebug.TJclStackInfoList.Create (Line 5509, "JclDebug.pas" + 34) + $0
[00000000009070D2] JclDebug.JclCreateStackList (Line 5351, "JclDebug.pas" + 1) + $3E
[0000000000906FB4] JclDebug.DoExceptionStackTrace (Line 5292, "JclDebug.pas" + 20) + $1F
[0000000000909E0C] JclDebug.DoExceptNotify (Line 6741, "JclDebug.pas" + 7) + $0
[00000000008F54C2] JclHookExcept.TNotifierItem.DoNotify (Line 272, "JclHookExcept.pas" + 5) + $1D
[00000000008F5793] JclHookExcept.DoExceptNotify (Line 347, "JclHookExcept.pas" + 21) + $2B
[00000000008F5890] JclHookExcept.HookedRaiseException (Line 381, "JclHookExcept.pas" + 14) + $0
[0000000000410EE3] System.@RaiseAtExcept (Line 22019, "System.pas" + 32) + $0
[0000000000410F01] System.@RaiseExcept (Line 22108, "System.pas" + 2) + $0
[000000000095CAD1] IdStack.TIdStack.RaiseSocketError (Line 976, "IdStack.pas" + 54) + $0
[000000000095CA61] IdStack.TIdStack.RaiseLastSocketError (Line 900, "IdStack.pas" + 2) + $0
[000000000095C98E] IdStack.TIdStack.CheckForSocketError (Line 875, "IdStack.pas" + 4) + $0
[00000000009568E2] IdStackWindows.TIdStackWindows.Connect (Line 2072, "IdStackWindows.pas" + 21) + $0
[000000000099BE3B] IdSocketHandle.TIdSocketHandle.Connect (Line 296, "IdSocketHandle.pas" + 2) + $0
[00000000009A1763] IdIOHandlerStack.TIdConnectThread.Execute (Line 488, "IdIOHandlerStack.pas" + 2) + $11
[000000000054E4A3] System.Classes.ThreadProc (Line 15573, "System.Classes.pas" + 18) + $E
[0000000000411A1D] System.ThreadWrapper (Line 25380, "System.pas" + 9) + $7
[00007FFC6CC67034] BaseThreadInitThunk + $14
[00007FFC6CE02651] RtlUserThreadStart + $21

     

  13. Posted · Edited by Hafedh TRIMECHE

    The leak is generated by a bad usage of SSL routine. The result of Base64Decode (TBytes=Blob) is passed to d2i_OCSP_RESPONSE as a Pointer not double Pointer PPointer.
    Bad: 

      PBlob := Blob;
  resp  := d2i_OCSP_RESPONSE(nil,@PBlob,Length(Blob));

    Correct: 

      PBlob := @Blob;
  resp  := d2i_OCSP_RESPONSE(nil,@PBlob,Length(Blob));

    Thus, the content of TBytes is modified by changing it's prefix (RefCnt, Length, ...) not by reallocating it.

     

    Sorry for the inconvenience.

  14. Posted

    8 hours ago, Stefan Glienke said:

    @Remy Lebeau The LStrFromPWCharLen entry indeed looks wrong - but the lines before and after that exactly match with the 10.3.3 code - I just checked. Maybe it's just a glitch in the stack walking code done by FastMM_FullDebugMode.dll

     

    Edit: Yep - I can repro the wrong entry in the call stack with this code:

      

    
uses
  FastMM5,
  System.SysUtils;

var
  x: TBytes;
  s: string;
  r: RawByteString;
begin
  s := 'test';
  r := RawByteString(s);
  SetLength(x, 10);
  Pointer(x) := nil;
  ReportMemoryLeaksOnShutdown := True;
end.

    and get this report:

      

    
This block was allocated by thread 0x432C, and the stack trace (return addresses) at the time was:
004128BA [FastMM5.pas][FastMM5][FastMM_DebugGetMem$qqri][7717]
0040476D [System.pas][System][@ReallocMem$qqrrpvi][5022]
00408181 [System.pas][System][DynArraySetLength$qqrrpvpvipi][36046]
00406E08 [System.pas][System][@LStrFromPWCharLen$qqrr27System.%AnsiStringT$us$i0$%pbius][26213]  <-- ?!?!
004082C2 [System.pas][System][@DynArraySetLength$qqrv][36150]
004265D9 
7732FA29 [BaseThreadInitThunk]
77E87C7E [RtlGetAppContainerNamedObjectPath]
77E87C4E [RtlGetAppContainerNamedObjectPath]

     

    My guess would be that the: 

    
PUSH    ESP
ADD     dword ptr [ESP],4

    in _DynArraySetLength is not properly handled by the stack walking code.

     

    Obviously, a defect in JclDebug LogStackTrace in FastMM_FullDebugMode.dpr - compiling FastMM_FullDebugMode.dll with madExcept gives this call stack as it just passes to madStackTrace.FastMM_LogStackTrace which seems to do a better job:

      

    
004128b5 +015 Project53.exe FastMM5  7717  +4 FastMM_DebugGetMem
00404767 +03f Project53.exe System   5022 +91 @ReallocMem
0040817c +16c Project53.exe System  36046 +70 DynArraySetLength
004082bd +005 Project53.exe System  36150  +3 @DynArraySetLength
7732fa27 +017 KERNEL32.DLL                    BaseThreadInitThunk

    Probably the bug is in GetRawStackTrace and madExcept is just able to fix it - I am not entirely sure - as far as I can see there is no method in JclDebug that can build a call stack from the data that FastMM_FullDebugMode GetRawStackTrace collects - that is why LogStackTrace simply iterates the entries and calls GetLocationInfo on each of them and just concats them.

     

    @Pierre le Riche fyi

    The leak is generated by a bad usage of SSL routine. The result of Base64Decode (TBytes=Blob) is passed to d2i_OCSP_RESPONSE as a Pointer not double Pointer PPointer.
    Bad: 

      PBlob := Blob;
  resp  := d2i_OCSP_RESPONSE(nil,@PBlob,Length(Blob));

    Correct: 

      PBlob := @Blob;
  resp  := d2i_OCSP_RESPONSE(nil,@PBlob,Length(Blob));

    Best regards.

  15. Posted · Edited by Hafedh TRIMECHE

    2 hours ago, David Heffernan said:

    The code that we can see can't leak. There is likely a bug in some other code, probably your code. If you show a minimal repro we'll find it easily. 

    I guess that is a Reallocation problem!

    The code changed to: 

      SetLength(Result,0);
  SetLength(Result,OutLen);


    solved the problem. But it's at a higher risk: Result content would be lost when setting length to 0.

  16. Posted

    Delphi: 10.3 Version 26.0.36039.7899

     

    This code generates a memory at the first call to SetLength:

      

    A memory block has been leaked. The size is: 519

This block was allocated by thread 0x2010, and the stack trace (return addresses) at the time was:
00420A36 [FastMM5.pas][FastMM5][FastMM_DebugGetMem][7718]
006E43A7 [uMemory.pas][uMemory][NewAllocMem][88]
00407441 [System.pas][System][@ReallocMem][5022]
0040DB51 [System.pas][System][DynArraySetLength][36046]
0040B09C [System.pas][System][@LStrFromPWCharLen][26213]
0040DC92 [System.pas][System][@DynArraySetLength][36150]
00811B23 [uCommon.pas][uCommon][Mime64Decode][3729]
00928D49 [uXMLSec.pas][uXMLSec][NodeGetBase64Value][311]
0092B828 [uXMLSec.pas][uXMLSec][VerifyNode][893]
0092C0D4 [uXMLSec.pas][uXMLSec][TXMLSec.Verify][1006]
00D43D7A [Main.pas][Main][TMainForm.UpdateAttachmentsAndSignatures][298]
00D44784 [Main.pas][Main][TMainForm.LoadFile][427]
00D44886 [Main.pas][Main][TMainForm.BtnOpenClick][443]
00578075 [Vcl.Controls.pas][Vcl.Controls][TControl.Click][7536]
0059B84F [Vcl.StdCtrls.pas][Vcl.StdCtrls][TCustomButton.Click][5470]
0059C365 [Vcl.StdCtrls.pas][Vcl.StdCtrls][TCustomButton.CNCommand][5931]
00577B19 [Vcl.Controls.pas][Vcl.Controls][TControl.WndProc][7420]
75FD5E7A [Unknown function at GetClassLongW]
75FD60BF [Unknown function at GetClassLongW]
75FD5EBC [Unknown function at GetClassLongW]
    function Mime64Decode(const Encoded:string):TBytes;
var
  InLen  ,
  OutLen : NativeUInt;
  Raw    : RawByteString;
begin
  Raw    := RawByteString(Encoded);
  InLen  := Length(Encoded);
  OutLen := 0;
  if InLen>0 then
  begin
    OutLen := MimeDecodedSize(InLen);
    SetLength(Result,OutLen);
    try
      OutLen := MimeDecode(Raw[1],InLen,Result[0]);
    except
      OutLen := 0;
    end;
  end;
  SetLength(Result,OutLen);
end;

     

    Is there any alternative to allocate memory to TBytes?

     

    Best regards.

  18. Posted · Edited by Hafedh TRIMECHE

    Exceptions are raised if Connected function is called before a connection attempt is made using Connect method.

    the variable FConnectionAttempt is introduced and initialized to False within the overridden InitComponent method: 

    procedure TTCPClient.InitComponent;
begin
  LoadOpenSSL;
  InitRecord(FConfig,SizeOf(FConfig));
  inherited;
  FConnectionAttempt := False;
  IOHandler          := nil;
  FCS                := TTCPLock.Create(ClassName);
  Tagged             := False;
  CompressClass      := nil;
  FSSLHandler        := TSSLIOClient.Create(Self);
  FPeerCertificate   := '';
  FCommonName        := '';
  FBound             := False;
  FOnConnect         := nil;
  FOnVerify          := nil;
  FOnDisconnect      := nil;
  OnConnected        := nil;
  OnDisconnected     := nil;
  Timeout            := IdTimeoutDefault;
  Ciphers            := 'DEFAULT';
  SSLEnabled         := False;
end;
    function TTCPClient.Connected:Boolean;
begin
  if (not FConnectionAttempt) then Exit(False);
  try
    Result := (inherited Connected);
  except
    Result := False;
  end;
end;
    procedure TTCPClient.Connect;
var
  LConfig : TTCPConfig;
begin
  Lock;
  LConfig := FConfig;
  Unlock;
  if LConfig.HostOrIP='' then Exit;
  Disconnect;
  try
    inherited Host := LConfig.HostOrIP;
    inherited Port := LConfig.Port
  except
  end;
  if LConfig.SSLEnabled then IOHandler := FSSLHandler
                        else IOHandler := nil;
  try
    inherited Connect;
  except
    on E: Exception do HandleException(E);
  end;
  FConnectionAttempt := True;
end;

    It seams that calling Connected function before invoking Connect method generates an access to components/objects not already initialized (fSSLSocket and/or fSSL).

     

    After modification made, no exception is raised.

     

  19. Posted

    Now the exception is raised inside OpenSSL libraries (libeay32.dll) EC_GROUP_get_degree: 

    ===============================================================================
Application Name      : PGFClient.exe
Memory manager        : msvcrt.dll
Compiler Version      : Delphi: 33
Indy Version          : 10.6.2.0
Zeos Version          : 7.2.6-stable
Report Unique ID      : {17CF23EB-3608-40C5-B1F7-3EB94BA7BA55}
Start Time            : 2020-06-10 21:15:28.616
Exception Time        : 2020-06-10 21:16:06.970
Application up time   :  38 seconds 354 milliseconds
===============================================================================
Processor             : eMachines, eMachines G640, AMD64 Family 16 Model 6 Stepping 3, AMD Athlon(tm) II P320 Dual-Core Processor, 2.095 GHz
System                : Windows 10 (Version 10.0, Build 18362, 64-bit Edition)
Display               : 1680x1050 pixels, 96 bpp
Total Physical Memory :   5.748 GB
Free Physical Memory  :   1.553 GB
Max used Memory       :   180.152 MB
===============================================================================
Exception class       : EAccessViolation
Access violation at address 62A56256 in module 'libeay32.dll'. Read of address FEEEFF0E
Exception trigger     : UnhandledException
-------------------------------------------------------------------------------
Module                : 
Command Line          : D:\Applications-Folder\PGFClient\PGFClient.exe
Procedure             : EC_GROUP_get_degree
-------------------------------------------------------------------------------
[62A56256] EC_GROUP_get_degree + $6
[00554DEB] System.SyncObjs.TCriticalSection.Release + $B
[007D6C49] IdSSLOpenSSL.SslLockingCallback (Line 2249, "IdSSLOpenSSL.pas" + 16) + $5
[00409A5C] System.TMonitor.Enter + $10
[00409F34] System.TMonitor.TryEnter + $28
[00409BEA] System.TMonitor.Exit + $6
[007D9E51] IdSSLOpenSSL.TIdSSLSocket.Connect (Line 3782, "IdSSLOpenSSL.pas" + 36) + $B
[007D85BE] IdSSLOpenSSL.TIdSSLIOHandlerSocketOpenSSL.OpenEncodedConnection (Line 3091, "IdSSLOpenSSL.pas" + 54) + $13
[007D7EDE] IdSSLOpenSSL.TIdSSLIOHandlerSocketOpenSSL.StartSSL (Line 2819, "IdSSLOpenSSL.pas" + 2) + $2
[007D7EC1] IdSSLOpenSSL.TIdSSLIOHandlerSocketOpenSSL.ConnectClient (Line 2813, "IdSSLOpenSSL.pas" + 23) + $5
[0079F12A] IdIOHandlerSocket.TIdIOHandlerSocket.Open (Line 369, "IdIOHandlerSocket.pas" + 13) + $4
[007D7F56] IdSSLOpenSSL.TIdSSLIOHandlerSocketOpenSSL.Open (Line 2839, "IdSSLOpenSSL.pas" + 2) + $0
[0079AB5C] IdTCPClient.TIdTCPClientCustom.Connect (Line 328, "IdTCPClient.pas" + 54) + $B
[0079596D] IdIOHandler.TIdIOHandler.SetHost (Line 1958, "IdIOHandler.pas" + 1) + $8
[007DF1FF] uTCP.TTCPClient.Connect (Line 1699, "uTCP.pas" + 14) + $3
[00B2ACB1] uAsyncTCP.TTCPAsyncClient.Connect (Line 774, "uAsyncTCP.pas" + 8) + $4
[00B29FF4] uAsyncTCP.TTCPAsyncThread.Execute (Line 442, "uAsyncTCP.pas" + 42) + $6
[004DA455] System.Classes.ThreadProc + $49
[0040ADAC] System.ThreadWrapper + $28

     

  20. Posted

    The function Readable is overridden to avoid exception. 

    type
  TIdSSLSocketWrapper=class(TIdSSLSocket);

function TSSLIOClient.Readable(AMSec:Integer):Boolean;
var
  IdSSLSocketWrapper : TIdSSLSocketWrapper;
begin
  IdSSLSocketWrapper := TIdSSLSocketWrapper(fSSLSocket);
  Result             := Assigned(IdSSLSocketWrapper) and Assigned(IdSSLSocketWrapper.fSSL);
  Result             := Result and inherited;
end;

     

  21. Posted · Edited by Hafedh TRIMECHE

    This TCP Client Wrapper is used for connecting to the server: 

    type
  TTCPClientNotify  = procedure(Client:TTCPClient) of object;
  TTCPClientVerify  = function(Client:TTCPClient;const Certificate:string):Boolean of object;

  TSSLOptions=class
  private
    FP12         : TBytes;
    FKeyPassword : string;
    FPEMCert     ,
    FPEMKey      : string;
    FCiphers     : string;
  public
    constructor Create;
    property    P12         : TBytes read FP12         write FP12;
    property    KeyPassword : string read FKeyPassword write FKeyPassword;
    property    Ciphers     : string read FCiphers     write FCiphers;
  end;

  TSSLIOClient = class(TIdSSLIOHandlerSocketOpenSSL)
  private
    FSSLOptions : TSSLOptions;
    FCACert     : PX509;
    FCert       : PX509;
    FPrivateKey : PEVP_PKEY;
    procedure InitSSLContext;
    property  PassThrough;
    function  GetPeerCert:string;
    function  GetPeerCommonName:string;
  protected
    procedure InitComponent;override;
  public
    destructor Destroy;override;
    property   SSLOptions:TSSLOptions read FSSLOptions write FSSLOptions;
    procedure  StartSSL;override;
    property   PeerCert       : string read GetPeerCert;
    property   PeerCommonName : string read GetPeerCommonName;
  end;

  TTCPConfig=
  packed record
    HostOrIP          : string;
    Port              : Integer;
    Tagged            : Boolean;
    MaxConnections    : Word;
    Timeout           : Integer;
    P12               : TBytes;
    KeyPassword       : string;
    Ciphers           : string;
    SSLEnabled        : Boolean;
    LinkCheckInterval : Integer;
  end;

  TTCPClient=class(TIdTCPClient)
  strict private
    property OnConnected;
    property OnDisconnected;
  private
  var
    FCS              : TTCPLock;
    FSSLHandler      : TSSLIOClient;
    FPeerCertificate : string;
    FCommonName      : string;
    FConfig          : TTCPConfig;
    FLastError       : Integer;
    FLastErrorDesc   : string;
    FBound           : Boolean;
    FOnConnect       : TTCPClientNotify;
    FOnVerify        : TTCPClientVerify;
    FOnDisconnect    : TTCPClientNotify;
    procedure ClearErrors;
    procedure SetHostOrIP(Value:string);
    procedure SetRemotePort(Value:Integer);
    procedure SetTagged(Value:Boolean);
    procedure SetTimeout(Value:Integer);
    procedure SetP12(Value:TBytes);
    procedure SetKeyPassword(Value:string);
    procedure SetCiphers(Value:string);
    procedure SetSSLEnabled(Value:Boolean);
    function  GetPeerInfo(Index:Integer):string;
    procedure HandleException(AException:Exception);
    procedure SetBound(Value:Boolean);
  protected
    procedure InitComponent;override;
    procedure DoOnConnected;override;
    procedure DoOnDisconnected;override;
    function  DoOnVerify(const PEMCert:string):Boolean;virtual;
  public
    Destructor Destroy;override;
    procedure  Lock;
    procedure  Unlock;
  public
    property  Host          : string           read FConfig.HostOrIP    write SetHostOrIP;
    property  Port          : Integer          read FConfig.Port        write SetRemotePort;
    property  Tagged        : Boolean          read FConfig.Tagged      write SetTagged;
    property  Timeout       : Integer          read FConfig.Timeout     write SetTimeout;
    property  P12           : TBytes           read FConfig.P12         write SetP12;
    property  KeyPassword   : string           read FConfig.KeyPassword write SetKeyPassword;
    property  Ciphers       : string           read FConfig.Ciphers     write SetCiphers;
    property  SSLEnabled    : Boolean          read FConfig.SSLEnabled  write SetSSLEnabled;
    procedure SetError(ErrorCode:Integer;ErrorDesc:string);
    procedure AssignConfig(Config:TTCPConfig);
    procedure Connect;overload;override;
    procedure Connect(const AHost:string;const APort:Integer);reintroduce;overload;
    procedure Reconnect;
    procedure Disconnect(ANotifyPeer:Boolean);override;
    function  Connected:Boolean;override;
    property  Bound : Boolean read FBound write SetBound;
  public
    property  LastError       : Integer read FLastError;
    property  LastErrorDesc   : string  read FLastErrorDesc;

    property  PeerCertificate : string index 1 read GetPeerInfo;
    property  CommonName      : string index 2 read GetPeerInfo;
  public
    property  OnConnect    : TTCPClientNotify read FOnConnect    write FOnConnect;
    property  OnVerify     : TTCPClientVerify read FOnVerify     write FOnVerify;
    property  OnDisconnect : TTCPClientNotify read FOnDisconnect write FOnDisconnect;
  end;

implementation

procedure HandleSocketException(E:Exception;var SocketError:Integer);
begin
  if E=nil then SocketError := 0 else
  begin
    SocketError := WSANO_RECOVERY;
    if (E is EIdSocketError)          then SocketError := (E as EIdSocketError).LastError else
    if (E is EIdOpenSSLError)         then SocketError := Id_WSAENOPROTOOPT               else
    if (E is EIdReadTimeout)          then SocketError := Id_WSAETIMEDOUT                 else
    if (E is EIdConnClosedGracefully) then SocketError := Id_WSAEHOSTDOWN                 else
    if (E is EIdAlreadyConnected)     then SocketError := Id_WSAEISCONN                   ;
  end;
end;
///////////////////////////////////////////////////////////////////////////
constructor TSSLOptions.Create;
begin
  LoadOpenSSL;
  FP12         := nil;
  FKeyPassword := '';
  FPEMCert     := '';
  FPEMKey      := '';
  FCiphers     := '';
end;
///////////////////////////////////////////////////////////////////////////
function VerifyCallback(ok:TIdC_INT;ctx:PX509_STORE_CTX):TIdC_INT;cdecl;
begin
  Result := 1;
end;

function TSSLIOClient.GetPeerCert: string;
begin
  if Assigned(fSSLSocket) and Assigned(fSSLSocket.PeerCert) then Result := TCPX509ToPEM(fSSLSocket.PeerCert.Certificate)
                                                            else Result := '';
end;

function TSSLIOClient.GetPeerCommonName:string;
begin
  if Assigned(fSSLSocket) and Assigned(fSSLSocket.PeerCert) then Result := TCPX509Name(fSSLSocket.PeerCert.Certificate)
                                                            else Result := '';
end;

procedure TSSLIOClient.InitComponent;
begin
  LoadOpenSSL;
  inherited;
  FCACert              := nil;
  FCert                := nil;
  FPrivateKey          := nil;
  FSSLOptions          := TSSLOptions.Create;
  FSSLOptions.FCiphers := SSLClientCiphers;
  PassThrough          := False;
end;

destructor TSSLIOClient.Destroy;
begin
  Close;
  if FCACert    <>nil then X509_free(FCACert);
  if FCert      <>nil then X509_free(FCert);
  if FPrivateKey<>nil then EVP_PKEY_free(FPrivateKey);
  FreeAndNil(FSSLOptions);
  inherited;
end;

type
  TTCPSSLContext = class(TIdSSLContext)
  public
    constructor Create;
  end;

constructor TTCPSSLContext.Create;
const
  SSLVersion = High(TIdSSLVersion);
begin
  inherited;
  RootCertFile := '';
  CertFile     := '';
  KeyFile      := '';
  DHParamsFile := '';
  VerifyDepth  := 0;
  VerifyMode   := [];
  VerifyDirs   := '';
  CipherList   := '';
  VerifyOn     := False;
  StatusInfoOn := False;
  Method       := sslvSSLv23;
  SSLVersions  := [SSLVersion,Pred(SSLVersion)];
end;

procedure TSSLIOClient.InitSSLContext;
begin
  if Assigned(fSSLContext) then FreeAndNil(fSSLContext);
  fSSLContext              := TTCPSSLContext.Create;
  fSSLContext.Parent       := Self;
  fSSLContext.StatusInfoOn := Assigned(fOnStatusInfo) or Assigned(fOnStatusInfoEx);
  fSSLContext.Mode         := sslmClient;
  TTCPSSLContext(fSSLContext).InitContext(sslCtxClient);
end;

procedure TSSLIOClient.StartSSL;
var
  Error   : Integer;
  FSSLCtx : PSSL_CTX;
begin
  InitSSLContext;
  FSSLCtx := TTCPSSLContext(fSSLContext).fContext;
  Error   := SSL_CTX_set_options(FSSLCtx,SSL_OP_STRONG);
  if Error>0 then
  begin
    SSL_CTX_set_mode(FSSLCtx,SSL_MODE_AUTO_RETRY);
    PrepareSSL(FSSLOptions,FCACert,FCert,FPrivateKey);
    if Assigned(FPrivateKey) and Assigned(FCACert) and Assigned(FCert) then
    begin
      if Error>0 then Error := SSL_CTX_use_certificate(FSSLCtx,FCert);
      if Error>0 then Error := SSL_CTX_use_PrivateKey(FSSLCtx,FPrivateKey);
      if Error>0 then Error := SSL_CTX_check_private_key(FSSLCtx);
    end;
    SSL_CTX_set_verify(FSSLCtx,SSL_VERIFY_PEER,VerifyCallback);
    SSL_CTX_set_verify_depth(FSSLCtx,1);
    if Error>0 then Error := SSL_CTX_ctrl(FSSLCtx,SSL_CTRL_SET_ECDH_AUTO,1,nil);
    if (Error>0) and (FSSLOptions.FCiphers<>'') then
    begin
      Error := SSL_CTX_set_cipher_list(FSSLCtx,PAnsiChar(RawByteString(FSSLOptions.FCiphers)));
    end;
  end;
  if Error<=0 then
  begin
    FreeAndNil(fSSLContext);
    EIdOSSLCreatingContextError.RaiseException(RSSSLCreatingContextError);
  end;
  inherited;
end;
///////////////////////////////////////////////////////////////////////////
procedure TTCPClient.InitComponent;
begin
  LoadOpenSSL;
  InitRecord(FConfig,SizeOf(FConfig));
  inherited;
  FCS              := TTCPLock.Create(ClassName);
  Tagged           := False;
  FSSLHandler      := TSSLIOClient.Create(Self);
  FPeerCertificate := '';
  FCommonName      := '';
  FBound           := False;
  FOnConnect       := nil;
  FOnVerify        := nil;
  FOnDisconnect    := nil;
  OnConnected      := nil;
  OnDisconnected   := nil;
  Timeout          := IdTimeoutDefault;
  Ciphers          := 'DEFAULT';
  SSLEnabled       := False;
end;

procedure TTCPClient.Lock;
begin
  FCS.Lock;
end;

procedure TTCPClient.Unlock;
begin
  FCS.Unlock;
end;

procedure TTCPClient.SetHostOrIP(Value: string);
var
  _Port   : Integer;
  _Params : string;
begin
  Value := ParseURI(Trim(Value),0,_Port,_Params);
  if (FConfig.HostOrIP=Value) and (FConfig.Port=_Port) then Exit;
  Lock;
  FConfig.HostOrIP := Value;
  if _Port>0 then FConfig.Port := _Port;
  Unlock;
end;

procedure TTCPClient.SetRemotePort(Value: Integer);
begin
  if FConfig.Port=Value then Exit;
  Lock;
  FConfig.Port := Value;
  Unlock;
end;

procedure TTCPClient.SetTagged(Value:Boolean);
begin
  if FConfig.Tagged=Value then Exit;
  if Connected then raise TCPException.Create('Tagged can only be set when connection is closed !...');
  Lock;
  FConfig.Tagged := Value;
  Unlock;
end;

procedure TTCPClient.SetTimeout(Value:Integer);
begin
  if Value<=0 then Value := IdTimeoutDefault;
  if FConfig.Timeout=Value then Exit;
  Lock;
  FConfig.Timeout := Value;
  ReadTimeout     := TimeoutMS(FConfig.Timeout);
  Unlock;
end;

procedure TTCPClient.SetP12(Value:TBytes);
begin
  if Similar(Value,FConfig.P12) then Exit;
  Lock;
  FConfig.P12 := Value;
  Unlock;
end;

procedure TTCPClient.SetKeyPassword(Value: string);
begin
  Value := Trim(Value);
  if FConfig.KeyPassword=Value then Exit;
  Lock;
  FConfig.KeyPassword := Value;
  Unlock;
end;

procedure TTCPClient.SetCiphers(Value: string);
begin
  Value := Trim(Value);
  if FConfig.Ciphers=Value then Exit;
  Lock;
  FConfig.Ciphers := Value;
  Unlock;
end;

procedure TTCPClient.SetSSLEnabled(Value:Boolean);
begin
  if FConfig.SSLEnabled=Value then Exit;
  Lock;
  FConfig.SSLEnabled := Value;
  Unlock;
end;

destructor TTCPClient.Destroy;
begin
  Disconnect;
  FreeAndNil(FCS);
  inherited;
end;

function TTCPClient.DoOnVerify(const PEMCert:string):Boolean;
begin
  if Assigned(FOnVerify) then Result := FOnVerify(Self,PEMCert)
                         else Result := True;
end;

procedure TTCPClient.DoOnConnected;
begin
  inherited;
  Socket.Binding.SetKeepAliveValues(True,KeepAliveDefault,KeepAliveIntervalDefault);
  if Assigned(FSSLHandler) then
  begin
    FPeerCertificate := FSSLHandler.PeerCert;
    FCommonName      := FSSLHandler.PeerCommonName;
  end
  else
  begin
    FPeerCertificate := '';
    FCommonName      := '';
  end;
  if DoOnVerify(FPeerCertificate) then
  begin
    if Assigned(FOnConnect) then FOnConnect(Self);
    if Assigned(FCompressor) then FCompressor.FActive := True;
  end
  else Disconnect;
end;

procedure TTCPClient.SetBound(Value:Boolean);
begin
  Lock;
  FBound := Value;
  Unlock;
end;

procedure TTCPClient.DoOnDisconnected;
begin
  inherited;
  if Assigned(FOnDisconnect) then FOnDisconnect(Self);
end;

function TTCPClient.GetPeerInfo(Index:Integer): string;
begin
  case Index of
    1 : Result := FPeerCertificate;
    2 : Result := FCommonName;
  end;
end;

procedure TTCPClient.AssignConfig(Config:TTCPConfig);
begin
  FConfig.HostOrIP          := Config.HostOrIP;
  FConfig.Port              := Config.Port;
  FConfig.Tagged            := Config.Tagged;
  FConfig.Timeout           := Config.Timeout;
  FConfig.P12               := Config.P12;
  FConfig.KeyPassword       := Config.KeyPassword;
  FConfig.Ciphers           := Config.Ciphers;
  FConfig.SSLEnabled        := Config.SSLEnabled;
  FConfig.LinkCheckInterval := Config.LinkCheckInterval;
end;

procedure TTCPClient.HandleException(AException: Exception);
begin
  inherited;
  HandleSocketException(AException,FLastError);
  Lock;
  FLastErrorDesc := AException.Message;
  Unlock;
end;

procedure TTCPClient.ClearErrors;
begin
  Lock;
  FLastError     := 0;
  FLastErrorDesc := '';
  Unlock;
end;

procedure TTCPClient.SetError(ErrorCode:Integer;ErrorDesc: string);
begin
  Lock;
  FLastError     := ErrorCode;
  FLastErrorDesc := ErrorDesc;
  Unlock;
end;

function TTCPClient.Connected: Boolean;
begin
  try
    Result := (inherited Connected);
  except
    Result := False;
  end;
end;

procedure TTCPClient.Disconnect(ANotifyPeer:Boolean);
begin
  try
    inherited Disconnect(ANotifyPeer);
  except
  end;
end;

procedure TTCPClient.Connect;
var
  LConfig : TTCPConfig;
begin
  Lock;
  LConfig := FConfig;
  Unlock;
  if LConfig.HostOrIP='' then Exit;
  Disconnect;
  try
    inherited Host := LConfig.HostOrIP;
    inherited Port := LConfig.Port
  except
  end;
  if LConfig.SSLEnabled then IOHandler := FSSLHandler
                        else IOHandler := nil;
  try
    inherited Connect;
  except
    on E: Exception do HandleException(E);
  end;
end;

procedure TTCPClient.Connect(const AHost:string;const APort:Integer);
begin
  SetHostOrIP(AHost);
  SetRemotePort(APort);
  Connect;
end;

procedure TTCPClient.Reconnect;
begin
  Connect;
end;
///////////////////////////////////////////////////////////////////////////

    TTCPClient connection is invoked from a the Thread Pool: 

    function TTCPAsyncClient.Connect(Client:TTCPClient):Boolean;
begin
  if FTerminated then Exit(False);
  Client.AssignConfig(FConfig);
  Client.Bound := False;
  if Client.Connected then Client.Disconnect;
  Result := False;
  if Client.Host<>'' then
  begin
    Client.Connect;
    Result := Client.Connected;
  end;
end;

    But this exception is raised: 

    ===============================================================================
Application Name      : PGFClient.exe
Memory manager        : msvcrt.dll
Compiler Version      : Delphi: 33
Indy Version          : 10.6.2.0
Zeos Version          : 7.2.6-stable
Report Unique ID      : {E824D1A9-DCC4-4F71-ADC7-0882AB6D23DD}
Start Time            : 2020-06-10 20:05:08.588
Exception Time        : 2020-06-10 20:05:58.583
Application up time   :  49 seconds 995 milliseconds
===============================================================================
Processor             : eMachines, eMachines G640, AMD64 Family 16 Model 6 Stepping 3, AMD Athlon(tm) II P320 Dual-Core Processor, 2.095 GHz
System                : Windows 10 (Version 10.0, Build 18362, 64-bit Edition)
Display               : 1680x1050 pixels, 96 bpp
Total Physical Memory :   5.748 GB
Free Physical Memory  :   1.772 GB
Max used Memory       :   174.250 MB
===============================================================================
Exception class       : EAccessViolation
Access violation at address 007D7F78 in module 'PGFClient.exe'. Read of address 0000000C
Exception trigger     : UnhandledException
-------------------------------------------------------------------------------
Module                : IdSSLOpenSSL
Command Line          : D:\Applications-Folder\PGFClient\PGFClient.exe
Procedure             : IdSSLOpenSSL.TIdSSLIOHandlerSocketOpenSSL.Readable
Unit                  : IdSSLOpenSSL.pas
Line                  : 2846
-------------------------------------------------------------------------------
[007D7F78] IdSSLOpenSSL.TIdSSLIOHandlerSocketOpenSSL.Readable (Line 2846, "IdSSLOpenSSL.pas" + 3) + $6
[00620030] Vcl.Themes.{System.Generics.Collections}TList<Vcl.Themes.TStyleHookClass>.GetCapacity + $8
[0079517D] IdIOHandler.TIdIOHandler.ReadFromSource (Line 1696, "IdIOHandler.pas" + 21) + $8
[0079B59A] IdIOHandlerStack.TIdIOHandlerStack.Connected (Line 243, "IdIOHandlerStack.pas" + 1) + $8
[007A153E] IdTCPConnection.TIdTCPConnection.Connected (Line 503, "IdTCPConnection.pas" + 7) + $4
[007DF064] uTCP.TTCPClient.Connected (Line 1653, "uTCP.pas" + 2) + $0
[00B29DAA] uAsyncTCP.TTCPAsyncThread.Connected (Line 383, "uAsyncTCP.pas" + 1) + $B
[00B2AD19] uAsyncTCP.TTCPAsyncClient.Connect (Line 803, "uAsyncTCP.pas" + 14) + $7
[00DE881E] uClient.TMainForm.ControllerStart (Line 1760, "uClient.pas" + 47) + $9
[00BC5E71] uMainForm.TUForm.SafeActivate (Line 1288, "uMainForm.pas" + 10) + $14
[00BC66A6] uMainForm.TUForm.WndProc (Line 1521, "uMainForm.pas" + 5) + $3
[0057980C] Vcl.Controls.TWinControl.MainWndProc + $2C
[004DDDDC] System.Classes.StdWndProc + $14
[0067606F] Vcl.Forms.TApplication.ProcessMessage + $F3
[006760B2] Vcl.Forms.TApplication.HandleMessage + $A
[006763E5] Vcl.Forms.TApplication.Run + $C9
[00E2C32D] PGFClient.PGFClient (Line 18, "" + -935) + $7

     

  22. Posted

    Please find the exception raised at the form creation and not at it's shutdown. 

    ===============================================================================
Application Name      : PGFClient.exe
Memory manager        : msvcrt.dll
Compiler Version      : Delphi: 33
Indy Version          : 10.6.2.0
Zeos Version          : 7.2.6-stable
Report Unique ID      : {44B4A782-BEAF-4AB4-AEAC-5863139C89AC}
Start Time            : 2020-06-09 22:42:32.370
Exception Time        : 2020-06-09 22:43:08.037
Application up time   :  35 seconds 667 milliseconds
===============================================================================
Processor             : eMachines, eMachines G640, AMD64 Family 16 Model 6 Stepping 3, AMD Athlon(tm) II P320 Dual-Core Processor, 2.095 GHz
System                : Windows 10 (Version 10.0, Build 18362, 64-bit Edition)
Display               : 1680x1050 pixels, 96 bpp
Total Physical Memory :   5.748 GB
Free Physical Memory  :   2.211 GB
Max used Memory       :   179.254 MB
===============================================================================
Exception class       : EAccessViolation
Access violation at address 007D98E8 in module 'PGFClient.exe'. Read of address 0000000C
Exception trigger     : UnhandledException
-------------------------------------------------------------------------------
Module                : IdSSLOpenSSL
Command Line          : D:\Applications-Folder\PGFClient\PGFClient.exe
Procedure             : IdSSLOpenSSL.TIdSSLSocket.GetSSLError
Unit                  : IdSSLOpenSSL.pas
Line                  : 3647
-------------------------------------------------------------------------------
[007D98E8] IdSSLOpenSSL.TIdSSLSocket.GetSSLError (Line 3647, "IdSSLOpenSSL.pas" + 5) + $1
[007D87F4] IdSSLOpenSSL.TIdSSLIOHandlerSocketOpenSSL.CheckForError (Line 3134, "IdSSLOpenSSL.pas" + 4) + $8
[007952C0] IdIOHandler.TIdIOHandler.ReadFromSource (Line 1737, "IdIOHandler.pas" + 62) + $8
[0079B59A] IdIOHandlerStack.TIdIOHandlerStack.Connected (Line 243, "IdIOHandlerStack.pas" + 1) + $8
[007A153E] IdTCPConnection.TIdTCPConnection.Connected (Line 503, "IdTCPConnection.pas" + 7) + $4
[007DF0EE] uTCP.TTCPClient.Connected (Line 1664, "uTCP.pas" + 7) + $0
[00B29E3E] uAsyncTCP.TTCPAsyncThread.Connected (Line 383, "uAsyncTCP.pas" + 1) + $B
[00B2ADAD] uAsyncTCP.TTCPAsyncClient.Connect (Line 803, "uAsyncTCP.pas" + 14) + $7
[00DE888E] uClient.TMainForm.ControllerStart (Line 1760, "uClient.pas" + 47) + $9
[00BC5ECD] uMainForm.TUForm.SafeActivate (Line 1287, "uMainForm.pas" + 10) + $14
[00BC66FE] uMainForm.TUForm.WndProc (Line 1520, "uMainForm.pas" + 5) + $3
[0057980C] Vcl.Controls.TWinControl.MainWndProc + $2C
[004DDDDC] System.Classes.StdWndProc + $14
[0067606F] Vcl.Forms.TApplication.ProcessMessage + $F3
[006760B2] Vcl.Forms.TApplication.HandleMessage + $A
[006763E5] Vcl.Forms.TApplication.Run + $C9
[00E2C32D] PGFClient.PGFClient (Line 18, "" + -935) + $7

    Would the creation of the the client into a thread be the problem? 

    type
  TTCPAsyncWorker=class(TTCPClient)
  private
  end;
////////////////////////////////////////////////////////////////////////
function TTCPAsyncClient.Connect(Client:TTCPClient):Boolean;
begin
  if FTerminated then Exit(False);
  Client.AssignConfig(FConfig);
  Client.Bound := False;
  if Client.Connected then Client.Disconnect;
  Result := False;
  if Client.Host<>'' then
  begin
    Client.Connect;
    Result := Client.Connected;
  end;
end;
////////////////////////////////////////////////////////////////////////
procedure TTCPAsyncThread.Execute;
var
  TCPHandler : TTCPHandler;
  Data       ,
  Pattern    : TBytes;
begin
  inherited;
  COMInitialize;
  InitRecord(TCPHandler,SizeOf(TCPHandler));
  FWorker              := TTCPAsyncWorker.Create(nil);
  TCPHandler.Worker    := FWorker;
  FWorker.SSLEnabled   := FAsyncClient.SSLEnabled;
  FWorker.Timeout      := IdTimeoutDefault;
  FWorker.OnConnect    := FAsyncClient.DoOnConnect;
  FWorker.OnDisconnect := FAsyncClient.DoOnDisconnect;
  FStarted             := True;
  while (not FAsyncClient.FTerminated) do
  begin
    RelinquishTimeSlice(20);
    if FAsyncClient.FTerminated then Break;
    if (FAsyncClient.Host='') or (FAsyncClient.Port=0) then Continue;
    while FWorker.Bound do
    begin
      if FAsyncClient.Tagged then
      begin
        TCPHandler.Data := FWorker.Read(TCPHandler.AsyncTag);
        if TCPHandler.Data=nil then
        begin
          RelinquishTimeSlice;
          Break;
        end;
        ProcessTagRead(TCPHandler);
      end
      else
      begin
        if (not FAsyncClient.DoOnWaitForData(TCPHandler,Data,Pattern)) then
        begin
          Disconnect;
          Break;
        end;
        MatchData(Data,Pattern);
      end;
    end;
    if FAsyncClient.FTerminated then Break;
    if (not Connected) then
    begin
      if FWorker.LastError<>0 then FAsyncClient.DoOnDisconnect(FWorker);
      FAsyncClient.Connect(FWorker);
    end;
  end;
  COMUninitialize;
  FreeAndNil(FWorker);
end;

    Best regards.

  23. Posted · Edited by Hafedh TRIMECHE

    Thank you Remy,

     

    Indeed, the exception is raised because the function Connected is called before the FSSLHandler is assigned to IOHandler so fSSLSocket and/or fSSL not assigned too. 

    function TIdSSLIOHandlerSocketOpenSSL.Readable(AMSec: Integer = IdTimeoutDefault): Boolean;
begin
  if not fPassThrough then
  begin
    Result := ssl_pending(fSSLSocket.fSSL) > 0;
    if Result then Exit;
  end;
  Result := inherited Readable(AMSec);
end;

     

     

  24. Posted

    Using SSL libraries version 1.0.2u, EAccessViolation  is raised.

    Code used for connection: 

    procedure TTCPClient.Connect;
var
  LConfig : TTCPConfig;
begin
  Lock;
  LConfig := FConfig;
  Unlock;
  if LConfig.HostOrIP='' then Exit;
  Disconnect;
  try
    inherited Host := LConfig.HostOrIP;
    inherited Port := LConfig.Port
  except
  end;
  if LConfig.SSLEnabled then IOHandler := FSSLHandler
                        else IOHandler := nil;
  try
    inherited Connect;
  except
    on E: Exception do HandleException(E);
  end;
end;

      

    ===============================================================================
Application Name      : PGFClient.exe
Memory manager        : msvcrt.dll
Compiler Version      : Delphi: 33
Indy Version          : 10.6.2.0
Zeos Version          : 7.2.6-stable
Report Unique ID      : {4C789C3C-712A-4FE7-B68B-73FF6B4160F1}
Start Time            : 2020-06-07 23:33:47.688
Exception Time        : 2020-06-07 23:34:19.770
Application up time   :  32 seconds 82 milliseconds
===============================================================================
Processor             : eMachines, eMachines G640, AMD64 Family 16 Model 6 Stepping 3, AMD Athlon(tm) II P320 Dual-Core Processor, 2.095 GHz
System                : Windows 10 (Version 10.0, Build 18362, 64-bit Edition)
Display               : 1680x1050 pixels, 96 bpp
Total Physical Memory :   5.748 GB
Free Physical Memory  :   1.092 GB
Max used Memory       :   176.047 MB
===============================================================================
Exception class       : EAccessViolation
Access violation at address 007D7E14 in module 'PGFClient.exe'. Read of address 0000000C
-------------------------------------------------------------------------------
Module                : IdSSLOpenSSL
Command Line          : D:\Applications-Folder\PGFClient\PGFClient.exe
Procedure             : IdSSLOpenSSL.TIdSSLIOHandlerSocketOpenSSL.SetPassThrough
Unit                  : IdSSLOpenSSL.pas
Line                  : 2889
-------------------------------------------------------------------------------
[007D7E14] IdSSLOpenSSL.TIdSSLIOHandlerSocketOpenSSL.SetPassThrough (Line 2889, "IdSSLOpenSSL.pas" + 36) + $1F
[00795019] IdIOHandler.TIdIOHandler.ReadFromSource (Line 1737, "IdIOHandler.pas" + 62) + $1
[0079B436] IdIOHandlerStack.DoConnectTimeout (Line 329, "IdIOHandlerStack.pas" + 76) + $2C
[007A13DA] IdTCPConnection.TIdTCPConnection.DoOnDisconnected (Line 584, "IdTCPConnection.pas" + 1) + $6
[007DEFE0] uTCP.TTCPClient.Connect (Line 1694, "uTCP.pas" + 13) + $A
[00B29D32] uAsyncTCP.TTCPAsyncThread.Execute (Line 421, "uAsyncTCP.pas" + 21) + $0
[00B2AC95] uAsyncTCP.TTCPAsyncClient.Disconnect (Line 842, "uAsyncTCP.pas" + 5) + $3
[00DE877E] uClient.TMainForm.ControllerStart (Line 1781, "uClient.pas" + 68) + $1B
[00BC5DBD] uMainForm.TUForm.Destroy (Line 1304, "uMainForm.pas" + 9) + $8
[00BC65EE] uMainForm.TUForm.WndProc (Line 1554, "uMainForm.pas" + 38) + $22
[0057980C] Vcl.Controls.TWinControl.MainWndProc + $2C
[004DDDDC] System.Classes.StdWndProc + $14
[0067606F] Vcl.Forms.TApplication.ProcessMessage + $F3
[006760B2] Vcl.Forms.TApplication.HandleMessage + $A
[006763E5] Vcl.Forms.TApplication.Run + $C9
[00E2C32D] PGFClient.PGFClient (Line 19, "" + -934) + $7

     

  25. Posted

    You may try this code: 

    procedure GlobalExceptionHandler(ExceptionObj:TObject);
var
  LException : Exception;
begin
  if (ExceptionObj is Exception) then LException := Exception(ExceptionObj)
                                 else LException := nil;
  TExceptionHandler.ProcessException(nil,LException);
end;

constructor TExceptionHandler.Create;
begin
  inherited;
  JclStackTrackingOptions := [stStack,stRawMode,stTraceAllExceptions];
  JclStartExceptionTracking;
  Application.OnException  := ProcessException;
  ExceptionAcquired        := @GlobalExceptionHandler;
end;

destructor TExceptionHandler.Destroy;
begin
  StopExceptionHandler;
  inherited;
end;

    It worked for me !

     

×