threads and sendmessage to tlabel
lazarus / 32-Linux

----------------------------------------------------------------------
tr_escape · 2017-11-07 06:41

Hello,

I have got a problem about sendmessage to TLabel component from
threads.

I can execute same codes in windows correctly but in Linux I got a lot
of SEG message.

I tried some fail safe but now worked , I also tried synchronize
command it working.

What I am doing wrong? Is the threads in Linux working more
aggressively than windows?

If I remove the

Code: Pascal  [Select][+][-]window.onload = function(){var x1 =
document.getElementById("main_content_section"); if (x1) { var x =
document.getElementsByClassName("geshi");for (var i = 0; i          
TLabel(Message.wParam).Caption := buf; line I don't catch any problem.

I attached my software but I also pasted as code:

Code: Pascal  [Select][+][-]window.onload = function(){var x1 =
document.getElementById("main_content_section"); if (x1) { var x =
document.getElementsByClassName("geshi");for (var i = 0; i unit
main; {$mode objfpc}{$H+} interface uses  Classes, LclIntf,
Messages,LMessages, LclType, LResources,  SysUtils, FileUtil,
uPSComponent, Forms, Controls, Graphics, Dialogs,  StdCtrls,
ExtCtrls,   uPSRuntime,uPSCompiler   ; const  WM_SET_CAPTION = WM_USER
+ $01; type   { TScriptThread }   TScriptThread = class (TThread)   
fScript:TPSScript;    procedure PSScriptExecute(Sender: TPSScript);  
procedure PSScriptCompImport(Sender: TObject; x: TPSPascalCompiler); 
 procedure PSScriptExecImport(Sender: TObject;                       
        se: TPSExec; x: TPSRuntimeClassImporter);    procedure
PSScriptCompile(Sender: TPSScript);     procedure AppProcMes;   
procedure ScrSleep(const ms: Integer);   protected    procedure
Execute; override;  public    constructor
Create(aText:String);overload;    destructor Destroy; override; 
end;  type   { TForm1 }   TForm1 = class(TForm)    Button4: TButton; 
 Label1: TLabel;    Label2: TLabel;    Label3: TLabel;    lblCallBack:
TLabel;    Memo1: TMemo;    Memo2: TMemo;    Memo3: TMemo;   
procedure Button4Click(Sender: TObject);  private    { private
declarations }  public    { public declarations }    procedure
MyCallBack;  protected     procedure WMSetCaption(var Message:
TLMessage); message WM_SET_CAPTION;  end; var  Form1: TForm1; 
thr1,thr2,thr3 : TScriptThread;  Cnt:Integer; 
Busy:Boolean=False; implementationuses      uPSR_std,      uPSC_std, 
   uPSR_stdctrls,      uPSC_stdctrls,      uPSR_forms,     
uPSC_forms,      uPSC_graphics,      uPSC_controls,     
uPSC_classes,      uPSR_graphics,      uPSR_controls,     
uPSR_classes;  {$R *.lfm} { TForm1 } procedure
TScriptThread.ScrSleep(const ms:Integer);begin 
Sleep(ms);end;  procedure SetLabelCaption(const aName,
aCaption:string);var  buf: PChar;  len: integer;  cmp :
TComponent;begin  if (aName='') or (aCaption='') then    Exit;   if
Busy then    Exit;   Busy:=True;   len := (Length(aCaption) + 1) *
SizeOf(Char);  GetMem(buf, len);  Move(aCaption[1], buf^, len);  cmp
:= Form1.FindComponent(aName);  if Assigned(cmp) then   
LclIntf.SendMessage(Form1.Handle,                       
WM_SET_CAPTION,                        Integer(cmp),                 
     Integer(buf));end;   constructor
TScriptThread.Create(aText:String);begin  inherited Create(True); 
FreeOnTerminate := True;  fScript:=TPSScript.Create(nil); 
fScript.Script.Text := aText;  fScript.OnCompile := @PSScriptCompile; 
fScript.OnExecute := @PSScriptExecute;  fScript.OnCompImport :=
@PSScriptCompImport;  fScript.OnExecImport := @PSScriptExecImport;  //
Execute;end; destructor TScriptThread.Destroy;begin 
FreeAndNil(fScript);  inherited;end; procedure
TScriptThread.Execute;begin  if fScript.Compile then   
fScript.Execute;end; procedure
TScriptThread.PSScriptCompImport(Sender: TObject;  x:
TPSPascalCompiler);begin  SIRegister_Std(x);  SIRegister_Classes(x,
true);  SIRegister_Graphics(x, true);  SIRegister_Controls(x); 
SIRegister_stdctrls(x);  SIRegister_Forms(x);end; procedure
TScriptThread.PSScriptExecImport(Sender: TObject; se: TPSExec;  x:
TPSRuntimeClassImporter);begin  RIRegister_Std(x); 
RIRegister_Classes(x, True);  RIRegister_Graphics(x, True); 
RIRegister_Controls(x);  RIRegister_stdctrls(x); 
RIRegister_Forms(x);end; procedure
TScriptThread.PSScriptExecute(Sender: TPSScript);begin 
Sender.SetVarToInstance('Application', Application); 
Sender.SetVarToInstance('Form1', Self);end; procedure
TScriptThread.PSScriptCompile(Sender: TPSScript);begin 
Sender.AddRegisteredVariable('Application', 'TApplication'); 
Sender.AddRegisteredVariable('Form1', 'TForm'); 
Sender.AddFunction(@TScriptThread.ScrSleep,                 
 'procedure ScrSleep(const ms:Integer);'); 
Sender.AddFunction(@SetLabelCaption,                   'procedure
SetLabelCaption(const aName, aCaption:string);'); 
Sender.AddFunction(@TScriptThread.AppProcMes,                   
'procedure AppProcMes;');end; procedure
TScriptThread.AppProcMes;begin  Synchronize(@Form1.MyCallBack); 
Synchronize(@Application.ProcessMessages);end; procedure
TForm1.Button4Click(Sender: TObject);begin  Cnt:=0;  
thr1:=TScriptThread.Create(Memo1.Text);  thr1.Start;  
thr2:=TScriptThread.Create(Memo2.Text);  thr2.Start;  
thr3:=TScriptThread.Create(Memo3.Text);  thr3.Start; end; procedure
TForm1.MyCallBack;begin  Cnt+=1; 
lblCallBack.Caption:=IntToStr(Cnt);end; var  // timeout:TDateTime; 
OldCmp : TComponent=nil;procedure TForm1.WMSetCaption(var Message:
TLMessage);var  buf: PChar;begin  if (Message.lParam <> 0) and
(Message.WParam<>0) then    try      buf := PChar(Message.lParam);   
 if // (now>timeout) and         (OldCmp<>TComponent(Message.wParam))
then        begin          // timeout:=Now+(1/24/60/60/1000);        
OldCmp:=TComponent(Message.wParam);         
TLabel(Message.wParam).Caption := buf;        end;    finally     
FreeMem(buf);      Busy:=False;    end;end; end.

----------------------------------------------------------------------
avra · 2017-11-07 08:21

I did not have time to debug your code, but here is a working
alternative using QueueAsyncCall() if you would like to take a look. I
use it for thread safe logging messages to Memo control, which is
close enough to your use case.

There is a MemoChannel unit where I have something like this:
Code: Pascal  [Select][+][-]window.onload = function(){var x1 =
document.getElementById("main_content_section"); if (x1) { var x =
document.getElementsByClassName("geshi");for (var i = 0; i ...type 
TLogMsgData = record    Text: string;  end;  PLogMsgData =
^TLogMsgData;...procedure TMemoChannel.Write(const AMsg: string);var 
LogMsgToSend: PLogMsgData;begin  New(LogMsgToSend); 
LogMsgToSend^.Text:= AMsg; 
Application.QueueAsyncCall(@WriteAsyncQueue,
NativeUInt(LogMsgToSend)); // put log msg into queue that will be
processed from the main thread after all other
messagesend;...procedure TMemoChannel.WriteAsyncQueue(Data:
PtrInt);var // called from main thread after all other messages have
been processed to allow thread safe TMemo access  ReceivedLogMsg:
TLogMsgData;begin  ReceivedLogMsg := PLogMsgData(Data)^;  try    if
(FMemo <> nil) and (not Application.Terminated) then    begin     
...      FMemo.Append(ReceivedLogMsg.Text) // <<< fully thread safe  
end;  finally    Dispose(PLogMsgData(Data));  end;end; All you have to
do is call Write('Your text') from the thread and Memo will be safely
updated because all writing to gui will be done after main gui loop
finished one full cycle, and additionaly all calls are serialized so
there is no fight for gui access at all. Also there is no thread
locking, which brings significant speed improvements in some thread
use cases.

Funny thing is that so far I have used this approach only on Windows,
and you need it to work also on Linux. I do not see why it shouldn't
work on both, but if you want to play with it then testing is up to
you.

EDIT: After comments from Thaddy and totya in https://forum.lazarus.fr
eepascal.org/index.php/topic,45924.msg325307.html#msg325307, PtrInt
was replaced with NativeUInt.

----------------------------------------------------------------------
tr_escape · 2017-11-07 11:29

Thank a lot I changed as your mentioned QueueAsyncCall it is worked as
well as.

https://github.com/mehmetulukaya/laz-
projects/blob/master/Laz_PascalScript_Multi/main.pas

----------------------------------------------------------------------
avra · 2017-11-08 20:00

Quote from: tr_escape on November 07, 2017, 12:29:58 pmThank a lot I
changed as your mentioned QueueAsyncCall it is worked as well as.You
are most welcome. I am glad it worked for you.

----------------------------------------------------------------------
Mike.Cornflake · 2017-11-11 18:34

Wild guess for a possible problem with the initial code
Code: [Select]    LclIntf.SendMessage(Form1.Handle,
                        WM_SET_CAPTION,
                        Integer(cmp),
                        Integer(buf));
Maybe should be?  (pointers was never my thing....)
Code: [Select]    LclIntf.SendMessage(Form1.Handle,
                        WM_SET_CAPTION,
                        Pointer(cmp),
                        Pointer(buf));