Форум "Delphi"

Паскаль, Делфи

#0 marishkin66 © 15.12.04 11:52:14 - 04.09.07 12:28:54

пишу чат (IdTCPClient/IdTCPServer)

Пытаюсь написать простейший чат с использованием компонентов INDY (IdTCPClient, IdTCPServer). Возникло несколько вопросов... Как организовать без использования таймера "прослушку" сервера? (т.е. если от клиента пришло сообщение его сразу должен получить и другой клиент) Как рассылать сообщение определенному клиенту? Помогите, пожалуйста! Может у кого есть примеры?

#1 Паша © 15.12.04 12:05:02

с этими компонентами не работал, так что подробно не скажу. клиент, когда цепляется к серверу, авторизируется, т.е. имя машины(IP), имя пользователя, пароль. т.е. сервак знает, кто к нему подключен. потом, если сообщение идет определенному пользователю, сервер ищет его в списке подключенных и пересылает сообщение. если общее сообщение - по всем подключившимся. в принципе, в сети полно примеров такой лабуды на сокетах. поищи что-то наподобие "чат на основе сокетов"

#2 marishkin66 © 15.12.04 12:13:37

да, чат на основе сокетов довольно простая штука!
я пока написала, только вот что
Сервер:
procedure TfmServer.IdTCPServer1Execute(AThread: TIdPeerThread);
var
s: String;
begin
with AThread.Connection do
try
  s := ReadLn;
   WriteLn(s);
finally
Disconnect;
end;
end;
Клиент:
procedure TfmClient.BBtnSendClick(Sender: TObject);
begin
with IdTCPClient1 do
begin
try
  Connect;
  try
   WriteLn(edClientText.Text);
   mmAllMsg.Lines.Add(ReadLn);
finally
Disconnect;
except
   ShowMessage('Communication Exception: /////');
end;
end;
end;

В принципе, можно при создании клиентской формы отправлять какое-нить (помеченое) сообщение серверу и так вести учет клиентам.

#3 marishkin66 © 15.12.04 12:15:27

Но так, сообщение получает только тот, кто его и отправил. Клиент соединяется делает что-то и отсоединяется. Наверное, надо, чтобы он все время был подключен к серверу?

#4 marishkin66 © 15.12.04 12:19:35

помогите, пли-и-исс...

#5 Паша © 15.12.04 12:26:57

да, он должен быть все время подключенным. если надо, и мыло живое, могу выслать пару статеек по чату на сокетах с примерами.

#6 marishkin66 © 15.12.04 12:33:08

Да, конечно! marishkin66(собачка)mail.ru пасиба

#7 marishkin66 © 15.12.04 12:40:48

вот, нашла кое-что
Но так и не поняла где определен тип PClient...

#8 Deep © 15.12.04 12:43:12

> Клиент соединяется делает что-то и отсоединяется. Наверное,
> надо, чтобы он все время был подключен к серверу?
совсем не объязательно. Если получателя на даный момент в сети нет, тогда сообщение сохраняется на сервере и будет отправлено получателю, когда тот войдет в сеть(т.е. зарегистрируется на сервере). Имено так поступает сервер ICQ.

#9 marishkin66 © 15.12.04 12:46:14

