Wątek a showmessage :: 4programmers.net

0

Witam. Napisałem (a właściwie skleiłem z przykładów znalezionych w internecie :D) prosty klient/serwer echo UDP z wykorzystaniem biblioteki Synapse. Pod Windowsem o dziwo działa dobrze, jednak na Linuksie po odebraniu wiadomości, program się "wykrzacza" z błędem Xów na wyjściu. Dowiedziałem się, że tylko główny wątek może rysować okienka.

Jak mogę to rozwiązać? Nie chcę wyświetlać wiadomości na onclick.

0

Ponieważ nie dałeś ani linii kodu to odpowiem tak Synchronize + F1 + Google Twoim przyjacielem.

0

Myślę że na forum powinno się pomagać bardziej początkującym użytkownikom, zamiast odsyłać ich do Google, gdzie już od pewnego czasu szukam informacji o synchronizacji wątków.

Nie widziałem sensu w umieszczaniu kodu, ale mogę dać ;).

Przepraszam że trochę zasyfiony.
Unit1:

unit Unit1; 

{$mode objfpc}{$H+}

interface

uses
  {$IFDEF UNIX}{$IFDEF UseCThreads}cthreads, cmem,{$ENDIF}{$ENDIF}
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
  blcksock, Unit2, Unit3, ExtCtrls, Unit5;

type

  { TForm1 }

  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Edit1: TEdit;
    Edit2: TEdit;
    Edit3: TEdit;
    GroupBox1: TGroupBox;
    GroupBox2: TGroupBox;
    Label1: TLabel;
    ToggleBox1: TToggleBox;
    ToggleBox2: TToggleBox;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Edit1Change(Sender: TObject);
    procedure Label1Click(Sender: TObject);
    procedure ToggleBox1Change(Sender: TObject);
    procedure ToggleBox2Change(Sender: TObject);
  private
    { private declarations }
  public
    { public declarations }

  end; 

var
  Form1: TForm1; 

implementation



{$R *.lfm}



{ TForm1 }
 var tueserWer:TUEServerThread;
 var tueKlient:TUEClient;




 procedure TForm1.Button2Click(Sender: TObject);
 begin
   tueklient.sendecho(edit2.text);

 end;

  procedure TForm1.Button3Click(Sender: TObject);
 begin

 end;

 procedure TForm1.Edit1Change(Sender: TObject);
 begin

 end;

 procedure TForm1.Label1Click(Sender: TObject);
 begin
   Label1.caption:=buforek;
 end;



 procedure TForm1.Button1Click(Sender: TObject);
 begin
 tueklient := tueclient.create();
 TUEKlient.Connect(Edit3.Text);
 end;




procedure TForm1.ToggleBox1Change(Sender: TObject);
begin
 ajpi:=Edit1.text;
 if ToggleBox1.Checked=true then
 begin
   //-B£¡CZENIE
   tueserwer:=tueserverthread.create(false);
   ToggleBox1.Caption:='Stop';

 end
 else begin
    //ROZ£¡CZANIE
   tueserwer.destroy;
   ToggleBox1.Caption:='Start';
 end;

end;

procedure TForm1.ToggleBox2Change(Sender: TObject);
begin
   if ToggleBox2.Checked=true then
 begin
   //£¡CZENIE
   tueklient := tueclient.create();
   TUEKlient.Connect(Edit3.Text);

   ToggleBox2.Caption:='Disconnect';

 end
 else begin
    //ROZ£¡CZANIE
   tueklient.Disconnect;
   tueklient.Destroy;
   ToggleBox2.Caption:='Connect';
 end;
end;



end.

Unit2:

unit Unit2;

{$mode objfpc}{$H+}

interface

uses
  {$IFDEF UNIX}{$IFDEF UseCThreads}cthreads, cmem,{$ENDIF}{$ENDIF}
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
  blcksock, ExtCtrls, Unit5;



