dnsquery.pas

BaiduMp3 search baidu mp3

  protected
    FWSocket                    : TWSocket;
    FPort                       : String;
    FAddr                       : String;
    FIDCount                    : WORD;
    FQueryBuf                   : array [0..511] of char;
    FQueryLen                   : Integer;
    fUseTCP                     : boolean;

    FResponseBuf                : PResBuf; // dynamic!   // !!KAP!! 2003-03-30
    FResponseLen                : Integer;
    FResponseBufSize            : integer;               // !!KAP!! 2003-03-30
    FResponseGotHead            : boolean;               // !!KAP!! 2003-03-30

    FOnRequestDone              : TDnsRequestDoneEvent;

    { !!KAP!! }
    fQueryPending               : boolean;

    procedure BuildRequestHeader(Dst       : PDnsRequestHeader;
                                 ID        : WORD;
                                 OPCode    : BYTE;
                                 Recursion : Boolean;
                                 QDCount   : WORD;
                                 ANCount   : WORD;
                                 NSCount   : WORD;
                                 ARCount   : WORD); virtual;
    function  BuildQuestionSection(Dst         : PChar;
                                   const QName : String;
                                   QType       : WORD;
                                   QClass      : WORD) : Integer; virtual;
    procedure WSocketDataAvailable(Sender: TObject; Error: WORD); virtual;
    procedure TriggerRequestDone(Error: WORD); virtual;
    function  GetResponseBuf : PChar;
    procedure SendQuery;

    { !!KAP!! 2002-02-15}
    procedure DNSSocketSessionClosed(Sender: TObject; Error: Word);
    // !!KAP!! 2003-03-30
    procedure DNSSocketSessionConnected(Sender: TObject; Error: Word);
  public
    constructor Create(AOwner : TComponent); override;
    destructor  Destroy; override;
    procedure   Notification(AComponent: TComponent; operation: TOperation); override;
    function    MXLookup(Domain : String) : Integer;
    function    ALookup(Host : String) : Integer;
    function    PTRLookup(IP : String) : Integer;
    { !!KAP!! }
    function    QueryAny(Host : String; QNumber : Integer) : Integer;
    // Query this to see if dns-request is pending
    property    QueryPending            : Boolean read fQueryPending;

    { !!KAP!! 2002-02-15}
    procedure   AbortPending;

    { !!KAP!! 2002-07-27}
    property Response      : TDnsRequestAnswerHeader                  read fDnsRequestAnswer;
    property ResponseBuf   : PChar                                    read GetResponseBuf;
    // 0 : all items, otherwise the queryitems
    property ResponseCount[nid : integer]:integer                     read GetRepsonsecount;
    property ResponseItem[nid : integer; nindex : integer]: TRRRecord read GetResponseItem;

    // simpler
    property Question : TQuestion read fQuestion;

    { !!KAP!! 2003-03-30}
    property CtrlSocket : TWSocket read FWSocket;
  published
    property Port    : String read  FPort write FPort;
    property Addr    : String read  FAddr write FAddr;
    property OnRequestDone : TDnsRequestDoneEvent read  FOnRequestDone
                                                  write FOnRequestDone;

    { !!KAP!! 2003-03-30}
    property UseTCP  : boolean read fUseTCP write fUseTCP;
  end;


function ReverseIP(const IP : String) : String;
function LongLatToDMS(longlat : longint; hemis : String) : String; { !!KAP!! }
function Loc2Geo(loc : TLOCInfo) : TLogGeo;                        { !!KAP!! }
function LocAltToAlt(Localt : LongInt) : LongInt;                  { !!KAP!! }
procedure Register;

// should compile.
Const   RRRecordsize = sizeof(TRRRecord);

implementation

type
    PWORD  = ^WORD;
    PDWORD = ^DWORD;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function ReverseIP(const IP : String) : String;
var
    I, J : Integer;
begin
    Result := '';
    if Length(IP) = 0 then
        Exit;
    J      := Length(IP);
    I      := J;
    while I >= 0 do begin
        if (I = 0) or (IP[I] = '.') then begin
            Result := Result + '.' + Copy(IP, I + 1, J - I);
            J := I - 1;
        end;
        Dec(I);
    end;
    if Result[1] = '.' then
        Delete(Result, 1, 1);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure Register;
