/packages/fcl-net/src/ssockets.pp

  1{
  2    This file is part of the Free Component Library (FCL)
  3    Copyright (c) 1999-2000 by the Free Pascal development team
  4
  5    See the file COPYING.FPC, included in this distribution,
  6    for details about the copyright.
  7
  8    This program is distributed in the hope that it will be useful,
  9    but WITHOUT ANY WARRANTY; without even the implied warranty of
 10    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 11
 12 **********************************************************************}
 13{$MODE objfpc}{$H+}
 14
 15unit ssockets;
 16
 17
 18interface
 19
 20uses
 21 SysUtils, Classes, ctypes, sockets;
 22
 23type
 24
 25  TSocketErrorType = (
 26    seHostNotFound,
 27    seCreationFailed,
 28    seBindFailed,
 29    seListenFailed,
 30    seConnectFailed,
 31    seAcceptFailed,
 32    seAcceptWouldBlock);
 33
 34  TSocketOption = (soDebug,soReuseAddr,soKeepAlive,soDontRoute,soBroadcast,
 35                   soOOBinline);
 36  TSocketOptions = Set of TSocketOption;
 37
 38  ESocketError = class(Exception)
 39    Code: TSocketErrorType;
 40    constructor Create(ACode: TSocketErrorType; const MsgArgs: array of const);
 41  end;
 42
 43  { TSocketStream }
 44
 45  TSocketStream = class(THandleStream)
 46  Private
 47    FReadFlags: Integer;
 48    FSocketInitialized : Boolean;
 49    FSocketOptions : TSocketOptions;
 50    FLastError : integer;
 51    FWriteFlags: Integer;
 52    Procedure GetSockOptions;
 53    Procedure SetSocketOptions(Value : TSocketOptions);
 54    function GetLocalAddress: TSockAddr;
 55    function GetRemoteAddress: TSockAddr;
 56  Public
 57    Constructor Create (AHandle : Longint);virtual;
 58    destructor Destroy; override;
 59    function Seek(Offset: Longint; Origin: Word): Longint; override;
 60    Function Read (Var Buffer; Count : Longint) : longint; Override;
 61    Function Write (Const Buffer; Count : Longint) :Longint; Override;
 62    Property SocketOptions : TSocketOptions Read FSocketOptions
 63                                            Write SetSocketOptions;
 64    property LocalAddress: TSockAddr read GetLocalAddress;
 65    property RemoteAddress: TSockAddr read GetRemoteAddress;
 66    Property LastError : Integer Read FLastError;
 67    Property ReadFlags : Integer Read FReadFlags Write FReadFlags;
 68    Property WriteFlags : Integer Read FWriteFlags Write FWriteFlags;
 69  end;
 70
 71  TConnectEvent = Procedure (Sender : TObject; Data : TSocketStream) Of Object;
 72  TConnectQuery = Procedure (Sender : TObject; ASocket : Longint; Var Allow : Boolean) of Object;
 73
 74  { TSocketServer }
 75
 76  TSocketServer = Class(TObject)
 77  Private
 78    FOnIdle : TNotifyEvent;
 79    FNonBlocking : Boolean;
 80    FSocket : longint;
 81    FListened : Boolean;
 82    FAccepting : Boolean;
 83    FMaxConnections : Longint;
 84    FQueueSize : Longint;
 85    FOnConnect : TConnectEvent;
 86    FOnConnectQuery : TConnectQuery;
 87    Procedure DoOnIdle;
 88    Function GetReuseAddress: Boolean;
 89    Function GetKeepAlive : Boolean;
 90    Function GetLinger : Integer;
 91    Procedure SetReuseAddress (AValue : Boolean);
 92    Procedure SetKeepAlive (AValue : Boolean);
 93    Procedure SetLinger(ALinger : Integer);
 94  Protected
 95    FSockType : Longint;
 96    FBound : Boolean;
 97    Procedure DoConnect(ASocket : TSocketStream); Virtual;
 98    Function  DoConnectQuery(ASocket : longint): Boolean ;Virtual;
 99    Procedure Bind; Virtual; Abstract;
