This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[inseparable changes from patch from perl5.003_12 to perl5.003_13]
[perl5.git] / lib / Net / Domain.pm
1 # Net::Domain.pm
2 #
3 # Copyright (c) 1995 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights
4 # reserved. 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 =head1 NAME
10
11 Net::Domain - Attempt to evaluate the current host's internet name and domain
12
13 =head1 SYNOPSIS
14
15     use Net::Domain qw(hostname hostfqdn hostdomain);
16
17 =head1 DESCRIPTION
18
19 Using various methods B<attempt> to find the Fully Qualified Domain Name (FQDN)
20 of the current host. From this determine the host-name and the host-domain.
21
22 Each of the functions will return I<undef> if the FQDN cannot be determined.
23
24 =over 4
25
26 =item hostfqdn ()
27
28 Identify and return the FQDN of the current host.
29
30 =item hostname ()
31
32 Returns the smallest part of the FQDN which can be used to identify the host.
33
34 =item hostdomain ()
35
36 Returns the remainder of the FQDN after the I<hostname> has been removed.
37
38 =back
39
40 =head1 AUTHOR
41
42 Graham Barr <bodg@tiuk.ti.com>.
43 Adapted from Sys::Hostname by David Sundstrom <sunds@asictest.sc.ti.com>
44
45 =head1 REVISION
46
47 $Revision: 2.0 $
48
49 =head1 COPYRIGHT
50
51 Copyright (c) 1995 Graham Barr. All rights reserved.
52 This library is free software; you can redistribute it and/or
53 modify it under the same terms as Perl itself.
54
55 =cut
56
57 require Exporter;
58
59 use Carp;
60 use strict;
61 use vars qw($VERSION @ISA @EXPORT_OK);
62
63 @ISA = qw(Exporter);
64 @EXPORT_OK = qw(hostname hostdomain hostfqdn domainname);
65
66 $VERSION = sprintf("%d.%02d", q$Revision: 2.0 $ =~ /(\d+)\.(\d+)/);
67
68 my($host,$domain,$fqdn) = (undef,undef,undef);
69
70 # Try every conceivable way to get hostname.
71
72 sub _hostname {
73
74     # method 1 - we already know it
75     return $host
76         if(defined $host);
77
78     # method 2 - syscall is preferred since it avoids tainting problems
79     eval {
80         {
81             package main;
82             require "syscall.ph";
83         }
84         my $tmp = "\0" x 65; ## preload scalar
85         $host = (syscall(&main::SYS_gethostname, $tmp, 65) == 0) ? $tmp : undef;
86     }
87
88
89     # method 3 - trusty old hostname command
90     || eval {
91         chop($host = `(hostname) 2>/dev/null`); # BSD'ish
92     }
93
94     # method 4 - sysV/POSIX uname command (may truncate)
95     || eval {
96         chop($host = `uname -n 2>/dev/null`); ## SYSV'ish && POSIX'ish
97     }
98
99  
100     # method 5 - Apollo pre-SR10
101     || eval {
102         $host = (split(/[:\. ]/,`/com/host`,6))[0];
103     }
104
105     || eval {
106         $host = "";
107     };
108  
109     # remove garbage 
110     $host =~ s/[\0\r\n]+//go;
111     $host =~ s/(\A\.+|\.+\Z)//go;
112     $host =~ s/\.\.+/\./go;
113
114     $host;
115 }
116
117 sub _hostdomain {
118
119     # method 1 - we already know it
120     return $domain
121         if(defined $domain);
122
123     # method 2 - just try hostname and system calls
124
125     my $host = _hostname();
126     my($dom,$site,@hosts);
127     local($_);
128
129     @hosts = ($host,"localhost");
130
131     unless($host =~ /\./) {
132         chop($dom = `domainname 2>/dev/null`);
133         unshift(@hosts, "$host.$dom")
134             if (defined $dom && $dom ne "");
135     }
136
137     # Attempt to locate FQDN
138
139     foreach (@hosts) {
140         my @info = gethostbyname($_);
141
142         next unless @info;
143
144         # look at real name & aliases
145         foreach $site ($info[0], split(/ /,$info[1])) { 
146             if(rindex($site,".") > 0) {
147
148                 # Extract domain from FQDN
149
150                 ($domain = $site) =~ s/\A[^\.]+\.//; 
151                 return $domain;
152             }
153         }
154     }
155
156     # try looking in /etc/resolv.conf
157
158     local *RES;
159
160     if(open(RES,"/etc/resolv.conf")) {
161         while(<RES>) {
162             $domain = $1
163                 if(/\A\s*(?:domain|search)\s+(\S+)/);
164         }
165         close(RES);
166
167         return $domain
168             if(defined $domain);
169     }
170
171     # Look for environment variable
172
173     $domain ||= $ENV{DOMAIN} || undef;
174
175     if(defined $domain) {
176         $domain =~ s/[\r\n\0]+//g;
177         $domain =~ s/(\A\.+|\.+\Z)//g;
178         $domain =~ s/\.\.+/\./g;
179     }
180
181     $domain;
182 }
183
184 sub domainname {
185
186     return $fqdn
187         if(defined $fqdn);
188
189     _hostname();
190     _hostdomain();
191
192     my @host   = split(/\./, $host);
193     my @domain = split(/\./, $domain);
194     my @fqdn   = ();
195
196     # Determine from @host & @domain the FQDN
197
198     my @d = @domain;
199  
200 LOOP:
201     while(1) {
202         my @h = @host;
203         while(@h) {
204             my $tmp = join(".",@h,@d);
205             if((gethostbyname($tmp))[0]) {
206                 @fqdn = (@h,@d);
207                 $fqdn = $tmp;
208               last LOOP;
209             }
210             pop @h;
211         }
212         last unless shift @d;
213     }
214
215     if(@fqdn) {
216         $host = shift @fqdn;
217         until((gethostbyname($host))[0]) {
218             $host .= "." . shift @fqdn;
219         }
220         $domain = join(".", @fqdn);
221     }
222     else {
223         undef $host;
224         undef $domain;
225         undef $fqdn;
226     }
227
228     $fqdn;
229 }
230
231 sub hostfqdn { domainname() }
232
233 sub hostname {
234     domainname()
235         unless(defined $host);
236     return $host;
237 }
238
239 sub hostdomain {
240     domainname()
241         unless(defined $domain);
242     return $domain;
243 }
244
245 1; # Keep require happy