begin
    RegisterComponents('FPiette', [TDnsQuery]);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
constructor TDnsQuery.Create(AOwner : TComponent);
begin
    inherited Create(AOwner);
    FWSocket := TWSocket.Create(nil);
    FPort    := '53';
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
destructor TDnsQuery.Destroy;
begin
  // erase cache
  if (fdatacache.count>0) then begin
    freemem(fdatacache.items,sizeof(fdatacache.items[0])*fdatacache.count);
    fdatacache.count:=0
  end;

  // !!KAP!! 2003-03-30
  if (FResponseBufSize>0) then begin
    freemem(FResponseBuf,FResponseBufSize);
    FResponseBufSize:=0;
    FResponseBuf:=nil;
  end;

    if Assigned(FWSocket) then begin
        FWSocket.Destroy;
        FWSocket := nil;
    end;
    inherited Destroy;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDnsQuery.Notification(AComponent: TComponent; operation: TOperation);
begin
    inherited Notification(AComponent, operation);
    if operation = opRemove then begin
        if AComponent = FWSocket then
            FWSocket := nil;
    end;
end;

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TDnsQuery.GetResponseBuf : PChar;
begin
  Result := @FResponseBuf^[0];
end;

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TDnsQuery.MXLookup(Domain : String) : Integer;
begin
    Inc(FIDCount);
    BuildRequestHeader(PDnsRequestHeader(@FQueryBuf), FIDCount, DnsOpCodeQuery, TRUE, 1, 0, 0, 0);
    FQueryLen := BuildQuestionSection(@FQueryBuf[SizeOf(TDnsRequestHeader)], Domain, DnsQueryMX, DnsClassIN);
    FQueryLen := FQueryLen + SizeOf(TDnsRequestHeader);
    Result    := FIDCount;
    SendQuery;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TDnsQuery.ALookup(Host : String) : Integer;
begin
    Inc(FIDCount);
    BuildRequestHeader(PDnsRequestHeader(@FQueryBuf), FIDCount, DnsOpCodeQuery, TRUE, 1, 0, 0, 0);
    FQueryLen := BuildQuestionSection(@FQueryBuf[SizeOf(TDnsRequestHeader)], Host, DnsQueryA, DnsClassIN);
    FQueryLen := FQueryLen + SizeOf(TDnsRequestHeader);
    Result    := FIDCount;
    SendQuery;
end;

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ !!KAP!! }
function TDnsQuery.QueryAny(Host : String; qnumber : integer) : Integer;
begin
    Inc(FIDCount);
    BuildRequestHeader(PDnsRequestHeader(@FQueryBuf), FIDCount, DnsOpCodeQuery, TRUE, 1, 0, 0, 0);
    FQueryLen := BuildQuestionSection(@FQueryBuf[SizeOf(TDnsRequestHeader)], Host, qnumber, DnsClassIN);
    FQueryLen := FQueryLen + SizeOf(TDnsRequestHeader);
    Result    := FIDCount;
    SendQuery;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TDnsQuery.PTRLookup(IP : String) : Integer;
begin
    Inc(FIDCount);
    BuildRequestHeader(PDnsRequestHeader(@FQueryBuf), FIDCount, DnsOpCodeQuery, TRUE, 1, 0, 0, 0);
    FQueryLen := BuildQuestionSection(@FQueryBuf[SizeOf(TDnsRequestHeader)],
                                      ReverseIP(IP) + '.in-addr.arpa',
                                      DnsQueryPTR, DnsClassIN);
    FQueryLen := FQueryLen + SizeOf(TDnsRequestHeader);
    Result    := FIDCount;
    SendQuery;
end;

Const sendtcp = 'tcp';      // !!KAP!! 2003-03-30
      sendudp = 'udp';

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDnsQuery.SendQuery;
begin
  // !!KAP!!
  fQueryPending:=true;

  // erase cache
  if (fdatacache.count>0) then begin
    freemem(fdatacache.items,sizeof(fdatacache.items[0])*fdatacache.count);
    fdatacache.count:=0
  end;

  FWSocket.OnDataAvailable := nil;
  FWSocket.Abort;

  // !!KAP!! 2003-03-30
  FResponseLen:=0;
  FResponseGotHead:=false;
  FWSocket.OnDataAvailable:=WSocketDataAvailable;
  FWSocket.OnSessionClosed:=DNSSocketSessionClosed;
  FWSocket.OnSessionConnected:=DNSSocketSessionConnected;

  // !!KAP!! 2003-03-30
  if (fUseTCP)
    then FWSocket.Proto:=sendtcp
    else FWSocket.Proto:=sendudp;

  FWSocket.Port:=FPort;
  FWSocket.Addr:=FAddr;

  // !!KAP!! 2003-03-30
  try
    FWSocket.Connect;
  except
    TriggerRequestDone(fwsocket.LastError); // No Connection? Bah!
  end;