100    Function  Accept: Longint;Virtual;Abstract;
101    Function  SockToStream (ASocket : Longint) : TSocketStream;Virtual;Abstract;
102    Procedure Close; Virtual;
103    function GetConnection: TSocketStream;
104  Public
105    Constructor Create(ASocket : Longint);
106    Destructor Destroy; Override;
107    Procedure Listen;
108    function  GetSockopt(ALevel,AOptName : cint; var optval; Var optlen : tsocklen): Boolean;
109    function  SetSockopt(ALevel,AOptName : cint; var optval; optlen : tsocklen): Boolean;
110    Procedure StartAccepting;
111    Procedure StopAccepting;
112    Procedure SetNonBlocking;
113    Property Bound : Boolean Read FBound;
114    Property MaxConnections : longint Read FMaxConnections Write FMaxConnections;
115    Property QueueSize : Longint Read FQueueSize Write FQueueSize default 5;
116    Property OnConnect : TConnectEvent Read FOnConnect Write FOnConnect;
117    Property OnConnectQuery : TConnectQuery Read FOnConnectQuery Write FOnConnectQuery;
118    Property OnIdle : TNotifyEvent Read FOnIdle Write FOnIdle;
119    Property NonBlocking : Boolean Read FNonBlocking;
120    Property Socket : Longint Read FSocket;
121    Property SockType : Longint Read FSockType;
122    Property KeepAlive : Boolean Read GetKeepAlive Write SetKeepAlive;
123    Property ReuseAddress : Boolean Read GetReuseAddress Write SetReuseAddress;
124    // -1 means no linger. Any value >=0 sets linger on.
125    Property Linger: Integer Read GetLinger Write Setlinger;
126  end;
127
128  { TInetServer }
129
130  TInetServer = Class(TSocketServer)
131  Protected
132    FAddr : TINetSockAddr;
133    FPort : Word;
134    FHost: string;
135    Function  SockToStream (ASocket : Longint) : TSocketStream;Override;
136    Function Accept : Longint;override;
137  Public
138    Procedure Bind; Override;
139    Constructor Create(APort: Word);
140    Constructor Create(const aHost: string; const APort: Word);
141    Property Port : Word Read FPort;
142    Property Host : string Read FHost;
143  end;
144
145{$ifdef Unix}
146
147  { TUnixServer }
148
149  TUnixServer = Class(TSocketServer)
150  Private
151    FUnixAddr : TUnixSockAddr;
152    FFileName : String;
153  Protected
154    Procedure Bind; Override;
155    Function Accept : Longint;override;
156    Function SockToStream (ASocket : Longint) : TSocketStream;Override;
157    Procedure Close; override;
158  Public
159    Constructor Create(AFileName : String);
160    Property FileName : String Read FFileName;
161  end;
162{$endif}
163
164  { TInetSocket }
165
166  TInetSocket = Class(TSocketStream)
167  Private
168    FHost : String;
169    FPort : Word;
170  Protected
171    Procedure DoConnect(ASocket : longint); Virtual;
172  Public
173    Constructor Create(ASocket : longint); Override; Overload;
174    Constructor Create(const AHost: String; APort: Word); Overload;
175    Property Host : String Read FHost;
176    Property Port : Word Read FPort;
177  end;
178
179{$ifdef Unix}
180
181  TUnixSocket = Class(TSocketStream)
182  Private
183    FFileName : String;
184  Protected
185    Procedure DoConnect(ASocket : longint); Virtual;
186  Public
187    Constructor Create(ASocket : Longint); Overload;
188    Constructor Create(AFileName : String); Overload;
189    Property FileName : String Read FFileName;
190  end;
191{$endif}
192
193Implementation
194
195uses
196{$ifdef unix}
197  BaseUnix, Unix,
198{$endif}
199  resolve;
200
201Const
202  SocketWouldBlock = -2;
203
204{ ---------------------------------------------------------------------
205  ESocketError
206  ---------------------------------------------------------------------}
207
208resourcestring
209  strHostNotFound = 'Host name resolution for "%s" failed.';
210  strSocketCreationFailed = 'Creation of socket failed: %s';
211  strSocketBindFailed = 'Binding of socket failed: %s';
212  strSocketListenFailed = 'Listening on port #%d failed, error: %d';
213  strSocketConnectFailed = 'Connect to %s failed.';
214  strSocketAcceptFailed = 'Could not accept a client connection on socket: %d, error %d';
215  strSocketAcceptWouldBlock = 'Accept would block on socket: %d';
216
217constructor ESocketError.Create(ACode: TSocketErrorType; const MsgArgs: array of const);
218var
219  s: String;
220begin
221  Code := ACode;
222  case ACode of
223    seHostNotFound  : s := strHostNotFound;
224    seCreationFailed: s := strSocketCreationFailed;
225    seBindFailed    : s := strSocketBindFailed;
226    seListenFailed  : s := strSocketListenFailed;
227    seConnectFailed : s := strSocketConnectFailed;
228    seAcceptFailed  : s := strSocketAcceptFailed;
229    seAcceptWouldBLock : S:= strSocketAcceptWouldBlock;
230  end;
231  s := Format(s, MsgArgs);
232  inherited Create(s);
233end;
234
235{ ---------------------------------------------------------------------
236    TSocketStream
237  ---------------------------------------------------------------------}
238Constructor TSocketStream.Create (AHandle : Longint);
239
240begin
241  Inherited Create(AHandle);
242  FSocketInitialized := true;
243  GetSockOptions;
244end;
245
246destructor TSocketStream.Destroy;
247begin
248  if FSocketInitialized then
249  {$ifdef netware}
250  CloseSocket(Handle);
251  {$else}
252  FileClose(Handle);
253  {$endif}
254  inherited Destroy;
255end;
256
257Procedure TSocketStream.GetSockOptions;
258
259begin
260end;
261
262Procedure TSocketStream.SetSocketOptions(Value : TSocketOptions);
263
264begin
265end;
266
267Function TSocketStream.Seek(Offset: Longint; Origin: Word): Longint;
268
269begin
270  Result:=0;
271end;
272
273Function TSocketStream.Read (Var Buffer; Count : Longint) : longint;
274
275Var
276  Flags : longint;
277
278begin
279  Flags:=FReadFlags;
280  Result:=fprecv(handle,@Buffer,count,flags);
281  If Result<0 then
282    FLastError:=SocketError
283  else
284    FLastError:=0;
285end;
286
287Function TSocketStream.Write (Const Buffer; Count : Longint) :Longint;
288
289Var
290  Flags : longint;
291
292begin
293  Flags:=FWriteFlags;
294  Result:=fpsend(handle,@Buffer,count,flags);
295  If Result<0 then
296    FLastError:=SocketError
297  else
298    FlastError:=0;
299end;
300
301function TSocketStream.GetLocalAddress: TSockAddr;
302var
303  len: LongInt;
304begin
305  len := SizeOf(TSockAddr);
306  if fpGetSockName(Handle, @Result, @len) <> 0 then
307    FillChar(Result, SizeOf(Result), 0);
308end;
309
310function TSocketStream.GetRemoteAddress: TSockAddr;
311var
312  len: LongInt;
313begin
314  len := SizeOf(TSockAddr);
315  if fpGetPeerName(Handle, @Result, @len) <> 0 then
316    FillChar(Result, SizeOf(Result), 0);
317end;
318
319
320{ ---------------------------------------------------------------------
321    TSocketServer
322  ---------------------------------------------------------------------}
323
324Constructor TSocketServer.Create(ASocket : Longint);
325
326begin
327  FSocket:=ASocket;
328  FQueueSize :=5;
329  FMaxConnections:=-1;
330end;
331
332Destructor TSocketServer.Destroy;
333
334begin
335  Close;
336  Inherited;
337end;
338
339Procedure TSocketServer.Close;
340
341begin
342  If FSocket<>-1 Then
343    {$ifdef netware}
344    CloseSocket(FSocket);
345    {$else}
346    FileClose(FSocket);
347    {$endif}
348  FSocket:=-1;
349end;
350
351Procedure TSocketServer.Listen;
352
353begin
354  If Not FBound then
355    Bind;
356  If  Sockets.FpListen(FSocket,FQueueSize)<>0 then
357    Raise ESocketError.Create(seListenFailed,[FSocket,SocketError]);
358end;
359
360function TSocketServer.GetSockopt(ALevel, AOptName: cint; Var optval;
361  var optlen: tsocklen): Boolean;
362begin
363  Result:=fpGetSockOpt(FSocket,ALevel,AOptName,@optval,@optlen)<>-1;
364end;
365
366function TSocketServer.SetSockopt(ALevel, AOptName: cint; var optval;
367  optlen: tsocklen): Boolean;
368begin
369  Result:=fpSetSockOpt(FSocket,ALevel,AOptName,@optval,optlen)<>-1;
370end;
371
372Function TSocketServer.GetConnection : TSocketStream;
373
374var
375  NewSocket : longint;
376
377begin
378  Result:=Nil;
379  NewSocket:=Accept;
380  If NewSocket>=0 then
381    begin
382    If FAccepting and DoConnectQuery(NewSocket) Then
383      Result:=SockToStream(NewSocket)
384    else
385      CloseSocket(NewSocket);
386    end
387end;
388
389Procedure TSocketServer.StartAccepting;
390
391Var
392 NoConnections : Integer;
393 Stream : TSocketStream;
394
395begin
396  FAccepting := True;
397  NoConnections := 0;
398  Listen;
399  Repeat
400    Repeat
401      Try
402        Stream:=GetConnection;
403        if Assigned(Stream) then
404          begin
405          Inc (NoConnections);
406          DoConnect(Stream);
407          end;
408      except
409        On E : ESocketError do
410          begin
411          If E.Code=seAcceptWouldBlock then
412            DoOnIdle
413          else
414            Raise;
415          end;
416       end;
417    Until (Stream<>Nil) or (Not NonBlocking);
418  Until Not (FAccepting) or ((FMaxConnections<>-1) and (NoConnections>=FMaxConnections));
419end;
420
421Procedure TSocketServer.StopAccepting;
422
423begin
424  FAccepting:=False;
425end;
426
427Procedure TSocketServer.DoOnIdle;
428
429begin
430  If Assigned(FOnIdle) then
431    FOnIdle(Self);
432end;
433
434function TSocketServer.GetReuseAddress: Boolean;
435Var
436  L : cint;
437  ls : Tsocklen;
438begin
439  L:=0;
440  ls:=0;
441{$IFDEF UNIX}
442  if not GetSockOpt(SOL_SOCKET, SO_REUSEADDR, L, LS) then
443    Raise ESocketError.CreateFmt('Failed to get SO_REUSEADDR to %d: %d',[l,socketerror]);
444  Result:=(L<>0);
445{$ELSE}
446  Result:=True;
447{$ENDIF}
448
449end;
450
451function TSocketServer.GetKeepAlive: Boolean;
452Var
453  L : cint;
454  ls : Tsocklen;
455begin
456  L:=0;
457  ls:=0;
458{$IFDEF UNIX}
459  if Not GetSockOpt(SOL_SOCKET, SO_KEEPALIVE, L, LS) then
460    Raise ESocketError.CreateFmt('Failed to get SO_KEEPALIVE: %d',[socketerror]);
461  Result:=(L<>0);
462{$ELSE}
463  Result:=True;
464{$ENDIF}
465end;
466
467function TSocketServer.GetLinger: Integer;
468Var
469  L : linger;
470  ls : tsocklen;
471
472begin
473  L.l_onoff:=0;
474  l.l_linger:=0;
475  if Not GetSockOpt(SOL_SOCKET, SO_LINGER, l, ls) then
476    Raise ESocketError.CreateFmt('Failed to set linger: %d',[socketerror]);
477  if l.l_onoff=0 then
478    Result:=-1
479  else
480    Result:=l.l_linger;
481end;
482
483Procedure TSocketServer.DoConnect(ASocket : TSocketStream);
484
485begin
486  If Assigned(FOnConnect) Then
487    FOnConnect(Self,ASocket);
488end;
489
490Function TSocketServer.DoConnectQuery(ASocket : Longint) : Boolean;
491
492begin
493  Result:=True;
494  If Assigned(FOnConnectQuery) then
495    FOnConnectQuery(Self,ASocket,Result);
496end;
497
498Procedure TSocketServer.SetNonBlocking;
499
500begin
501{$ifdef Unix}
502  fpfcntl(FSocket,F_SETFL,O_NONBLOCK);
503{$endif}
504  FNonBlocking:=True;
505end;
506
507procedure TSocketServer.SetLinger(ALinger: Integer);
508Var
509  L : linger;
510begin
511  L.l_onoff:=Ord(ALinger>0);
512  if ALinger<0 then
513    l.l_linger:=ALinger
514  else
515    l.l_linger:=0;
516  if Not SetSockOpt(SOL_SOCKET, SO_LINGER, l, SizeOf(L)) then
517    Raise ESocketError.CreateFmt('Failed to set linger: %d',[socketerror]);
518end;
519
520procedure TSocketServer.SetReuseAddress(AValue: Boolean);
521Var
522  L : cint;
523begin
524  L:=Ord(AValue);
525{$IFDEF UNIX}
526  if not SetSockOpt(SOL_SOCKET, SO_REUSEADDR , L, SizeOf(L)) then
527    Raise ESocketError.CreateFmt('Failed to set SO_REUSEADDR to %d: %d',[l,socketerror]);
528{$ENDIF}
529end;
530
531procedure TSocketServer.SetKeepAlive(AValue: Boolean);
532Var
533  L : cint;
534begin
535  L:=Ord(AValue);
536{$IFDEF UNIX}
537  if Not SetSockOpt(SOL_SOCKET, SO_KEEPALIVE, L, SizeOf(L)) then
538    Raise ESocketError.CreateFmt('Failed to set SO_REUSEADDR to %d: %d',[l,socketerror]);
539{$ENDIF}
540end;
541
542{ ---------------------------------------------------------------------
543    TInetServer
544  ---------------------------------------------------------------------}
545
546Constructor TInetServer.Create(APort: Word);
547
548begin
549  Create('0.0.0.0', aPort);
550end;
551
552Constructor TInetServer.Create(const aHost: string; const APort: Word);
553
554Var S : longint;
555
556begin
557  FHost:=aHost;
558  FPort:=APort;
559  S:=Sockets.FpSocket(AF_INET,SOCK_STREAM,0);
560  If S=-1 Then
561    Raise ESocketError.Create(seCreationFailed,[Format('%d',[APort])]);
562  Inherited Create(S);
563end;
564
565Procedure TInetServer.Bind;
566
567begin
568  Faddr.sin_family := AF_INET;
569  Faddr.sin_port := ShortHostToNet(FPort);
570  Faddr.sin_addr.s_addr := LongWord(StrToNetAddr(FHost));
571  if  Sockets.fpBind(FSocket, @FAddr, Sizeof(FAddr))<>0 then
572    raise ESocketError.Create(seBindFailed, [IntToStr(FPort)]);
573  FBound:=True;
574end;
575
576Function  TInetServer.SockToStream (ASocket : Longint) : TSocketStream;
577
578begin
579  Result:=TInetSocket.Create(ASocket);
580  (Result as TInetSocket).FHost:='';
581  (Result as TInetSocket).FPort:=FPort;
582end;
583
584Function TInetServer.Accept : Longint;
585
586Var l : longint;
587
588begin
589  L:=SizeOf(FAddr);
590  Result:=Sockets.fpAccept(Socket,@Faddr,@L);
591  If Result<0 then
592{$ifdef Unix}
593    If SocketError=ESysEWOULDBLOCK then
594      Raise ESocketError.Create(seAcceptWouldBlock,[socket])
595    else
596{$endif}
597      Raise ESocketError.Create(seAcceptFailed,[Socket,SocketError]);
598end;
599
600{ ---------------------------------------------------------------------
601    TUnixServer
602  ---------------------------------------------------------------------}
603{$ifdef Unix}
604Constructor TUnixServer.Create(AFileName : String);
605
606Var S : Longint;
607
608begin
609  FFileName:=AFileName;
610  S:=Sockets.fpSocket(AF_UNIX,SOCK_STREAM,0);
611  If S=-1 then
612    Raise ESocketError.Create(seCreationFailed,[AFileName])
613  else
614    Inherited Create(S);
615end;
616
617Procedure TUnixServer.Close;
618begin
619  Inherited Close;
620  DeleteFile(FFileName);
621  FFileName:='';
622end;
623
624Procedure TUnixServer.Bind;
625
626var
627  AddrLen  : longint;
628begin
629  Str2UnixSockAddr(FFilename,FUnixAddr,AddrLen);
630  If  Sockets.FpBind(Socket,@FUnixAddr,AddrLen)<>0 then
631    Raise ESocketError.Create(seBindFailed,[FFileName]);
632  FBound:=True;
633end;
634
635Function TUnixServer.Accept : Longint;
636
637Var L : longint;
638
639begin
640  L:=Length(FFileName);
641  Result:=Sockets.fpAccept(Socket,@FUnixAddr,@L);
642  If Result<0 then
643    If SocketError=ESysEWOULDBLOCK then
644      Raise ESocketError.Create(seAcceptWouldBlock,[socket])
645    else
646      Raise ESocketError.Create(seAcceptFailed,[socket,SocketError]);
647end;
648
649Function  TUnixServer.SockToStream (ASocket : Longint) : TSocketStream;
650
651begin
652  Result:=TUnixSocket.Create(ASocket);
653  (Result as TUnixSocket).FFileName:=FFileName;
654end;
655
656{$endif}
657
658{ ---------------------------------------------------------------------
659    TInetSocket
660  ---------------------------------------------------------------------}
661Constructor TInetSocket.Create(ASocket : Longint);
662
663begin
664  Inherited Create(ASocket);
665end;
666
667Constructor TInetSocket.Create(const AHost: String; APort: Word);
668
669Var
670  S : Longint;
671
672begin
673  FHost:=AHost;
674  FPort:=APort;
675  S:=fpSocket(AF_INET,SOCK_STREAM,0);
676  DoConnect(S);
677  Inherited Create(S);
678end;
679
680Procedure TInetSocket.DoConnect(ASocket : Longint);
681
682Var
683  A : THostAddr;
684  addr: TInetSockAddr;
685
686begin
687  A := StrToHostAddr(FHost);
688  if A.s_bytes[1] = 0 then
689    With THostResolver.Create(Nil) do
690      try
691        If Not NameLookup(FHost) then
692          raise ESocketError.Create(seHostNotFound, [FHost]);
693        A:=HostAddress;
694      finally
695        free;
696      end;
697  addr.sin_family := AF_INET;
698  addr.sin_port := ShortHostToNet(FPort);
699  addr.sin_addr.s_addr := HostToNet(a.s_addr);
700
701  If  Sockets.fpConnect(ASocket, @addr, sizeof(addr))<>0 then
702    raise ESocketError.Create(seConnectFailed, [Format('%s:%d',[FHost, FPort])]);
703end;
704
705{ ---------------------------------------------------------------------
706    TUnixSocket
707  ---------------------------------------------------------------------}
708{$ifdef Unix}
709Constructor TUnixSocket.Create(ASocket : Longint);
710
711begin
712  Inherited Create(ASocket);
713end;
714
715Constructor TUnixSocket.Create(AFileName : String);
716
717Var S : Longint;
718
719begin
720  FFileName:=AFileName;
721  S:=FpSocket(AF_UNIX,SOCK_STREAM,0);
722  DoConnect(S);
723  Inherited Create(S);
724end;
725
726Procedure TUnixSocket.DoConnect(ASocket : longint);
727
728Var
729  UnixAddr : TUnixSockAddr;
730  AddrLen  : longint;
731begin
732  Str2UnixSockAddr(FFilename,UnixAddr,AddrLen);
733  If  FpConnect(ASocket,@UnixAddr,AddrLen)<>0 then
734    Raise ESocketError.Create(seConnectFailed,[FFilename]);
735end;
736{$endif}
737end.