Ćwiczenie z TCP/IP — przesłanie linijki tekstu pomiędzy serwerem i clientem

procedure tclient.execute;   // wątek klienta
label 1;
begin
c := TTCPBlockSocket.Create;
c.Connect (ip, port);
1:
if wyslij<>'' then begin
c.SendString (wyslij);
przyjmij := c.RecvString(timeout);
wyslij:=''; //po wysłaniu ma się skasować aby nie wysyłało co 100ms
end;
sleep(100);
goto 1;
end;

procedure tserver.execute;   //wątek serwera
label 1;
var
reciv:string;
begin
s := TTCPBlockSocket.Create;
s.Bind (ip, port);
1:
s.Listen;
if s.canread (timeout) then
begin
  przyjmij:=s.RecvString(timeout);
  s.SendString(wyslij); // wyslij np = 'ok! odebrano';
end;
sleep(100);
goto 1;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
ser:tserver;
cli:tclient;
begin
port:='8008';
timeout:=1000;
ip:=getip;
cli:=tclient.Create(false); // mają działac cały czas słuchając i być gotowe do zmian zmiennych globalnych
ser:=tserver.Create(false);
end;

procedure TClient.Execute();
begin
  while not Terminated do // jeśli nie przerwano pracy wątku
  begin
    // wykonuj instrukcje
    // ewentualny "Sleep"
  end;
end;

unit Unit1;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls, StdCtrls,
  blcksock, synsock;

 type
  tserver = class(TThread)
          private
           { Private declarations }

          protected  procedure execute; override;
  end;

 type
     tclient = class(TThread)
     private
     { Private declarations }
     public

     protected  procedure execute; override;
     end;

type

  { TForm1 }

  TForm1 = class(TForm)
    Button1: TButton;
    Edit1: TEdit;
    Timer1: TTimer;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private

  public

  end;

var
  Form1: TForm1;
  klient,serwer:TTCPBlockSocket;
  ip,port:string;
  timeout:integer;
  WysylanyTekst:string;
  PrzyjmowanyTekst:string;

implementation

{$R *.lfm}

{ TForm1 }

function  GetIP: string;
var
  TcpSock: TTCPBlockSocket;
  ipList: TStringList;
begin
  Result := '';
  ipList := TStringList.Create;
  try
    TcpSock := TTCPBlockSocket.create;
    try
      TcpSock.ResolveNameToIP(TcpSock.LocalName, ipList);
      Result := ipList.CommaText;
    finally
      TcpSock.Free;
    end;
  finally
    ipList.Free;
  end;
end;




