Hafedh TRIMECHE
-
Content Count
27 -
Joined
-
Last visited
Posts posted by Hafedh TRIMECHE
-
-
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
-
AutoSize has not effect on a TPanel component. When set to True, the width is kept unchanged.
-
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.
-
Please note that TUButton is a customized component derived from TButton.
-
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.
- 1
-
The Event handler must resume execution.
-
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.
-
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;
-
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.
-
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
-
-
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.
-
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
JclDebugLogStackTrace 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.
-
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. -
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.
-
Hello,
Is there a function GetBaseType which returns the Base Type of a sub-type?
type TCustomDateTime = type TDateTime;
GetBaseType(TypeInfo(TCustomDateTime)) would return TypeInfo(TDateTime).
Best regards.
-
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.
-
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
-
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;
-
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
-
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.
-
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;
-
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
-
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 !
TPanel and AutoSize problem (Delphi 11)
in VCL
Posted
When a Panel is empty (no controls) it would adjust its size to the text width as it is done when using a TLabel.