home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _4a9de0a002c88454410a0e081169bac7 < prev    next >
Text File  |  2004-06-01  |  8KB  |  343 lines
  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
  343.