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

Contents of /trunk/dnswin.pas

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1 - (show annotations)
Fri Mar 28 02:26:58 2008 UTC (13 years, 4 months ago) by plugwash
File size: 10010 byte(s)
initial import

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