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

Contents of /trunk/dnswin.pas

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2 - (show annotations)
Sun Mar 30 00:16:07 2008 UTC (11 years, 7 months ago) by beware
File size: 10589 byte(s)
the big lot of changes by beware

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