Konuyu Oyla:
  • Derecelendirme: 0/5 - 0 oy
  • 1
  • 2
  • 3
  • 4
  • 5
Thread kod kontrolü
#1
Arkadaşlar merhaba, bir projede kullanmak üzere bir örnekten yararlanarak soket programı yazdım (kodlar aşağıda), thread ile kontrol sağlamaya çalıştım, şu an için 3-4 makinada sorunsuz çalışıyor. Konu hakkında uzman arkadaşlar kodu inceleyip ileride bir sorun çıkartırmı veya kodun yazılışında bir sorun varmı, ilaveler yapılabilirmi vs.vs. gibi kafamdaki sorular hakkında yorum yapabilirlerse memnun olurum. İleride 100 civarı (yerel ve uzak bağlantı şeklinde) kullanıcı bağlanacak şekilde kullanmayı düşünüyorum.

unit http_listen;

{$mode objfpc}{$H+}
//{$DEFINE Debug}

interface

uses
 Classes, SysUtils, blcksock, sockets,
 Synautil, // synapse
 fpjson, jsonparser, // json
 StdCtrls;

type
 TPassMessage = procedure(AMsg: string) of object;

 { TClientRaw }
 TClientRaw = class(TThread)
 protected
   FId: Integer;
   FClientSocket: TTCPBlockSocket;
   FMsg1: TPassMessage;
   procedure Execute; override;
 public
   constructor Create(Id: Integer; ASocket: TTCPBlockSocket; OnPassMessage: TPassMessage) ;
 end;

 { TClient }
 TClient = class(TThread)
 protected
   FId: Integer;
   FClientSocket: TTCPBlockSocket;
   FMsg: TPassMessage;
   procedure Execute; override;
 public
   constructor Create(Id: Integer; ASocket: TTCPBlockSocket; OnPassMessage: TPassMessage) ;
 end;

 { TLightWeb }

 TLightWeb = class(TThread)
 private
   _Port: word;
   _PassMessage: TPassMessage;
   procedure TriggerMessage(AMsg: string);
 protected
   procedure Execute; override;
 public
   constructor Create(APort: word);
   destructor Destroy; override;
   property OnPassMessage: TPassMessage read _PassMessage write _PassMessage;
 end;

var

  Const
   HtmlHeader : String = 'HTTP/1.0 200' + CRLF +
                'Content-type: Text/Html; charset=utf-8;' + CRLF +
                'Connection: close' + CRLF +
                'Server: Lazarus Synapse' + CRLF+
                'Access-Control-Allow-Origin: *' + CRLF;

implementation

{ TClientRaw }

constructor TClientRaw.Create(Id: Integer; ASocket: TTCPBlockSocket; OnPassMessage: TPassMessage);
begin
 inherited Create(False);
 Randomize;
 FId := Id;
 FMsg1 := OnPassMessage;
 FMsg1(IntToStr(FId) + ' - Create');
 FClientSocket := TTCPBlockSocket.Create;
 FClientSocket.Socket := ASocket.accept;
end;

procedure TClientRaw.Execute;
var
 timeout: integer;
 OutputDataString : String;
 MS:TMemoryStream;
begin
 timeout := 120000;
 try
   try
     FClientSocket.RecvStreamRaw(MS,timeout);
     OutputDataString:='Veri Geldi';
     FClientSocket.SendString(HtmlHeader);
     FClientSocket.SendString('Content-length: ' + IntTostr(Length(OutputDataString)) + CRLF); // mesaj boyutunu yaz
     FClientSocket.SendString('Date: ' + Rfc822DateTime(now) + CRLF);
     FClientSocket.SendString('' + CRLF);
     FClientSocket.SendString(OutputDataString);
   except
     on E: Exception do
     begin
       FMsg1(IntToStr(FId) + ' - Hata');
     end;
   end;
 finally
   FClientSocket.CloseSocket;
   FreeAndNil(FClientSocket);
   FMsg1(IntToStr(FId) + ' - Finally');
 end;
end;

{ TClient }

constructor TClient.Create(Id: Integer; ASocket: TTCPBlockSocket; OnPassMessage: TPassMessage);
begin
 inherited Create(False);
 Randomize;
 FId := Id;
 FMsg := OnPassMessage;
 FMsg(IntToStr(FId) + ' - Create');
 FClientSocket := TTCPBlockSocket.Create;
 FClientSocket.Socket := ASocket.accept;
end;

procedure TClient.Execute;
var
 timeout: integer;
 message: TStringList;
 OutputDataString : String;
 recv : string;
