[Summary view] [Print] [Text view]

   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