1package Net::DNS::Resolver::MSWin32;
2
3use strict;
4use warnings;
5our $VERSION = (qw$Id: MSWin32.pm 1812 2020-10-07 18:09:53Z willem $)[2];
6
7
8=head1 NAME
9
10Net::DNS::Resolver::MSWin32 - MS Windows resolver class
11
12=cut
13
14
15use base qw(Net::DNS::Resolver::Base);
16use Carp;
17
18use constant WINHLP => defined eval 'require Win32::IPHelper';	## no critic
19use constant WINREG => defined eval 'use Win32::TieRegistry qw(KEY_READ REG_DWORD); 1';	## no critic
20
21our $Registry;
22
23
24sub _init {
25	my $defaults = shift->_defaults;
26
27	my $debug = 0;
28
29	my $FIXED_INFO = {};
30
31	my $err = Win32::IPHelper::GetNetworkParams($FIXED_INFO);
32	croak "GetNetworkParams() error %u: %s\n", $err, Win32::FormatMessage($err) if $err;
33
34	if ($debug) {
35		require Data::Dumper;
36		print Data::Dumper::Dumper $FIXED_INFO;
37	}
38
39
40	my @nameservers = map { $_->{IpAddress} } @{$FIXED_INFO->{DnsServersList}};
41	$defaults->nameservers(@nameservers);
42
43	my $devolution = 0;
44	my $domainname = $FIXED_INFO->{DomainName} || '';
45	my @searchlist = grep {length} $domainname;
46
47	if (WINREG) {
48
49		# The Win32::IPHelper does not return searchlist.
50		# Make best effort attempt to get searchlist from the registry.
51
52		my @root = qw(HKEY_LOCAL_MACHINE SYSTEM CurrentControlSet Services);
53
54		my $leaf = join '\\', @root, qw(Tcpip Parameters);
55		my $reg_tcpip = $Registry->Open( $leaf, {Access => KEY_READ} );
56
57		unless ( defined $reg_tcpip ) {			# Didn't work, Win95/98/Me?
58			$leaf = join '\\', @root, qw(VxD MSTCP);
59			$reg_tcpip = $Registry->Open( $leaf, {Access => KEY_READ} );
60		}
61
62		if ( defined $reg_tcpip ) {
63			my $searchlist = $reg_tcpip->GetValue('SearchList') || '';
64			push @searchlist, split m/[\s,]+/, $searchlist;
65
66			my ( $value, $type ) = $reg_tcpip->GetValue('UseDomainNameDevolution');
67			$devolution = defined $value && $type == REG_DWORD ? hex $value : 0;
68		}
69	}
70
71
72	# fix devolution if configured, and simultaneously
73	# eliminate duplicate entries (but keep the order)
74	my @list;
75	my %seen;
76	foreach (@searchlist) {
77		s/\.+$//;
78		push( @list, $_ ) unless $seen{lc $_}++;
79
80		next unless $devolution;
81
82		# while there are more than two labels, cut
83		while (s#^[^.]+\.(.+\..+)$#$1#) {
84			push( @list, $_ ) unless $seen{lc $_}++;
85		}
86	}
87	$defaults->searchlist(@list);
88
89	%$defaults = Net::DNS::Resolver::Base::_untaint(%$defaults);
90
91	$defaults->_read_env;
92	return;
93}
94
95
961;
97__END__
98
99
100=head1 SYNOPSIS
101
102    use Net::DNS::Resolver;
103
104=head1 DESCRIPTION
105
106This class implements the OS specific portions of C<Net::DNS::Resolver>.
107
108No user serviceable parts inside, see L<Net::DNS::Resolver>
109for all your resolving needs.
110
111=head1 COPYRIGHT
112
113Copyright (c)2003 Chris Reinhardt.
114
115Portions Copyright (c)2009 Olaf Kolkman, NLnet Labs
116
117All rights reserved.
118
119=head1 LICENSE
120
121Permission to use, copy, modify, and distribute this software and its
122documentation for any purpose and without fee is hereby granted, provided
123that the above copyright notice appear in all copies and that both that
124copyright notice and this permission notice appear in supporting
125documentation, and that the name of the author not be used in advertising
126or publicity pertaining to distribution of the software without specific
127prior written permission.
128
129THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
130IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
131FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
132THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
133LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
134FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
135DEALINGS IN THE SOFTWARE.
136
137=head1 SEE ALSO
138
139L<perl>, L<Net::DNS>, L<Net::DNS::Resolver>
140
141=cut
142
143