Crtsock.pas

unit crtsock;
{
 CrtSocket for Delphi 32
 Copyright (C) 1999-2001 Paul Toth <tothpaul@free.fr>
 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;
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;
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;
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;
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;
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.
Category:Связь
Category:Сокеты