Crtsock.pas

Code:

unit crtsock;

{

CrtSocket for Delphi 32

http://tothpaul.free.fr

This program is free software; you can redistribute it and/or

modify it under the terms of the GNU General Public License

as published by the Free Software Foundation; either version 2

of the License, or (at your option) any later version.

This program is distributed in the hope that it will be useful,

but WITHOUT ANY WARRANTY; without even the implied warranty of

MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the

GNU General Public License for more details.

You should have received a copy of the GNU General Public License

along with this program; if not, write to the Free Software

Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

}

interface

uses windows,sysutils;

{-$define debug}

// Server side :

// - start a server

// - wait for a client

function StartServer(Port:word):integer;

function WaitClient(Server:integer):integer;

function WaitClientEx(Server:integer; var ip:string):integer;

// Client side :

// - call a server

function CallServer(Server:string;Port:word):integer;

// Both side :

// - Assign CRT Sockets

// - Disconnect server

procedure AssignCrtSock(Socket:integer; Var Input,Output:TextFile);

procedure Disconnect(Socket:integer);

// BroadCasting (UDP)

function StartBroadCast(Port:word):integer;

function SendBroadCast(Server:integer; Port:word; s:string):integer;

function SendBroadCastTo(Server:integer; Port:word; ip,s:string):integer;

function ReadBroadCast(Server:integer; Port:word):string;

function ReadBroadCastEx(Server:integer; Port:word; var ip:string):string;

// BlockRead

function SockAvail(Socket:integer):integer;

function DataAvail(Var F:TextFile):integer;

Function BlockReadsock(Var F:TextFile; var s:string):boolean;

Function send(socket:integer; data:pointer; datalen,flags:integer):integer; stdcall; far;

Function recv(socket:integer; data:pchar; datalen,flags:integer):integer; stdcall; far;

// some usefull SOCKET apis

type

PHost = ^THost;

THost = packed record

name : PChar;

aliases : ^PChar;

addrtype : Smallint;

length : Smallint;

addr : ^pointer;

end;

TSockAddr=packed record

Family:word;

Port:word;

Addr:LongInt;

Zeros:array[0..7] of byte;

end;

TTimeOut=packed record

sec:integer;

usec:integer;

end;

Const

fIoNbRead = $4004667F;

Function socket(Family,Kind,Protocol:integer):integer; stdcall;

Function closesocket(socket:Integer):integer; stdcall;

Function gethostbyname(HostName:PChar):PHost; stdcall;

Function gethostname(name:pchar; size:integer):integer; stdcall;

Function bind(Socket:Integer; Var SockAddr:TSockAddr; AddrLen:integer):integer; stdcall;

Function WSAGetLastError:integer; stdcall;

Function ioctlsocket(socket:integer; cmd: integer; var arg: integer): Integer; stdcall;

// Convert an IP Value to xxx.xxx.xxx.xxx string

Function LongToIp(Long:LongInt):string;

Function IpToLong(ip:string):longint;

Function HostToLong(AHost:string):LongInt;

Var

EofSock:boolean;

implementation

//------ winsock -------------------------------------------------------

Const

WinSock='wsock32.dll'; { 32bits socket DLL }

Internet=2; { Internat familly }

Stream=1; { Streamed socket }

Datagrams=2;

// fIoNbRead = $4004667F;

sol_socket=$FFFF;

SO_BROADCAST = $0020; { permit sending of broadcast msgs }

Type

TWSAData = packed record

wVersion: Word;

wHighVersion: Word;

szDescription: array[0..256] of Char;

szSystemStatus: array[0..128] of Char;

iMaxSockets: Word;

iMaxUdpDg: Word;

lpVendorInfo: PChar;

end;

{ Winsock }

Function WSAStartup(Version:word; Var Data:TwsaData):integer; stdcall; far; external winsock;

Function socket(Family,Kind,Protocol:integer):integer; stdcall; far; external winsock;

Function shutdown(Socket,How:Integer):integer; stdcall; far; external winsock;

Function closesocket(socket:Integer):integer; stdcall; far; external winsock;

