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

Annotation of /trunk/httpserver_20080306/dnswin.pas

Parent Directory Parent Directory | Revision Log Revision Log


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

1 plugwash 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 if res.ai_family = af_inet6 then begin
192     result.family := af_inet6;
193     result.ip6 := res.ai_addr.InAddr6.sin6_addr;
194     end;
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 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 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     dwas.hadevent := true;
250     if assigned (dwas.onrequestdone) then dwas.onrequestdone(dwas,awparam);
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