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"; # $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);

   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 hostname ()

   318 

   319 Returns the smallest part of the FQDN which can be used to identify the host.

   320 

   321 =item hostdomain ()

   322 

   323 Returns the remainder of the FQDN after the I<hostname> has been removed.

   324 

   325 =back

   326 

   327 =head1 AUTHOR

   328 

   329 Graham Barr <gbarr@pobox.com>.

   330 Adapted from Sys::Hostname by David Sundstrom <sunds@asictest.sc.ti.com>

   331 

   332 =head1 COPYRIGHT

   333 

   334 Copyright (c) 1995-1998 Graham Barr. All rights reserved.

   335 This program is free software; you can redistribute it and/or modify

   336 it under the same terms as Perl itself.

   337 

   338 =for html <hr>

   339 

   340 I<$Id: //depot/libnet/Net/Domain.pm#21 $>

   341 

   342 =cut