Update Socket to CPAN version 2.016
[perl.git] / cpan / libnet / 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.23";
20
21 my ($host, $domain, $fqdn) = (undef, undef, undef);
22
23 # Try every conceivable way to get hostname.
24
25
26 sub _hostname {
27
28   # we already know it
29   return $host
30     if (defined $host);
31
32   if ($^O eq 'MSWin32') {
33     require Socket;
34     my ($name, $alias, $type, $len, @addr) = gethostbyname($ENV{'COMPUTERNAME'} || 'localhost');
35     while (@addr) {
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 =
75         (syscall(&main::SYS_gethostname, $tmp, 256) == 0)
76         ? $tmp
77         : undef;
78       }
79
80       # POSIX
81       || eval {
82       require POSIX;
83       $host = (POSIX::uname())[1];
84       }
85
86       # trusty old hostname command
87       || eval {
88       chop($host = `(hostname) 2>/dev/null`);    # BSD'ish
89       }
90
91       # sysV/POSIX uname command (may truncate)
92       || eval {
93       chop($host = `uname -n 2>/dev/null`);      ## SYSV'ish && POSIX'ish
94       }
95
96       # Apollo pre-SR10
97       || eval { $host = (split(/[:\. ]/, `/com/host`, 6))[0]; }
98
99       || eval { $host = ""; };
100   }
101
102   # remove garbage
103   $host =~ s/[\0\r\n]+//go;
104   $host =~ s/(\A\.+|\.+\Z)//go;
105   $host =~ s/\.\.+/\./go;
106
107   $host;
108 }
109
110
111 sub _hostdomain {
112
113   # we already know it
114   return $domain
115     if (defined $domain);
116
117   local $SIG{'__DIE__'};
118
119   return $domain = $NetConfig{'inet_domain'}
120     if defined $NetConfig{'inet_domain'};
121
122   # try looking in /etc/resolv.conf
123   # putting this here and assuming that it is correct, eliminates
124   # calls to gethostbyname, and therefore DNS lookups. This helps
125   # those on dialup systems.
126
127   local *RES;
128   local ($_);
129
130   if (open(RES, "/etc/resolv.conf")) {
131     while (<RES>) {
132       $domain = $1
133         if (/\A\s*(?:domain|search)\s+(\S+)/);
134     }
135     close(RES);
136
137     return $domain
138       if (defined $domain);
139   }
140
141   # just try hostname and system calls
142
143   my $host = _hostname();
144   my (@hosts);
145
146   @hosts = ($host, "localhost");
147
148   unless (defined($host) && $host =~ /\./) {
149     my $dom = undef;
150     eval {
151       my $tmp = "\0" x 256;    ## preload scalar
152       eval {
153         package main;
154         require "syscall.ph";
155         }
156         || eval {
157         package main;
158         require "sys/syscall.ph";
159         }
160         and $dom =
161         (syscall(&main::SYS_getdomainname, $tmp, 256) == 0)
162         ? $tmp
163         : undef;
164     };
165
166     if ($^O eq 'VMS') {
167       $dom ||= $ENV{'TCPIP$INET_DOMAIN'}
168         || $ENV{'UCX$INET_DOMAIN'};
169     }
170
171     chop($dom = `domainname 2>/dev/null`)
172       unless (defined $dom || $^O =~ /^(?:cygwin|MSWin32|android)/);
173
174     if (defined $dom) {
175       my @h = ();
176       $dom =~ s/^\.+//;
177       while (length($dom)) {
178         push(@h, "$host.$dom");
179         $dom =~ s/^[^.]+.+// or last;
180       }
181       unshift(@hosts, @h);
182     }
183   }
184
185   # Attempt to locate FQDN
186
187   foreach (grep { defined $_ } @hosts) {
188     my @info = gethostbyname($_);
189
190     next unless @info;
191
192     # look at real name & aliases
193     my $site;
194     foreach $site ($info[0], split(/ /, $info[1])) {
195       if (rindex($site, ".") > 0) {
196
197         # Extract domain from FQDN
198
199         ($domain = $site) =~ s/\A[^\.]+\.//;
200         return $domain;
201       }
202     }
203   }
204
205   # Look for environment variable
206
207   $domain ||= $ENV{LOCALDOMAIN} || $ENV{DOMAIN};
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
219 sub domainname {
220
221   return $fqdn
222     if (defined $fqdn);
223
224   _hostname();
225
226   # *.local names are special on darwin. If we call gethostbyname below, it
227   # may hang while waiting for another, non-existent computer to respond.
228   if($^O eq 'darwin' && $host =~ /\.local$/) {
229     return $host;
230   }
231
232   _hostdomain();
233
234   # Assumption: If the host name does not contain a period
235   # and the domain name does, then assume that they are correct
236   # this helps to eliminate calls to gethostbyname, and therefore
237   # eliminate DNS lookups
238
239   return $fqdn = $host . "." . $domain
240     if (defined $host
241     and defined $domain
242     and $host !~ /\./
243     and $domain =~ /\./);
244
245   # For hosts that have no name, just an IP address
246   return $fqdn = $host if defined $host and $host =~ /^\d+(\.\d+){3}$/;
247
248   my @host   = defined $host   ? split(/\./, $host)   : ('localhost');
249   my @domain = defined $domain ? split(/\./, $domain) : ();
250   my @fqdn   = ();
251
252   # Determine from @host & @domain the FQDN
253
254   my @d = @domain;
255
256 LOOP:
257   while (1) {
258     my @h = @host;
259     while (@h) {
260       my $tmp = join(".", @h, @d);
261       if ((gethostbyname($tmp))[0]) {
262         @fqdn = (@h, @d);
263         $fqdn = $tmp;
264         last LOOP;
265       }
266       pop @h;
267     }
268     last unless shift @d;
269   }
270
271   if (@fqdn) {
272     $host = shift @fqdn;
273     until ((gethostbyname($host))[0]) {
274       $host .= "." . shift @fqdn;
275     }
276     $domain = join(".", @fqdn);
277   }
278   else {
279     undef $host;
280     undef $domain;
281     undef $fqdn;
282   }
283
284   $fqdn;
285 }
286
287
288 sub hostfqdn { domainname() }
289
290
291 sub hostname {
292   domainname()
293     unless (defined $host);
294   return $host;
295 }
296
297
298 sub hostdomain {
299   domainname()
300     unless (defined $domain);
301   return $domain;
302 }
303
304 1;    # Keep require happy
305
306 __END__
307
308 =head1 NAME
309
310 Net::Domain - Attempt to evaluate the current host's internet name and domain
311
312 =head1 SYNOPSIS
313
314     use Net::Domain qw(hostname hostfqdn hostdomain domainname);
315
316 =head1 DESCRIPTION
317
318 Using various methods B<attempt> to find the Fully Qualified Domain Name (FQDN)
319 of the current host. From this determine the host-name and the host-domain.
320
321 Each of the functions will return I<undef> if the FQDN cannot be determined.
322
323 =over 4
324
325 =item hostfqdn ()
326
327 Identify and return the FQDN of the current host.
328
329 =item domainname ()
330
331 An alias for hostfqdn ().
332
333 =item hostname ()
334
335 Returns the smallest part of the FQDN which can be used to identify the host.
336
337 =item hostdomain ()
338
339 Returns the remainder of the FQDN after the I<hostname> has been removed.
340
341 =back
342
343 =head1 AUTHOR
344
345 Graham Barr <gbarr@pobox.com>.
346 Adapted from Sys::Hostname by David Sundstrom <sunds@asictest.sc.ti.com>
347
348 =head1 COPYRIGHT
349
350 Copyright (c) 1995-1998 Graham Barr. All rights reserved.
351 This program is free software; you can redistribute it and/or modify
352 it under the same terms as Perl itself.
353
354 =cut