1package Sys::Hostname::Long;
2use strict;
3use Carp;
4
5require Exporter;
6use Sys::Hostname;
7
8# Use perl < 5.6 compatible methods for now, change to 'use base' soon
9@Sys::Hostname::Long::ISA     = qw/ Exporter Sys::Hostname /;
10
11# Use perl < 5.6 compatible methods for now, change to 'our' soon.
12use vars qw(@EXPORT $VERSION $hostlong %dispatch $lastdispatch);
13@EXPORT  = qw/ hostname_long /;
14$VERSION = '1.5';
15
16%dispatch = (
17
18	'gethostbyname' => {
19		'title' => 'Get Host by Name',
20		'description' => '',
21		'exec' => sub {
22			return gethostbyname('localhost');
23		},
24	},
25
26	'exec_hostname' => {
27		'title' => 'Execute "hostname"',
28		'description' => '',
29		'exec' => sub {
30			my $tmp = `hostname`;
31			$tmp =~ tr/\0\r\n//d;
32			return $tmp;
33		},
34	},
35
36	'win32_registry1' => {
37		'title' => 'WIN32 Registry',
38		'description' => 'LMachine/System/CurrentControlSet/Service/VxD/MSTCP/Domain',
39		'exec' => sub {
40			return eval q{
41				use Win32::TieRegistry ( TiedHash => '%RegistryHash' );
42				$RegistryHash{'LMachine'}{'System'}{'CurrentControlSet'}{'Services'}{'VxD'}{'MSTCP'}{'Domain'};
43			};
44		},
45	},
46
47	'uname' => {
48		'title' => 'POSIX::uname',
49		'description' => '',
50		'exec' => sub {
51			return eval {
52				local $SIG{__DIE__};
53				require POSIX;
54				(POSIX::uname())[1];
55			};
56		},
57	},
58
59	# XXX This is the same as above - what happened to the other one !!!
60	'win32_registry2' => {
61		'title' => 'WIN32 Registry',
62		'description' => 'LMachine/System/CurrentControlSet/Services/VxD/MSTCP/Domain',
63		'exec' => sub {
64			return eval q{
65				use Win32::TieRegistry ( TiedHash => '%RegistryHash' );
66				$RegistryHash{'LMachine'}{'System'}{'CurrentControlSet'}{'Services'}{'VxD'}{'MSTCP'}{'Domain'};
67			};
68		},
69	},
70
71	'exec_hostname_fqdn' => {
72		'title' => 'Execute "hostname --fqdn"',
73		'description' => '',
74		'exec' => sub {
75			# Skip for Solaris, and only run as non-root
76			# Skip for darwin (Mac OS X), RT#28894
77			my $tmp;
78			if ( $^O ne 'darwin' ) {
79				if ($< == 0) {
80					$tmp = `su nobody -c "hostname --fqdn"`;
81				} else {
82					$tmp = `hostname --fqdn`;
83				}
84				$tmp =~ tr/\0\r\n//d;
85			}
86			return $tmp;
87		},
88	},
89
90	'exec_hostname_domainname' => {
91		'title' => 'Execute "hostname" and "domainname"',
92		'description' => '',
93		'exec' => sub {
94			my $tmp = `hostname` . '.' . `domainname`;
95			$tmp =~ tr/\0\r\n//d;
96			return $tmp;
97		},
98	},
99
100
101	'network' => {
102		'title' => 'Network Socket hostname (not DNS)',
103		'description' => '',
104		'exec' => sub {
105			return eval q{
106				use IO::Socket;
107				my $s = IO::Socket::INET->new(
108					# m.root-servers.net (a remote IP number)
109					PeerAddr => '202.12.27.33',
110					# random safe port
111					PeerPort => 2000,
112					# We don't actually want to connect
113					Proto => 'udp',
114				) or die "Faile socket - $!";
115				gethostbyaddr($s->sockaddr(), AF_INET);
116			};
117		},
118	},
119
120	'ip' => {
121		'title' => 'Network Socket IP then Hostname via DNS',
122		'description' => '',
123		'exec' => sub {
124			return eval q{
125				use IO::Socket;
126				my $s = IO::Socket::INET->new(
127					# m.root-servers.net (a remote IP number)
128					PeerAddr => '202.12.27.33',
129					# random safe port
130					PeerPort => 2000,
131					# We don't actually want to connect
132					Proto => 'udp',
133				) or die "Faile socket - $!";
134				$s->sockhost;
135			};
136		},
137	},
138
139);
140
141# Dispatch from table
142sub dispatcher {
143	my ($method, @rest) = @_;
144	$lastdispatch = $method;
145	return $dispatch{$method}{exec}(@rest);
146}
147
148sub dispatch_keys {
149	return sort keys %dispatch;
150}
151
152sub dispatch_title {
153	return $dispatch{$_[0]}{title};
154}
155
156sub dispatch_description {
157	return $dispatch{$_[0]}{description};
158}
159
160sub hostname_long {
161	return $hostlong if defined $hostlong; 	# Cached copy (takes a while to lookup sometimes)
162	my ($ip, $debug) = @_;
163
164	$hostlong = dispatcher('uname');
165
166	unless ($hostlong =~ m|.*\..*|) {
167		if ($^O eq 'MacOS') {
168			# http://bumppo.net/lists/macperl/1999/03/msg00282.html
169			#	suggests that it will work (checking localhost) on both
170			#	Mac and Windows.
171			#	Personally this makes no sense what so ever as
172			$hostlong = dispatcher('gethostbyname');
173
174		} elsif ($^O eq 'IRIX') {	# XXX Patter match string !
175			$hostlong = dispatcher('exec_hostname');
176
177		} elsif ($^O eq 'cygwin') {
178			$hostlong = dispatcher('win32_registry1');
179
180		} elsif ($^O eq 'MSWin32') {
181			$hostlong = dispatcher('win32_registry2');
182
183		} elsif ($^O =~ m/(bsd|nto)/i) {
184			$hostlong = dispatcher('exec_hostname');
185
186		# (covered above) } elsif ($^O eq "darwin") {
187		#	$hostlong = dispatcher('uname');
188
189		} elsif ($^O eq 'solaris') {
190			$hostlong = dispatcher('exec_hostname_domainname');
191
192		} else {
193			$hostlong = dispatcher('exec_hostname_fqdn');
194		}
195
196		if (!defined($hostlong) || $hostlong eq "") {
197			# FALL BACK - Requires working internet and DNS and reverse
198			# lookups of your IP number.
199			$hostlong = dispatcher('network');
200		}
201
202		if ($ip && !defined($hostlong) || $hostlong eq "") {
203			$hostlong = dispatcher('ip');
204		}
205	}
206	warn "Sys::Hostname::Long - Last Dispatch method = $lastdispatch" if ($debug);
207	return $hostlong;
208}
209
2101;
211
212__END__
213
214=head1 NAME
215
216Sys::Hostname::Long - Try every conceivable way to get full hostname
217
218=head1 SYNOPSIS
219
220    use Sys::Hostname::Long;
221    $host_long = hostname_long;
222
223=head1 DESCRIPTION
224
225How to get the host full name in perl on multiple operating systems (mac,
226windows, unix* etc)
227
228=head1 DISCUSSION
229
230This is the SECOND release of this code. It has an improved set of tests and
231improved interfaces - but it is still often failing to get a full host name.
232This of course is the reason I wrote the module, it is difficult to get full
233host names accurately on each system. On some systems (eg: Linux) it is
234dependent on the order of the entries in /etc/hosts.
235
236To make it easier to test I have testall.pl to generate an output list of all
237methods. Thus even if the logic is incorrect, it may be possible to get the
238full name.
239
240Attempt via many methods to get the systems full name. The L<Sys::Hostname>
241class is the best and standard way to get the system hostname. However it is
242missing the long hostname.
243
244Special thanks to B<David Sundstrom> and B<Greg Bacon> for the original
245L<Sys::Hostname>
246
247=head1 SUPPORT
248
249This is the original list of platforms tested.
250
251	MacOS		Macintosh Classic		OK
252	Win32		MS Windows (95,98,nt,2000...)
253			98				OK
254	MacOS X		Macintosh 10			OK
255			(other darwin)			Probably OK (not tested)
256	Linux 		Linux UNIX OS			OK
257			Sparc				OK
258	HPUX		H.P. Unix 10?			Not Tested
259	Solaris		SUN Solaris 7?			OK (now)
260	Irix		SGI Irix 5?			Not Tested
261	FreeBSD		FreeBSD				OK
262
263A new list has now been compiled of all the operating systems so that I can
264individually keep information on their success.
265
266THIS IS IN NEED OF AN UPDATE AFTER NEXT RELEASE.
267
268=over 4
269
270=item Acorn - Not yet tested
271
272=item AIX - Not yet tested
273
274=item Amiga - Not yet tested
275
276=item Atari - Not yet tested
277
278=item AtheOS - Not yet tested
279
280=item BeOS - Not yet tested
281
282=item BSD - Not yet tested
283
284=item BSD/OS - Not yet tested
285
286=item Compaq - Not yet tested
287
288=item Cygwin - Not yet tested
289
290=item Concurrent - Not yet tested
291
292=item DG/UX - Not yet tested
293
294=item Digital - Not yet tested
295
296=item DEC OSF/1 - Not yet tested
297
298=item Digital UNIX - Not yet tested
299
300=item DYNIX/ptx - Not yet tested
301
302=item EPOC - Not yet tested
303
304=item FreeBSD - Not yet tested
305
306=item Fujitsu-Siemens - Not yet tested
307
308=item Guardian - Not yet tested
309
310=item HP - Not yet tested
311
312=item HP-UX - Not yet tested
313
314=item IBM - Not yet tested
315
316=item IRIX - Not yet tested - 3rd hand information might be ok.
317
318=item Japanese - Not yet tested
319
320=item JPerl - Not yet tested
321
322=item Linux
323
324=over 8
325
326=item Debian - Not yet tested
327
328=item Gentoo - Not yet tested
329
330=item Mandrake - Not yet tested
331
332=item Red Hat- Not yet tested
333
334=item Slackware - Not yet tested
335
336=item SuSe - Not yet tested
337
338=item Yellowdog - Not yet tested
339
340=back
341
342=item LynxOS - Not yet tested
343
344=item Mac OS - Not yet tested
345
346=item Mac OS X - OK 20040315 (v1.1)
347
348=item MachTen - Not yet tested
349
350=item Minix - Not yet tested
351
352=item MinGW - Not yet tested
353
354=item MiNT - Not yet tested
355
356=item MPE/iX - Not yet tested
357
358=item MS-DOS - Not yet tested
359
360=item MVS - Not yet tested
361
362=item NetBSD - Not yet tested
363
364=item NetWare - Not yet tested
365
366=item NEWS-OS - Not yet tested
367
368=item NextStep - Not yet tested
369
370=item Novell - Not yet tested
371
372=item NonStop - Not yet tested
373
374=item NonStop-UX - Not yet tested
375
376=item OpenBSD - Not yet tested
377
378=item ODT - Not yet tested
379
380=item OpenVMS - Not yet tested
381
382=item Open UNIX - Not yet tested
383
384=item OS/2 - Not yet tested
385
386=item OS/390 - Not yet tested
387
388=item OS/400 - Not yet tested
389
390=item OSF/1 - Not yet tested
391
392=item OSR - Not yet tested
393
394=item Plan 9 - Not yet tested
395
396=item Pocket PC - Not yet tested
397
398=item PowerMAX - Not yet tested
399
400=item Psion - Not yet tested
401
402=item QNX
403
404=over 8
405
406=item 4 - Not yet tested
407
408=item 6 (Neutrino) - Not yet tested
409
410=back
411
412=item Reliant UNIX - Not yet tested
413
414=item RISCOS - Not yet tested
415
416=item SCO - Not yet tested
417
418=item SGI - Not yet tested
419
420=item Symbian - Not yet tested
421
422=item Sequent - Not yet tested
423
424=item Siemens - Not yet tested
425
426=item SINIX - Not yet tested
427
428=item Solaris - Not yet tested
429
430=item SONY - Not yet tested
431
432=item Sun - Not yet tested
433
434=item Stratus - Not yet tested
435
436=item Tandem - Not yet tested
437
438=item Tru64 - Not yet tested
439
440=item Ultrix - Not yet tested
441
442=item UNIX - Not yet tested
443
444=item U/WIN - Not yet tested
445
446=item Unixware - Not yet tested
447
448=item VMS - Not yet tested
449
450=item VOS - Not yet tested
451
452=item Windows
453
454=over 8
455
456=item CE - Not yet tested
457
458=item 3.1 - Not yet tested
459
460=item 95 - Not yet tested
461
462=item 98 - Not yet tested
463
464=item Me - Not yet tested
465
466=item NT - Not yet tested
467
468=item 2000 - Not yet tested
469
470=item XP - Not yet tested
471
472=back
473
474=item z/OS - Not yet tested
475
476=back
477
478=head1 KNOWN LIMITATIONS
479
480=head2 Unix
481
482Most unix systems have trouble working out the fully qualified domain name as
483it to be configured somewhere in the system correctly. For example in most
484linux systems (debian, ?) the fully qualified name should be the first entry
485next to the ip number in /etc/hosts
486
487	192.168.0.1	fred.somwhere.special	fred
488
489If it is the other way around, it will fail.
490
491=head2 Mac
492
493=head1 TODO
494
495Contributions
496
497	David Dick
498	Graeme Hart
499	Piotr Klaban
500
501	* Extra code from G
502	* Dispatch table
503	* List of all operating systems.
504
505Solaris
506	* Fall back 2 - TCP with DNS works ok
507	* Also can read /etc/defaultdomain file
508
509=head1 SEE ALSO
510
511	L<Sys::Hostname>
512
513=head1 AUTHOR
514
515Originally by Scott Penrose E<lt>F<scottp@dd.com.au>E<gt>
516
517Contributions: Michiel Beijen E<lt>F<michiel.beijen@gmail.com>E<gt>
518
519
520=head1 COPYRIGHT
521
522Copyright (c) 2001,2004,2005,2015 Scott Penrose. All rights reserved.
523This program is free software; you can redistribute it and/or modify
524it under the same terms as Perl itself.
525
526=cut
527