Commit | Line | Data |
---|---|---|
406c51ee JH |
1 | # Net::Domain.pm |
2 | # | |
2e173144 CBW |
3 | # Versions up to 2.21 Copyright (c) 1995-1998 Graham Barr <gbarr@pobox.com>. |
4 | # All rights reserved. | |
5 | # Changes in Version 2.22 onwards Copyright (C) 2013-2014 Steve Hay. All rights | |
6 | # reserved. | |
a4f8ff46 SH |
7 | # This module is free software; you can redistribute it and/or modify it under |
8 | # the same terms as Perl itself, i.e. under the terms of either the GNU General | |
9 | # Public License or the Artistic License, as specified in the F<LICENCE> file. | |
406c51ee JH |
10 | |
11 | package Net::Domain; | |
12 | ||
2e173144 | 13 | use 5.008001; |
406c51ee | 14 | |
406c51ee | 15 | use strict; |
2e173144 | 16 | use warnings; |
406c51ee | 17 | |
2e173144 CBW |
18 | use Carp; |
19 | use Exporter; | |
20 | use Net::Config; | |
406c51ee | 21 | |
2e173144 CBW |
22 | our @ISA = qw(Exporter); |
23 | our @EXPORT_OK = qw(hostname hostdomain hostfqdn domainname); | |
bfdb5bfe | 24 | our $VERSION = "3.08"; |
406c51ee | 25 | |
b3f6f6a6 | 26 | my ($host, $domain, $fqdn) = (undef, undef, undef); |
406c51ee JH |
27 | |
28 | # Try every conceivable way to get hostname. | |
29 | ||
b3f6f6a6 | 30 | |
406c51ee JH |
31 | sub _hostname { |
32 | ||
b3f6f6a6 RGS |
33 | # we already know it |
34 | return $host | |
35 | if (defined $host); | |
36 | ||
37 | if ($^O eq 'MSWin32') { | |
38 | require Socket; | |
39 | my ($name, $alias, $type, $len, @addr) = gethostbyname($ENV{'COMPUTERNAME'} || 'localhost'); | |
40 | while (@addr) { | |
41 | my $a = shift(@addr); | |
42 | $host = gethostbyaddr($a, Socket::AF_INET()); | |
43 | last if defined $host; | |
406c51ee | 44 | } |
b3f6f6a6 RGS |
45 | if (defined($host) && index($host, '.') > 0) { |
46 | $fqdn = $host; | |
2901a52f | 47 | ($host, $domain) = $fqdn =~ /^([^.]+)\.(.*)$/; |
406c51ee | 48 | } |
b3f6f6a6 RGS |
49 | return $host; |
50 | } | |
51 | elsif ($^O eq 'MacOS') { | |
52 | chomp($host = `hostname`); | |
53 | } | |
54 | elsif ($^O eq 'VMS') { ## multiple varieties of net s/w makes this hard | |
55 | $host = $ENV{'UCX$INET_HOST'} if defined($ENV{'UCX$INET_HOST'}); | |
56 | $host = $ENV{'MULTINET_HOST_NAME'} if defined($ENV{'MULTINET_HOST_NAME'}); | |
57 | if (index($host, '.') > 0) { | |
58 | $fqdn = $host; | |
2901a52f | 59 | ($host, $domain) = $fqdn =~ /^([^.]+)\.(.*)$/; |
406c51ee | 60 | } |
b3f6f6a6 RGS |
61 | return $host; |
62 | } | |
63 | else { | |
64 | local $SIG{'__DIE__'}; | |
686337f3 | 65 | |
b3f6f6a6 RGS |
66 | # syscall is preferred since it avoids tainting problems |
67 | eval { | |
68 | my $tmp = "\0" x 256; ## preload scalar | |
69 | eval { | |
70 | package main; | |
2e173144 | 71 | require "syscall.ph"; ## no critic (Modules::RequireBarewordIncludes) |
b3f6f6a6 RGS |
72 | defined(&main::SYS_gethostname); |
73 | } | |
74 | || eval { | |
75 | package main; | |
2e173144 | 76 | require "sys/syscall.ph"; ## no critic (Modules::RequireBarewordIncludes) |
b3f6f6a6 RGS |
77 | defined(&main::SYS_gethostname); |
78 | } | |
79 | and $host = | |
80 | (syscall(&main::SYS_gethostname, $tmp, 256) == 0) | |
81 | ? $tmp | |
82 | : undef; | |
83 | } | |
84 | ||
85 | # POSIX | |
86 | || eval { | |
87 | require POSIX; | |
88 | $host = (POSIX::uname())[1]; | |
89 | } | |
90 | ||
91 | # trusty old hostname command | |
92 | || eval { | |
93 | chop($host = `(hostname) 2>/dev/null`); # BSD'ish | |
94 | } | |
95 | ||
96 | # sysV/POSIX uname command (may truncate) | |
97 | || eval { | |
98 | chop($host = `uname -n 2>/dev/null`); ## SYSV'ish && POSIX'ish | |
99 | } | |
100 | ||
101 | # Apollo pre-SR10 | |
2901a52f | 102 | || eval { $host = (split(/[:. ]/, `/com/host`, 6))[0]; } |
b3f6f6a6 RGS |
103 | |
104 | || eval { $host = ""; }; | |
105 | } | |
106 | ||
107 | # remove garbage | |
108 | $host =~ s/[\0\r\n]+//go; | |
109 | $host =~ s/(\A\.+|\.+\Z)//go; | |
110 | $host =~ s/\.\.+/\./go; | |
111 | ||
112 | $host; | |
406c51ee JH |
113 | } |
114 | ||
b3f6f6a6 | 115 | |
406c51ee JH |
116 | sub _hostdomain { |
117 | ||
b3f6f6a6 RGS |
118 | # we already know it |
119 | return $domain | |
120 | if (defined $domain); | |
406c51ee | 121 | |
b3f6f6a6 RGS |
122 | local $SIG{'__DIE__'}; |
123 | ||
124 | return $domain = $NetConfig{'inet_domain'} | |
125 | if defined $NetConfig{'inet_domain'}; | |
126 | ||
127 | # try looking in /etc/resolv.conf | |
128 | # putting this here and assuming that it is correct, eliminates | |
129 | # calls to gethostbyname, and therefore DNS lookups. This helps | |
130 | # those on dialup systems. | |
131 | ||
b3f6f6a6 | 132 | local ($_); |
406c51ee | 133 | |
2e173144 CBW |
134 | if (open(my $res, '<', "/etc/resolv.conf")) { |
135 | while (<$res>) { | |
b3f6f6a6 RGS |
136 | $domain = $1 |
137 | if (/\A\s*(?:domain|search)\s+(\S+)/); | |
138 | } | |
2e173144 | 139 | close($res); |
b3f6f6a6 RGS |
140 | |
141 | return $domain | |
142 | if (defined $domain); | |
143 | } | |
406c51ee | 144 | |
b3f6f6a6 | 145 | # just try hostname and system calls |
406c51ee | 146 | |
b3f6f6a6 RGS |
147 | my $host = _hostname(); |
148 | my (@hosts); | |
406c51ee | 149 | |
b3f6f6a6 | 150 | @hosts = ($host, "localhost"); |
406c51ee | 151 | |
b3f6f6a6 RGS |
152 | unless (defined($host) && $host =~ /\./) { |
153 | my $dom = undef; | |
154 | eval { | |
155 | my $tmp = "\0" x 256; ## preload scalar | |
156 | eval { | |
157 | package main; | |
2e173144 | 158 | require "syscall.ph"; ## no critic (Modules::RequireBarewordIncludes) |
b3f6f6a6 RGS |
159 | } |
160 | || eval { | |
161 | package main; | |
2e173144 | 162 | require "sys/syscall.ph"; ## no critic (Modules::RequireBarewordIncludes) |
b3f6f6a6 RGS |
163 | } |
164 | and $dom = | |
165 | (syscall(&main::SYS_getdomainname, $tmp, 256) == 0) | |
166 | ? $tmp | |
167 | : undef; | |
168 | }; | |
169 | ||
170 | if ($^O eq 'VMS') { | |
171 | $dom ||= $ENV{'TCPIP$INET_DOMAIN'} | |
172 | || $ENV{'UCX$INET_DOMAIN'}; | |
406c51ee JH |
173 | } |
174 | ||
b3f6f6a6 | 175 | chop($dom = `domainname 2>/dev/null`) |
487a122b | 176 | unless (defined $dom || $^O =~ /^(?:cygwin|MSWin32|android)/); |
b3f6f6a6 RGS |
177 | |
178 | if (defined $dom) { | |
179 | my @h = (); | |
180 | $dom =~ s/^\.+//; | |
181 | while (length($dom)) { | |
182 | push(@h, "$host.$dom"); | |
183 | $dom =~ s/^[^.]+.+// or last; | |
184 | } | |
185 | unshift(@hosts, @h); | |
406c51ee | 186 | } |
b3f6f6a6 | 187 | } |
406c51ee | 188 | |
b3f6f6a6 | 189 | # Attempt to locate FQDN |
406c51ee | 190 | |
b3f6f6a6 RGS |
191 | foreach (grep { defined $_ } @hosts) { |
192 | my @info = gethostbyname($_); | |
406c51ee | 193 | |
b3f6f6a6 | 194 | next unless @info; |
406c51ee | 195 | |
b3f6f6a6 | 196 | # look at real name & aliases |
2e173144 | 197 | foreach my $site ($info[0], split(/ /, $info[1])) { |
b3f6f6a6 | 198 | if (rindex($site, ".") > 0) { |
406c51ee | 199 | |
b3f6f6a6 | 200 | # Extract domain from FQDN |
406c51ee | 201 | |
2901a52f | 202 | ($domain = $site) =~ s/\A[^.]+\.//; |
b3f6f6a6 RGS |
203 | return $domain; |
204 | } | |
406c51ee | 205 | } |
b3f6f6a6 | 206 | } |
406c51ee | 207 | |
b3f6f6a6 | 208 | # Look for environment variable |
406c51ee | 209 | |
b3f6f6a6 | 210 | $domain ||= $ENV{LOCALDOMAIN} || $ENV{DOMAIN}; |
406c51ee | 211 | |
b3f6f6a6 RGS |
212 | if (defined $domain) { |
213 | $domain =~ s/[\r\n\0]+//g; | |
214 | $domain =~ s/(\A\.+|\.+\Z)//g; | |
215 | $domain =~ s/\.\.+/\./g; | |
216 | } | |
406c51ee | 217 | |
b3f6f6a6 | 218 | $domain; |
406c51ee JH |
219 | } |
220 | ||
b3f6f6a6 | 221 | |
406c51ee JH |
222 | sub domainname { |
223 | ||
b3f6f6a6 RGS |
224 | return $fqdn |
225 | if (defined $fqdn); | |
406c51ee | 226 | |
b3f6f6a6 | 227 | _hostname(); |
8723f121 SH |
228 | |
229 | # *.local names are special on darwin. If we call gethostbyname below, it | |
230 | # may hang while waiting for another, non-existent computer to respond. | |
231 | if($^O eq 'darwin' && $host =~ /\.local$/) { | |
232 | return $host; | |
233 | } | |
234 | ||
b3f6f6a6 | 235 | _hostdomain(); |
406c51ee | 236 | |
b3f6f6a6 RGS |
237 | # Assumption: If the host name does not contain a period |
238 | # and the domain name does, then assume that they are correct | |
239 | # this helps to eliminate calls to gethostbyname, and therefore | |
07513bb4 | 240 | # eliminate DNS lookups |
406c51ee | 241 | |
b3f6f6a6 RGS |
242 | return $fqdn = $host . "." . $domain |
243 | if (defined $host | |
244 | and defined $domain | |
245 | and $host !~ /\./ | |
246 | and $domain =~ /\./); | |
406c51ee | 247 | |
b3f6f6a6 RGS |
248 | # For hosts that have no name, just an IP address |
249 | return $fqdn = $host if defined $host and $host =~ /^\d+(\.\d+){3}$/; | |
406c51ee | 250 | |
b3f6f6a6 RGS |
251 | my @host = defined $host ? split(/\./, $host) : ('localhost'); |
252 | my @domain = defined $domain ? split(/\./, $domain) : (); | |
253 | my @fqdn = (); | |
406c51ee | 254 | |
b3f6f6a6 | 255 | # Determine from @host & @domain the FQDN |
406c51ee | 256 | |
b3f6f6a6 | 257 | my @d = @domain; |
686337f3 | 258 | |
406c51ee | 259 | LOOP: |
b3f6f6a6 RGS |
260 | while (1) { |
261 | my @h = @host; | |
262 | while (@h) { | |
263 | my $tmp = join(".", @h, @d); | |
264 | if ((gethostbyname($tmp))[0]) { | |
265 | @fqdn = (@h, @d); | |
266 | $fqdn = $tmp; | |
267 | last LOOP; | |
268 | } | |
269 | pop @h; | |
406c51ee | 270 | } |
b3f6f6a6 RGS |
271 | last unless shift @d; |
272 | } | |
406c51ee | 273 | |
b3f6f6a6 RGS |
274 | if (@fqdn) { |
275 | $host = shift @fqdn; | |
276 | until ((gethostbyname($host))[0]) { | |
277 | $host .= "." . shift @fqdn; | |
406c51ee | 278 | } |
b3f6f6a6 RGS |
279 | $domain = join(".", @fqdn); |
280 | } | |
281 | else { | |
282 | undef $host; | |
283 | undef $domain; | |
284 | undef $fqdn; | |
285 | } | |
286 | ||
287 | $fqdn; | |
406c51ee JH |
288 | } |
289 | ||
b3f6f6a6 | 290 | |
406c51ee JH |
291 | sub hostfqdn { domainname() } |
292 | ||
b3f6f6a6 | 293 | |
406c51ee | 294 | sub hostname { |
b3f6f6a6 RGS |
295 | domainname() |
296 | unless (defined $host); | |
297 | return $host; | |
406c51ee JH |
298 | } |
299 | ||
b3f6f6a6 | 300 | |
406c51ee | 301 | sub hostdomain { |
b3f6f6a6 RGS |
302 | domainname() |
303 | unless (defined $domain); | |
304 | return $domain; | |
406c51ee JH |
305 | } |
306 | ||
b3f6f6a6 | 307 | 1; # Keep require happy |
406c51ee JH |
308 | |
309 | __END__ | |
310 | ||
311 | =head1 NAME | |
312 | ||
313 | Net::Domain - Attempt to evaluate the current host's internet name and domain | |
314 | ||
315 | =head1 SYNOPSIS | |
316 | ||
c20cde70 | 317 | use Net::Domain qw(hostname hostfqdn hostdomain domainname); |
406c51ee JH |
318 | |
319 | =head1 DESCRIPTION | |
320 | ||
321 | Using various methods B<attempt> to find the Fully Qualified Domain Name (FQDN) | |
322 | of the current host. From this determine the host-name and the host-domain. | |
323 | ||
324 | Each of the functions will return I<undef> if the FQDN cannot be determined. | |
325 | ||
326 | =over 4 | |
327 | ||
328 | =item hostfqdn () | |
329 | ||
330 | Identify and return the FQDN of the current host. | |
331 | ||
c20cde70 SP |
332 | =item domainname () |
333 | ||
334 | An alias for hostfqdn (). | |
335 | ||
406c51ee JH |
336 | =item hostname () |
337 | ||
338 | Returns the smallest part of the FQDN which can be used to identify the host. | |
339 | ||
340 | =item hostdomain () | |
341 | ||
342 | Returns the remainder of the FQDN after the I<hostname> has been removed. | |
343 | ||
344 | =back | |
345 | ||
346 | =head1 AUTHOR | |
347 | ||
2e173144 CBW |
348 | Graham Barr E<lt>F<gbarr@pobox.com>E<gt>. |
349 | Adapted from Sys::Hostname by David Sundstrom E<lt>F<sunds@asictest.sc.ti.com>E<gt> | |
350 | ||
351 | Steve Hay E<lt>F<shay@cpan.org>E<gt> is now maintaining libnet as of version | |
352 | 1.22_02 | |
406c51ee JH |
353 | |
354 | =head1 COPYRIGHT | |
355 | ||
2e173144 CBW |
356 | Versions up to 2.21 Copyright (c) 1995-1998 Graham Barr. All rights reserved. |
357 | Changes in Version 2.22 onwards Copyright (C) 2013-2014 Steve Hay. All rights | |
358 | reserved. | |
359 | ||
a4f8ff46 SH |
360 | This module is free software; you can redistribute it and/or modify it under the |
361 | same terms as Perl itself, i.e. under the terms of either the GNU General Public | |
362 | License or the Artistic License, as specified in the F<LICENCE> file. | |
406c51ee JH |
363 | |
364 | =cut |