source: tags/2.9/USunriseChatCore.pas

Last change on this file was 10, checked in by george, 16 years ago

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