Sources
Delphi Russian Knowledge Base
DRKB - это самая большая и удобная в использовании база знаний по Дельфи в рунете, составленная Виталием Невзоровым
DRKB ➤ Интернет, Сети и Протоколы ➤ Сокеты ➤ CrtSock - модуль для работы с сокетами в Delphi32 ➤ Crtsock.pas
DRKB Banner

Все желающие могут разместить у себя на сайте баннер DRKB:

DRKB

Код баннера:


Top.Mail.Ru


Crtsock.pas

01.01.2007
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.
2001-2025,   DRKB Powered by yoCMS v.0.9.2, Ex.time: 0.0059s.