[_(Sly)_]

Народ. Помогите написать корпоротивный чат. Немогу разобратса с синхроннасть работы ServerSocket1ClientRead. Проблема в том что если
в сети припустим 10000 клиентов то мой сервер умерает(вобшето он умерает и при 10). Пробовал отправлять на сервер команды SendText-но ето как оказалось неефективно. Подскажыте как написать устойчевый чат! Please!!!

[mskvkin]

Уж лучше написать маил агент тогда хоть будет реальный функционал

Вот тебе код:

Код:

program Project1;

uses
  Forms,
  Unit1 in 'Unit1.pas' {Form1},
  accountForm in 'accountForm.pas' {Form2},
  ChatForm in 'ChatForm.pas' {Form3},
  Unit4 in 'Unit4.pas' {Form4};

{$R *.res}

begin
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.CreateForm(TForm2, Form2);
  Application.CreateForm(TForm3, Form3);
  Application.CreateForm(TForm4, Form4);
  Application.Run;
end.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ComCtrls, Menus, StdCtrls, ImgList, Proto, WinSock, Mrim,
  ExtCtrls;

type
  TForm1 = class(TForm)
    MainMenu1: TMainMenu;
    N1: TMenuItem;
    ConnectBtn: TMenuItem;
    DisconnectBtn: TMenuItem;
    N4: TMenuItem;
    N10: TMenuItem;
    StatusBtn: TMenuItem;
    N12: TMenuItem;
    N2: TMenuItem;
    N5: TMenuItem;
    ImageList2: TImageList;
    MailAgent: TMrim;
    ListView1: TListView;
    ConnectBar: TProgressBar;
    N6: TMenuItem;
    StatusBar1: TStatusBar;
    PopupMenu1: TPopupMenu;
    N3: TMenuItem;
    procedure ConnectBtnClick(Sender: TObject);
    procedure MailAgentConnectProgress(state: Integer);
    procedure N2Click(Sender: TObject);
    procedure N5Click(Sender: TObject);
    procedure N6Click(Sender: TObject);
    procedure DisconnectBtnClick(Sender: TObject);
    procedure MailAgentList(list: AContact_List);
    procedure MailAgentDisconnect(eMessage: String);
    procedure MailAgentListUpdate(List: AContact_List);
    procedure MailAgentSecondLogin(error: String);
    procedure MailAgentStatus(id: Integer; email: String; oldstatus,
      newstatus: Integer; adv_s_id, adv_s_name, adv_s_desc,
      adv_s_cid: String);
    procedure MailAgentNewMail(mess_: String);
    procedure MailAgentMessage(msg_type_flags: Cardinal; from,
      message_text: String);
    procedure ListView1DblClick(Sender: TObject);
    procedure MailAgentAuthReq(email, nick, req_msg: String);
    procedure N3Click(Sender: TObject);
  private
    _ContactList: Mrim.AContact_list;
    procedure SetStatus(Status:Integer; Name:string; Desc:String);
    procedure CreateNewTab (user_email:string; text:string);
    procedure GetUserList;
    function GetStatusImage(status:integer; advStatusId:string):integer;
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

uses accountForm, ChatForm, Unit4;

{$R *.dfm}

{ TForm1 }
procedure TForm1.ConnectBtnClick(Sender: TObject);
begin
 ConnectBar.Visible := true;
 StatusBar1.Panels[0].Text := 'Подключение...';

 If Form2.ShowModal = mrCancel Then
  Exit;

 MailAgent.Login := Form2.LoginEdit.Text;
 MailAgent.Password := Form2.PassEdit.Text;
 MailAgent.LoginStatus := STATUS_ONLINE;

 MailAgent.login_s__desc := 'Я в сети!!!!';
 MailAgent.Connect2(MailAgent.Login, MailAgent.Password);
end;

procedure TForm1.MailAgentConnectProgress(state: Integer);
begin
 ConnectBar.Position := State;
 If State = 100 Then
 begin
  Sleep(100);
  ConnectBar.Visible := false;
  StatusBar1.Panels[0].Text := 'В сети';
 end;
end;


