1# Net::Domain.pm
2#
3# Copyright (C) 1995-1998 Graham Barr.  All rights reserved.
4# Copyright (C) 2013-2014, 2020 Steve Hay.  All rights reserved.
5# This module is free software; you can redistribute it and/or modify it under
6# the same terms as Perl itself, i.e. under the terms of either the GNU General
7# Public License or the Artistic License, as specified in the F<LICENCE> file.
8
9package Net::Domain;
10
11use 5.008001;
12
13use strict;
14use warnings;
15
16use Carp;
17use Exporter;
18use Net::Config;
19
20our @ISA       = qw(Exporter);
21our @EXPORT_OK = qw(hostname hostdomain hostfqdn domainname);
22our $VERSION = "3.14";
23
24my ($host, $domain, $fqdn) = (undef, undef, undef);
25
26# Try every conceivable way to get hostname.
27
28
29sub _hostname {
30
31  # we already know it
32  return $host
33    if (defined $host);
34
35  if ($^O eq 'MSWin32') {
36    require Socket;
37    my ($name, $alias, $type, $len, @addr) = gethostbyname($ENV{'COMPUTERNAME'} || 'localhost');
38    while (@addr) {
39      my $a = shift(@addr);
40      $host = gethostbyaddr($a, Socket::AF_INET());
41      last if defined $host;
42    }
43    if (defined($host) && index($host, '.') > 0) {
44      $fqdn = $host;
45      ($host, $domain) = $fqdn =~ /^([^.]+)\.(.*)$/;
46    }
47    return $host;
48  }
49  elsif ($^O eq 'MacOS') {
50    chomp($host = `hostname`);
51  }
52  elsif ($^O eq 'VMS') {    ## multiple varieties of net s/w makes this hard
53    $host = $ENV{'UCX$INET_HOST'}      if defined($ENV{'UCX$INET_HOST'});
54    $host = $ENV{'MULTINET_HOST_NAME'} if defined($ENV{'MULTINET_HOST_NAME'});
55    if (index($host, '.') > 0) {
56      $fqdn = $host;
57      ($host, $domain) = $fqdn =~ /^([^.]+)\.(.*)$/;
58    }
59    return $host;
60  }
61  else {
62    local $SIG{'__DIE__'};
63
64    # syscall is preferred since it avoids tainting problems
65    eval {
66      my $tmp = "\0" x 256;    ## preload scalar
67      eval {
68        package main;
69        require "syscall.ph"; ## no critic (Modules::RequireBarewordIncludes)
70        defined(&main::SYS_gethostname);
71        }
72        || eval {
73        package main;
74        require "sys/syscall.ph"; ## no critic (Modules::RequireBarewordIncludes)
75        defined(&main::SYS_gethostname);
76        }
77        and $host =
78        (syscall(&main::SYS_gethostname, $tmp, 256) == 0)
79        ? $tmp
80        : undef;
81      }
82
83      # POSIX
84      || eval {
85      require POSIX;
86      $host = (POSIX::uname())[1];
87      }
88
89      # trusty old hostname command
90      || eval {
91      chop($host = `(hostname) 2>/dev/null`);    # BSD'ish
92      }
93
94      # sysV/POSIX uname command (may truncate)
95      || eval {
96      chop($host = `uname -n 2>/dev/null`);      ## SYSV'ish && POSIX'ish
97      }
98
99      # Apollo pre-SR10
100      || eval { $host = (split(/[:. ]/, `/com/host`, 6))[0]; }
101
102      || eval { $host = ""; };
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
114sub _hostdomain {
115
116  # we already know it
117  return $domain
118    if (defined $domain);
119
120  local $SIG{'__DIE__'};
121
122  return $domain = $NetConfig{'inet_domain'}
123    if defined $NetConfig{'inet_domain'};
124
125  # try looking in /etc/resolv.conf
126  # putting this here and assuming that it is correct, eliminates
127  # calls to gethostbyname, and therefore DNS lookups. This helps
128  # those on dialup systems.
129
130  local ($_);
131
132  if (open(my $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"; ## no critic (Modules::RequireBarewordIncludes)
157        }
158        || eval {
159        package main;
160        require "sys/syscall.ph"; ## no critic (Modules::RequireBarewordIncludes)
161        }
162        and $dom =
163        (syscall(&main::SYS_getdomainname, $tmp, 256) == 0)
164        ? $tmp
165        : undef;
166    };
167
168    if ($^O eq 'VMS') {
169      $dom ||= $ENV{'TCPIP$INET_DOMAIN'}
170        || $ENV{'UCX$INET_DOMAIN'};
171    }
172
173    chop($dom = `domainname 2>/dev/null`)
174      unless (defined $dom || $^O =~ /^(?:cygwin|MSWin32|android)/);
175
176    if (defined $dom) {
177      my @h = ();
178      $dom =~ s/^\.+//;
179      while (length($dom)) {
180        push(@h, "$host.$dom");
181        $dom =~ s/^[^.]+.+// or last;
182      }
183      unshift(@hosts, @h);
184    }
185  }
186
187  # Attempt to locate FQDN
188
189  foreach (grep { defined $_ } @hosts) {
190    my @info = gethostbyname($_);
191
192    next unless @info;
193
194    # look at real name & aliases
195    foreach my $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
220sub domainname {
221
222  return $fqdn
223    if (defined $fqdn);
224
225  _hostname();
226
227  # *.local names are special on darwin. If we call gethostbyname below, it
228  # may hang while waiting for another, non-existent computer to respond.
229  if($^O eq 'darwin' && $host =~ /\.local$/) {
230    return $host;
231  }
232
233  _hostdomain();
234
235  # Assumption: If the host name does not contain a period
236  # and the domain name does, then assume that they are correct
237  # this helps to eliminate calls to gethostbyname, and therefore
238  # eliminate DNS lookups
239
240  return $fqdn = $host . "." . $domain
241    if (defined $host
242    and defined $domain
243    and $host !~ /\./
244    and $domain =~ /\./);
245
246  # For hosts that have no name, just an IP address
247  return $fqdn = $host if defined $host and $host =~ /^\d+(\.\d+){3}$/;
248
249  my @host   = defined $host   ? split(/\./, $host)   : ('localhost');
250  my @domain = defined $domain ? split(/\./, $domain) : ();
251  my @fqdn   = ();
252
253  # Determine from @host & @domain the FQDN
254
255  my @d = @domain;
256
257LOOP:
258  while (1) {
259    my @h = @host;
260    while (@h) {
261      my $tmp = join(".", @h, @d);
262      if ((gethostbyname($tmp))[0]) {
263        @fqdn = (@h, @d);
264        $fqdn = $tmp;
265        last LOOP;
266      }
267      pop @h;
268    }
269    last unless shift @d;
270  }
271
272  if (@fqdn) {
273    $host = shift @fqdn;
274    until ((gethostbyname($host))[0]) {
275      $host .= "." . shift @fqdn;
276    }
277    $domain = join(".", @fqdn);
278  }
279  else {
280    undef $host;
281    undef $domain;
282    undef $fqdn;
283  }
284
285  $fqdn;
286}
287
288
289sub hostfqdn { domainname() }
290
291
292sub hostname {
293  domainname()
294    unless (defined $host);
295  return $host;
296}
297
298
299sub hostdomain {
300  domainname()
301    unless (defined $domain);
302  return $domain;
303}
304
3051;    # Keep require happy
306
307__END__
308
309=head1 NAME
310
311Net::Domain - Attempt to evaluate the current host's internet name and domain
312
313=head1 SYNOPSIS
314
315    use Net::Domain qw(hostname hostfqdn hostdomain domainname);
316
317=head1 DESCRIPTION
318
319Using various methods B<attempt> to find the Fully Qualified Domain Name (FQDN)
320of the current host. From this determine the host-name and the host-domain.
321
322Each of the functions will return I<undef> if the FQDN cannot be determined.
323
324=head2 Functions
325
326=over 4
327
328=item C<hostfqdn()>
329
330Identify and return the FQDN of the current host.
331
332=item C<domainname()>
333
334An alias for hostfqdn().
335
336=item C<hostname()>
337
338Returns the smallest part of the FQDN which can be used to identify the host.
339
340=item C<hostdomain()>
341
342Returns the remainder of the FQDN after the I<hostname> has been removed.
343
344=back
345
346=head1 EXPORTS
347
348The following symbols are, or can be, exported by this module:
349
350=over 4
351
352=item Default Exports
353
354I<None>.
355
356=item Optional Exports
357
358C<hostname>,
359C<hostdomain>,
360C<hostfqdn>,
361C<domainname>.
362
363=item Export Tags
364
365I<None>.
366
367=back
368
369
370=head1 KNOWN BUGS
371
372See L<https://rt.cpan.org/Dist/Display.html?Status=Active&Queue=libnet>.
373
374=head1 AUTHOR
375
376Graham Barr E<lt>L<gbarr@pobox.com|mailto:gbarr@pobox.com>E<gt>.
377
378Adapted from Sys::Hostname by David Sundstrom
379E<lt>L<sunds@asictest.sc.ti.com|mailto:sunds@asictest.sc.ti.com>E<gt>.
380
381Steve Hay E<lt>L<shay@cpan.org|mailto:shay@cpan.org>E<gt> is now maintaining
382libnet as of version 1.22_02.
383
384=head1 COPYRIGHT
385
386Copyright (C) 1995-1998 Graham Barr.  All rights reserved.
387
388Copyright (C) 2013-2014, 2020 Steve Hay.  All rights reserved.
389
390=head1 LICENCE
391
392This module is free software; you can redistribute it and/or modify it under the
393same terms as Perl itself, i.e. under the terms of either the GNU General Public
394License or the Artistic License, as specified in the F<LICENCE> file.
395
396=head1 VERSION
397
398Version 3.14
399
400=head1 DATE
401
40223 Dec 2020
403
404=head1 HISTORY
405
406See the F<Changes> file.
407
408=cut
409