{ $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:  10135: IdDNSResolver.pas 
{
{   Rev 1.5    4/30/2003 03:06:56 AM  JPMugaas
}
{
{   Rev 1.2    1/3/2003 1:53:52 PM  VVassiliev
}
{
{   Rev 1.1    01/02/2003 9:42:18 AM  VVassiliev
{ Bug fix 659874, 660267
}
{
{   Rev 1.0    2002.11.12 10:36:22 PM  czhower
}
{
  IdDNSResolver.

  Started: sometime.
  Finished:

  The Resolver does NOT support COMPLETE XFER's since these should be based   
  on the TCP protocol. Use the appropriate component for that (if one exists!).

  The resolver also does not support Chaos RR. Only IN RR are supported as of this time.
  Part of code from Ray Malone
}

// SG 28/1/02: Changed the DNSStrToDomain function according to original Author of the old comp: Ray Malone
{SG 10/07/01 Added support for qrStar query}
{VV 12/09/01 Added construction of reverse query (PTR)}
{DS 12/31/01 Corrected ReponsiblePerson spelling }
{VV 01/02/03 TQueryResult.DNSStrToDomain fix}

{ TODO : Add structure of IDHEADER IN FIGURE }

unit IdDNSResolver;

interface

uses
  Classes,
  IdGlobal,
  IdUDPClient;

type
  { TODO : Solve problem with obsolete records }
  TQueryRecordTypes = (qtA, qtNS, qtMD, qtMF, qtName, qtSOA, qtMB,
    qtMG, qtMR, qtNull, qtWKS, qtPTR, qtHINFO, qtMINFO, qtMX, qtTXT, qtSTAR);
const
  // Lookup table for query record values.
  QueryRecordValues: array [0..16] of word= (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,255);
  QueryRecordTypes: Array [0..16] of TQueryRecordTypes = (qtA, qtNS, qtMD, qtMF, qtName, qtSOA, qtMB,
    qtMG, qtMR, qtNull, qtWKS, qtPTR, qtHINFO, qtMINFO, qtMX, qtTXT, qtSTAR);
type
  TQueryType = set of TQueryRecordTypes;

  TResultRecord = class(TCollectionItem) // Rename to REsourceRecord
  private
    FRecType: TQueryRecordTypes;
    FRecClass: word;
    FName: string;
    FTTL: cardinal;
    FRData: String;
    FRDataLength: Integer;
  public
    // Parse the data (descendants only)
    procedure Parse(CompleteMessage: String; APos: Integer); virtual;
    { TODO : This needs to change }
    property RecType: TQueryRecordTypes read FRecType;
    property RecClass: word read FRecClass;
    property Name: string read FName;
    property TTL: cardinal read FTTL;
    Property RDataLength: Integer read FRDataLength;
    property RData: String read FRData;
    destructor Destroy; override;
  end;

  TRDATARecord = class(TResultRecord)
  private
    FIPAddress: String;
  public
    procedure Parse(CompleteMessage: String; APos: Integer); override;
    constructor Create(Collection: TCollection); override;
    procedure Assign(Source: TPersistent); override;
    property IPAddress: string read FIPAddress;
  end;

  TARecord = class(TRDATARecord)
  end;

  TWKSRecord = Class(TResultRecord)
  private
    FByteCount: integer;
    FAddress: String;
    FProtocol: Word;
    FData: PByte;
    function GetABit(index: integer): Byte;
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    procedure Parse(CompleteMessage: String; APos: Integer); override;
    property Address: String read FAddress;
    property Protocol: Word read FProtocol;
    property BitMap[index: integer]: Byte read GetABit;
    property ByteCount: integer read FByteCount;
  end;

  TMXRecord = class(TResultRecord)
  private
    FExchangeServer: string;
    FPreference: Word;
  public
    procedure Parse(CompleteMessage: String; APos: Integer); override;
    constructor Create(Collection: TCollection); override;
    procedure Assign(Source: TPersistent); override;

    property ExchangeServer: string read FExchangeServer;
    property Preference: word read FPreference;
  end;

  TTextRecord = class(TResultRecord)
  private
    FText: TStrings;
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    procedure Parse(CompleteMessage: String; APos: Integer); override;
    Property Text: TStrings read FText;
  end;

  THINFORecord = Class(TTextRecord)
  private
    FCPU: String;
    FOS: String;
  public
    procedure Parse(CompleteMessage: String; APos: Integer); override;
    property CPU: String read FCPU;
    property OS: String read FOS;
  end;

  TMINFORecord = Class(TResultRecord)
  private
    FResponsiblePerson: String;
    FErrorMailbox: String;
  public
    procedure Parse(CompleteMessage: String; APos: Integer); override;
    property ResponsiblePersonMailbox: String read FResponsiblePerson;
    property ErrorMailbox: String read FErrorMailbox;
  end;

  TSOARecord = class(TResultRecord)
  private
    FSerial: cardinal;
    FMinimumTTL: Cardinal;
    FRefresh: Cardinal;
    FRetry: Cardinal;
    FMNAME: string;
    FRNAME: string;
    FExpire: Cardinal;
  public
    procedure Parse(CompleteMessage: String; APos: Integer); override;

    property Primary: string read FMNAME;
    property ResponsiblePerson: string read FRNAME;
    property Serial: cardinal read FSerial;
    property Refresh: Cardinal read FRefresh;
    property Retry: Cardinal read FRetry;
    property Expire: Cardinal read FExpire;

    property MinimumTTL: Cardinal read FMinimumTTL;
  end;

  TNAMERecord = class(TResultRecord)
  private
    FHostName: string;
  public
    procedure Parse(CompleteMessage: String; APos: Integer); override;
    constructor Create(Collection: TCollection); override;
    procedure Assign(Source: TPersistent); override;
    property HostName: string read FHostName;
  end;

  TNSRecord = class(TNAMERecord)
  end;

  TCNRecord = class(TNAMERecord)
  end;


  TQueryResult = class(TCollection)
  private
    FRec: TResultRecord;
    FDomainName: String;
    FQueryClass: Word;
    FQueryType: Word;
    FQueryPointerList: TStringList;
    function DNSStrToDomain(SrcStr: string; var Idx: Integer): string;
    function NextDNSLabel(DNSStr: string; Var APos: Integer): string;
    procedure SetItem(Index: Integer; Value: TResultRecord);
    function GetItem(Index: Integer): TResultRecord;
  protected
    function GetOwner: TPersistent; override;
  public
    constructor Create(AResultRecord: TResultRecord);
    destructor destroy; override;
    function Add(Answer: string; var APos: Integer): TResultRecord;
    procedure Clear; reintroduce;

    Property QueryClass: Word read FQueryClass;
    Property QueryType: Word read FQueryType;
    Property DomainName: String read FDomainName;

    property Items[Index: Integer]: TResultRecord read GetItem write SetItem; default;
  end;



  TPTRRecord = Class(TNAMERecord)
  end;

  // This class is used INTERNALLY. It does not need to be accessed by the user
  TDNSHeader = class
  private
    FID: Word;
    FBitCode: Word;
    FQDCount: Word;
    FANCount: Word;
    FNSCount: Word;
    FARCount: Word;
    function GetAA: Word;
    function GetOpCode: Word;
    function GetQr: Word;
    function GetRA: Word;
    function GetRCode: Word;
    function GetRD: Word;
    function GetTC: Word;
    procedure SetAA(const Value: Word);
    procedure SetOpCode(const Value: Word);
    procedure SetQr(const Value: Word);
    procedure SetRA(const Value: Word);
    procedure SetRCode(const Value: Word);
    procedure SetRD(const Value: Word);
    procedure SetTC(const Value: Word);

  public
    constructor Create;
    procedure ClearByteCode;

    property ID: Word read FID write FID;

    property Qr: Word read GetQr write SetQr;
    property OpCode: Word read GetOpCode write SetOpCode;
    property AA: Word read GetAA write SetAA;
    property TC: Word read GetTC write SetTC;
    property RD: Word read GetRD write SetRD;
    property RA: Word read GetRA write SetRA;
    property RCode: Word read GetRCode write SetRCode;
    property BitCode: Word read FBitCode;
    property QDCount: Word read FQDCount write FQDCount;
    property ANCount: Word read FANCount write FANCount;
    property NSCount: Word read FNSCount write FNSCount;
    property ARCount: Word read FARCount write FARCount;
  end;

  TIdDNSResolver = class(TIdUDPClient)
  private
    FDNSHeader: TDNSHeader;
    FQueryResult: TQueryResult;
    FInternalQuery: string;
    FQuestionLength: Integer;
    FAllowRecursiveQueries: Boolean;
    procedure SetAllowRecursiveQueries(const Value: Boolean);
  protected
    FQueryRecords: TQueryType; // Compression dictionary


    procedure ParseAnswers(Answer: String; AnswerNum: Cardinal);
    procedure CreateQuery(ADomain: string);
    procedure FillResult(AResult: string);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Resolve(ADomain: string);
    property QueryResult: TQueryResult read FQueryResult;
  published
    property QueryRecords: TQueryType read FQueryRecords write FQueryRecords;
    property AllowRecursiveQueries: Boolean read FAllowRecursiveQueries write SetAllowRecursiveQueries default true;
  end;

implementation

uses
  IdAssignedNumbers,
  IdBaseComponent,
  IdResourceStrings,
  IdException,
  SysUtils;

const
  cRCodeNoError   = 0;
  cRCodeFormatErr = 1;
  cRCodeServerErr = 2;
  cRCodeNameErr   = 3;
  cRCodeNotImplemented = 4;
  cRCodeRefused  = 5;

  cRCodeStrs : Array[cRCodeNoError..cRCodeRefused] Of String =
    (RSCodeNoError,
    RSCodeQueryFormat,
    RSCodeQueryServer,
    RSCodeQueryName,
    RSCodeQueryNotImplemented,
    RSCodeQueryQueryRefused);

{ TODO : Move to IdGlobal }
function WordToTwoCharStr(AWord : Word): String;
begin
  Result := Chr ( Hi ( AWord ) ) + Chr ( Lo ( AWord ) );
end;

function FourCharToCardinal(AChar1,AChar2,AChar3,AChar4 : Char): Cardinal;
var
  LCardinal: TIdCardinalBytes;
begin
  LCardinal.Byte1 := Ord(AChar4);
  LCardinal.Byte2 := Ord(AChar3);
  LCardinal.Byte3 := Ord(AChar2);
  LCardinal.Byte4 := Ord(AChar1);
  Result := LCardinal.Whole;
end;

{ TODO : Move to IdGlobal }
function TwoCharToWord(AChar1,AChar2: Char):Word;
//Since Replys are returned as Strings, we need a rountime to convert two
// characters which are a 2 byte U Int into a two byte unsigned integer
begin
  Result := Word((Ord(AChar1) shl 8) and $FF00) or Word(Ord(AChar2) and $00FF);
end;

{ TODO : Move these to member }
function GetErrorStr(Code, Id :Integer): String;
begin
  case code Of
    1 : Result := Format ( RSQueryInvalidQueryCount, [ Id ] );
    2 : Result := Format ( RSQueryInvalidPacketSize, [ Id ] );
    3 : Result := Format ( RSQueryLessThanFour, [ Id ] );
    4 : Result := Format ( RSQueryInvalidHeaderID, [ Id ] );
    5 : Result := Format ( RSQueryLessThanTwelve, [ Id ] );
    6 : Result := Format ( RSQueryPackReceivedTooSmall, [Id] );
  end;  //case code Of
end;

// SG 28/1/02: Changed that function according to original Author of the old comp: Ray Malone
function TQueryResult.DNSStrToDomain(SrcStr: string; var Idx: Integer): string;
var
  LabelStr : String;
  Len : Integer;
  SavedIdx : Integer;
  AChar :Char;
  fRPackSize: Integer;
begin
    Result := '';                {Do not Localize}
    fRPackSize := Length(SrcStr);
    SavedIdx := 0;
    repeat
      Len := byte(SrcStr[Idx]);
      while (Len and $C0) = $C0 do // {!!0.01} added loop for pointer
      begin                         // that points to a pointer. Removed  >63 hack. Am I really that stupid?
        if SavedIdx = 0 then SavedIdx := Succ(Idx); // it is important to return to original index  spot
	// when we go down more than 1 level.
        aChar := char(Len and $3F);                       // strip first two bits ($C) from first byte of offset pos
        Idx := TwoCharToWord(aChar, SrcStr[Idx + 1]) + 1; // add one to index for delphi string index
        Len := byte(SrcStr[Idx]);  // if len is another $Cx we will (while) loop again
      end;
      Assert(Idx < fRPackSize, GetErrorStr(2, 2)); // loop screwed up. This  very very unlikely now  could be removed.
      SetLength(LabelStr, Len);
      if Len > 0 then
      begin
        Move(SrcStr[Idx + 1], LabelStr[1], Length(LabelStr));
        Inc(Idx, Length(LabelStr) + 1);
      end;
      if Pred(Idx) > fRPackSize then // len byte was corrupted puting us past end of packet
        raise  EIdDnsResolverError.Create(GetErrorStr(2, 3));
      Result := Result + LabelStr + '.';  // concat and add period.  {Do not Localize}
    until (SrcStr[Idx] = char(0)) or (Idx >= Length(SrcStr)); // name field ends with nul byte
    if Result[Length(Result)] = '.' then  // remove final period    {Do not Localize}
    begin
      System.Delete(Result, Length(Result), 1);
    end;
    if SavedIdx > 0 then Idx := SavedIdx; // restore original Idx +1
    Inc(Idx); // set to first char of next item in  the resource
end;

function TQueryResult.NextDNSLabel(DNSStr: string; Var APos: Integer): string;
var
  LabelLength: Byte;
  function IsPointer(TestVal: Integer): boolean;
  begin
    result := (TestVal AND $C0) <> 0;
  end;
begin
  result := '';      {Do not Localize}
  if Length(DNSStr) > APos then
  begin
    LabelLength := Integer(DNSStr[APos]);
    if IsPointer(LabelLength) then
    begin
      // do not dereference pointers
      result := '';    {Do not Localize}
      Inc(APos, 2);
    end
    else
    begin
      if (LabelLength > 0) then
      begin
        result := Copy(DNSStr, APos + 1, LabelLength);
        inc(APos, LabelLength + 1);
      end
      else
      begin
        result := '';      {Do not Localize}
        Inc(APos);
      end;
    end;
  end;
end;




{ TODO : Move these to member }
function GetRCodeStr(RCode : Integer): String;
begin
  if Rcode in [cRCodeNoError..cRCodeRefused] then
  begin
    Result :=  cRCodeStrs[Rcode];
  end  // if Rcode in [cRCodeNoError..cRCodeRefused] then
  else
  begin
    Result := RSCodeQueryUnknownError;
  end; //else.. if Rcode in [cRCodeNoError..cRCodeRefused] then
end;

{ TIdDNSResolver }

constructor TIdDNSResolver.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Port := IdPORT_DOMAIN;
  FQueryResult := TQueryResult.Create(nil);
  FDNSHeader := TDNSHeader.Create;
  FAllowRecursiveQueries := true;
end;

procedure TIdDNSResolver.CreateQuery(ADomain: string);


  function DoDomainName(ADNS : String): string;
  var
    BufStr : String;
    aPos : Integer;
  begin                         { DoDomainName }
    Result := '';
    while Length(aDns) > 0 do
    begin
      aPos := Pos('.', aDns);    {Do not Localize}
      if aPos = 0 then
      begin
        aPos := Length(aDns) + 1;
      end; //if aPos = 0 then
      BufStr := Copy(aDns, 1, aPos - 1);
      Delete(aDns, 1, aPos);
      Result := Result + Chr(Length(BufStr)) + BufStr;
    end;
  end;

  function DoHostAddress(aDNS :String): string;
  var
    BufStr,
    BufStr2 : String;
    aPos : Integer;
  begin                         { DoHostAddress }
    while Length( aDns ) > 0 do
    begin
      aPos := IndyPos( '.', aDns );   {Do not Localize}
      if aPos =0 then
      begin
        aPos := Length(aDns) + 1;
      end;  //if aPos =0 then
      BufStr := Copy(aDns, 1, aPos-1 );
      Delete ( aDns, 1, aPos);
      BufStr2 := Chr ( Length ( BufStr ) ) + BufStr + BufStr2;
    end;  // while Length( aDns ) > 0 do
    Result := BufStr2 + Chr ( 07 ) + 'in-addr' + Chr ( 04 ) + 'arpa'; {do not localize}
  end;                          { DoHostAddress }


var
  ARecType: TQueryRecordTypes;
  iQ: Integer;
  AQuestion: string;
begin
  AQuestion := '';
  FDNSHeader.ClearByteCode;
  FDNSHeader.Qr := 0;
  FDNSHeader.OpCode := 0;
  FDNSHeader.RD := Word(FAllowRecursiveQueries);
  iQ := 0;
  // Iterate thru questions
  FInternalQuery := WordToTwoCharStr(FDNSHeader.ID);
  FInternalQuery := FInternalQuery + WordToTwoCharStr(FDNSHeader.BitCode);
  { TODO : Optimize for non-double loop }
  for ARecType := Low(TQueryRecordTypes) to High(TQueryRecordTypes) do begin
    if ARecType in QueryRecords then begin
      inc(iQ);
    end;
  end;
  FDNSHeader.QDCount := iQ;
  if FDNSHeader.QDCount = 0 then begin
    FInternalQuery := '';    {Do not Localize}
    Exit;
  end;
  FInternalQuery := FInternalQuery + WordToTwoCharStr(FDNSHeader.FQDCount);
  FInternalQuery := FInternalQuery + Chr(0) + Chr(0) + Chr(0) + Chr(0) + Chr(0) + Chr(0);
  for ARecType := Low(TQueryRecordTypes) to High(TQueryRecordTypes) do begin
    if ARecType in QueryRecords then begin
      // Create the question
      if (ARecType = qtPTR) and (IndyPos('in-addr', ADomain) = 0) then begin {do not localize}
        AQuestion := AQuestion + DoHostAddress(ADomain) + Chr(0);
      end else begin
        AQuestion := AQuestion + DoDomainName(ADomain) + Chr(0);
      end;
      AQuestion := AQuestion + WordToTwoCharStr(QueryRecordValues[Ord(ARecType)]);
      AQuestion := AQuestion + WordToTwoCharStr(1);
    end;
  end;
  FInternalQuery := FInternalQuery + AQuestion;
  FQuestionLength := Length(AQuestion);
end;

destructor TIdDNSResolver.Destroy;
begin
  FQueryResult.Free;
  FDNSHeader.Free;
  inherited Destroy;
end;


procedure TIdDNSResolver.ParseAnswers(Answer: String; AnswerNum: Cardinal);
var
  i: integer;
  APos: Integer;
begin
  QueryResult.Clear;
  APos := 13; // Header is 12 byte long we need next byte
  // first, get the question
  // extract the domain name
  QueryResult.FDomainName :=  QueryResult.DNSStrToDomain(Answer, APos);
  // get the query type
  QueryResult.FQueryType := TwoCharToWord(Answer[APos], Answer[APos + 1]);
  Inc(APos, 2);
  // get the Query Class
  QueryResult.FQueryClass := TwoCharToWord(Answer[APos], Answer[APos + 1]);
  Inc(APos, 2);
  for i := 1 to AnswerNum  do
  begin
    QueryResult.Add(Answer, APos);
  end;
end;

procedure TIdDNSResolver.FillResult(AResult: string);
var
  ReplyId: Word;
  NAnswers: Word;
begin
  { TODO : Check bytes received }
  // Check to see if the reply is the one waited for
  ReplyId := TwoCharToWord(AResult[1],AResult[2]);
  if ReplyId <> FDNSHeader.FId then begin
    raise EIdDnsResolverError.Create(GetErrorStr(4, fDNSHeader.Fid));
  end;
  FDNSHeader.FBitCode := TwoCharToWord(AResult[3], AResult[4]);
  if FDNSHeader.RCode <> 0 then begin
    raise EIdDnsResolverError.Create(GetRCodeStr(FDNSHeader.RCode));
  end;
  if Length(AResult) < 12 then begin
    Raise EIdDnsResolverError.Create(GetErrorStr(5, 29));
  end;
  if Length(AResult) < Length(FInternalQuery) then begin
    raise EIdDnsResolverError.Create(GetErrorStr(5, 30));
  end;
  FDNSHeader.FQDCount := TwoCharToWord(AResult[5], AResult[6]);
  FDNSHeader.FANCount:= TwoCharToWord(AResult[7], AResult[8]);
  FDNSHeader.FNSCount := TwoCharToWord(AResult[9], AResult[10]);
  FDNSHeader.FARCount := TwoCharToWord(AResult[11], AResult[12]);
  NAnswers := FDNSHeader.FANCount + FDNSHeader.FNSCount + FDNSHeader.FARCount;
  if NAnswers > 0 then begin
    // Move Pointer to Start of answers
    if Length(AResult) > 12 then
      ParseAnswers(AResult, NAnswers);
  end;
end;

procedure TIdDNSResolver.Resolve(ADomain: string);
var
  AResult: string;
begin
  // Resolve queries the DNS for the records contained in the
  CreateQuery(ADomain);
  if Length(FInternalQuery) = 0 then
    raise EIdDnsResolverError.CreateFmt(RSQueryInvalidQueryCount, [0]);
  Send(FInternalQuery);
  AResult := ReceiveString;
  if Length(AResult) > 4 then
    FillResult(AResult)
  else
    raise EIdDnsResolverError.Create(RSDNSTimeout);
end;

{ TARecord }

procedure TRDATARecord.Assign(Source: TPersistent);
begin
  if Source is TARecord then begin
    FIPAddress := TARecord(Source).IPAddress;
  end else begin
    inherited Assign(Source);
  end;
end;

constructor TRDATARecord.Create(Collection: TCollection);
begin
//  FRecType := rtA;
  inherited Create(Collection);
end;

{ TMXRecord }

procedure TMXRecord.Assign(Source: TPersistent);
begin
  if Source is TMXRecord then begin
    FExchangeServer := TMXRecord(Source).ExchangeServer;
    FPreference := TMXRecord(Source).Preference;
  end else begin
    inherited Assign(Source);
  end;
end;

constructor TMXRecord.Create(Collection: TCollection);
begin
//  FRecType := rtMX;
  inherited Create(Collection);
end;

{ TCNAMERecord }

procedure TNAMERecord.Assign(Source: TPersistent);
begin
  if Source is TNAMERecord then begin
    FHostName := TNAMERecord(Source).HostName;
  end else begin
    inherited Assign(Source);
  end;
end;

constructor TNAMERecord.Create(Collection: TCollection);
begin
//  FRecType := rtCNAME;
  inherited Create(Collection);
end;

{ TQueryResult }

function TQueryResult.Add(Answer: string; var APos: Integer): TResultRecord;
var
  RRName: String;
  RR_type, RR_Class: word;
  RR_TTL: Cardinal;
  RD_Length: word;
  RData: String;
begin
  // extract the RR data
  RRName := DNSStrToDomain(Answer, APos);
  RR_Type := TwoCharToWord(Answer[APos], Answer[APos + 1]);
  RR_Class := TwoCharToWord(Answer[APos + 2], Answer[APos + 3]);
  RR_TTL := FourCharToCardinal(Answer[APos + 4], Answer[APos + 5], Answer[APos + 6], Answer[APos + 7]);
  RD_Length := TwoCharToWord(Answer[APos + 8], Answer[APos + 9]);
  RData := Copy(Answer, APos + 10, RD_Length);
  // remove what we have read from the buffer
  // Read the record type
  case TQueryRecordTypes(RR_Type - 1) of
    qtA:
    begin
      result := TARecord.Create(Self);
    end;
    qtNS:
    begin
      result := TNSRecord.Create(Self);
    end;
    qtMX:
    begin
      result := TMXRecord.Create(Self);
    end;
    qtName:
    begin
      result := TNAMERecord.Create(Self);
    end;
    qtSOA:
    begin
      result := TSOARecord.Create(Self);
    end;
    qtHINFO:
    begin
      result := THINFORecord.Create(Self);
    end;
    qtTXT:
    begin
      result := TTextRecord.Create(Self);
    end;
    qtWKS:
    begin
      result := TWKSRecord.Create(Self);
    end;
    qtPTR:
    begin
      result := TPTRRecord.Create(Self);
    end;
    qtMINFO:
    begin
      result := TMINFORecord.Create(Self);
    end;
    else
      // Unsoppurted query type, return generic record
      result := TResultRecord.Create(self);
  end; // case
  // Set the "general purprose" options
  if assigned(result) then
  begin
    if RR_Type <= High(QueryRecordTypes) then
      result.FRecType := QueryRecordTypes[Ord(RR_Type) - 1];
    result.FRecClass := RR_Class;
    result.FName := RRName;
    result.FTTL := RR_TTL;
    Result.FRData := Copy(RData, 1, RD_Length);
    Result.FRDataLength := RD_Length;
    // Parse the result
    // Since the DNS message can be compressed, we need to have the whole message to parse it, in case
    // we encounter a pointer
    Result.Parse(Copy(Answer, 1, APos + 9 + RD_Length), APos + 10);
  end;
  // Set the new position
  inc(APos, RD_Length + 10);
end;

constructor TQueryResult.Create(AResultRecord: TResultRecord);
begin
  inherited Create(TResultRecord);
  FRec := AResultRecord;
  FQueryPointerList := TStringList.Create;
end;

destructor TQueryResult.destroy;
begin
  FQueryPointerList.Free;
  inherited;
end;

function TQueryResult.GetItem(Index: Integer): TResultRecord;
begin
  Result := TResultRecord(inherited GetItem(Index));
end;

function TQueryResult.GetOwner: TPersistent;
begin
  Result := FRec;
end;

procedure TQueryResult.SetItem(Index: Integer; Value: TResultRecord);
begin
  inherited SetItem(Index, Value);
end;

{ TDNSHeader }

procedure TDNSHeader.ClearByteCode;
begin
  FBitCode := 0;
end;

constructor TDNSHeader.Create;
begin
  Randomize;
  FId := Random(65535);
end;

function TDNSHeader.GetAA: Word;
begin
  Result := (FBitCode and $0700) shr 10;
end;

function TDNSHeader.GetOpCode: Word;
begin
  Result := ((FBitCode and $7800) shr 11) and $000F;
end;

function TDNSHeader.GetQr: Word;
begin
  Result := FBitCode shr 15;
end;

function TDNSHeader.GetRA: Word;
begin
  Result := (FBitCode and $0800) shr 7;
end;

function TDNSHeader.GetRCode: Word;
begin
  Result := FBitCode and $000F;
end;

function TDNSHeader.GetRD: Word;
begin
  Result := (FBitCode and $0100) shr 8;
end;

function TDNSHeader.GetTC: Word;
begin
  Result := (FBitCode and $0200) shr 9;
end;

procedure TDNSHeader.SetAA(const Value: Word);
begin
  if Value = 0 then begin
    FBitCode := FBitCode and $FBFF;
  end else begin
    FBitCode := FBitCode or $0400;
  end;
end;

procedure TDNSHeader.SetOpCode(const Value: Word);
begin
  case Value of
    0: FBitCode := FBitCode and $87FF;
    1: FBitCode := FBitCode and $8FFF;
    2: FBitCode := FBitCode and $4BFF;
  end;
end;

procedure TDNSHeader.SetQr(const Value: Word);
begin
  if Value = 0 then begin
    FBitCode := FBitCode and $EFFF;
  end else begin
    FBitCode := FBitCode or $8000;
  end;
end;

procedure TDNSHeader.SetRA(const Value: Word);
begin
  if Value = 0 then begin
    FBitCode := FBitCode and $FF7F;
  end else begin
    FBitCode := FBitCode or $0080;
  end;
end;

procedure TDNSHeader.SetRCode(const Value: Word);
begin
  FBitCode := (FBitCode and $FFF0) or (Value and $000F);
end;

procedure TDNSHeader.SetRD(const Value: Word);
begin
  if Value = 0 then begin
    FBitCode := FBitCode and $FEFFF;
  end else begin
    FBitCode := FBitCode or $0100;
  end;
end;

procedure TDNSHeader.SetTC(const Value: Word);
begin
  if Value = 0 then begin
    FBitCode := FBitCode and $FDFF;
  end else begin
    FBitCode := FBitCode or $0200;
  end;
end;

procedure TIdDNSResolver.SetAllowRecursiveQueries(const Value: Boolean);
begin
  FAllowRecursiveQueries := Value;
end;

procedure TRDATARecord.Parse(CompleteMessage: String; APos: Integer);
begin
  inherited;
  if Length(RData) > 0 then
    FIPAddress := Format('%d.%d.%d.%d',[Word(RData[1]), Word(RData[2]), Word(RData[3]), Word(RData[4])]);  {Do not Localize}
end;

{ TResultRecord }


destructor TResultRecord.Destroy;
begin
  inherited;
end;

procedure TResultRecord.Parse;
begin

end;

procedure TNAMERecord.Parse(CompleteMessage: String; APos: Integer);
begin
  inherited;
  FHostName := (Collection as TQueryResult).DNSStrToDomain(CompleteMessage, APos);
end;


procedure TQueryResult.Clear;
begin
  inherited Clear;
  FQueryPointerList.Clear;
end;

procedure TMXRecord.Parse(CompleteMessage: String; APos: Integer);
var
  Chars: Array[0..1] of char;
begin
  inherited;
  Move(CompleteMessage[APos], Chars, 2);
  FPreference := TwoCharToWord(Chars[0], Chars[1]);
  Inc(Apos, 2);
  FExchangeServer := (Collection as TQueryResult).DNSStrToDomain(CompleteMessage, APos);
end;

{ TTextRecord }

constructor TTextRecord.Create(Collection: TCollection);
begin
  inherited;
  FText := TStringlist.Create;
end;

destructor TTextRecord.Destroy;
begin
  FText.free;
  inherited;
end;

procedure TTextRecord.Parse(CompleteMessage: String; APos: Integer);
var
  Buffer: string;
begin
  FText.Clear;
  repeat
    Buffer := (Collection as TQueryResult).NextDNSLabel(CompleteMessage, APos);
    if Buffer = '' then   {Do not Localize}
    begin
      Break
    end
    else
    begin
      FText.Add(Buffer);
    end;
  until false;
  inherited;
end;

{ TSOARecord }

procedure TSOARecord.Parse(CompleteMessage: String;APos: Integer);
begin
  inherited;
  FMNAME := (Collection as TQueryResult).DNSStrToDomain(CompleteMessage, APos);
  FRNAME := (Collection as TQueryResult).DNSStrToDomain(CompleteMessage, APos);
  FSerial := FourCharToCardinal(CompleteMessage[APos], CompleteMessage[APos + 1], CompleteMessage[APos + 2], CompleteMessage[APos + 3]);
  inc(Apos, 4);
  FRefresh := FourCharToCardinal(CompleteMessage[APos], CompleteMessage[APos + 1], CompleteMessage[APos + 2], CompleteMessage[APos + 3]);
  inc(Apos, 4);
  FRetry := FourCharToCardinal(CompleteMessage[APos], CompleteMessage[APos + 1], CompleteMessage[APos + 2], CompleteMessage[APos + 3]);
  inc(Apos, 4);
  FExpire := FourCharToCardinal(CompleteMessage[APos], CompleteMessage[APos + 1], CompleteMessage[APos + 2], CompleteMessage[APos + 3]);
  inc(Apos, 4);
  FMinimumTTL := FourCharToCardinal(CompleteMessage[APos], CompleteMessage[APos + 1], CompleteMessage[APos + 2], CompleteMessage[APos + 3]);
end;

{ TWKSRecord }

constructor TWKSRecord.Create;
begin

end;

destructor TWKSRecord.Destroy;
begin
  inherited;
end;

function TWKSRecord.GetABit(index: integer): Byte;
var
  realPos: PByte;
begin
  realPos := FData;
  Inc(realPos, Index);
  result := realPos^;
end;

procedure TWKSRecord.Parse(CompleteMessage: String; APos: Integer);
begin
  inherited;
  FAddress := Format('%d.%d.%d.%d',[Word(RData[1]), Word(RData[2]), Word(RData[3]), Word(RData[4])]);   {Do not Localize}
  FProtocol := Word(Rdata[5]);
  FData := PByte(PChar(FRData));
  Inc(FData, 5);
end;

{ TMINFORecord }

procedure TMINFORecord.Parse(CompleteMessage: String; APos: Integer);
begin
  inherited;
  FResponsiblePerson := (Collection as TQueryResult).DNSStrToDomain(CompleteMessage, APos);
  FErrorMailbox := (Collection as TQueryResult).DNSStrToDomain(CompleteMessage, APos);
end;

{ THINFORecord }

procedure THINFORecord.Parse(CompleteMessage: String; APos: Integer);
begin
  inherited;
  FCPU := (Collection as TQueryResult).NextDNSLabel(CompleteMessage, APos);
  FOS := (Collection as TQueryResult).NextDNSLabel(CompleteMessage, APos);
end;


end.
