|
Registriert seit: 26. Okt 2003 102 Beiträge RAD-Studio 2010 Arc |
#1
Ich eröffne diesen Thread weniger als fragethread sondern eher als hilfethread für
die vielen Hilfesuchenden zum thema "TServersocket/TClientsocket und Netzwerk/Internet Chat" Hab mich mal eine weile hingesetzt und mir so ein wenig überlegt wie man am besten nen Server mit mehreren Extras baut. Das ganze hat nicht lange gedauert und der erste ansatz war fertig. Zuerst einmal hab ich eine unit geschrieben die ich für die Userliste benutze. Unteranderem hab ich hier mehrere Funktionen eingebaut womit ich zum bsp eine Nicklist erstellen und aktuell halten kann. Ändern des Nicknamens, Senden von Text an alle oder auch nur an bestimmte Personen. Mag sein das es für einige nicht die beste art ist einige sachen zu lösen aber ich bin auch für vorschläge offen ^^. Datei: userlist.pas
Delphi-Quellcode:
unit userlist;
interface uses Windows, Messages, SysUtils, Variants, Classes, ScktComp, StdCtrls, Dialogs; // ********************************************* // ******** TUserdata ************************** // ********************************************* type TUserdata = record Username: string[12]; // Name des Users Userip: string; // Ip des Clienten Userport: string; // Port des Clienten von dem aus er Connected ist Userid: string; // id bestehend aus ip:port zur genauen identifizierung des Users (Cloneschutz) private { Private-Deklarationen } public { Public-Deklarationen } end; // ********************************************* // ******** TUserlist ************************** // ********************************************* type TUserlist = class Userdaten: array[1..250] of TUserdata; Count: integer; procedure Adduser(name,ip, port: string; mylist:TListBox); overload; procedure Adduser(name,ip, port: string); overload; procedure Deleteuser(ip, port: string; mylist:TListBox); overload; procedure Deleteuser(ip, port: string); overload; procedure Sendtextto(code, ip, port, text: string; Socket: TServerSocket); procedure Broadcast(text: string; Socket: TServerSocket); procedure Clear; procedure Sendfile(ip, port: string; filename: pchar; Socket: TServerSocket); function GetUsernamebyid(id: string): string; function GetUserIdbyname(name: string): string; function GetUseripbyid(id: string): string; function GetUserportbyid(id: string): string; function ChangeNickName(oldname,newname: string; Socket: TServerSocket; mylist: TListbox): string; function GetFileSize(const FileName: String): Int64; private { Private-Deklarationen } public { Public-Deklarationen } end; implementation // ********************************************* // ******** TUserlist Proceduren *************** // ********************************************* procedure TUserlist.Clear; var a: integer; begin for a := 1 to length(Userdaten) - 1 do begin Userdaten[a].Username := ''; Userdaten[a].Userip := ''; Userdaten[a].Userport := ''; Userdaten[a].Userid := ''; Count := 0; end; end; function TUserlist.ChangeNickName(oldname,newname: string; Socket: TServerSocket; mylist: TListbox): string; var a,b,c: integer; begin b := 0; for a := 1 to length(Userdaten) - 1 do begin if (Userdaten[a].Username = oldname) then c := a; if (Userdaten[a].Username = newname) then begin Result := '*** Name bereits vergeben! ***'; b := 1; Exit; end; end; if (b = 0) then begin for a := 0 to mylist.Count - 1 do begin if (mylist.Items[a] = oldname) then mylist.Items[a] := newname; end; Userdaten[c].Username := newname; Broadcast('Namechange: '+oldname+' => '+newname,Socket); Result := ''; end; end; function TUserlist.GetFileSize(const FileName: String): Int64; var srec: TSearchRec; begin Result := -1; if FindFirst(FileName, faAnyFile, srec) = 0 then begin try result := srec.Size; finally FindClose(srec); end; end; end; procedure TUserlist.Adduser(name,ip, port: string; mylist:TListBox); var a: integer; begin for a := 1 to length(Userdaten) - 1 do begin if (Userdaten[a].Userip = '') then begin Userdaten[a].Username := name; Userdaten[a].Userip := ip; Userdaten[a].Userport := port; Userdaten[a].Userid := ip+':'+port; mylist.Items.Add(name); Count := Count+1; exit; end; end; end; procedure TUserlist.AddUser(name,ip,port: string); var a: integer; begin for a := 1 to length(Userdaten) - 1 do begin if (Userdaten[a].Userip = '') then begin Userdaten[a].Username := name; Userdaten[a].Userip := ip; Userdaten[a].Userport := port; Userdaten[a].Userid := ip+':'+port; Count := Count+1; exit; end; end; end; procedure TUserlist.Deleteuser(ip, port: string; mylist:TListBox); var a: integer; xu: string; begin try xu := GetUsernamebyid(ip+':'+port); for a := mylist.Count - 1 downto 0 do begin if (mylist.Items[a] = xu) then begin mylist.Items.Move(a,mylist.Count-1); mylist.Items.delete(mylist.count-1); mylist.Refresh; end; end; finally for a := 1 to length(Userdaten) - 1 do begin if (Userdaten[a].Userid = ip+':'+port) then begin Userdaten[a].Username := ''; Userdaten[a].Userip := ''; Userdaten[a].Userport := ''; Userdaten[a].Userid := ''; Count := Count-1; end; end; end; end; procedure TUserlist.Deleteuser(ip, port: string); var a: integer; begin for a := 1 to length(Userdaten) - 1 do begin if (Userdaten[a].Userid = ip+':'+port) then begin Userdaten[a].Username := ''; Userdaten[a].Userip := ''; Userdaten[a].Userport := ''; Userdaten[a].Userid := ''; Count := Count-1; Exit; end; end; end; procedure TUserlist.Sendtextto(code,ip, port, text: string; Socket: TServerSocket); var a: integer; begin for a := 0 to socket.Socket.ActiveConnections - 1 do begin if ((socket.Socket.Connections[a].RemoteAddress = ip) AND (socket.Socket.Connections[a].RemotePort = StrToInt(port))) then begin socket.Socket.Connections[a].SendText(code+' '+text); exit; end; end; end; function TUserlist.GetUsernamebyid(id: string): string; var a: integer; begin for a := 1 to length(Userdaten) - 1 do begin if (Userdaten[a].Userid = id) then begin result := Userdaten[a].Username; exit; end; end; end; function TUserlist.GetUseripbyid(id: string): string; var a: integer; begin for a := 1 to length(Userdaten) - 1 do begin if (Userdaten[a].Userid = id) then begin result := Userdaten[a].Userip; exit; end; end; end; function TUserlist.GetUserportbyid(id: string): string; var a: integer; begin for a := 1 to length(Userdaten) - 1 do begin if (Userdaten[a].Userid = id) then begin result := Userdaten[a].Userport; exit; end; end; end; function TUserlist.GetUserIdbyname(name: string): string; var a: integer; begin for a := 1 to length(Userdaten) - 1 do begin if (Userdaten[a].Username = name) then begin result := Userdaten[a].Userid; exit; end; end; end; procedure TUserlist.Sendfile(ip, port: string; filename: pchar; Socket: TServerSocket); var a: integer; begin for a := 0 to socket.Socket.ActiveConnections - 1 do begin socket.Socket.Connections[a].SendText('FILE '+filename+' SIZE '+IntToStr(GetFileSize(filename))); Socket.Socket.Connections[a].SendStream(TFileStream.Create(filename, fmOpenRead or fmShareDenyWrite)); end; end; procedure TUserlist.Broadcast(text: string; Socket: TServerSocket); var a: integer; begin for a := 0 to socket.Socket.ActiveConnections - 1 do begin socket.Socket.Connections[a].SendText(text); end; end; // ********************************************* // ******** TUserlist Proceduren *************** // ********************************************* end. Hier der Code des eigentlichen Programms: Datei: unit1.pas
Delphi-Quellcode:
Fehlende Funktionen:
unit Unit1;
interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, userlist, ScktComp, StdCtrls, ExtCtrls, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient, IdHTTP, Menus, ComCtrls, ClipBrd; // ********************************************* // ******** TForm1 ***************************** // ********************************************* type TForm1 = class(TForm) Server: TServerSocket; HTTP: TIdHTTP; ListBox1: TListBox; Panel1: TPanel; Button1: TButton; Button2: TButton; Edit1: TEdit; ListBox2: TListBox; Splitter1: TSplitter; PopupMenu1: TPopupMenu; Kick1: TMenuItem; Ban1: TMenuItem; N1: TMenuItem; MSGTOUser1: TMenuItem; FILETOUser1: TMenuItem; N2: TMenuItem; INFOFROMUser1: TMenuItem; Button3: TButton; speichern: TSaveDialog; StatusBar1: TStatusBar; PopupMenu2: TPopupMenu; CopyText1: TMenuItem; procedure Button1Click(Sender: TObject); procedure Button2Click(Sender: TObject); procedure FormCreate(Sender: TObject); procedure ServerClientConnect(Sender: TObject; Socket: TCustomWinSocket); procedure ServerClientDisconnect(Sender: TObject; Socket: TCustomWinSocket); procedure Edit1KeyPress(Sender: TObject; var Key: Char); procedure ServerClientRead(Sender: TObject; Socket: TCustomWinSocket); procedure ServerClientError(Sender: TObject; Socket: TCustomWinSocket; ErrorEvent: TErrorEvent; var ErrorCode: Integer); procedure Button3Click(Sender: TObject); procedure PopupMenu1Popup(Sender: TObject); procedure PopupMenu2Popup(Sender: TObject); procedure CopyText1Click(Sender: TObject); private { Private-Deklarationen } public { Public-Deklarationen } end; var Form1: TForm1; Userliste: TUserlist; uid: integer; implementation {$R *.dfm} procedure TForm1.Button1Click(Sender: TObject); begin HTTP.Get('http://www.*******/adminip.php?action=reactivate'); // Onlineupdate siehe extra hinweis unten ListBox1.Items.Add('*** Online-Update wurde durchgeführt! ***'); end; procedure TForm1.Button2Click(Sender: TObject); begin if (Server.Active) then begin Server.Close; ListBox1.Items.Add('*** Server wurde beendet! ***'); Button2.Caption := 'Start Server'; ListBox2.Clear; Userliste.Clear; uid := 1; end else begin Server.Open; ListBox1.Items.Add('*** Server wurde gestartet! ***'); Button2.Caption := 'Stop Server'; ListBox2.Clear; Userliste.Clear; uid := 1; end; end; procedure TForm1.Button3Click(Sender: TObject); begin if (speichern.Execute) then // Abspeichern des Server-Chat-Log's in eine Datei ListBox1.Items.SaveToFile(speichern.FileName); end; procedure TForm1.CopyText1Click(Sender: TObject); begin Clipboard.AsText := ListBox1.Items[ListBox1.ItemIndex]; // eine kleine Kopierfunktion um zeilen aus dem Server-Chat-Log rauszukopieren end; procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char); begin if (key=#13) then // wenn "Enter" dann mache folgendes begin Userliste.Broadcast('Server: '+Edit1.Text,Server); // das was im Servereditfeld eingegeben wird wird hier an alle user geschickt ListBox1.Items.Add('*** Server: '+Edit1.Text+' ***'); // und hier wird es dem server selber ausgegeben Edit1.Clear; end; end; procedure TForm1.FormCreate(Sender: TObject); begin Userliste := TUserlist.Create; Userliste.Clear; uid := 1; end; procedure TForm1.PopupMenu1Popup(Sender: TObject); var x: string; begin if (ListBox2.ItemIndex &gt;= 0) then begin x := ListBox2.Items[ListBox2.ItemIndex]; Popupmenu1.Items[0].Visible := True; Popupmenu1.Items[1].Visible := True; Popupmenu1.Items[3].Visible := True; Popupmenu1.Items[4].Visible := True; Popupmenu1.Items[6].Visible := True; Popupmenu1.Items[0].Caption := 'KICK '+x; Popupmenu1.Items[1].Caption := 'BAN '+x; Popupmenu1.Items[3].Caption := 'MSG TO '+x; Popupmenu1.Items[4].Caption := 'FILE TO '+x; Popupmenu1.Items[6].Caption := 'INFO FROM '+x; end else begin Popupmenu1.Items[0].Visible := False; Popupmenu1.Items[1].Visible := False; Popupmenu1.Items[3].Visible := False; Popupmenu1.Items[4].Visible := False; Popupmenu1.Items[6].Visible := False; end; end; procedure TForm1.PopupMenu2Popup(Sender: TObject); var x: string; begin if (ListBox1.ItemIndex &gt;= 0) then begin x := ListBox1.Items[ListBox1.ItemIndex]; Popupmenu2.Items[0].Visible := True; end else begin Popupmenu2.Items[0].Visible := False; end; end; procedure TForm1.ServerClientConnect(Sender: TObject; Socket: TCustomWinSocket); begin Userliste.Adduser('User'+inttostr(uid),Socket.RemoteAddress,IntToStr(Socket.RemotePort),ListBox2); Userliste.Broadcast('JOIN User'+inttostr(uid)+' ('+Socket.RemoteHost+':'+IntToStr(Socket.RemotePort)+')',Server); ListBox1.Items.Add('*** User Connected: User'+inttostr(uid)+' ('+Socket.RemoteHost+':'+IntToStr(Socket.RemotePort)+') ***'); inc(uid); StatusBar1.Panels[1].Text := IntToStr(Userliste.Count); end; procedure TForm1.ServerClientDisconnect(Sender: TObject; Socket: TCustomWinSocket); var xname: string; begin try xname := Userliste.GetUsernamebyid(Socket.RemoteAddress+':'+IntToStr(Socket.RemotePort)); Userliste.Broadcast('QUIT '+xname+' ('+Socket.RemoteHost+':'+IntToStr(Socket.RemotePort)+')',Server); ListBox1.Items.Add('*** User Disconnected: '+xname+' ('+Socket.RemoteHost+':'+IntToStr(Socket.RemotePort)+') ***'); finally Userliste.Deleteuser(Socket.RemoteAddress, IntToStr(Socket.RemotePort),ListBox2); StatusBar1.Panels[1].Text := IntToStr(Userliste.Count); end; end; procedure TForm1.ServerClientError(Sender: TObject; Socket: TCustomWinSocket; ErrorEvent: TErrorEvent; var ErrorCode: Integer); begin ListBox1.Items.Add('*** ERROR: ('+IntToStr(ErrorCode)+') ***'); end; procedure TForm1.ServerClientRead(Sender: TObject; Socket: TCustomWinSocket); var sr,xu, meta: string; begin xu := Userliste.GetUsernamebyid(Socket.RemoteAddress+':'+IntTostr(Socket.RemotePort)); sr := Socket.ReceiveText; if ((sr[1] = '/') AND (sr[2] = 's') AND (sr[3] = 'a') AND (sr[4] = 'y')) then // der say befehl sendet text an alle user begin Userliste.BroadCast(xu+': '+Copy(sr,6,length(sr)-5),Server); ListBox1.Items.Add('*** '+xu+': '+Copy(sr,6,length(sr)-5)+' ***'); end; if ((sr[1] = '/') AND (sr[2] = 'n') AND (sr[3] = 'a') AND (sr[4] = 'm') AND (sr[5] = 'e')) then // mit /name ändert man den namen begin meta := Userliste.ChangeNickName(xu,Copy(sr,7,length(sr)-6),Server,ListBox2); if (meta <&gt; '') then Userliste.Sendtextto('INFO',Socket.RemoteAddress,IntToStr(Socket.RemotePort),meta,Server) else ListBox1.Items.Add('*** Namensänderung: '+xu+' =&gt; '+Copy(sr,7,length(sr)-6)+' ***'); end; end; end. - Senden von Dateien - Senden von Text an bestimmte User - Abrufen der Userliste vom Client - die Popupmenucommands (kick, ban, info, sendmsg, sendfile) *** Bisher hab ich noch nicht alle funktionen eingebaut, aber das sollte bald folgen. Onlineupdate: Diese Funktion ermöglicht es ohne Probleme bei wechselnder IP dem Clienten den Server zu finden Sobald der Server ein Onlineupdate macht wird mit hilfe einer php datei die ip gespeichert. Der Client hat ebenfalls einen Updatebutton und holt von der phpdatei die ipaddresse, somit kann der Client ohne austauschen der IP über telefon/voicechat oder anderer chattools auf den Server connecten. In der Datenbank hab ich eine Tabelle angelegt mit den werten: - id: int(11) - ip: varchar(255) Leider wird der php code durch das Forum verpfuscht von daher hab ich das ganze als zip angehängt. Der Server liegt immer auf id=1 die anderen sind wenn wer versucht die seite zu öffnen ohne korrekten $action-wert. Das mit dem Onlineupdate kann aber jeder handhaben wie er will ![]() Probleme: Momentan hab ich ein Problem damit wenn mehrere Clients gleichzeitig disconnecten, da ja sobald einer disconnected an alle eine nachricht geschickt wird. wenn nun user1 kurz vor user2 rausgeht dann bekommt user2 "normalerweise" noch die nachricht von user1 das er disconnected ist. und da der Client das nicht mehr empfangen kann da er ja zum selben augenblick raus ist bekomm ich eine Fehlermeldung bzw stürzt sogar das Programm ab. :/ Mehrere Clients wie zum bsp Clone des angehängten Client-Programms (welches nicht von mir ist habs in nem Tutorial gefunden) was ich ein wenig umgebaut hab und damit meinen server teste. Brauchte erstmal nur ein kleines Client-Programm zum testen. Bis auf die "Fehlenden Funktionen" und das "Problem" ist das ganze system funktionsfähig. Man kann mit mehreren Clients connecten die clienten können schreiben der server kann schreiben und man kann den namen ändern. und die nachricht wird mit dem namen angezeigt und nicht mit der "IP", "IP ![]() Am Anfang bekommt auch jeder user einen namen zugewiesen "User+uid" also "User1" und steigend. Ich werde den Sourcecode und die dateien auf dem aktuellsten stand halten wenn ich weitere Funktionen fertig habe. |
![]() |
Ansicht |
![]() |
![]() |
![]() |
ForumregelnEs ist dir nicht erlaubt, neue Themen zu verfassen.
Es ist dir nicht erlaubt, auf Beiträge zu antworten.
Es ist dir nicht erlaubt, Anhänge hochzuladen.
Es ist dir nicht erlaubt, deine Beiträge zu bearbeiten.
BB-Code ist an.
Smileys sind an.
[IMG] Code ist an.
HTML-Code ist aus. Trackbacks are an
Pingbacks are an
Refbacks are aus
|
|
Nützliche Links |
Heutige Beiträge |
Sitemap |
Suchen |
Code-Library |
Wer ist online |
Alle Foren als gelesen markieren |
Gehe zu... |
LinkBack |
![]() |
![]() |