type

  { TUEServerThread }

  TUEServerThread = class(TThread)
  protected
    procedure Execute; override;
  end;

  TUEServer = class
  private
    FUEServerThread: TUEServerThread;
    function GetRunning: Boolean;
  public
    procedure Stop;
    procedure Start;
    property Running: Boolean read GetRunning;
  end;

implementation

{ TUEServer }

function TUEServer.GetRunning: Boolean;
begin
  Result := FUEServerThread <> nil;
end;

procedure TUEServer.Start;
begin
  FUEServerThread := TUEServerThread.Create(False);
end;

procedure TUEServer.Stop;
begin
  if FUEServerThread <> nil then
  begin
    FUEServerThread.Terminate;
    FUEServerThread.WaitFor;
    FreeAndNil(FUEServerThread);
  end;
end;

{ TUEServerThread }

procedure TUEServerThread.Execute;
var
  Socket: TUDPBlockSocket;
  Buffer: string;
  Size: string;
begin
  Socket := TUDPBlockSocket.Create;
  try
    Socket.Bind(ajpi, '7');
    try
      if Socket.LastError <> 0 then
      begin
        raise Exception.CreateFmt('Bind failed with error code %d', [Socket.LastError]);
        Exit;
      end;

      while not Terminated do
      begin
        // wait one second for new packet
        Buffer := Socket.RecvPacket(1000);

        if Socket.LastError = 0 then
        begin
          // just send the same packet back
          Socket.SendString(Buffer);
        end;

        // minimal sleep
        if Buffer = '' then
          Sleep(10) else begin showmessage(Buffer); end;
      end;



    finally
      Socket.CloseSocket;
    end;
  finally
    Socket.Free;
  end;
end;

end.

Unit3:

unit Unit3;

{$mode objfpc}{$H+}

interface

uses
  {$IFDEF UNIX}{$IFDEF UseCThreads}cthreads, cmem,{$ENDIF}{$ENDIF}
  {$IFDEF WINDOWS}Windows,{$ENDIF}Classes, SysUtils, DateUtils,

  // synapse
  blcksock;

const
  cReceiveTimeout = 2000;
  cBatchSize = 100;

type
  { TUEClient }

  TUEClient = class
  private
    FSocket: TUDPBlockSocket;
    FResponseTime: Int64;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Disconnect;
    function Connect(const Address: string): Boolean;
    function SendEcho(const Message: string): string;
    property ReponseTime: Int64 read FResponseTime;
  end;

  { TUEAnalyzer }

  { TUEAnalyzerThread }

  TUEAnalyzerThread = class(TThread)
  private
    FAddress: string;
    FBatchDelay: Cardinal;
    FDropedPackets: Cardinal;
    FAverageResponse: Extended;
    FCriticalSection: TRTLCriticalSection;
    function GetAverageResponse: Extended;
    function GetDropedPackets: Cardinal;
  protected
    procedure Execute; override;
  public
    destructor Destroy; override;
    constructor Create(const Address: string; const BatchDelay: Cardinal);
    property DropedPackets: Cardinal read GetDropedPackets;
    property AverageResponse: Extended read GetAverageResponse;
  end;

  TUEAnalyzer = class
  private
    FAddress: string;
    FBatchDelay: Cardinal;
    FAnalyzerThread: TUEAnalyzerThread;
    function GetAverageResponse: Extended;
    function GetDropedPackets: Cardinal;
    function GetRunning: Boolean;
  public
    procedure StopAnalyzer;
    procedure StartAnalyzer;
    property Running: Boolean read GetRunning;
    property Address: string read FAddress write FAddress;
    property DropedPackets: Cardinal read GetDropedPackets;
    property AverageResponse: Extended read GetAverageResponse;
    property BatchDelay: Cardinal read FBatchDelay write FBatchDelay;
  end;

implementation

{ TUEAnalyzerThread }

function TUEAnalyzerThread.GetAverageResponse: Extended;
begin
  EnterCriticalsection(FCriticalSection);
  try
    Result := FAverageResponse;
  finally
    LeaveCriticalsection(FCriticalSection);
  end;