end;

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ !!KAP!! 2003-03-30}
procedure TDnsQuery.DNSSocketSessionConnected(Sender: TObject; Error: Word);
Var len : word;
begin
  if (fUseTCP) then begin
    len:=WSocket_ntohs(FQueryLen);
    fwsocket.send(@len,sizeof(len));
  end;

  FWSocket.Send(@FQueryBuf, FQueryLen);
end;

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TDnsQuery.BuildQuestionSection(
    Dst         : PChar;
    const QName : String;
    QType       : WORD;
    QClass      : WORD) : Integer;
var
    I   : Integer;
    p   : PChar;
    Ptr : PChar;
begin
    Ptr := Dst;
    if Ptr = nil then begin
        Result := 0;
        Exit;
    end;
    I := 1;
    while I <= Length(QName) do begin
        p := Ptr;
        Inc(Ptr);
        while (I <= Length(QName)) and (QName[I] <> '.') do begin
            Ptr^ := QName[I];
            Inc(Ptr);
            Inc(I);
        end;
        p^ := Chr(Ptr - p - 1);
        Inc(I);
    end;
    Ptr^ := #0;
    Inc(Ptr);
    PWORD(Ptr)^ := htons(QType);
    Inc(Ptr, 2);
    PWORD(Ptr)^ := htons(QClass);
    Inc(Ptr, 2);
    Result := Ptr - Dst;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDnsQuery.BuildRequestHeader(
    Dst       : PDnsRequestHeader;
    ID        : WORD;
    OPCode    : BYTE;
    Recursion : Boolean;
    QDCount   : WORD;
    ANCount   : WORD;
    NSCount   : WORD;
    ARCount   : WORD);
begin
    if Dst = nil then
        Exit;
    Dst^.ID      := htons(ID);
    Dst^.Flags   := htons((OpCode shl 11) + (Ord(Recursion) shl 8));
    Dst^.QDCount := htons(QDCount);
    Dst^.ANCount := htons(ANCount);
    Dst^.NSCount := htons(NSCount);
    Dst^.ARCount := htons(ARCount);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDnsQuery.TriggerRequestDone(Error: WORD);
begin
  if Assigned(FOnRequestDone) then
    FOnRequestDone(Self, Error);

  //!!KAP!!
  fQueryPending:=false;
end;

{ !!KAP!! 2002-02-15}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDnsQuery.AbortPending;
begin
  fQueryPending:=false;
end;

(************************************************************************************************)
(************************************************************************************************)
function TDnsQuery.NewExtractName(var p : pchar):string;
var N  : Integer;
    I  : Integer;
    pc : pchar;
begin
  result:='';

  if (P^=#0) then
    Inc(P)
   else
    repeat
      { Get name part length }
      N:=Ord(P^);
      if (N and $C0)=$C0 then begin
        { Message compression }
        N := ((N and $3F) shl 8) + Ord(P[1]);
        pc:=fResponseBuf^;  // !!KAP!! 2003-03-30
        inc(pc,n);
        result:=result+NewExtractName(pc);
        // Weiter
        Inc(P,2);
        n:=0;
       end else begin
        Inc(P);
        if (N<>0) then begin
          { Copy name part }
          i:=length(result);
          setlength(result,i+n);
          move(p^,result[i+1],n);
          inc(p,n);
          if (P^<>#0) then
            result:=result+'.';
        end;
      end;
    until (n=0);
end;

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TDnsQuery.WSocketDataAvailable(Sender: TObject; Error: WORD);
Var Flags    : Integer;
    Ans      : PDnsRequestHeader;
    len      : word;
    i        : integer;
    rp       : PResBuf;
    REndPtr,
    RDataPtr,
    P        : PChar;
begin
  frrcache.lastid:=-1;