|
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 |