[p5sagit/p5-mst-13.2.git] / lib / Net / Domain.pm

# Net::Domain.pm
#
# Copyright (c) 1995-1998 Graham Barr <gbarr@pobox.com>. 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.18"; # $Id: //depot/libnet/Net/Domain.pm#20 $

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;
        };

	if ( $^O eq 'VMS' ) {
	    $dom ||= $ENV{'TCPIP$INET_DOMAIN'}
		 || $ENV{'UCX$INET_DOMAIN'};
	}

	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 <gbarr@pobox.com>.
Adapted from Sys::Hostname by David Sundstrom <sunds@asictest.sc.ti.com>

=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#20 $>

=cut
Commit	Line	Data
406c51ee	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
dea4d7df	19	$VERSION = "2.18"; # $Id: //depot/libnet/Net/Domain.pm#20 $
406c51ee	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
686337f3	31	if ($^O eq 'MSWin32') {
406c51ee	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;
43a88cff	39	}
43a88cff	40	if (defined($host) && index($host,'.') > 0) {
406c51ee	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	}
686337f3	104
43a88cff	105	# remove garbage
406c51ee	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;
c8570720	130	local($_);
406c51ee	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);
406c51ee	147
	148	@hosts = ($host,"localhost");
	149
43a88cff	150	unless (defined($host) && $host =~ /\./) {
406c51ee	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
dea4d7df	167	if ( $^O eq 'VMS' ) {
	168	$dom \|\|= $ENV{'TCPIP$INET_DOMAIN'}
	169	\|\| $ENV{'UCX$INET_DOMAIN'};
	170	}
	171
406c51ee	172	chop($dom = `domainname 2>/dev/null`)
302c2e6b	173	unless(defined $dom \|\| $^O =~ /^(?:cygwin\|MSWin32)/);
406c51ee	174
	175	if(defined $dom) {
	176	my @h = ();
	177	while(length($dom)) {
	178	push(@h, "$host.$dom");
	179	$dom =~ s/^[^.]+.//;
	180	}
	181	unshift(@hosts,@h);
	182	}
	183	}
	184
	185	# Attempt to locate FQDN
	186
43a88cff	187	foreach (grep {defined $_} @hosts) {
406c51ee	188	my @info = gethostbyname($_);
	189
	190	next unless @info;
	191
	192	# look at real name & aliases
	193	my $site;
43a88cff	194	foreach $site ($info[0], split(/ /,$info[1])) {
406c51ee	195	if(rindex($site,".") > 0) {
	196
	197	# Extract domain from FQDN
	198
43a88cff	199	($domain = $site) =~ s/\A[^\.]+\.//;
406c51ee	200	return $domain;
	201	}
	202	}
	203	}
	204
	205	# Look for environment variable
	206
686337f3	207	$domain \|\|= $ENV{LOCALDOMAIN} \|\| $ENV{DOMAIN};
406c51ee	208
	209	if(defined $domain) {
	210	$domain =~ s/[\r\n\0]+//g;
	211	$domain =~ s/(\A\.+\|\.+\Z)//g;
	212	$domain =~ s/\.\.+/\./g;
	213	}
	214
	215	$domain;
	216	}
	217
	218	sub domainname {
	219
	220	return $fqdn
	221	if(defined $fqdn);
	222
	223	_hostname();
	224	_hostdomain();
	225
	226	# Assumption: If the host name does not contain a period
	227	# and the domain name does, then assume that they are correct
	228	# this helps to eliminate calls to gethostbyname, and therefore
	229	# eleminate DNS lookups
	230
	231	return $fqdn = $host . "." . $domain
302c2e6b	232	if(defined $host and defined $domain
302c2e6b	233	and $host !~ /\./ and $domain =~ /\./);
406c51ee	234
406c51ee	235	# For hosts that have no name, just an IP address
302c2e6b	236	return $fqdn = $host if defined $host and $host =~ /^\d+(\.\d+){3}$/;
406c51ee	237
bebec187	238	my @host = defined $host ? split(/\./, $host) : ('localhost');
43a88cff	239	my @domain = defined $domain ? split(/\./, $domain) : ();
406c51ee	240	my @fqdn = ();
	241
	242	# Determine from @host & @domain the FQDN
	243
	244	my @d = @domain;
686337f3	245
406c51ee	246	LOOP:
	247	while(1) {
	248	my @h = @host;
	249	while(@h) {
	250	my $tmp = join(".",@h,@d);
	251	if((gethostbyname($tmp))[0]) {
	252	@fqdn = (@h,@d);
	253	$fqdn = $tmp;
	254	last LOOP;
	255	}
	256	pop @h;
	257	}
	258	last unless shift @d;
	259	}
	260
	261	if(@fqdn) {
	262	$host = shift @fqdn;
	263	until((gethostbyname($host))[0]) {
	264	$host .= "." . shift @fqdn;
	265	}
	266	$domain = join(".", @fqdn);
	267	}
	268	else {
	269	undef $host;
	270	undef $domain;
	271	undef $fqdn;
	272	}
	273
	274	$fqdn;
	275	}
	276
	277	sub hostfqdn { domainname() }
	278
	279	sub hostname {
	280	domainname()
	281	unless(defined $host);
	282	return $host;
	283	}
	284
	285	sub hostdomain {
	286	domainname()
	287	unless(defined $domain);
	288	return $domain;
	289	}
	290
	291	1; # Keep require happy
	292
	293	__END__
	294
	295	=head1 NAME
	296
	297	Net::Domain - Attempt to evaluate the current host's internet name and domain
	298
	299	=head1 SYNOPSIS
	300
	301	use Net::Domain qw(hostname hostfqdn hostdomain);
	302
	303	=head1 DESCRIPTION
	304
	305	Using various methods B<attempt> to find the Fully Qualified Domain Name (FQDN)
	306	of the current host. From this determine the host-name and the host-domain.
	307
	308	Each of the functions will return I<undef> if the FQDN cannot be determined.
	309
310	=over 4
311
312	=item hostfqdn ()
313
314	Identify and return the FQDN of the current host.
315
316	=item hostname ()
317
318	Returns the smallest part of the FQDN which can be used to identify the host.
319
320	=item hostdomain ()
321
322	Returns the remainder of the FQDN after the I<hostname> has been removed.
323
324	=back
325
326	=head1 AUTHOR
327
328	Graham Barr <gbarr@pobox.com>.
329	Adapted from Sys::Hostname by David Sundstrom <sunds@asictest.sc.ti.com>
330
331	=head1 COPYRIGHT
332
333	Copyright (c) 1995-1998 Graham Barr. All rights reserved.
334	This program is free software; you can redistribute it and/or modify
335	it under the same terms as Perl itself.
336
686337f3	337	=for html <hr>
686337f3	338
dea4d7df	339	I<$Id: //depot/libnet/Net/Domain.pm#20 $>
686337f3	340
406c51ee	341	=cut