begin
 timeout := 120000;
 message := TStringList.Create;
 try
   try
     message.Append(FClientSocket.RecvString(Timeout));
     if (pos('komut=',message.Strings[message.Count - 1])>0) then
     begin
       recv:=copy(message.Strings[message.Count - 1],
                  pos('komut=',message.Strings[message.Count - 1])+6,
                  length(message.Strings[message.Count - 1]));
       delete(recv, pos('HTTP',recv)-1,50);
       FMsg('---Gelen = ' + DecodeUrl(recv));
       OutputDataString:='---Gelen = ' + DecodeUrl(recv);
     end else Exit;

     FClientSocket.SendString(HtmlHeader);
     FClientSocket.SendString('Content-length: ' + IntTostr(Length(OutputDataString)) + CRLF); // mesaj boyutunu yaz
     FClientSocket.SendString('Date: ' + Rfc822DateTime(now) + CRLF);
     FClientSocket.SendString('' + CRLF);
     FClientSocket.SendString(OutputDataString);
   except
     on E: Exception do
     begin
       FMsg(IntToStr(FId) + ' - Hata');
     end;
   end;
 finally
   FreeAndNil(message);
   FClientSocket.CloseSocket;
   FreeAndNil(FClientSocket);
   FMsg(IntToStr(FId) + ' - Finally');
 end;
end;

{ TLightWeb }

constructor TLightWeb.Create(APort: word);
begin
 inherited Create(False);
 _Port := Aport;
 TId:=0;
end;

procedure TLightWeb.Execute;
var
 Cl : TClient;
 C2 : TClientRaw;
 ListenerSocket, BlckSocket: TTCPBlockSocket;
begin
 try
   ListenerSocket := TTCPBlockSocket.Create;
   BlckSocket := TTCPBlockSocket.Create;

   ListenerSocket.CreateSocket;
   ListenerSocket.SetLinger(True, 100);
   ListenerSocket.bind('0.0.0.0', IntToStr(_Port));
   ListenerSocket.listen;
   repeat
     if ListenerSocket.canread(10000) then
     begin   // can read
If _Port=5050
  Then Begin
       Cl := TClient.Create(ClientId, ListenerSocket, _PassMessage);
       Cl.Start;
       End;
If _Port=5051
  Then Begin
       C2 := TClientRaw.Create(ClientId, ListenerSocket, _PassMessage);
       C2.Start;
       End;
     End;    // can read
   until Terminated;
 finally
   FreeAndNil(ListenerSocket);
 end;
end;

procedure TLightWeb.TriggerMessage(AMsg: string);
begin
 if Assigned(_PassMessage) then
   _PassMessage(AMsg);
end;

destructor TLightWeb.Destroy();
begin
 inherited Destroy;
end;

end.
WWW
Cevapla
#2
Ben olsam kontrolünü sağladığınız 2 farklı port için 2 ayrı sunucu yazardım. İş yükünü paralele yaymış olurdunuz.

Yanlış görmediysem TClient ve TClientRaw örnekleri Free edilmiyorlar. Onların Create olaylarında FreeOnTerminate kullanabilirsiniz.

Ayrıca; TClient ve TClientRaw'ı Create ederken Suspended mod kullanmamışsınız. ( inherited Create(False) ) Dolayısıyla bu Thread'lerin örnekleri siz Start komutunu vermeden çalışmaya başlayacaklar. Yani mevcut durumuda C1 ve C2 değişkenlerini tanımlamaya ve Start etmeye gerek yok.
There's no place like 127.0.0.1
WWW
Cevapla
#3
@SimaWB değerli yorumunuz için teşekkürler.
WWW
Cevapla


Konu ile Alakalı Benzer Konular
Konular Yazar Yorumlar Okunma Son Yorum
  Thread içinde CoInitialize(nil) ve CoUninitialize serdar 6 1.021 22-08-2023, Saat: 09:50
Son Yorum: yhackup
  joystic kontrolu sadikacar60 2 397 13-08-2023, Saat: 20:34
Son Yorum: sadikacar60
  Thread Socket (Yardım) hkeskin 1 1.360 11-07-2023, Saat: 12:47
Son Yorum: delphiman
  Thread pool mantığı nasıl kurulmalı ? mrmarman 12 3.106 16-12-2021, Saat: 20:45
Son Yorum: Tuğrul HELVACI
  Web Servis TXSDateTime Kontrolü hi_selamlar 0 483 04-12-2021, Saat: 17:25
Son Yorum: hi_selamlar



Konuyu Okuyanlar: 1 Ziyaretçi