fpc/rtl/inc/sockets.inc

{
    $Id$
    This file is part of the Free Pascal run time library.
    Copyright (c) 1999-2000 by the Free Pascal development team

    See the file COPYING.FPC, included in this distribution,
    for details about the copyright.

    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.

 **********************************************************************}

{******************************************************************************
                     Text File Writeln/ReadLn Support
******************************************************************************}


Procedure OpenSock(var F:Text);
begin
  if textrec(f).handle=UnusedHandle then
   textrec(f).mode:=fmclosed
  else
   case textrec(f).userdata[1] of
     S_OUT : textrec(f).mode:=fmoutput;
     S_IN : textrec(f).mode:=fminput;
   else
    textrec(f).mode:=fmclosed;
   end;
end;



Procedure IOSock(var F:text);
begin
  case textrec(f).mode of
   fmoutput : {$ifdef unix}fpWrite{$else}fdwrite{$endif}(textrec(f).handle,textrec(f).bufptr^,textrec(f).bufpos);
    fminput : textrec(f).BufEnd:={$ifdef Unix}fpRead{$else}fdread{$endif}(textrec(f).handle,textrec(f).bufptr^,textrec(f).bufsize);
  end;
  textrec(f).bufpos:=0;
end;



Procedure FlushSock(var F:Text);
begin
  if (textrec(f).mode=fmoutput) and (textrec(f).bufpos<>0) then
   begin
     IOSock(f);
     textrec(f).bufpos:=0;
   end;
end;



Procedure CloseSock(var F:text);
begin
  { Nothing special has to be done here }
end;



Procedure Sock2Text(Sock:Longint;Var SockIn,SockOut:Text);
{
 Set up two Pascal Text file descriptors for reading and writing)
}
begin
{ First the reading part.}
  Assign(SockIn,'.');
  Textrec(SockIn).Handle:=Sock;
  Textrec(Sockin).userdata[1]:=S_IN;
  TextRec(SockIn).OpenFunc:=@OpenSock;
  TextRec(SockIn).InOutFunc:=@IOSock;
  TextRec(SockIn).FlushFunc:=@FlushSock;
  TextRec(SockIn).CloseFunc:=@CloseSock;
  TextRec(SockIn).Mode := fmInput;
{ Now the writing part. }
  Assign(SockOut,'.');
  Textrec(SockOut).Handle:=Sock;
  Textrec(SockOut).userdata[1]:=S_OUT;
  TextRec(SockOut).OpenFunc:=@OpenSock;
  TextRec(SockOut).InOutFunc:=@IOSock;
  TextRec(SockOut).FlushFunc:=@FlushSock;
  TextRec(SockOut).CloseFunc:=@CloseSock;
  TextRec(SockOut).Mode := fmOutput;
end;


{******************************************************************************
                                Untyped File
******************************************************************************}

Procedure Sock2File(Sock:Longint;Var SockIn,SockOut:File);
begin
{Input}
  Assign(SockIn,'.');
  FileRec(SockIn).Handle:=Sock;
  FileRec(SockIn).RecSize:=1;
  FileRec(Sockin).userdata[1]:=S_IN;
  FileRec(SockIn).Mode := fmInput;

{Output}
  Assign(SockOut,'.');
  FileRec(SockOut).Handle:=Sock;
  FileRec(SockOut).RecSize:=1;
  FileRec(SockOut).userdata[1]:=S_OUT;
  FileRec(SockOut).Mode := fmOutput;
end;

{******************************************************************************
                               InetSock
******************************************************************************}

Function DoAccept(Sock:longint;Var addr:TInetSockAddr):longint;

Var AddrLen : Longint;

begin
  AddrLEn:=SizeOf(Addr);
  DoAccept:=Accept(Sock,Addr,AddrLen);
end;

Function DoConnect(Sock:longint;const addr: TInetSockAddr): Boolean;

begin
  DoConnect:=Connect(Sock,Addr,SizeOF(TInetSockAddr));
end;

Function Connect(Sock:longint;const addr: TInetSockAddr;var SockIn,SockOut:text):Boolean;

