{ $HDR$}
{**********************************************************************}
{ Unit archived using Team Coherence                                   }
{ Team Coherence is Copyright 2002 by Quality Software Components      }
{                                                                      }
{ For further information / comments, visit our WEB site at            }
{ http://www.TeamCoherence.com                                         }
{**********************************************************************}
{}
{ $Log:  10269: IdNetworkCalculator.pas 
{
{   Rev 1.0    2002.11.12 10:47:10 PM  czhower
}
unit IdNetworkCalculator;

interface

uses
  SysUtils, Classes, IdBaseComponent;

type

  TIpStruct = record
  case integer of
    0: (Byte4, Byte3, Byte2, Byte1: byte);
    1: (FullAddr: Longword);
  end;

  TNetworkClass = (ID_NET_CLASS_A, ID_NET_CLASS_B, ID_NET_CLASS_C,
    ID_NET_CLASS_D, ID_NET_CLASS_E);

const
  ID_NC_MASK_LENGTH = 32;
  ID_NETWORKCLASS = ID_NET_CLASS_A;

type
  TIdIPAddressType = (IPLocalHost, IPLocalNetwork, IPReserved, IPInternetHost,
    IPPrivateNetwork, IPLoopback, IPMulticast, IPFutureUse, IPGlobalBroadcast);

  TIpProperty = Class(TPersistent)
  protected
    FReadOnly: boolean;
    FOnChange: TNotifyEvent;
    FByteArray: array[0..31] of boolean;
    FDoubleWordValue: Longword;

    FAsString: String;
    FAsBinaryString: String;
    FByte3: Byte;
    FByte4: Byte;
    FByte2: Byte;
    FByte1: byte;
    function GetAddressType: TIdIPAddressType;
    procedure SetReadOnly(const Value: boolean);
    procedure SetOnChange(const Value: TNotifyEvent);
    function GetByteArray(Index: cardinal): boolean;
    procedure SetAsBinaryString(const Value: String);
    procedure SetAsDoubleWord(const Value: Longword);
    procedure SetAsString(const Value: String);
    procedure SetByteArray(Index: cardinal; const Value: boolean);
    procedure SetByte4(const Value: Byte);
    procedure SetByte1(const Value: byte);
    procedure SetByte3(const Value: Byte);
    procedure SetByte2(const Value: Byte);
    //
    property ReadOnly: boolean read FReadOnly write SetReadOnly default false;
  public
    procedure SetAll(One, Two, Three, Four: Byte); virtual;
    procedure Assign(Source: Tpersistent); override;
    //
    property ByteArray[Index: cardinal]: boolean read GetByteArray write SetByteArray;
    property AddressType: TIdIPAddressType read GetAddressType;
  published
    property Byte1: byte read FByte1 write SetByte1 stored false;
    property Byte2: Byte read FByte2 write SetByte2 stored false;
    property Byte3: Byte read FByte3 write SetByte3 stored false;
    property Byte4: Byte read FByte4 write SetByte4 stored false;
    property AsDoubleWord: Longword read FDoubleWordValue write SetAsDoubleWord stored false;
    property AsBinaryString: String read FAsBinaryString write SetAsBinaryString stored false;
    property AsString: String read FAsString write SetAsString;
    property OnChange: TNotifyEvent read FOnChange write SetOnChange;
  end;

  TIdNetworkCalculator = class(TIdBaseComponent)
  protected
    FListIP: TStrings;
    FNetworkMaskLength: cardinal;
    FNetworkMask: TIpProperty;
    FNetworkAddress: TIpProperty;
    FNetworkClass: TNetworkClass;
    FOnChange: TNotifyEvent;
    FOnGenIPList: TNotifyEvent;
    function GetNetworkClassAsString: String;
    function GetIsAddressRoutable: Boolean;
    procedure SetOnChange(const Value: TNotifyEvent);
    procedure SetOnGenIPList(const Value: TNotifyEvent);
    function GetListIP: TStrings;
    procedure SetNetworkAddress(const Value: TIpProperty);
    procedure SetNetworkMask(const Value: TIpProperty);
    procedure SetNetworkMaskLength(const Value: cardinal);
    procedure OnNetMaskChange(Sender: TObject);
    procedure OnNetAddressChange(Sender: TObject);
  public
    function NumIP: integer;
    function StartIP: String;
    function EndIP: String;
    procedure FillIPList;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    //
    property ListIP: TStrings read GetListIP;
    property NetworkClass: TNetworkClass read FNetworkClass;
    property NetworkClassAsString: String read GetNetworkClassAsString;
    property IsAddressRoutable: Boolean read GetIsAddressRoutable;
  published
    function IsAddressInNetwork(Address: String): Boolean;
    property NetworkAddress: TIpProperty read FNetworkAddress write SetNetworkAddress;
    property NetworkMask: TIpProperty read FNetworkMask write SetNetworkMask;
    property NetworkMaskLength: cardinal read FNetworkMaskLength write SetNetworkMaskLength
     default ID_NC_MASK_LENGTH;
    property OnGenIPList: TNotifyEvent read FOnGenIPList write SetOnGenIPList;
    property OnChange: TNotifyEvent read FOnChange write SetOnChange;
  end;

implementation

uses
  IdException, IdGlobal, IdResourceStrings;

{ TIdNetworkCalculator }

function IP(Byte1, Byte2, Byte3, Byte4: byte): TIpStruct;
begin
  result.Byte1 := Byte1;
  result.Byte2 := Byte2;
  result.Byte3 := Byte3;
  result.Byte4 := Byte4;
end;

function StrToIP(const value: string): TIPStruct;
var
  strBuffers: Array [0..3] of String;
  cardBuffers: Array[0..3] of cardinal;
  StrWork: String;
begin
  StrWork := Value;
  // Separate the strings
  strBuffers[0] := Fetch(StrWork, '.', true);    {Do not Localize}
  strBuffers[1] := Fetch(StrWork, '.', true);    {Do not Localize}
  strBuffers[2] := Fetch(StrWork, '.', true);    {Do not Localize}
  strBuffers[3] := StrWork;
  try
    cardBuffers[0] := StrToInt(strBuffers[0]);
    cardBuffers[1] := StrToInt(strBuffers[1]);
    cardBuffers[2] := StrToInt(strBuffers[2]);
    cardBuffers[3] := StrToInt(strBuffers[3]);
  except
    on e: exception do
      Raise exception.Create(Format( RSNETCALInvalidIPString, [Value]));
  end;
  // range check
  if not(cardBuffers[0] in [0..255]) then
      raise EIdException.Create(Format( RSNETCALInvalidIPString, [Value]));
  if not(cardBuffers[1] in [0..255]) then
      raise EIdException.Create(Format( RSNETCALInvalidIPString, [Value]));
  if not(cardBuffers[2] in [0..255]) then
      raise EIdException.Create(Format( RSNETCALInvalidIPString, [Value]));
  if not(cardBuffers[3] in [0..255]) then
      raise EIdException.Create(Format( RSNETCALInvalidIPString, [Value]));
  result := IP(cardBuffers[0], cardBuffers[1], cardBuffers[2], cardBuffers[3]);
end;

constructor TIdNetworkCalculator.Create(AOwner: TComponent);
begin
  inherited;
  FNetworkMask := TIpProperty.Create;
  FNetworkAddress := TIpProperty.Create;

  FNetworkMask.OnChange := OnNetMaskChange;
  FNetworkAddress.OnChange := OnNetAddressChange;
  FListIP := TStringList.Create;
  FNetworkClass := ID_NETWORKCLASS;
  NetworkMaskLength := ID_NC_MASK_LENGTH;
end;

destructor TIdNetworkCalculator.Destroy;
begin
  FNetworkMask.Free;
  FNetworkAddress.Free;
  FListIP.Free;
  inherited;
end;

procedure TIdNetworkCalculator.FillIPList;
var
  i: Cardinal;
  BaseIP: TIpStruct;
begin
  if FListIP.Count = 0 then
  begin
    // prevent to start a long loop in the IDE (will lock delphi)
    if (csDesigning in ComponentState) and (NumIP > 1024) then
    begin
      FListIP.text := Format(RSNETCALConfirmLongIPList,[NumIP]);
    end
    else
    begin
      BaseIP.FullAddr := NetworkAddress.AsDoubleWord AND NetworkMask.AsDoubleWord;
      // preallocate the memory for the list
      FListIP.Capacity := NumIP;
      // Lock the list so we won't be "repainting" the whole time...    {Do not Localize}
      FListIP.BeginUpdate;
      try
        for i := 1 to (NumIP - 1) do
        begin
          Inc(BaseIP.FullAddr);
          FListIP.append(format('%d.%d.%d.%d', [BaseIP.Byte1, BaseIP.Byte2, BaseIP.Byte3, BaseIP.Byte4]));    {Do not Localize}
        end;
      finally
        FListIP.EndUpdate;
      end;
    end;
  end;
end;

function TIdNetworkCalculator.GetListIP: TStrings;
begin
  FillIPList;
  result := FListIP;
end;

function TIdNetworkCalculator.IsAddressInNetwork(Address: String): Boolean;
var
  IPStruct: TIPStruct;
begin
  IPStruct := StrToIP(Address);
  result := (IPStruct.FullAddr AND NetworkMask.FDoubleWordValue) = (NetworkAddress.FDoubleWordValue AND NetworkMask.FDoubleWordValue);
end;

procedure TIdNetworkCalculator.OnNetAddressChange(Sender: TObject);
begin
  FListIP.Clear;
  // RFC 1365
  if IndyPos('0', NetworkAddress.AsBinaryString) = 1 then    {Do not Localize}
  begin
    fNetworkClass := ID_NET_CLASS_A;
  end;
  if IndyPos('10', NetworkAddress.AsBinaryString) = 1 then    {Do not Localize}
  begin
    fNetworkClass := ID_NET_CLASS_B;
  end;
  if IndyPos('110', NetworkAddress.AsBinaryString) = 1 then    {Do not Localize}
  begin
    fNetworkClass := ID_NET_CLASS_C;
  end;
  // Network class D is reserved for multicast
  if IndyPos('1110', NetworkAddress.AsBinaryString) = 1 then    {Do not Localize}
  begin
    fNetworkClass := ID_NET_CLASS_D;
  end;
  // network class E is reserved and shouldn't be used    {Do not Localize}
  if IndyPos('1111', NetworkAddress.AsBinaryString) = 1 then    {Do not Localize}
  begin
    fNetworkClass := ID_NET_CLASS_E;
  end;
  if assigned( FOnChange ) then
    FOnChange(Self);
end;

procedure TIdNetworkCalculator.OnNetMaskChange(Sender: TObject);
var
  sBuffer: string;
  InitialMaskLength: Cardinal;
begin
  FListIP.Clear;
  InitialMaskLength := FNetworkMaskLength;
  // A network mask MUST NOT contains holes.
  sBuffer := FNetworkMask.AsBinaryString;
  while (length(sBuffer) > 0) and (sBuffer[1] = '1') do    {Do not Localize}
  begin
    Delete(sBuffer, 1, 1);
  end;    { while }


  if IndyPos('1', sBuffer) > 0 then    {Do not Localize}
  begin
    NetworkMaskLength := InitialMaskLength;
    raise EIdexception.Create(RSNETCALCInvalidNetworkMask); //  'Invalid network mask'    {Do not Localize}
  end
  else
  begin
    // set the net mask length
    NetworkMaskLength := 32 - Length(sBuffer);
  end;
  if assigned( FOnChange ) then
    FOnChange(Self);
end;

procedure TIdNetworkCalculator.SetNetworkAddress(const Value: TIpProperty);
begin
  FNetworkAddress.Assign(Value);
end;

procedure TIdNetworkCalculator.SetNetworkMask(const Value: TIpProperty);
begin
  FNetworkMask.Assign(Value);
end;

procedure TIdNetworkCalculator.SetNetworkMaskLength(const Value: cardinal);