end;

function TUEAnalyzerThread.GetDropedPackets: Cardinal;
begin
  EnterCriticalsection(FCriticalSection);
  try
    Result := FDropedPackets;
  finally
    LeaveCriticalsection(FCriticalSection);
  end;
end;

procedure TUEAnalyzerThread.Execute;
var
  UEClient: TUEClient;
  Connected: Boolean;
  SendString: string;
  SendCounter: Int64;
  SumResponse: Cardinal;
  SumDropedPackets: Cardinal;
begin
  UEClient := TUEClient.Create;
  try
    Connected := UEClient.Connect(FAddress);
    try
      if not Connected then
      begin
        raise Exception.CreateFmt('Could not connect UPD client to address %s', [FAddress]);
        Exit;
      end;

      SumDropedPackets := 0;
      FAverageResponse := 0;
      FDropedPackets := 0;
      SumResponse := 0;
      SendCounter := 1;

      while not Terminated do
      begin
        SendString := IntToStr(SendCounter);

        if not (UEClient.SendEcho(SendString) = SendString) then
          Inc(SumDropedPackets);

        Inc(SumResponse, UEClient.ReponseTime);
        Inc(SendCounter);

        if (SendCounter mod cBatchSize) = 0 then
        begin
          EnterCriticalsection(FCriticalSection);
          try
            FAverageResponse := SumResponse / cBatchSize;
            FDropedPackets := SumDropedPackets;
          finally
            LeaveCriticalsection(FCriticalSection);
          end;

          // sleep for specified batch time
          Sleep(FBatchDelay * 1000);
          SumDropedPackets := 0;
          SumResponse := 0;
        end;

        // minimal sleep
        Sleep(10);
      end;
    finally
      UEClient.Disconnect;
    end;
  finally
    UEClient.Free;
  end;
end;

destructor TUEAnalyzerThread.Destroy;
begin
  {$IFDEF MSWINDOWS}
    DeleteCriticalSection(FCriticalSection)
  {$ELSE}
    DoneCriticalSection(FCriticalSection)
  {$ENDIF};

  inherited Destroy;
end;

constructor TUEAnalyzerThread.Create(const Address: string; const BatchDelay: Cardinal);
begin
  {$IFDEF MSWINDOWS}
    InitializeCriticalSection(FCriticalSection)
  {$ELSE}
    InitCriticalSection(FCriticalSection)
  {$ENDIF};

  FBatchDelay := BatchDelay;
  FreeOnTerminate := True;
  FAddress := Address;

  inherited Create(False);
end;

{ TUEAnalyzer }

procedure TUEAnalyzer.StartAnalyzer;
begin
  FAnalyzerThread := TUEAnalyzerThread.Create(FAddress, FBatchDelay);
end;

function TUEAnalyzer.GetRunning: Boolean;
begin
  Result := FAnalyzerThread <> nil;
end;

function TUEAnalyzer.GetAverageResponse: Extended;
begin
  Result := FAnalyzerThread.AverageResponse;
end;

function TUEAnalyzer.GetDropedPackets: Cardinal;
begin
  Result := FAnalyzerThread.DropedPackets;
end;

procedure TUEAnalyzer.StopAnalyzer;
begin
  if Running then
  begin
    FAnalyzerThread.Terminate;
    FAnalyzerThread := nil;
  end;
end;

{ TUEClient }

constructor TUEClient.Create;
begin
  FSocket := TUDPBlockSocket.Create;
end;

destructor TUEClient.Destroy;
begin
  FreeAndNil(FSocket);

  inherited Destroy;
end;

procedure TUEClient.Disconnect;
begin
  FSocket.CloseSocket;
end;

function TUEClient.Connect(const Address: string): Boolean;
begin
  FSocket.Connect(Address, '7');
  Result := FSocket.LastError = 0;
end;

