123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357 |
- unit dnswin;
-
- interface
-
- uses binipstuff,classes,lcore;
-
- {$include lcoreconfig.inc}
-
- //on failure a null string or zeroed out binip will be retuned and error will be
- //set to a windows error code (error will be left untouched under non error
- //conditions).
- function winforwardlookuplist(name : string;familyhint:integer;var error : integer) : tbiniplist;
- function winreverselookup(ip:tbinip;var error:integer):string;
-
-
- type
- //do not call destroy on a tdnswinasync instead call release and the
- //dnswinasync will be freed when appropriate. Calling destroy will block
- //the calling thread until the dns lookup completes.
- //release should only be called from the main thread
- tdnswinasync=class(tthread)
- private
- freverse : boolean;
- error : integer;
- freewhendone : boolean;
- hadevent : boolean;
- protected
- procedure execute; override;
- public
- onrequestdone:tsocketevent;
- name : string;
- iplist : tbiniplist;
-
- procedure forwardlookup(name:string);
- procedure reverselookup(ip:tbinip);
- destructor destroy; override;
- procedure release;
- constructor create;
- property reverse : boolean read freverse;
-
- end;
-
- implementation
- uses
- lsocket,pgtypes,sysutils,winsock,windows,messages;
-
- type
- //taddrinfo = record; //forward declaration
- paddrinfo = ^taddrinfo;
- taddrinfo = packed record
- ai_flags : longint;
- ai_family : longint;
- ai_socktype : longint;
- ai_protocol : longint;
- ai_addrlen : taddrint;
- ai_canonname : pchar;
- ai_addr : pinetsockaddrv;
- ai_next : paddrinfo;
- end;
- ppaddrinfo = ^paddrinfo;
- tgetaddrinfo = function(nodename : pchar; servname : pchar; hints : paddrinfo;res : ppaddrinfo) : longint; stdcall;
- tfreeaddrinfo = procedure(ai : paddrinfo); stdcall;
- tgetnameinfo = function(sa:Pinetsockaddrv;salen : longint; host:pchar;hostlen : longint;serv:pchar;servlen:longint;flags:longint) : longint;stdcall;
- var
- getaddrinfo : tgetaddrinfo;
- freeaddrinfo : tfreeaddrinfo;
- getnameinfo : tgetnameinfo;
- procedure v4onlyfreeaddrinfo(ai : paddrinfo); stdcall;
- var
- next:paddrinfo;
- begin
- while assigned(ai) do begin
- freemem(ai.ai_addr);
- next := ai.ai_next;
- freemem(ai);
- ai := next;
- end;
- end;
-
- type
- plongint = ^longint;
- pplongint = ^plongint;
-
- function v4onlygetaddrinfo(nodename : pchar; servname : pchar; hints : paddrinfo;res : ppaddrinfo) : longint; stdcall;
- var
- output,prev,first : paddrinfo;
- hostent : phostent;
- addrlist:^pointer;
- begin
- if hints.ai_family <> af_inet6 then begin
- result := 0;
-
-
- hostent := gethostbyname(nodename);
- if hostent = nil then begin
- result := wsagetlasterror;
- v4onlyfreeaddrinfo(output);
- exit;
- end;
- addrlist := pointer(hostent.h_addr_list);
-
- //ipint := pplongint(hostent.h_addr_list)^^;
- prev := nil;
- first := nil;
- repeat
- if not assigned(addrlist^) then break;
-
- getmem(output,sizeof(taddrinfo));
- if assigned(prev) then prev.ai_next := output;
- getmem(output.ai_addr,sizeof(tinetsockaddr));
- if servname <> nil then output.ai_addr.InAddr.port := htons(strtoint(servname)) else output.ai_addr.InAddr.port := 0;
- output.ai_addr.InAddr.addr := longint(addrlist^^);
- inc(integer(addrlist),4);
- output.ai_flags := 0;
- output.ai_family := af_inet;
- output.ai_socktype := 0;
- output.ai_protocol := 0;
- output.ai_addrlen := sizeof(tinetsockaddr);
- output.ai_canonname := nil;
- output.ai_next := nil;
- prev := output;
- if not assigned(first) then first := output;
- until false;
- res^ := first;
- end else begin
- result := WSANO_RECOVERY;
- end;
- end;
-
- function min(a,b : integer):integer;
- begin
- if a<b then result := a else result := b;
- end;
-
- function v4onlygetnameinfo(sa:Pinetsockaddrv;salen : longint; host:pchar;hostlen : longint;serv:pchar;servlen:longint;flags:longint) : longint;stdcall;
- var
- hostent : phostent;
- bytestocopy : integer;
- begin
- if sa.InAddr.family = af_inet then begin
- result := 0;
- hostent := gethostbyaddr(@(sa.inaddr.addr),4,AF_INET);
- if hostent = nil then begin
- result := wsagetlasterror;
- exit;
- end;
- bytestocopy := min(strlen(hostent.h_name)+1,hostlen);
- move((hostent.h_name)^,host^,bytestocopy);
-
-
- end else begin
- result := WSANO_RECOVERY;
- end;
- end;
-
-
- procedure populateprocvars;
- var
- libraryhandle : hmodule;
- i : integer;
- dllname : string;
-
- begin
- if assigned(getaddrinfo) then exit; //procvars already populated
- for i := 0 to 1 do begin
- if i=0 then dllname := 'Ws2_32.dll' else dllname := 'Wship6.dll';
- libraryhandle := LoadLibrary(pchar(dllname));
- getaddrinfo := getprocaddress(libraryhandle,'getaddrinfo');
- freeaddrinfo := getprocaddress(libraryhandle,'freeaddrinfo');
- getnameinfo := getprocaddress(libraryhandle,'getnameinfo');
- if assigned(getaddrinfo) and assigned(freeaddrinfo) and assigned(getnameinfo) then begin
- //writeln('found getaddrinfo and freeaddrinfo in'+dllname);
- exit; //success
- end;
-
- end;
- //writeln('could not find getaddrinfo and freeaddrinfo, falling back to ipv4 only lookup');
- getaddrinfo := v4onlygetaddrinfo;
- freeaddrinfo := v4onlyfreeaddrinfo;
- getnameinfo := v4onlygetnameinfo;
- end;
-
-
- function winforwardlookuplist(name : string;familyhint:integer;var error : integer) : tbiniplist;
- var
- hints: taddrinfo;
- res0,res : paddrinfo;
- getaddrinforesult : integer;
- biniptemp:tbinip;
- begin
- populateprocvars;
-
- hints.ai_flags := 0;
- hints.ai_family := familyhint;
- hints.ai_socktype := 0;
- hints.ai_protocol := 0;
- hints.ai_addrlen := 0;
- hints.ai_canonname := nil;
- hints.ai_addr := nil;
- hints.ai_next := nil;
- getaddrinforesult := getaddrinfo(pchar(name),'1',@hints,@res);
- res0 := res;
- result := biniplist_new;
- if getaddrinforesult = 0 then begin
-
- while assigned(res) do begin
- if res.ai_family = af_inet then begin
- biniptemp.family := af_inet;
- biniptemp.ip := res.ai_addr.InAddr.addr;
- biniplist_add(result,biniptemp);
- {$ifdef ipv6}
- end else if res.ai_family = af_inet6 then begin
- biniptemp.family := af_inet6;
- biniptemp.ip6 := res.ai_addr.InAddr6.sin6_addr;
- biniplist_add(result,biniptemp);
- {$endif}
- end;
- res := res.ai_next;
- end;
- freeaddrinfo(res0);
- exit;
- end;
-
- if getaddrinforesult <> 0 then begin
- fillchar(result,0,sizeof(result));
- error := getaddrinforesult;
- end;
- end;
-
- function winreverselookup(ip:tbinip;var error : integer):string;
- var
- sa : tinetsockaddrv;
- getnameinforesult : integer;
- begin
-
- if ip.family = AF_INET then begin
- sa.InAddr.family := AF_INET;
- sa.InAddr.port := 1;
- sa.InAddr.addr := ip.ip;
- end else {$ifdef ipv6}if ip.family = AF_INET6 then begin
- sa.InAddr6.sin6_family := AF_INET6;
- sa.InAddr6.sin6_port := 1;
- sa.InAddr6.sin6_addr := ip.ip6;
- end else{$endif} begin
- raise exception.create('unrecognised address family');
- end;
- populateprocvars;
- setlength(result,1025);
- getnameinforesult := getnameinfo(@sa,sizeof(tinetsockaddrv),pchar(result),length(result),nil,0,0);
- if getnameinforesult <> 0 then begin
- error := getnameinforesult;
- result := '';
- exit;
- end;
- if pos(#0,result) >= 0 then begin
- setlength(result,pos(#0,result)-1);
- end;
- end;
-
- var
- hwnddnswin : hwnd;
-
- function MyWindowProc(
- ahWnd : HWND;
- auMsg : Integer;
- awParam : WPARAM;
- alParam : LPARAM): Integer; stdcall;
- var
- dwas : tdnswinasync;
- begin
- if (ahwnd=hwnddnswin) and (aumsg=wm_user) then begin
- Dwas := tdnswinasync(alparam);
- if assigned (dwas.onrequestdone) then dwas.onrequestdone(dwas,awparam);
- dwas.hadevent := true;
- if dwas.freewhendone then dwas.free;
- end else begin
- //not passing unknown messages on to defwindowproc will cause window
- //creation to fail! --plugwash
- Result := DefWindowProc(ahWnd, auMsg, awParam, alParam)
- end;
- end;
-
- procedure tdnswinasync.forwardlookup(name:string);
- begin
- self.name := name;
- freverse := false;
- resume;
- end;
- procedure tdnswinasync.reverselookup(ip:tbinip);
- begin
- iplist := biniplist_new;
- biniplist_add(iplist,ip);
- freverse := true;
- resume;
- end;
-
- procedure tdnswinasync.execute;
- var
- error : integer;
-
- begin
- error := 0;
- if reverse then begin
- name := winreverselookup(biniplist_get(iplist,0),error);
- end else begin
- iplist := winforwardlookuplist(name,0,error);
-
- end;
- postmessage(hwnddnswin,wm_user,error,taddrint(self));
- end;
-
- destructor tdnswinasync.destroy;
- begin
- WaitFor;
- inherited destroy;
- end;
- procedure tdnswinasync.release;
- begin
- if hadevent then destroy else begin
- onrequestdone := nil;
- freewhendone := true;
- end;
- end;
-
- constructor tdnswinasync.create;
- begin
- inherited create(true);
- end;
-
- var
- MyWindowClass : TWndClass = (style : 0;
- lpfnWndProc : @MyWindowProc;
- cbClsExtra : 0;
- cbWndExtra : 0;
- hInstance : 0;
- hIcon : 0;
- hCursor : 0;
- hbrBackground : 0;
- lpszMenuName : nil;
- lpszClassName : 'dnswinClass');
- begin
-
- if Windows.RegisterClass(MyWindowClass) = 0 then halt;
- //writeln('about to create lcore handle, hinstance=',hinstance);
- hwnddnswin := CreateWindowEx(WS_EX_TOOLWINDOW,
- MyWindowClass.lpszClassName,
- '', { Window name }
- WS_POPUP, { Window Style }
- 0, 0, { X, Y }
- 0, 0, { Width, Height }
- 0, { hWndParent }
- 0, { hMenu }
- HInstance, { hInstance }
- nil); { CreateParam }
- //writeln('dnswin hwnd is ',hwnddnswin);
- //writeln('last error is ',GetLastError);
- end.
|