lcore/trunk/dnswin.pas

unit dnswin;

interface

uses binipstuff,classes,lcore,pgtypes;

{$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 : thostname;familyhint:integer;var error : integer) : tbiniplist;
function winreverselookup(ip:tbinip;var error:integer):thostname;


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;
    freewhendone : boolean;
    hadevent : boolean;
  protected
    procedure execute; override;
  public
    onrequestdone:tsocketevent;
    name : thostname;
    iplist : tbiniplist;

    procedure forwardlookup(name:thostname);
    procedure reverselookup(ip:tbinip);
    destructor destroy; override;
    procedure release;
    constructor create;
    property reverse : boolean read freverse;

  end;

procedure init;

implementation
uses
  // zipplet: moved pgtypes to interface because it's needed for the string definitions
  lsocket,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 : pansichar;
    ai_addr : pinetsockaddrv;
    ai_next : paddrinfo;
  end;
  ppaddrinfo = ^paddrinfo;
  tgetaddrinfo = function(nodename : pansichar; servname : pansichar; hints : paddrinfo;res : ppaddrinfo) : longint; stdcall;
  tfreeaddrinfo = procedure(ai : paddrinfo); stdcall;
  tgetnameinfo = function(sa:Pinetsockaddrv;salen : longint; host:pansichar;hostlen : longint;serv:pansichar;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 : pansichar; servname : pansichar; hints : paddrinfo;res : ppaddrinfo) : longint; stdcall;
var
  output,prev,first : paddrinfo;
  hostent : phostent;
  addrlist:^pointer;
begin
  output := nil;
  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(tlinetsockaddr4));
      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(taddrint(addrlist),4);
      output.ai_flags := 0;
      output.ai_family := af_inet;
      output.ai_socktype := 0;
      output.ai_protocol := 0;
      output.ai_addrlen := sizeof(tlinetsockaddr4);
      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:pansichar;hostlen : longint;serv:pansichar;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 : ansistring;

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 := LoadLibraryA(pansichar(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 : thostname;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(pansichar(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):thostname;
var
  sa : tinetsockaddrv;
  getnameinforesult : integer;
begin

  makeinaddrv(ip,'1',sa);
  populateprocvars;
  setlength(result,1025);
  getnameinforesult := getnameinfo(@sa,sizeof(tinetsockaddrv),pansichar(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;
    result := 0; {added returning 0 when handling --beware}
  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:thostname);
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');
procedure init;
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;


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