source: branches/3 fndSockets/SunriseChatCoreUnit.pas

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

Opraveno: Načítání seznamu síťových adaptérů na Linuxu.
Přidáno: Úpravy pro potřeby ladění problému s nepřijímáním UDP paketů.
  • Property svn:executable set to *
File size: 27.8 KB
Line 
1unit SunriseChatCoreUnit;
2
3interface
4
5uses
6 SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
7 Forms, StdCtrls, ExtCtrls, SunriseChatCoreUtils, DateUtils, Dialogs;
8
9const
10 ProtocolVersion = 3;
11 CoreVersion = '3.0';
12 RemoveTimeout = 33/24/3600; // 33 seconds
13 AliveCommandSendingPeriod = 5; // in seconds
14
15 UserStatusModeText: array[0..4] of string = ('Online', 'Away', 'Writing',
16 'Invisible', 'Offline');
17
18 DefaultEventsFormat: array[0..22] of string = ('<%0:s> %1:s', '<%0:s> %3:s: %1:s',
19 'User %0:s connected from %1:s', 'User %0:s disconnected', 'User %0:s restored',
20 'User %0:s timeout', 'User %0:s went off', 'User %0:s got beck',
21 'Callup sended to user %0:s', 'Callup received from user %0:s',
22 'Ping sended to user %0:s', 'Ping response received from user %0:s',
23 'User %0:s changed nick to %1:s', 'Nick %0:s conflict',
24 'Room %1:s created by user %0:s', 'User %0:s left room %1:s',
25 'User %0:s gone to auto away mode', 'User %0:s returned from auto away mode',
26 '%0:s hours', 'Welcome %0:s!', 'Goodbye %0:s!', 'User %0:s invited to private room',
27 'Custom event');
28
29type
30 TSunriseChatCore = class;
31
32 TSystemCommand = (scUnknown, scMessage, scConnect, scDisconnect, scCallUp,
33 scCallUpResponse, scPing, scPingResponse, scAlive, scWhoIs, scCreateRoom,
34 scLeaveRoom, scUserInfo, scCustomCommand);
35
36 TAppEventType = (aeCommonMessage, aeOneUserMessage, aeUserConnect,
37 aeUserDisconnect, aeUserRestore, aeUserTimeout, aeUserGoAway, aeUserGoBack,
38 aeSendCallUp, aeReceiveCallUp, aeSendPing, aePingResponse, aeUserChangeNick,
39 aeUserChangeNickConflict, aeCreateRoom, aeLeaveRoom, aeUserAutoGoAway,
40 aeUserAutoGoBack, aeShowHours, aeStart, aeEnd, aeUserInvited, aeCustomEvent);
41
42 TMessageEvent = procedure (Text: string; Color: Integer) of object;
43 TClassMethod = procedure of object;
44
45 TRoomType = (rtPublic, rtPrivate);
46 TRoomLine = class(TPersistent)
47 public
48 Nick: string;
49 Text: string;
50 Font: TFont;
51 Time: TDateTime;
52 EventType: TAppEventType;
53 constructor Create;
54 procedure Assign(Source: TPersistent); override;
55 destructor Destroy; override;
56 end;
57
58 TRoom = class
59 private
60 FParent: TSunriseChatCore;
61 public
62 Id: Cardinal;
63 Name: string;
64 Typ: TRoomType;
65 StartLine: Integer;
66 Count: Integer;
67 Lines: TList; // of TRoomLine;
68 constructor Create(Parent: TSunriseChatCore);
69 procedure Select;
70 procedure Remove;
71 destructor Destroy; override;
72 end;
73
74 TUserStatusMode = (usOnline, usAway, usWriting, usInvisible, usOffline);
75
76 TClientIdentification = record
77 Machine: Cardinal;
78 User: Cardinal;
79 end;
80
81 TUser = class(TPersistent)
82 private
83 FParent: TSunriseChatCore;
84 FNick: string;
85 procedure SetNick(const Value: string);
86 public
87 HostName: string;
88 Id: TClientIdentification;
89 Female: Boolean;
90 Color: Integer;
91 Client: string;
92 ClientVersion: string;
93 CoreVersion: string;
94 OSVersion: string;
95 OSUser: string;
96 Status: TUserStatusMode;
97 LastTime: TDateTime; // Time of last Alive command (local)
98 Delay: TDateTime; // Time between LastTime
99 IdleTime: Integer; // User inactivity delay in seconds
100 UpTime: TDateTime; // Time of start of user client application
101 LocalSystemTime: TDateTime; // Current system time on user computer
102 UserInfoTime: TDateTime; // Time of last UserInfo command
103 NickTime: TDateTime; // Time of start of using nick
104 Reason: string; // Reason in away mode
105 Sequence: Integer; // Command sequence number
106 ErrorCount: Integer; // Number of sequence errors
107 BlockMessages: Boolean; // Blocking user activity
108 DetailInfo: string; // User description
109 property Nick: string read FNick write SetNick;
110 constructor Create(Parent: TSunriseChatCore);
111 procedure Assign(Source: TPersistent); override;
112 end;
113
114 TAddMessageMethod = procedure(EventType: TAppEventType; Room: TRoom;
115 const Args: array of const; RoomLine: TRoomLine) of object;
116
117 TSunriseChatCore = class(TComponent)
118 private
119 FCounter: Integer;
120 FTimer1: TTimer;
121 FOnAddMessage: TAddMessageMethod;
122 FOnChangeNetworkState: TClassMethod;
123 FOnUserListUpdate: TClassMethod;
124// FOnPingResponse: TClassMethod;
125// FOnCallUp: TClassMethod;
126// FOnNickChange: TClassMethod;
127 FOnRoomListChanged: TClassMethod;
128 FMaxRoomLines: Integer;
129 LastHour: Word;
130 FOnSendCommand: TGetStrProc;
131 FUseDefaultEventsText: Boolean;
132 procedure FTimer1Timer(Sender: TObject);
133 procedure SetMaxRoomLines(Number: Integer);
134 function SameClientId(Id1, Id2: TClientIdentification): Boolean;
135 protected
136 FActive: Boolean;
137 procedure SetActive(const Value: Boolean);
138 public
139 LocalUser: TUser;
140 UserList: TList; // of TUser;
141 ActiveRoom: TRoom;
142 RoomList: TList; // of TRoom;
143 FAutoAwayDelay: Integer;
144 constructor Create(AOwner: TComponent); override;
145 procedure DeleteRoom(RoomIndex: Integer);
146 procedure AddMessage(MessageEventType: TAppEventType; Room: TRoom; const Args: array of const);
147 procedure DeleteOfflineUsers;
148 procedure UpdateUser(User: TUser);
149 procedure SendCommand(Command: TSystemCommand; Text: string = '';
150 DestinationMachineId: Cardinal = 0; DestinationUserId: Cardinal = 0);
151 procedure ProcessCommand(Text: string);
152 destructor Destroy; override;
153 published
154 property AutoAwayDelay: Integer read FAutoAwayDelay write FAutoAwayDelay;
155 property UseDefaultEventsText: Boolean read FUseDefaultEventsText write FUseDefaultEventsText;
156 property Active: Boolean read FActive write SetActive;
157 property MaxRoomLines: Integer read FMaxRoomLines write SetMaxRoomLines;
158// property OnNickChange: TClassMethod read FOnNickChange write FOnNickChange;
159 property OnUserListUpdate: TClassMethod read FOnUserListUpdate write FOnUserListUpdate;
160 property OnAddMessage: TAddMessageMethod read FOnAddMessage write FOnAddMessage;
161 property OnChangeNetworkState: TClassMethod read FOnChangeNetworkState write FOnChangeNetworkState;
162// property OnPingResponse: TClassMethod read FOnPingResponse write FOnPingResponse;
163// property OnCallUp: TClassMethod read FOnCallUp write FOnCallUp;
164 property OnRoomListChanged: TClassMethod read FOnRoomListChanged write FOnRoomListChanged;
165 property OnSendCommand: TGetStrProc read FOnSendCommand write FOnSendCommand;
166 end;
167
168procedure Register;
169
170implementation
171
172uses
173 UProtocolMessageLog;
174
175procedure Register;
176begin
177 RegisterComponents('Chronosoft', [TSunriseChatCore]);
178end;
179
180{ TSunriseChatCore }
181
182constructor TSunriseChatCore.Create(AOwner: TComponent);
183var
184 NewRoom: TRoom;
185begin
186 inherited;
187 RoomList := TList.Create;
188 UserList := TList.Create;
189 LastHour := HourOf(Now);
190 LocalUser := TUser.Create(Self);
191 with LocalUser do begin
192 OSVersion := GetWindowsVersionStr;
193 OSUser := GetUserName;
194 Status := usOnline;
195 HostName := LocalHostName;
196 //HostName := LocalHostName;
197 Uptime := Now;
198 Id.Machine := Random(High(Integer));
199 Id.User := Random(High(Integer));
200 end;
201 LocalUser.CoreVersion := CoreVersion;
202 FMaxRoomLines := 100;
203 NewRoom := TRoom.Create(Self);
204 with NewRoom do begin
205 Id := 0;
206 Name := 'Public';
207 Typ := rtPublic;
208 end;
209 ActiveRoom := NewRoom;
210 RoomList.Add(NewRoom);
211 FActive := False;
212
213 // Initialise timer
214 FTimer1 := TTimer.Create(Self);
215 FCounter := 0;
216 with FTimer1 do begin
217 Interval := 1000; // 1 second
218 OnTimer := FTimer1Timer;
219 Enabled := False;
220 end;
221 FUseDefaultEventsText := True;
222 FAutoAwayDelay := 5;
223end;
224
225destructor TSunriseChatCore.Destroy;
226var
227 I: Integer;
228begin
229 Active := False;
230 for I := 0 to UserList.Count - 1 do TList(UserList[I]).Free;
231 UserList.Free;
232 LocalUser.Free;
233 for I := 0 to RoomList.Count - 1 do TRoom(RoomList[I]).Free;
234 RoomList.Free;
235 inherited;
236end;
237
238function TSunriseChatCore.SameClientId(Id1, Id2: TClientIdentification): Boolean;
239begin
240 Result := (Id1.Machine = Id2.Machine) and (Id1.User = Id2.User);
241end;
242
243procedure TSunriseChatCore.ProcessCommand(Text: string);
244var
245 SourceUser: TUser;
246 TargetUSer: TUser;
247 ProtocolVersion: Integer;
248 Seq: Integer;
249 Command: TSystemCommand;
250// Data: string;
251 Part: string;
252 I: Integer;
253 IdleTime2: Integer;
254 NewRoom: TRoom;
255 UserListCount: Integer;
256 Args: array of TVarRec;
257 RoomId: Cardinal;
258 RoomName: string;
259 RoomType: TRoomType;
260 TextMessage: string;
261
262function Parse: string;
263begin
264 Result := Copy(Text, 1, Pos('|', Text)-1);
265 Delete(Text, 1, Length(Result)+1);
266end;
267
268begin
269 UserListCount := UserList.Count;
270 SourceUser := TUser.Create(Self);
271 TargetUSer := TUser.Create(Self);
272// OnAddMessage(Text,clSysMessage);
273 //AddMessage(Command);
274 with SourceUser do try
275 ProtocolVersion := StrToInt(Parse);
276 case ProtocolVersion of
277 3: begin
278 SourceUser.Id.Machine := StrToInt64(Parse); // Source IP
279 SourceUser.Id.User := StrToInt64(Parse); // Source ID
280 TargetUser.Id.Machine := StrToInt64(Parse); // Destination IP
281 TargetUser.Id.User := StrToInt64(Parse); // Destination ID
282 Seq := StrToInt(Parse); // sequence command number
283
284 ProtocolMessageLogForm.Memo1.Lines.Add('ProcessCommand: ' + Text);
285 // Load source user data
286 if SameClientId(TargetUser.Id, LocalUser.Id) then begin
287 I := 0;
288 while (I < UserList.Count) and not SameClientId(TUser(UserList[I]).Id, TargetUser.Id) do
289 I := I + 1;
290 if I < UserList.Count then
291 TargetUser.Assign(UserList[I]);
292 end;
293
294 // Load source user data
295 I := 0;
296 while (I < UserList.Count) and not SameClientId(TUser(UserList[I]).Id, Id) do
297 I := I + 1;
298 if I < UserList.Count then begin
299 SourceUser.Assign(UserList[I]);
300 end else Sequence := Seq - 1;
301 if Seq <> (SourceUser.Sequence + 1) then ErrorCount := ErrorCount + 1;
302 Sequence := Seq;
303 ProtocolMessageLogForm.Memo1.Lines.Add('ProcessCommand: UpdateUser ');
304 UpdateUser(SourceUser);
305
306 begin
307 Command := TSystemCommand(StrToInt(Parse)); // Command
308 case Command of
309
310 scMessage: begin
311 TextMessage := Parse;
312 RoomId := StrToInt64(Parse);
313 RoomName := Parse;
314 RoomType := TRoomType(StrToInt(Parse));
315
316 // Search room
317 I := 0;
318 while (I < RoomList.Count) and (TRoom(RoomList[I]).Id <> RoomId) do
319 I := I + 1;
320 if (RoomType = rtPublic) and (I = RoomList.Count) then begin
321 NewRoom := TRoom.Create(Self);
322 with NewRoom do begin
323 Id := RoomId;
324 Name := RoomName;
325 Typ := RoomType;
326 end;
327 RoomList.Add(NewRoom);
328 if Assigned(FOnRoomListChanged) then FOnRoomListChanged;
329 end;
330
331 UpdateUser(SourceUser);
332 if (I < RoomList.Count) and not BlockMessages then begin
333 if not SameClientId(TargetUser.Id, LocalUser.Id) then
334 AddMessage(aeCommonMessage, TRoom(RoomList[I]), [Nick, TextMessage, Color])
335 else AddMessage(aeOneUserMessage, TRoom(RoomList[I]), [Nick, TextMessage, Color, TargetUser.Nick]);
336 end;
337 end;
338
339 scCreateRoom: begin
340 RoomId := StrToInt64(Parse);
341 RoomName := Parse;
342 RoomType := TRoomType(StrToInt(Parse));
343 //ShowMessage(LocalUser.IP+','+IP+' '+IntToStr(LocalUser.ID)+','+IntToStr(ID));
344 if (RoomType = rtPublic) or ((RoomType = rtPrivate) and
345 SameClientId(LocalUser.Id, TargetUser.Id)) then begin
346 // Search room
347 I := 0;
348 while (I < RoomList.Count) and (TRoom(RoomList[I]).Id <> RoomId) do
349 I := I + 1;
350 if I < RoomList.Count then
351 else begin
352 NewRoom := TRoom.Create(Self);
353 with NewRoom do begin
354 Id := RoomId;
355 Name := RoomName;
356 Typ := RoomType;
357 end;
358 RoomList.Add(NewRoom);
359 end;
360 if Assigned(FOnRoomListChanged) then FOnRoomListChanged;
361 AddMessage(aeCreateRoom, TRoom(RoomList[I]), [SourceUser.Nick, RoomName]);
362 end;
363 end;
364
365 scLeaveRoom: begin
366 RoomId := StrToInt64(Parse);
367 RoomName := Parse;
368
369 // Search room
370 I := 0;
371 while (I < RoomList.Count) and (TRoom(RoomList[I]).Id <> RoomId) do
372 I := I + 1;
373 if I < RoomList.Count then begin
374 if Assigned(FOnRoomListChanged) then FOnRoomListChanged;
375 AddMessage(aeLeaveRoom, TRoom(RoomList[I]), [Nick, RoomName]);
376 end;
377 end;
378
379 scConnect: begin
380 Nick := Parse;
381 NickTime := StrToDateTime(Parse);
382 if not SameClientId(LocalUser.Id, Id) then
383 AddMessage(aeUserConnect, nil, [Nick, HostName])
384 else AddMessage(aeStart, nil , [Nick]);
385 SendCommand(scUserInfo);
386 UpdateUser(SourceUser);
387 end;
388
389 scDisconnect: begin
390 if not SameClientId(LocalUser.Id, Id) then
391 AddMessage(aeUserDisconnect, nil, [Nick])
392 else AddMessage(aeEnd, nil , [Nick]);
393
394 // Delete disconnected user
395 I := 0;
396 while (I < UserList.Count) and not SameClientId(TUser(UserList[I]).Id, Id) do
397 I := I + 1;
398 if I < UserList.Count then begin
399 TUser(UserList[I]).Free;
400 UserList.Delete(I);
401 end;
402 if Assigned(OnUserListUpdate) then OnUserListUpdate;
403 end;
404
405 scCallUp: begin
406 if (not BlockMessages) and SameClientId(LocalUser.Id, TargetUser.Id) then AddMessage(aeReceiveCallUp, nil, [Nick]);
407 end;
408
409 scPing: begin
410 if SameClientId(LocalUser.Id, TargetUser.Id) then SendCommand(scPingResponse, Parse, TargetUser.Id.Machine, TargetUSer.Id.User);
411 end;
412
413 scPingResponse: begin
414 if SameClientId(LocalUser.Id, TargetUser.Id) then AddMessage(aePingResponse, nil, [Nick,TimeToStr(Now - StrToTime(Parse))]);
415 end;
416
417 scAlive: begin
418 Delay := Now - LastTime;
419 LastTime := Now;
420 if not TryStrToInt(Parse, IdleTime2) then IdleTime2 := 0;
421 if (IdleTime2 > AutoAwayDelay * 60) and (IdleTime < AutoAwayDelay * 60) and (Status = usOnline) then begin
422 AddMessage(aeUserGoAway, nil, [Nick, IntToStr(AutoAwayDelay)]);
423 end;
424 if (IdleTime > AutoAwayDelay * 60) and (IdleTime2 < AutoAwayDelay * 60) and (Status = usOnline) then begin
425 AddMessage(aeUserAutoGoBack, nil, [Nick, IntToStr(IdleTime div 60)]);
426 end;
427 IdleTime := IdleTime2;
428 UpdateUser(SourceUser);
429 end;
430
431 scWhoIs: begin
432 //if SameClientId(LocalUser.Id, TargetUser.Id) then
433 SendCommand(scUserInfo);
434 end;
435
436 scCustomCommand: begin
437 while Length(Text) > 0 do begin
438 SetLength(Args, Length(Args)+1);
439 Args[High(Args)].VPChar := PChar(Parse);
440 end;
441 AddMessage(aeCustomEvent, nil, Args);
442 end;
443
444 scUserInfo: begin
445 Part := Parse;
446 if (Part <> Nick) and (NickTime <> 0) then AddMessage(aeUserChangeNick, nil, [Nick, Part]);
447 FNick := Part;
448 ProtocolMessageLogForm.Memo1.Lines.Add('ProcessCommand: UserInfo ' + FNick);
449 NickTime := StrToDateTime(Parse);
450 Color := StrToInt(Parse);
451 Reason := Parse;
452 Part := Parse;
453 if TUserStatusMode(StrToInt(Part)) <> Status then
454 case TUserStatusMode(StrToInt(Part)) of
455 usAway: begin
456 AddMessage(aeUserGoAway, nil, [Nick, Reason]);
457 UpdateUser(SourceUser);
458 end;
459 usOnline: begin
460 AddMessage(aeUserGoBack, nil, [Nick]);
461 UpdateUser(SourceUser);
462 end;
463 end;
464 Status := TUserStatusMode(StrToInt(Part));
465 HostName := Parse;
466 OSVersion := Parse;
467 OSUser := Parse;
468 Uptime := StrToDateTime(Parse);
469 Client := Parse;
470 ClientVersion := Parse;
471 CoreVersion := Parse;
472 LocalSystemTime := StrToDateTime(Parse);
473 DetailInfo := Parse;
474 UserInfoTime := Now;
475
476 // Nick conflict test
477 if (LocalUser.Nick = Nick) and not SameClientId(LocalUser.Id, Id) then begin
478 if LocalUser.NickTime > NickTime then begin
479 // Set nick to Host(Guest) n
480 if Copy(LocalUser.Nick, 1, 4) = 'Host' then begin
481 if TryStrToInt(Copy(LocalUser.Nick, 5, 255), I) then I := I + 1 else I := 1;
482 end else I := 1;
483 LocalUser.Nick := 'Host' + IntToStr(I);
484 AddMessage(aeUserChangeNickConflict, nil, [LocalUser.Nick]);
485 end else SendCommand(scUserInfo);
486 end;
487 UpdateUser(SourceUser);
488 end;
489 end;
490 if (UserListCount <> UserList.Count) and (Command <> scConnect) and
491 (Command <> scUserInfo) then
492 AddMessage(aeUserRestore, nil, [SourceUser.Nick]);
493 if Nick = '' then SendCommand(scWhoIs, '', Id.Machine, Id.User);
494 end;
495 end;
496 end;
497 except
498 end;
499 SourceUser.Free;
500 TargetUSer.Free;
501end;
502
503procedure TSunriseChatCore.SendCommand(Command: TSystemCommand;
504 Text: string = '';
505 DestinationMachineId: Cardinal = 0; DestinationUserId: Cardinal = 0);
506var
507 Data: string;
508
509procedure AddPart(Part: string);
510begin
511 Data := Data + Part + '|';
512end;
513
514begin
515 if LocalUser.Status <> usInvisible then begin
516 //if not NoResloveHostName then
517 Data := '';
518 with LocalUser do begin
519 AddPart(IntToStr(ProtocolVersion)); // Version of protocol
520 AddPart(IntToStr(Int64(Id.Machine))); // Source machine id
521 AddPart(IntToStr(Int64(Id.User))); // Source user id
522 AddPart(IntToStr(Int64(DestinationMachineId))); // Destination machine id
523 AddPart(IntToStr(Int64(DestinationUserId))); // Destination user id
524 Sequence := Sequence + 1;
525 AddPart(IntToStr(Sequence)); // Command sequence number
526 AddPart(IntToStr(Integer(Command))); // Command
527 case Command of
528
529 scMessage: begin
530 AddPart(Text); // Text
531 AddPart(IntToStr(ActiveRoom.Id)); // Room name
532 AddPart(ActiveRoom.Name); // Room name
533 AddPart(IntToStr(Integer(ActiveRoom.Typ))); // Public or private room
534 end;
535
536 scConnect: begin
537 AddPart(Nick);
538 AddPart(DateTimeToStr(NickTime));
539 end;
540
541 scDisconnect: begin
542 end;
543
544 scCallUp: begin
545 end;
546
547 scCallUpResponse: begin
548 end;
549
550 scPing: begin
551 AddPart(TimeToStr(Now)); // Send time
552 end;
553
554 scPingResponse: begin
555 AddPart(Text); // Send time
556 end;
557
558 scAlive: begin
559 AddPart(IntToStr(SecondsIdle));
560 end;
561
562 scWhoIs: begin
563 end;
564
565 scCreateRoom: begin
566 AddPart(IntToStr(Int64(ActiveRoom.Id))); // Room Id
567 AddPart(ActiveRoom.Name); // Room name
568 AddPart(IntToStr(Integer(ActiveRoom.Typ))); // Public or private room
569 end;
570
571 scLeaveRoom: begin
572 AddPart(IntToStr(Int64(Id))); // Room Id
573 AddPart(ActiveRoom.Name); // Room name
574 end;
575
576 scUserInfo: begin
577 AddPart(Nick); // User name
578 AddPart(DateTimeToStr(NickTime)); // User name time
579 AddPart(IntToStr(Color)); // Text color
580 AddPart(Reason); // Away mode reason
581 AddPart(IntToStr(Integer(Status))); // User status
582 AddPart(HostName); // Local host name
583 AddPart(OSVersion); // OS version
584 AddPart(OSUser); // Logged user
585 AddPart(DateTimeToStr(Uptime)); // Application uptime
586 AddPart(Client); // Name of client application
587 AddPart(ClientVersion); // Version of application
588 AddPart(CoreVersion); // SunriseChatCoreVersion
589 AddPart(DateTimeToStr(Now)); // Local system time
590 AddPart(DetailInfo); // Detailed info about user
591 end;
592 end;
593 end;
594 if Assigned(ProtocolMessageLogForm) then
595 ProtocolMessageLogForm.Memo1.Lines.Add('SendCommand: ' + Data);
596 if Assigned(FOnSendCommand) then FOnSendCommand(Data + #13);
597 end;
598end;
599
600procedure TSunriseChatCore.FTimer1Timer(Sender: TObject);
601begin
602 if (FCounter mod AliveCommandSendingPeriod) = 0 then SendCommand(scAlive);
603 DeleteOfflineUsers;
604 if HourOf(Now) <> LastHour then begin
605 LastHour := HourOf(Now);
606 AddMessage(aeShowHours, nil, [HourOf(Now), MinuteOf(Now)]);
607 end;
608 FCounter := FCounter + 1;
609end;
610
611procedure TSunriseChatCore.DeleteOfflineUsers;
612var
613 I: Integer;
614 Changed: Boolean;
615begin
616 I := 0;
617 Changed := False;
618 while (I < UserList.Count) do begin
619 if (Now - TUser(UserList[I]).LastTime) > RemoveTimeout then begin
620 AddMessage(aeUserTimeout, nil, [TUser(UserList[I]).Nick]);
621 TUser(UserList[I]).Free;
622 UserList.Delete(I);
623 Changed := True;
624 end else I := I + 1;
625 end;
626 if Changed and Assigned(FOnUserListUpdate) then FOnUserListUpdate;
627end;
628
629procedure TSunriseChatCore.UpdateUser(User: TUser);
630var
631 I: Integer;
632 NewUser: TUser;
633begin
634 I := 0;
635 while (I < UserList.Count) and not SameClientId(TUser(UserList[I]).Id, User.Id) do
636 I := I + 1;
637 if I = UserList.Count then begin
638 NewUser := TUser.Create(Self);
639 UserList.Add(NewUser);
640 end;
641 User.LastTime := Now;
642 TUser(UserList[I]).Assign(User);
643 if Assigned(FOnUserListUpdate) then FOnUserListUpdate;
644end;
645
646procedure TSunriseChatCore.AddMessage(MessageEventType: TAppEventType;
647 Room: TRoom; const Args: array of const);
648var
649 NewRoomLine: TRoomLine;
650 RoomIndex: Integer;
651 I: Integer;
652 RoomListStartIndex: Integer;
653 RoomListEndIndex: Integer;
654begin
655 //if (StrPas(PChar(Args[0].VString)) <> '') then
656 begin
657 // Create new room line
658 NewRoomLine := TRoomLine.Create;
659 with NewRoomLine do begin
660 if UseDefaultEventsText then try
661 Text := Format(DefaultEventsFormat[Integer(MessageEventType)], Args);
662 except
663 raise Exception.Create('Default event text format error');
664 end else Text := '';
665 Time := Now;
666 if MessageEventType in [aeOneUserMessage, aeCommonMessage] then begin
667 Font.Color := Args[2].VInteger;
668 end;
669 end;
670 NewRoomLine.EventType := MessageEventType;
671
672 if Assigned(OnAddMessage) then OnAddMessage(MessageEventType, Room, Args, NewRoomLine);
673
674 // Select target rooms
675 if not Assigned(Room) then begin // nil = add to all rooms
676 RoomListStartIndex := 0;
677 RoomListEndIndex := RoomList.Count - 1;
678 end else begin
679 RoomListStartIndex := RoomList.IndexOf(Room);
680 RoomListEndIndex := RoomList.IndexOf(Room);
681 end;
682
683 // Add new line
684 for RoomIndex := RoomListStartIndex to RoomListEndIndex do
685 if (RoomIndex < RoomList.Count) and (RoomIndex >= 0) then
686 with TRoom(RoomList[RoomIndex]) do begin
687 Count := Count + 1;
688 if Count > FMaxRoomLines then begin
689 StartLine := (StartLine + 1) mod FMaxRoomLines;
690 Count := FMaxRoomLines;
691 end;
692 I := (StartLine + Count - 1) mod FMaxRoomLines;
693 TRoomLine(Lines[I]).Assign(NewRoomLine);
694 end;
695 NewRoomLine.Free;
696 end;
697end;
698
699procedure TSunriseChatCore.DeleteRoom(RoomIndex: Integer);
700begin
701 TRoom(RoomList[RoomIndex]).Free;
702 RoomList.Delete(RoomIndex);
703 if Assigned(FOnRoomListChanged) then FOnRoomListChanged;
704end;
705
706procedure TSunriseChatCore.SetMaxRoomLines(Number: Integer);
707var
708 I, II: Integer;
709begin
710 FMaxRoomLines := Number;
711 for I := 0 to RoomList.Count-1 do with TRoom(RoomList[I]) do begin
712 for II := 0 to Lines.Count-1 do TRoomLine(Lines[II]).Free;
713 Lines.Count := Number;
714 for II := 0 to Lines.Count-1 do Lines[II] := TRoomLine.Create;
715 end;
716end;
717
718procedure TSunriseChatCore.SetActive(const Value: Boolean);
719begin
720 FTimer1.Enabled := Value;
721 FActive := Value;
722end;
723
724{ TRoom }
725
726constructor TRoom.Create(Parent: TSunriseChatCore);
727var
728 I: Integer;
729begin
730 FParent := Parent;
731 ID := Random(High(Integer));
732 Lines := TList.Create;
733 Lines.Count := FParent.FMaxRoomLines;
734 for I := 0 to Lines.Count-1 do begin
735 Lines[I] := TRoomLine.Create;
736 end;
737 StartLine := 0;
738 Count := 0;
739end;
740
741destructor TRoom.Destroy;
742var
743 I: Integer;
744begin
745 for I := 0 to Lines.Count-1 do TRoomLine(Lines[I]).Free;
746 Lines.Free;
747 inherited;
748end;
749
750procedure TRoom.Remove;
751begin
752 with FParent.RoomList do
753 if Id <> 0 then Delete(IndexOf(Self));
754end;
755
756procedure TRoom.Select;
757begin
758 FParent.ActiveRoom := Self;
759end;
760
761{ TUser }
762
763procedure TUser.Assign(Source: TPersistent);
764begin
765 if Source is TUser then
766 with TUser(Source) do begin
767 Self.FNick := FNick;
768 Self.HostName := HostName;
769 Self.Id := Id;
770 Self.Female := Female;
771 Self.Color := Color;
772 Self.Client := Client;
773 Self.ClientVersion := ClientVersion;
774 Self.CoreVersion := CoreVersion;
775 Self.OSVersion := OSVersion;
776 Self.OSUser := OSUser;
777 Self.Status := Status;
778 Self.LastTime := LastTime;
779 Self.UpTime := UpTime;
780 Self.LocalSystemTime := LocalSystemTime;
781 Self.UserInfoTime := UserInfoTime;
782 Self.NickTime := NickTime;
783 Self.Reason := Reason;
784 Self.Sequence := Sequence;
785 Self.ErrorCount := ErrorCount;
786 Self.BlockMessages := BlockMessages;
787 Self.Delay := Delay;
788 Self.DetailInfo := DetailInfo;
789 Self.IdleTime := IdleTime;
790 end else inherited;
791end;
792
793constructor TUser.Create(Parent: TSunriseChatCore);
794begin
795 FParent := Parent;
796end;
797
798procedure TUser.SetNick(const Value: string);
799begin
800 NickTime := Now;
801 FNick := Value;
802 FParent.SendCommand(scUserInfo);
803end;
804
805{ TRoomLine }
806
807procedure TRoomLine.Assign(Source: TPersistent);
808begin
809 if Source is TRoomLine then
810 with TRoomLine(Source) do begin
811 Self.Text := Text;
812 Self.Font.Assign(Font);
813 Self.Time := Time;
814 Self.EventType := EventType;
815 end else inherited;
816end;
817
818constructor TRoomLine.Create;
819begin
820 Font := TFont.Create;
821end;
822
823destructor TRoomLine.Destroy;
824begin
825 Font.Free;
826 inherited;
827end;
828
829end.
Note: See TracBrowser for help on using the repository browser.