procedure tclient.execute;
begin
klient := TTCPBlockSocket.Create;
klient.Bind(ip,port);
klient.Connect (ip, port);
while not terminated do begin
      if wysylanyTekst<>'' then begin
         if klient.CanWrite(timeout) then begin
            klient.SendString (wysylanyTekst+#13#10);
            if klient.LastError<>0 then przyjmowanyTekst:='Błąd wysyłki';
            end;
         wysylanyTekst:='';
         end;
sleep(100);
end;
end;

procedure tserver.execute;
begin
while not terminated do begin
      serwer := TTCPBlockSocket.Create;
      serwer.Bind (ip, port);
      serwer.Listen;
      if serwer.CanRead(timeout) then begin
         przyjmowanyTekst:=serwer.RecvString(timeout);
         end;
         sleep(100);
end;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
   ser:tserver;
   cli:tclient;
begin
     port:='40516';
     timeout:=10000;
     ip:=getip;
     ser:=tserver.Create(false);
     cli:=tclient.Create(false);
     end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  wysylanyTekst:=form1.Edit1.Text;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  form1.Caption:='Client ip:'+ip+' klient  napisał: '+przyjmowanyTekst;
end;

end.


program project1;

{$mode objfpc}{$H+}

uses
  {$IFDEF UNIX}
  cthreads,
  {$ENDIF}
  Interfaces, // this includes the LCL widgetset
  Forms, Unit1
  { you can add units after this };

{$R *.res}

begin
  RequireDerivedFormResource:=True;
  Application.Scaled:=True;
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.

if klient.LastError<>0 then przyjmowanyTekst:='Błąd wysyłki'; 

if klient.LastError<>0 then przyjmowanyTekst:=klient.GetErrorDescEx;  

procedure   TTCServer.Execute;   // основной цикл
var
  ClientSock:TSocket;
begin
  with sock do
    begin
      CreateSocket;
      setLinger(true,10000);
      bind('127.0.0.1','80');
      listen;
      repeat
        if terminated then break;
        if canread(10000) then
          begin
            ClientSock:=accept;
            if lastError=0 then TTCClient.create(ClientSock);
          end;
      until false;
    end;
end;

unit Unit1;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls, StdCtrls,
  blcksock, synsock;

 type
     tclient = class(TThread)
     private
     { Private declarations }
     public

     protected  procedure execute; override;
     end;
//***********************
type

  { TForm1 }

  TForm1 = class(TForm)
    Button1: TButton;
    Edit1: TEdit;
    Timer1: TTimer;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private

  public

  end;

var
  Form1: TForm1;
  klient:TTCPBlockSocket;
  ip,port:string;
  timeout:integer;
  WysylanyTekst:string;
  PrzyjmowanyTekst:string;

implementation

{$R *.lfm}

{ TForm1 }

function  GetIP: string;
var
  TcpSock: TTCPBlockSocket;
  ipList: TStringList;
begin
  Result := '';
  ipList := TStringList.Create;
  try
    TcpSock := TTCPBlockSocket.create;
    try
      TcpSock.ResolveNameToIP(TcpSock.LocalName, ipList);
      Result := ipList.CommaText;
    finally
      TcpSock.Free;
    end;
  finally
    ipList.Free;
  end;
end;




procedure tclient.execute;
var
  s:string;
begin
klient := TTCPBlockSocket.Create;

while not terminated do begin
klient.Connect(ip, port);
         if klient.LastError=0 then begin;
            if klient.CanWrite(timeout) then begin
            klient.SendString(wysylanytekst+#13#10);
            PrzyjmowanyTekst:=klient.RecvString(1000);
            end;
         end;
if klient.LastError<>0 then PrzyjmowanyTekst:=klient.GetErrorDescEx;
klient.ResetLastError;
klient.CloseSocket;
sleep(1000);
end;
end;


procedure TForm1.FormCreate(Sender: TObject);
var
   cli:tclient;
begin
     port:='40516';
     timeout:=1000;
     ip:=getip;
     wysylanytekst:='Wiadomosc dla serwera';
     form1.Button1.Caption:='Wyślij edit1';
     cli:=tclient.Create(false);
     end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  wysylanyTekst:=form1.Edit1.Text;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  form1.Caption:='Client ip:'+ip+' serwer  odpowiedział: '+przyjmowanyTekst;
end;

end. 

unit Unit1;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls, StdCtrls,
  blcksock, synsock,process,synautil;
//****************
 type
  tserver = class(TThread)
          private
           { Private declarations }
           procedure wpisz;
           procedure AttendConnection(ASocket: TTCPBlockSocket);
           procedure connect;
          protected  procedure execute; override;
  end;

type

  { TForm1 }

  TForm1 = class(TForm)
    Button1: TButton;
    Edit1: TEdit;
    Memo1: TMemo;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);

  private

  public

  end;

var
  Form1: TForm1;
  klient,serwer:TTCPBlockSocket;
  ip,port:string;
  timeout:integer;
  WysylanyTekst:string;
  PrzyjmowanyTekst:string;

implementation

{$R *.lfm}

{ TForm1 }
procedure tserver.AttendConnection(ASocket: TTCPBlockSocket);
var
  timeout: integer;
  s: string;
  method, uri, protocol: string;
  OutputDataString: string;
  ResultCode: integer;

begin
  timeout := 12000000;
  s := ASocket.RecvString(timeout);
  przyjmowanytekst:=s;
  synchronize(@wpisz);
  asocket.SendString(wysylanytekst+#13#10);
end;

 procedure tserver.connect;
var
  ListenerSocket, ConnectionSocket: TTCPBlockSocket;

begin
  ListenerSocket := TTCPBlockSocket.Create;
  ConnectionSocket := TTCPBlockSocket.Create;

  ListenerSocket.CreateSocket;
  ListenerSocket.setLinger(true,10);
  ListenerSocket.bind(ip,port);
  ListenerSocket.listen;
  repeat
    if ListenerSocket.canread(1000) then
    begin
      ConnectionSocket.Socket := ListenerSocket.accept;
      if connectionsocket.LastError<>0 then
      przyjmowanytekst:=('Error code: '+ inttostr(ConnectionSocket.lasterror));
      AttendConnection(ConnectionSocket);

    end;
  until false;
   ConnectionSocket.CloseSocket;
  ListenerSocket.Free;
  ConnectionSocket.Free;

  end;

 function  GetIP: string;
 var
   TcpSock: TTCPBlockSocket;
   ipList: TStringList;
 begin
   Result := '';
   ipList := TStringList.Create;
   try
     TcpSock := TTCPBlockSocket.create;
     try
       TcpSock.ResolveNameToIP(TcpSock.LocalName, ipList);
       Result := ipList.CommaText;
     finally
       TcpSock.Free;
     end;
   finally
     ipList.Free;
   end;
 end;
lenovo
procedure tserver.wpisz;
begin
     form1.Memo1.Lines.Add(przyjmowanytekst);
     wysylanytekst:=form1.Edit1.Text;
end;

procedure tserver.execute;
begin
     connect;
     synchronize(@wpisz);
end;
//***************
procedure TForm1.FormCreate(Sender: TObject);
var
   ser:tserver;
begin
     port:='40516';
     ip:=getip;
     end;
//*******************
procedure TForm1.Button1Click(Sender: TObject);
var
   ser:tserver;
begin
  ser:=tserver.Create(false);
  button1.Visible:=false;
end;

end.