Function WSACleanup:integer; stdcall; far; external winsock;

//Function WSAAsyncSelect(Socket:Integer; Handle:Hwnd; Msg:word; Level:Longint):longint; stdcall; far; external winsock;

Function bind(Socket:Integer; Var SockAddr:TSockAddr; AddrLen:integer):integer; stdcall; far; external winsock;

Function listen(socket,flags:Integer):integer; stdcall; far; external winsock;

Function connect(socket:Integer; Var SockAddr:TSockAddr; AddrLen:integer):integer; stdcall; far; external winsock;

Function accept(socket:Integer; Var SockAddr:TSockAddr; Var AddrLen:Integer):integer; stdcall; far; external winsock;

Function WSAGetLastError:integer; stdcall; far; external winsock;

Function recv(socket:integer; data:pchar; datalen,flags:integer):integer; stdcall; far; external winsock;

Function send(socket:integer; data:pointer; datalen,flags:integer):integer; stdcall; far; external winsock;

//Function getpeername(socket:integer; var SockAddr:TSockAddr; Var AddrLen:Integer):Integer; stdcall; far; external winsock;

Function gethostbyname(HostName:PChar):PHost; stdcall; far; external winsock;

//Function getsockname(socket:integer; var SockAddr:TSockAddr; Var AddrLen:Integer):integer; stdcall; far; external winsock;

//Function inet_ntoa(addr:longint):PChar; stdcall; far; external winsock;

Function WSAIsBlocking:boolean; stdcall; far; external winsock;

Function WSACancelBlockingCall:integer; stdcall; far; external winsock;

Function ioctlsocket(socket:integer; cmd: integer; var arg: integer): Integer; stdcall; far; external winsock;

//Function gethostbyaddr(var addr:longint; size,atype:integer):PHost; stdcall; far; external winsock;

Function gethostname(name:pchar; size:integer):integer; stdcall; far; external winsock;

function select(nfds:integer; readfds, writefds, exceptfds:pointer; var timeout:TTimeOut):integer; stdcall; far; external winsock;

function setsockopt(socket,level,optname:integer;var optval; optlen:integer):integer; stdcall; far; external winsock;

Function sendto(socket:integer; data:pointer; datalen,flags:integer; var SockAddr:TSockAddr; AddrLen:Integer):integer; stdcall; far; external winsock;

Function recvfrom(socket:integer; data:pointer; datalen,flags:integer; var SockAddr:TSockAddr; var AddrLen:Integer):integer; stdcall; far; external winsock;

Function IpToLong(ip:string):LongInt;

var

x,i:byte;

ipx:array[0..3] of byte;

v:integer;

begin

Result:=0;

longint(ipx):=0; i:=0;

for x:=1 to length(ip) do

if ip[x]='.' then begin

inc(i);

if i=4 then exit;

end else begin

if not (ip[x] in ['0'..'9']) then exit;

v:=ipx[i]*10+ord(ip[x])-ord('0');

if v>255 then exit;

ipx[i]:=v;

end;

result:=longint(ipx);

end;

Function HostToLong(AHost:string):LongInt;

Var

Host:PHost;

begin

Result:=IpToLong(AHost);

if Result=0 then begin

Host:=GetHostByName(PChar(AHost));

if Host<>nil then Result:=longint(Host^.Addr^^);

end;

Function LongToIp(Long:LongInt):string;

var

ipx:array[0..3] of byte;

i:byte;

begin

longint(ipx):=long;

Result:='';

for i:=0 to 3 do result:=result+IntToStr(ipx[i])+'.';

SetLength(Result,Length(Result)-1);

end;

//--- Server Side ------------------------------------------------------------------------

function StartServer(Port:word):integer;

Var

SockAddr:TSockAddr;

begin

Result:=socket(Internet,Stream,0);

if Result=-1 then exit;

FillChar(SockAddr,SizeOf(SockAddr),0);

SockAddr.Family:=Internet;

SockAddr.Port:=swap(Port);

if (Bind(Result,SockAddr,SizeOf(SockAddr))<>0)

