lib/Net/Domain.pm

   1 # Net::Domain.pm
   2 #
   3 # Copyright (c) 1995 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights
   4 # reserved. 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 =head1 NAME
  10
  11 Net::Domain - Attempt to evaluate the current host's internet name and domain
  12
  13 =head1 SYNOPSIS
  14
  15     use Net::Domain qw(hostname hostfqdn hostdomain);
  16
  17 =head1 DESCRIPTION
  18
  19 Using various methods B<attempt> to find the Fully Qualified Domain Name (FQDN)
  20 of the current host. From this determine the host-name and the host-domain.
  21
  22 Each of the functions will return I<undef> if the FQDN cannot be determined.
  23
  24 =over 4
  25
  26 =item hostfqdn ()
  27
  28 Identify and return the FQDN of the current host.
  29
  30 =item hostname ()
  31
  32 Returns the smallest part of the FQDN which can be used to identify the host.
  33
  34 =item hostdomain ()
  35
  36 Returns the remainder of the FQDN after the I<hostname> has been removed.
  37
  38 =back
  39
  40 =head1 AUTHOR
  41
  42 Graham Barr <bodg@tiuk.ti.com>.
  43 Adapted from Sys::Hostname by David Sundstrom <sunds@asictest.sc.ti.com>
  44
  45 =head1 REVISION
  46
  47 $Revision: 2.0 $
  48
  49 =head1 COPYRIGHT
  50
  51 Copyright (c) 1995 Graham Barr. All rights reserved.
  52 This library is free software; you can redistribute it and/or
  53 modify it under the same terms as Perl itself.
  54
  55 =cut
  56
  57 require Exporter;
  58
  59 use Carp;
  60 use strict;
  61 use vars qw($VERSION @ISA @EXPORT_OK);
  62
  63 @ISA = qw(Exporter);
  64 @EXPORT_OK = qw(hostname hostdomain hostfqdn domainname);
  65
  66 $VERSION = sprintf("%d.%02d", q$Revision: 2.0 $ =~ /(\d+)\.(\d+)/);
  67
  68 my($host,$domain,$fqdn) = (undef,undef,undef);
  69
  70 # Try every conceivable way to get hostname.
  71
  72 sub _hostname {
  73
  74     # method 1 - we already know it
  75     return $host
  76         if(defined $host);
  77
  78     # method 2 - syscall is preferred since it avoids tainting problems
  79     eval {
  80         {
  81             package main;
  82             require "syscall.ph";
  83         }
  84         my $tmp = "\0" x 65; ## preload scalar
  85         $host = (syscall(&main::SYS_gethostname, $tmp, 65) == 0) ? $tmp : undef;
  86     }
  87
  88
  89     # method 3 - trusty old hostname command
  90     || eval {
  91         chop($host = `(hostname) 2>/dev/null`); # BSD'ish
  92     }
  93
  94     # method 4 - sysV/POSIX uname command (may truncate)
  95     || eval {
  96         chop($host = `uname -n 2>/dev/null`); ## SYSV'ish && POSIX'ish
  97     }
  98
  99
 100     # method 5 - Apollo pre-SR10
 101     || eval {
 102         $host = (split(/[:\. ]/,`/com/host`,6))[0];
 103     }
 104
 105     || eval {
 106         $host = "";
 107     };
 108
 109     # remove garbage
 110     $host =~ s/[\0\r\n]+//go;
 111     $host =~ s/(\A\.+|\.+\Z)//go;
 112     $host =~ s/\.\.+/\./go;
 113
 114     $host;
 115 }
 116
 117 sub _hostdomain {
 118
 119     # method 1 - we already know it
 120     return $domain
 121         if(defined $domain);
 122
 123     # method 2 - just try hostname and system calls
 124
 125     my $host = _hostname();
 126     my($dom,$site,@hosts);
 127     local($_);
 128
 129     @hosts = ($host,"localhost");
 130
 131     unless($host =~ /\./) {
 132         chop($dom = `domainname 2>/dev/null`);
 133         unshift(@hosts, "$host.$dom")
 134             if (defined $dom && $dom ne "");
 135     }
 136
 137     # Attempt to locate FQDN
 138
 139     foreach (@hosts) {
 140         my @info = gethostbyname($_);
 141
 142         next unless @info;
 143
 144         # look at real name & aliases
 145         foreach $site ($info[0], split(/ /,$info[1])) {
 146             if(rindex($site,".") > 0) {
 147
 148                 # Extract domain from FQDN
 149
 150                 ($domain = $site) =~ s/\A[^\.]+\.//;
 151                 return $domain;
 152             }
 153         }
 154     }
 155
 156     # try looking in /etc/resolv.conf
 157
 158     local *RES;
 159
 160     if(open(RES,"/etc/resolv.conf")) {
 161         while(<RES>) {
 162             $domain = $1
 163                 if(/\A\s*(?:domain|search)\s+(\S+)/);
 164         }
 165         close(RES);
 166
 167         return $domain
 168             if(defined $domain);
 169     }
 170
 171     # Look for environment variable
 172
 173     $domain ||= $ENV{DOMAIN} || undef;
 174
 175     if(defined $domain) {
 176         $domain =~ s/[\r\n\0]+//g;
 177         $domain =~ s/(\A\.+|\.+\Z)//g;
 178         $domain =~ s/\.\.+/\./g;
 179     }
 180
 181     $domain;
 182 }
 183
 184 sub domainname {
 185
 186     return $fqdn
 187         if(defined $fqdn);
 188
 189     _hostname();
 190     _hostdomain();
 191
 192     my @host   = split(/\./, $host);
 193     my @domain = split(/\./, $domain);
 194     my @fqdn   = ();
 195
 196     # Determine from @host & @domain the FQDN
 197
 198     my @d = @domain;
 199
 200 LOOP:
 201     while(1) {
 202         my @h = @host;
 203         while(@h) {
 204             my $tmp = join(".",@h,@d);
 205             if((gethostbyname($tmp))[0]) {
 206                 @fqdn = (@h,@d);
 207                 $fqdn = $tmp;
 208               last LOOP;
 209             }
 210             pop @h;
 211         }
 212         last unless shift @d;
 213     }
 214
 215     if(@fqdn) {
 216         $host = shift @fqdn;
 217         until((gethostbyname($host))[0]) {
 218             $host .= "." . shift @fqdn;
 219         }
 220         $domain = join(".", @fqdn);
 221     }
 222     else {
 223         undef $host;
 224         undef $domain;
 225         undef $fqdn;
 226     }
 227
 228     $fqdn;
 229 }
 230
 231 sub hostfqdn { domainname() }
 232
 233 sub hostname {
 234     domainname()
 235         unless(defined $host);
 236     return $host;
 237 }
 238
 239 sub hostdomain {
 240     domainname()
 241         unless(defined $domain);
 242     return $domain;
 243 }
 244
 245 1; # Keep require happy