This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Extract doio.c's open(2) mode to string conversion as PerlIO_intmod2str()
[perl5.git] / lib / Net / Domain.pm
CommitLineData
406c51ee
JH
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
7package Net::Domain;
8
9require Exporter;
10
11use Carp;
12use strict;
13use vars qw($VERSION @ISA @EXPORT_OK);
14use Net::Config;
15
16@ISA = qw(Exporter);
17@EXPORT_OK = qw(hostname hostdomain hostfqdn domainname);
18
686337f3 19$VERSION = "2.14"; # $Id: //depot/libnet/Net/Domain.pm#15 $
406c51ee
JH
20
21my($host,$domain,$fqdn) = (undef,undef,undef);
22
23# Try every conceivable way to get hostname.
24
25sub _hostname {
26
27 # we already know it
28 return $host
29 if(defined $host);
30
686337f3 31 if ($^O eq 'MSWin32') {
406c51ee
JH
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;
06c7082d
NIS
39 }
40 if (defined($host) && index($host,'.') > 0) {
406c51ee
JH
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
06c7082d 105 # remove garbage
406c51ee
JH
106 $host =~ s/[\0\r\n]+//go;
107 $host =~ s/(\A\.+|\.+\Z)//go;
108 $host =~ s/\.\.+/\./go;
109
110 $host;
111}
112
113sub _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
06c7082d 150 unless (defined($host) && $host =~ /\./) {
406c51ee
JH
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`)
686337f3 168 unless(defined $dom || $^O eq 'MSWin32');
406c51ee
JH
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
06c7082d 182 foreach (grep {defined $_} @hosts) {
406c51ee
JH
183 my @info = gethostbyname($_);
184
185 next unless @info;
186
187 # look at real name & aliases
188 my $site;
06c7082d 189 foreach $site ($info[0], split(/ /,$info[1])) {
406c51ee
JH
190 if(rindex($site,".") > 0) {
191
192 # Extract domain from FQDN
193
06c7082d 194 ($domain = $site) =~ s/\A[^\.]+\.//;
406c51ee
JH
195 return $domain;
196 }
197 }
198 }
199
200 # Look for environment variable
201
686337f3 202 $domain ||= $ENV{LOCALDOMAIN} || $ENV{DOMAIN};
406c51ee
JH
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
213sub 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;
686337f3 239
406c51ee
JH
240LOOP:
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
271sub hostfqdn { domainname() }
272
273sub hostname {
274 domainname()
275 unless(defined $host);
276 return $host;
277}
278
279sub hostdomain {
280 domainname()
281 unless(defined $domain);
282 return $domain;
283}
284
2851; # Keep require happy
286
287__END__
288
289=head1 NAME
290
291Net::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
299Using various methods B<attempt> to find the Fully Qualified Domain Name (FQDN)
300of the current host. From this determine the host-name and the host-domain.
301
302Each of the functions will return I<undef> if the FQDN cannot be determined.
303
304=over 4
305
306=item hostfqdn ()
307
308Identify and return the FQDN of the current host.
309
310=item hostname ()
311
312Returns the smallest part of the FQDN which can be used to identify the host.
313
314=item hostdomain ()
315
316Returns the remainder of the FQDN after the I<hostname> has been removed.
317
318=back
319
320=head1 AUTHOR
321
322Graham Barr <gbarr@pobox.com>.
323Adapted from Sys::Hostname by David Sundstrom <sunds@asictest.sc.ti.com>
324
325=head1 COPYRIGHT
326
327Copyright (c) 1995-1998 Graham Barr. All rights reserved.
328This program is free software; you can redistribute it and/or modify
329it under the same terms as Perl itself.
330
686337f3
JH
331=for html <hr>
332
333I<$Id: //depot/libnet/Net/Domain.pm#15 $>
334
406c51ee 335=cut