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.