paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-26 20:50:30 +02:00
Code Issues Packages Projects Releases Wiki Activity

* added setsocketoptions + pulled it through source beautifier

Browse Source
This commit is contained in:
marco 2000-06-05 07:19:32 +00:00
parent 26e15a2e1d
commit ab086a8e20
1 changed files with 181 additions and 164 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

345
docs/sockex/serverex.pp
View File

@ -9,14 +9,14 @@ Program Socket_Comms_Test;
to the port number. to the port number.
This program runs as-is, just telnet localhost 5000 to connect to it. This program runs as-is, just telnet localhost 5000 to connect to it.
No warranty at all, I will not be responsible if this sets fire to your dog! No warranty at all, I will not be responsible if this sets fire to your dog!
This is exactly as I use it, I have just put the references to my db unit This is exactly as I use it, I have just put the references to my db unit
in curly brackets. It just echoes back what you type on a line by line basis in curly brackets. It just echoes back what you type on a line by line basis
Run it in X or on a seperate virtual console to the one you are telneting from Run it in X or on a seperate virtual console to the one you are telneting from
as it prints a LOT of info to the console about what it is doing and such. as it prints a LOT of info to the console about what it is doing and such.
I'm not a pretty coder at all, so please, no complaints about the lack of I'm not a pretty coder at all, so please, no complaints about the lack of
comments or coding style, unless they are very contructive ;p) comments or coding style, unless they are very contructive ;p)
type 'quit', minus the quotes and in lower case on the console to exit the type 'quit', minus the quotes and in lower case on the console to exit the
program. The only problem I can see with this, is if you exit it, it does program. The only problem I can see with this, is if you exit it, it does
not shut down the connections to the telnet sessions cleanly, and therefore not shut down the connections to the telnet sessions cleanly, and therefore
@ -26,256 +26,273 @@ Program Socket_Comms_Test;
If you know how to fix this, please let me know and I'll update the code. If you know how to fix this, please let me know and I'll update the code.
If you exit all your telnet sessions before shutting the server down, it If you exit all your telnet sessions before shutting the server down, it
works fine. works fine.
Hope some of you find this usefull. I wrote it, purely because there is a Hope some of you find this usefull. I wrote it, purely because there is a
big lack of examples of linux port use in FPC. And I know NO C, therefore big lack of examples of linux port use in FPC. And I know NO C, therefore
the examples on the net meant nothing to me. the examples on the net meant nothing to me.
All I ask is :- All I ask is :-
If you like it, use it or want to change it, please drop me an E-mail. If you like it, use it or want to change it, please drop me an E-mail.
Regards Brad Campbell Regards Brad Campbell
bcampbel@omen.net.au bcampbel@omen.net.au
***************************************************************************} ***************************************************************************}
{$mode ObjFPC}
Uses Linux, Sockets, Sysutils{, dbu}; Uses Linux, Sockets, Sysutils{, dbu};
Const Const
NumberofConnections = 5; NumberofConnections = 5;
Type ConnectionType = Record Type ConnectionType = Record
IP : Cardinal; IP : Cardinal;
Port : Word; Port : Word;
Handle : Integer; Handle : Integer;
Connected : Boolean; Connected : Boolean;
IdleTimer : Integer; IdleTimer : Integer;
End; End;
Var Var
Connection : Array[1..NumberofConnections] of ConnectionType; Connection : Array[1..NumberofConnections] Of ConnectionType;
FDS : FDSet; FDS : FDSet;
S : LongInt; S : LongInt;
PortNumber : Word; PortNumber : Word;
GreatestHandle : Integer; GreatestHandle : Integer;
Quit : Boolean; Quit : Boolean;
Command : String; Command : String;
Procedure ZeroConnection; Procedure ZeroConnection;
Var Loop : Integer; Var Loop : Integer;
Begin Begin
For Loop := 1 to NumberOfConnections do For Loop := 1 To NumberOfConnections Do
Connection[Loop].Connected := False; Connection[Loop].Connected := False;
End; End;
Function FreeConnections : Integer; Function FreeConnections : Integer;
Var Loop : Integer;
Result : Integer; Var Loop : Integer;
Begin Begin
Result := 0; Result := 0;
For Loop := 1 to NumberOfConnections do For Loop := 1 To NumberOfConnections Do
If Not Connection[Loop].Connected then Result := Result + 1; If Not Connection[Loop].Connected Then Inc(Result);
FreeConnections := Result; FreeConnections := Result;
End; End;
Function GetFreeConnection : Integer; Function GetFreeConnection : Integer;
Var Loop : Integer; Var Loop : Integer;
Result : Integer; Found : Boolean;
Found : Boolean;
Begin Begin
Result := 0; Result := 0;
Loop := 1; Loop := 1;
Found := False; Found := False;
While (Loop < NumberOfConnections + 1) and (Not Found) do While (Loop < NumberOfConnections + 1) and (Not Found) Do
Begin Begin
If Not Connection[Loop].Connected then If Not Connection[Loop].Connected Then
Begin Begin
Found := True; Found := True;
Result := Loop; Result := Loop;
End; End;
Loop := Loop + 1; Inc(Loop);
GetFreeConnection := Result; GetFreeConnection := Result;
End; End;
End; End;
Procedure PError(S : String); Procedure PError(S : String);
Begin Begin
Writeln(S,SocketError); Writeln(S,SocketError);
Halt(100); Halt(100);
End; End;
Procedure PDebug(S : String); Procedure PDebug(S : String);
Begin Begin
Writeln(S); Writeln(S);
End; End;
Procedure PDebugNOLF(S: String); Procedure PDebugNOLF(S: String);
Begin Begin
Write(S); Write(S);
End; End;
Function SockAddrtoString(InAddr : LongWord) : String; Function SockAddrtoString(InAddr : LongWord) : String;
Var Var
P1,P2,P3,P4 : Byte; P1,P2,P3,P4 : Byte;
S1,S2,S3,S4 : String; S1,S2,S3,S4 : String;
Begin Begin
P1 := (InAddr And $ff000000) Shr 24; P1 := (InAddr And $ff000000) Shr 24;
P2 := (InAddr And $ff0000) Shr 16; P2 := (InAddr And $ff0000) Shr 16;
P3 := (InAddr And $ff00) Shr 8; P3 := (InAddr And $ff00) Shr 8;
P4 := InAddr And $FF; P4 := InAddr And $FF;
Str(P1,S1); Str(P1,S1);
Str(P2,S2); Str(P2,S2);
Str(P3,S3); Str(P3,S3);
Str(P4,S4); Str(P4,S4);
SockAddrtoString := S4+'.'+S3+'.'+S2+'.'+S1; SockAddrtoString := S4+'.'+S3+'.'+S2+'.'+S1;
End; End;
Procedure WelcomeHandle(Handle, ConnNum : Integer); Procedure WelcomeHandle(Handle, ConnNum : Integer);
Var Buffer : String;
Sent : Integer; Var Buffer : String;
Sent : Integer;
Begin Begin
Buffer := 'Welcome to Brads Server 1.0'+#10+#13+'You Are Connection '+ Buffer := 'Welcome to Brads Server 1.0'+#10+#13+'You Are Connection '+
InttoStr(ConnNum)+' Of '+InttoStr(NumberofConnections)+ InttoStr(ConnNum)+' Of '+InttoStr(NumberofConnections)+
', With '+InttoStr(FreeConnections)+' Connections Free'#13+#10; ', With '+InttoStr(FreeConnections)+' Connections Free'#13+#10;
Sent := Send(Handle,Buffer[1],Length(Buffer),0); Sent := Send(Handle,Buffer[1],Length(Buffer),0);
If Sent <> Length(Buffer) then PDebug('Wanted to Send : ' If Sent <> Length(Buffer) Then
+InttoStr(Length(Buffer))+' Sent Only : '+InttoStr(Sent)+ PDebug('Wanted to Send : ' +InttoStr(Length(Buffer))+' Sent Only : '
' to Connection : '+InttoStr(ConnNum)); +InttoStr(Sent)+' to Connection : '+InttoStr(ConnNum));
End; End;
Procedure AcceptNewConnection; Procedure AcceptNewConnection;
Var ConnectionNumber : Integer; Var ConnectionNumber : Integer;
Handle : LongInt; Handle : LongInt;
FromAddrSize : LongInt; FromAddrSize : LongInt;
FromAddr : TInetSockAddr; FromAddr : TInetSockAddr;
Begin Begin
FromAddrSize := Sizeof(FromAddr); FromAddrSize := Sizeof(FromAddr);
If FreeConnections > 0 then Begin If FreeConnections > 0 Then
ConnectionNumber := GetFreeConnection; Begin
PDebug('Accepting New Connection Number : '+InttoStr(ConnectionNumber)); ConnectionNumber := GetFreeConnection;
Handle := Accept(S,FromAddr,FromAddrSize); PDebug('Accepting New Connection Number : '+InttoStr(ConnectionNumber));
If Handle < 0 then PError('Accept Error!!'); Handle := Accept(S,FromAddr,FromAddrSize);
PDebug('Accepted From : '+SockAddrtoString(FromAddr.Addr)+' Port : ' If Handle < 0 Then PError('Accept Error!!');
+Inttostr(Swap(FromAddr.Port))); PDebug('Accepted From : '+SockAddrtoString(FromAddr.Addr)+' Port : '
Connection[ConnectionNumber].Handle := Handle; +Inttostr(Swap(FromAddr.Port)));
Connection[ConnectionNumber].IP := FromAddr.Addr; Connection[ConnectionNumber].Handle := Handle;
Connection[ConnectionNumber].Port := FromAddr.Port; Connection[ConnectionNumber].IP := FromAddr.Addr;
Connection[ConnectionNumber].Connected := True; Connection[ConnectionNumber].Port := FromAddr.Port;
Connection[ConnectionNumber].IdleTimer := 0; Connection[ConnectionNumber].Connected := True;
WelcomeHandle(Handle,ConnectionNumber); Connection[ConnectionNumber].IdleTimer := 0;
End; WelcomeHandle(Handle,ConnectionNumber);
End;
End; End;
Procedure SetUpSocket; Procedure SetUpSocket;
Var Var
SockAddr : TInetSockAddr; SockAddr : TInetSockAddr;
yes : longint;
Begin Begin
SockAddr.Family := AF_INET; SockAddr.Family := AF_INET;
SockAddr.Port := Swap(PortNumber); SockAddr.Port := Swap(PortNumber);
SockAddr.Addr := 0; SockAddr.Addr := 0;
S := Socket(AF_INET,SOCK_STREAM,0); S := Socket(AF_INET,SOCK_STREAM,0);
If SocketError <> 0 then PError('Socket Error : '); If SocketError <> 0 Then PError('Socket Error : ');
If not Bind(S,SockAddr,SizeOf(SockAddr)) then PError('Bind Error : '); yes := $1010101; {Copied this from existing code. Value is empiric,
If not Listen(S,5) then PError('Listen Error : '); but works. (yes=true<>0) }
SetSocketOptions(s, SOL_SOCKET, SO_REUSEADDR,yes,sizeof(yes));
If Not Bind(S,SockAddr,SizeOf(SockAddr)) Then PError('Bind Error : ');
If Not Listen(S,5) Then PError('Listen Error : ');
End; End;
Procedure LoadConnectedFDS; Procedure LoadConnectedFDS;
Var Loop : Integer; Var Loop : Integer;
Begin Begin
For Loop := 1 to NumberOfConnections Do For Loop := 1 To NumberOfConnections Do
If Connection[Loop].Connected then If Connection[Loop].Connected Then
Begin Begin
FD_SET(Connection[Loop].Handle,FDS); FD_SET(Connection[Loop].Handle,FDS);
If Connection[Loop].Handle > GreatestHandle then If Connection[Loop].Handle > GreatestHandle Then
GreatestHandle := Connection[Loop].Handle; GreatestHandle := Connection[Loop].Handle;
End; End;
End; End;
Procedure ServiceHandle(Handle, ConnectionNum : Integer); Procedure ServiceHandle(Handle, ConnectionNum : Integer);
Var Buffer : String; Var Buffer : String;
Sent, BufferLength : Integer; Sent, BufferLength : Integer;
Begin
Writeln('Service Handle : ',Handle);
BufferLength := Recv(Handle,Buffer[1],200,0);
Setlength(Buffer,BufferLength);
If SocketError <> 0 then PDebug('Reciceved Socket Error : '
+InttoStr(SocketError)+' OnHandle '+InttoStr(Handle));
If BufferLength = 0 then {It's EOF, Socket has been closed}
Begin Begin
PDebug('Socket Handle '+InttoStr(Handle)+' Closed'); Writeln('Service Handle : ',Handle);
Connection[ConnectionNum].Connected := False; BufferLength := Recv(Handle,Buffer[1],200,0);
Shutdown(Handle,2); Setlength(Buffer,BufferLength);
fdClose(Handle); If SocketError <> 0 Then
End PDebug('Reciceved Socket Error : '
+InttoStr(SocketError)+' OnHandle '+InttoStr(Handle));
Else Begin If BufferLength = 0 Then {It's EOF, Socket has been closed}
PDebug(InttoStr(BufferLength)+' Bytes Recieved'); Begin
{Buffer := Db_Query(Buffer);} PDebug('Socket Handle '+InttoStr(Handle)+' Closed');
Sent := Send(Handle,Buffer[1],Length(Buffer),0); Connection[ConnectionNum].Connected := False;
If Sent <> Bufferlength then Shutdown(Handle,2);
PDebug('Wanted to Send : '+InttoStr(Length(Buffer))+' Only Sent : '+InttoStr(Sent)); fdClose(Handle);
End; End
Else
Begin
PDebug(InttoStr(BufferLength)+' Bytes Recieved');
{Buffer := Db_Query(Buffer);}
Sent := Send(Handle,Buffer[1],Length(Buffer),0);
If Sent <> Bufferlength Then
PDebug('Wanted to Send : '+InttoStr(Length(Buffer))+' Only Sent : '+InttoStr(Sent));
End;
End; End;
Procedure ServiceSockets; Procedure ServiceSockets;
Var Loop : Integer; Var Loop : Integer;
Begin Begin
For Loop := 1 to NumberOfConnections do For Loop := 1 To NumberOfConnections Do
If Connection[Loop].Connected then If Connection[Loop].Connected Then
If FD_ISSET(Connection[Loop].Handle,FDS) Then If FD_ISSET(Connection[Loop].Handle,FDS) Then
ServiceHandle(Connection[Loop].Handle,Loop); ServiceHandle(Connection[Loop].Handle,Loop);
IF FD_ISSET(S,FDS) then AcceptNewConnection; If FD_ISSET(S,FDS) Then AcceptNewConnection;
End; End;
Procedure CloseAllOpen; Procedure CloseAllOpen;
Var Loop : Integer; Var Loop : Integer;
Begin Begin
For Loop := 1 to NumberOfConnections do For Loop := 1 To NumberOfConnections Do
Begin Begin
If Connection[Loop].Connected = True then If Connection[Loop].Connected = True Then
Begin Begin
Shutdown(Connection[Loop].Handle,1); Shutdown(Connection[Loop].Handle,1);
{ fdClose(Connection[Loop].Handle);} { fdClose(Connection[Loop].Handle);}
{Connection[Loop].Connected := False;} {Connection[Loop].Connected := False;}
End; End;
End; End;
End; End;
begin
ZeroConnection; {Clear Connected Array}
Quit := False;
PortNumber := 5000;
SetupSocket;
Repeat
FD_ZERO(FDS);
FD_SET(S,FDS); { Socket Looking for new connections }
FD_SET(1,FDS); { Terminal }
GreatestHandle := S;
LoadConnectedFDS;
If Select(GreatestHandle+1,@FDS,nil,nil,1000) > 0 then
Begin Begin
ServiceSockets; ZeroConnection; {Clear Connected Array}
If FD_ISSET(1,FDS) then Quit := False;
Begin PortNumber := 5000;
PDebug('Reading Console'); SetupSocket;
Readln(Command); Repeat
If Command='quit' then quit := True; FD_ZERO(FDS);
FD_SET(S,FDS); { Socket Looking for new connections }
FD_SET(1,FDS); { Terminal }
GreatestHandle := S;
LoadConnectedFDS;
If Select(GreatestHandle+1,@FDS,Nil,Nil,1000) > 0 Then
Begin
ServiceSockets;
If FD_ISSET(1,FDS) Then
Begin
PDebug('Reading Console');
Readln(Command);
If Command='quit' Then quit := True;
{ Else Writeln(DB_Query(Command));} { Else Writeln(DB_Query(Command));}
Command := ''; Command := '';
End; End;
End; End;
{DB_Tic;} {Updates Database Internals, Needs at Least 1 run per second} {DB_Tic;} {Updates Database Internals, Needs at Least 1 run per second}
Until Quit = True; Until Quit = True;
CloseAllOpen; CloseAllOpen;
End. End.