function TUEClient.SendEcho(const Message: string): string;
var
  StartTime: TDateTime;
begin
  Result := '';
  StartTime := Now;
  FSocket.SendString(Message);

  if FSocket.LastError = 0 then
  begin
    Result := FSocket.RecvPacket(cReceiveTimeout);
    FResponseTime := MilliSecondsBetween(Now, StartTime);

    if FSocket.LastError <> 0 then
    begin
      FResponseTime := -1;
      Result := '';
    end;
  end;
end;

end.

Unit5:

unit Unit5; 

{$mode objfpc}{$H+}

interface

uses
  {$IFDEF UNIX}{$IFDEF UseCThreads}cthreads, cmem,{$ENDIF}{$ENDIF}
  Classes, SysUtils; 
var ajpi:string;
implementation

end.

0

  {$IFDEF MSWINDOWS}
    InitializeCriticalSection(FCriticalSection)
  {$ELSE}
    InitCriticalSection(FCriticalSection)
  {$ENDIF};

Czemu tak? Wszędzie powinno działać Init.

program się "wykrzacza" z błędem Xów na wyjściu

Debugger zabrali? A może po prostu masz ogromny napis 'X ERROR' na cały ekran?

gdzie już od pewnego czasu szukam informacji o synchronizacji wątków.

Serwer/klient w Synapse można postawić bez wątków.

0

Masz ten błąd, jak ci zależy, ale nic nowego z tego nie wynika ;).

