dnswin.pas

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