home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl_ste.zip / Net / Domain.pm < prev    next >
Text File  |  1997-09-26  |  6KB  |  294 lines

  1. # Net::Domain.pm
  2. #
  3. # Copyright (c) 1995-1997 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 = do { my @r=(q$Revision: 2.5.2 $=~/\d+/g); sprintf "%d."."%02d"x$#r,@r};
  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.     # syscall is preferred since it avoids tainting problems
  32.     eval {
  33.         my $tmp = "\0" x 256; ## preload scalar
  34.         eval {
  35.             package main;
  36.              require "syscall.ph";
  37.         }
  38.         || eval {
  39.             package main;
  40.              require "sys/syscall.ph";
  41.         }
  42.         and $host = (syscall(&main::SYS_gethostname, $tmp, 256) == 0)
  43.         ? $tmp
  44.         : undef;
  45.     }
  46.  
  47.     # POSIX
  48.     || eval {
  49.     require POSIX;
  50.     $host = (POSIX::uname())[1];
  51.     }
  52.  
  53.     # trusty old hostname command
  54.     || eval {
  55.         chop($host = `(hostname) 2>/dev/null`); # BSD'ish
  56.     }
  57.  
  58.     # sysV/POSIX uname command (may truncate)
  59.     || eval {
  60.         chop($host = `uname -n 2>/dev/null`); ## SYSV'ish && POSIX'ish
  61.     }
  62.  
  63.     # Apollo pre-SR10
  64.     || eval {
  65.         $host = (split(/[:\. ]/,`/com/host`,6))[0];
  66.     }
  67.  
  68.     || eval {
  69.         $host = "";
  70.     };
  71.  
  72.     # remove garbage 
  73.     $host =~ s/[\0\r\n]+//go;
  74.     $host =~ s/(\A\.+|\.+\Z)//go;
  75.     $host =~ s/\.\.+/\./go;
  76.  
  77.     $host;
  78. }
  79.  
  80. sub _hostdomain {
  81.  
  82.     # we already know it
  83.     return $domain
  84.         if(defined $domain);
  85.  
  86.     return $domain = $NetConfig{'inet_domain'}
  87.     if defined $NetConfig{'inet_domain'};
  88.  
  89.     # try looking in /etc/resolv.conf
  90.     # putting this here and assuming that it is correct, eliminates
  91.     # calls to gethostbyname, and therefore DNS lookups. This helps
  92.     # those on dialup systems.
  93.  
  94.     local *RES;
  95.  
  96.     if(open(RES,"/etc/resolv.conf")) {
  97.         while(<RES>) {
  98.             $domain = $1
  99.                 if(/\A\s*(?:domain|search)\s+(\S+)/);
  100.         }
  101.         close(RES);
  102.  
  103.         return $domain
  104.             if(defined $domain);
  105.     }
  106.  
  107.     # just try hostname and system calls
  108.  
  109.     my $host = _hostname();
  110.     my(@hosts);
  111.     local($_);
  112.  
  113.     @hosts = ($host,"localhost");
  114.  
  115.     unless($host =~ /\./) {
  116.     my $dom = undef;
  117.         eval {
  118.             my $tmp = "\0" x 256; ## preload scalar
  119.             eval {
  120.                 package main;
  121.                  require "syscall.ph";
  122.             }
  123.             || eval {
  124.                 package main;
  125.                  require "sys/syscall.ph";
  126.             }
  127.             and $dom = (syscall(&main::SYS_getdomainname, $tmp, 256) == 0)
  128.             ? $tmp
  129.             : undef;
  130.         };
  131.  
  132.     chop($dom = `domainname 2>/dev/null`)
  133.         unless(defined $dom);
  134.  
  135.     if(defined $dom) {
  136.         my @h = ();
  137.         while(length($dom)) {
  138.         push(@h, "$host.$dom");
  139.         $dom =~ s/^[^.]+.//;
  140.         }
  141.         unshift(@hosts,@h);
  142.         }
  143.     }
  144.  
  145.     # Attempt to locate FQDN
  146.  
  147.     foreach (@hosts) {
  148.         my @info = gethostbyname($_);
  149.  
  150.         next unless @info;
  151.  
  152.         # look at real name & aliases
  153.         my $site;
  154.         foreach $site ($info[0], split(/ /,$info[1])) { 
  155.             if(rindex($site,".") > 0) {
  156.  
  157.                 # Extract domain from FQDN
  158.  
  159.                  ($domain = $site) =~ s/\A[^\.]+\.//; 
  160.                  return $domain;
  161.             }
  162.         }
  163.     }
  164.  
  165.     # Look for environment variable
  166.  
  167.     $domain ||= $ENV{LOCALDOMAIN} ||= $ENV{DOMAIN} || undef;
  168.  
  169.     if(defined $domain) {
  170.         $domain =~ s/[\r\n\0]+//g;
  171.         $domain =~ s/(\A\.+|\.+\Z)//g;
  172.         $domain =~ s/\.\.+/\./g;
  173.     }
  174.  
  175.     $domain;
  176. }
  177.  
  178. sub domainname {
  179.  
  180.     return $fqdn
  181.         if(defined $fqdn);
  182.  
  183.     _hostname();
  184.     _hostdomain();
  185.  
  186.     # Assumption: If the host name does not contain a period
  187.     # and the domain name does, then assume that they are correct
  188.     # this helps to eliminate calls to gethostbyname, and therefore
  189.     # eleminate DNS lookups
  190.  
  191.     return $fqdn = $host . "." . $domain
  192.     if($host !~ /\./ && $domain =~ /\./);
  193.  
  194.     my @host   = split(/\./, $host);
  195.     my @domain = split(/\./, $domain);
  196.     my @fqdn   = ();
  197.  
  198.     # Determine from @host & @domain the FQDN
  199.  
  200.     my @d = @domain;
  201.  
  202. LOOP:
  203.     while(1) {
  204.         my @h = @host;
  205.         while(@h) {
  206.             my $tmp = join(".",@h,@d);
  207.             if((gethostbyname($tmp))[0]) {
  208.                  @fqdn = (@h,@d);
  209.                  $fqdn = $tmp;
  210.                last LOOP;
  211.             }
  212.             pop @h;
  213.         }
  214.         last unless shift @d;
  215.     }
  216.  
  217.     if(@fqdn) {
  218.         $host = shift @fqdn;
  219.         until((gethostbyname($host))[0]) {
  220.             $host .= "." . shift @fqdn;
  221.         }
  222.         $domain = join(".", @fqdn);
  223.     }
  224.     else {
  225.         undef $host;
  226.         undef $domain;
  227.         undef $fqdn;
  228.     }
  229.  
  230.     $fqdn;
  231. }
  232.  
  233. sub hostfqdn { domainname() }
  234.  
  235. sub hostname {
  236.     domainname()
  237.         unless(defined $host);
  238.     return $host;
  239. }
  240.  
  241. sub hostdomain {
  242.     domainname()
  243.         unless(defined $domain);
  244.     return $domain;
  245. }
  246.  
  247. 1; # Keep require happy
  248.  
  249. __END__
  250.  
  251. =head1 NAME
  252.  
  253. Net::Domain - Attempt to evaluate the current host's internet name and domain
  254.  
  255. =head1 SYNOPSIS
  256.  
  257.     use Net::Domain qw(hostname hostfqdn hostdomain);
  258.  
  259. =head1 DESCRIPTION
  260.  
  261. Using various methods B<attempt> to find the Fully Qualified Domain Name (FQDN)
  262. of the current host. From this determine the host-name and the host-domain.
  263.  
  264. Each of the functions will return I<undef> if the FQDN cannot be determined.
  265.  
  266. =over 4
  267.  
  268. =item hostfqdn ()
  269.  
  270. Identify and return the FQDN of the current host.
  271.  
  272. =item hostname ()
  273.  
  274. Returns the smallest part of the FQDN which can be used to identify the host.
  275.  
  276. =item hostdomain ()
  277.  
  278. Returns the remainder of the FQDN after the I<hostname> has been removed.
  279.  
  280. =back
  281.  
  282. =head1 AUTHOR
  283.  
  284. Graham Barr <gbarr@pobox.com>.
  285. Adapted from Sys::Hostname by David Sundstrom <sunds@asictest.sc.ti.com>
  286.  
  287. =head1 COPYRIGHT
  288.  
  289. Copyright (c) 1995-1997 Graham Barr. All rights reserved.
  290. This program is free software; you can redistribute it and/or modify
  291. it under the same terms as Perl itself.
  292.  
  293. =cut
  294.