[xcb] Unknown request in queue while dequeuing
[xcb] Most likely this is a multi-threaded client and XInitThreads has not been called
[xcb] Aborting, sorry about that.
project1: xcb_io.c:178: dequeue_pending_request: Warunek zapewnienia `!xcb_xlib_unknown_req_in_deq' nie został spełniony.
Przerwane (core dumped)

Nie wiem jak ty chcesz aktywny serwer UDP bez wątków postawić, ale raczej się mylę, bo dopiero zaczynam z Synapse i opieram się na przykładach z internetu. Przepraszam za fatygę, po prostu poczytam o tym synchronize :).

1

Masz ten błąd, jak ci zależy, ale nic nowego z tego nie wynika

To po co nas pytasz skoro uważasz się za mądrzejszego.

Nie wiem jak ty chcesz aktywny serwer UDP bez wątków postawić, ale raczej się mylę, bo dopiero zaczynam z Synapse i opieram się na przykładach z internetu.

W synapse wszystkie procedury UDP są nieblokujące więc jaki widzisz problem?

Przepraszam za fatygę, po prostu poczytam o tym synchronize

No to się zdecyduj, czy pytasz czy nie.

0

Zobacz prosty przykład:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TMsgEvent = procedure(Sender: TObject; Msg: string) of Object;
  TMyThread = class(TThread)
  protected
    procedure Execute; override;
  private
    fOnShowMsg: TMsgEvent;

    procedure DoMsg;
  public
    property OnShowMsg: TMsgEvent read fOnShowMsg write fOnShowMsg;
  end;

  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
    MyThread: TMyThread;

    procedure ShowMsg(Sender: TObject; Msg: string);
  public

    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TMyThread.DoMsg;
begin
  if Assigned(fOnShowMsg) then
    fOnShowMsg(Self, 'test');
end;

procedure TMyThread.Execute;
begin
  //tu cos
  Synchronize(DoMsg);
  //tu cos
end;

procedure TForm1.ShowMsg(Sender: TObject; Msg: string);
begin
  ShowMessage(Msg);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  MyThread:= TMyThread.Create(True);
  MyThread.FreeOnTerminate:= True;
  MyThread.OnShowMsg:= ShowMsg;
  MyThread.Resume;
end;

end.

0

A sam przykład powinien się chociaż skompilować? Bo w moim programie, a nawet po odpaleniu tego kodu wywala
Error: Incompatible type for arg no. 1: Got "untyped", expected "<procedure variable type of procedure of object;Register>" w linii synchronize(domsg);

0

Error: Incompatible type for arg no. 1: Got "untyped", expected "<procedure variable type of procedure of object;Register>"

Używasz FPC w dialekcie OBJFPC/FPC więc kod nie będzie działać. Zmień dialekt na DELPHI albo przerób tak żeby działało pod OBJFPC.
To nie wina @kAzek że jesteś na tyle mądry odwrotnie że wybierasz inny dialekt niż on i się dziwisz ze kod jest niepoprawny.

0

Niestety na Delphi nie zmienię, bo w temacie nawet napisałem że program ma działać pod Linuksem ;).

0

KBanan napisał(a):

Niestety na Delphi nie zmienię, bo w temacie nawet napisałem że program ma działać pod Linuksem ;).

No ba, przecież w Lazarusie nie ma ANI importera projektów delphi ANI możliwości ustawienia FPC w tryb zgodności ANI możliwości ręcznej zmiany.
Nie ma to jak zabierać się za problem od d**y strony.

0

A wystarczyło tylko wpisać komunikat błędu w Google i już po paru sekundach mam http://wiki.lazarus.freepascal.org/index.php/Multithreaded_Application_Tutorial nawet pobieżnie przeglądając w pół minuty widzę że trzeba dodać @ czyli:

unit Unit1; 

{$mode objfpc}{$H+}
interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ComCtrls,
  StdCtrls;

type
  TMsgEvent = procedure(Sender: TObject; Msg: string) of Object;
  TMyThread = class(TThread)
  protected
    procedure Execute; override;
  private
    fOnShowMsg: TMsgEvent;
    procedure DoMsg;
  public
    property OnShowMsg: TMsgEvent read fOnShowMsg write fOnShowMsg;
  end;

  { TForm1 }

  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    MyThread: TMyThread;
    { private declarations }
    procedure ShowMsg(Sender: TObject; Msg: string);
  public
    { public declarations }
  end; 

var
  Form1: TForm1; 

implementation

{ TForm1 }

{$R *.lfm}

procedure TForm1.ShowMsg(Sender: TObject; Msg: string);
begin
  ShowMessage(Msg);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  MyThread:= TMyThread.Create(True);
  MyThread.FreeOnTerminate:= True;
  MyThread.OnShowMsg:= @ShowMsg;
  MyThread.Start;
end;

procedure TMyThread.DoMsg;
begin
  if Assigned(fOnShowMsg) then
    fOnShowMsg(Self, 'test');
end;

procedure TMyThread.Execute;
begin
  //tu cos
  Synchronize(@DoMsg);
  //tu cos
end;

end.

0

Tu masz rozwiązanie:

http://www.experts-exchange.com/Programming/Languages/Pascal/Delphi/Q_21595998.html

Podsumowując:
a) (najlepiej) użyj Synchronize(UpdateResults) gdzie UpdateResults robi z GUI co mu się podoba - chociaż najlepiej NIE przez ShowXXX, MessageBox itd.
b) albo używasz MessageBox
c) albo przesyłasz wiadomość do głównego okna przez SendMessage

0

A wystarczyło tylko wpisać komunikat błędu w Google i już po paru sekundach mam http://wiki.lazarus.freepascal[...]ithreaded_Application_Tutorial nawet pobieżnie przeglądając w pół minuty widzę że trzeba dodać @

Możesz też użyć switcha {$MODE DELPHI} jeżeli preferujesz składnię Delphi. Jeżeli natomiast masz projekt Delphi to możesz go zimportować do Lazarusa gdzie masz kreator który cię za rączkę poprowadzi i zapewne po mniejszych zmianach kod odpali. Więc jeżeli się zdecydujesz jednak na zmianę to przejdzie ona dosyć bezboleśnie.

Wątek a showmessage

KBanan napisał(a):

1 użytkowników online, w tym zalogowanych: 0, gości: 1

Praca dla programistów

Forum dyskusyjne

Sprawy administracyjne

O nas

Skontaktuj się z nami