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

Contents of /trunk/dnswin.pas

Parent Directory Parent Directory | Revision Log Revision Log


Revision 46 - (show annotations)
Mon Apr 13 00:16:07 2009 UTC (10 years, 7 months ago) by plugwash
File size: 10138 byte(s)
fix screwup in previous commit

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

Properties

Name Value
svn:executable

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