/[lcore]/trunk/dnswin.pas
ViewVC logotype

Contents of /trunk/dnswin.pas

Parent Directory Parent Directory | Revision Log Revision Log


Revision 147 - (show annotations)
Mon Feb 6 17:38:48 2017 UTC (10 months, 1 week ago) by beware
File size: 10409 byte(s)
comment style
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(integer(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.

Properties

Name Value
svn:eol-style CRLF

No admin address has been configured">No admin address has been configured
ViewVC Help
Powered by ViewVC 1.1.5