"сообщение сохраняется на сервере" В буфер класть?
проблема в отсылке сообщений всем кто есть в сети. =(( просто не знаю как это сделать...

#10 Deep © 15.12.04 13:11:28

> В буфер класть?
лучше в файл писать. Потому как если сервер вырубиться -- неотправленные сообщения из буфера пропадут.

> проблема в отсылке сообщений всем кто есть в сети.
погоди, погоди. Ты хочешь сделать чат для локальной сети или для интернета? Послать всем пользователям интернета -- это знаешь ли, накладно.

А вод для всех зарегистрированных пользователей локальной сети - это можно.

На сервере формируешь список айпишек подключенных пользователей и рассылаешь им нужное сообщение. Точно так же как и одному пользователю, только в цикле.

#11 marishkin66 © 15.12.04 13:20:50

Да. для локальной сети. а как узнать ip-адреса подключенных клиентов? как отправить сообщение клиенту с определенным адресом?

#12 marishkin66 © 15.12.04 13:35:55

Вот с первой частью своего же вопроса разобралась: для определения используется AThread.Connection.Socket.Binding.PeerIP

#13 Паша © 15.12.04 13:41:49

а сообщение по другому и не отправишь. токо в определенный АП-адрес. примеры пришли? там все достаточно популярно изложено

#14 marishkin66 © 15.12.04 13:45:26

да пришли, ну там же про вин сокеты все... =( а нужно обязательно через idTCPClient/idTCPServer...

#15 Паша © 15.12.04 13:46:59

ну и что? идея-то одинакова. просто свойства в твоих компонентах инди другие, видимо. так по ним надо хелп посмотреть

#16 Deep © 15.12.04 13:47:14

> #12 marishkin66 ©
мне кажется, тебе было бы проще скачать готовый чат и разобраться в его коде. А потом просто подкоректировать прогу в нужных местах по своему вкусу и цвету.

#17 marishkin66 © 15.12.04 14:02:47

Deep! Так уже двое суток ищу исходники готового чата!! Или ищу плохо или что-то одно из двух... нету... только на сокетах или на UDP... =((

#18 marishkin66 © 15.12.04 15:54:35

Может у кого есть примерчик самого простенького чата на основе IdTCPClient/IdTCPServer?

#19 Паша © 15.12.04 15:59:23

+IdTCPServer&meta=

наслаждайся. не знаю, чего там, но почтитать есть что, на первый взгляд

#20 marishkin66 © 15.12.04 16:32:32

забавно, вроде что-то есть

#21 Deep © 15.12.04 16:32:32

> #18 marishkin66 ©
не нравится, мне инди. Чесслово. Никогда им не пользовался. В ранних версиях глюков много было, а потом уже другими пакетами начал пользоваться. Разве это серьезно, если на официальном сайте практически нет документации и примеров?

вообщем-то и тебе не рекомендую юзать именно Инди, или тебе дали задание сделать именно на нем?

#22 marishkin66 © 15.12.04 17:03:50

=) вот прочтейший чат на indy без всего (работает )

клиент:
unit untClient;
interface
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient,
  StdCtrls;
type
  TfmClient = class(TForm)
   IdTCPClient1: TIdTCPClient;
   Label1: TLabel;
   Label2: TLabel;
   mmAll: TMemo;
   edNick: TEdit;
   edMessage: TEdit;
   BtnSend: TButton;
   BtnConnect: TButton;

   procedure BtnSendClick(Sender: TObject);
   procedure BtnConnectClick(Sender: TObject);
  private
   { private declarations }
  public
   { public declarations }
  end;

  TPackage = record
   UserNick,
   Txt : string[255];
  end;
  TClientOnReceive = class(TThread)
   private
   ActiveP: TPackage;
   procedure Action;
   protected
   procedure Execute;
   override;
  end;
var
  fmClient: TfmClient;
  ClientRecive: TClientOnReceive;

implementation

{$R *.dfm}
procedure TClientOnReceive.Action;
begin
  fmClient.mmAll.Lines.Add (ActiveP.UserNick + ' : ' + ActiveP.Txt);
end;

procedure TClientOnReceive.Execute;
begin
  while not Terminated do
  begin
   if not fmClient.IdTCPClient1.Connected then
   Terminate
   else
   try
   fmClient.IdTCPClient1.ReadBuffer(ActiveP, SizeOf (ActiveP));
   Synchronize(Action);
   except
   end;
  end;
end;

procedure TfmClient.BtnSendClick(Sender: TObject);
var
  SendPackage : TPackage;

begin
  SendPackage.UserNick := edNick.Text;
  SendPackage.Txt := edMessage.Text;

  IdTCPClient1.WriteBuffer (SendPackage, SizeOf (SendPackage), true);
end;

procedure TfmClient.BtnConnectClick(Sender: TObject);
begin
try

   IdTCPClient1.Port := 12000;
   IdTCPClient1.Connect(10000);

   ClientRecive := TClientOnReceive.Create(True);
   ClientRecive.FreeOnTerminate:=True;
   ClientRecive.Resume;

   except
   on E: Exception do MessageDlg ('Ошбка соединения: '+#13+E.message, mtError, [mbOk], 0);
   end;
end;

end.

#23 marishkin66 © 15.12.04 17:04:45

сервер:
unit untServer;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, IdThreadMgr, IdThreadMgrDefault, IdBaseComponent, IdComponent,
  IdTCPServer, StdCtrls;

type

  WConnection = ^TConnection;
  TConnection = record
   Host : string[20];
   Thread : Pointer;
   end;
  TPackage = record
   UserNick,
   Txt : string[255];
  end;

  TfmServer = class(TForm)
   IdTCPServer1: TIdTCPServer;
   mmInf: TMemo;
   BtnStart: TButton;

   procedure IdTCPServer1Connect(AThread: TIdPeerThread);
   procedure IdTCPServer1Execute(AThread: TIdPeerThread);
   procedure IdTCPServer1Disconnect(AThread: TIdPeerThread);
   procedure FormCreate(Sender: TObject);
   procedure FormClose(Sender: TObject; var Action: TCloseAction);
   procedure BtnStartClick(Sender: TObject);
   private
   { private declarations }
   public
   { public declarations }
  end;

var
  fmServer: TfmServer;
  ConnectionLst: TThreadList;

implementation

{$R *.dfm}

procedure TfmServer.IdTCPServer1Connect(AThread: TIdPeerThread);
var
NewConnection: WConnection;

begin
  GetMem(NewConnection, SizeOf(TConnection));
  NewConnection.Host :=AThread.Connection.LocalName;
  NewConnection.Thread :=AThread;
  AThread.Data:=TObject(NewConnection);

  try

   ConnectionLst.LockList.Add(NewConnection);

  finally

   ConnectionLst.UnlockList;

  end;

  mmInf.Lines.Add('новое соединение:'+ NewConnection.Host+ ' ' +TimeToStr(Time));

end;

procedure TfmServer.IdTCPServer1Execute(AThread: TIdPeerThread);
var

  DestThread: TIdPeerThread;
  i: Integer;
  DestConnection: WConnection;
  Package, NewPackage: TPackage;

begin

  begin
   AThread.Connection.ReadBuffer (Package, SizeOf (Package));

   mmInf.Lines.Add (TimeToStr(Time)+ ' - ' + Package.UserNick+ ' : '+Package.Txt);
   NewPackage := Package;

   with ConnectionLst.LockList do
   try
   for i := 0 to Count-1 do
   begin
   DestConnection := Items[i];
   DestThread := DestConnection.Thread;
   DestThread.Connection.WriteBuffer(NewPackage, SizeOf(NewPackage), True);
   end;
   finally
   ConnectionLst.UnlockList;
   end;
   end;
end;

procedure TfmServer.IdTCPServer1Disconnect(AThread: TIdPeerThread);
var
  ActiveConnection: WConnection;

begin
  ActiveConnection := WConnection(AThread.Data);
  try
   ConnectionLst.LockList.Remove(ActiveConnection);
  finally
   ConnectionLst.UnlockList;
  end;
  FreeMem(ActiveConnection);
  AThread.Data := nil;
end;

procedure TfmServer.FormCreate(Sender: TObject);
begin
ConnectionLst := TThreadList.Create;
end;

procedure TfmServer.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  IdTCPServer1.Active := False;
  ConnectionLst.Free;
end;

procedure TfmServer.BtnStartClick(Sender: TObject);
begin
IdTCPServer1.DefaultPort := 12000;
IdTCPServer1.Active := True;
end;

end.

Я молодец?

#24 Паша © 15.12.04 17:07:29

>#21 Deep ©
я тоже не пойму, зачем эти навороты, когда сокеты нормально работают... инди всякие...

#25 Паша © 15.12.04 17:09:19

> Я молодец?
контрал+С, контрал+В? ай, маладца!

#26 marishkin66 © 15.12.04 17:30:24

"контрал+С, контрал+В? ай, маладца! "
у-у-у я хоть понимаю, что написано...

#27 Паша © 15.12.04 17:56:13

>#26 marishkin66 ©
шутю я, шутю

#28 marishkin66 © 16.12.04 15:34:42

дополнение: как сделать, чтобы сообщения были разного цвета
В сервере и клиенте добавляем поле userColor : TColor в тип TPackage.

В клиенте заменяем компонент mmAll: TEdit на mmAll: TRichEdit и добавляем на форму компонент ColorBox1: TColorBox; (для выбора цвета текста)
Обрабатываем событие:
procedure TfmClient.ColorBox1Change(Sender: TObject);
begin
  edMessage.Font.Color:=ColorBox1.Selected;
end;
в событие
procedure TfmClient.BtnSendClick(Sender: TObject);
добавляем SendPackage.userColor := ColorBox1.Selected; (перед посылкой пакета)

в событие
procedure TClientOnReceive.Action;
добавляем
fmClient.mmAll.SelAttributes.Color := ActiveP.userColor;
  fmClient.mmAll.Lines.Add (ActiveP.UserNick + ' : ' + ActiveP.Txt);
  fmClient.mmAll.Refresh;

ВСЕ

#29 Deep © 16.12.04 16:10:52

> #28 marishkin66 ©
можешь еще сделать флажок приватных сообщений. Т.е. когда сообщение посылается конкретному участнику: он видит посланое сообщение, а другим пишется, что мол "двое таких то товарищей шепчутся по-секрету".

#30 marishkin66 © 17.12.04 17:46:37

флажок приватных сообщений.
Сделала

И список пользователей добавила

А на сервере отражается если кто новенький пришел или если ушел кто-нить (и когда)

#31 старый маразматик 17.12.04 18:03:13

> а другим пишется, что мол "двое таких то товарищей шепчутся по-секрету"
ну, эт здря. не надо такого писать, нехорошо

>#30 marishkin66 ©
молодца. а список активных пользователей надо у каждого участника коференции шоб был

#32 Deep © 17.12.04 18:07:07

> #30 marishkin66 ©
ну... теперь можно и выложить где-нить исходники -- может кому-нить пригодятся.

Если хочешь могу выложить на нашем сайте. Пиши письмо. Можешь и о себе немного написать.

#33 marishkin66 © 20.12.04 10:24:02

Вот усовершенствованный код клиента и сервера TCP чата...
клиент:
unit untClient;
interface
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient,
  StdCtrls, ExtCtrls, ComCtrls, Winsock;

type
  TfmClient = class(TForm)
   IdTCPClient1: TIdTCPClient;
   Label1: TLabel;
   Label2: TLabel;
   Label3: TLabel;
   Label4: TLabel;
   Label5: TLabel;
   edNick: TEdit;

   edMessage: TEdit; //ñòðîêà ñîîáùåíèÿ
   edIP: TEdit; //ñòðîêà äëÿ ââîäà àäðåñà
   BtnSend: TButton; //êíîïêà ïîñûëêè ñîîáùåíèÿ
   BtnConnect: TButton; //êíîïêà "Âîé&#242;è â ÷àò"
   BtnDisconnect: TButton; //êíîïêà âûéòè èç ÷àòà
   ColorBox1: TColorBox; //âûáîð öâåòà òåêñòà ñîîáùåíèÿ
   mmAll: TRichEdit; //ìåìî â êîòîðîì âèäíû âñå ñîîáùåíèÿ îò âñåõ ïîëüçîâàòåëåé
   mmHwo: TListBox; //ëèñò â êîòîðîì âèäíû íèêè ïîëüçîâàòåëåé
   CheckBox1: TCheckBox; //ôëàæîê äëÿ ïðèâàòíûõ ñîîáùåíèé
   lbFor: TLabel; //çäåñü îòìå÷åíî êîìó èìåííî îòñûëàåì ïðèâàòíîå ñîîáùåíèå

   procedure BtnSendClick(Sender: TObject);
   procedure BtnConnectClick(Sender: TObject);
   procedure ColorBox1Change(Sender: TObject);
   procedure FormCreate(Sender: TObject);
   procedure FormClose(Sender: TObject; var Action: TCloseAction);
   procedure BtnDisconnectClick(Sender: TObject);
   procedure CheckBox1Click(Sender: TObject);
   procedure mmHwoClick(Sender: TObject);
  private
   { private declarations }
  public
   { public declarations }
  end;

  TPackage = record
   UserNick, Who,
   Txt : string[255];
   userColor : TColor;

  end;

  TClientOnReceive = class(TThread)
   private
   ActiveP: TPackage;
   procedure Action;
   protected
   procedure Execute;
   override;
  end;

var
  fmClient: TfmClient;
  ClientRecive: TClientOnReceive;

implementation

{$R *.dfm}

function CharCount(InputStr: string; InputSubStr: char): integer;
//Ïîäñ÷¸ò êîëè÷åñòâà âõîæäåíèé ñèìâîëà â ñòðîêå
var
  i: integer;
begin
  result := 0;
  for i := 1 to length(InputStr) do
   if InputStr[i] = InputSubStr then
   inc(result);
end;

procedure TClientOnReceive.Action;
var s, uname, from_name: String;
   i, pos_: integer;
begin

s:=ActiveP.Who;
// À çäåñü ìû äîáàâëÿåì â ñïèñîê íîâîãî ïîëüçîâàòåëÿ (åñëè îí ïðèñîåäèíèëñÿ, êîíå÷íî)
if (Copy(s,1,2) = '#N') then
begin
  fmClient.mmHwo.Clear;
  Delete(s,1,2);
  for i:=0 to CharCount(s,';')-1 do
   begin
   uname:=Copy(s,1,Pos(';',s)-1);
   fmClient.mmHwo.Items.Add(uname);
   Delete(s,1,Pos(';',s));
   end;

  fmClient.mmHwo.Items.Add(s);
end else
begin
  //Âûâîä ñîîáùåíèÿ
  fmClient.mmAll.SelAttributes.Color := ActiveP.userColor;
  s:=ActiveP.Txt;
  if (Copy(s,1,2) = '#P') then //ïðèâàòíîãî
  begin
   Delete(s,1,2);
   uname:=Copy(s,1,pos(';',s)-1);
   Delete(s,1,pos(';',s));
   from_name:=Copy(s,1,pos(';',s)-1);
   Delete(s,1,pos(';',s));
   if((uname=fmClient.edNick.Text)or(from_name=fmClient.edNick.Text))then
   fmClient.mmAll.Lines.Add (ActiveP.UserNick + ' (ïðèâàòíîå)' + ' : ' + s );
  end else //ñîîáùåíèå äëÿ âñåõ
  fmClient.mmAll.Lines.Add (ActiveP.UserNick + ' : ' + ActiveP.Txt);
  fmClient.mmAll.Refresh;
end;
end;

procedure TClientOnReceive.Execute;
begin
  while not Terminated do
  begin
   if not fmClient.IdTCPClient1.Connected then
   Terminate
   else
   try
   fmClient.IdTCPClient1.ReadBuffer(ActiveP, SizeOf (ActiveP));
   Synchronize(Action);
   except
   end;
  end;
end;

procedure TfmClient.BtnSendClick(Sender: TObject);
//ïûòàåìñÿ ïîñëàòü ñîîáùåíèå
var
  SendPackage : TPackage;
begin
if(edMessage.Text='') then showmessage('Íåâîçìîæíî îòïðàâèòü ïóñòîå ñîîáùåíèå!') else
begin
  SendPackage.UserNick := edNick.Text;
  if(CheckBox1.Checked)then //åñëè ïðèâàòíîå ñîîáùåíèå-äîáàâëÿåì âíà÷àëå ñòðîêè ôëàæîê '#P' è èìåíà ïîëó÷àòåëÿ-îòïðàâèòåëÿ
   SendPackage.Txt := '#P'+mmHwo.Items[mmHwo.ItemIndex]+';'+SendPackage.UserNick+';'+edMessage.Text else
  SendPackage.Txt := edMessage.Text;
  //óñòàíàâëèâàåì öâåò ñîîáùåíèÿ
  SendPackage.userColor := ColorBox1.Selected;

  //ïàêåòèê ñî ñâåé èíôîðìàöèåé çàïèñûâàåì â áóôåð êëèåíòà
  IdTCPClient1.WriteBuffer (SendPackage, SizeOf (SendPackage), true);
end;
end;

#34 marishkin66 © 20.12.04 10:24:42

procedure TfmClient.BtnConnectClick(Sender: TObject);
//ïûòàåìñÿ ñîåäèíèòüñÿ
var SendPackage : TPackage;
begin
if (edNick.Text='')then ShowMessage('Ââåäèòå, ïîæàëóéñòà íèê.') else
begin
  BtnSend.Enabled:=true;
  CheckBox1.Enabled:=true;
  try
   //óñòàíàâëèâàåì ïîðò (ìîæíî ñâîå çíà÷åíèå, íî, ìíå íðàâèòñÿ 12)
   IdTCPClient1.Port := 12000;
   //óñòàíàâëèâàåì õîñò
   IdTCPClient1.Host:=edIP.Text;
   //ïûòàåìñÿ íåñêîëüêî ñåêóíä ñîåäèíèòüñÿ
   IdTCPClient1.Connect(10000);

   ClientRecive := TClientOnReceive.Create(True);
   ClientRecive.FreeOnTerminate:=True;
   ClientRecive.Resume;

   edNick.ReadOnly:=true;
   // Îòïðàâëÿåì èìÿ íîâîãî ïîëüçîâàòåëÿ ñåðâåðó
   SendPackage.UserNick := edNick.Text;
   IdTCPClient1.WriteBuffer (SendPackage, SizeOf (SendPackage), true);
   except
   on E: Exception do MessageDlg ('Îøáêà ñîåäèíåíèÿ: '+#13+E.message, mtError, [mbOk], 0);
   end;
  end;
end;

procedure TfmClient.ColorBox1Change(Sender: TObject);
begin
  edMessage.Font.Color:=ColorBox1.Selected;
end;

procedure TfmClient.FormCreate(Sender: TObject);
begin
end;

procedure TfmClient.FormClose(Sender: TObject; var Action: TCloseAction);
begin
if IdTCPClient1.Connected then IdTCPClient1.WriteLn(edNick.Text) else
   IdTCPClient1.Disconnect;
end;

procedure TfmClient.BtnDisconnectClick(Sender: TObject);
begin
//âûõîäèì èç ÷àòà
if IdTCPClient1.Connected then
begin
  IdTCPClient1.WriteLn(edNick.Text);
  IdTCPClient1.Disconnect;
end;
  mmHwo.Clear;
  mmAll.Clear;
  edNick.Text:='';
  edMessage.Text:='';
  ColorBox1.Selected:=clBlack;
  edNick.ReadOnly:=false;
  BtnSend.Enabled:=false;
  CheckBox1.Enabled:=false;
  lbFor.Visible:=false;
end;

procedure TfmClient.CheckBox1Click(Sender: TObject);
begin
if (CheckBox1.Checked) then
begin
  if mmHwo.ItemIndex=-1 then mmHwo.ItemIndex:=0;
  lbFor.Visible:=true;
  lbFor.Caption:='Äë&#255; '+mmHwo.Items[mmHwo.ItemIndex];
end else
begin
  mmHwo.ItemIndex:=-1;
  lbFor.Visible:=false;
end;
end;

procedure TfmClient.mmHwoClick(Sender: TObject);
begin
if(CheckBox1.Checked)then
begin
  if(mmHwo.ItemIndex>-1)then
  lbFor.Caption:='Äë&#255; '+mmHwo.Items[mmHwo.ItemIndex];
end;
end;

end.

#35 marishkin66 © 20.12.04 10:25:24

упс... что-то не то с русскими буквами =((

#36 marishkin66 © 20.12.04 10:27:54

ладно, теперь сервер:
unit untServer;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, IdThreadMgr, IdThreadMgrDefault, IdBaseComponent, IdComponent,
  IdTCPServer, StdCtrls;

type

  WConnection = ^TConnection;
  TConnection = record
   Host : string[20];
   Thread : Pointer;
   end;
  TPackage = record
   UserNick, Who,
   Txt : string[255];
   color_ : TColor;
  end;

  TfmServer = class(TForm)
   IdTCPServer1: TIdTCPServer;
   mmInf: TMemo;
   BtnStart: TButton;
   mmWho: TMemo;

   procedure IdTCPServer1Connect(AThread: TIdPeerThread);
   procedure IdTCPServer1Execute(AThread: TIdPeerThread);
   procedure IdTCPServer1Disconnect(AThread: TIdPeerThread);
   procedure FormCreate(Sender: TObject);
   procedure FormClose(Sender: TObject; var Action: TCloseAction);
   procedure BtnStartClick(Sender: TObject);
   private
   { private declarations }
   public
   { public declarations }
  end;

var
  fmServer: TfmServer;
  ConnectionLst: TThreadList;

implementation

{$R *.dfm}
function CntRecurrences(substr, str : string): integer;
// ïîäñ÷èòàòü êîëè÷åñòâî âõîæäåíèé ïîäñòðîêè â ñòðîêó
var cnt, p : integer;
begin
cnt := 0;
while str <> '' do begin
  p := Pos(substr, str);
  if p > 0 then inc(cnt) else p := 1;
  Delete(str, 1, (p+Length(substr)-1));
end;
Result := cnt;
end;

procedure TfmServer.IdTCPServer1Connect(AThread: TIdPeerThread);
var
NewConnection: WConnection;
Package, NewPackage: TPackage;
DestConnection: WConnection;
DestThread: TIdPeerThread;
i:integer;
s, ss :string;
begin
  GetMem(NewConnection, SizeOf(TConnection));
  NewConnection.Host :=AThread.Connection.LocalName;
  NewConnection.Thread :=AThread;
  AThread.Data:=TObject(NewConnection);
  try
   ConnectionLst.LockList.Add(NewConnection);
  finally
   ConnectionLst.UnlockList;
  end;

AThread.Connection.ReadBuffer (Package, SizeOf (Package));

mmInf.Lines.Add('Ê íàì ïðèøåë:'+ Package.UserNick + ' ' +TimeToStr(Time));
mmWho.Lines.Add(Package.UserNick);

s:='#N';
//ôîðìèðóåì ñïèñîê âñåõ ïîëüçîâàòåëåé
for i:=1 to mmWho.Lines.Count-1 do
begin
   ss:=mmWho.Lines[i];
   //Delete(ss, length(ss)-6, 7);
   s:= s + ss + ';';
end;
   Delete(s, length(s), 1);

//Îòñûëàåì íîâîìó ïîëüçîâàòåëþ ñïèñîê âñåõ ïîëüçîâàòåëåé
Package.Who:=s;

//Îòñûëàåì âñåì ñïèñîê âñåõ ïîëüçîâàòåëåé

NewPackage := Package;
with ConnectionLst.LockList do
   try
   for i := 0 to Count-1 do
   begin

   DestConnection := Items[i];
   DestThread := DestConnection.Thread;
   DestThread.Connection.WriteBuffer(NewPackage, SizeOf(NewPackage), True);
   end;
   finally
   ConnectionLst.UnlockList;
   end;
end;

procedure TfmServer.IdTCPServer1Execute(AThread: TIdPeerThread);
var

  DestThread: TIdPeerThread;
  i: Integer;
  s, uname: string;
  DestConnection: WConnection;
  Package, NewPackage: TPackage;

begin

   AThread.Connection.ReadBuffer (Package, SizeOf (Package));
   mmInf.Lines.Add (TimeToStr(Time)+ ' - ' + Package.UserNick+ ' : '+Package.Txt);

   NewPackage := Package;
   with ConnectionLst.LockList do
   try
   for i := 0 to Count-1 do
   begin
   DestConnection := Items[i];
   DestThread := DestConnection.Thread;
   DestThread.Connection.WriteBuffer(NewPackage, SizeOf(NewPackage), True);
   end;
   finally
   ConnectionLst.UnlockList;
   end;

end;

#37 marishkin66 © 20.12.04 10:28:19

procedure TfmServer.IdTCPServer1Disconnect(AThread: TIdPeerThread);
var
  ActiveConnection: WConnection;
  Package, NewPackage: TPackage;
  i: integer;
  s, ss:string;
  DestConnection: WConnection;
DestThread: TIdPeerThread;
begin
  ActiveConnection := WConnection(AThread.Data);
  try

   ss:= AThread.Connection.ReadLn;
   mmInf.Lines.Add('Íà&#241; ïîêèíóë: '+ss +' '+TimeToStr(Time));

   for i:=1 to mmWho.Lines.Count-1 do
   begin
   s:= mmWho.Lines[i];

   if (ss=s) then

   begin
   mmWho.Lines.Delete(i);
   mmWho.Refresh;
   break;
   end;
   end;

  //ðàññûëàåì ñïèñîê ïðèñóòñòâ. â ÷àòå

s:='#N';
//ôîðìèðóåì ñïèñîê âñåõ ïîëüçîâàòåëåé
for i:=1 to mmWho.Lines.Count-1 do
begin
   ss:=mmWho.Lines[i];
   s:= s + ss + ';';
end;
  Delete(s, length(s), 1);
  ConnectionLst.LockList.Remove(ActiveConnection);
  finally
   ConnectionLst.UnlockList;
  end;
  FreeMem(ActiveConnection);
  AThread.Data := nil;

NewPackage.Who := s;
with ConnectionLst.LockList do
   try
   for i := 0 to Count-1 do
   begin

   DestConnection := Items[i];
   DestThread := DestConnection.Thread;
   DestThread.Connection.WriteBuffer(NewPackage, SizeOf(NewPackage), True);
   end;
   finally
   ConnectionLst.UnlockList;
   end;

end;

procedure TfmServer.FormCreate(Sender: TObject);
begin
  ConnectionLst := TThreadList.Create;
end;

procedure TfmServer.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  IdTCPServer1.Active := False;
  ConnectionLst.Free;
end;

procedure TfmServer.BtnStartClick(Sender: TObject);
begin
IdTCPServer1.DefaultPort := 12000;
IdTCPServer1.Active := True;
end;

end.

#39 Deep © 20.12.04 11:56:44

> #38 marishkin66 ©
это потому, что они у тебя в юникоде были. Нужно было исходники заархивировать и мне на мыло прислать.

#40 Kolio 05.04.05 10:28:45

кул хлопцы!!!

#41 wagner 09.10.05 14:43:00

NewConnection.Host :=AThread.Connection.LocalName;
Всегда возвращает имя сервера - как это обойти ?

#44 wagner 12.10.05 22:46:17

to deep - согласен !
идеологически правильно ... я не тот вопрос задал -
хочется получать имя клиента а не сервера !
Так как в дальнейшем проверяется как бы сказать

  if RecClient.DNS=CommBlock.ReceiverName then
   begin
   RecThread:=RecClient.Thread;

соответствие между клиентом подключившимся и отправившим пакет !

#45 Серый 14.10.05 10:51:32

Привет Марина. Не могла бы ты поделиться исходником чата, но так как я ещё младенец в этом деле, то желательно с комментариями. Заранее большое спасибо. x-grey(собачка)mail.ru

#46 marishkin66 © 14.10.05 15:00:16

#45 Серый
Привет, Сергей! все исходники ты можешь найти в этом посте! ничго нового по чату я с тех пор не написала. удачи!

#47 Dmitriy O. © 17.10.05 07:41:36

Возми исходники чата

И не парься. Воще локальный чат лутьше писать на основе если Delphi то БД Interbase. Т.к. есть возможность
1.Посылать отложенные сообщения
2.Посылать файлы
3.Смотреть сообщения

#48 DpoHro 25.10.05 15:46:28

Вопрос следующего характера, подобная конструкция является неблокирующей, тоесть когда происходит чтение/запись на одном подключении блокируются остальные?
Вобщем мне то нужно написать чат который бы успешно обслуживал бы до 200-300 пользователей одновременно...
Такой подход пойдет?

#49 Dmitriy O. © 26.10.05 07:55:43

Если писать чат с использованием БД типа Interbase то проблем не будет транзакции надо тока правильно выставить.

#50 deep © 26.10.05 09:21:05

> #48 DpoHro
>> подобная конструкция является неблокирующей,
насколько, я знаю для "неблокирующей конструкции" серверная компонента должна поддерживать многопоточность.

#51 DpoHro 27.10.05 15:23:35

Ну Indy поддерживает!

#53 P.R. 10.11.05 19:26:18

Indy блокирует выполнение программы в рамках потока, обслуживающего одного клиента. Для каждого клиента - свой поток. Так что без граблей.

#55 SargonRa 04.09.07 12:28:53

Изучаю делфи. Ну народ нет слов. Чаты забабахали.

Написать ответ