dnswin.pas

   1 unit dnswin;\r
   2 \r
   3 interface\r
   4 \r
   5 uses binipstuff,classes,lcore;\r
   6 \r
   7 {$include lcoreconfig.inc}\r
   8 \r
   9 //on failure a null string or zeroed out binip will be retuned and error will be\r
  10 //set to a windows error code (error will be left untouched under non error\r
  11 //conditions).\r
  12 function winforwardlookuplist(name : string;familyhint:integer;var error : integer) : tbiniplist;\r
  13 function winreverselookup(ip:tbinip;var error:integer):string;\r
  14 \r
  15 \r
  16 type\r
  17   //do not call destroy on a tdnswinasync instead call release and the\r
  18   //dnswinasync will be freed when appropriate. Calling destroy will block\r
  19   //the calling thread until the dns lookup completes.\r
  20   //release should only be called from the main thread\r
  21   tdnswinasync=class(tthread)\r
  22   private\r
  23     freverse : boolean;\r
  24     error : integer;\r
  25     freewhendone : boolean;\r
  26     hadevent : boolean;\r
  27   protected\r
  28     procedure execute; override;\r
  29   public\r
  30     onrequestdone:tsocketevent;\r
  31     name : string;\r
  32     iplist : tbiniplist;\r
  33 \r
  34     procedure forwardlookup(name:string);\r
  35     procedure reverselookup(ip:tbinip);\r
  36     destructor destroy; override;\r
  37     procedure release;\r
  38     constructor create;\r
  39     property reverse : boolean read freverse;\r
  40 \r
  41   end;\r
  42 \r
  43 implementation\r
  44 uses\r
  45   lsocket,pgtypes,sysutils,winsock,windows,messages;\r
  46 \r
  47 type\r
  48   //taddrinfo = record; //forward declaration\r
  49   paddrinfo = ^taddrinfo;\r
  50   taddrinfo = packed record\r
  51     ai_flags : longint;\r
  52     ai_family : longint;\r
  53     ai_socktype : longint;\r
  54     ai_protocol : longint;\r
  55     ai_addrlen : taddrint;\r
  56     ai_canonname : pchar;\r
  57     ai_addr : pinetsockaddrv;\r
  58     ai_next : paddrinfo;\r
  59   end;\r
  60   ppaddrinfo = ^paddrinfo;\r
  61   tgetaddrinfo = function(nodename : pchar; servname : pchar; hints : paddrinfo;res : ppaddrinfo) : longint; stdcall;\r
  62   tfreeaddrinfo = procedure(ai : paddrinfo); stdcall;\r
  63   tgetnameinfo = function(sa:Pinetsockaddrv;salen : longint; host:pchar;hostlen : longint;serv:pchar;servlen:longint;flags:longint) : longint;stdcall;\r
  64 var\r
  65   getaddrinfo : tgetaddrinfo;\r
  66   freeaddrinfo : tfreeaddrinfo;\r
  67   getnameinfo : tgetnameinfo;\r
  68 procedure v4onlyfreeaddrinfo(ai : paddrinfo); stdcall;\r
  69 var\r
  70   next:paddrinfo;\r
  71 begin\r
  72   while assigned(ai) do begin\r
  73     freemem(ai.ai_addr);\r
  74     next := ai.ai_next;\r
  75     freemem(ai);\r
  76     ai := next;\r
  77   end;\r
  78 end;\r
  79 \r
  80 type\r
  81   plongint = ^longint;\r
  82   pplongint = ^plongint;\r
  83 \r
  84 function v4onlygetaddrinfo(nodename : pchar; servname : pchar; hints : paddrinfo;res : ppaddrinfo) : longint; stdcall;\r
  85 var\r
  86   output,prev,first : paddrinfo;\r
  87   hostent : phostent;\r
  88   addrlist:^pointer;\r
  89 begin\r
  90   if hints.ai_family <> af_inet6 then begin\r
  91     result := 0;\r
  92 \r
  93 \r
  94     hostent := gethostbyname(nodename);\r
  95     if hostent = nil then begin\r
  96       result := wsagetlasterror;\r
  97       v4onlyfreeaddrinfo(output);\r
  98       exit;\r
  99     end;\r
 100     addrlist := pointer(hostent.h_addr_list);\r
 101 \r
 102     //ipint := pplongint(hostent.h_addr_list)^^;\r
 103     prev := nil;\r
 104     first := nil;\r
 105     repeat\r
 106       if not assigned(addrlist^) then break;\r
 107 \r
 108       getmem(output,sizeof(taddrinfo));\r
 109       if assigned(prev) then prev.ai_next := output;\r
 110       getmem(output.ai_addr,sizeof(tinetsockaddr));\r
 111       if servname <> nil then output.ai_addr.InAddr.port := htons(strtoint(servname)) else output.ai_addr.InAddr.port := 0;\r
 112       output.ai_addr.InAddr.addr := longint(addrlist^^);\r
 113       inc(integer(addrlist),4);\r
 114       output.ai_flags := 0;\r
 115       output.ai_family := af_inet;\r
 116       output.ai_socktype := 0;\r
 117       output.ai_protocol := 0;\r
 118       output.ai_addrlen := sizeof(tinetsockaddr);\r
 119       output.ai_canonname := nil;\r
 120       output.ai_next := nil;\r
 121       prev := output;\r
 122       if not assigned(first) then first := output;\r
 123     until false;\r
 124     res^ := first;\r
 125   end else begin\r
 126     result := WSANO_RECOVERY;\r
 127   end;\r
 128 end;\r
 129 \r
 130 function min(a,b : integer):integer;\r
 131 begin\r
 132   if a<b then result := a else result := b;\r
 133 end;\r
 134 \r
 135 function v4onlygetnameinfo(sa:Pinetsockaddrv;salen : longint; host:pchar;hostlen : longint;serv:pchar;servlen:longint;flags:longint) : longint;stdcall;\r
 136 var\r
 137   hostent : phostent;\r
 138   bytestocopy : integer;\r
 139 begin\r
 140   if sa.InAddr.family = af_inet then begin\r
 141     result := 0;\r
 142     hostent := gethostbyaddr(@(sa.inaddr.addr),4,AF_INET);\r
 143     if hostent = nil then begin\r
 144       result := wsagetlasterror;\r
 145       exit;\r
 146     end;\r
 147     bytestocopy := min(strlen(hostent.h_name)+1,hostlen);\r
 148     move((hostent.h_name)^,host^,bytestocopy);\r
 149 \r
 150 \r
 151   end else begin\r
 152     result := WSANO_RECOVERY;\r
 153   end;\r
 154 end;\r
 155 \r
 156 \r
 157 procedure populateprocvars;\r
 158 var\r
 159   libraryhandle : hmodule;\r
 160   i : integer;\r
 161   dllname : string;\r
 162 \r
 163 begin\r
 164   if assigned(getaddrinfo) then exit; //procvars already populated\r
 165   for i := 0 to 1 do begin\r
 166     if i=0 then dllname := 'Ws2_32.dll' else dllname := 'Wship6.dll';\r
 167     libraryhandle := LoadLibrary(pchar(dllname));\r
 168     getaddrinfo := getprocaddress(libraryhandle,'getaddrinfo');\r
 169     freeaddrinfo := getprocaddress(libraryhandle,'freeaddrinfo');\r
 170     getnameinfo := getprocaddress(libraryhandle,'getnameinfo');\r
 171     if assigned(getaddrinfo) and assigned(freeaddrinfo) and assigned(getnameinfo) then begin\r
 172       //writeln('found getaddrinfo and freeaddrinfo in'+dllname);\r
 173       exit; //success\r
 174     end;\r
 175 \r
 176   end;\r
 177   //writeln('could not find getaddrinfo and freeaddrinfo, falling back to ipv4 only lookup');\r
 178   getaddrinfo := v4onlygetaddrinfo;\r
 179   freeaddrinfo := v4onlyfreeaddrinfo;\r
 180   getnameinfo := v4onlygetnameinfo;\r
 181 end;\r
 182 \r
 183 \r
 184 function winforwardlookuplist(name : string;familyhint:integer;var error : integer) : tbiniplist;\r
 185 var\r
 186   hints: taddrinfo;\r
 187   res0,res : paddrinfo;\r
 188   getaddrinforesult : integer;\r
 189   biniptemp:tbinip;\r
 190 begin\r
 191   populateprocvars;\r
 192 \r
 193   hints.ai_flags := 0;\r
 194   hints.ai_family := familyhint;\r
 195   hints.ai_socktype := 0;\r
 196   hints.ai_protocol := 0;\r
 197   hints.ai_addrlen := 0;\r
 198   hints.ai_canonname := nil;\r
 199   hints.ai_addr := nil;\r
 200   hints.ai_next := nil;\r
 201   getaddrinforesult := getaddrinfo(pchar(name),'1',@hints,@res);\r
 202   res0 := res;\r
 203   result := biniplist_new;\r
 204   if getaddrinforesult = 0 then begin\r
 205 \r
 206     while assigned(res) do begin\r
 207       if res.ai_family = af_inet then begin\r
 208         biniptemp.family := af_inet;\r
 209         biniptemp.ip := res.ai_addr.InAddr.addr;\r
 210         biniplist_add(result,biniptemp);\r
 211       {$ifdef ipv6}\r
 212       end else if res.ai_family = af_inet6 then begin\r
 213         biniptemp.family := af_inet6;\r
 214         biniptemp.ip6 := res.ai_addr.InAddr6.sin6_addr;\r
 215         biniplist_add(result,biniptemp);\r
 216       {$endif}\r
 217       end;\r
 218       res := res.ai_next;\r
 219     end;\r
 220     freeaddrinfo(res0);\r
 221     exit;\r
 222   end;\r
 223 \r
 224   if getaddrinforesult <> 0 then begin\r
 225     fillchar(result,0,sizeof(result));\r
 226     error := getaddrinforesult;\r
 227   end;\r
 228 end;\r
 229 \r
 230 function winreverselookup(ip:tbinip;var error : integer):string;\r
 231 var\r
 232   sa : tinetsockaddrv;\r
 233   getnameinforesult : integer;\r
 234 begin\r
 235 \r
 236   if ip.family = AF_INET then begin\r
 237     sa.InAddr.family := AF_INET;\r
 238     sa.InAddr.port := 1;\r
 239     sa.InAddr.addr := ip.ip;\r
 240   end else {$ifdef ipv6}if ip.family = AF_INET6 then begin\r
 241     sa.InAddr6.sin6_family  := AF_INET6;\r
 242     sa.InAddr6.sin6_port := 1;\r
 243     sa.InAddr6.sin6_addr := ip.ip6;\r
 244   end else{$endif} begin\r
 245     raise exception.create('unrecognised address family');\r
 246   end;\r
 247   populateprocvars;\r
 248   setlength(result,1025);\r
 249   getnameinforesult := getnameinfo(@sa,sizeof(tinetsockaddrv),pchar(result),length(result),nil,0,0);\r
 250   if getnameinforesult <> 0 then begin\r
 251     error := getnameinforesult;\r
 252     result := '';\r
 253     exit;\r
 254   end;\r
 255   if pos(#0,result) >= 0 then begin\r
 256     setlength(result,pos(#0,result)-1);\r
 257   end;\r
 258 end;\r
 259 \r
 260 var\r
 261   hwnddnswin : hwnd;\r
 262 \r
 263 function MyWindowProc(\r
 264     ahWnd   : HWND;\r
 265     auMsg   : Integer;\r
 266     awParam : WPARAM;\r
 267     alParam : LPARAM): Integer; stdcall;\r
 268 var\r
 269   dwas : tdnswinasync;\r
 270 begin\r
 271   if (ahwnd=hwnddnswin) and (aumsg=wm_user) then begin\r
 272     Dwas := tdnswinasync(alparam);\r
 273     if assigned (dwas.onrequestdone) then dwas.onrequestdone(dwas,awparam);\r
 274     dwas.hadevent := true;\r
 275     if dwas.freewhendone then dwas.free;\r
 276   end else begin\r
 277     //not passing unknown messages on to defwindowproc will cause window\r
 278     //creation to fail! --plugwash\r
 279     Result := DefWindowProc(ahWnd, auMsg, awParam, alParam)\r
 280   end;\r
 281 end;\r
 282 \r
 283 procedure tdnswinasync.forwardlookup(name:string);\r
 284 begin\r
 285   self.name := name;\r
 286   freverse := false;\r
 287   resume;\r
 288 end;\r
 289 procedure tdnswinasync.reverselookup(ip:tbinip);\r
 290 begin\r
 291   iplist := biniplist_new;\r
 292   biniplist_add(iplist,ip);\r
 293   freverse := true;\r
 294   resume;\r
 295 end;\r
 296 \r
 297 procedure tdnswinasync.execute;\r
 298 var\r
 299   error : integer;\r
 300 \r
 301 begin\r
 302   error := 0;\r
 303   if reverse then begin\r
 304     name := winreverselookup(biniplist_get(iplist,0),error);\r
 305   end else begin\r
 306     iplist := winforwardlookuplist(name,0,error);\r
 307 \r
 308   end;\r
 309   postmessage(hwnddnswin,wm_user,error,taddrint(self));\r
 310 end;\r
 311 \r
 312 destructor tdnswinasync.destroy;\r
 313 begin\r
 314   WaitFor;\r
 315   inherited destroy;\r
 316 end;\r
 317 procedure tdnswinasync.release;\r
 318 begin\r
 319   if hadevent then destroy else begin\r
 320     onrequestdone := nil;\r
 321     freewhendone := true;\r
 322   end;\r
 323 end;\r
 324 \r
 325 constructor tdnswinasync.create;\r
 326 begin\r
 327   inherited create(true);\r
 328 end;\r
 329 \r
 330 var\r
 331   MyWindowClass : TWndClass = (style         : 0;\r
 332                                  lpfnWndProc   : @MyWindowProc;\r
 333                                  cbClsExtra    : 0;\r
 334                                  cbWndExtra    : 0;\r
 335                                  hInstance     : 0;\r
 336                                  hIcon         : 0;\r
 337                                  hCursor       : 0;\r
 338                                  hbrBackground : 0;\r
 339                                  lpszMenuName  : nil;\r
 340                                  lpszClassName : 'dnswinClass');\r
 341 begin\r
 342 \r
 343     if Windows.RegisterClass(MyWindowClass) = 0 then halt;\r
 344   //writeln('about to create lcore handle, hinstance=',hinstance);\r
 345   hwnddnswin := CreateWindowEx(WS_EX_TOOLWINDOW,\r
 346                                MyWindowClass.lpszClassName,\r
 347                                '',        { Window name   }\r
 348                                WS_POPUP,  { Window Style  }\r
 349                                0, 0,      { X, Y          }\r
 350                                0, 0,      { Width, Height }\r
 351                                0,         { hWndParent    }\r
 352                                0,         { hMenu         }\r
 353                                HInstance, { hInstance     }\r
 354                                nil);      { CreateParam   }\r
 355   //writeln('dnswin hwnd is ',hwnddnswin);\r
 356   //writeln('last error is ',GetLastError);\r
 357 end.\r