ServerSocket problem z przeładowanim stosu

0

Cze napisałe chata (Client ->Server->Klienci) i tu pojawił się problem. Gdy podłączają sie ludzie z dużym opóźnieniem to czasami server sie wysypuje :(. Kolega u którego stoi server powiedzial mi że stos się przepełnia. Co można z tym zrobić ??
podaje kod server:
unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ScktComp, ComCtrls, CheckLst, ShellAPI, Menus,
IdBaseComponent, IdAntiFreezeBase, IdAntiFreeze;

type
pakiet = record id:integer;
kolor:TColor;
IPdes:string[16];
login:string[25];
dane:string[160];
end;
TForm1 = class(TForm)
ServerSocket1: TServerSocket;
Label1: TLabel;
Label2: TLabel;
StatusBar1: TStatusBar;
PopupMenu1: TPopupMenu;
Poka1: TMenuItem;
Ukryj1: TMenuItem;
N1: TMenuItem;
Zamknij1: TMenuItem;
IdAntiFreeze1: TIdAntiFreeze;
procedure ServerSocket1ClientConnect(Sender: TObject;
Socket: TCustomWinSocket);
procedure ServerSocket1ClientDisconnect(Sender: TObject;
Socket: TCustomWinSocket);
procedure ServerSocket1ClientRead(Sender: TObject;
Socket: TCustomWinSocket);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure TrayMessage(var Msg: TMessage); message WM_USER+1;
procedure Poka1Click(Sender: TObject);
procedure Ukryj1Click(Sender: TObject);
procedure Zamknij1Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure WMSysCommand(var Msg: TWMSysCommand);message WM_SYSCOMMAND;
procedure ServerSocket1ClientError(Sender: TObject;
Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
var ErrorCode: Integer);

private
TrayIconData: TNotifyIconData;
procedure Send_top(d:pakiet; HSocket:integer);
procedure Send_pri(d:pakiet; HSocket:integer);
procedure Send_new(d:pakiet;HSocket:integer);
procedure Send_all(d:pakiet;HSocket:integer);
{ Private declarations }
public
{ Public declarations }
end;

Temat = record kto:string[15];
               co:string[75];
        end;

var
Form1: TForm1;
Sub:Temat;

implementation
{$W+}
{$STACKFRAMES ON}
{$R *.dfm}

procedure TForm1.ServerSocket1ClientConnect(Sender: TObject;
Socket: TCustomWinSocket);
var
dane:pakiet;
//i:integer;
begin
Label2.Caption:=IntToStr(StrToInt(Label2.Caption)+1);
Application.Title:='BaterChat-Server: '+Label2.Caption;
StrPCopy(TrayIconData.szTip, Application.Title);
Shell_NotifyIcon(NIM_MODIFY, @TrayIconData);
dane.id:=10;
dane.login:=sub.kto;
dane.dane:=sub.co;
Application.ProcessMessages;
Socket.SendBuf(dane,sizeof(pakiet));
end;

procedure TForm1.ServerSocket1ClientDisconnect(Sender: TObject;
Socket: TCustomWinSocket);
var
dane:pakiet;
i:integer;
begin
Label2.Caption:=IntToStr(StrToInt(Label2.Caption)-1);
Application.Title:='BaterChat-Server: '+Label2.Caption;
StrPCopy(TrayIconData.szTip, Application.Title);
Shell_NotifyIcon(NIM_MODIFY, @TrayIconData);

dane.id:=4;
dane.dane:=IntToStr(Socket.SocketHandle);
for i:=0 to ServerSocket1.Socket.ActiveConnections-1 do
    begin
    Application.ProcessMessages;
    ServerSocket1.Socket.Connections[i].SendBuf(dane,SizeOf(pakiet));
    end;

end;
procedure TForm1.Send_all(d:pakiet;HSocket:integer);
var
i:integer;
begin
d.IPdes:=IntToStr(HSocket);
for i:=0 to ServerSocket1.Socket.ActiveConnections-1 do
begin
Application.ProcessMessages;
ServerSocket1.Socket.Connections[i].SendBuf(d,SizeOf(pakiet));
end;
end;
procedure TForm1.Send_new(d:pakiet;HSocket:integer);
var
temp:pakiet;
i:integer;
begin
temp.id:=2;
temp.kolor:=clSkyBlue;
temp.login:=d.login;
temp.dane:=d.dane;
temp.IPdes:=IntToStr(HSocket);
for i:=0 to ServerSocket1.Socket.ActiveConnections-1 do
begin
Application.ProcessMessages;
ServerSocket1.Socket.Connections[i].SendBuf(temp,SizeOf(pakiet));
end;
end;
procedure TForm1.Send_pri(d:pakiet; HSocket:integer);
var
i:integer;
begin
for i:=0 to ServerSocket1.Socket.ActiveConnections-1 do
begin
if ServerSocket1.Socket.Connections[i].SocketHandle=StrToInt(d.IPdes) then
BEGIN

                Application.ProcessMessages;
                d.IPdes:=IntToStr(HSocket);
                ServerSocket1.Socket.Connections[i].SendBuf(d,SizeOf(pakiet));
                exit;
            end;
    end;

end;
procedure TForm1.Send_top(d:pakiet; HSocket:integer);
var
i:integer;
begin
d.IPdes:=IntToStr(HSocket);
Sub.kto:=d.login;
Sub.co:=d.dane;
for i:=0 to ServerSocket1.Socket.ActiveConnections-1 do
begin
Application.ProcessMessages;
ServerSocket1.Socket.Connections[i].SendBuf(d,SizeOf(pakiet));
end;

end;
procedure TForm1.ServerSocket1ClientRead(Sender: TObject;
Socket: TCustomWinSocket);
var
dane:pakiet;
//i:integer;
begin
Application.ProcessMessages;
Socket.ReceiveBuf(dane,SizeOf(pakiet));
case dane.id of
1,5,6,12:begin Send_all(dane,Socket.SocketHandle);exit;end;
2:begin Send_new(dane,Socket.SocketHandle);exit;end;
3,7,8,9,11,13:begin Send_pri(dane,Socket.SocketHandle);exit;end;
10:begin Send_top(dane,Socket.SocketHandle);exit;end;
end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
with TrayIconData do
begin
cbSize := SizeOf(TrayIconData);
Wnd := Handle;
uID := 0;
uFlags := NIF_MESSAGE + NIF_ICON + NIF_TIP;
uCallbackMessage := WM_USER+1;
hIcon := Application.Icon.Handle;
StrPCopy(szTip, Application.Title);
end;

Shell_NotifyIcon(NIM_ADD, @TrayIconData);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
Shell_NotifyIcon(NIM_DELETE, @TrayIconData);
end;
procedure TForm1.TrayMessage(var Msg: TMessage);
var
p : TPoint;
begin
case Msg.lParam of
WM_LBUTTONDBLCLK:
begin
if Form1.Visible=false then
begin
Form1.Show;
Application.Restore;
end
else
begin
Form1.Hide;
Application.Restore;
end;
end;
WM_RBUTTONDOWN:
begin
SetForegroundWindow(Handle);
GetCursorPos(p);
PopUpMenu1.Popup(p.x, p.y);
PostMessage(Handle, WM_NULL, 0, 0);
end;
end;
end;

procedure TForm1.Poka1Click(Sender: TObject);
begin
Form1.Show;
Application.Restore;
end;

procedure TForm1.Ukryj1Click(Sender: TObject);
begin
Form1.Hide;
Application.Restore;
end;

procedure TForm1.Zamknij1Click(Sender: TObject);
begin
Form1.Close;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
Form1.Hide;
Application.Restore;
end;
procedure TForm1.WMSysCommand;
begin
if (Msg.CmdType = SC_MINIMIZE) then
begin
Form1.Hide;
Application.Restore;
end
else
DefaultHandler(Msg) ;
end;

procedure TForm1.ServerSocket1ClientError(Sender: TObject;
Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
var ErrorCode: Integer);
begin
ErrorCode:=0;
Label2.Caption:=inttostr(ServerSocket1.Socket.ActiveConnections);
Application.Title:='BaterChat-Server: '+Label2.Caption;
StrPCopy(TrayIconData.szTip, Application.Title);
Shell_NotifyIcon(NIM_MODIFY, @TrayIconData);
end;

end.

0

Od dłuższego czasu poszukuję kodu do Chata naSocketch.
Czyudostępnisz/prześlesz cały kod?
[email protected]

0

Use debugger :]. Będziesz wiedział gdzie się przepełnia, a to już ci powinno pomóc w odnalezieniu odpowiedzi. Tak z kodu to ciężku tutaj coś zobaczyć.

0

Radzę skracać takie kody przed publikacją tu .. w ten sposób nikt Ci nie pomoże.

Polecam lekturę "Simple Czat Serwer" - art jest w zasobach.. chyba o to chodziło.

ServerSocket problem z przeładowanim stosu

1 użytkowników online, w tym zalogowanych: 0, gości: 1

Praca dla programistów

Forum dyskusyjne

Sprawy administracyjne

O nas

Skontaktuj się z nami