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.19"; # $Id: //depot/libnet/Net/Domain.pm#21 $

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 = ();
            $dom =~ s/^\.+//;
            while(length($dom)) {
                push(@h, "$host.$dom");
                $dom =~ s/^[^.]+.+// or last;
            }
            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#21 $>

=cut
Revision:	1.1
Committed:	Thu Jun 30 14:27:14 2005 UTC (21 years, 3 months ago) by root
Branch:	MAIN
CVS Tags:	HEAD
Branch point for:	PERL
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.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