or (Listen(Result,0)<>0) then begin

CloseSocket(Result);

Result:=-1;

end;

function WaitClient(Server:integer):integer;

var

Client:TSockAddr;

Size:integer;

begin

Size:=SizeOf(Client);

Result:=Accept(Server,Client,Size);

end;

function WaitClientEx(Server:integer; var ip:string):integer;

var

Client:TSockAddr;

Size:integer;

begin

Size:=SizeOf(Client);

Result:=Accept(Server,Client,Size);

ip:=LongToIp(Client.Addr);

end;

function SockReady(Socket:integer):boolean;

var

sockset:packed record

count:integer;

socks:{array[0..63] of} integer;

end;

timeval:TTimeOut;

begin

sockSet.count:=1;

sockSet.socks:=Socket;

timeval.sec :=0;

timeval.usec :=0;

result:=Select(0,@sockSet,nil,nil,timeval)>0;

end;

function SockAvail(Socket:integer):integer;

var

rdy:boolean;

begin

rdy:=SockReady(Socket); // before IoCtlSocket to be sure (?) that we don't get some data between the 2 calls

if IoctlSocket(Socket, fIoNbRead,Result)<0 then

Result:=-1

else begin

if (Result=0) and RDY then result:=-1; // SockReady is TRUE when Data ara Avaible AND when Socket is closed

end;

function DataAvail(Var F:TextFile):integer;

var

s:integer;

begin

// cause of TexTFile Buffer, we need to check both Buffer & Socket !

With TTextRec(F) do begin

Result:=BufEnd-BufPos;

s:=SockAvail(Handle);

end;

if Result=0 then Result:=s else if s>0 then Inc(Result,s);

end;

Function BlockReadSock(Var F:TextFile; var s:string):boolean;

Var

Handle:THandle;

Size:integer;

begin

Result:=False;

Handle:=TTextRec(F).Handle;

Repeat

if (IoctlSocket(Handle, fIoNbRead, Size)<0) then exit;

if Size=0 then exit

until (Size>0);

SetLength(s,Size);

Recv(Handle,pchar(s),Size,0);

Result:=True;

end;

// Client Side--------------------------------------------------------------------------

function CallServer(Server:string; Port:word):integer;

var

SockAddr:TSockAddr;

begin

Result:=socket(Internet,Stream,0);

if Result=-1 then exit;

FillChar(SockAddr,SizeOf(SockAddr),0);

SockAddr.Family:=Internet;

SockAddr.Port:=swap(Port);

SockAddr.Addr:=HostToLong(Server);

if Connect(Result,SockAddr,SizeOf(SockAddr))<>0 then begin

Disconnect(Result);

Result:=-1;

end;

// BroadCasting-------------------------------------

function StartBroadCast(Port:word):integer;

Var

SockAddr:TSockAddr;

bc:integer;

begin

Result:=socket(Internet,Datagrams,17); // 17 for UDP ... work also with 0 ?!

if Result=-1 then exit;

FillChar(SockAddr,SizeOf(SockAddr),0);

SockAddr.Family:=Internet;

SockAddr.Port:=swap(Port);

// SockAddr.Addr:=0; ?

bc:=SO_BROADCAST;

if (Bind(Result,SockAddr,SizeOf(SockAddr))<>0)

or (setsockopt(Result,SOL_SOCKET,SO_BROADCAST,bc,SizeOf(bc))<>0) then begin

CloseSocket(Result);

Result:=-1;

end;

function SendBroadCast(Server:integer; Port:word; s:string):integer;

Var

SockAddr:TSockAddr;

begin

SockAddr.Family:=Internet;

SockAddr.Port:=swap(Port);

SockAddr.Addr:=-1;

Result:=SendTo(Server,@s[1],length(s),0,SockAddr,SizeOf(SockAddr));

end;

function SendBroadCastTo(Server:integer; Port:word; ip,s:string):integer;

Var

SockAddr:TSockAddr;

begin

SockAddr.Family:=Internet;

SockAddr.Port:=swap(Port);

SockAddr.Addr:=IpToLong(ip);