procedure TForm1.SetStatus(Status: Integer; Name:string; Desc:string);
begin
 MailAgent.MyStatus(Status, IntToStr(Status), Name, Desc);
end;

procedure TForm1.N2Click(Sender: TObject);
begin
 SetStatus(STATUS_ONLINE, 'В сети', 'Я в онлайне');
end;

procedure TForm1.N5Click(Sender: TObject);
begin
 SetStatus(STATUS_AWAY, 'Отошел', 'Ушел хакать пентагон, вернусь не скоро');
end;

procedure TForm1.N6Click(Sender: TObject);
begin
 SetStatus(STATUS_ONLINE+STATUS_FLAG_INVISIBLE, 'Невидимый','');
end;

procedure TForm1.DisconnectBtnClick(Sender: TObject);
begin
 MailAgent.Disconnect;
end;

procedure TForm1.MailAgentList(list: AContact_List);
begin
 _ContactList := List;
 GetUserList;
end;

procedure TForm1.GetUserList;
var
 i:integer;
 _User : AUser;
begin
 ListView1.Items.Clear;

 for i:=0 to _ContactList.users_num-1 do
 begin
  _User := _ContactList.users_id[i];
  with ListView1.Items.Add do
  begin
    Caption := _User.user_nick;
    ImageIndex := GetStatusImage(_User.user_status, _user.user_status_id);
   end;
 end;
end;

procedure TForm1.MailAgentDisconnect(eMessage: String);
begin
 StatusBar1.Visible := True;
 StatusBar1.Panels[0].Text := 'Отключен';
end;

procedure TForm1.MailAgentListUpdate(List: AContact_List);
begin
 _ContactList := List;
 GetUserList;
end;

function TForm1.GetStatusImage(status: integer; advStatusId:string): integer;
begin
 Result := 1;
 Case Status Of
  STATUS_ONLINE: Result := 0;
  STATUS_OFFLINE: Result := 1;
  STATUS_AWAY: Result := 2;
  STATUS_FLAG_INVISIBLE : Result := 5;
  STATUS_USER_DEFINED:
  begin
    if advStatusId = 'status_chat' then Result := 3;
    if advStatusId = 'status_dnd'  then Result := 4;
  end;
 end;
end;

procedure TForm1.MailAgentSecondLogin(error: String);
begin
 ShowMessage('Ахтунг!!! Кто вошел под твоим логином!!!');
end;

procedure TForm1.MailAgentStatus(id: Integer; email: String; oldstatus,
  newstatus: Integer; adv_s_id, adv_s_name, adv_s_desc, adv_s_cid: String);
begin
 ListView1.Items[id].ImageIndex := GetStatusImage(newStatus, adv_s_id);
end;

procedure TForm1.MailAgentNewMail(mess_: String);
begin
 ShowMessage('Получено новое письмо: '+mess_);
end;

procedure TForm1.MailAgentMessage(msg_type_flags: Cardinal; from,
  message_text: String);
begin
  CreateNewTab(from, message_text);
  Form3.Show;
end;

procedure TForm1.CreateNewTab(user_email: string; text:string);
var
 _NewTab : TTabSheet;
 _NewTextMemo, _NewChatMemo:TMemo;
 i:integer;
begin
 for i:=0 to form3.PageControl1.PageCount-1 Do
  if form3.PageControl1.Pages[i].Caption = user_nick then
  begin
    form3.PageControl1.ActivePageIndex := i;
    if Text <> '' then
      TMemo(Form3.PageControl1.Pages[i].FindComponent('ChatMemo'+IntToStr(i+1))).Lines.Add(user_nick+': '+text);
    form3.Show;
    Exit;
  end;

 _NewTab := TTabSheet.Create(form3.PageControl1);
 _NewTab.Caption := user_nick;
 _NewTab.Name := 'Tab'+IntToStr(form3.PageControl1.PageCount);
 _NewTab.PageControl := form3.PageControl1;

 _NewChatMemo := TMemo.Create(_NewTab);
 _NewChatMemo.Name := 'ChatMemo'+IntToStr(Form3.PageControl1.PageCount);
 _NewChatMemo.Align := alTop;
 _NewTab.InsertControl(_NewChatMemo);

 _NewTextMemo := TMemo.Create(_NewTab);
 _NewTextMemo.Name := 'TextMemo'+IntToStr(form3.PageControl1.PageCount);
 _NewTextMemo.Align := alTop;
 _NewTab.InsertControl(_NewTextMemo);

 _NewChatMemo.Lines.Clear;
 _NewTextMemo.Lines.Clear;

 If Text <> '' Then
   _NewChatMemo.Lines.Add(user_nick+': '+text);

 Form3.PageControl1.ActivePage := _NewTab;
 Form3.Show;
