1{ lNet v0.6.2
2
3  CopyRight (C) 2004-2008 Ales Katona
4
5  This library is Free software; you can rediStribute it and/or modify it
6  under the terms of the GNU Library General Public License as published by
7  the Free Software Foundation; either version 2 of the License, or (at your
8  option) any later version.
9
10  This program is diStributed in the hope that it will be useful, but WITHOUT
11  ANY WARRANTY; withOut even the implied warranty of MERCHANTABILITY or
12  FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
13  for more details.
14
15  You should have received a Copy of the GNU Library General Public License
16  along with This library; if not, Write to the Free Software Foundation,
17  Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
18
19  This license has been modified. See File LICENSE.ADDON for more inFormation.
20  Should you find these sources without a LICENSE File, please contact
21  me at ales@chello.sk
22}
23
24unit lNet;
25
26{$mode objfpc}{$H+}{$T-}
27{$interfaces corba}
28
29interface
30
31uses
32  Classes, lEvents, lCommon,
33  {$i sys/osunits.inc}
34
35const
36  { API compatibility, these had to be moved to prevent circular unit usage and a
37    fpc bug with inline }
38  LADDR_ANY   = lCommon.LADDR_ANY;
39  LADDR_BR    = lCommon.LADDR_BR;
40  LADDR_LO    = lCommon.LADDR_LO;
41  LADDR6_ANY  = lCommon.LADDR6_ANY;
42  LADDR6_LO   = lCommon.LADDR6_LO;
43
44type
45  TLSocket = class;
46  TLComponent = class;
47  TLConnection = class;
48  TLSession = class;
49
50  { Callback Event procedure for errors }
51  TLSocketErrorEvent = procedure(const msg: string; aSocket: TLSocket) of object;
52
53  { Callback Event procedure for others }
54  TLSocketEvent = procedure(aSocket: TLSocket) of object;
55
56  { Callback Event procedure for progress reports}
57  TLSocketProgressEvent = procedure (aSocket: TLSocket; const Bytes: Integer) of object;
58
59  { TLSocketState }
60  TLSocketState = (ssServerSocket, ssBlocking, ssReuseAddress, ssCanSend,
61                   ssCanReceive, ssSSLActive{, ssNoDelay});
62
63  { TLSocketStates }
64  TLSocketStates = set of TLSocketState;
65
66  { TLSocketConnection }
67  TLSocketConnectionStatus = (scNone, scConnecting, scConnected, scDisconnecting);
68
69  { TLSocketOperation }
70  TLSocketOperation = (soSend, soReceive);
71
72  { TLSocket }
73
74  TLSocket = class(TLHandle)
75   protected
76    FAddress: TLSocketAddress;
77    FPeerAddress: TLSocketAddress;
78    FReuseAddress: Boolean;
79    FConnectionStatus: TLSocketConnectionStatus;
80    FNextSock: TLSocket;
81    FPrevSock: TLSocket;
82    FSocketState: TLSocketStates;
83    FOnFree: TLSocketEvent;
84    FBlocking: Boolean;
85    FListenBacklog: Integer;
86    FProtocol: Integer;
87    FSocketType: Integer;
88    FSocketNet: Integer;
89    FCreator: TLComponent;
90    FSession: TLSession;
91    FConnection: TLConnection;
92    FMSGBufferSize: integer;
93   protected
94    function GetConnected: Boolean; virtual; deprecated;
95    function GetConnecting: Boolean; virtual; deprecated;
96    function GetConnectionStatus: TLSocketConnectionStatus; virtual;
97    function GetIPAddressPointer: psockaddr;
98    function GetIPAddressLength: TSocklen;
99
100    function SetupSocket(const APort: Word; const Address: string): Boolean; virtual;
101
102    function DoSend(const aData; const aSize: Integer): Integer; virtual;
103    function DoGet(out aData; const aSize: Integer): Integer; virtual;
104
105    function HandleResult(const aResult: Integer; aOp: TLSocketOperation): Integer; virtual;
106
107    function GetLocalPort: Word;
108    function GetPeerPort: Word;
109    function GetPeerAddress: string;
110    function GetLocalAddress: string;
111    function SendPossible: Boolean; inline;
112    function ReceivePossible: Boolean; inline;
113
114    procedure SetOptions; virtual;
115    procedure SetBlocking(const aValue: Boolean);
116    procedure SetReuseAddress(const aValue: Boolean);
117//    procedure SetNoDelay(const aValue: Boolean);
118
119    procedure HardDisconnect(const NoShutdown: Boolean = False);
120    procedure SoftDisconnect;
121
122    function Bail(const msg: string; const ernum: Integer): Boolean;
123
124    function LogError(const msg: string; const ernum: Integer): Boolean; virtual;
125
126    property SocketType: Integer read FSocketType write FSocketType; // inherit and publicize if you need to set this outside
127   public
128    constructor Create; override;
129    destructor Destroy; override;
130
131    function SetState(const aState: TLSocketState; const TurnOn: Boolean = True): Boolean; virtual;
132
133    function Listen(const APort: Word; const AIntf: string = LADDR_ANY): Boolean;
134    function Accept(const SerSock: TSocket): Boolean;
135    function Connect(const Address: string; const APort: Word): Boolean;
136
137    function Send(const aData; const aSize: Integer): Integer; virtual;
138    function SendMessage(const msg: string): Integer;
139
140    function Get(out aData; const aSize: Integer): Integer; virtual;
141    function GetMessage(out msg: string): Integer;
142
143    procedure Disconnect(const Forced: Boolean = True); virtual;
144   public
145    property Connected: Boolean read GetConnected; deprecated;
146    property Connecting: Boolean read GetConnecting; deprecated;
147    property ConnectionStatus: TLSocketConnectionStatus read GetConnectionStatus;
148    property ListenBacklog: Integer read FListenBacklog write FListenBacklog;
149    property Protocol: Integer read FProtocol write FProtocol;
150    property SocketNet: Integer read FSocketNet write FSocketNet;
151    property PeerAddress: string read GetPeerAddress;
152    property PeerPort: Word read GetPeerPort;
153    property LocalAddress: string read GetLocalAddress;
154    property LocalPort: Word read GetLocalPort;
155    property NextSock: TLSocket read FNextSock write FNextSock;
156    property PrevSock: TLSocket read FPrevSock write FPrevSock;
157    property SocketState: TLSocketStates read FSocketState;
158    property Creator: TLComponent read FCreator;
159    property Session: TLSession read FSession;
160    Property MsgBufferSize: Integer Read FMsgBufferSize Write FMsgBufferSize;
161  end;
162  TLSocketClass = class of TLSocket;
163
164  { this is the socket used by TLConnection }
165
166  TLActionEnum = (acConnect, acAccept, acSend, acReceive, acError);
167
168  { Base interface common to ALL connections }
169
170  ILComponent = interface
171    procedure Disconnect(const Forced: Boolean = True);
172    procedure CallAction;
173
174    property SocketClass: TLSocketClass;
175    property Host: string;
176    property Port: Word;
177  end;
178
179  { Interface for protools with direct send/get capabilities }
180
181  ILDirect = interface
182    function Get(out aData; const aSize: Integer; aSocket: TLSocket = nil): Integer;
183    function GetMessage(out msg: string; aSocket: TLSocket = nil): Integer;
184
185    function Send(const aData; const aSize: Integer; aSocket: TLSocket = nil): Integer;
186    function SendMessage(const msg: string; aSocket: TLSocket = nil): Integer;
187  end;
188
189  { Interface for all servers }
190
191  ILServer = interface
192    function Listen(const APort: Word; const AIntf: string = LADDR_ANY): Boolean;
193  end;
194
195  { Interface for all clients }
196
197  ILClient = interface
198    function Connect(const Address: string; const APort: Word): Boolean; overload;
199    function Connect: Boolean; overload;
200  end;
201
202  { TLComponent }
203
204  TLComponent = class(TComponent, ILComponent)
205   protected
206    FHost: string;
207    FPort: Word;
208    FCreator: TLComponent;
209    FActive: Boolean;
210    procedure SetCreator(AValue: TLComponent); virtual;
211   public
212    constructor Create(aOwner: TComponent); override;
213    procedure Disconnect(const Forced: Boolean = True); virtual; abstract;
214    procedure CallAction; virtual; abstract;
215   public
216    SocketClass: TLSocketClass;
217    property Host: string read FHost write FHost;
218    property Port: Word read FPort write FPort;
219    property Creator: TLComponent read FCreator write SetCreator;
220    property Active: Boolean read FActive;
221  end;
222
223  { TLConnection
224    Common ancestor for TLTcp and TLUdp classes. Holds Event properties
225    and common variables. }
226
227  TLConnection = class(TLComponent, ILDirect, ILServer, ILClient)
228   protected
229    FTimeVal: TTimeVal;
230    FOnReceive: TLSocketEvent;
231    FOnAccept: TLSocketEvent;
232    FOnConnect: TLSocketEvent;
233    FOnDisconnect: TLSocketEvent;
234    FOnCanSend: TLSocketEvent;
235    FOnError: TLSocketErrorEvent;
236    FRootSock: TLSocket;
237    FIterator: TLSocket;
238    FID: Integer; // internal number for server
239    FEventer: TLEventer;
240    FEventerClass: TLEventerClass;
241    FTimeout: Integer;
242    FListenBacklog: Integer;
243    FSession: TLSession;
244   protected
245    function InitSocket(aSocket: TLSocket): TLSocket; virtual;
246
247    function GetConnected: Boolean; virtual; abstract;
248    function GetCount: Integer; virtual;
249    function GetItem(const i: Integer): TLSocket;
250
251    function GetTimeout: Integer;
252    procedure SetTimeout(const AValue: Integer);
253
254    procedure SetEventer(Value: TLEventer);
255    procedure SetSession(aSession: TLSession);
256    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
257
258    procedure ConnectAction(aSocket: TLHandle); virtual;
259    procedure AcceptAction(aSocket: TLHandle); virtual;
260    procedure ReceiveAction(aSocket: TLHandle); virtual;
261    procedure SendAction(aSocket: TLHandle); virtual;
262    procedure ErrorAction(aSocket: TLHandle; const msg: string); virtual;
263
264    procedure ConnectEvent(aSocket: TLHandle); virtual;
265    procedure DisconnectEvent(aSocket: TLHandle); virtual;
266    procedure AcceptEvent(aSocket: TLHandle); virtual;
267    procedure ReceiveEvent(aSocket: TLHandle); virtual;
268    procedure CanSendEvent(aSocket: TLHandle); virtual;
269    procedure ErrorEvent(aSocket: TLHandle; const msg: string); virtual;
270    procedure EventerError(const msg: string; Sender: TLEventer);
271
272    procedure RegisterWithEventer; virtual;
273
274    procedure FreeSocks(const Forced: Boolean); virtual;
275   public
276    constructor Create(aOwner: TComponent); override;
277    destructor Destroy; override;
278
279    function Connect(const Address: string; const APort: Word): Boolean; virtual; overload;
280    function Connect: Boolean; virtual; overload;
281
282    function Listen(const APort: Word; const AIntf: string = LADDR_ANY): Boolean; virtual; abstract; overload;
283    function Listen: Boolean; virtual; overload;
284
285    function Get(out aData; const aSize: Integer; aSocket: TLSocket = nil): Integer; virtual; abstract;
286    function GetMessage(out msg: string; aSocket: TLSocket = nil): Integer; virtual; abstract;
287
288    function Send(const aData; const aSize: Integer; aSocket: TLSocket = nil): Integer; virtual; abstract;
289    function SendMessage(const msg: string; aSocket: TLSocket = nil): Integer; virtual; abstract;
290
291    function IterNext: Boolean; virtual; abstract;
292    procedure IterReset; virtual; abstract;
293   public
294    property OnError: TLSocketErrorEvent read FOnError write FOnError;
295    property OnReceive: TLSocketEvent read FOnReceive write FOnReceive;
296    property OnDisconnect: TLSocketEvent read FOnDisconnect write FOnDisconnect;
297    property OnCanSend: TLSocketEvent read FOnCanSend write FOnCanSend;
298    property Socks[index: Integer]: TLSocket read GetItem; default;
299    property Count: Integer read GetCount;
300    property Connected: Boolean read GetConnected;
301    property ListenBacklog: Integer read FListenBacklog write FListenBacklog;
302    property Iterator: TLSocket read FIterator;
303    property Timeout: Integer read GetTimeout write SetTimeout;
304    property Eventer: TLEventer read FEventer write SetEventer;
305    property EventerClass: TLEventerClass read FEventerClass write FEventerClass;
306    property Session: TLSession read FSession write SetSession;
307  end;
308
309  { TLUdp }
310
311  TLUdp = class(TLConnection)
312   protected
313    function InitSocket(aSocket: TLSocket): TLSocket; override;
314
315    function GetConnected: Boolean; override;
316
317    procedure ReceiveAction(aSocket: TLHandle); override;
318    procedure ErrorAction(aSocket: TLHandle; const msg: string); override;
319
320    function Bail(const msg: string): Boolean;
321
322    procedure SetAddress(const Address: string);
323   public
324    constructor Create(aOwner: TComponent); override;
325
326    function Connect(const Address: string; const APort: Word): Boolean; override;
327    function Listen(const APort: Word; const AIntf: string = LADDR_ANY): Boolean; override;
328
329    function Get(out aData; const aSize: Integer; aSocket: TLSocket = nil): Integer; override;
330    function GetMessage(out msg: string; aSocket: TLSocket = nil): Integer; override;
331
332    function SendMessage(const msg: string; aSocket: TLSocket = nil): Integer; override;
333    function SendMessage(const msg: string; const Address: string): Integer; overload;
334
335    function Send(const aData; const aSize: Integer; aSocket: TLSocket = nil): Integer; override;
336    function Send(const aData; const aSize: Integer; const Address: string): Integer; overload;
337
338    function IterNext: Boolean; override;
339    procedure IterReset; override;
340
341    procedure Disconnect(const Forced: Boolean = True); override;
342
343    procedure CallAction; override;
344  end;
345
346  { TLTcp }
347
348  TLTcp = class(TLConnection)
349   protected
350    FSocketNet: Integer;
351    FCount: Integer;
352    FReuseAddress: Boolean;
353    FMsgBufferSize: integer;
354    function InitSocket(aSocket: TLSocket): TLSocket; override;
355
356    function GetConnected: Boolean; override;
357    function GetConnecting: Boolean;
358    function GetCount: Integer; override;
359    function GetValidSocket: TLSocket;
360
361    procedure SetReuseAddress(const aValue: Boolean);
362    procedure SetSocketNet(const aValue: Integer);
363
364    procedure ConnectAction(aSocket: TLHandle); override;
365    procedure AcceptAction(aSocket: TLHandle); override;
366    procedure ReceiveAction(aSocket: TLHandle); override;
367    procedure SendAction(aSocket: TLHandle); override;
368    procedure ErrorAction(aSocket: TLHandle; const msg: string); override;
369
370    function Bail(const msg: string; aSocket: TLSocket): Boolean;
371
372    procedure SocketDisconnect(aSocket: TLSocket);
373   public
374    constructor Create(aOwner: TComponent); override;
375
376    function Connect(const Address: string; const APort: Word): Boolean; override;
377    function Listen(const APort: Word; const AIntf: string = LADDR_ANY): Boolean; override;
378
379    function Get(out aData; const aSize: Integer; aSocket: TLSocket = nil): Integer; override;
380    function GetMessage(out msg: string; aSocket: TLSocket = nil): Integer; override;
381
382    function Send(const aData; const aSize: Integer; aSocket: TLSocket = nil): Integer; override;
383    function SendMessage(const msg: string; aSocket: TLSocket = nil): Integer; override;
384
385    function IterNext: Boolean; override;
386    procedure IterReset; override;
387
388    procedure CallAction; override;
389
390    procedure Disconnect(const Forced: Boolean = True); override;
391   public
392    property Connecting: Boolean read GetConnecting;
393    property OnAccept: TLSocketEvent read FOnAccept write FOnAccept;
394    property OnConnect: TLSocketEvent read FOnConnect write FOnConnect;
395    property ReuseAddress: Boolean read FReuseAddress write SetReuseAddress;
396    property SocketNet: Integer read FSocketNet write SetSocketNet;
397    property MsgBufferSize: integer read FMsgBufferSize write FMsgBufferSize;
398  end;
399
400  { TLSession }
401
402  TLSession = class(TComponent)
403   protected
404    FActive: Boolean;
405   public
406    procedure RegisterWithComponent(aConnection: TLConnection); virtual;
407
408    procedure InitHandle(aHandle: TLHandle); virtual;
409
410    procedure ReceiveEvent(aHandle: TLHandle); virtual;
411    procedure SendEvent(aHandle: TLHandle); virtual;
412    procedure ErrorEvent(aHandle: TLHandle; const msg: string); virtual;
413    procedure ConnectEvent(aHandle: TLHandle); virtual;
414    procedure AcceptEvent(aHandle: TLHandle); virtual;
415    procedure DisconnectEvent(aHandle: TLHandle); virtual;
416
417    procedure CallReceiveEvent(aHandle: TLHandle); inline;
418    procedure CallSendEvent(aHandle: TLHandle); inline;
419    procedure CallErrorEvent(aHandle: TLHandle; const msg: string); inline;
420    procedure CallConnectEvent(aHandle: TLHandle); inline;
421    procedure CallAcceptEvent(aHandle: TLHandle); inline;
422    procedure CallDisconnectEvent(aHandle: TLHandle); inline;
423   public
424    property Active: Boolean read FActive;
425  end;
426
427implementation
428
429//********************************TLSocket*************************************
430
431constructor TLSocket.Create;
432begin
433  inherited Create;
434  FHandle := INVALID_SOCKET;
435  FListenBacklog := LDEFAULT_BACKLOG;
436  FPrevSock := nil;
437  FNextSock := nil;
438  FSocketState := [ssCanSend];
439  FConnectionStatus := scNone;
440  FSocketType := SOCK_STREAM;
441  FSocketNet := LAF_INET;
442  FProtocol := LPROTO_TCP;
443  FMSGBufferSize := 0;
444end;
445
446destructor TLSocket.Destroy;
447begin
448  if Assigned(FOnFree) then
449    FOnFree(Self);
450
451  inherited Destroy; // important! must be called before disconnect
452  Disconnect(True);
453end;
454
455function TLSocket.SetState(const aState: TLSocketState; const TurnOn: Boolean = True): Boolean;
456begin
457  Result := False;
458
459  case aState of
460    ssServerSocket      : if TurnOn then
461                            FSocketState := FSocketState + [aState]
462                          else
463                            raise Exception.Create('Can not turn off server socket feature');
464
465    ssBlocking          : SetBlocking(TurnOn);
466    ssReuseAddress      : SetReuseAddress(TurnOn);
467
468    ssCanSend,
469    ssCanReceive        : if TurnOn then
470                            FSocketState := FSocketState + [aState]
471                          else
472                            FSocketState := FSocketState - [aState];
473
474    ssSSLActive         : raise Exception.Create('Can not turn SSL/TLS on in TLSocket instance');
475{    ssNoDelay           : SetNoDelay(TurnOn);}
476  end;
477
478  Result := True;
479end;
480
481procedure TLSocket.Disconnect(const Forced: Boolean = True);
482begin
483  if Forced then
484    HardDisconnect
485  else
486    SoftDisconnect;
487end;
488
489function TLSocket.LogError(const msg: string; const ernum: Integer): Boolean;
490begin
491  Result := False;
492  if Assigned(FOnError) then
493    if ernum > 0 then
494      FOnError(Self, msg + LStrError(ernum))
495    else
496      FOnError(Self, msg);
497end;
498
499function TLSocket.Bail(const msg: string; const ernum: Integer): Boolean;
500begin
501  Result := False; // return the result for the caller
502  if FDispose then // why?
503    Exit;
504  Disconnect(True);
505  LogError(msg, ernum);
506end;
507
508function TLSocket.GetPeerAddress: string;
509begin
510  Result := '';
511  if FSocketType = SOCK_STREAM then
512    Result := NetAddrtoStr(FAddress.IPv4.sin_addr)
513  else
514    Result := NetAddrtoStr(FPeerAddress.IPv4.sin_addr);
515end;
516
517function TLSocket.GetLocalAddress: string;
518var
519  a: TSockAddr;
520  l: Integer;
521begin
522  Result := '';
523  l := SizeOf(a);
524  if fpGetSockName(FHandle, @a, @l) = 0 then
525    Result := NetAddrToStr(a.sin_addr);
526end;
527
528function TLSocket.SendPossible: Boolean; inline;
529begin
530  Result := True;
531  if FConnectionStatus <> scConnected then
532    Exit(LogError('Can''t send when not connected', -1));
533
534  if not (ssCanSend in FSocketState) then begin
535    if not Assigned(FConnection)
536    or not Assigned(FConnection.FOnCanSend) then
537      LogError('Send buffer full, try again later', -1);
538    Exit(False);
539  end;
540
541  if ssServerSocket in FSocketState then
542    Exit(LogError('Can''t send on server socket', -1));
543end;
544
545function TLSocket.ReceivePossible: Boolean; inline;
546begin
547  Result := (FConnectionStatus in [scConnected, scDisconnecting])
548    and (ssCanReceive in FSocketState) and not (ssServerSocket in FSocketState);
549end;
550
551procedure TLSocket.SetOptions;
552begin
553  SetBlocking(FBlocking);
554end;
555
556procedure TLSocket.SetBlocking(const aValue: Boolean);
557begin
558  if FHandle >= 0 then // we already set our socket
559    if not lCommon.SetBlocking(FHandle, aValue) then
560      Bail('Error on SetBlocking', LSocketError)
561    else begin
562      FBlocking := aValue;
563      if aValue then
564        FSocketState := FSocketState + [ssBlocking]
565      else
566        FSocketState := FSocketState - [ssBlocking];
567    end;
568end;
569
570procedure TLSocket.SetReuseAddress(const aValue: Boolean);
571begin
572  if FConnectionStatus = scNone then begin
573    FReuseAddress := aValue;
574    if aValue then
575      FSocketState := FSocketState + [ssReuseAddress]
576    else
577      FSocketState := FSocketState - [ssReuseAddress];
578  end;
579end;
580
581procedure TLSocket.HardDisconnect(const NoShutdown: Boolean = False);
582var
583  NeedsShutdown: Boolean;
584begin
585  NeedsShutdown := (FConnectionStatus = scConnected) and (FSocketType = SOCK_STREAM)
586               and (not (ssServerSocket in FSocketState));
587  if NoShutdown then
588    NeedsShutdown := False;
589
590  FDispose := True;
591  FSocketState := FSocketState + [ssCanSend, ssCanReceive];
592  FIgnoreWrite := True;
593  if FConnectionStatus in [scConnected, scConnecting] then begin
594    FConnectionStatus := scNone;
595    if NeedsShutdown then
596      if fpShutDown(FHandle, SHUT_RDWR) <> 0 then
597        LogError('Shutdown error', LSocketError);
598
599    if Assigned(FEventer) then
600      FEventer.UnregisterHandle(Self);
601
602    if CloseSocket(FHandle) <> 0 then
603      LogError('Closesocket error', LSocketError);
604    FHandle := INVALID_SOCKET;
605  end;
606end;
607
608procedure TLSocket.SoftDisconnect;
609begin
610  if FConnectionStatus in [scConnected, scConnecting] then begin
611    if  (FConnectionStatus = scConnected) and (not (ssServerSocket in FSocketState))
612    and (FSocketType = SOCK_STREAM) then begin
613      FConnectionStatus := scDisconnecting;
614      if fpShutDown(FHandle, SHUT_WR) <> 0 then
615        LogError('Shutdown error', LSocketError);
616    end else
617      HardDisconnect; // UDP or ServerSocket
618  end;
619end;
620
621{procedure TLSocket.SetNoDelay(const aValue: Boolean);
622begin
623  if FHandle >= 0 then // we already set our socket
624    if not lCommon.SetNoDelay(FHandle, aValue) then
625      Bail('Error on SetNoDelay', LSocketError)
626    else begin
627      if aValue then
628        FSocketState := FSocketState + [ssNoDelay]
629      else
630        FSocketState := FSocketState - [ssNoDelay];
631    end;
632end;}
633
634function TLSocket.GetMessage(out msg: string): Integer;
635begin
636  Result := 0;
637  SetLength(msg, BUFFER_SIZE);
638  SetLength(msg, Get(PChar(msg)^, Length(msg)));
639  Result := Length(msg);
640end;
641
642function TLSocket.Get(out aData; const aSize: Integer): Integer;
643begin
644  Result := 0;
645
646  if aSize = 0 then
647    raise Exception.Create('Invalid buffer size 0 in Get');
648
649  if ReceivePossible then begin
650    Result := DoGet(aData, aSize);
651
652    if Result = 0 then
653    begin
654      FConnectionStatus := scNone;
655      if FSocketType = SOCK_STREAM then
656        Disconnect(True)
657      else begin
658        Bail('Receive Error [0 on recvfrom with UDP]', 0);
659        Exit(0);
660      end;
661    end;
662
663    Result := HandleResult(Result, soReceive);
664  end;
665end;
666
667function TLSocket.GetConnected: Boolean;
668begin
669  Result := (FConnectionStatus = scConnected);
670end;
671
672function TLSocket.GetConnecting: Boolean;
673begin
674  Result := FConnectionStatus = scConnecting;
675end;
676
677function TLSocket.GetConnectionStatus: TLSocketConnectionStatus;
678begin
679  Result := FConnectionStatus;
680end;
681
682function TLSocket.GetIPAddressPointer: psockaddr;
683begin
684  case FSocketNet of
685    LAF_INET  : Result := psockaddr(@FAddress.IPv4);
686    LAF_INET6 : Result := psockaddr(@FAddress.IPv6);
687  else
688    raise Exception.Create('Unknown socket network type (not IPv4 or IPv6)');
689  end;
690end;
691
692function TLSocket.GetIPAddressLength: TSocklen;
693begin
694  case FSocketNet of
695    LAF_INET  : Result := SizeOf(FAddress.IPv4);
696    LAF_INET6 : Result := SizeOf(FAddress.IPv6);
697  else
698    raise Exception.Create('Unknown socket network type (not IPv4 or IPv6)');
699  end;
700end;
701
702function TLSocket.SetupSocket(const APort: Word; const Address: string): Boolean;
703var
704  Done: Boolean;
705  Arg, Opt: Integer;
706begin
707  Result := false;
708  if FConnectionStatus = scNone then begin
709    Done := true;
710    FHandle := fpSocket(FSocketNet, FSocketType, FProtocol);
711    if FHandle = INVALID_SOCKET then
712      Exit(Bail('Socket error', LSocketError));
713    SetOptions;
714
715    Arg := 1;
716    if FSocketType = SOCK_DGRAM then begin
717      if fpsetsockopt(FHandle, SOL_SOCKET, SO_BROADCAST, @Arg, Sizeof(Arg)) = SOCKET_ERROR then
718        Exit(Bail('SetSockOpt error', LSocketError));
719    end else if FReuseAddress then begin
720      Opt := SO_REUSEADDR;
721      {$ifdef WIN32} // I expect 64 has it oddly, so screw them for now
722      if (Win32Platform = 2) and (Win32MajorVersion >= 5) then
723        Opt := Integer(not Opt);
724      {$endif}
725      if fpsetsockopt(FHandle, SOL_SOCKET, Opt, @Arg, Sizeof(Arg)) = SOCKET_ERROR then
726        Exit(Bail('SetSockOpt error setting reuseaddr', LSocketError));
727    end;
728
729    {$ifdef darwin}
730    Arg := 1;
731    if fpsetsockopt(FHandle, SOL_SOCKET, SO_NOSIGPIPE, @Arg, Sizeof(Arg)) = SOCKET_ERROR then
732      Exit(Bail('SetSockOpt error setting nosigpipe', LSocketError));
733    {$endif}
734
735    FillAddressInfo(FAddress, FSocketNet, Address, aPort);
736    FillAddressInfo(FPeerAddress, FSocketNet, LADDR_BR, aPort);
737    if FMSGBufferSize>0 then
738      begin
739      if fpsetsockopt(Handle, SOL_SOCKET, SO_RCVBUF, @FMSGBufferSize, Sizeof(integer))
740        = SOCKET_ERROR then
741        Exit(Bail('SetSockOpt error setting rcv buffer size', LSocketError));
742      if fpsetsockopt(Handle, SOL_SOCKET, SO_SNDBUF, @FMSGBufferSize, Sizeof(integer))
743        = SOCKET_ERROR then
744        Exit(Bail('SetSockOpt error setting snd buffer size', LSocketError));
745      end;
746    Result  :=  Done;
747  end;
748end;
749
750function TLSocket.DoSend(const aData; const aSize: Integer): Integer;
751var
752  AddressLength: Longint = SizeOf(FPeerAddress);
753begin
754  if FSocketType = SOCK_STREAM then
755    Result := Sockets.fpSend(FHandle, @aData, aSize, LMSG)
756  else
757    Result := sockets.fpsendto(FHandle, @aData, aSize, LMSG, @FPeerAddress, AddressLength);
758end;
759
760function TLSocket.DoGet(out aData; const aSize: Integer): Integer;
761var
762  AddressLength: Longint = SizeOf(FPeerAddress);
763begin
764  if FSocketType = SOCK_STREAM then
765    Result := sockets.fpRecv(FHandle, @aData, aSize, LMSG)
766  else
767    Result := sockets.fpRecvfrom(FHandle, @aData, aSize, LMSG, @FPeerAddress, @AddressLength);
768end;
769
770function TLSocket.HandleResult(const aResult: Integer; aOp: TLSocketOperation): Integer;
771const
772  GSStr: array[TLSocketOperation] of string = ('Send', 'Get');
773var
774  LastError: Longint;
775begin
776  Result := aResult;
777  if Result = SOCKET_ERROR then begin
778    LastError := LSocketError;
779    if IsBlockError(LastError) then case aOp of
780      soSend:
781         begin
782           FSocketState := FSocketState - [ssCanSend];
783           IgnoreWrite := False;
784         end;
785      soReceive:
786         begin
787           FSocketState := FSocketState - [ssCanReceive];
788           IgnoreRead := False;
789         end;
790    end else if IsNonFatalError(LastError) then
791      LogError(GSStr[aOp] + ' error', LastError) // non fatals don't cause disconnect
792    else if (aOp = soSend) and IsPipeError(LastError) then begin
793      LogError(GSStr[aOp] + ' error', LastError);
794      HardDisconnect(True); {$warning check if we need aOp = soSend in the IF, perhaps bad recv is possible?}
795    end else
796      Bail(GSStr[aOp] + ' error', LastError);
797
798    Result := 0;
799  end;
800end;
801
802function TLSocket.GetLocalPort: Word;
803begin
804  Result := ntohs(FAddress.IPv4.sin_port);
805end;
806
807function TLSocket.GetPeerPort: Word;
808begin
809  if FSocketType = SOCK_STREAM then
810    Result := ntohs(FAddress.IPv4.sin_port)
811  else
812    Result := ntohs(FPeerAddress.IPv4.sin_port);
813end;
814
815function TLSocket.Listen(const APort: Word; const AIntf: string = LADDR_ANY): Boolean;
816begin
817  Result := False;
818
819  if FConnectionStatus <> scNone then
820    Disconnect(True);
821
822  SetupSocket(APort, AIntf);
823  if fpBind(FHandle, GetIPAddressPointer, GetIPAddressLength) = SOCKET_ERROR then
824    Bail('Error on bind', LSocketError)
825  else
826    Result := true;
827
828  if (FSocketType = SOCK_STREAM) and Result then
829    if fpListen(FHandle, FListenBacklog) = SOCKET_ERROR then
830      Result := Bail('Error on Listen', LSocketError)
831    else
832      Result := true;
833end;
834
835function TLSocket.Accept(const sersock: TSocket): Boolean;
836var
837  AddressLength: tsocklen;
838begin
839  Result := false;
840  AddressLength := GetIPAddressLength;
841
842  if FConnectionStatus <> scNone then
843    Disconnect(True);
844
845  FHandle := fpAccept(sersock, GetIPAddressPointer, @AddressLength);
846  if FHandle <> INVALID_SOCKET then begin
847    SetOptions;
848    Result := true;
849  end else
850    Bail('Error on accept', LSocketError);
851end;
852
853function TLSocket.Connect(const Address: string; const aPort: Word): Boolean;
854begin
855  Result := False;
856
857  if FConnectionStatus <> scNone then
858    Disconnect(True);
859
860  if SetupSocket(APort, Address) then begin
861    fpConnect(FHandle, GetIPAddressPointer, GetIPAddressLength);
862    FConnectionStatus := scConnecting;
863    Result := True;
864  end;
865end;
866
867function TLSocket.SendMessage(const msg: string): Integer;
868begin
869  Result := Send(PChar(msg)^, Length(msg));
870end;
871
872function TLSocket.Send(const aData; const aSize: Integer): Integer;
873begin
874  Result := 0;
875
876  if aSize = 0 then
877    raise Exception.Create('Invalid buffersize 0 in Send');
878
879  if SendPossible then begin
880    if aSize <= 0 then begin
881      LogError('Send error: Size <= 0', -1);
882      Exit(0);
883    end;
884
885    Result := HandleResult(DoSend(aData, aSize), soSend);
886  end;
887end;
888
889//*******************************TLComponent*********************************
890
891procedure TLComponent.SetCreator(AValue: TLComponent);
892begin
893  FCreator := aValue;
894end;
895
896constructor TLComponent.Create(aOwner: TComponent);
897begin
898  inherited Create(aOwner);
899  FCreator := Self;
900end;
901
902//*******************************TLConnection*********************************
903
904constructor TLConnection.Create(aOwner: TComponent);
905begin
906  inherited Create(aOwner);
907
908  FHost := '';
909  FPort := 0;
910  FListenBacklog := LDEFAULT_BACKLOG;
911  FTimeout := 0;
912  SocketClass := TLSocket;
913  FOnReceive := nil;
914  FOnError := nil;
915  FOnDisconnect := nil;
916  FOnCanSend := nil;
917  FOnConnect := nil;
918  FOnAccept := nil;
919  FTimeVal.tv_sec := 0;
920  FTimeVal.tv_usec := 0;
921  FIterator := nil;
922  FEventer := nil;
923  FEventerClass := BestEventerClass;
924end;
925
926destructor TLConnection.Destroy;
927begin
928  FreeSocks(True);
929  if Assigned(FEventer) then
930    FEventer.DeleteRef;
931  inherited Destroy;
932end;
933
934function TLConnection.Connect(const Address: string; const APort: Word
935  ): Boolean;
936begin
937  FHost := Address;
938  FPort := aPort;
939  Result := False;
940end;
941
942function TLConnection.Connect: Boolean;
943begin
944  Result := Connect(FHost, FPort);
945end;
946
947function TLConnection.Listen: Boolean;
948begin
949  Result := Listen(FPort, FHost);
950end;
951
952procedure TLConnection.SetSession(aSession: TLSession);
953begin
954  if FSession = aSession then Exit;
955
956  if FActive then
957    raise Exception.Create('Cannot change session on active component');
958
959  FSession := aSession;
960  if Assigned(FSession) then begin
961    FSession.FreeNotification(Self);
962    FSession.RegisterWithComponent(Self);
963  end;
964end;
965
966procedure TLConnection.Notification(AComponent: TComponent;
967  Operation: TOperation);
968begin
969  inherited Notification(AComponent, Operation);
970
971  if (Operation = opRemove) and (AComponent = FSession) then
972    FSession := nil;
973end;
974
975function TLConnection.InitSocket(aSocket: TLSocket): TLSocket;
976begin
977  FActive := True; // once we got a socket, we're considered active
978  aSocket.OnRead := @ReceiveAction;
979  aSocket.OnWrite := @SendAction;
980  aSocket.OnError := @ErrorAction;
981  aSocket.ListenBacklog := FListenBacklog;
982  aSocket.FCreator := FCreator;
983  aSocket.FConnection := Self;
984  aSocket.FSession := FSession;
985  if Assigned(FSession) then
986    FSession.InitHandle(aSocket);
987  Result := aSocket;
988end;
989
990function TLConnection.GetCount: Integer;
991begin
992  Result := 1;
993end;
994
995function TLConnection.GetItem(const i: Integer): TLSocket;
996var
997  Tmp: TLSocket;
998  Jumps: Integer;
999begin
1000  Result := nil;
1001  Tmp := FRootSock;
1002  Jumps := 0;
1003  while Assigned(Tmp.NextSock) and (Jumps < i) do begin
1004    Tmp := Tmp.NextSock;
1005    Inc(Jumps);
1006  end;
1007  if Jumps = i then
1008    Result := Tmp;
1009end;
1010
1011function TLConnection.GetTimeout: Integer;
1012begin
1013  if Assigned(FEventer) then
1014    Result := FEventer.Timeout
1015  else
1016    Result := FTimeout;
1017end;
1018
1019procedure TLConnection.ConnectAction(aSocket: TLHandle);
1020begin
1021end;
1022
1023procedure TLConnection.AcceptAction(aSocket: TLHandle);
1024begin
1025end;
1026
1027procedure TLConnection.ReceiveAction(aSocket: TLHandle);
1028begin
1029end;
1030
1031procedure TLConnection.SendAction(aSocket: TLHandle);
1032begin
1033  with TLSocket(aSocket) do begin
1034    SetState(ssCanSend);
1035    IgnoreWrite := True;
1036
1037    if Assigned(FSession) then
1038      FSession.SendEvent(aSocket)
1039    else
1040      CanSendEvent(aSocket);
1041  end;
1042end;
1043
1044procedure TLConnection.ErrorAction(aSocket: TLHandle; const msg: string);
1045begin
1046end;
1047
1048procedure TLConnection.ConnectEvent(aSocket: TLHandle);
1049begin
1050  if Assigned(FOnConnect) then
1051    FOnConnect(TLSocket(aSocket));
1052end;
1053
1054procedure TLConnection.DisconnectEvent(aSocket: TLHandle);
1055begin
1056  if Assigned(FOnDisconnect) then
1057    FOnDisconnect(TLSocket(aSocket));
1058end;
1059
1060procedure TLConnection.AcceptEvent(aSocket: TLHandle);
1061begin
1062  if Assigned(FOnAccept) then
1063    FOnAccept(TLSocket(aSocket));
1064end;
1065
1066procedure TLConnection.ReceiveEvent(aSocket: TLHandle);
1067begin
1068  if Assigned(FOnReceive) then
1069    FOnReceive(TLSocket(aSocket));
1070end;
1071
1072procedure TLConnection.CanSendEvent(aSocket: TLHandle);
1073begin
1074  if Assigned(FOnCanSend) then
1075    FOnCanSend(TLSocket(aSocket));
1076end;
1077
1078procedure TLConnection.ErrorEvent(aSocket: TLHandle; const msg: string);
1079begin
1080  if Assigned(FOnError) then
1081    FOnError(msg, TLSocket(aSocket));
1082end;
1083
1084procedure TLConnection.SetTimeout(const AValue: Integer);
1085begin
1086  if Assigned(FEventer) then
1087    FEventer.Timeout := aValue;
1088  FTimeout := aValue;
1089end;
1090
1091procedure TLConnection.SetEventer(Value: TLEventer);
1092begin
1093  if Assigned(FEventer) then
1094    FEventer.DeleteRef;
1095  FEventer := Value;
1096  FEventer.AddRef;
1097end;
1098
1099procedure TLConnection.EventerError(const msg: string; Sender: TLEventer);
1100begin
1101  ErrorEvent(nil, msg);
1102end;
1103
1104procedure TLConnection.RegisterWithEventer;
1105begin
1106  if not Assigned(FEventer) then begin
1107    FEventer := FEventerClass.Create;
1108    FEventer.OnError := @EventerError;
1109  end;
1110
1111  if Assigned(FRootSock) then
1112    FEventer.AddHandle(FRootSock);
1113
1114  if (FEventer.Timeout = 0) and (FTimeout <> 0) then
1115    FEventer.Timeout := FTimeout
1116  else
1117    FTimeout := FEventer.Timeout;
1118end;
1119
1120procedure TLConnection.FreeSocks(const Forced: Boolean);
1121var
1122  Tmp, Tmp2: TLSocket;
1123begin
1124  Tmp := FRootSock;
1125  while Assigned(Tmp) do begin
1126    Tmp2 := Tmp;
1127    Tmp := Tmp.NextSock;
1128    Tmp2.Disconnect(Forced);
1129    if Forced then
1130      Tmp2.Free;
1131  end;
1132end;
1133
1134//*******************************TLUdp*********************************
1135
1136constructor TLUdp.Create(aOwner: TComponent);
1137begin
1138  inherited Create(aOwner);
1139  FTimeVal.tv_usec := 0;
1140  FTimeVal.tv_sec := 0;
1141end;
1142
1143procedure TLUdp.Disconnect(const Forced: Boolean = True);
1144begin
1145  if Assigned(FRootSock) then begin
1146    FRootSock.Disconnect(True);
1147    FRootSock := nil; // even if the old one exists, eventer takes care of it
1148  end;
1149end;
1150
1151function TLUdp.Connect(const Address: string; const APort: Word): Boolean;
1152begin
1153  Result := inherited Connect(Address, aPort);
1154
1155  if Assigned(FRootSock) and (FRootSock.FConnectionStatus <> scNone) then
1156    Disconnect(True);
1157
1158  FRootSock := InitSocket(SocketClass.Create);
1159  FIterator := FRootSock;
1160
1161  Result := FRootSock.SetupSocket(APort, LADDR_ANY);
1162
1163  if Result then begin
1164    FillAddressInfo(FRootSock.FPeerAddress, FRootSock.FSocketNet, Address, aPort);
1165    FRootSock.FConnectionStatus := scConnected;
1166    RegisterWithEventer;
1167  end;
1168end;
1169
1170function TLUdp.Listen(const APort: Word; const AIntf: string = LADDR_ANY): Boolean;
1171begin
1172  Result := False;
1173
1174  if Assigned(FRootSock) and (FRootSock.FConnectionStatus <> scNone) then
1175    Disconnect(True);
1176
1177  FRootSock := InitSocket(SocketClass.Create);
1178  FIterator := FRootSock;
1179
1180  if FRootSock.Listen(APort, AIntf) then begin
1181    FillAddressInfo(FRootSock.FPeerAddress, FRootSock.FSocketNet, LADDR_BR, aPort);
1182
1183    FRootSock.FConnectionStatus := scConnected;
1184    RegisterWithEventer;
1185    Result := True;
1186  end;
1187end;
1188
1189function TLUdp.Bail(const msg: string): Boolean;
1190begin
1191  Result := False;
1192
1193  Disconnect(True);
1194
1195  if Assigned(FSession) then
1196    FSession.ErrorEvent(nil, msg)
1197  else
1198    ErrorEvent(FRootSock, msg);
1199end;
1200
1201procedure TLUdp.SetAddress(const Address: string);
1202var
1203  n: Integer;
1204  s: string;
1205  p: Word;
1206begin
1207  n := Pos(':', Address);
1208  if n > 0 then begin
1209    s := Copy(Address, 1, n-1);
1210    p := Word(StrToInt(Copy(Address, n+1, Length(Address))));
1211
1212    FillAddressInfo(FRootSock.FPeerAddress, FRootSock.FSocketNet, s, p);
1213  end else
1214    FillAddressInfo(FRootSock.FPeerAddress, FRootSock.FSocketNet, Address,
1215                                            FRootSock.PeerPort);
1216end;
1217
1218function TLUdp.InitSocket(aSocket: TLSocket): TLSocket;
1219begin
1220  Result := FRootSock;
1221  if not Assigned(FRootSock) then begin
1222    aSocket.SocketType := SOCK_DGRAM;
1223    aSocket.Protocol := LPROTO_UDP;
1224    Result := inherited InitSocket(aSocket); // call last, to make sure sessions get their turn in overriding
1225  end;
1226end;
1227
1228procedure TLUdp.ReceiveAction(aSocket: TLHandle);
1229begin
1230  with TLSocket(aSocket) do begin
1231    SetState(ssCanReceive);
1232    if Assigned(FSession) then
1233      FSession.ReceiveEvent(aSocket)
1234    else
1235      ReceiveEvent(aSocket);
1236  end;
1237end;
1238
1239procedure TLUdp.ErrorAction(aSocket: TLHandle; const msg: string);
1240begin
1241  if Assigned(FSession) then
1242    FSession.ErrorEvent(aSocket, msg)
1243  else
1244    ErrorEvent(aSocket, msg);
1245end;
1246
1247function TLUdp.IterNext: Boolean;
1248begin
1249  Result := False;
1250end;
1251
1252procedure TLUdp.IterReset;
1253begin
1254end;
1255
1256procedure TLUdp.CallAction;
1257begin
1258  if Assigned(FEventer) then
1259    FEventer.CallAction;
1260end;
1261
1262function TLUdp.GetConnected: Boolean;
1263begin
1264  Result := False;
1265  if Assigned(FRootSock) then
1266  Result := FRootSock.ConnectionStatus = scConnected;
1267end;
1268
1269function TLUdp.Get(out aData; const aSize: Integer; aSocket: TLSocket): Integer;
1270begin
1271  Result := 0;
1272  if Assigned(FRootSock) then
1273    Result := FRootSock.Get(aData, aSize);
1274end;
1275
1276function TLUdp.GetMessage(out msg: string; aSocket: TLSocket): Integer;
1277begin
1278  Result := 0;
1279  if Assigned(FRootSock) then
1280    Result := FRootSock.GetMessage(msg);
1281end;
1282
1283function TLUdp.SendMessage(const msg: string; aSocket: TLSocket = nil): Integer;
1284begin
1285  Result := 0;
1286  if Assigned(FRootSock) then
1287    Result := FRootSock.SendMessage(msg)
1288end;
1289
1290function TLUdp.SendMessage(const msg: string; const Address: string): Integer;
1291begin
1292  Result := 0;
1293  if Assigned(FRootSock) then begin
1294    SetAddress(Address);
1295    Result := FRootSock.SendMessage(msg)
1296  end;
1297end;
1298
1299function TLUdp.Send(const aData; const aSize: Integer; aSocket: TLSocket): Integer;
1300begin
1301  Result := 0;
1302  if Assigned(FRootSock) then
1303    Result := FRootSock.Send(aData, aSize)
1304end;
1305
1306function TLUdp.Send(const aData; const aSize: Integer; const Address: string
1307  ): Integer;
1308begin
1309  Result := 0;
1310  if Assigned(FRootSock) then begin
1311    SetAddress(Address);
1312    Result := FRootSock.Send(aData, aSize);
1313  end;
1314end;
1315
1316//******************************TLTcp**********************************
1317
1318constructor TLTcp.Create(aOwner: TComponent);
1319begin
1320  inherited Create(aOwner);
1321  FSocketNet := LAF_INET; // default to IPv4
1322  FIterator  := nil;
1323  FCount     := 0;
1324  FRootSock  := nil;
1325end;
1326
1327function TLTcp.Connect(const Address: string; const APort: Word): Boolean;
1328begin
1329  Result := inherited Connect(Address, aPort);
1330
1331  if Assigned(FRootSock) then
1332    Disconnect(True);
1333
1334  FRootSock := InitSocket(SocketClass.Create);
1335  Result := FRootSock.Connect(Address, aPort);
1336
1337  if Result then begin
1338    Inc(FCount);
1339    FIterator := FRootSock;
1340    RegisterWithEventer;
1341  end else begin
1342    FreeAndNil(FRootSock); // one possible use, since we're not in eventer yet
1343    FIterator := nil;
1344  end;
1345end;
1346
1347function TLTcp.Listen(const APort: Word; const AIntf: string = LADDR_ANY): Boolean;
1348begin
1349  Result := false;
1350
1351  if Assigned(FRootSock) then
1352    Disconnect(True);
1353
1354  FRootSock := InitSocket(SocketClass.Create);
1355  FRootSock.SetReuseAddress(FReuseAddress);
1356  FRootSock.MsgBufferSize:= MsgBufferSize;
1357  if FRootSock.Listen(APort, AIntf) then begin
1358    FRootSock.SetState(ssServerSocket);
1359    FRootSock.FConnectionStatus := scConnected;
1360    FIterator := FRootSock;
1361    Inc(FCount);
1362    RegisterWithEventer;
1363    Result := true;
1364  end;
1365end;
1366
1367function TLTcp.Bail(const msg: string; aSocket: TLSocket): Boolean;
1368begin
1369  Result  :=  False;
1370
1371  if Assigned(FSession) then
1372    FSession.ErrorEvent(aSocket, msg)
1373  else
1374    ErrorEvent(aSocket, msg);
1375
1376  if Assigned(aSocket) then
1377    aSocket.Disconnect(True)
1378  else
1379    Disconnect(True);
1380end;
1381
1382procedure TLTcp.SocketDisconnect(aSocket: TLSocket);
1383begin
1384  if aSocket = FIterator then begin
1385    if Assigned(FIterator.NextSock) then
1386      FIterator := FIterator.NextSock
1387    else if Assigned(FIterator.PrevSock) then
1388      FIterator := FIterator.PrevSock
1389    else FIterator := nil; // NOT iterreset, not reorganized yet
1390    if Assigned(FIterator) and (ssServerSocket in FIterator.SocketState) then
1391      FIterator := nil;
1392  end;
1393
1394  if aSocket = FRootSock then
1395    FRootSock := aSocket.NextSock;
1396  if Assigned(aSocket.PrevSock) then
1397    aSocket.PrevSock.NextSock := aSocket.NextSock;
1398  if Assigned(aSocket.NextSock) then
1399    aSocket.NextSock.PrevSock := aSocket.PrevSock;
1400
1401  Dec(FCount);
1402end;
1403
1404function TLTcp.InitSocket(aSocket: TLSocket): TLSocket;
1405begin
1406  aSocket.SocketType := SOCK_STREAM;
1407  aSocket.Protocol := LPROTO_TCP;
1408  aSocket.SocketNet := FSocketNet;
1409  aSocket.FOnFree := @SocketDisconnect;
1410
1411  Result := inherited InitSocket(aSocket); // call last to make sure session can override options
1412end;
1413
1414function TLTcp.IterNext: Boolean;
1415begin
1416  Result := False;
1417  if Assigned(FIterator.NextSock) then begin
1418    FIterator := FIterator.NextSock;
1419    Result := True;
1420  end else IterReset;
1421end;
1422
1423procedure TLTcp.IterReset;
1424begin
1425  FIterator := FRootSock;
1426end;
1427
1428procedure TLTcp.Disconnect(const Forced: Boolean = True);
1429begin
1430  if Assigned(FOnDisconnect) then
1431    FOnDisconnect(FRootSock);
1432  FreeSocks(Forced);
1433  FRootSock := nil;
1434  FCount := 0;
1435  FIterator := nil;
1436end;
1437
1438procedure TLTcp.CallAction;
1439begin
1440  if Assigned(FEventer) then
1441    FEventer.CallAction;
1442end;
1443
1444procedure TLTcp.ConnectAction(aSocket: TLHandle);
1445var
1446  a: TInetSockAddr;
1447  l: Longint;
1448begin
1449  with TLSocket(aSocket) do begin
1450    l := SizeOf(a);
1451    if Sockets.fpGetPeerName(FHandle, @a, @l) <> 0 then
1452      Self.Bail('Error on connect: connection refused', TLSocket(aSocket))
1453    else begin
1454      FConnectionStatus := scConnected;
1455      IgnoreWrite := True;
1456      if Assigned(FSession) then
1457        FSession.ConnectEvent(aSocket)
1458      else
1459        ConnectEvent(aSocket);
1460    end;
1461  end;
1462end;
1463
1464procedure TLTcp.AcceptAction(aSocket: TLHandle);
1465var
1466  Tmp: TLSocket;
1467begin
1468  Tmp := InitSocket(SocketClass.Create);
1469
1470  if Tmp.Accept(FRootSock.FHandle) then begin
1471    if Assigned(FRootSock.FNextSock) then begin
1472      Tmp.FNextSock := FRootSock.FNextSock;
1473      FRootSock.FNextSock.FPrevSock := Tmp;
1474    end;
1475
1476    FRootSock.FNextSock := Tmp;
1477    Tmp.FPrevSock := FRootSock;
1478
1479    if not Assigned(FIterator)      // if we don't have (bug?) an iterator yet
1480    or (ssServerSocket in FIterator.SocketState) then // or if it's the first socket accepted
1481      FIterator := Tmp;  // assign it as iterator (don't assign later acceptees)
1482
1483    Inc(FCount);
1484    FEventer.AddHandle(Tmp);
1485
1486    Tmp.FConnectionStatus := scConnected;
1487    Tmp.IgnoreWrite := True;
1488
1489    if Assigned(FSession) then
1490      FSession.AcceptEvent(Tmp)
1491    else
1492      AcceptEvent(Tmp);
1493  end else
1494    Tmp.Free;
1495end;
1496
1497procedure TLTcp.ReceiveAction(aSocket: TLHandle);
1498begin
1499  if (TLSocket(aSocket) = FRootSock) and (ssServerSocket in TLSocket(aSocket).SocketState) then
1500    AcceptAction(aSocket)
1501  else with TLSocket(aSocket) do begin
1502    if FConnectionStatus in [scConnected, scDisconnecting] then begin
1503      SetState(ssCanReceive);
1504      if Assigned(FSession) then
1505        FSession.ReceiveEvent(aSocket)
1506      else
1507        ReceiveEvent(aSocket);
1508
1509      if not (FConnectionStatus = scConnected) then begin
1510        DisconnectEvent(aSocket);
1511        aSocket.Free;
1512      end;
1513    end;
1514  end;
1515end;
1516
1517procedure TLTcp.SendAction(aSocket: TLHandle);
1518begin
1519  with TLSocket(aSocket) do begin
1520    if FConnectionStatus = scConnecting then
1521      ConnectAction(aSocket)
1522    else
1523      inherited;
1524  end;
1525end;
1526
1527procedure TLTcp.ErrorAction(aSocket: TLHandle; const msg: string);
1528begin
1529  if TLSocket(aSocket).ConnectionStatus = scConnecting then begin
1530    Self.Bail('Error on connect: connection refused', TLSocket(aSocket));
1531    Exit;
1532  end;
1533
1534  if Assigned(FSession) then
1535    FSession.ErrorEvent(aSocket, msg)
1536  else
1537    ErrorEvent(aSocket, msg);
1538end;
1539
1540function TLTcp.GetConnected: Boolean;
1541var
1542  Tmp: TLSocket;
1543begin
1544  Result := False;
1545  Tmp := FRootSock;
1546  while Assigned(Tmp) do begin
1547    if Tmp.ConnectionStatus = scConnected then begin
1548      Result := True;
1549      Exit;
1550    end else Tmp := Tmp.NextSock;
1551  end;
1552end;
1553
1554function TLTcp.GetConnecting: Boolean;
1555begin
1556  Result := False;
1557  if Assigned(FRootSock) then
1558    Result := FRootSock.ConnectionStatus = scConnecting;
1559end;
1560
1561function TLTcp.GetCount: Integer;
1562begin
1563  Result := FCount;
1564end;
1565
1566function TLTcp.GetValidSocket: TLSocket;
1567begin
1568  Result := nil;
1569
1570  if Assigned(FIterator) and not (ssServerSocket in FIterator.SocketState) then
1571    Result := FIterator
1572  else if Assigned(FRootSock) and Assigned(FRootSock.FNextSock) then
1573    Result := FRootSock.FNextSock;
1574end;
1575
1576procedure TLTcp.SetReuseAddress(const aValue: Boolean);
1577begin
1578  if not Assigned(FRootSock)
1579  or (FRootSock.FConnectionStatus = scNone) then
1580    FReuseAddress := aValue;
1581end;
1582
1583procedure TLTcp.SetSocketNet(const aValue: Integer);
1584begin
1585  if GetConnected then
1586    raise Exception.Create('Cannot set socket network on a connected system');
1587
1588  FSocketNet := aValue;
1589end;
1590
1591function TLTcp.Get(out aData; const aSize: Integer; aSocket: TLSocket): Integer;
1592begin
1593  Result := 0;
1594
1595  if not Assigned(aSocket) then
1596    aSocket := GetValidSocket;
1597
1598  if Assigned(aSocket) then
1599    Result := aSocket.Get(aData, aSize)
1600  else
1601    Bail('No connected socket to get through', nil);
1602end;
1603
1604function TLTcp.GetMessage(out msg: string; aSocket: TLSocket): Integer;
1605begin
1606  Result := 0;
1607
1608  if not Assigned(aSocket) then
1609    aSocket := GetValidSocket;
1610
1611  if Assigned(aSocket) then
1612    Result := aSocket.GetMessage(msg)
1613  else
1614    Bail('No connected socket to get through', nil);
1615end;
1616
1617function TLTcp.Send(const aData; const aSize: Integer; aSocket: TLSocket): Integer;
1618begin
1619  Result := 0;
1620
1621  if not Assigned(aSocket) then
1622    aSocket := GetValidSocket;
1623
1624  if Assigned(aSocket) then
1625    Result := aSocket.Send(aData, aSize)
1626  else
1627    Bail('No connected socket to send through', nil);
1628end;
1629
1630function TLTcp.SendMessage(const msg: string; aSocket: TLSocket): Integer;
1631begin
1632  Result := Send(PChar(msg)^, Length(msg), aSocket);
1633end;
1634
1635//*******************************TLSession*********************************
1636
1637procedure TLSession.RegisterWithComponent(aConnection: TLConnection);
1638begin
1639  if not Assigned(aConnection) then
1640    raise Exception.Create('Cannot register session with nil connection');
1641end;
1642
1643procedure TLSession.InitHandle(aHandle: TLHandle);
1644begin
1645  TLSocket(aHandle).FSession := Self;
1646end;
1647
1648procedure TLSession.ReceiveEvent(aHandle: TLHandle);
1649begin
1650  FActive := True;
1651  CallReceiveEvent(aHandle);
1652end;
1653
1654procedure TLSession.SendEvent(aHandle: TLHandle);
1655begin
1656  FActive := True;
1657  CallSendEvent(aHandle);
1658end;
1659
1660procedure TLSession.ErrorEvent(aHandle: TLHandle; const msg: string);
1661begin
1662  FActive := True;
1663  CallErrorEvent(aHandle, msg);
1664end;
1665
1666procedure TLSession.ConnectEvent(aHandle: TLHandle);
1667begin
1668  FActive := True;
1669  CallConnectEvent(aHandle);
1670end;
1671
1672procedure TLSession.AcceptEvent(aHandle: TLHandle);
1673begin
1674  FActive := True;
1675  CallAcceptEvent(aHandle);
1676end;
1677
1678procedure TLSession.DisconnectEvent(aHandle: TLHandle);
1679begin
1680  FActive := True;
1681  CallDisconnectEvent(aHandle);
1682end;
1683
1684procedure TLSession.CallReceiveEvent(aHandle: TLHandle); inline;
1685begin
1686  TLSocket(aHandle).FConnection.ReceiveEvent(TLSocket(aHandle));
1687end;
1688
1689procedure TLSession.CallSendEvent(aHandle: TLHandle); inline;
1690begin
1691  TLSocket(aHandle).FConnection.CanSendEvent(TLSocket(aHandle));
1692end;
1693
1694procedure TLSession.CallErrorEvent(aHandle: TLHandle; const msg: string);
1695  inline;
1696begin
1697  TLSocket(aHandle).FConnection.ErrorEvent(TLSocket(aHandle), msg);
1698end;
1699
1700procedure TLSession.CallConnectEvent(aHandle: TLHandle); inline;
1701begin
1702  TLSocket(aHandle).FConnection.ConnectEvent(TLSocket(aHandle));
1703end;
1704
1705procedure TLSession.CallAcceptEvent(aHandle: TLHandle); inline;
1706begin
1707  TLSocket(aHandle).FConnection.AcceptEvent(TLSocket(aHandle));
1708end;
1709
1710procedure TLSession.CallDisconnectEvent(aHandle: TLHandle); inline;
1711begin
1712  TLSocket(aHandle).FConnection.DisconnectEvent(TLSocket(aHandle));
1713end;
1714
1715
1716end.
1717
1718