Crtsock.pas
Материал из DRKB
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.