end;


procedure TForm1.ListView1DblClick(Sender: TObject);
var
 i:integer;
begin
 i:=ListView1.Selected.Index;
 CreateNewTab(_ContactList.users_id[i].user_mail, '');
end;

procedure TForm1.MailAgentAuthReq(email, nick, req_msg: String);
begin
 with form4 do
 begin
  UserLabel.Caption := nick;
  UserMailLabel.Caption := email;
  Memo1.Lines.Clear;
  Memo1.Lines.Add(req_msg);
  ShowModal;
 end;

 if form4.ModalResult = mrYes Then
  MailAgent.Send_Auth(email);


end;

procedure TForm1.N3Click(Sender: TObject);
begin
 if ListView1.Selected = nil then
  Exit;

 MailAgent.DeleteUser(_ContactList.users_id[ListView1.Selected.Index].user_mail);
end;

end.






unit accountForm;

interface

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

type
  TForm2 = class(TForm)
    Label1: TLabel;
    LoginEdit: TEdit;
    Label2: TLabel;
    PassEdit: TEdit;
    Button1: TButton;
    Button2: TButton;
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form2: TForm2;

implementation

{$R *.dfm}

end.







unit ChatForm;

interface

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

type
  TForm3 = class(TForm)
    SendBtn: TButton;
    PageControl1: TPageControl;
    procedure SendBtnClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form3: TForm3;

implementation

uses Unit1;

{$R *.dfm}

procedure TForm3.SendBtnClick(Sender: TObject);
var
 index : integer;
 TextMemo, ChatMemo:TMemo;
begin
 index := PageControl1.ActivePageIndex;
 TextMemo := TMemo(PageControl1.Pages[index].FindComponent('TextMemo'+IntToStr(index+1)));
 ChatMemo := TMemo(PageControl1.Pages[index].FindComponent('ChatMemo'+IntToStr(index+1)));
 form1.MailAgent.SendMessage(PageControl1.Pages[index].Caption, TextMemo.Text);

 CHatMemo.Lines.Add('Я: '+TextMemo.Text);
 TextMemo.Clear;
end;

end.

unit Unit4;

interface

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

type
  TForm4 = class(TForm)
    Memo1: TMemo;
    BitBtn1: TBitBtn;
    BitBtn2: TBitBtn;
    Label1: TLabel;
    UserLabel: TLabel;
    Label2: TLabel;
    UserMailLabel: TLabel;
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form4: TForm4;

implementation

{$R *.dfm}

end.

Admin: Пользуемся тегами! Настоятельно рекомендую!

Что должно пулучится можешь скачать отсюда
Внимание для работы программы необходим компонент TMRim
TMRim работает протоколом MMP (Разработчик компонента Алексей Панов)

[_(Sly)_]

Спасибо. Но ето немного не то. Жду на спасение. Пожалусто не игнорируйте а помогите.

[The Shadow]

mskvkin, читайте правила...

[DungeonLords]

Что - то ты всё усложнил досмерти! Зачем откуда-то взял этот протокол, как там его... MMP...
Дал бы уш, если на то пошло и ссылку на компонент!

[Drozh]

Вот чат сделанный на TCPServer <-> TCPClient работает превосходно (взят с книги по Delphi)

[DungeonLords]

Ну вообще я просил с компонентами TClientSocket и TServerSocket!

[DSL88]

Смотри туто, выдержит нормально даже 10 000 клиентов.
Асихронно разбирайтесь сами.
http://www.delphisources.ru/forum/sh...?t=5271&page=2