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