begin
  Connect:=DoConnect(Sock,addr);
  If Connect then
     Sock2Text(Sock,SockIn,SockOut);
end;

Function Connect(Sock:longint;const addr:TInetSockAddr;var SockIn,SockOut:file):Boolean;

begin
  Connect:=DoConnect(Sock,addr);
  If Connect then
     Sock2File(Sock,SockIn,SockOut);
end;

Function Accept(Sock:longint;var addr:TInetSockAddr;var SockIn,SockOut:text):Boolean;
var
  s : longint;
begin
  S:=DoAccept(Sock,addr);
  if S>0 then
   begin
     Sock2Text(S,SockIn,SockOut);
     Accept:=true;
   end
  else
   Accept:=false;
end;

Function Accept(Sock:longint;var addr:TInetSockAddr;var SockIn,SockOut:File):Boolean;
var
  s : longint;
begin
  S:=DoAccept(Sock,addr);
  if S>0 then
   begin
     Sock2File(S,SockIn,SockOut);
     Accept:=true;
   end
  else
   Accept:=false;
end;

type thostaddr= packed array[1..4] of byte;

function htonl( host : longint):longint; {$ifdef HASINLINE} inline; {$ENDIF}

begin
{$ifdef FPC_BIG_ENDIAN}
  htonl:=host;
{$else}
  htonl:=THostAddr(host)[4];
  htonl:=htonl or ( (THostAddr(host)[3]) shl 8);
  htonl:=htonl or ( (THostAddr(host)[2]) shl 16);
  htonl:=htonl or ( (THostAddr(host)[1]) shl 24);
{$endif}
end;

Function NToHl (Net : Longint) : Longint;  {$ifdef HASINLINE} inline; {$ENDIF}

begin
{$ifdef FPC_BIG_ENDIAN}
  ntohl:=net;
{$else}
  ntohl:=THostAddr(Net)[4];
  ntohl:=ntohl or ( (THostAddr(Net)[3]) shl 8);
  ntohl:=ntohl or ( (THostAddr(Net)[2]) shl 16);
  ntohl:=ntohl or ( (THostAddr(Net)[1]) shl 24);
{$endif}
end;

function htons( host : word):word; {$ifdef HASINLINE} inline; {$ENDIF}

begin
{$ifdef FPC_BIG_ENDIAN}
  htons:=host;
{$else}
  htons:=swap(host);
{$endif}
end;

Function NToHs (Net : word):word;{$ifdef HASINLINE} inline; {$ENDIF}

begin
{$ifdef FPC_BIG_ENDIAN}
  ntohs:=net;
{$else}
  ntohs:=swap(net);
{$endif}
end;

Type array4int = array[1..4] of byte;

function NetAddrToStr (Entry : in_addr) : AnsiString;

Var Dummy : Ansistring;
    i,j   : Longint;

begin
  NetAddrToStr:='';
  j:=entry.s_addr;
  For I:=1 to 4 do
   begin
     Str(array4int(j)[i],Dummy);
     NetAddrToStr:=NetAddrToStr+Dummy;
     If I<4 Then
       NetAddrToStr:=NetAddrToStr+'.';
   end;
end;

function HostAddrToStr (Entry : in_addr) : AnsiString;

Var x: in_addr;

begin
  x.s_addr:=htonl(entry.s_addr);
  HostAddrToStr:=NetAddrToStr(x);
end;

function StrToHostAddr(IP : AnsiString) : in_addr ;

Var
    Dummy : AnsiString;
    I,j,k     : Longint;
    Temp : in_addr;

begin
  strtohostaddr.s_addr:=0;              //:=NoAddress;
  For I:=1 to 4 do
    begin
      If I<4 Then
        begin
          J:=Pos('.',IP);
          If J=0 then
            exit;
          Dummy:=Copy(IP,1,J-1);
          Delete (IP,1,J);
        end
       else
         Dummy:=IP;
      Val (Dummy,k,J);
      array4int(temp.s_addr)[i]:=k;
      If J<>0 then Exit;
   end;
   strtohostaddr.s_addr:=ntohl(Temp.s_addr);
