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