1package Net::DNS::Resolver::Win32;
2#
3# $Id: Win32.pm 588 2006-05-22 20:28:00Z olaf $
4#
5
6use strict;
7use vars qw(@ISA $VERSION);
8
9use Net::DNS::Resolver::Base ();
10
11@ISA     = qw(Net::DNS::Resolver::Base);
12$VERSION = (qw$LastChangedRevision: 588 $)[1];
13
14use Win32::Registry;
15
16sub init {
17
18        my $debug=0;
19	my ($class) = @_;
20
21	my $defaults = $class->defaults;
22
23	my ($resobj, %keys);
24
25	my $root = 'SYSTEM\CurrentControlSet\Services\Tcpip\Parameters';
26
27	unless ($main::HKEY_LOCAL_MACHINE->Open($root, $resobj)) {
28		# Didn't work, maybe we are on 95/98/Me?
29		$root = 'SYSTEM\CurrentControlSet\Services\VxD\MSTCP';
30		$main::HKEY_LOCAL_MACHINE->Open($root, $resobj)
31			or Carp::croak "can't read registry: $!";
32	}
33
34	$resobj->GetValues(\%keys)
35		or Carp::croak "can't read registry values: $!";
36
37	# Best effort to find a useful domain name for the current host
38	# if domain ends up blank, we're probably (?) not connected anywhere
39	# a DNS server is interesting either...
40	my $domain = $keys{'Domain'}->[2] || $keys{'DhcpDomain'}->[2] || '';
41
42	# If nothing else, the searchlist should probably contain our own domain
43	# also see below for domain name devolution if so configured
44	# (also remove any duplicates later)
45	my $searchlist = "$domain ";
46	$searchlist  .= $keys{'SearchList'}->[2];
47
48	# This is (probably) adequate on NT4
49	# NameServer overrides DhcpNameServer if both exist
50	my $nt4nameservers = $keys{'NameServer'}->[2] || $keys{'DhcpNameServer'}->[2];
51	my $nameservers = "";
52
53
54
55#
56#
57#  This code is agued to be broken see ticket rt.cpan.org ticket 11931
58#  There seems to be sufficient reason to remove this code
59#
60#  For details see https://rt.cpan.org/Ticket/Display.html?id=11931
61#
62#
63#	#
64#	# but on W2K/XP the registry layout is more advanced due to dynamically
65#	# appearing connections. So we attempt to handle them, too...
66#	# opt to silently fail if something isn't ok (maybe we're on NT4)
67#	# drop any duplicates later, but must ignore NT4 style entries if in 2K/XP
68#	my $dnsadapters;
69#	$resobj->Open("DNSRegisteredAdapters", $dnsadapters);
70#	if ($dnsadapters) {
71#		my @adapters;
72#		$dnsadapters->GetKeys(\@adapters);
73#		foreach my $adapter (@adapters) {
74#			my $regadapter;
75#			$dnsadapters->Open($adapter, $regadapter);
76#			if ($regadapter) {
77#				my($type,$ns);
78#				$regadapter->QueryValueEx("DNSServerAddresses", $type, $ns);
79#				while (length($ns) >= 4) {
80#					my $addr = join('.', unpack("C4", substr($ns,0,4,"")));
81#					$nameservers .= " $addr";
82#				}
83#			}
84#		}
85#	}
86
87
88
89
90  # This code was introduced by Hanno Stock, see ticket 1193 dd May 19 2006
91  #
92  # it should work on Win2K and XP and looks for the DNS services
93  # using the BIND key
94  #
95
96  my $bind_linkage;
97  my @sorted_interfaces;
98	print ";; DNS: Getting sorted interface list\n" if $debug;
99  $main::HKEY_LOCAL_MACHINE->Open('SYSTEM\CurrentControlSet\Services\Tcpip\Linkage',
100   $bind_linkage);
101	if($bind_linkage){
102	  my $bind_linkage_list;
103	  my $type;
104	  $bind_linkage->QueryValueEx('Bind', $type, $bind_linkage_list);
105	  if($bind_linkage_list){
106	    @sorted_interfaces = split(m/[^\w{}\\-]+/s, $bind_linkage_list);
107	  }
108	  foreach my $interface (@sorted_interfaces){
109	    $interface =~ s/^\\device\\//i;
110	    print ";; DNS:Interface: $interface\n" if $debug;
111	  }
112	}
113
114
115	my $interfaces;
116	$resobj->Open("Interfaces", $interfaces);
117	if ($interfaces) {
118	  my @ifacelist;
119	  if(@sorted_interfaces){
120	    @ifacelist = @sorted_interfaces;
121	  }else{
122	    $interfaces->GetKeys(\@ifacelist);
123	  }
124	  foreach my $iface (@ifacelist) {
125		my $regiface;
126		$interfaces->Open($iface, $regiface);
127
128		if ($regiface) {
129		    my $ns;
130		    my $type;
131		    my $ip;
132		    my $ipdhcp;
133		    $regiface->QueryValueEx("IPAddress", $type, $ip);
134		    $regiface->QueryValueEx("DhcpIPAddress", $type, $ipdhcp);
135		    if (($ip && !($ip =~ /0\.0\.0\.0/)) || ($ipdhcp && !($ipdhcp =~ /0\.0
136\.0\.0/))) {
137			# NameServer overrides DhcpNameServer if both exist
138			$regiface->QueryValueEx("NameServer", $type, $ns);
139			$regiface->QueryValueEx("DhcpNameServer", $type, $ns) unless $ns;
140			$nameservers .= " $ns" if $ns;
141		    }
142		}
143	    }
144	}
145	if (!$nameservers) {
146	    $nameservers = $nt4nameservers;
147	}
148
149	if ($domain) {
150		$defaults->{'domain'} = $domain;
151	}
152
153	my $usedevolution = $keys{'UseDomainNameDevolution'}->[2];
154	if ($searchlist) {
155		# fix devolution if configured, and simultaneously make sure no dups (but keep the order)
156		my @a;
157		my %h;
158		foreach my $entry (split(m/[\s,]+/, $searchlist)) {
159			push(@a, $entry) unless $h{$entry};
160			$h{$entry} = 1;
161			if ($usedevolution) {
162				# as long there's more than two pieces, cut
163				while ($entry =~ m#\..+\.#) {
164					$entry =~ s#^[^\.]+\.(.+)$#$1#;
165					push(@a, $entry) unless $h{$entry};
166					$h{$entry} = 1;
167					}
168				}
169			}
170		$defaults->{'searchlist'} = \@a;
171	}
172
173	if ($nameservers) {
174		# remove blanks and dupes
175		my @a;
176		my %h;
177		foreach my $ns (split(m/[\s,]+/, $nameservers)) {
178			push @a, $ns unless (!$ns || $h{$ns});
179			$h{$ns} = 1;
180		}
181		$defaults->{'nameservers'} = [map { m/(.*)/ } @a];
182	}
183
184	$class->read_env;
185
186	if (!$defaults->{'domain'} && @{$defaults->{'searchlist'}}) {
187		$defaults->{'domain'} = $defaults->{'searchlist'}[0];
188	} elsif (!@{$defaults->{'searchlist'}} && $defaults->{'domain'}) {
189		$defaults->{'searchlist'} = [ $defaults->{'domain'} ];
190	}
191}
192
1931;
194__END__
195
196
197=head1 NAME
198
199Net::DNS::Resolver::Win32 - Windows Resolver Class
200
201=head1 SYNOPSIS
202
203 use Net::DNS::Resolver;
204
205=head1 DESCRIPTION
206
207This class implements the windows specific portions of C<Net::DNS::Resolver>.
208
209No user serviceable parts inside, see L<Net::DNS::Resolver|Net::DNS::Resolver>
210for all your resolving needs.
211
212=head1 COPYRIGHT
213
214Copyright (c) 1997-2002 Michael Fuhr.
215
216Portions Copyright (c) 2002-2004 Chris Reinhardt.
217
218All rights reserved.  This program is free software; you may redistribute
219it and/or modify it under the same terms as Perl itself.
220
221=head1 SEE ALSO
222
223L<perl(1)>, L<Net::DNS>, L<Net::DNS::Resolver>
224
225=cut
226