cpan/libnet/lib/Net/Domain.pm

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