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