PC World 2003 March/PCWorld_2003-03_cd.bin/Software/Topware/activeperl/ActivePerl/Perl/lib/Net/Domain.pm

Perl POD Document | 2002-06-19 | 7.6 KB | 337 lines

# Net::Domain.pm
#
# Copyright (c) 1995-1998 Graham Barr <[e-mail]>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.

package Net::Domain;

require Exporter;

use Carp;
use strict;
use vars qw($VERSION @ISA @EXPORT_OK);
use Net::Config;

@ISA = qw(Exporter);
@EXPORT_OK = qw(hostname hostdomain hostfqdn domainname);

$VERSION = "2.17"; # $Id: //depot/libnet/Net/Domain.pm#19 $

my($host,$domain,$fqdn) = (undef,undef,undef);

# Try every conceivable way to get hostname.

sub _hostname {

    # we already know it
    return $host
        if(defined $host);

    if ($^O eq 'MSWin32') {
        require Socket;
        my ($name,$alias,$type,$len,@addr) =  gethostbyname($ENV{'COMPUTERNAME'}||'localhost');
        while (@addr)
         {
          my $a = shift(@addr);
          $host = gethostbyaddr($a,Socket::AF_INET());
          last if defined $host;
         }
        if (defined($host) && index($host,'.') > 0) {
           $fqdn = $host;
           ($host,$domain) = $fqdn =~ /^([^\.]+)\.(.*)$/;
         }
        return $host;
    }
    elsif ($^O eq 'MacOS') {
    chomp ($host = `hostname`);
    }
    elsif ($^O eq 'VMS') {   ## multiple varieties of net s/w makes this hard
        $host = $ENV{'UCX$INET_HOST'} if defined($ENV{'UCX$INET_HOST'});
        $host = $ENV{'MULTINET_HOST_NAME'} if defined($ENV{'MULTINET_HOST_NAME'});
        if (index($host,'.') > 0) {
           $fqdn = $host;
           ($host,$domain) = $fqdn =~ /^([^\.]+)\.(.*)$/;
        }
        return $host;
    }
    else {
    local $SIG{'__DIE__'};

    # syscall is preferred since it avoids tainting problems
    eval {
            my $tmp = "\0" x 256; ## preload scalar
            eval {
            package main;
             require "syscall.ph";
        defined(&main::SYS_gethostname);
            }
            || eval {
            package main;
             require "sys/syscall.ph";
        defined(&main::SYS_gethostname);
            }
            and $host = (syscall(&main::SYS_gethostname, $tmp, 256) == 0)
            ? $tmp
            : undef;
    }

    # POSIX
    || eval {
        require POSIX;
        $host = (POSIX::uname())[1];
    }

    # trusty old hostname command
    || eval {
            chop($host = `(hostname) 2>/dev/null`); # BSD'ish
    }

    # sysV/POSIX uname command (may truncate)
    || eval {
            chop($host = `uname -n 2>/dev/null`); ## SYSV'ish && POSIX'ish
    }

    # Apollo pre-SR10
    || eval {
            $host = (split(/[:\. ]/,`/com/host`,6))[0];
    }

    || eval {
            $host = "";
    };
    }

    # remove garbage
    $host =~ s/[\0\r\n]+//go;
    $host =~ s/(\A\.+|\.+\Z)//go;
    $host =~ s/\.\.+/\./go;

    $host;
}

