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

Annotation of /trunk/dnswin.pas

Parent Directory Parent Directory | Revision Log Revision Log


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

1 plugwash 1 unit dnswin;
2    
3     interface
4 beware 2
5 plugwash 1 uses binipstuff,classes,lcore;
6    
7 beware 2 {$include lcoreconfig.inc}
8    
9 plugwash 1 //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 beware 2 function winforwardlookuplist(name : string;familyhint:integer;var error : integer) : tbiniplist;
13 plugwash 1 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 plugwash 13 iplist : tbiniplist;
33 plugwash 1
34 beware 20 procedure forwardlookup(name:string);
35 plugwash 1 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 beware 2 var
70     next:paddrinfo;
71 plugwash 1 begin
72 beware 2 while assigned(ai) do begin
73     freemem(ai.ai_addr);
74     next := ai.ai_next;
75     freemem(ai);
76     ai := next;
77     end;
78 plugwash 1 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 beware 2 output,prev,first : paddrinfo;
87 plugwash 1 hostent : phostent;
88 beware 2 addrlist:^pointer;
89 plugwash 1 begin
90 beware 2 if hints.ai_family <> af_inet6 then begin
91 plugwash 1 result := 0;
92 beware 2
93    
94 plugwash 1 hostent := gethostbyname(nodename);
95     if hostent = nil then begin
96     result := wsagetlasterror;
97     v4onlyfreeaddrinfo(output);
98     exit;
99     end;
100 beware 2 addrlist := pointer(hostent.h_addr_list);
101 plugwash 1
102 beware 2 //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 plugwash 1 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 beware 2 function winforwardlookuplist(name : string;familyhint:integer;var error : integer) : tbiniplist;
185 plugwash 1 var
186     hints: taddrinfo;
187 beware 2 res0,res : paddrinfo;
188 plugwash 1 getaddrinforesult : integer;
189 beware 2 biniptemp:tbinip;
190 plugwash 1 begin
191     populateprocvars;
192    
193 beware 2 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 plugwash 1 if res.ai_family = af_inet then begin
208 beware 2 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 plugwash 1 end;
220 beware 2 freeaddrinfo(res0);
221     exit;
222 plugwash 1 end;
223 beware 2
224 plugwash 1 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 plugwash 46 makeinaddrv(ip,'1',sa);
237 plugwash 1 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 beware 20 procedure tdnswinasync.forwardlookup(name:string);
274 plugwash 1 begin
275     self.name := name;
276     freverse := false;
277     resume;
278     end;
279     procedure tdnswinasync.reverselookup(ip:tbinip);
280     begin
281 plugwash 13 iplist := biniplist_new;
282     biniplist_add(iplist,ip);
283 plugwash 1 freverse := true;
284     resume;
285     end;
286 beware 2
287 plugwash 1 procedure tdnswinasync.execute;
288     var
289     error : integer;
290 plugwash 13
291 plugwash 1 begin
292     error := 0;
293     if reverse then begin
294 plugwash 13 name := winreverselookup(biniplist_get(iplist,0),error);
295 plugwash 1 end else begin
296 plugwash 13 iplist := winforwardlookuplist(name,0,error);
297    
298 plugwash 1 end;
299     postmessage(hwnddnswin,wm_user,error,taddrint(self));
300     end;
301    
302 beware 2 destructor tdnswinasync.destroy;
303 plugwash 1 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