Fix typo present in "our" Archive::Tar::File but not on CPAN.
[perl.git] / ext / libnet / lib / Net / Domain.pm
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.20";
20
21 my ($host, $domain, $fqdn) = (undef, undef, undef);
22
23 # Try every conceivable way to get hostname.
24
25
26 sub _hostname {
27
28   # we already know it
29   return $host
30     if (defined $host);
31
32   if ($^O eq 'MSWin32') {
33     require Socket;
34     my ($name, $alias, $type, $len, @addr) = gethostbyname($ENV{'COMPUTERNAME'} || 'localhost');
35     while (@addr) {
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 =
75         (syscall(&main::SYS_gethostname, $tmp, 256) == 0)
76         ? $tmp
77         : undef;
78       }
79
80       # POSIX
81       || eval {
82       require POSIX;
83       $host = (POSIX::uname())[1];
84       }
85
86       # trusty old hostname command
87       || eval {
88       chop($host = `(hostname) 2>/dev/null`);    # BSD'ish
89       }
90
91       # sysV/POSIX uname command (may truncate)
92       || eval {
93       chop($host = `uname -n 2>/dev/null`);      ## SYSV'ish && POSIX'ish
94       }
95
96       # Apollo pre-SR10
97       || eval { $host = (split(/[:\. ]/, `/com/host`, 6))[0]; }
98
99       || eval { $host = ""; };
100   }
101
102   # remove garbage
103   $host =~ s/[\0\r\n]+//go;
104   $host =~ s/(\A\.+|\.+\Z)//go;
105   $host =~ s/\.\.+/\./go;
106
107   $host;
108 }
109
110
111 sub _hostdomain {
112
113   # we already know it
114   return $domain
115     if (defined $domain);
116
117   local $SIG{'__DIE__'};
118
119   return $domain = $NetConfig{'inet_domain'}
120     if defined $NetConfig{'inet_domain'};
121
122   # try looking in /etc/resolv.conf
123   # putting this here and assuming that it is correct, eliminates
124   # calls to gethostbyname, and therefore DNS lookups. This helps
125   # those on dialup systems.
126
127   local *RES;
128   local ($_);
129
130   if (open(RES, "/etc/resolv.conf")) {
131     while (<RES>) {
132       $domain = $1
133         if (/\A\s*(?:domain|search)\s+(\S+)/);
134     }
135     close(RES);
136
137     return $domain
138       if (defined $domain);
139   }
140
141   # just try hostname and system calls
142
143   my $host = _hostname();
144   my (@hosts);
145
146   @hosts = ($host, "localhost");
147
148   unless (defined($host) && $host =~ /\./) {
149     my $dom = undef;
150     eval {
151       my $tmp = "\0" x 256;    ## preload scalar
152       eval {
153         package main;
154         require "syscall.ph";
155         }
156         || eval {
157         package main;
158         require "sys/syscall.ph";
159         }
160         and $dom =
161         (syscall(&main::SYS_getdomainname, $tmp, 256) == 0)
162         ? $tmp
163         : undef;
164     };
165
166     if ($^O eq 'VMS') {
167       $dom ||= $ENV{'TCPIP$INET_DOMAIN'}
168         || $ENV{'UCX$INET_DOMAIN'};
169     }
170
171     chop($dom = `domainname 2>/dev/null`)
172       unless (defined $dom || $^O =~ /^(?:cygwin|MSWin32)/);
173
174     if (defined $dom) {
175       my @h = ();
176       $dom =~ s/^\.+//;
177       while (length($dom)) {
178         push(@h, "$host.$dom");
179         $dom =~ s/^[^.]+.+// or last;
180       }
181       unshift(@hosts, @h);
182     }
183   }
184
185   # Attempt to locate FQDN
186
187   foreach (grep { defined $_ } @hosts) {
188     my @info = gethostbyname($_);
189
190     next unless @info;
191
192     # look at real name & aliases
193     my $site;
194     foreach $site ($info[0], split(/ /, $info[1])) {
195       if (rindex($site, ".") > 0) {
196
197         # Extract domain from FQDN
198
199         ($domain = $site) =~ s/\A[^\.]+\.//;
200         return $domain;
201       }
202     }
203   }
204
205   # Look for environment variable
206
207   $domain ||= $ENV{LOCALDOMAIN} || $ENV{DOMAIN};
208
209   if (defined $domain) {
210     $domain =~ s/[\r\n\0]+//g;
211     $domain =~ s/(\A\.+|\.+\Z)//g;
212     $domain =~ s/\.\.+/\./g;
213   }
214
215   $domain;
216 }
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
234     and defined $domain
235     and $host !~ /\./
236     and $domain =~ /\./);
237
238   # For hosts that have no name, just an IP address
239   return $fqdn = $host if defined $host and $host =~ /^\d+(\.\d+){3}$/;
240
241   my @host   = defined $host   ? split(/\./, $host)   : ('localhost');
242   my @domain = defined $domain ? split(/\./, $domain) : ();
243   my @fqdn   = ();
244
245   # Determine from @host & @domain the FQDN
246
247   my @d = @domain;
248
249 LOOP:
250   while (1) {
251     my @h = @host;
252     while (@h) {
253       my $tmp = join(".", @h, @d);
254       if ((gethostbyname($tmp))[0]) {
255         @fqdn = (@h, @d);
256         $fqdn = $tmp;
257         last LOOP;
258       }
259       pop @h;
260     }
261     last unless shift @d;
262   }
263
264   if (@fqdn) {
265     $host = shift @fqdn;
266     until ((gethostbyname($host))[0]) {
267       $host .= "." . shift @fqdn;
268     }
269     $domain = join(".", @fqdn);
270   }
271   else {
272     undef $host;
273     undef $domain;
274     undef $fqdn;
275   }
276
277   $fqdn;
278 }
279
280
281 sub hostfqdn { domainname() }
282
283
284 sub hostname {
285   domainname()
286     unless (defined $host);
287   return $host;
288 }
289
290
291 sub hostdomain {
292   domainname()
293     unless (defined $domain);
294   return $domain;
295 }
296
297 1;    # Keep require happy
298
299 __END__
300
301 =head1 NAME
302
303 Net::Domain - Attempt to evaluate the current host's internet name and domain
304
305 =head1 SYNOPSIS
306
307     use Net::Domain qw(hostname hostfqdn hostdomain domainname);
308
309 =head1 DESCRIPTION
310
311 Using various methods B<attempt> to find the Fully Qualified Domain Name (FQDN)
312 of the current host. From this determine the host-name and the host-domain.
313
314 Each of the functions will return I<undef> if the FQDN cannot be determined.
315
316 =over 4
317
318 =item hostfqdn ()
319
320 Identify and return the FQDN of the current host.
321
322 =item domainname ()
323
324 An alias for hostfqdn ().
325
326 =item hostname ()
327
328 Returns the smallest part of the FQDN which can be used to identify the host.
329
330 =item hostdomain ()
331
332 Returns the remainder of the FQDN after the I<hostname> has been removed.
333
334 =back
335
336 =head1 AUTHOR
337
338 Graham Barr <gbarr@pobox.com>.
339 Adapted from Sys::Hostname by David Sundstrom <sunds@asictest.sc.ti.com>
340
341 =head1 COPYRIGHT
342
343 Copyright (c) 1995-1998 Graham Barr. All rights reserved.
344 This program is free software; you can redistribute it and/or modify
345 it under the same terms as Perl itself.
346
347 =cut