end;

function StrToNetAddr(IP : AnsiString) : in_addr;

begin
  StrToNetAddr.s_addr:=htonl(StrToHostAddr(IP).s_addr);
end;

Function HostToNet (Host : in_addr):in_addr;

begin
  HostToNet.s_addr:=htonl(host.s_addr);
end;

Function NetToHost (Net : in_addr) : in_addr;

begin
  NetToHost.s_addr:=ntohl(net.s_addr);
end;

Function HostToNet (Host : Longint) : Longint;

begin
  HostToNet:=htonl(host);
end;

Function NetToHost (Net : Longint) : Longint;

begin
  NetToHost:=ntohl(net);
end;

Function ShortHostToNet (Host : Word) : Word;

begin
  ShortHostToNet:=htons(host);
end;

Function ShortNetToHost (Net : Word) : Word;

begin
  ShortNEtToHost:=ntohs(net);
end;

const digittab : shortstring = ('0123456789ABCDEF');

function lclinttohex (i:integer;digits:longint): ansistring;

var j,k : integer;

begin
  SetLength(lclinttohex,4);
  lclinttohex[4]:=digittab[1+(i and 15)];
  lclinttohex[3]:=digittab[1+((i shr 4) and 15)];
  lclinttohex[2]:=digittab[1+((i shr 8) and 15)];
  lclinttohex[1]:=digittab[1+((i shr 12) and 15)];;
end;

function HostAddrToStr6 (Entry : TIn6_Addr) :ansiString;
var
  i: byte;
  zr1,zr2: set of byte;
  zc1,zc2: byte;
  have_skipped: boolean;
begin
  zr1 := [];
  zr2 := [];
  zc1 := 0;
  zc2 := 0;
  for i := 0 to 7 do begin
    if Entry.u6_addr16[i] = 0 then begin
      include(zr2, i);
      inc(zc2);
    end else begin
      if zc1 < zc2 then begin
        zc1 := zc2;
        zr1 := zr2;
        zc2 := 0; zr2 := [];
      end;
    end;
  end;
  if zc1 < zc2 then begin
    zc1 := zc2;
    zr1 := zr2;
  end;
  SetLength(HostAddrToStr6, 8*5-1);
  SetLength(HostAddrToStr6, 0);
  have_skipped := false;
  for i := 0 to 7 do begin
    if not (i in zr1) then begin
      if have_skipped then begin
        if HostAddrToStr6 = ''
          then HostAddrToStr6 := '::'
          else HostAddrToStr6 := HostAddrToStr6 + ':';
        have_skipped := false;
      end;
      // FIXME: is that shortnettohost really proper there? I wouldn't be too sure...
      HostAddrToStr6 := HostAddrToStr6 +lclIntToHex(ShortNetToHost(Entry.u6_addr16[i]), 1) + ':';
    end else begin
      have_skipped := true;
    end;
  end;
  if have_skipped then
    if HostAddrToStr6 = ''
      then HostAddrToStr6 := '::'
      else HostAddrToStr6 := HostAddrToStr6 + ':';

  if HostAddrToStr6 = '' then HostAddrToStr6 := '::';
  if not (7 in zr1) then
    SetLength(HostAddrToStr6, Length(HostAddrToStr6)-1);
end;

function StrToHostAddr6(IP : String) : TIn6_addr;
begin
end;

function NetAddrToStr6 (Entry : TIn6_Addr) : ansiString;
begin
  netaddrtostr6 := HostAddrToStr6((Entry));
end;

function StrToNetAddr6(IP : ansiString) : TIn6_Addr;
begin
  StrToNetAddr6 := StrToHostAddr6(IP);
end;


{
  $Log$
  Revision 1.17  2005-03-18 10:04:31  marco
   * cosmetic fix in netaddrtostr

  Revision 1.16  2005/02/14 17:13:26  peter
    * truncate log

  Revision 1.15  2005/02/13 19:59:57  marco
   * More htons like functionality. IPV6 string support still missing

}