Result:=SendTo(Server,@s[1],length(s),0,SockAddr,SizeOf(SockAddr));

end;

function ReadBroadCast(Server:integer; Port:word):string;

Var

SockAddr:TSockAddr;

SockLen:integer;

len:integer;

begin

FillChar(SockAddr,SizeOf(SockAddr),0);

SockAddr.Family:=Internet;

SockAddr.Port:=swap(Port);

SockLen:=SizeOf(SockAddr);

setlength(result,1024);

len:=recvfrom(Server,@result[1],1024,0,SockAddr,SockLen);

if len>0 then SetLength(result,len) else result:='';

end;

function ReadBroadCastEx(Server:integer; Port:word; var ip:string):string;

Var

SockAddr:TSockAddr;

SockLen:integer;

len:integer;

begin

FillChar(SockAddr,SizeOf(SockAddr),0);

SockAddr.Family:=Internet;

SockAddr.Port:=swap(Port);

SockLen:=SizeOf(SockAddr);

setlength(result,1024);

len:=recvfrom(Server,@result[1],1024,0,SockAddr,SockLen);

if len>0 then SetLength(result,len) else result:='';

ip:=LongToIp(SockAddr.Addr);

end;

//------------ CrtSock -----------------

Var

InitOk:boolean;

function OutputSock(Var F:TTextRec):integer; far;

begin

{$ifdef debug}writeln('out ',F.BufPtr);{$endif}

if F.BufPos<>0 then begin

Send(F.Handle,F.BufPtr,F.BufPos,0);

F.BufPos:=0;

end;

Result:=0;

end;

function InputSock(var F: TTextRec): Integer; far;

Var

Size:integer;

begin

F.BufEnd:=0;

F.BufPos:=0;

Result:=0;

Repeat

if (IoctlSocket(F.Handle, fIoNbRead, Size)<0) then begin

EofSock:=True;

exit;

end;

until (Size>=0);

//if Size>0 then

F.BufEnd:=Recv(F.Handle,F.BufPtr,F.BufSize,0);

EofSock:=(F.BufEnd=0);

{$ifdef debug}writeln('in ',F.BufPtr);{$endif}

end;

procedure Disconnect(Socket:integer);

var

dummy:array[0..1024] of char;

begin

ShutDown(Socket,1);

repeat until recv(Socket,dummy,1024,0)<=0;

CloseSocket(Socket);

end;

function CloseSock(var F:TTextRec):integer; far;

begin

Disconnect(F.Handle);

F.Handle:=-1;

Result:=0;

end;

function OpenSock(var F: TTextRec): Integer; far;

begin

F.BufPos:=0;

F.BufEnd:=0;

if F.Mode = fmInput then begin // ReadLn

EofSock:=False;

F.InOutFunc := @InputSock;

F.FlushFunc := nil;

end else begin // WriteLn

F.Mode := fmOutput;

F.InOutFunc := @OutputSock;

F.FlushFunc := @OutputSock;

end;

F.CloseFunc := @CloseSock;

Result:=0;

end;

Procedure AssignCrtSock(Socket:integer; Var Input,Output:TextFile);

begin

with TTextRec(Input) do begin

Handle := Socket;

Mode := fmClosed;

BufSize := SizeOf(Buffer);

BufPtr := @Buffer;

OpenFunc := @OpenSock;

end;

with TTextRec(Output) do begin

Handle := Socket;

Mode := fmClosed;

BufSize := SizeOf(Buffer);

BufPtr := @Buffer;

OpenFunc := @OpenSock;

end;

Reset(Input);

Rewrite(Output);

end;

//----- Initialization/Finalization--------------------------------------------------

Procedure InitCrtSock;

var

wsaData:TWSAData;

begin

InitOk:=wsaStartup($101,wsaData)=0;

{$ifdef debug}allocconsole{$endif}

end;

Procedure DoneCrtSock;

begin

if not InitOk then exit;

if wsaIsBlocking then wsaCancelBlockingCall;

wsaCleanup;

end;

Initialization InitCrtSock;

Finalization DoneCrtSock;

end.