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