Forum > QT

[Solved] SigSeg in TQtWidget.GetWidget: QWidgetH;

(1/1)

cdbc:
Hi
Can someone please explain to me, why i get this error, when i run threadcode in my application???


--- Code: Pascal  [+][-]window.onload = function(){var x1 = document.getElementById("main_content_section"); if (x1) { var x = document.getElementsByClassName("geshi");for (var i = 0; i < x.length; i++) { x[i].style.maxHeight='none'; x[i].style.height = Math.min(x[i].clientHeight+15,306)+'px'; x[i].style.resize = "vertical";}};} ---in QtWidgets: function TQtWidget.GetWidget: QWidgetH;begin  Result := QWidgetH(TheObject);end;  Thread code

--- Code: Pascal  [+][-]window.onload = function(){var x1 = document.getElementById("main_content_section"); if (x1) { var x = document.getElementsByClassName("geshi");for (var i = 0; i < x.length; i++) { x[i].style.maxHeight='none'; x[i].style.height = Math.min(x[i].clientHeight+15,306)+'px'; x[i].style.resize = "vertical";}};} --- {------------------------------------------------------------------------------|| Project name: Debug Server                                                   || Unit name   : lfm_main.pas                                                   || Copyright   : (c) 2021 cdbc.dk                                               || Programmer  : Benny Christensen /bc                                          || Created     : 2021.01.13 /bc initial design and coding                       || Updated     : 2020.01.13 /bc Setting up environment, structure and vision    ||                                                                              ||                                                                              ||                                                                              ||                                                                              ||------------------------------------------------------------------------------|| Abstract:                                                                    ||   A debug server to connect to while running a live application.             ||                                                                              ||                                                                              ||                                                                              ||                                                                              |-------------------------------------------------------------------------------} unit debug_srv;{$mode objfpc}{$H+}{.$define debug}interface uses  Classes,  LMessages,  LCLIntf,  sysutils,  blcksock,  synsock; const  { internal messages for use between daemon & app }  LM_CREATE           = LM_USER+1;  LM_LISTEN           = LM_USER+3;  LM_ACCEPT           = LM_USER+5;  LM_WORKING          = LM_USER+7;  LM_DONE             = LM_USER+11;  LM_DESTROY          = LM_USER+13; type  { TTCPDebugDaemon }  TTCPDebugDaemon = class(TThread)  private    fHandle: THandle;    fAddress: string;    fPort: string;    fSock: TTCPBlockSocket;  public    Constructor Create(const aHandle: THandle);    Destructor Destroy; override;    procedure Execute; override;    property Address: string read fAddress write fAddress;    property Port: string read fPort write fPort;  end;   { TTCPDebugThrd }   TTCPDebugThrd = class(TThread)  private    fHandle: THandle;    fSock:TTCPBlockSocket;    CSock: TSocket;  public    Constructor Create(hSock: TSocket;aHandle: THandle);    procedure Execute; override;  end; implementation { TTCPDebugThrd } constructor TTCPDebugThrd.Create(hSock: TSocket; aHandle: THandle);begin  inherited Create(true); // 13.01.2021 / bc:   inherited create(false);  CSock:= hSock;  FreeOnTerminate:= true;  fHandle:= aHandle;  Start; { safer this way, thread may start running before the properties are set! }end; procedure TTCPDebugThrd.Execute;var S: string;begin  fSock:= TTCPBlockSocket.create;  try    fSock.Socket:= CSock;    fSock.GetSins;    with fSock do begin      repeat        if Terminated then break;        S:= RecvPacket(60000);        if LastError <> 0 then break;        PostMessage(fHandle,LM_WORKING,length(S),longint(pchar('Worker thread is running...')));        SendString(S); // here ææ        S:= 'Sent: '+S;//        PostMessage(fHandle,LM_WORKING,length(S),longint(pchar(S)));  //AV        if LastError <> 0 then break;      until false;    end;  finally    fSock.Free;  end;  PostMessage(fHandle,LM_WORKING,0,longint(pchar('Worker thread is Done.')));end; (*var   __Example: TObject; function Example: TObject; { singleton }begin  if not assigned(__Example) then __Example:= TObject.Create;  Result:= __Example;end; { gets released on progam end }*) { TTCPDebugDaemon } constructor TTCPDebugDaemon.Create(const aHandle: THandle);begin  inherited create(true);  fSock:=TTCPBlockSocket.create;  { this is the server socket, it only listens }  FreeOnTerminate:= true;                                 { when done, go away }  fAddress:= '0.0.0.0';                                        { listen to all }  fPort:= '8723';                                                { port ~ 8723 }  fHandle:= aHandle;                     { used for inter-thread communication }  Start;                                              { RUN Forrest run!!! :-) }  PostMessage(fHandle,              LM_CREATE,              strtoint(fPort),              longint(pchar('Debug daemon created...')));end; destructor TTCPDebugDaemon.Destroy;begin  fSock.free;  PostMessage(fHandle,LM_DESTROY,strtoint(fPort),longint(pchar('Debug daemon destroyed...')));  inherited Destroy;end; procedure TTCPDebugDaemon.Execute;var  ClientSock:TSocket;begin  with fSock do begin    CreateSocket;    SetLinger(true,10000);    Bind(fAddress,fPort); //ææ    Listen;    PostMessage(fHandle,LM_LISTEN,strtoint(fPort),longint(pchar('Debug daemon is listening...')));    repeat      if Terminated then break;      if CanRead(1000) then begin        ClientSock:= Accept;        if LastError = 0 then begin          TTCPDebugThrd.Create(ClientSock,fHandle);          PostMessage(fHandle,LM_ACCEPT,strtoint(fPort),longint(pchar('Worker thread created...')));        end;      end;    until false;  end;  PostMessage(fHandle,LM_DONE,strtoint(fPort),longint(pchar('Debug daemon done.')));end; initialization//  __Example:= nil; finalization //  FreeAndNil(__Example);  end. lfm_main.pas code:


