source: branches/2/USunriseChatCore.pas

Last change on this file was 1, checked in by george, 17 years ago

Přidáno: Verze 2.10 do vývojové větve 2.
  • Property svn:executable set to *
File size: 31.2 KB
Line 
1unit USunriseChatCore;
2
3interface
4
5uses
6 SysUtils, Classes, ExtCtrls, cWindows, cSockets, cSocketsUDP, cTCPClient,
7 cTCPServer, Forms, Dialogs, cWinSock, cSocketHostLookup, WinSock, Graphics,
8 Windows, Registry, cUtils, typinfo, UEthernetAddress;
9
10const
11 ProtocolVersion = 2;
12 CoreVersion = '2.7';
13 RemoveTimeout = 33/24/3600; // 33 seconds
14
15 clSysMessage = $7fffffff;
16 riAll = -1;
17
18 // User status modes
19 usAway = 'Away';
20 usOnline = 'Online';
21 usWritting = 'Writting';
22 usInvisible = 'Invisible';
23 usOffline = 'Offline';
24
25type
26 TAppEventType = (aeCommonMessage, aeOneUserMessage, aeUserConnect,
27 aeUserDisconnect, aeUserRestore, aeUserTimeout, aeUserGoAway, aeUserGoBack,
28 aeSendCallUp, aeReceiveCallUp, aeSendPing, aePingResponse, aeUserChangeNick,
29 aeUserChangeNickConflict, aeCreateRoom, aeLeaveRoom, aeUserAutoGoAway,
30 aeUserAutoGoBack, aeShowHours, aeStart);
31
32 TMessageEvent = procedure (Text: string; Color: Integer) of object;
33 TClassMethod = procedure of object;
34 TArrayOfString = array of string;
35
36 TRoomType = (rtPublic, rtPrivate);
37 TLine = record
38 Text: string;
39 Font: TFont;
40 Time: TDateTime;
41 Nick: string;
42 EventType: TAppEventType;
43 end;
44
45 TRoom = record
46 Name: string;
47 Typ: TRoomType;
48 StartLine: Integer;
49 Count: Integer;
50 Lines: array of TLine;
51 end;
52
53 TUser = record
54 Nick: string;
55 HostName: string;
56 IP: string;
57 Female: Boolean;
58 Color: Integer;
59 Client: string;
60 ClientVersion: string;
61 CoreVersion: string;
62 OSVersion: string;
63 OSUser: string;
64 Status: string;
65 LastTime: TDateTime;
66 UpTime: TDateTime;
67 LocalSystemTime: TDateTime;
68 UserInfoTime: TDateTime;
69 ID: Integer;
70 NickTime: TDateTime;
71 Reason: string;
72 Sequence: Integer;
73 ErrorCount: Integer;
74 BlockMessages: Boolean;
75 Delay: TDateTime;
76 RoomName: string;
77 RoomType: TRoomType;
78 DetailInfo: string;
79 IdleTime: Integer;
80 end;
81
82 TAddMessageMethod = procedure(RoomIndex: Integer; const Args: array of const; EventType: TAppEventType; TextColor: TColor = clSysMessage; Nick: string = '') of object;
83
84 TBroadcastType = (btLocal, btGlobal);
85
86 TSunriseChatCore = class(TDataModule)
87 fndTCPServer1: TfndTCPServer;
88 fndTCPClient1: TfndTCPClient;
89 fndUDPClientSocket1: TfndUDPClientSocket;
90 Timer1: TTimer;
91 Timer2: TTimer;
92 Timer3: TTimer;
93 procedure fndTCPServer1DataAvailable(Sender: TTCPServerClient);
94 procedure fndTCPClient1ConnectFailed(Sender: ATCPClient);
95 procedure fndTCPClient1DataAvailable(Sender: ATCPClient);
96 procedure fndUDPClientSocket1DataAvailable(Sender: AUDPSocket);
97 procedure fndTCPClient1Close(Sender: ATCPClient);
98 procedure Timer1Timer(Sender: TObject);
99 procedure Timer2Timer(Sender: TObject);
100 procedure DataModuleCreate(Sender: TObject);
101 procedure fndUDPClientSocket1Error(Sender: ASocket);
102 procedure Timer3Timer(Sender: TObject);
103 private
104 FOnAddMessage: TAddMessageMethod;
105 FOnChangeNetworkState: TClassMethod;
106 FOnUserListChange: TClassMethod;
107// FOnPingResponse: TClassMethod;
108// FOnCallUp: TClassMethod;
109 FOnCommand: TClassMethod;
110// FOnNickChange: TClassMethod;
111 FConnected: Boolean;
112 FOnRoomListChanged: TClassMethod;
113 FMaxRoomLines: Integer;
114 LibHandle: HInst; //dll handle
115 LastHour: Word;
116 InputBuffer: string;
117 procedure ExecuteCommand(Text: string);
118 function GetWindowsVersionStr: string;
119 procedure SetMaxRoomLines(Number: Integer);
120 function SecondsIdle: DWord;
121 function Explode(Separator: Char; Data: string): TArrayOfString;
122 public
123 BroadcastType: TBroadcastType;
124 NetworkInterfaces: TNetworkInterfaceList;
125 UDPPort: Integer;
126 NetworkInterfaceIPAddress: string;
127 LocalUser: TUser;
128 UserList: array of TUser;
129 ActiveRoomIndex: Integer;
130 RoomList: array of TRoom;
131 LastMessage: string;
132 LastFont: TFont;
133 LastUserIndex: Integer;
134 LastEventType: TAppEventType;
135 AutoAwayIdleTime: Integer;
136 NetworkBridge: Boolean;
137 NetworkInterfaceIndex: Integer;
138 procedure ChangeNick(NewNick: string; SendCmd: Boolean = True);
139 procedure Init;
140 procedure DeleteRoom(RoomIndex: Integer);
141 procedure AddMessage(RoomIndex: Integer; const Args: array of const; EventType: TAppEventType; TextColor: TColor = clSysMessage; Nick: string = '');
142 procedure DeleteOfflineUsers;
143 procedure UpdateUser(User: TUser);
144 constructor Create(AOwner: TComponent); override;
145 procedure SendCommand(Command, Text: string; DestinationIP: string = ''; DestinationID: Integer = 0);
146 procedure StartNetwork;
147 destructor Done;
148 property Connected: Boolean read FConnected;
149 procedure LoadNetworkInterfaceList;
150 procedure SelectNetworkInterface(SelectedGUID: string);
151 published
152 property MaxRoomLines: Integer read FMaxRoomLines write SetMaxRoomLines;
153 property LocalIPAddress: string read LocalUser.IP write LocalUser.IP;
154// property OnNickChange: TClassMethod read FOnNickChange write FOnNickChange;
155 property OnUserListChange: TClassMethod read FOnUserListChange write FOnUserListChange;
156 property OnAddMessage: TAddMessageMethod read FOnAddMessage write FOnAddMessage;
157 property OnChangeNetworkState: TClassMethod read FOnChangeNetworkState write FOnChangeNetworkState;
158// property OnPingResponse: TClassMethod read FOnPingResponse write FOnPingResponse;
159// property OnCallUp: TClassMethod read FOnCallUp write FOnCallUp;
160 property OnCommand: TClassMethod read FOnCommand write FOnCommand;
161 property OnRoomListChanged: TClassMethod read FOnRoomListChanged write FOnRoomListChanged;
162 end;
163
164var
165 SunriseChatCore: TSunriseChatCore;
166 GetLastInputInfo2: function(var plii: TLastInputInfo): BOOL; stdcall;
167
168implementation
169
170uses DateUtils, UMainWindow, StrUtils, IpHlpApi, IpTypes;
171
172{$R *.dfm}
173
174{ TSunriseChatCore }
175
176function TSunriseChatCore.SecondsIdle: DWord;
177var
178 liInfo: TLastInputInfo;
179begin
180 // Only WinNT+
181 if Assigned(GetLastInputInfo2) then begin
182 liInfo.cbSize := SizeOf(TLastInputInfo) ;
183 GetLastInputInfo2(liInfo) ;
184 Result := (GetTickCount - liInfo.dwTime) DIV 1000;
185 end else Result:= 0;
186// MainWindow.RichEdit1.Lines.Add(IntToStr(Result));
187// SysUtils.Beep;
188// Result:= IdleTrackerGetLastTickCount div 1000;
189// Button1.Caption:= IntToStr(Result);
190// Result:= 0;
191end;
192
193constructor TSunriseChatCore.Create(AOwner: TComponent);
194begin
195 inherited;
196
197 // Try to load indirectly function GetLastInputInfo for compatibility with Win9x
198 LibHandle:= LoadLibrary('user32.dll');
199 if LibHandle = 0 then begin
200 GetLastInputInfo2:= nil;
201 end else begin
202 @GetLastInputInfo2:= GetProcAddress(LibHandle,'GetLastInputInfo');
203 if (@GetLastInputInfo2 = nil) then FreeLibrary(LibHandle);
204 end;
205
206 with LocalUser do begin
207 OSVersion:= GetWindowsVersionStr;
208 OSUser:= cWindows.GetUserName;
209 Status:= usOnline;
210 HostName:= LocalHostName;
211 Uptime:= Now;
212 IP:= LocalIPAddress;
213 ID:= Application.Handle;
214 RoomName:= 'Všichni';
215 RoomType:= rtPublic;
216 end;
217 LocalUser.CoreVersion:= CoreVersion;
218 SetLength(RoomList,1);
219 with RoomList[0] do begin
220 Name:= 'Všichni';
221 Typ:= rtPublic;
222// AddMessage(0,'Vítejte v SunriseChatu!');
223 end;
224(*
225 with RoomList[1] do begin
226 Name:= 'George';
227 Typ:= rtPrivate;
228 ActiveRoomIndex:= 1;
229 //AddMessage(1,'Test');
230 end;
231*)
232end;
233
234destructor TSunriseChatCore.Done;
235begin
236
237end;
238
239procedure TSunriseChatCore.ExecuteCommand(Text: string);
240var
241 RemoteUser: TUser;
242 ProtocolVersion: Integer;
243 DestinationIP: string;
244 DestinationID: Integer;
245 Seq: Integer;
246 Command: string;
247 Data: string;
248 NewNick: string;
249 I: Integer;
250 IdleTime2: Integer;
251
252function Parse: string;
253begin
254 Result:= Copy(Text,1,Pos('|',Text)-1);
255 Delete(Text,1,Length(Result)+1);
256end;
257
258begin
259// OnAddMessage(Text,clSysMessage);
260 //AddMessage(Command);
261 with SunriseChatCore, RemoteUser do try
262 ProtocolVersion:= StrToInt(Parse);
263 case ProtocolVersion of
264 1: begin
265 Client:= Parse;
266 ClientVersion:= Parse;
267 Nick:= Parse;
268 OSVersion:= Parse;
269 ID:= StrToInt(Parse);
270 Color:= StrToInt(Parse);
271 Uptime:= StrToDateTime(Parse);
272 IP:= Parse;
273 HostName:= Parse;
274 Command:= Parse;
275 Data:= Parse;
276 if Command = 'Message' then begin
277// if not BlockMessages then OnAddMessage('(Nepodporovaná verze) <'+Nick+'> '+Data,Color);
278 end else
279 end;
280 2: begin
281 DestinationIP:= Parse; // Destination IP
282 DestinationID:= StrToInt(Parse); // Destination ID
283 IP:= Parse; // Source IP
284 ID:= StrToInt(Parse); // Source ID
285 Seq:= StrToInt(Parse); // sequence command number
286
287 // Load remote user data
288 I:= 0;
289 while (I<Length(UserList)) and ((UserList[I].IP<>IP) or (UserList[I].ID<>ID)) do I:= I + 1;
290 if I<Length(UserList) then begin
291 RemoteUser:= UserList[I];
292 end else Sequence:= Seq-1;
293 if Seq<>(RemoteUser.Sequence+1) then ErrorCount:= ErrorCount + 1;
294 Sequence:= Seq;
295 UpdateUser(RemoteUser);
296
297 if ((DestinationIP = LocalUser.IP) and (DestinationID = LocalUser.ID)) or (DestinationIP='') then begin
298
299 Command:= Parse; // Command
300 if Command = 'Message' then begin
301 Color:= StrToInt(Parse);
302 LastMessage:= Parse;
303 RoomName:= Parse;
304 RoomType:= TRoomType(StrToInt(Parse));
305
306 // Search room
307 I:= 0;
308 while (I<Length(RoomList)) and (RoomList[I].Name<>RoomName) do I:= I + 1;
309 if (RoomType = rtPublic) and (I=Length(RoomList)) then begin
310 SetLength(RoomList,Length(RoomList)+1);
311 with RoomList[High(RoomList)] do begin
312 Name:= RoomName;
313 Typ:= RoomType;
314 SetLength(Lines,FMaxRoomLines);
315 StartLine:= 0;
316 Count:= 0;
317 end;
318 if Assigned(FOnRoomListChanged) then FOnRoomListChanged;
319 end;
320
321 UpdateUser(RemoteUser);
322 if (I<Length(RoomList)) and not BlockMessages then begin
323 AddMessage(I, [RemoteUser.Nick, LastMessage], aeCommonMessage,Color,Nick);
324 end;
325 end else
326 if Command = 'CreateRoom' then begin
327 RoomName:= Parse;
328 RoomType:= TRoomType(StrToInt(Parse));
329 //ShowMessage(LocalUser.IP+','+IP+' '+IntToStr(LocalUser.ID)+','+IntToStr(ID));
330 if (RoomType = rtPublic) or ((RoomType = rtPrivate) and (LocalUser.IP = DestinationIP) and (LocalUser.ID = DestinationID)) then begin
331 // Search room
332 I:= 0;
333 while (I<Length(RoomList)) and (RoomList[I].Name<>RoomName) do I:= I + 1;
334 if I<Length(RoomList) then
335 else begin
336 SetLength(RoomList,Length(RoomList)+1);
337 with RoomList[High(RoomList)] do begin
338 Name:= RoomName;
339 Typ:= RoomType;
340 SetLength(Lines,FMaxRoomLines);
341 StartLine:= 0;
342 Count:= 0;
343 end;
344 end;
345 //ActiveRoomIndex:= I;
346 if Assigned(FOnRoomListChanged) then FOnRoomListChanged;
347 AddMessage(riAll, [RemoteUser.Nick, RoomName] ,aeCreateRoom);
348 end;
349 end else
350 if Command = 'LeaveRoom' then begin
351 RoomName:= Parse;
352
353 // Search room
354 I:= 0;
355 while (I<Length(RoomList)) and (RoomList[I].Name<>RoomName) do I:= I + 1;
356 if I<Length(RoomList) then
357 AddMessage(riAll, [RemoteUser.Nick, RoomName], aeLeaveRoom);
358 end else
359 if Command = 'Connect' then begin
360 Nick:= Parse;
361 NickTime:= StrToDateTime(Parse);
362 if (LocalUser.IP<>IP) or (LocalUser.ID<>ID) then
363 AddMessage(riAll,[Nick, HostName], aeUserConnect);
364 SendCommand('UserInfo','');
365 UpdateUser(RemoteUser);
366 end else
367 if Command = 'Disconnect' then begin
368 AddMessage(riAll,[Nick],aeUserDisconnect);
369
370 // Delete disconnected user
371 I:= 0;
372 while (I<Length(UserList)) and ((UserList[I].IP <> RemoteUser.IP) or (UserList[I].ID <> RemoteUser.ID)) do I:= I + 1;
373 if I < Length(UserList) then begin
374 UserList[I]:= UserList[High(UserList)];
375 SetLength(UserList,High(UserList));
376 end;
377 if Assigned(OnUserListChange) then OnUserListChange;
378 end else
379 if Command = 'GoAway' then begin
380 Reason:= Parse;
381 Status:= usAway;
382 AddMessage(riAll, [Nick, Reason], aeUserGoAway);
383 UpdateUser(RemoteUser);
384 end else
385 if Command = 'GoOnline' then begin
386 Status:= usOnline;
387 AddMessage(riAll, [Nick], aeUserGoBack);
388 UpdateUser(RemoteUser);
389 end else
390 if Command = 'CallUp' then begin
391 if not BlockMessages then AddMessage(riAll, [Nick], aeReceiveCallUp);
392 end else
393 if Command = 'Ping' then begin
394 SendCommand('PingResponse',Parse,IP,ID);
395 end else
396 if Command = 'PingResponse' then begin
397 AddMessage(riAll,[Nick,TimeToStr(Now-StrToTime(Parse))],aePingResponse);
398 end else
399 if Command = 'Alive' then begin
400 Delay:= Now-LastTime;
401 LastTime:= Now;
402 if not TryStrToInt(Parse,IdleTime2) then IdleTime2:= 0;
403 if (IdleTime2 > AutoAwayIdleTime*60) and (IdleTime < AutoAwayIdleTime*60) and (Status = usOnline) then begin
404 AddMessage(riAll,[Nick, IntToStr(AutoAwayIdleTime)], aeUserAutoGoAway);
405 end;
406 if (IdleTime > AutoAwayIdleTime*60) and (IdleTime2 < AutoAwayIdleTime*60) and (Status = usOnline) then begin
407 AddMessage(riAll, [Nick, IntToStr(IdleTime div 60)], aeUserAutoGoBack);
408 end;
409 IdleTime:= IdleTime2;
410 UpdateUser(RemoteUser);
411 end else
412 if Command = 'WhoIs' then begin
413 SendCommand('UserInfo','');
414 end else
415 if Command = 'UserInfo' then begin
416 NewNick:= Parse;
417 if (NewNick <> Nick) and (NickTime<>0) then AddMessage(riAll, [Nick, NewNick], aeUserChangeNick);
418 Nick:= NewNick;
419 NickTime:= StrToDateTime(Parse);
420 if (HostName='') and (LastTime<>0) then AddMessage(riAll, [RemoteUser.Nick], aeUserRestore);
421 Reason:= Parse;
422 Status:= Parse;
423 HostName:= Parse;
424 OSVersion:= Parse;
425 OSUser:= Parse;
426 Uptime:= StrToDateTime(Parse);
427 Client:= Parse;
428 ClientVersion:= Parse;
429 CoreVersion:= Parse;
430 if Length(Text)>0 then begin
431 LocalSystemTime:= StrToDateTime(Parse);
432 end;
433 DetailInfo:= Parse;
434
435 UserInfoTime:= Now;
436
437 // Nick conflict test
438 if (LocalUser.Nick = Nick) and ((LocalUser.IP <> IP) or (LocalUser.ID <> ID)) then begin
439 if LocalUser.NickTime > NickTime then begin
440 // Set nick to Host(Guest) n
441 if Copy(LocalUser.Nick,1,4) = 'Host' then begin
442 if TryStrToInt(Copy(LocalUser.Nick,5,255),I) then I:= I + 1 else I:= 1;
443 end else I:= 1;
444 ChangeNick('Host' + IntToStr(I), False);
445 AddMessage(riAll, [LocalUser.Nick], aeUserChangeNickConflict);
446 end else SendCommand('UserInfo','');
447 end;
448 UpdateUser(RemoteUser);
449 end;
450 if Nick='' then SendCommand('WhoIs','',IP,ID);
451 end;
452 end;
453 end;
454 except
455 end;
456end;
457
458function UserIdleTime: Integer;
459begin
460end;
461
462procedure TSunriseChatCore.SendCommand(Command, Text: string; DestinationIP: string = ''; DestinationID: Integer = 0);
463var
464 Data: string;
465
466procedure AddPart(Part: string);
467begin
468 Data:= Data + Part + '|';
469end;
470
471begin
472 if FConnected and (LocalUser.Status <> usInvisible) then begin
473 //if not NoResloveHostName then
474 Data:= '';
475 with LocalUser do begin
476 AddPart(IntToStr(ProtocolVersion));// Version of protocol
477 AddPart(DestinationIP); // Destination IP
478 AddPart(IntToStr(DestinationID)); // Destination ID
479 AddPart(IP); // Source IP
480 AddPart(IntToStr(ID)); // Source ID
481 Sequence:= Sequence + 1;
482 AddPart(IntToStr(Sequence)); // Sequence command number
483 AddPart(Command); // Command
484 if Command = 'Message' then begin
485 AddPart(IntToStr(Color)); // User text color
486 AddPart(Text); // Command data
487 AddPart(RoomList[ActiveRoomIndex].Name); // Room name
488 AddPart(IntToStr(Integer(RoomList[ActiveRoomIndex].Typ))); // Public or private room
489 end else
490 if Command = 'Connect' then begin
491 AddPart(Nick);
492 AddPart(DateTimeToStr(NickTime));
493 end else
494 if Command = 'Disconnect' then begin
495 end else
496 if Command = 'GoAway' then begin
497 AddPart(Reason); // Away mode reason
498 end else
499 if Command = 'GoOnline' then begin
500 end else
501 if Command = 'GoAutoAway' then begin
502 end else
503 if Command = 'GoAutoOnline' then begin
504 end else
505 if Command = 'CallUp' then begin
506 end else
507 if Command = 'CallUpResponse' then begin
508 end else
509 if Command = 'Ping' then begin
510 AddPart(TimeToStr(Now)); // Send time
511 end else
512 if Command = 'PingResponse' then begin
513 AddPart(Text); // Send time
514 end else
515 if Command = 'Alive' then begin
516 AddPart(IntToStr(SecondsIdle));
517 end else
518 if Command = 'WhoIs' then begin
519 end else
520 if Command = 'CreateRoom' then begin
521 AddPart(RoomName); // Room name
522 AddPart(IntToStr(Integer(RoomType))); // Public or private room
523 end else
524 if Command = 'LeaveRoom' then begin
525 AddPart(RoomList[ActiveRoomIndex].Name); // Room name
526 end else
527 if Command = 'UserInfo' then begin
528 AddPart(Nick); // User name
529 AddPart(DateTimeToStr(NickTime)); // User name time
530 AddPart(Reason); // Away mode reason
531 AddPart(Status); // User status
532 AddPart(HostName); // Local host name
533 AddPart(OSVersion); // OS version
534 AddPart(OSUser); // Logged user
535 AddPart(DateTimeToStr(Uptime)); // Application uptime
536 AddPart(Client); // Name of client application
537 AddPart(ClientVersion); // Version of application
538 AddPart(CoreVersion); // SunriseChatCoreVersion
539 AddPart(DateTimeToStr(Now)); // Local system time
540 AddPart(DetailInfo); // Detailed info about user
541 end;
542 end;
543 fndTCPClient1.Socket.SendStr(Data+#13);
544 end;
545end;
546
547procedure TSunriseChatCore.fndTCPServer1DataAvailable(Sender: TTCPServerClient);
548var
549 Text: string;
550begin
551 if Sender.Socket.InBufferSize>0 then begin
552 Text:= Sender.Socket.ReadAvailable;
553 if BroadcastType = btGlobal then
554 fndUDPClientSocket1.Broadcast(IntToStr(UDPPort), Text) else
555 fndUDPClientSocket1.SendStr(Text);
556 end;
557end;
558
559procedure TSunriseChatCore.fndTCPClient1ConnectFailed(Sender: ATCPClient);
560begin
561// ShowMessage(Sender.Socket.ErrorMessage);
562end;
563
564procedure TSunriseChatCore.fndTCPClient1DataAvailable(Sender: ATCPClient);
565var
566 Text: string;
567begin
568 if Sender.Socket.InBufferSize > 0 then begin
569 InputBuffer := InputBuffer + Sender.Socket.ReadAvailable;
570 while Pos(#13, InputBuffer) > 0 do begin
571 Text := Copy(InputBuffer, 1, Pos(#13, InputBuffer) - 1);
572 Delete(InputBuffer, 1, Length(Text) + 1);
573 ExecuteCommand(Text);
574 end;
575 end;
576end;
577
578procedure TSunriseChatCore.fndUDPClientSocket1DataAvailable(
579 Sender: AUDPSocket);
580var
581 Text: string;
582 Address : TSockAddr;
583 I: Integer;
584 LocalIPs: TInAddrArray;
585begin
586 if FConnected then begin
587 Sender.ReadPacket(Text,Address);
588
589// ShowMessage(Text);
590 for I:= 0 to fndTCPServer1.ClientCount-1 do
591 with fndTCPServer1.Client[I] do Socket.SendStr(Text);
592 end;
593end;
594
595procedure TSunriseChatCore.fndTCPClient1Close(Sender: ATCPClient);
596begin
597// ShowMessage('TCPClient close');
598 FConnected := False;
599 Timer1.Enabled:= True;
600 if Assigned(FOnChangeNetworkState) then FOnChangeNetworkState;
601end;
602
603procedure TSunriseChatCore.StartNetwork;
604var
605 I, II: Integer;
606const
607 Stav: array [0..6] of string = ('Closed', 'Resolving', 'Resolved', 'Connecting',
608 'Negotiating', 'Connected', 'Listening');
609begin
610 fndTCPClient1.OnClose:= nil;
611 Timer1.Enabled:= False;
612 FConnected:= False;
613 fndTCPClient1.Active:= False;
614 with fndTCPServer1 do begin
615 Active:= False;
616 ListenPort:= IntToStr(UDPPort+1);
617 LocalHost:= LocalUser.IP; //'localhost';
618 try
619 Active:= True;
620 except
621 end;
622 // ShowMessage(Stav[Integer(fndTCPServer1.Socket.State)]);
623
624 fndUDPClientSocket1.Terminate;
625 fndUDPClientSocket1.LocalHost:= LocalUser.IP;
626 fndUDPClientSocket1.LocalPort:= IntToStr(UDPPort);
627 fndUDPClientSocket1.Host:= NetworkInterfaces[NetworkInterfaceIndex].BroadcastIPAddress;
628 fndUDPClientSocket1.Port:= IntToStr(UDPPort);
629 fndUDPClientSocket1.BroadcastOption:= True;
630 try
631 fndUDPClientSocket1.Bind;
632 except
633// on EWinSock do begin
634// ShowMessage('Nelze inicializovat síť!');
635// Application.Terminate;
636// end;
637 end;
638 end;
639 with fndTCPClient1 do begin
640 Active:= False;
641 Host:= LocalUser.IP; // 'localhost';
642 Port:= IntToStr(UDPPort+1);
643 LocalHost:= LocalUser.IP; //'localhost';
644 I:= 2;
645 repeat
646 Active:= False;
647 LocalPort:= IntToStr(UDPPort+I);
648 I:= I + 1;
649 try
650 Active:= True;
651 except
652 end;
653 II:= 0;
654 while (Socket.State in [ssResolving, ssNegotiating, ssConnecting]) and (II<100) do begin
655 Application.ProcessMessages;
656 //Sleep(10);
657 II:= II + 1;
658 end;
659// ShowMessage(Stav[Integer(fndTCPClient1.Socket.State)]);
660 until (Socket.State in [ssConnected, ssResolved]) or (I>30); //or (fndTCPServer1.Socket.State = ssClosed);
661 FConnected := not (fndUDPClientSocket1.Bound xor (fndTCPServer1.Socket.State = ssListening)) and
662 (fndTCPClient1.Socket.State in [ssConnected, ssResolved]);
663 //ShowMessage(IntToStr(Integer(fndTCPClient1.Socket.State))+','+BoolToStr(fndUDPClientSocket1.Bound)
664 //+','+BoolToStr(FConnected)+','+BoolToStr(fndTCPClient1.Socket.Connected));
665 if FConnected then begin
666 SunriseChatCore.SendCommand('UserInfo','');
667 SunriseChatCore.SendCommand('Connect','');
668 end;
669 if Assigned(FOnChangeNetworkState) then OnChangeNetworkState;
670 end;
671 Timer1.Enabled := True;
672 fndTCPClient1.OnClose:= fndTCPClient1Close;
673end;
674
675procedure TSunriseChatCore.Timer1Timer(Sender: TObject);
676begin
677// Timer1.Enabled := False;
678// if fndUDPClientSocket1.State
679 if not FConnected then StartNetwork;
680 if FConnected and (HourOf(Now) <> LastHour) then begin
681 LastHour:= HourOf(Now);
682 AddMessage(riAll,[HourOf(Now),MinuteOf(Now)], aeShowHours);
683 end;
684// Timer1.Enabled := True;
685end;
686
687procedure TSunriseChatCore.Init;
688begin
689 StartNetwork;
690end;
691
692function TSunriseChatCore.GetWindowsVersionStr: string;
693begin
694 case Win32Platform of
695 1: case Win32MajorVersion of
696 4: case Win32MinorVersion of
697 0: Result:= '95';
698 10: Result:= '98';
699 90: Result:= 'Me';
700 end;
701 end;
702 2: case Win32MajorVersion of
703 4: case Win32MinorVersion of
704 0: Result:= 'NT 4.0';
705 end;
706 5: case Win32MinorVersion of
707 0: Result:= '2000';
708 1: Result:= 'XP';
709 2: Result:= 'Server 2003';
710 end;
711 6: case Win32MinorVersion of
712 0: Result := 'Vista';
713 end;
714 end;
715 end;
716 Result:= 'Windows ' + Result;
717end;
718
719procedure TSunriseChatCore.DeleteOfflineUsers;
720var
721 I: Integer;
722 Changed: Boolean;
723begin
724 I:= 0;
725 Changed:= False;
726 while (I<Length(UserList)) do begin
727 if (Now - UserList[I].LastTime)>RemoveTimeout then begin
728 AddMessage(riAll, [UserList[I].Nick], aeUserTimeout);
729 UserList[I]:= UserList[High(UserList)];
730 SetLength(UserList,High(UserList));
731 Changed:= True;
732 end else I:= I + 1;
733 end;
734 if Changed and Assigned(FOnUserListChange) then FOnUserListChange;
735// TSocketState
736end;
737
738procedure TSunriseChatCore.UpdateUser(User: TUser);
739var
740 I: Integer;
741begin
742 I:= 0;
743 while (I<Length(UserList)) and ((UserList[I].IP<>User.IP) or ((UserList[I].ID<>User.ID))) do I:= I + 1;
744 if I = Length(UserList) then begin
745 SetLength(UserList,Length(UserList)+1);
746 end;
747 User.LastTime:= Now;
748 UserList[I]:= User;
749 LastUserIndex:= I;
750 if Assigned(FOnUserListChange) then FOnUserListChange;
751end;
752
753procedure TSunriseChatCore.Timer2Timer(Sender: TObject);
754begin
755// MainWindow.Label1.Caption:= IntToStr(Integer(fndTCPClient1.Socket.State));
756 SendCommand('Alive', '');
757// MainWindow.Label3.Caption := IntToStr(StrToInt(MainWindow.Label3.Caption) + 1);
758 DeleteOfflineUsers;
759end;
760
761procedure TSunriseChatCore.AddMessage(RoomIndex: Integer; const Args: array of const; EventType: TAppEventType; TextColor: TColor = clSysMessage; Nick: string = '');
762var
763 I: Integer;
764begin
765 if Assigned(OnAddMessage) then OnAddMessage(RoomIndex, Args, EventType, TextColor, Nick);
766
767 if (LastMessage<>'') and (RoomIndex < Length(RoomList)) then begin
768 if RoomIndex = riAll then begin
769 for RoomIndex := 0 to High(RoomList) do with RoomList[RoomIndex] do begin
770 Count := Count + 1;
771 if Count > FMaxRoomLines then begin
772 StartLine := (StartLine + 1) mod FMaxRoomLines;
773 Count := FMaxRoomLines;
774 end;
775 I := (StartLine + Count - 1) mod FMaxRoomLines;
776 Lines[I].Text := LastMessage;
777 Lines[I].Font := LastFont;
778 Lines[I].Time := Now;
779 Lines[I].Nick := Nick;
780 end;
781 end else with RoomList[RoomIndex] do begin
782 Count := Count + 1;
783 if Count > FMaxRoomLines then begin
784 StartLine := (StartLine + 1) mod FMaxRoomLines;
785 Count := FMaxRoomLines;
786 end;
787 I := (StartLine + Count - 1) mod FMaxRoomLines;
788 Lines[I].Text := LastMessage;
789 Lines[I].Font := LastFont;
790 Lines[I].Time := Now;
791 Lines[I].Nick := Nick;
792 end;
793 end;
794end;
795
796procedure TSunriseChatCore.DeleteRoom(RoomIndex: Integer);
797begin
798 RoomList[RoomIndex]:= RoomList[High(RoomList)];
799 SetLength(RoomList,High(RoomList));
800 FOnRoomListChanged;
801end;
802
803procedure TSunriseChatCore.ChangeNick(NewNick: string; SendCmd: Boolean = True);
804begin
805 with SunriseChatCore do begin
806 LocalUser.NickTime:= Now;
807 LocalUser.Nick:= NewNick;
808 SendCommand('UserInfo','');
809 end;
810end;
811
812procedure TSunriseChatCore.SetMaxRoomLines(Number: Integer);
813var
814 I: Integer;
815begin
816 FMaxRoomLines:= Number;
817 for I:= 0 to High(RoomList) do with RoomList[I] do begin
818 SetLength(Lines,Number);
819 StartLine:= 0;
820 Count:= 0;
821 end;
822end;
823
824procedure TSunriseChatCore.DataModuleCreate(Sender: TObject);
825begin
826 LastHour:= HourOf(Now);
827 LoadNetworkInterfaceList;
828end;
829
830procedure TSunriseChatCore.LoadNetworkInterfaceList;
831var
832 I, II: Integer;
833 Status: Cardinal;
834 AdaptersList : array of IP_ADAPTER_INFO;
835 BufSize: Cardinal;
836 IPParts: TArrayOfString;
837 SubnetParts: TArrayOfString;
838
839function IpListToStr(pIpAddr : PIP_ADDR_STRING) : String;
840begin
841 Result := '';
842 repeat
843 Result := Result + ', ' + Pchar(Addr(pIpAddr^.IpAddress));
844 pIpAddr := pIpAddr.Next;
845 until pIpAddr = nil;
846 Delete(Result, 1, 2);
847 if Result = '' then Result := 'none';
848end;
849
850begin
851 SetLength(NetworkInterfaces,0); // Clear list
852 if Win32Platform > 1 then begin
853 BufSize := 0;
854 Status := GetAdaptersInfo(@AdaptersList[0], BufSize);
855 SetLength(AdaptersList, BufSize div SizeOf(IP_ADAPTER_INFO));
856 SetLength(NetworkInterfaces, Length(AdaptersList));
857 Status := GetAdaptersInfo(@AdaptersList[0], BufSize);
858 for I := 0 to High(AdaptersList) do with NetworkInterfaces[I], AdaptersList[I] do begin
859// IPAddress := CurrentIpAddress^.IpAddress.s;
860// SubNetMask := CurrentIpAddress^.IpMask.s;
861 IPAddress := IpAddressList.IPAddress.S;
862 SubNetMask := IpAddressList.IPMask.s;
863 GUID := AdapterName;
864(*
865 II := MAX_ADAPTER_DESCRIPTION_LENGTH;
866 while Description[II] = #0 do Dec(II);
867 SetLength(Name, II);
868 Move(Description[0], Name[1], Length(Name));
869*)
870 Name := Description;
871 SubnetParts := Explode('.', SubNetMask);
872 IPParts := Explode('.', IPAddress);
873 for II := 0 to 3 do
874 IPParts[II] := IntToStr(StrToInt(IPParts[II]) or (StrToInt(SubnetParts[II]) xor $ff));
875 BroadcastIPAddress := IPParts[0]+'.'+IPParts[1]+'.'+IPParts[2]+'.'+IPParts[3];
876 end;
877// DisplayIfConf;
878// NetworkInterfaces := GetNetworkAdapterList;
879 end else begin
880 // For Windows 9x compatibility
881 SetLength(NetworkInterfaces,Length(LocalIPAddressesStr));
882 for I:= 0 to High(LocalIPAddressesStr) do with NetworkInterfaces[I] do begin
883 IPAddress:= LocalIPAddressesStr[I];
884 Name:= LocalIPAddressesStr[I];
885 GUID:= LocalIPAddressesStr[I];
886 end;
887 end;
888end;
889
890procedure TSunriseChatCore.SelectNetworkInterface(SelectedGUID: string);
891var
892 I: Integer;
893begin
894 I:= 0;
895 while (I<Length(NetworkInterfaces)) and (NetworkInterfaces[I].GUID <> SelectedGUID) do I:= I + 1;
896 if I<Length(NetworkInterfaces) then begin
897 NetworkInterfaceIndex:= I;
898 LocalUser.IP:= NetworkInterfaces[I].IPAddress;
899 end else begin
900 if Length(NetworkInterfaces)>0 then begin
901 NetworkInterfaceIndex:= 0;
902 LocalUser.IP:= NetworkInterfaces[0].IPAddress;
903 end else begin
904 NetworkInterfaceIndex:= 0;
905 LocalUser.IP:= '127.0.0.1';
906 end;
907 end;
908 StartNetwork;
909end;
910
911function TSunriseChatCore.Explode(Separator: Char;
912 Data: string): TArrayOfString;
913begin
914 SetLength(Result,0);
915 while Pos(Separator,Data)>0 do begin
916 SetLength(Result, Length(Result)+1);
917 Result[High(Result)]:= Copy(Data,1,Pos(Separator,Data)-1);
918 Delete(Data,1,Pos(Separator,Data));
919 end;
920 SetLength(Result, Length(Result)+1);
921 Result[High(Result)]:= Data;
922end;
923
924procedure TSunriseChatCore.fndUDPClientSocket1Error(Sender: ASocket);
925begin
926// ShowMessage('UDPClient error');
927end;
928
929procedure TSunriseChatCore.Timer3Timer(Sender: TObject);
930begin
931 try
932 MainWindow.Caption := GetEnumName(TypeInfo(TSocketState), Integer(fndTCPClient1.Socket.State)) +
933 ','+GetEnumName(TypeInfo(TSocketState), Integer(fndUDPClientSocket1.State))+ BoolToStr(fndUDPClientSocket1.Bound);
934 finally
935 end;
936end;
937
938end.
Note: See TracBrowser for help on using the repository browser.