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