--- Code: Pascal  [+][-]window.onload = function(){var x1 = document.getElementById("main_content_section"); if (x1) { var x = document.getElementsByClassName("geshi");for (var i = 0; i < x.length; i++) { x[i].style.maxHeight='none'; x[i].style.height = Math.min(x[i].clientHeight+15,306)+'px'; x[i].style.resize = "vertical";}};} ---unit lfm_main; {$mode objfpc}{$H+} interface uses  Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ComCtrls, StdCtrls,  ExtCtrls,  LMessages,  debug_srv; type   { TfrmMain }   TfrmMain = class(TForm)    btnConnect: TButton;    gbxControls: TGroupBox;    gbxData: TGroupBox;    edtLocalAddress: TLabeledEdit;    edtRemoteAddress: TLabeledEdit;    edtPort: TLabeledEdit;    lblStatus: TLabel;    Memo1: TMemo;    stbNotifications: TStatusBar;    procedure btnConnectClick(Sender: TObject);  private    fDebugDaemon: TTCPDebugDaemon;    procedure LMCreate(var Message: TLMessage); message LM_CREATE;    procedure LMListen(var Message: TLMessage); message LM_LISTEN;    procedure LMAccept(var Message: TLMessage); message LM_ACCEPT;    procedure LMWorking(var Message: TLMessage); message LM_WORKING;    procedure LMDone(var Message: TLMessage); message LM_DONE;    procedure LMDestroy(var Message: TLMessage); message LM_DESTROY;  public    procedure StartServer;    procedure StopServer;  end; var  frmMain: TfrmMain; implementation {$R *.lfm} { TfrmMain } procedure TfrmMain.btnConnectClick(Sender: TObject);begin  case btnConnect.Tag of    0: begin         btnConnect.Caption:= 'Stop';         lblStatus.Font.Color:= clLime;         lblStatus.Caption:= 'Running';         btnConnect.Tag:= 1;         stbNotifications.SimpleText:= 'Serving...';         Application.ProcessMessages;         StartServer;       end;    1: begin         btnConnect.Caption:= 'Start';         lblStatus.Font.Color:= clRed;         lblStatus.Caption:= 'Stopped';         btnConnect.Tag:= 0;         stbNotifications.SimpleText:= 'Waiting...';         Application.ProcessMessages;         StopServer;       end;  end;end; procedure TfrmMain.LMCreate(var Message: TLMessage);begin  Memo1.Lines.Add(inttostr(Message.WParam)+': '+string(pchar(Message.LParam)));end; procedure TfrmMain.LMListen(var Message: TLMessage);begin  Memo1.Lines.Add(inttostr(Message.WParam)+': '+string(pchar(Message.LParam)));end; procedure TfrmMain.LMAccept(var Message: TLMessage);begin  Memo1.Lines.Add(inttostr(Message.WParam)+': '+string(pchar(Message.LParam)));end; procedure TfrmMain.LMWorking(var Message: TLMessage);begin  Memo1.Lines.Add(inttostr(Message.WParam)+': '+string(pchar(Message.LParam)));end; procedure TfrmMain.LMDone(var Message: TLMessage);begin  Memo1.Lines.Add(inttostr(Message.WParam)+': '+string(pchar(Message.LParam)));end; procedure TfrmMain.LMDestroy(var Message: TLMessage);begin  Memo1.Lines.Add(inttostr(Message.WParam)+': '+string(pchar(Message.LParam)));end; procedure TfrmMain.StartServer;begin  fDebugDaemon:= TTCPDebugDaemon.Create(Handle);end; procedure TfrmMain.StopServer;begin  fDebugDaemon.Terminate;  fDebugDaemon.WaitFor;  FreeAndNil(fDebugDaemon);end; end. And yes i have enabled cthreads in lpr file.
Regards Benny

zeljko:
Probably because TheObject is dangling pointer ? What kind of widget it is ? Form ?

cdbc:
Hi
No, not a dangling pointer...
Tried to free the thread twice:

--- Code: Pascal  [+][-]window.onload = function(){var x1 = document.getElementById("main_content_section"); if (x1) { var x = document.getElementsByClassName("geshi");for (var i = 0; i < x.length; i++) { x[i].style.maxHeight='none'; x[i].style.height = Math.min(x[i].clientHeight+15,306)+'px'; x[i].style.resize = "vertical";}};} ---OnTerminate:= true; // <---- stupid me :-) procedure StopServer;begin  Terminate;  Waitfor;  FreeAndNil; // <---- stupid me :-)end; Now it all works as expected, thank you for your suggestion  ;)
Regards Benny

Navigation

[0] Message Index

Go to full version