source: trunk/SunriseChatNetworkCoreUnit.pas

Last change on this file was 15, checked in by george, 18 years ago

Přepracováno: Změna síťových komponent z fundamentals sockets na Indy. Prozatím ne dostatečně funkční.
Typografikcé úpravy.
  • Property svn:executable set to *
File size: 14.0 KB
Line 
1unit SunriseChatNetworkCoreUnit;
2
3interface
4
5uses
6 SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
7 Forms, StdCtrls, ExtCtrls, SunriseChatCoreUtils, DateUtils, SunriseChatCoreUnit,
8 cWindows, cSockets, cSocketsUDP, cTCPClient, cTCPServer, cUtils, WinSock,
9 cWinSock, Registry, UEthernetAddress, IdUDPBase, IdUDPServer, IdUDPClient,
10 IdBaseComponent, IdComponent, IdGlobal, IdSocketHandle, IdCustomTCPServer,
11 IdTCPServer, IdTCPConnection, IdTCPClient, IdContext, IdAntiFreeze;
12
13const
14 DefaultUdpPort = 55557;
15 BroadcastIPAddress = '255.255.255.255';
16
17type
18 TBroadcastType = (btLocal, btGlobal);
19
20 TSunriseChatNetworkCore = class;
21
22 TReadingThread = class(TThread)
23 protected
24 FConnection: TIdTCPConnection;
25 FParent: TSunriseChatNetworkCore;
26 procedure Execute; override;
27 public
28 constructor Create(AParent: TSunriseChatNetworkCore; AConnection: TIdTCPConnection); reintroduce;
29 end;
30
31 TNetworkInterface = class
32 private
33 FParent: TSunriseChatNetworkCore;
34 public
35 IPAddress: string;
36 BroadcastIPAddress: string;
37 SubNetMask: string;
38 Name: string;
39 DeviceName: string;
40 GUID: string;
41 procedure Select;
42 constructor Create(Parent: TSunriseChatNetworkCore);
43 end;
44
45 TSunriseChatNetworkCore = class(TSunriseChatCore)
46 private
47 IdTCPServer1: TIdTCPServer;
48 IdTCPClient1: TIdTCPClient;
49 IdUDPServer1: TIdUDPServer;
50 IdUDPClient1: TIdUDPClient;
51 FConnected: Boolean;
52 FOnChangeNetworkState: TClassMethod;
53 FUdpPort: Word;
54 FActive: Boolean;
55 FBroadcastType: TBroadcastType;
56 FActiveNetworkInterface: TNetworkInterface;
57 FAutoReconnect: Boolean;
58 FTimer2: TTimer;
59 FReadingThread: TReadingThread;
60 procedure Timer2Timer(Sender: TObject);
61 function GetLocalIPAddress: string;
62 procedure SetLocalIPAddress(const Value: string);
63 procedure SetActive(const Value: Boolean);
64 procedure StartNetwork;
65 procedure StopNetwork;
66 procedure SendCommandToNetwork(const S: string);
67 procedure IdUDPServer1UDPRead(Sender: TObject; AData: TIdBytes; ABinding: TIdSocketHandle);
68 procedure IdTCPServer1Execute(AContext: TIdContext);
69 procedure IdTCPClient1Connected(Sender: TObject);
70 procedure IdTCPClient1Disconnect(Sender: TObject);
71 procedure SetAutoReconnect(const Value: Boolean);
72 property OnSendCommand;
73 public
74 NetworkInterfaces: TList; // TList<TNetworkInterface>;
75 constructor Create(AOwner: TComponent); override;
76 function IPAddrToStr(Addr: Cardinal): string;
77 function StrToIPAddr(Addr: string): Cardinal;
78 procedure LoadNetworkInterfaceList;
79 procedure SelectNetworkInterfaceByGUID(GUID: string);
80 destructor Destroy; override;
81 property ActiveNetworkInterface: TNetworkInterface read FActiveNetworkInterface;
82 published
83 property AutoReconnect: Boolean read FAutoReconnect write SetAutoReconnect;
84 property BroadcastType: TBroadcastType read FBroadcastType write FBroadCastType;
85 property Active: Boolean read FActive write SetActive;
86 property UdpPort: Word read FUdpPort write FUdpPort;
87 property OnChangeNetworkState: TClassMethod read FOnChangeNetworkState write FOnChangeNetworkState;
88 property Connected: Boolean read FConnected;
89 end;
90
91procedure Register;
92
93implementation
94
95uses
96 IpHlpApi, IpTypes, Dialogs, UProtocolMessageLog, IdIOHandlerSocket;
97
98procedure Register;
99begin
100 RegisterComponents('Chronosoft', [TSunriseChatNetworkCore]);
101end;
102
103{ TReadingThread }
104
105constructor TReadingThread.Create(AParent: TSunriseChatNetworkCore;
106 AConnection: TIdTCPConnection);
107begin
108 FConnection := AConnection;
109 FParent := AParent;
110 inherited Create(False);
111end;
112
113procedure TReadingThread.Execute;
114var
115 Text: string;
116begin
117 try
118 while not Terminated and FConnection.Connected do
119 begin
120 Text := FConnection.IOHandler.Readln;
121 //ProtocolMessageLogForm.Memo1.Lines.Add('TCPClientDataAvailable: ' + Data);
122 FParent.ProcessCommand(Text);
123 end;
124 except
125 end;
126end;
127
128{ TSunriseChatNetworkCore }
129
130constructor TSunriseChatNetworkCore.Create(AOwner: TComponent);
131begin
132 inherited;
133 NetworkInterfaces := TList.Create;
134 IdTCPServer1 := TIdTCPServer.Create(Self);
135 IdTCPServer1.OnExecute := IdTCPServer1Execute;
136 IdTCPClient1 := TIdTCPClient.Create(Self);
137 IdTCPClient1.OnDisconnected := IdTCPClient1Disconnect;
138 IdTCPClient1.OnConnected := IdTCPClient1Connected;
139 IdUDPServer1 := TIdUDPServer.Create(Self);
140 IdUDPServer1.OnUDPRead := IdUDPServer1UDPRead;
141 IdUDPClient1 := TIdUDPClient.Create(Self);
142 FUdpPort := DefaultUdpPort;
143 FActive := False;
144 OnSendCommand := SendCommandToNetwork;
145 LoadNetworkInterfaceList;
146 LocalUser.Id.User := Application.Handle;
147 FAutoReconnect := False;
148end;
149
150destructor TSunriseChatNetworkCore.Destroy;
151var
152 I: Integer;
153begin
154// IdTCPClient1.OnDisconnected := nil;
155 OnChangeNetworkState := nil;
156 Active := False;
157 for I := 0 to NetworkInterfaces.Count - 1 do
158 TNetworkInterface(NetworkInterfaces[I]).Free;
159 NetworkInterfaces.Free;
160 IdTCPServer1.Destroy;
161 IdTCPClient1.Destroy;
162 IdUDPServer1.Destroy;
163 IdUDPClient1.Destroy;
164 inherited;
165end;
166
167procedure TSunriseChatNetworkCore.IdTCPClient1Connected(Sender: TObject);
168begin
169 FReadingThread := TReadingThread.Create(Self, IdTCPClient1);
170 FReadingThread.FreeOnTerminate := True;
171end;
172
173procedure TSunriseChatNetworkCore.IdTCPClient1Disconnect(Sender: TObject);
174begin
175 FConnected := False;
176 if Assigned(FOnChangeNetworkState) then FOnChangeNetworkState;
177 if FActive and FAutoReconnect then begin
178 StopNetwork;
179 StartNetwork;
180 end;
181end;
182
183procedure TSunriseChatNetworkCore.IdTCPServer1Execute(AContext: TIdContext);
184var
185 Text: string;
186begin
187 Text := AContext.Connection.IOHandler.ReadLn;
188 (*
189 if AContext.Connection.Connected then begin
190 Text := ''; // AContext.Connection.IOHandler.AllData;
191 *)
192// ProtocolMessageLogForm.Memo1.Lines.Add('TCPServerDataAvailable: ' + Text);
193 if BroadcastType = btGlobal then
194 IdUDPClient1.Broadcast(Text, UDPPort) else
195 IdUDPClient1.Send(FActiveNetworkInterface.BroadcastIPAddress, UDPPort, Text);
196// end;
197end;
198
199procedure TSunriseChatNetworkCore.IdUDPServer1UDPRead(Sender: TObject; AData: TIdBytes; ABinding: TIdSocketHandle);
200var
201 Text: string;
202 I: Integer;
203 ClientList: TList;
204begin
205 SetLength(Text, Length(AData));
206 for I := 0 to Length(AData) - 1 do
207 Text[I + 1] := Chr(AData[I]);
208 //ProtocolMessageLogForm.Memo1.Lines.Add('UDPServerDataAvailable: ' + Text);
209
210 // Send data to all clients
211 if FConnected then begin
212 ClientList := IdTCPServer1.Contexts.LockList;
213 try
214 for I := 0 to ClientList.Count - 1 do
215 TIdContext(ClientList.Items[I]).Connection.IOHandler.WriteLn(Text);
216 finally
217 IdTCPServer1.Contexts.UnlockList;
218 end;
219 end;
220end;
221
222function TSunriseChatNetworkCore.GetLocalIPAddress: string;
223begin
224 Result := IPAddrToStr(LocalUser.Id.Machine);
225end;
226
227function TSunriseChatNetworkCore.IPAddrToStr(Addr: Cardinal): string;
228var
229 I: Integer;
230begin
231 Result := '';
232 for I := 0 to 3 do Result := IntToStr(Byte(Addr shr (8*I))) + '.' + Result;
233 Delete(Result, Length(Result), 1);
234end;
235
236procedure TSunriseChatNetworkCore.LoadNetworkInterfaceList;
237var
238 I, II: Integer;
239 AdaptersList : array of IP_ADAPTER_INFO;
240 BufSize: Cardinal;
241 IPParts: TArrayOfString;
242 SubnetParts: TArrayOfString;
243 NewNetworkInterface: TNetworkInterface;
244
245function IpListToStr(pIpAddr : PIP_ADDR_STRING) : String;
246begin
247 Result := '';
248 repeat
249 Result := Result + ', ' + Pchar(Addr(pIpAddr^.IpAddress));
250 pIpAddr := pIpAddr.Next;
251 until pIpAddr = nil;
252 Delete(Result, 1, 2);
253 if Result = '' then Result := 'none';
254end;
255
256begin
257 for I := 0 to NetworkInterfaces.Count - 1 do
258 TNetworkInterface(NetworkInterfaces[I]).Free;
259 NetworkInterfaces.Clear;
260
261 if Win32Platform > 1 then begin
262 // Windows NT/2000/XP/Vista
263 BufSize := 0;
264 GetAdaptersInfo(@AdaptersList[0], BufSize);
265 SetLength(AdaptersList, BufSize div SizeOf(IP_ADAPTER_INFO));
266 GetAdaptersInfo(@AdaptersList[0], BufSize);
267 for I := 0 to High(AdaptersList) do with AdaptersList[I] do begin
268 if IpAddressList.IPAddress.S <> '' then begin
269 NewNetworkInterface := TNetworkInterface.Create(Self);
270 with NewNetworkInterface do begin
271 IPAddress := IpAddressList.IPAddress.S;
272 SubNetMask := IpAddressList.IPMask.s;
273 GUID := AdapterName;
274 Name := Description;
275 if Name = '' then Name := 'Network adapter ' + IntToStr(I);
276 SubnetParts := Explode('.', SubNetMask);
277 IPParts := Explode('.', IPAddress);
278 for II := 0 to 3 do
279 IPParts[II] := IntToStr(StrToInt(IPParts[II]) or (StrToInt(SubnetParts[II]) xor $ff));
280 BroadcastIPAddress := IPParts[0]+'.'+IPParts[1]+'.'+IPParts[2]+'.'+IPParts[3];
281 end;
282 NetworkInterfaces.Add(NewNetworkInterface);
283 end;
284 end;
285 end else begin
286 // Windows 95/98/Me
287 for I := 0 to High(LocalIPAddressesStr) do begin
288 NewNetworkInterface := TNetworkInterface.Create(Self);
289 with NewNetworkInterface do begin
290 IPAddress := LocalIPAddressesStr[I];
291 Name := LocalIPAddressesStr[I];
292 GUID := LocalIPAddressesStr[I];
293 end;
294 NetworkInterfaces.Add(NewNetworkInterface);
295 end;
296 end;
297 if NetworkInterfaces.Count > 1 then
298 TNetworkInterface(NetworkInterfaces[1]).Select
299 else TNetworkInterface(NetworkInterfaces[0]).Select;
300end;
301
302procedure TSunriseChatNetworkCore.SelectNetworkInterfaceByGUID(
303 GUID: string);
304var
305 I: Integer;
306begin
307 I := 0;
308 while (I < NetworkInterfaces.Count) and (TNetworkInterface(NetworkInterfaces[I]).GUID <> GUID) do
309 I := I + 1;
310 if I >= NetworkInterfaces.Count then I := 0;
311 TNetworkInterface(NetworkInterfaces[I]).Select;
312end;
313
314procedure TSunriseChatNetworkCore.SendCommandToNetwork(const S: string);
315begin
316 if FConnected then IdTCPClient1.IOHandler.WriteLn(S);
317end;
318
319procedure TSunriseChatNetworkCore.SetActive(const Value: Boolean);
320begin
321 if (not FActive) and Value then begin
322 StartNetwork;
323 end;
324 if (FActive) and (not Value) then StopNetwork;
325 FActive := Value;
326 inherited SetActive(Value);
327end;
328
329procedure TSunriseChatNetworkCore.SetAutoReconnect(const Value: Boolean);
330begin
331 FAutoReconnect := Value;
332
333end;
334
335procedure TSunriseChatNetworkCore.SetLocalIPAddress(const Value: string);
336begin
337 LocalUser.Id.Machine := StrToIPAddr(Value);
338end;
339
340procedure TSunriseChatNetworkCore.StartNetwork;
341var
342 I, II: Integer;
343 SocketBinding: TIdSocketHandle;
344const
345 Stav: array [0..6] of string = ('Closed', 'Resolving', 'Resolved', 'Connecting',
346 'Negotiating', 'Connected', 'Listening');
347begin
348 IdTCPClient1.OnDisconnected := nil;
349 FConnected := False;
350 try
351 IdTCPClient1.Disconnect;
352 with IdTCPServer1 do begin
353 Active := False;
354 SocketBinding := IdTCPServer1.Bindings.Add;
355 SocketBinding.IP := IPAddrToStr(LocalUser.Id.Machine);
356 SocketBinding.Port := UDPPort + 1;
357 try
358 Active := True;
359 except
360 end;
361 // ShowMessage(Stav[Integer(fndTCPServer1.Socket.State)]);
362 end;
363 IdUDPServer1.Active := False;
364 SocketBinding := IdUDPServer1.Bindings.Add;
365 SocketBinding.IP := IPAddrToStr(LocalUser.Id.Machine);
366 SocketBinding.Port := UDPPort;
367 IdUDPServer1.BroadcastEnabled := True;
368 try
369 IdUDPServer1.Active := True;
370 except
371 end;
372 IdUDPClient1.Disconnect;
373 IdUDPClient1.Host := FActiveNetworkInterface.BroadcastIPAddress;
374 IdUDPClient1.Port := UdpPort;
375 IdUDPClient1.BroadcastEnabled := True;
376 try
377 IdUDPClient1.Connect;
378 except
379 end;
380 with IdTCPClient1 do begin
381 Disconnect;
382 Host := IPAddrToStr(LocalUser.Id.Machine); // 'localhost';
383 Port := UDPPort + 1;
384 BoundIP := IPAddrToStr(LocalUser.Id.Machine); //'localhost';
385 Connect;
386(*
387 I := 2;
388 repeat
389 Disconnect;
390 //BoundPort := UDPPort + I;
391 I := I + 1;
392 try
393 Connect;
394 except
395 end;
396 II := 0;
397 while (not Connected and (II < 100)) do begin
398 Application.ProcessMessages;
399 Sleep(10);
400 II := II + 1;
401 end;
402 // ShowMessage(Stav[Integer(fndTCPClient1.Socket.State)]);
403 until (Connected) or (I > 30); //or (fndTCPServer1.Socket.State = ssClosed);
404*)
405 FConnected := IdUDPServer1.Active and IdUDPClient1.Active and
406 IdTCPServer1.Active and IdTCPClient1.Connected;
407 //ShowMessage(IntToStr(Integer(fndTCPClient1.Socket.State))+','+BoolToStr(fndUDPClientSocket1.Bound)
408 //+','+BoolToStr(FConnected)+','+BoolToStr(fndTCPClient1.Socket.Connected));
409 if FConnected then begin
410 SendCommand(scUserInfo);
411 SendCommand(scConnect);
412 end;
413 if Assigned(FOnChangeNetworkState) then OnChangeNetworkState;
414 end;
415 finally
416 IdTCPClient1.OnDisconnected := IdTCPClient1Disconnect;
417 end;
418end;
419
420procedure TSunriseChatNetworkCore.StopNetwork;
421begin
422 FAutoReconnect := False;
423 if IdTCPClient1.Connected then IdTCPClient1.Disconnect;
424 IdTCPServer1.Active := False;
425 IdUDPClient1.Active := False;
426 IdUDPServer1.Active := False;
427end;
428
429function TSunriseChatNetworkCore.StrToIPAddr(Addr: string): Cardinal;
430var
431 Parts: TArrayOfString;
432 I: Integer;
433begin
434 Result := 0;
435 Parts := Explode('.', Addr);
436 for I := 0 to 3 do Result := Result or (Byte(StrToInt(Parts[I])) shl (24-8*I));
437end;
438
439procedure TSunriseChatNetworkCore.Timer2Timer(Sender: TObject);
440begin
441 if not FConnected then StartNetwork;
442end;
443
444{ TNetworkInterface }
445
446constructor TNetworkInterface.Create(Parent: TSunriseChatNetworkCore);
447begin
448 FParent := Parent;
449end;
450
451procedure TNetworkInterface.Select;
452begin
453 FParent.FActiveNetworkInterface := Self;
454 FParent.LocalUser.Id.Machine := FPArent.StrToIPAddr(IPAddress);
455 if FParent.FActive then begin
456 FParent.Active := False;
457 FParent.Active := True;
458 end;
459end;
460
461end.
Note: See TracBrowser for help on using the repository browser.