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.
Linkleri Görebilmeniz İçin Üye Olmanız Gerekiyor. Üye Olabilmek İçin Lütfen Buraya Tıklayınız.
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.
Linkleri Görebilmeniz İçin Üye Olmanız Gerekiyor. Üye Olabilmek İçin Lütfen Buraya Tıklayınız.
WWW
Cevapla


Konu ile Alakalı Benzer Konular
Konular Yazar Yorumlar Okunma Son Yorum
  inputquery ile sayisal değer kontrolu serdar 4 166 20-09-2019, Saat: 10:28
Son Yorum: serdar
  Thread içerisinde Tstrings & TStringList yhackup 2 149 10-09-2019, Saat: 22:45
Son Yorum: yhackup
  ÇÖZÜLDÜ-timer kullanmadan saat kontrolü mümkünmü? sadikacar60 3 207 10-09-2019, Saat: 22:19
Son Yorum: sadettinpolat
  Thread içerisinde sleep kullanımı berk06 1 203 26-08-2019, Saat: 11:36
Son Yorum: Tuğrul HELVACI
  Deneme süreli lisans kontrolü anemos 1 235 18-07-2019, Saat: 20:12
Son Yorum: cinarbil



Konuyu Okuyanlar: 1 Ziyaretçi