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