{==============================================================================|
| Project : Ararat Synapse                                       | 001.002.001 |
|==============================================================================|
| Content: IP address support procedures and functions                         |
|==============================================================================|
| Copyright (c)2006-2010, Lukas Gebauer                                        |
| All rights reserved.                                                         |
|                                                                              |
| Redistribution and use in source and binary forms, with or without           |
| modification, are permitted provided that the following conditions are met:  |
|                                                                              |
| Redistributions of source code must retain the above copyright notice, this  |
| list of conditions and the following disclaimer.                             |
|                                                                              |
| Redistributions in binary form must reproduce the above copyright notice,    |
| this list of conditions and the following disclaimer in the documentation    |
| and/or other materials provided with the distribution.                       |
|                                                                              |
| Neither the name of Lukas Gebauer nor the names of its contributors may      |
| be used to endorse or promote products derived from this software without    |
| specific prior written permission.                                           |
|                                                                              |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
| DAMAGE.                                                                      |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 2006-2010.               |
| All Rights Reserved.                                                         |
|==============================================================================|
| Contributor(s):                                                              |
|==============================================================================|
| History: see HISTORY.HTM from distribution package                           |
|          (Found at URL: http://www.ararat.cz/synapse/)                       |
|==============================================================================}

{:@abstract(IP adress support procedures and functions)}

{$IFDEF FPC}
  {$MODE DELPHI}
{$ENDIF}
{$Q-}
{$R-}
{$H+}

{$IFDEF UNICODE}
  {$WARN IMPLICIT_STRING_CAST OFF}
  {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
  {$WARN SUSPICIOUS_TYPECAST OFF}
{$ENDIF}

unit synaip;

interface

uses
  SysUtils, SynaUtil;

type
{:binary form of IPv6 adress (for string conversion routines)}
  TIp6Bytes = array [0..15] of Byte;
{:binary form of IPv6 adress (for string conversion routines)}
  TIp6Words = array [0..7] of Word;

{:Returns @TRUE, if "Value" is a valid IPv4 address. Cannot be a symbolic Name!}
function IsIP(const Value: string): Boolean;

{:Returns @TRUE, if "Value" is a valid IPv6 address. Cannot be a symbolic Name!}
function IsIP6(const Value: string): Boolean;

{:Returns a string with the "Host" ip address converted to binary form.}
function IPToID(Host: string): Ansistring;

{:Convert IPv6 address from their string form to binary byte array.}
function StrToIp6(value: string): TIp6Bytes;

{:Convert IPv6 address from binary byte array to string form.}
function Ip6ToStr(value: TIp6Bytes): string;

{:Convert IPv4 address from their string form to binary.}
function StrToIp(value: string): integer;

{:Convert IPv4 address from binary to string form.}
function IpToStr(value: integer): string;

{:Convert IPv4 address to reverse form.}
function ReverseIP(Value: AnsiString): AnsiString;

{:Convert IPv6 address to reverse form.}
function ReverseIP6(Value: AnsiString): AnsiString;

{:Expand short form of IPv6 address to long form.}
function ExpandIP6(Value: AnsiString): AnsiString;


implementation

{==============================================================================}

function IsIP(const Value: string): Boolean;
var
  TempIP: string;
  function ByteIsOk(const Value: string): Boolean;
  var
    x, n: integer;
  begin
    x := StrToIntDef(Value, -1);
    Result := (x >= 0) and (x < 256);
    // X may be in correct range, but value still may not be correct value!
    // i.e. "$80"
    if Result then
      for n := 1 to length(Value) do
        if not (AnsiChar(Value[n]) in ['0'..'9']) then
        begin
          Result := False;
          Break;
        end;
  end;
begin
  TempIP := Value;
  Result := False;
  if not ByteIsOk(Fetch(TempIP, '.')) then
    Exit;
  if not ByteIsOk(Fetch(TempIP, '.')) then
    Exit;
  if not ByteIsOk(Fetch(TempIP, '.')) then
    Exit;
  if ByteIsOk(TempIP) then
    Result := True;
end;

{==============================================================================}

function IsIP6(const Value: string): Boolean;
var
  TempIP: string;
  s,t: string;
  x: integer;
  partcount: integer;
  zerocount: integer;
  First: Boolean;
begin
  TempIP := Value;
  Result := False;
  if Value = '::' then
  begin
    Result := True;
    Exit;
  end;
  partcount := 0;
  zerocount := 0;
  First := True;
  while tempIP <> '' do
  begin
    s := fetch(TempIP, ':');
    if not(First) and (s = '') then
      Inc(zerocount);
    First := False;
    if zerocount > 1 then
      break;
    Inc(partCount);
    if s = '' then
      Continue;
    if partCount > 8 then
      break;
    if tempIP = '' then
    begin
      t := SeparateRight(s, '%');
      s := SeparateLeft(s, '%');
      x := StrToIntDef('$' + t, -1);
      if (x < 0) or (x > $ffff) then
        break;
    end;
    x := StrToIntDef('$' + s, -1);
    if (x < 0) or (x > $ffff) then
      break;
    if tempIP = '' then
      if not((PartCount = 1) and (ZeroCount = 0)) then
        Result := True;
  end;
end;

{==============================================================================}
function IPToID(Host: string): Ansistring;
var
  s: string;
  i, x: Integer;
begin
  Result := '';
  for x := 0 to 3 do
  begin
    s := Fetch(Host, '.');
    i := StrToIntDef(s, 0);
    Result := Result + AnsiChar(i);
  end;
end;

{==============================================================================}

function StrToIp(value: string): integer;
var
  s: string;
  i, x: Integer;
begin
  Result := 0;
  for x := 0 to 3 do
  begin
    s := Fetch(value, '.');
    i := StrToIntDef(s, 0);
    Result := (256 * Result) + i;
  end;
end;

{==============================================================================}

function IpToStr(value: integer): string;
var
  x1, x2: word;
  y1, y2: byte;
begin
  Result := '';
  x1 := value shr 16;
  x2 := value and $FFFF;
  y1 := x1 div $100;
  y2 := x1 mod $100;
  Result := inttostr(y1) + '.' + inttostr(y2) + '.';
  y1 := x2 div $100;
  y2 := x2 mod $100;
  Result := Result + inttostr(y1) + '.' + inttostr(y2);
end;

{==============================================================================}

function ExpandIP6(Value: AnsiString): AnsiString;
var
 n: integer;
 s: ansistring;
 x: integer;
begin
  Result := '';
  if value = '' then
    exit;
  x := countofchar(value, ':');
  if x > 7 then
    exit;
  if value[1] = ':' then
    value := '0' + value;
  if value[length(value)] = ':' then
    value := value + '0';
  x := 8 - x;
  s := '';
  for n := 1 to x do
    s := s + ':0';
  s := s + ':';
  Result := replacestring(value, '::', s);
end;
{==============================================================================}

function StrToIp6(Value: string): TIp6Bytes;
var
 IPv6: TIp6Words;
 Index: Integer;
 n: integer;
 b1, b2: byte;
 s: string;
 x: integer;
begin
  for n := 0 to 15 do
    Result[n] := 0;
  for n := 0 to 7 do
    Ipv6[n] := 0;
  Index := 0;
  Value := ExpandIP6(value);
  if value = '' then
    exit;
  while Value <> '' do
  begin
    if Index > 7 then
      Exit;
    s := fetch(value, ':');
    if s = '@' then
      break;
    if s = '' then
    begin
      IPv6[Index] := 0;
    end
    else
    begin
      x := StrToIntDef('$' + s, -1);
      if (x > 65535) or (x < 0) then
        Exit;
      IPv6[Index] := x;
    end;
    Inc(Index);
  end;
  for n := 0 to 7 do
  begin
    b1 := ipv6[n] div 256;
    b2 := ipv6[n] mod 256;
    Result[n * 2] := b1;
    Result[(n * 2) + 1] := b2;
  end;
end;

{==============================================================================}
//based on routine by the Free Pascal development team
function Ip6ToStr(value: TIp6Bytes): string;
var
  i, x: byte;
  zr1,zr2: set of byte;
  zc1,zc2: byte;
  have_skipped: boolean;
  ip6w: TIp6words;
begin
  zr1 := [];
  zr2 := [];
  zc1 := 0;
  zc2 := 0;
  for i := 0 to 7 do
  begin
    x := i * 2;
    ip6w[i] := value[x] * 256 + value[x + 1];
    if ip6w[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
    zr1 := zr2;
  end;
  SetLength(Result, 8*5-1);
  SetLength(Result, 0);
  have_skipped := false;
  for i := 0 to 7 do
  begin
    if not(i in zr1) then
    begin
      if have_skipped then
      begin
        if Result = '' then
          Result := '::'
        else
          Result := Result + ':';
        have_skipped := false;
      end;
      Result := Result + IntToHex(Ip6w[i], 1) + ':';
    end
    else
    begin
      have_skipped := true;
    end;
  end;
  if have_skipped then
    if Result = '' then
      Result := '::0'
    else
      Result := Result + ':';

  if Result = '' then
    Result := '::0';
  if not (7 in zr1) then
    SetLength(Result, Length(Result)-1);
  Result := LowerCase(result);
end;

{==============================================================================}
function ReverseIP(Value: AnsiString): AnsiString;
var
  x: Integer;
begin
  Result := '';
  repeat
    x := LastDelimiter('.', Value);
    Result := Result + '.' + Copy(Value, x + 1, Length(Value) - x);
    Delete(Value, x, Length(Value) - x + 1);
  until x < 1;
  if Length(Result) > 0 then
    if Result[1] = '.' then
      Delete(Result, 1, 1);
end;

{==============================================================================}
function ReverseIP6(Value: AnsiString): AnsiString;
var
  ip6: TIp6bytes;
  n: integer;
  x, y: integer;
begin
  ip6 := StrToIP6(Value);
  x := ip6[15] div 16;
  y := ip6[15] mod 16;
  Result := IntToHex(y, 1) + '.' + IntToHex(x, 1);
  for n := 14 downto 0 do
  begin
    x := ip6[n] div 16;
    y := ip6[n] mod 16;
    Result := Result + '.' + IntToHex(y, 1) + '.' + IntToHex(x, 1);
  end;
end;

{==============================================================================}
end.