Magic-Mirror/llvm-capstone
1
0
Fork 0
mirror of https://github.com/capstone-engine/llvm-capstone.git synced 2024-12-26 17:57:07 +00:00
Code Issues Actions 2 Packages Projects Releases Wiki Activity
dfcd4384cb
llvm-capstone/openmp/runtime/tools/lib/Uname.pm
Chandler Carruth 57b08b0944 Update more file headers across all of the LLVM projects in the monorepo 
to reflect the new license. These used slightly different spellings that
defeated my regular expressions.

We understand that people may be surprised that we're moving the header
entirely to discuss the new license. We checked this carefully with the
Foundation's lawyer and we believe this is the correct approach.

Essentially, all code in the project is now made available by the LLVM
project under our new license, so you will see that the license headers
include that license only. Some of our contributors have contributed
code under our old license, and accordingly, we have retained a copy of
our old license notice in the top-level files in each project and
repository.

llvm-svn: 351648
2019-01-19 10:56:40 +00:00

639 lines
24 KiB
Perl
Raw Blame History

#
# 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...
#
#
#//===----------------------------------------------------------------------===//
#//
#// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
#// See https://llvm.org/LICENSE.txt for license information.
#// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
#//
#//===----------------------------------------------------------------------===//
#
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 #
Reference in New Issue View Git Blame Copy Permalink