diff options
Diffstat (limited to 'final/runtime/tools/lib/Uname.pm')
| -rw-r--r-- | final/runtime/tools/lib/Uname.pm | 639 |
1 files changed, 639 insertions, 0 deletions
diff --git a/final/runtime/tools/lib/Uname.pm b/final/runtime/tools/lib/Uname.pm new file mode 100644 index 0000000..f85e1ee --- /dev/null +++ b/final/runtime/tools/lib/Uname.pm @@ -0,0 +1,639 @@ +# +# This is not a runnable script, it is a Perl module, a collection of variables, subroutines, etc. +# To get help about exported variables and subroutines, execute the following command: +# +# perldoc Uname.pm +# +# or see POD (Plain Old Documentation) embedded to the source... +# +# +#//===----------------------------------------------------------------------===// +#// +#// The LLVM Compiler Infrastructure +#// +#// This file is dual licensed under the MIT and the University of Illinois Open +#// Source Licenses. See LICENSE.txt for details. +#// +#//===----------------------------------------------------------------------===// +# + +package Uname; + +use strict; +use warnings; +use warnings::register; +use Exporter; + +use POSIX; +use File::Glob ":glob"; +use Net::Domain qw{}; + +# Following code does not work with Perl 5.6 on Linux* OS and Windows* OS: +# +# use if $^O eq "darwin", tools => qw{}; +# +# The workaround for Perl 5.6: +# +BEGIN { + if ( $^O eq "darwin" or $^O eq "linux" ) { + require tools; + import tools; + }; # if + if ( $^O eq "MSWin32" ) { + require Win32; + }; # if +}; # BEGIN + +my $mswin = qr{\A(?:MSWin32|Windows_NT)\z}; + +my @posix = qw{ kernel_name fqdn kernel_release kernel_version machine }; + # Properties supported by POSIX::uname(). +my @linux = + qw{ processor hardware_platform operating_system }; + # Properties reported by uname in Linux* OS. +my @base = ( @posix, @linux ); + # Base properties. +my @aux = + ( + qw{ host_name domain_name }, + map( "operating_system_$_", qw{ name release codename description } ) + ); + # Auxiliary properties. +my @all = ( @base, @aux ); + # All the properties. +my @meta = qw{ base_names all_names value }; + # Meta functions. + +our $VERSION = "0.07"; +our @ISA = qw{ Exporter }; +our @EXPORT = qw{}; +our @EXPORT_OK = ( @all, @meta ); +our %EXPORT_TAGS = + ( + base => [ @base ], + all => [ @all ], + meta => [ @meta ], + ); + +my %values; + # Hash of values. Some values are strings, some may be references to code which should be + # evaluated to get real value. This trick is implemented because call to Net::Domain::hostfqdn() + # is relatively slow. + +# Get values from POSIX::uname(). +@values{ @posix } = POSIX::uname(); + +# On some systems POSIX::uname() returns "short" node name (without domain name). To be consistent +# on all systems, we will get node name from alternative source. +if ( $^O =~ m/cygwin/i ) { + # Function from Net::Domain module works well, but on Cygwin it prints to + # stderr "domainname: not found". So we will use environment variables for now. + $values{ fqdn } = lc( $ENV{ COMPUTERNAME } . "." . $ENV{ USERDNSDOMAIN } ); +} else { + # On systems other than Cygwin, let us use Net::Domain::hostfqdn(), but do it only node name + # is really requested. + $values{ fqdn } = + sub { + my $fqdn = Net::Domain::hostfqdn(); # "fqdn" stands for "fully qualified doamain name". + # On some systems POSIX::uname() and Net::Domain::hostfqdn() reports different names. + # Let us issue a warning if they significantly different. Names are insignificantly + # different if POSIX::uname() matches the beginning of Net::Domain::hostfqdn(). + if ( + $fqdn eq substr( $fqdn, 0, length( $fqdn ) ) + && + ( + length( $fqdn ) == length( $fqdn ) + || + substr( $fqdn, length( $fqdn ), 1 ) eq "." + ) + ) { + # Ok. + } else { + warnings::warnif( + "POSIX::uname() and Net::Domain::hostfqdn() reported different names: " . + "\"$values{ fqdn }\" and \"$fqdn\" respectively\n" + ); + }; # if + return $fqdn; + }; # sub +}; # if + +if ( $^O =~ $mswin ) { + if ( + $values{ machine } =~ m{\A(?:x86|[56]86)\z} + and + exists( $ENV{ PROCESSOR_ARCHITECTURE } ) and $ENV{ PROCESSOR_ARCHITECTURE } eq "x86" + and + exists( $ENV{ PROCESSOR_ARCHITEW6432 } ) + ) { + if ( $ENV{ PROCESSOR_ARCHITEW6432 } eq "AMD64" ) { + $values{ machine } = "x86_64"; + }; # if + }; # if +}; # if + +# Some values are not returned by POSIX::uname(), let us compute them. + +# processor. +$values{ processor } = $values{ machine }; + +# hardware_platform. +if ( 0 ) { +} elsif ( $^O eq "linux" or $^O eq "freebsd" or $^O eq "netbsd" ) { + if ( 0 ) { + } elsif ( $values{ machine } =~ m{\Ai[3456]86\z} ) { + $values{ hardware_platform } = "i386"; + } elsif ( $values{ machine } =~ m{\A(x86_64|amd64)\z} ) { + $values{ hardware_platform } = "x86_64"; + } elsif ( $values{ machine } =~ m{\Aarmv7\D*\z} ) { + $values{ hardware_platform } = "arm"; + } elsif ( $values{ machine } =~ m{\Appc64le\z} ) { + $values{ hardware_platform } = "ppc64le"; + } elsif ( $values{ machine } =~ m{\Appc64\z} ) { + $values{ hardware_platform } = "ppc64"; + } elsif ( $values{ machine } =~ m{\Aaarch64\z} ) { + $values{ hardware_platform } = "aarch64"; + } elsif ( $values{ machine } =~ m{\Amips64\z} ) { + $values{ hardware_platform } = "mips64"; + } elsif ( $values{ machine } =~ m{\Amips\z} ) { + $values{ hardware_platform } = "mips"; + } else { + die "Unsupported machine (\"$values{ machine }\") returned by POSIX::uname(); stopped"; + }; # if +} elsif ( $^O eq "darwin" ) { + if ( 0 ) { + } elsif ( $values{ machine } eq "x86" or $values{ machine } eq "i386" ) { + $values{ hardware_platform } = + sub { + my $platform = "i386"; + # Some OSes on Intel(R) 64 still reports "i386" machine. Verify it by using + # the value returned by 'sysctl -n hw.optional.x86_64'. On Intel(R) 64-bit systems the + # value == 1; on 32-bit systems the 'hw.optional.x86_64' property either does not exist + # or the value == 0. The path variable does not contain a path to sysctl when + # started by crontab. + my $sysctl = ( which( "sysctl" ) or "/usr/sbin/sysctl" ); + my $output; + debug( "Executing $sysctl..." ); + execute( [ $sysctl, "-n", "hw.optional.x86_64" ], -stdout => \$output, -stderr => undef ); + chomp( $output ); + if ( 0 ) { + } elsif ( "$output" eq "" or "$output" eq "0" ) { + $platform = "i386"; + } elsif ( "$output" eq "1" ) { + $platform = "x86_64"; + } else { + die "Unsupported value (\"$output\") returned by \"$sysctl -n hw.optional.x86_64\"; stopped"; + }; # if + return $platform; + }; # sub { + } elsif ( $values{ machine } eq "x86_64" ) { + # Some OS X* versions report "x86_64". + $values{ hardware_platform } = "x86_64"; + } else { + die "Unsupported machine (\"$values{ machine }\") returned by POSIX::uname(); stopped"; + }; # if +} elsif ( $^O =~ $mswin ) { + if ( 0 ) { + } elsif ( $values{ machine } =~ m{\A(?:x86|[56]86)\z} ) { + $values{ hardware_platform } = "i386"; + } elsif ( $values{ machine } eq "x86_64" or $values{ machine } eq "amd64" ) { + # ActivePerl for IA-32 architecture returns "x86_64", while ActivePerl for Intel(R) 64 returns "amd64". + $values{ hardware_platform } = "x86_64"; + } else { + die "Unsupported machine (\"$values{ machine }\") returned by POSIX::uname(); stopped"; + }; # if +} elsif ( $^O eq "cygwin" ) { + if ( 0 ) { + } elsif ( $values{ machine } =~ m{\Ai[3456]86\z} ) { + $values{ hardware_platform } = "i386"; + } elsif ( $values{ machine } eq "x86_64" ) { + $values{ hardware_platform } = "x86_64"; + } else { + die "Unsupported machine (\"$values{ machine }\") returned by POSIX::uname(); stopped"; + }; # if +} else { + die "Unsupported OS (\"$^O\"); stopped"; +}; # if + +# operating_system. +if ( 0 ) { +} elsif ( $values{ kernel_name } eq "Linux" ) { + $values{ operating_system } = "GNU/Linux"; + my $release; # Name of chosen "*-release" file. + my $bulk; # Content of release file. + # On Ubuntu, lsb-release is quite informative, e. g.: + # DISTRIB_ID=Ubuntu + # DISTRIB_RELEASE=9.04 + # DISTRIB_CODENAME=jaunty + # DISTRIB_DESCRIPTION="Ubuntu 9.04" + # Try lsb-release first. But on some older systems lsb-release is not informative. + # It may contain just one line: + # LSB_VERSION="1.3" + $release = "/etc/lsb-release"; + if ( -e $release ) { + $bulk = read_file( $release ); + } else { + $bulk = ""; + }; # if + if ( $bulk =~ m{^DISTRIB_} ) { + # Ok, this lsb-release is informative. + $bulk =~ m{^DISTRIB_ID\s*=\s*(.*?)\s*$}m + or runtime_error( "$release: There is no DISTRIB_ID:", $bulk, "(eof)" ); + $values{ operating_system_name } = $1; + $bulk =~ m{^DISTRIB_RELEASE\s*=\s*(.*?)\s*$}m + or runtime_error( "$release: There is no DISTRIB_RELEASE:", $bulk, "(eof)" ); + $values{ operating_system_release } = $1; + $bulk =~ m{^DISTRIB_CODENAME\s*=\s*(.*?)\s*$}m + or runtime_error( "$release: There is no DISTRIB_CODENAME:", $bulk, "(eof)" ); + $values{ operating_system_codename } = $1; + $bulk =~ m{^DISTRIB_DESCRIPTION\s*="?\s*(.*?)"?\s*$}m + or runtime_error( "$release: There is no DISTRIB_DESCRIPTION:", $bulk, "(eof)" ); + $values{ operating_system_description } = $1; + } else { + # Oops. lsb-release is missed or not informative. Try other *-release files. + $release = "/etc/system-release"; + if ( not -e $release ) { # Use /etc/system-release" if such file exists. + # Otherwise try other "/etc/*-release" files, but ignore "/etc/lsb-release". + my @releases = grep( $_ ne "/etc/lsb-release", bsd_glob( "/etc/*-release" ) ); + # On some Fedora systems there are two files: fedora-release and redhat-release + # with identical content. If fedora-release present, ignore redjat-release. + if ( grep( $_ eq "/etc/fedora-release", @releases ) ) { + @releases = grep( $_ ne "/etc/redhat-release", @releases ); + }; # if + if ( @releases == 1 ) { + $release = $releases[ 0 ]; + } else { + if ( @releases == 0 ) { + # No *-release files found, try debian_version. + $release = "/etc/debian_version"; + if ( not -e $release ) { + $release = undef; + warning( "No release files found in \"/etc/\" directory." ); + }; # if + } else { + $release = undef; + warning( "More than one release files found in \"/etc/\" directory:", @releases ); + }; # if + }; # if + }; # if + if ( defined( $release ) ) { + $bulk = read_file( $release ); + if ( $release =~ m{system|redhat|fedora} ) { + # Red Hat or Fedora. Parse the first line of file. + # Typical values of *-release (one of): + # Red Hat Enterprise Linux* OS Server release 5.2 (Tikanga) + # Red Hat Enterprise Linux* OS AS release 3 (Taroon Update 4) + # Fedora release 10 (Cambridge) + $bulk =~ m{\A(.*)$}m + or runtime_error( "$release: Cannot find the first line:", $bulk, "(eof)" ); + my $first_line = $1; + $values{ operating_system_description } = $first_line; + $first_line =~ m{\A(.*?)\s+release\s+(.*?)(?:\s+\((.*?)(?:\s+Update\s+(.*?))?\))?\s*$} + or runtime_error( "$release:1: Cannot parse line:", $first_line ); + $values{ operating_system_name } = $1; + $values{ operating_system_release } = $2 . ( defined( $4 ) ? ".$4" : "" ); + $values{ operating_system_codename } = $3; + } elsif ( $release =~ m{SuSE} ) { + # Typical SuSE-release: + # SUSE Linux* OS Enterprise Server 10 (x86_64) + # VERSION = 10 + # PATCHLEVEL = 2 + $bulk =~ m{\A(.*)$}m + or runtime_error( "$release: Cannot find the first line:", $bulk, "(eof)" ); + my $first_line = $1; + $values{ operating_system_description } = $first_line; + $first_line =~ m{^(.*?)\s*(\d+)\s*\(.*?\)\s*$} + or runtime_error( "$release:1: Cannot parse line:", $first_line ); + $values{ operating_system_name } = $1; + $bulk =~ m{^VERSION\s*=\s*(.*)\s*$}m + or runtime_error( "$release: There is no VERSION:", $bulk, "(eof)" ); + $values{ operating_system_release } = $1; + if ( $bulk =~ m{^PATCHLEVEL\s*=\s*(.*)\s*$}m ) { + $values{ operating_system_release } .= ".$1"; + }; # if + } elsif ( $release =~ m{debian_version} ) { + # Debian. The file debian_version contains just version number, nothing more: + # 4.0 + my $name = "Debian"; + $bulk =~ m{\A(.*)$}m + or runtime_error( "$release: Cannot find the first line:", $bulk, "(eof)" ); + my $version = $1; + $values{ operating_system_name } = $name; + $values{ operating_system_release } = $version; + $values{ operating_system_codename } = "unknown"; + $values{ operating_system_description } = sprintf( "%s %s", $name, $version ); + }; # if + }; # if + }; # if + if ( not defined( $values{ operating_system_name } ) ) { + $values{ operating_system_name } = "GNU/Linux"; + }; # if +} elsif ( $values{ kernel_name } eq "Darwin" ) { + my %codenames = ( + 10.4 => "Tiger", + 10.5 => "Leopard", + 10.6 => "Snow Leopard", + ); + my $darwin; + my $get_os_info = + sub { + my ( $name ) = @_; + if ( not defined $darwin ) { + $darwin->{ operating_system } = "Darwin"; + # sw_vers prints OS X* version to stdout: + # ProductName: OS X* + # ProductVersion: 10.4.11 + # BuildVersion: 8S2167 + # It does not print codename, so we code OS X* codenames here. + my $sw_vers = which( "sw_vers" ) || "/usr/bin/sw_vers"; + my $output; + debug( "Executing $sw_vers..." ); + execute( [ $sw_vers ], -stdout => \$output, -stderr => undef ); + $output =~ m{^ProductName:\s*(.*)\s*$}m + or runtime_error( "There is no ProductName in sw_vers output:", $output, "(eof)" ); + my $name = $1; + $output =~ m{^ProductVersion:\s*(.*)\s*$}m + or runtime_error( "There is no ProductVersion in sw_vers output:", $output, "(eof)" ); + my $release = $1; + # Sometimes release reported as "10.4.11" (3 componentes), sometimes as "10.6". + # Handle both variants. + $release =~ m{^(\d+.\d+)(?:\.\d+)?(?=\s|$)} + or runtime_error( "Cannot parse OS X* version: $release" ); + my $version = $1; + my $codename = ( $codenames{ $version } or "unknown" ); + $darwin->{ operating_system_name } = $name; + $darwin->{ operating_system_release } = $release; + $darwin->{ operating_system_codename } = $codename; + $darwin->{ operating_system_description } = sprintf( "%s %s (%s)", $name, $release, $codename ); + }; # if + return $darwin->{ $name }; + }; # sub + $values{ operating_system } = sub { $get_os_info->( "operating_system" ); }; + $values{ operating_system_name } = sub { $get_os_info->( "operating_system_name" ); }; + $values{ operating_system_release } = sub { $get_os_info->( "operating_system_release" ); }; + $values{ operating_system_codename } = sub { $get_os_info->( "operating_system_codename" ); }; + $values{ operating_system_description } = sub { $get_os_info->( "operating_system_description" ); }; +} elsif ( $values{ kernel_name } =~ m{\AWindows[ _]NT\z} ) { + $values{ operating_system } = "MS Windows"; + # my @os_name = Win32::GetOSName(); + # $values{ operating_system_release } = $os_name[ 0 ]; + # $values{ operating_system_update } = $os_name[ 1 ]; +} elsif ( $values{ kernel_name } =~ m{\ACYGWIN_NT-} ) { + $values{ operating_system } = "MS Windows"; +} elsif ( $values{ kernel_name } =~ m{\AFreeBSD} ) { + $values{ operating_system } = "FreeBSD"; +} elsif ( $values{ kernel_name } =~ m{\ANetBSD} ) { + $values{ operating_system } = "NetBSD"; +} else { + die "Unsupported kernel_name (\"$values{ kernel_name }\") returned by POSIX::uname(); stopped"; +}; # if + +# host_name and domain_name +$values{ host_name } = + sub { + my $fqdn = value( "fqdn" ); + $fqdn =~ m{\A([^.]*)(?:\.(.*))?\z}; + my $host_name = $1; + if ( not defined( $host_name ) or $host_name eq "" ) { + die "Unexpected error: undefined or empty host name; stopped"; + }; # if + return $host_name; + }; +$values{ domain_name } = + sub { + my $fqdn = value( "fqdn" ); + $fqdn =~ m{\A([^.]*)(?:\.(.*))?\z}; + my $domain_name = $2; + if ( not defined( $domain_name ) or $domain_name eq "" ) { + die "Unexpected error: undefined or empty domain name; stopped"; + }; # if + return $domain_name; + }; + +# Replace undefined values with "unknown". +foreach my $name ( @all ) { + if ( not defined( $values{ $name } ) ) { + $values{ $name } = "unknown"; + }; # if +}; # foreach $name + +# Export functions reporting properties. +foreach my $name ( @all ) { + no strict "refs"; + *$name = sub { return value( $name ); }; +}; # foreach $name + +# This function returns base names. +sub base_names { + return @base; +}; # sub base_names + +# This function returns all the names. +sub all_names { + return @all; +}; # sub all_names + +# This function returns value by the specified name. +sub value($) { + my $name = shift( @_ ); + if ( ref( $values{ $name } ) ) { + my $value = $values{ $name }->(); + $values{ $name } = $value; + }; # if + return $values{ $name }; +}; # sub value + +return 1; + +__END__ + +=pod + +=head1 NAME + +B<Uname.pm> -- A few subroutines to get system information usually provided by +C</bin/uname> and C<POSIX::uname()>. + +=head1 SYNOPSIS + + use Uname; + + # Base property functions. + $kernel_name = Uname::kernel_name(); + $fqdn = Uname::fqdn(); + $kernel_release = Uname::kernel_release(); + $kernel_version = Uname::kernel_version(); + $machine = Uname::machine(); + $processor = Uname::processor(); + $hardware_platform = Uname::hardware_platform(); + $operating_system = Uname::operating_system(); + + # Auxiliary property functions. + $host_name = Uname::host_name(); + $domain_name = Uname::domain_name(); + $os_name = Uname::operating_system_name(); + $os_release = Uname::operating_system_release(); + $os_codename = Uname::operating_system_codename(); + $os_description = Uname::operating_system_description(); + + # Meta functions. + @base_names = Uname::base_names(); + @all_names = Uname::all_names(); + $kernel_name = Uname::value( "kernel_name" ); + +=head1 DESCRIPTION + +B<Uname.pm> resembles functionality found in C<POSIX::uname()> function or in C<uname> program. +However, both C<POSIX::uname()> and C</bin/uname> have some disadvantages: + +=over + +=item * + +C<uname> may be not available in some environments, for example, in Windows* OS +(C<uname> may be found in some third-party software packages, like MKS Toolkit or Cygwin, but it is +not a part of OS). + +=item * + +There are many different versions of C<uname>. For example, C<uname> on OS X* does not +recognize options C<-i>, C<-o>, and any long options. + +=item * + +Different versions of C<uname> may report the same property differently. For example, +C<uname> on Linux* OS reports machine as C<i686>, while C<uname> on OS X* reports the same machine as +C<x86>. + +=item * + +C<POSIX::uname()> returns list of values. I cannot recall what is the fourth element of the list. + +=back + +=head2 Base Functions + +Base property functions provide the information as C<uname> program. + +=over + +=item B<kernel_name()> + +Returns the kernel name, as reported by C<POSIX::uname()>. + +=item B<fqdn()> + +Returns the FQDN, fully qualified domain name. On some systems C<POSIX::uname()> reports short node +name (with no domain name), on others C<POSIX::uname()> reports full node name. This +function strive to return FQDN always (by refining C<POSIX::uname()> with +C<Net::Domain::hostfqdn()>). + +=item B<kernel_release()> + +Returns the kernel release string, as reported by C<POSIX::uname()>. Usually the string consists of +several numbers, separated by dots and dashes, but may also include some non-numeric substrings like +"smp". + +=item B<kernel_version()> + +Returns the kernel version string, as reported by C<POSIX::uname()>. It is B<not> several +dot-separated numbers but much longer string describing the kernel. +For example, on Linux* OS it includes build date. +If you look for something identifying the kernel, look at L<kernel_release>. + +=item B<machine()> + +Returns the machine hardware name, as reported by POSIX::uname(). Not reliable. Different OSes may +report the same machine hardware name differently. For example, Linux* OS reports C<i686>, while OS X* +reports C<x86> on the same machine. + +=item B<processor()> + +Returns the processor type. Not reliable. Usually the same as C<machine>. + +=item B<hardware_platform()> + +One of: C<i386> or C<x86_64>. + +=item B<operating_system()> + +One of: C<GNU/Linux>, C<OS X*>, or C<MS Windows>. + +=back + +=head2 Auxiliary Functions + +Auxiliary functions extends base functions with information not reported by C<uname> program. + +Auxiliary functions collect information from different sources. For example, on OS X*, they may +call C<sw_vers> program to find out OS release; on Linux* OS they may parse C</etc/redhat-release> file, +etc. + +=over + +=item B<host_name()> + +Returns host name (FQDN with dropped domain part). + +=item B<domain_name()> + +Returns domain name (FQDN with dropped host part). + +=item B<operating_system_name> + +Name of operating system or name of Linux* OS distribution, like "Fedora" or +"Red Hat Enterprise Linux* OS Server". + +=item B<operating_system_release> + +Release (version) of operating system or Linux* OS distribution. Usually it is a series of +dot-separated numbers. + +=item B<operating_system_codename> + +Codename of operating system release or Linux* OS distribution. For example, Fedora 10 is "Cambridge" +while OS X* 10.4 is "Tiger". + +=item B<operating_system_description> + +Longer string. Usually it includes all the operating system properting mentioned above -- name, +release, codename in parentheses. + +=back + +=head2 Meta Functions + +=over + +=item B<base_names()> + +This function returns the list of base property names. + +=item B<all_names()> + +This function returns the list of all property names. + +=item B<value(> I<name> B<)> + +This function returns the value of the property specified by I<name>. + +=back + +=head1 EXAMPLES + + use Uname; + + print( Uname::string(), "\n" ); + + foreach my $name ( Uname::all_names() ) { + print( "$name=\"" . Uname::value( $name ) . "\"\n" ); + }; # foreach $name + +=head1 SEE ALSO + +L<POSIX::uname>, L<uname>. + +=cut + +# end of file # + |