sub _hostdomain {

    # we already know it
    return $domain
        if(defined $domain);

    local $SIG{'__DIE__'};

    return $domain = $NetConfig{'inet_domain'}
    if defined $NetConfig{'inet_domain'};

    # try looking in /etc/resolv.conf
    # putting this here and assuming that it is correct, eliminates
    # calls to gethostbyname, and therefore DNS lookups. This helps
    # those on dialup systems.

    local *RES;
    local($_);

    if(open(RES,"/etc/resolv.conf")) {
        while(<RES>) {
            $domain = $1
                if(/\A\s*(?:domain|search)\s+(\S+)/);
        }
        close(RES);

        return $domain
            if(defined $domain);
    }

    # just try hostname and system calls

    my $host = _hostname();
    my(@hosts);

    @hosts = ($host,"localhost");

    unless (defined($host) && $host =~ /\./) {
    my $dom = undef;
        eval {
            my $tmp = "\0" x 256; ## preload scalar
            eval {
                package main;
                 require "syscall.ph";
            }
            || eval {
                package main;
                 require "sys/syscall.ph";
            }
            and $dom = (syscall(&main::SYS_getdomainname, $tmp, 256) == 0)
            ? $tmp
            : undef;
        };

    chop($dom = `domainname 2>/dev/null`)
        unless(defined $dom || $^O =~ /^(?:cygwin|MSWin32)/);

    if(defined $dom) {
        my @h = ();
        while(length($dom)) {
        push(@h, "$host.$dom");
        $dom =~ s/^[^.]+.//;
        }
        unshift(@hosts,@h);
        }
    }

    # Attempt to locate FQDN

    foreach (grep {defined $_} @hosts) {
        my @info = gethostbyname($_);

        next unless @info;

        # look at real name & aliases
        my $site;
        foreach $site ($info[0], split(/ /,$info[1])) {
            if(rindex($site,".") > 0) {

                # Extract domain from FQDN

                 ($domain = $site) =~ s/\A[^\.]+\.//;
                 return $domain;
            }
        }
    }

    # Look for environment variable

    $domain ||= $ENV{LOCALDOMAIN} || $ENV{DOMAIN};

    if(defined $domain) {
        $domain =~ s/[\r\n\0]+//g;
        $domain =~ s/(\A\.+|\.+\Z)//g;
        $domain =~ s/\.\.+/\./g;
    }

    $domain;
}

sub domainname {

    return $fqdn
        if(defined $fqdn);

    _hostname();
    _hostdomain();

    # Assumption: If the host name does not contain a period
    # and the domain name does, then assume that they are correct
    # this helps to eliminate calls to gethostbyname, and therefore
    # eleminate DNS lookups

    return $fqdn = $host . "." . $domain
    if(defined $host and defined $domain
        and $host !~ /\./ and $domain =~ /\./);

    # For hosts that have no name, just an IP address
    return $fqdn = $host if defined $host and $host =~ /^\d+(\.\d+){3}$/;

    my @host   = defined $host   ? split(/\./, $host)   : ('localhost');
    my @domain = defined $domain ? split(/\./, $domain) : ();
    my @fqdn   = ();

    # Determine from @host & @domain the FQDN

    my @d = @domain;

LOOP:
    while(1) {
        my @h = @host;
        while(@h) {
            my $tmp = join(".",@h,@d);
            if((gethostbyname($tmp))[0]) {
                 @fqdn = (@h,@d);
                 $fqdn = $tmp;
               last LOOP;
            }
            pop @h;
        }
        last unless shift @d;
    }

    if(@fqdn) {
        $host = shift @fqdn;
        until((gethostbyname($host))[0]) {
            $host .= "." . shift @fqdn;
        }
        $domain = join(".", @fqdn);
    }
    else {
        undef $host;
        undef $domain;
        undef $fqdn;
    }

    $fqdn;
}

sub hostfqdn { domainname() }

sub hostname {
    domainname()
        unless(defined $host);
    return $host;
}

sub hostdomain {
    domainname()
        unless(defined $domain);
    return $domain;
}

1; # Keep require happy

__END__

=head1 NAME

Net::Domain - Attempt to evaluate the current host's internet name and domain

=head1 SYNOPSIS

    use Net::Domain qw(hostname hostfqdn hostdomain);

=head1 DESCRIPTION

Using various methods B<attempt> to find the Fully Qualified Domain Name (FQDN)
of the current host. From this determine the host-name and the host-domain.

Each of the functions will return I<undef> if the FQDN cannot be determined.

=over 4

=item hostfqdn ()

Identify and return the FQDN of the current host.

=item hostname ()

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

=item hostdomain ()

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

=back

=head1 AUTHOR

Graham Barr <[e-mail]>.
Adapted from Sys::Hostname by David Sundstrom <[e-mail]>

=head1 COPYRIGHT

Copyright (c) 1995-1998 Graham Barr. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=for html <hr>

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

=cut