Commit | Line | Data |
---|---|---|
920dae64 AT |
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 | ||
19 | $VERSION = "2.19"; # $Id: //depot/libnet/Net/Domain.pm#21 $ | |
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 | ||
31 | if ($^O eq 'MSWin32') { | |
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; | |
39 | } | |
40 | if (defined($host) && index($host,'.') > 0) { | |
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 | } | |
104 | ||
105 | # remove garbage | |
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 | local($_); | |
131 | ||
132 | if(open(RES,"/etc/resolv.conf")) { | |
133 | while(<RES>) { | |
134 | $domain = $1 | |
135 | if(/\A\s*(?:domain|search)\s+(\S+)/); | |
136 | } | |
137 | close(RES); | |
138 | ||
139 | return $domain | |
140 | if(defined $domain); | |
141 | } | |
142 | ||
143 | # just try hostname and system calls | |
144 | ||
145 | my $host = _hostname(); | |
146 | my(@hosts); | |
147 | ||
148 | @hosts = ($host,"localhost"); | |
149 | ||
150 | unless (defined($host) && $host =~ /\./) { | |
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 | if ( $^O eq 'VMS' ) { | |
168 | $dom ||= $ENV{'TCPIP$INET_DOMAIN'} | |
169 | || $ENV{'UCX$INET_DOMAIN'}; | |
170 | } | |
171 | ||
172 | chop($dom = `domainname 2>/dev/null`) | |
173 | unless(defined $dom || $^O =~ /^(?:cygwin|MSWin32)/); | |
174 | ||
175 | if(defined $dom) { | |
176 | my @h = (); | |
177 | $dom =~ s/^\.+//; | |
178 | while(length($dom)) { | |
179 | push(@h, "$host.$dom"); | |
180 | $dom =~ s/^[^.]+.+// or last; | |
181 | } | |
182 | unshift(@hosts,@h); | |
183 | } | |
184 | } | |
185 | ||
186 | # Attempt to locate FQDN | |
187 | ||
188 | foreach (grep {defined $_} @hosts) { | |
189 | my @info = gethostbyname($_); | |
190 | ||
191 | next unless @info; | |
192 | ||
193 | # look at real name & aliases | |
194 | my $site; | |
195 | foreach $site ($info[0], split(/ /,$info[1])) { | |
196 | if(rindex($site,".") > 0) { | |
197 | ||
198 | # Extract domain from FQDN | |
199 | ||
200 | ($domain = $site) =~ s/\A[^\.]+\.//; | |
201 | return $domain; | |
202 | } | |
203 | } | |
204 | } | |
205 | ||
206 | # Look for environment variable | |
207 | ||
208 | $domain ||= $ENV{LOCALDOMAIN} || $ENV{DOMAIN}; | |
209 | ||
210 | if(defined $domain) { | |
211 | $domain =~ s/[\r\n\0]+//g; | |
212 | $domain =~ s/(\A\.+|\.+\Z)//g; | |
213 | $domain =~ s/\.\.+/\./g; | |
214 | } | |
215 | ||
216 | $domain; | |
217 | } | |
218 | ||
219 | sub domainname { | |
220 | ||
221 | return $fqdn | |
222 | if(defined $fqdn); | |
223 | ||
224 | _hostname(); | |
225 | _hostdomain(); | |
226 | ||
227 | # Assumption: If the host name does not contain a period | |
228 | # and the domain name does, then assume that they are correct | |
229 | # this helps to eliminate calls to gethostbyname, and therefore | |
230 | # eleminate DNS lookups | |
231 | ||
232 | return $fqdn = $host . "." . $domain | |
233 | if(defined $host and defined $domain | |
234 | and $host !~ /\./ and $domain =~ /\./); | |
235 | ||
236 | # For hosts that have no name, just an IP address | |
237 | return $fqdn = $host if defined $host and $host =~ /^\d+(\.\d+){3}$/; | |
238 | ||
239 | my @host = defined $host ? split(/\./, $host) : ('localhost'); | |
240 | my @domain = defined $domain ? split(/\./, $domain) : (); | |
241 | my @fqdn = (); | |
242 | ||
243 | # Determine from @host & @domain the FQDN | |
244 | ||
245 | my @d = @domain; | |
246 | ||
247 | LOOP: | |
248 | while(1) { | |
249 | my @h = @host; | |
250 | while(@h) { | |
251 | my $tmp = join(".",@h,@d); | |
252 | if((gethostbyname($tmp))[0]) { | |
253 | @fqdn = (@h,@d); | |
254 | $fqdn = $tmp; | |
255 | last LOOP; | |
256 | } | |
257 | pop @h; | |
258 | } | |
259 | last unless shift @d; | |
260 | } | |
261 | ||
262 | if(@fqdn) { | |
263 | $host = shift @fqdn; | |
264 | until((gethostbyname($host))[0]) { | |
265 | $host .= "." . shift @fqdn; | |
266 | } | |
267 | $domain = join(".", @fqdn); | |
268 | } | |
269 | else { | |
270 | undef $host; | |
271 | undef $domain; | |
272 | undef $fqdn; | |
273 | } | |
274 | ||
275 | $fqdn; | |
276 | } | |
277 | ||
278 | sub hostfqdn { domainname() } | |
279 | ||
280 | sub hostname { | |
281 | domainname() | |
282 | unless(defined $host); | |
283 | return $host; | |
284 | } | |
285 | ||
286 | sub hostdomain { | |
287 | domainname() | |
288 | unless(defined $domain); | |
289 | return $domain; | |
290 | } | |
291 | ||
292 | 1; # Keep require happy | |
293 | ||
294 | __END__ | |
295 | ||
296 | =head1 NAME | |
297 | ||
298 | Net::Domain - Attempt to evaluate the current host's internet name and domain | |
299 | ||
300 | =head1 SYNOPSIS | |
301 | ||
302 | use Net::Domain qw(hostname hostfqdn hostdomain); | |
303 | ||
304 | =head1 DESCRIPTION | |
305 | ||
306 | Using various methods B<attempt> to find the Fully Qualified Domain Name (FQDN) | |
307 | of the current host. From this determine the host-name and the host-domain. | |
308 | ||
309 | Each of the functions will return I<undef> if the FQDN cannot be determined. | |
310 | ||
311 | =over 4 | |
312 | ||
313 | =item hostfqdn () | |
314 | ||
315 | Identify and return the FQDN of the current host. | |
316 | ||
317 | =item hostname () | |
318 | ||
319 | Returns the smallest part of the FQDN which can be used to identify the host. | |
320 | ||
321 | =item hostdomain () | |
322 | ||
323 | Returns the remainder of the FQDN after the I<hostname> has been removed. | |
324 | ||
325 | =back | |
326 | ||
327 | =head1 AUTHOR | |
328 | ||
329 | Graham Barr <gbarr@pobox.com>. | |
330 | Adapted from Sys::Hostname by David Sundstrom <sunds@asictest.sc.ti.com> | |
331 | ||
332 | =head1 COPYRIGHT | |
333 | ||
334 | Copyright (c) 1995-1998 Graham Barr. All rights reserved. | |
335 | This program is free software; you can redistribute it and/or modify | |
336 | it under the same terms as Perl itself. | |
337 | ||
338 | =for html <hr> | |
339 | ||
340 | I<$Id: //depot/libnet/Net/Domain.pm#21 $> | |
341 | ||
342 | =cut |