diff options
20 files changed, 987 insertions, 5618 deletions
diff --git a/openmp/runtime/cmake/LibompExports.cmake b/openmp/runtime/cmake/LibompExports.cmake index dbeb18f..461e47d 100644 --- a/openmp/runtime/cmake/LibompExports.cmake +++ b/openmp/runtime/cmake/LibompExports.cmake @@ -28,15 +28,22 @@ endif() string(REPLACE ";" "" libomp_suffix "${libomp_suffix}") # Set exports locations +if(WIN32) + set(LIBOMP_SHORT_OS win) +elseif(APPLE) + set(LIBOMP_SHORT_OS mac) +else() + set(LIBOMP_SHORT_OS lin) +endif() if(${MIC}) - set(libomp_platform "${LIBOMP_PERL_SCRIPT_OS}_${LIBOMP_MIC_ARCH}") # e.g., lin_knf, lin_knc + set(libomp_platform "${LIBOMP_SHORT_OS}_${LIBOMP_MIC_ARCH}") # e.g., lin_knf, lin_knc else() if(${IA32}) - set(libomp_platform "${LIBOMP_PERL_SCRIPT_OS}_32") + set(libomp_platform "${LIBOMP_SHORT_OS}_32") elseif(${INTEL64}) - set(libomp_platform "${LIBOMP_PERL_SCRIPT_OS}_32e") + set(libomp_platform "${LIBOMP_SHORT_OS}_32e") else() - set(libomp_platform "${LIBOMP_PERL_SCRIPT_OS}_${LIBOMP_ARCH}") # e.g., lin_arm, lin_ppc64 + set(libomp_platform "${LIBOMP_SHORT_OS}_${LIBOMP_ARCH}") # e.g., lin_arm, lin_ppc64 endif() endif() set(LIBOMP_EXPORTS_DIR "${LIBOMP_BASE_DIR}/exports") diff --git a/openmp/runtime/cmake/LibompHandleFlags.cmake b/openmp/runtime/cmake/LibompHandleFlags.cmake index 1aba1fb..cb7e488 100644 --- a/openmp/runtime/cmake/LibompHandleFlags.cmake +++ b/openmp/runtime/cmake/LibompHandleFlags.cmake @@ -170,7 +170,7 @@ function(libomp_get_fflags fflags) set(${fflags} ${fflags_local} PARENT_SCOPE) endfunction() -# Perl generate-defs.pl flags (For Windows only) +# Python generate-defs.py flags (For Windows only) function(libomp_get_gdflags gdflags) set(gdflags_local) if(${IA32}) diff --git a/openmp/runtime/cmake/LibompMicroTests.cmake b/openmp/runtime/cmake/LibompMicroTests.cmake index 6fcde37..0d48246 100644 --- a/openmp/runtime/cmake/LibompMicroTests.cmake +++ b/openmp/runtime/cmake/LibompMicroTests.cmake @@ -25,12 +25,7 @@ # - Fails if stack is executable. Should only be readable and writable. Not executable. # - Program dependencies: perl, readelf # - Available for Unix dynamic library builds. Not available otherwise. -# (4) test-instr (Intel(R) MIC Architecture only) -# - Tests Intel(R) MIC Architecture libraries for valid instruction set -# - Fails if finds invalid instruction for Intel(R) MIC Architecture (wasn't compiled with correct flags) -# - Program dependencies: perl, objdump -# - Available for Intel(R) MIC Architecture and i386 builds. Not available otherwise. -# (5) test-deps +# (4) test-deps # - Tests newly created libomp for library dependencies # - Fails if sees a dependence not listed in td_exp variable below # - Program dependencies: perl, (unix)readelf, (mac)otool[64], (windows)link.exe @@ -93,7 +88,6 @@ endif() macro(libomp_test_touch_recipe test_touch_dir) set(libomp_test_touch_dependencies ${LIBOMP_SRC_DIR}/test-touch.c omp) set(libomp_test_touch_exe ${test_touch_dir}/test-touch${CMAKE_EXECUTABLE_SUFFIX}) - set(libomp_test_touch_obj ${test_touch_dir}/test-touch${CMAKE_C_OUTPUT_EXTENSION}) if(WIN32) if(${RELEASE_BUILD} OR ${RELWITHDEBINFO_BUILD}) if(${test_touch_dir} MATCHES "test-touch-mt") @@ -108,13 +102,13 @@ macro(libomp_test_touch_recipe test_touch_dir) libomp_append(libomp_test_touch_cflags /MDd) endif() endif() - set(libomp_test_touch_out_flags -Fe${libomp_test_touch_exe} -Fo${libomp_test_touch_obj}) + set(libomp_test_touch_out_flags -Fe${libomp_test_touch_exe}) list(APPEND libomp_test_touch_dependencies ompimp) else() set(libomp_test_touch_out_flags -o ${libomp_test_touch_exe}) endif() add_custom_command( - OUTPUT ${test_touch_dir}/.success ${libomp_test_touch_exe} ${libomp_test_touch_obj} + OUTPUT ${test_touch_dir}/.success ${libomp_test_touch_exe} COMMAND ${CMAKE_COMMAND} -E make_directory ${CMAKE_CURRENT_BINARY_DIR}/${test_touch_dir} COMMAND ${CMAKE_COMMAND} -E remove -f ${test_touch_dir}/* COMMAND ${libomp_test_touch_compiler} ${libomp_test_touch_out_flags} ${libomp_test_touch_cflags} @@ -152,22 +146,10 @@ set_target_properties(libomp-test-execstack PROPERTIES FOLDER "OpenMP/Tests") add_custom_command( OUTPUT test-execstack/.success COMMAND ${CMAKE_COMMAND} -E make_directory ${CMAKE_CURRENT_BINARY_DIR}/test-execstack - COMMAND ${PERL_EXECUTABLE} ${LIBOMP_TOOLS_DIR}/check-execstack.pl - --arch=${LIBOMP_PERL_SCRIPT_ARCH} ${LIBOMP_OUTPUT_DIRECTORY}/${LIBOMP_LIB_FILE} + COMMAND ${Python3_EXECUTABLE} ${LIBOMP_TOOLS_DIR}/check-execstack.py + ${LIBOMP_OUTPUT_DIRECTORY}/${LIBOMP_LIB_FILE} COMMAND ${CMAKE_COMMAND} -E touch test-execstack/.success - DEPENDS omp -) - -# test-instr -add_custom_target(libomp-test-instr DEPENDS test-instr/.success) -set_target_properties(libomp-test-instr PROPERTIES FOLDER "OpenMP/Tests") -add_custom_command( - OUTPUT test-instr/.success - COMMAND ${CMAKE_COMMAND} -E make_directory ${CMAKE_CURRENT_BINARY_DIR}/test-instr - COMMAND ${PERL_EXECUTABLE} ${LIBOMP_TOOLS_DIR}/check-instruction-set.pl --os=${LIBOMP_PERL_SCRIPT_OS} - --arch=${LIBOMP_PERL_SCRIPT_ARCH} --show --mic-arch=${LIBOMP_MIC_ARCH} ${LIBOMP_OUTPUT_DIRECTORY}/${LIBOMP_LIB_FILE} - COMMAND ${CMAKE_COMMAND} -E touch test-instr/.success - DEPENDS omp ${LIBOMP_TOOLS_DIR}/check-instruction-set.pl + DEPENDS omp ${LIBOMP_TOOLS_DIR}/check-execstack.py ) # test-deps @@ -187,7 +169,15 @@ elseif(APPLE) set(libomp_expected_library_deps /usr/lib/libSystem.B.dylib) elseif(WIN32) set(libomp_expected_library_deps kernel32.dll) - libomp_append(libomp_expected_library_deps psapi.dll LIBOMP_OMPT_SUPPORT) + libomp_append(libomp_expected_library_deps api-ms-win-crt-convert-l1-1-0.dll) + libomp_append(libomp_expected_library_deps api-ms-win-crt-environment-l1-1-0.dll) + libomp_append(libomp_expected_library_deps api-ms-win-crt-heap-l1-1-0.dll) + libomp_append(libomp_expected_library_deps api-ms-win-crt-runtime-l1-1-0.dll) + libomp_append(libomp_expected_library_deps api-ms-win-crt-stdio-l1-1-0.dll) + libomp_append(libomp_expected_library_deps api-ms-win-crt-string-l1-1-0.dll) + libomp_append(libomp_expected_library_deps api-ms-win-crt-utility-l1-1-0.dll) + libomp_append(libomp_expected_library_deps vcruntime140.dll) + libomp_append(libomp_expected_library_deps psapi.dll) else() if(${MIC}) set(libomp_expected_library_deps libc.so.6 libpthread.so.0 libdl.so.2) @@ -202,9 +192,11 @@ else() if(${IA32}) libomp_append(libomp_expected_library_deps libc.so.6) libomp_append(libomp_expected_library_deps ld-linux.so.2) + libomp_append(libomp_expected_library_deps librt.so.1) elseif(${INTEL64}) libomp_append(libomp_expected_library_deps libc.so.6) libomp_append(libomp_expected_library_deps ld-linux-x86-64.so.2) + libomp_append(libomp_expected_library_deps librt.so.1) elseif(${ARM}) libomp_append(libomp_expected_library_deps libc.so.6) libomp_append(libomp_expected_library_deps libffi.so.6) @@ -232,13 +224,14 @@ else() libomp_append(libomp_expected_library_deps libstdc++.so.6 LIBOMP_USE_STDCPPLIB) libomp_append(libomp_expected_library_deps libm.so.6 LIBOMP_STATS) endif() -# Perl script expects comma separated list +# Check depends script expects comma separated list string(REPLACE ";" "," libomp_expected_library_deps "${libomp_expected_library_deps}") add_custom_command( OUTPUT test-deps/.success COMMAND ${CMAKE_COMMAND} -E make_directory ${CMAKE_CURRENT_BINARY_DIR}/test-deps - COMMAND ${PERL_EXECUTABLE} ${LIBOMP_TOOLS_DIR}/check-depends.pl --os=${LIBOMP_PERL_SCRIPT_OS} - --arch=${LIBOMP_PERL_SCRIPT_ARCH} --expected="${libomp_expected_library_deps}" ${LIBOMP_OUTPUT_DIRECTORY}/${LIBOMP_LIB_FILE} + COMMAND ${Python3_EXECUTABLE} ${LIBOMP_TOOLS_DIR}/check-depends.py + --expected="${libomp_expected_library_deps}" + ${LIBOMP_OUTPUT_DIRECTORY}/${LIBOMP_LIB_FILE} COMMAND ${CMAKE_COMMAND} -E touch test-deps/.success - DEPENDS omp ${LIBOMP_TOOLS_DIR}/check-depends.pl + DEPENDS omp ${LIBOMP_TOOLS_DIR}/check-depends.py ) diff --git a/openmp/runtime/cmake/config-ix.cmake b/openmp/runtime/cmake/config-ix.cmake index 337fe2e..0568474 100644 --- a/openmp/runtime/cmake/config-ix.cmake +++ b/openmp/runtime/cmake/config-ix.cmake @@ -219,30 +219,10 @@ if (IA32 OR INTEL64) set(CMAKE_REQUIRED_FLAGS ${OLD_CMAKE_REQUIRED_FLAGS}) endif() -# Find perl executable -# Perl is used to create omp.h (and other headers) along with kmp_i18n_id.inc and kmp_i18n_default.inc -find_package(Perl REQUIRED) -# The perl scripts take the --os=/--arch= flags which expect a certain format for operating systems and arch's. -# Until the perl scripts are removed, the most portable way to handle this is to have all operating systems that -# are neither Windows nor Mac (Most Unix flavors) be considered lin to the perl scripts. This is rooted -# in that all the Perl scripts check the operating system and will fail if it isn't "valid". This -# temporary solution lets us avoid trying to enumerate all the possible OS values inside the Perl modules. -if(WIN32) - set(LIBOMP_PERL_SCRIPT_OS win) -elseif(APPLE) - set(LIBOMP_PERL_SCRIPT_OS mac) -else() - set(LIBOMP_PERL_SCRIPT_OS lin) -endif() -if(IA32) - set(LIBOMP_PERL_SCRIPT_ARCH 32) -elseif(MIC) - set(LIBOMP_PERL_SCRIPT_ARCH mic) -elseif(INTEL64) - set(LIBOMP_PERL_SCRIPT_ARCH 32e) -else() - set(LIBOMP_PERL_SCRIPT_ARCH ${LIBOMP_ARCH}) -endif() +# Find python3 executable +# Python3 is used to create kmp_i18n_id.inc and +# kmp_i18n_default.inc and for Windows the *.def files. +find_package(Python3 REQUIRED COMPONENTS Interpreter) # Checking features # Check if version symbol assembler directives are supported diff --git a/openmp/runtime/src/CMakeLists.txt b/openmp/runtime/src/CMakeLists.txt index 62c35c1..60641e6 100644 --- a/openmp/runtime/src/CMakeLists.txt +++ b/openmp/runtime/src/CMakeLists.txt @@ -28,15 +28,15 @@ endif() # Generate message catalog files: kmp_i18n_id.inc and kmp_i18n_default.inc add_custom_command( OUTPUT kmp_i18n_id.inc - COMMAND ${PERL_EXECUTABLE} ${LIBOMP_TOOLS_DIR}/message-converter.pl --os=${LIBOMP_PERL_SCRIPT_OS} - --prefix=kmp_i18n --enum=kmp_i18n_id.inc ${LIBOMP_SRC_DIR}/i18n/en_US.txt - DEPENDS ${LIBOMP_SRC_DIR}/i18n/en_US.txt ${LIBOMP_TOOLS_DIR}/message-converter.pl + COMMAND ${Python3_EXECUTABLE} ${LIBOMP_TOOLS_DIR}/message-converter.py + --enum=kmp_i18n_id.inc ${LIBOMP_SRC_DIR}/i18n/en_US.txt + DEPENDS ${LIBOMP_SRC_DIR}/i18n/en_US.txt ${LIBOMP_TOOLS_DIR}/message-converter.py ) add_custom_command( OUTPUT kmp_i18n_default.inc - COMMAND ${PERL_EXECUTABLE} ${LIBOMP_TOOLS_DIR}/message-converter.pl --os=${LIBOMP_PERL_SCRIPT_OS} - --prefix=kmp_i18n --default=kmp_i18n_default.inc ${LIBOMP_SRC_DIR}/i18n/en_US.txt - DEPENDS ${LIBOMP_SRC_DIR}/i18n/en_US.txt ${LIBOMP_TOOLS_DIR}/message-converter.pl + COMMAND ${Python3_EXECUTABLE} ${LIBOMP_TOOLS_DIR}/message-converter.py + --default=kmp_i18n_default.inc ${LIBOMP_SRC_DIR}/i18n/en_US.txt + DEPENDS ${LIBOMP_SRC_DIR}/i18n/en_US.txt ${LIBOMP_TOOLS_DIR}/message-converter.py ) # Set the -D definitions for all sources @@ -301,11 +301,12 @@ if(WIN32) # Create the main def file with ordinals to use for building the runtime dll to maintain backwards compatible exports order libomp_get_gdflags(LIBOMP_GDFLAGS) libomp_string_to_list("${LIBOMP_GDFLAGS}" LIBOMP_GDFLAGS) + add_custom_command( OUTPUT ${LIBOMP_GENERATED_DEF_FILE} - COMMAND ${PERL_EXECUTABLE} ${LIBOMP_TOOLS_DIR}/generate-def.pl ${LIBOMP_GDFLAGS} -D NAME=${LIBOMP_LIB_FILE} + COMMAND ${Python3_EXECUTABLE} ${LIBOMP_TOOLS_DIR}/generate-def.py ${LIBOMP_GDFLAGS} --name ${LIBOMP_LIB_FILE} -o ${LIBOMP_GENERATED_DEF_FILE} ${CMAKE_CURRENT_SOURCE_DIR}/dllexports - DEPENDS ${CMAKE_CURRENT_SOURCE_DIR}/dllexports ${LIBOMP_TOOLS_DIR}/generate-def.pl + DEPENDS ${CMAKE_CURRENT_SOURCE_DIR}/dllexports ${LIBOMP_TOOLS_DIR}/generate-def.py ) if(MSVC) @@ -317,9 +318,10 @@ if(WIN32) set_target_properties(libompimp-needed-def-file PROPERTIES FOLDER "OpenMP/Resources") add_custom_command( OUTPUT ${LIBOMPIMP_GENERATED_DEF_FILE} - COMMAND ${PERL_EXECUTABLE} ${LIBOMP_TOOLS_DIR}/generate-def.pl ${LIBOMP_GDFLAGS} -D NAME=${LIBOMP_LIB_FILE} -D NOORDINALS - -o ${LIBOMPIMP_GENERATED_DEF_FILE} ${CMAKE_CURRENT_SOURCE_DIR}/dllexports - DEPENDS ${CMAKE_CURRENT_SOURCE_DIR}/dllexports ${LIBOMP_TOOLS_DIR}/generate-def.pl + COMMAND ${Python3_EXECUTABLE} ${LIBOMP_TOOLS_DIR}/generate-def.py ${LIBOMP_GDFLAGS} + --name ${LIBOMP_LIB_FILE} --no-ordinals + -o ${LIBOMPIMP_GENERATED_DEF_FILE} ${CMAKE_CURRENT_SOURCE_DIR}/dllexports + DEPENDS ${CMAKE_CURRENT_SOURCE_DIR}/dllexports ${LIBOMP_TOOLS_DIR}/generate-def.py ) # while this merely generates an import library off a def file, CMAKE still requires it to have a "source" so feed it a dummy one, # making it a .txt which CMAKE will filter out from the librarian (a .cpp will make lib.exe punt trying to resolve the .def symbols) @@ -396,9 +398,6 @@ endif() if(NOT WIN32 AND NOT APPLE) add_dependencies(libomp-micro-tests libomp-test-execstack) endif() -if(${MIC}) - add_dependencies(libomp-micro-tests libomp-test-instr) -endif() add_dependencies(libomp-micro-tests libomp-test-deps) # `omp` needs to be exported if in-tree build. diff --git a/openmp/runtime/tools/check-depends.pl b/openmp/runtime/tools/check-depends.pl deleted file mode 100755 index aca888b..0000000 --- a/openmp/runtime/tools/check-depends.pl +++ /dev/null @@ -1,505 +0,0 @@ -#!/usr/bin/env perl - -# -#//===----------------------------------------------------------------------===// -#// -#// 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 -#// -#//===----------------------------------------------------------------------===// -# - -use strict; -use warnings; - -use FindBin; -use lib "$FindBin::Bin/lib"; - -use tools; - -our $VERSION = "0.005"; -my $target_os; -my $target_arch; - -# -------------------------------------------------------------------------------------------------- -# Output parse error. -# $tool -- Name of tool. -# @bulk -- Output of the tool. -# $n -- Number of line caused parse error. -sub parse_error($\@$) { - my ( $tool, $bulk, $n ) = @_; - my @bulk; - for ( my $i = 0; $i < @$bulk; ++ $i ) { - push( @bulk, ( $i == $n ? ">>> " : " " ) . $bulk->[ $i ] ); - }; # for $i - runtime_error( "Fail to parse $tool output:", @bulk, "(eof)" ); -}; # sub parse_error - - -# -------------------------------------------------------------------------------------------------- -# Linux* OS version of get_deps() parses output of ldd: -# -# $ ldd libname.so -# libc.so.6 => /lib64/libc.so.6 (0x00002b60fedd8000) -# libdl.so.2 => /lib64/libdl.so.2 (0x00002b60ff12b000) -# libpthread.so.0 => /lib64/libpthread.so.0 (0x00002b60ff32f000) -# /lib64/ld-linux-x86-64.so.2 (0x0000003879400000) -# -# Note: ldd printd all the dependencies, direct and indirect. (For example, if specified library -# requires libdl.so, and libdl.so requires /lib/ld-linux.so, ldd prints both libdl.so and -# /lib/ld-linux.so). If you do not want indirect dependencies, look at readelf tool. -# -sub get_deps_ldd($) { - - my $lib = shift ( @_ ); - my $tool = "ldd"; - my @bulk; - my @deps; - - execute( [ $tool, $lib ], -stdout => \@bulk ); - debug( @bulk, "(eof)" ); - - foreach my $i ( 0 .. @bulk - 1 ) { - my $line = $bulk[ $i ]; - if ( $line !~ m{^\s*(?:([_a-z0-9.+-/]*)\s+=>\s+)?([_a-z0-9.+-/]*)\s+\(0x[0-9a-z]*\)$}i ) { - parse_error( $tool, @bulk, $i ); - }; # if - my $dep = ( defined( $1 ) ? $1 : $2 ); - push( @deps, $dep ); - }; # foreach $i - - return @deps; - -}; # sub get_deps_ldd - - -# -------------------------------------------------------------------------------------------------- -# Another Linux* OS version of get_deps() parses output of readelf: -# -# $ readelf -d exports/lin_32e/lib/libomp.so -# -# Dynamic segment at offset 0x87008 contains 24 entries: -# Tag Type Name/Value -# 0x0000000000000001 (NEEDED) Shared library: [libc.so.6] -# 0x0000000000000001 (NEEDED) Shared library: [libdl.so.2] -# 0x0000000000000001 (NEEDED) Shared library: [libpthread.so.0] -# 0x000000000000000e (SONAME) Library soname: [libomp.so] -# 0x000000000000000d (FINI) 0x51caa -# 0x0000000000000004 (HASH) 0x158 -# 0x0000000000000005 (STRTAB) 0x9350 -# ... -# -# Note: In contrast to ldd, readelf shows only direct dependencies. -# -sub get_deps_readelf($) { - - my $file = shift ( @_ ); - my $tool; - my @bulk; - my @deps; - - if($target_arch eq "mic") { - $tool = "x86_64-k1om-linux-readelf"; - } else { - $tool = "readelf"; - } - - # Force the readelf call to be in English. For example, when readelf - # is called on a french localization, it will find "Librairie partagees" - # instead of shared library - $ENV{ LANG } = "C"; - - execute( [ $tool, "-d", $file ], -stdout => \@bulk ); - debug( @bulk, "(eof)" ); - - my $i = 0; - # Parse header. - ( $i < @bulk and $bulk[ $i ] =~ m{^\s*$} ) - or parse_error( $tool, @bulk, $i ); - ++ $i; - if ( $i == @bulk - 1 and $bulk[ $i ] =~ m{^There is no dynamic section in this file\.\s*$} ) { - # This is not dynamic executable => no dependencies. - return @deps; - }; # if - ( $i < @bulk and $bulk[ $i ] =~ m{^Dynamic (?:segment|section) at offset 0x[0-9a-f]+ contains \d+ entries:\s*$} ) - or parse_error( $tool, @bulk, $i ); - ++ $i; - ( $i < @bulk and $bulk[ $i ] =~ m{^\s*Tag\s+Type\s+Name/Value\s*$} ) - or parse_error( $tool, @bulk, $i ); - ++ $i; - # Parse body. - while ( $i < @bulk ) { - my $line = $bulk[ $i ]; - if ( $line !~ m{^\s*0x[0-9a-f]+\s+\(?([_A-Z0-9]+)\)?\s+(.*)\s*$}i ) { - parse_error( $tool, @bulk, $i ); - }; # if - my ( $type, $value ) = ( $1, $2 ); - if ( $type eq "NEEDED" ) { - if ( $value !~ m{\AShared library: \[(.*)\]\z} ) { - parse_error( $tool, @bulk, $i ); - }; # if - my $dep = $1; - push( @deps, $dep ); - }; # if - ++ $i; - }; # foreach $i - - return @deps; - -}; # sub get_deps_readelf - - -# -------------------------------------------------------------------------------------------------- -# OS X* version of get_deps() parses output of otool: -# -# $ otool -L libname.dylib -# exports/mac_32/lib.thin/libomp.dylib: -# libomp.dylib (compatibility version 5.0.0, current version 5.0.0) -# /usr/lib/libSystem.B.dylib (compatibility version 1.0.0, current version 88.1.3) -# -sub get_deps_otool($) { - - my $file = shift ( @_ ); - my $name = get_file( $file ); - my $tool = "otool"; - my @bulk; - my @deps; - - if ( $target_arch eq "32e" ) { - # On older (Tiger) systems otool does not recognize 64-bit binaries, so try to locate - # otool64. - my $path = which( "otool64" ); - if ( defined ( $path ) ) { - $tool = "otool64"; - }; # if - }; # if - - execute( [ $tool, "-L", $file ], -stdout => \@bulk ); - debug( @bulk, "(eof)" ); - - my $i = 0; - # Parse the first one or two lines separately. - ( $i < @bulk and $bulk[ $i ] =~ m{^\Q$file\E:$} ) - or parse_error( $tool, @bulk, $i ); - ++ $i; - if ( $name =~ m{\.dylib\z} ) { - # Added "@rpath/" enables dynamic load of the library designated at link time. - $name = '@rpath/' . $name; - # In case of dynamic library otool print the library itself as a dependent library. - ( $i < @bulk and $bulk[ $i ] =~ m{^\s+\Q$name\E\s+\(compatibility version.*\)$} ) - or parse_error( $tool, @bulk, $i ); - ++ $i; - }; # if - - # Then parse the rest. - while ( $i < @bulk ) { - my $line = $bulk[ $i ]; - if ( $line !~ m/^\s*(.*)\s+\(compatibility version\s.*\)$/ ) { - parse_error( $tool, @bulk, $i ); - }; # if - my ( $dep ) = ( $1 ); - push( @deps, $dep ); - ++ $i; - }; # while - - return @deps; - -}; # sub get_deps_otool - - -# -------------------------------------------------------------------------------------------------- -# Windows* OS version of get_deps() parses output of link: -# -# > link -dump -dependents libname.dll -# Microsoft (R) COFF/PE Dumper Version 8.00.40310.39 -# Copyright (C) Microsoft Corporation. All rights reserved. -# Dump of file S:\Projects.OMP\users\omalyshe\omp\libomp\exports\win_64\lib\libompmd.dll -# File Type: DLL -# Image has the following dependencies: -# KERNEL32.dll -# Summary -# C000 .data -# 6000 .pdata -# 18000 .rdata -# ... -# -# > link -dump -directives libname.lib -# Microsoft (R) COFF/PE Dumper Version 8.00.40310.39 -# Copyright (C) Microsoft Corporation. All rights reserved. -# Dump of file S:\Projects.OMP\users\omalyshe\omp\libomp\exports\win_32e\lib\libimp5mt.lib -# File Type: LIBRARY -# Linker Directives -# ----------------- -# -defaultlib:"uuid.lib" -# -defaultlib:"uuid.lib" -# ..... -# Summary -# 3250 .bss -# 3FBC .data -# 34 .data1 -# .... -sub get_deps_link($) { - - my ( $lib ) = @_; - my $tool = "link"; - my @bulk; - my @deps; - - my $ext = lc( get_ext( $lib ) ); - if ( $ext !~ m{\A\.(?:lib|dll|exe)\z}i ) { - runtime_error( "Incorrect file is specified: `$lib'; only `lib', `dll' or `exe' file expected" ); - }; # if - - execute( - [ $tool, "/dump", ( $ext eq ".lib" ? "/directives" : "/dependents" ), $lib ], - -stdout => \@bulk - ); - - debug( @bulk, "(eof)" ); - - my $i = 0; - ( $i < @bulk and $bulk[ $i ] =~ m{^Microsoft \(R\) COFF\/PE Dumper Version.*$} ) or parse_error( $tool, @bulk, $i ); ++ $i; - ( $i < @bulk and $bulk[ $i ] =~ m{^Copyright \(C\) Microsoft Corporation\..*$} ) or parse_error( $tool, @bulk, $i ); ++ $i; - ( $i < @bulk and $bulk[ $i ] =~ m{^\s*$} ) or parse_error( $tool, @bulk, $i ); ++ $i; - ( $i < @bulk and $bulk[ $i ] =~ m{^\s*$} ) or parse_error( $tool, @bulk, $i ); ++ $i; - ( $i < @bulk and $bulk[ $i ] =~ m{^Dump of file\s\Q$lib\E$} ) or parse_error( $tool, @bulk, $i ); ++ $i; - ( $i < @bulk and $bulk[ $i ] =~ m{^\s*$} ) or parse_error( $tool, @bulk, $i ); ++ $i; - ( $i < @bulk and $bulk[ $i ] =~ m{^File Type:\s(.*)$} ) or parse_error( $tool, @bulk, $i ); ++ $i; - ( $i < @bulk and $bulk[ $i ] =~ m{^\s*$} ) or parse_error( $tool, @bulk, $i ); ++ $i; - - if ( $ext eq ".lib" ) { - - my %deps; - while ( $i < @bulk ) { - my $line = $bulk[ $i ]; - if ( 0 ) { - } elsif ( $line =~ m{^\s*[-/]defaultlib\:(.*)\s*$}i ) { - my $dep = $1; - # Normalize library name: - $dep = lc( $1 ); # Convert to lower case. - $dep =~ s{\A"(.*)"\z}{$1}; # Drop surrounding quotes (if any). - $dep =~ s{\.lib\z}{}; # Drop .lib suffix (if any). - $deps{ $dep } = 1; - } elsif ( $line =~ m{^\s*Linker Directives\s*$} ) { - } elsif ( $line =~ m{^\s*-+\s*$} ) { - } elsif ( $line =~ m{^\s*/alternatename\:.*$} ) { - } elsif ( $line =~ m{^\s*$} ) { - } elsif ( $line =~ m{^\s*/FAILIFMISMATCH\:.*$} ) { - # This directive is produced only by _MSC_VER=1600 - } elsif ( $line =~ m{^\s*Summary\s*$} ) { - last; - } else { - parse_error( $tool, @bulk, $i ); - }; # if - ++ $i; - } # while - @deps = keys( %deps ); - - } else { - - ( $i < @bulk and $bulk[ $i ] =~ m{\s*Image has the following dependencies\:$} ) - or parse_error( $tool, @bulk, $i ); - ++ $i; - while ( $i < @bulk ) { - my $line = $bulk[ $i ]; - if ( 0 ) { - } elsif ( $line =~ m{^\s*$} ) { - # Ignore empty lines. - } elsif ( $line =~ m{^\s*(.*\.dll)$}i ) { - my $dep = lc( $1 ); - push( @deps, $dep ); - } elsif ( $line =~ m{^\s*Summary$} ) { - last; - } else { - parse_error( $tool, @bulk, $i ); - }; # if - ++ $i; - }; # while - - }; # if - - return @deps; - -}; # sub get_deps_link - - -# -------------------------------------------------------------------------------------------------- -# Main. -# -------------------------------------------------------------------------------------------------- - -# Parse command line. -my $expected; -my $bare; -Getopt::Long::Configure( "permute" ); -get_options( - "os=s" => \$target_os, - "arch=s" => \$target_arch, - "bare" => \$bare, - "expected=s" => \$expected, -); -my @expected; -if ( defined( $expected ) ) { - if ( $expected ne "none" ) { - @expected = sort( split( ",", $expected ) ); - if ( $target_os eq "win" ) { - @expected = map( lc( $_ ), @expected ); - }; # if - }; # if -}; # if -if ( @ARGV < 1 ) { - cmdline_error( "Specify a library name to check for dependencies" ); -}; # if -if ( @ARGV > 1 ) { - cmdline_error( "Too many arguments" ); -}; # if -my $lib = shift( @ARGV ); -if ( not -e $lib ){ - runtime_error( "Specified file does not exist: \"$lib\"" ); -}; # if - -# Select appropriate get_deps implementation. -if ( 0 ) { -} elsif ( $target_os eq "lin" ) { - *get_deps = \*get_deps_readelf; -} elsif ( $target_os eq "mac" ) { - *get_deps = \*get_deps_otool; -} elsif ( $target_os eq "win" ) { - *get_deps = \*get_deps_link; -} else { - runtime_error( "OS \"$target_os\" not supported" ); -}; # if - -# Do the work. -my @deps = sort( get_deps( $lib ) ); -if ( $bare ) { - print( map( "$_\n", @deps ) ); -} else { - info( "Dependencies:", @deps ? map( " $_", @deps ) : "(none)" ); -}; # if -if ( defined( $expected ) ) { - my %deps = map( ( $_ => 1 ), @deps ); - foreach my $dep ( @expected ) { - delete( $deps{ $dep } ); - }; # foreach - my @unexpected = sort( keys( %deps ) ); - if ( @unexpected ) { - runtime_error( "Unexpected dependencies:", map( " $_", @unexpected ) ); - }; # if -}; # if - -exit( 0 ); - -__END__ - -=pod - -=head1 NAME - -B<check-depends.pl> -- Check dependencies for a specified library. - -=head1 SYNOPSIS - -B<check-depends.pl> I<OPTIONS>... I<library> - -=head1 DESCRIPTION - -C<check-depends.pl> finds direct dependencies for a specified library. List of actual dependencies -is sorted alphabetically and printed. If list of expected dependencies is specified, the scripts -checks the library has only allowed dependencies. In case of not expected dependencies. the script -issues error message and exits with non-zero code. - -Linux* OS and OS X*: The script finds dependencies only for dynamic libraries. Windows* OS: The script -finds dependencies for either static or dynamic libraries. - -The script uses external tools. On Linux* OS, it runs F<readelf>, on OS X* -- F<otool> (or F<otool64>), -on Windows* OS -- F<link>. - -On Windows* OS dependencies are printed in lower case, case of expected dependencies ignored. - -=head1 OPTIONS - -=over - -=item B<--bare> - -Do not use fancy formatting; produce plain, bare output: just a list of libraries, -a library per line. - -=item B<--expected=>I<list> - -I<list> is comma-separated list of expected dependencies (or C<none>). -If C<--expected> option specified, C<check-depends.pl> checks the specified library -has only expected dependencies. - -=item B<--os=>I<str> - -Specify target OS (tool to use) manually. -Useful for cross-build, when host OS is not the same as target OS. -I<str> should be either C<lin>, C<mac>, or C<win>. - -=back - -=head2 Standard Options - -=over - -=item B<--help> - -Print short help message and exit. - -=item B<--doc> - -=item B<--manual> - -Print full documentation and exit. - -=item B<--quiet> - -Do not output informational messages. - -=item B<--version> - -Print version and exit. - -=back - -=head1 ARGUMENTS - -=over - -=item I<library> - -A name of library to find or check dependencies. - -=back - -=head1 EXAMPLES - -Just print library dependencies (Windows* OS): - - > check-depends.pl exports/win_32/lib/libompmd.dll - check-depends.pl: (i) Dependencies: - check-depends.pl: (i) kernel32.dll - -Print library dependencies, use bare output (Linux* OS): - - $ check-depends.pl --bare exports/lin_32e/lib/libomp_db.so - libc.so.6 - libdl.so.2 - libpthread.so.0 - -Check the library does not have any dependencies (OS X*): - - $ check-depends.pl --expected=none exports/mac_32/lib/libomp.dylib - check-depends.pl: (i) Dependencies: - check-depends.pl: (i) /usr/lib/libSystem.B.dylib - check-depends.pl: (x) Unexpected dependencies: - check-depends.pl: (x) /usr/lib/libSystem.B.dylib - $ echo $? - 2 - -=cut - -# end of file # - diff --git a/openmp/runtime/tools/check-depends.py b/openmp/runtime/tools/check-depends.py new file mode 100644 index 0000000..f185900 --- /dev/null +++ b/openmp/runtime/tools/check-depends.py @@ -0,0 +1,168 @@ +#!/usr/bin/env python3 + +# +# //===----------------------------------------------------------------------===// +# // +# // 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 +# // +# //===----------------------------------------------------------------------===// +# + +import argparse +import os +import platform +import re +import sys +from libomputils import ( + ScriptError, + error, + execute_command, + print_info_line, + print_error_line, +) + + +def get_deps_readelf(filename): + """Get list of dependencies from readelf""" + deps = [] + # Force readelf call to be in English + os.environ["LANG"] = "C" + r = execute_command(["readelf", "-d", filename]) + if r.returncode != 0: + error("readelf -d {} failed".format(filename)) + neededRegex = re.compile(r"\(NEEDED\)\s+Shared library: \[([a-zA-Z0-9_.-]+)\]") + for line in r.stdout.split(os.linesep): + match = neededRegex.search(line) + if match: + deps.append(match.group(1)) + return deps + + +def get_deps_otool(filename): + """Get list of dependencies from otool""" + deps = [] + r = execute_command(["otool", "-L", filename]) + if r.returncode != 0: + error("otool -L {} failed".format(filename)) + libRegex = re.compile(r"([^ \t]+)\s+\(compatibility version ") + thisLibRegex = re.compile(r"@rpath/{}".format(os.path.basename(filename))) + for line in r.stdout.split(os.linesep): + match = thisLibRegex.search(line) + if match: + # Don't include the library itself as a needed dependency + continue + match = libRegex.search(line) + if match: + deps.append(match.group(1)) + continue + return deps + + +def get_deps_link(filename): + """Get list of dependecies from link (Windows OS)""" + depsSet = set([]) + f = filename.lower() + args = ["link", "/DUMP"] + if f.endswith(".lib"): + args.append("/DIRECTIVES") + elif f.endswith(".dll") or f.endswith(".exe"): + args.append("/DEPENDENTS") + else: + error("unrecognized file extension: {}".format(filename)) + args.append(filename) + r = execute_command(args) + if r.returncode != 0: + error("{} failed".format(args.command)) + if f.endswith(".lib"): + regex = re.compile(r"\s*[-/]defaultlib:(.*)\s*$") + for line in r.stdout.split(os.linesep): + line = line.lower() + match = regex.search(line) + if match: + depsSet.add(match.group(1)) + else: + started = False + markerStart = re.compile(r"Image has the following depend") + markerEnd = re.compile(r"Summary") + markerEnd2 = re.compile(r"Image has the following delay load depend") + for line in r.stdout.split(os.linesep): + if not started: + if markerStart.search(line): + started = True + continue + else: # Started parsing the libs + line = line.strip() + if not line: + continue + if markerEnd.search(line) or markerEnd2.search(line): + break + depsSet.add(line.lower()) + return list(depsSet) + + +def main(): + parser = argparse.ArgumentParser(description="Check library dependencies") + parser.add_argument( + "--bare", + action="store_true", + help="Produce plain, bare output: just a list" + " of libraries, a library per line", + ) + parser.add_argument( + "--expected", + metavar="CSV_LIST", + help="CSV_LIST is a comma-separated list of expected" + ' dependencies (or "none"). checks the specified' + " library has only expected dependencies.", + ) + + parser.add_argument("library", help="The library file to check") + commandArgs = parser.parse_args() + # Get dependencies + deps = [] + + system = platform.system() + if system == "Windows": + deps = get_deps_link(commandArgs.library) + elif system == "Darwin": + deps = get_deps_otool(commandArgs.library) + else: + deps = get_deps_readelf(commandArgs.library) + deps = sorted(deps) + + # If bare output specified, then just print the dependencies one per line + if commandArgs.bare: + print(os.linesep.join(deps)) + return + + # Calculate unexpected dependencies if expected list specified + unexpected = [] + if commandArgs.expected: + # none => any dependency is unexpected + if commandArgs.expected == "none": + unexpected = list(deps) + else: + expected = [d.strip() for d in commandArgs.expected.split(",")] + unexpected = [d for d in deps if d not in expected] + + # Regular output + print_info_line("Dependencies:") + for dep in deps: + print_info_line(" {}".format(dep)) + if unexpected: + print_error_line("Unexpected Dependencies:") + for dep in unexpected: + print_error_line(" {}".format(dep)) + error("found unexpected dependencies") + + +if __name__ == "__main__": + try: + main() + except ScriptError as e: + print_error_line(str(e)) + sys.exit(1) + +# end of file diff --git a/openmp/runtime/tools/check-execstack.pl b/openmp/runtime/tools/check-execstack.pl deleted file mode 100755 index 7a71007..0000000 --- a/openmp/runtime/tools/check-execstack.pl +++ /dev/null @@ -1,145 +0,0 @@ -#!/usr/bin/env perl - -# -#//===----------------------------------------------------------------------===// -#// -#// 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 -#// -#//===----------------------------------------------------------------------===// -# - -use strict; -use warnings; - -use FindBin; -use lib "$FindBin::Bin/lib"; - -use tools; - -our $VERSION = "0.002"; -my $target_arch; - -sub execstack($) { - my ( $file ) = @_; - my @output; - my @stack; - my $tool; - if($target_arch eq "mic") { - $tool = "x86_64-k1om-linux-readelf"; - } else { - $tool = "readelf"; - } - execute( [ $tool, "-l", "-W", $file ], -stdout => \@output ); - @stack = grep( $_ =~ m{\A\s*(?:GNU_)?STACK\s+}, @output ); - if ( not @stack ) { - # Interpret missed "STACK" line as error. - runtime_error( "$file: No stack segment found; looks like stack would be executable." ); - }; # if - if ( @stack > 1 ) { - runtime_error( "$file: More than one stack segment found.", "readelf output:", @output, "(eof)" ); - }; # if - # Typical stack lines are: - # Linux* OS IA-32 architecture: - # GNU_STACK 0x000000 0x00000000 0x00000000 0x00000 0x00000 RWE 0x4 - # Linux* OS Intel(R) 64: - # GNU_STACK 0x000000 0x0000000000000000 0x0000000000000000 0x000000 0x000000 RWE 0x8 - if ( $stack[ 0 ] !~ m{\A\s*(?:GNU_)?STACK(?:\s+0x[0-9a-f]+){5}\s+([R ][W ][E ])\s+0x[0-9a-f]+\s*\z} ) { - runtime_error( "$file: Cannot parse stack segment line:", ">>> $stack[ 0 ]" ); - }; # if - my $attrs = $1; - if ( $attrs =~ m{E} ) { - runtime_error( "$file: Stack is executable" ); - }; # if -}; # sub execstack - -get_options( - "arch=s" => \$target_arch, -); - -foreach my $file ( @ARGV ) { - execstack( $file ); -}; # foreach $file - -exit( 0 ); - -__END__ - -=pod - -=head1 NAME - -B<check-execstack.pl> -- Check whether stack is executable, issue an error if so. - -=head1 SYNOPSIS - -B<check-execstack.pl> I<option>... I<file>... - -=head1 DESCRIPTION - -The script checks whether stack of specified executable file, and issues error if stack is -executable. If stack is not executable, the script exits silently with zero exit code. - -The script runs C<readelf> utility to get information about specified executable file. So, the -script fails if C<readelf> is not available. Effectively it means the script works only on Linux* OS -(and, probably, Intel(R) Many Integrated Core Architecture). - -=head1 OPTIONS - -=over - -=item Standard Options - -=over - -=item B<--doc> - -=item B<--manual> - -Print full help message and exit. - -=item B<--help> - -Print short help message and exit. - -=item B<--usage> - -Print very short usage message and exit. - -=item B<--verbose> - -Do print informational messages. - -=item B<--version> - -Print program version and exit. - -=item B<--quiet> - -Work quiet, do not print informational messages. - -=back - -=back - -=head1 ARGUMENTS - -=over - -=item I<file> - -A name of executable or shared object to check. Multiple files may be specified. - -=back - -=head1 EXAMPLES - -Check libomp.so library: - - $ check-execstack.pl libomp.so - -=cut - -# end of file # - diff --git a/openmp/runtime/tools/check-execstack.py b/openmp/runtime/tools/check-execstack.py new file mode 100644 index 0000000..9c36bd2 --- /dev/null +++ b/openmp/runtime/tools/check-execstack.py @@ -0,0 +1,65 @@ +#!/usr/bin/env python3 + +# +# //===----------------------------------------------------------------------===// +# // +# // 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 +# // +# //===----------------------------------------------------------------------===// +# + +import argparse +import os +import re +import sys +from libomputils import ScriptError, error, print_error_line, execute_command + + +def is_stack_executable_readelf(library): + """Returns true if stack of library file is executable""" + r = execute_command(["readelf", "-l", "-W", library]) + if r.returncode != 0: + error("{} failed".format(r.command)) + stack_lines = [] + for line in r.stdout.split(os.linesep): + if re.search("STACK", line): + stack_lines.append(line.strip()) + if not stack_lines: + error("{}: Not stack segment found".format(library)) + if len(stack_lines) > 1: + error("{}: More than one stack segment found".format(library)) + h = r"0x[0-9a-fA-F]+" + m = re.search( + r"((GNU_)?STACK)\s+({0})\s+({0})\s+({0})\s+({0})\s+({0})" + " ([R ][W ][E ])".format(h), + stack_lines[0], + ) + if not m: + error("{}: Cannot parse stack segment line".format(library)) + if m: + flags = m.group(8) + if "E" in flags: + return True + return False + + +def main(): + parser = argparse.ArgumentParser( + description="Check library does not have" " executable stack" + ) + parser.add_argument("library", help="The library file to check") + commandArgs = parser.parse_args() + if is_stack_executable_readelf(commandArgs.library): + error("{}: Stack is executable".format(commandArgs.library)) + + +if __name__ == "__main__": + try: + main() + except ScriptError as e: + print_error_line(str(e)) + sys.exit(1) + +# end of file diff --git a/openmp/runtime/tools/check-instruction-set.pl b/openmp/runtime/tools/check-instruction-set.pl deleted file mode 100755 index 6edfb55..0000000 --- a/openmp/runtime/tools/check-instruction-set.pl +++ /dev/null @@ -1,320 +0,0 @@ -#!/usr/bin/env perl - -# -#//===----------------------------------------------------------------------===// -#// -#// 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 -#// -#//===----------------------------------------------------------------------===// -# - -use strict; -use warnings; - -use FindBin; -use lib "$FindBin::Bin/lib"; - -use tools; - -our $VERSION = "0.004"; -my $target_os; -my $target_arch; -my $target_mic_arch; - -my $hex = qr{[0-9a-f]}i; # hex digit. - -# mic-specific details. - -sub bad_mic_fmt($) { - # Before we allowed both elf64-x86-64-freebsd and elf-l1om-freebsd. - # Now the first one is obsolete, only elf64-l1om-freebsd is allowed. - my ( $fmt ) = @_; - if ( 0 ) { - } elsif ( "$target_mic_arch" eq "knf" ) { - return $fmt !~ m{\Aelf64-l1om?\z}; - } elsif ( "$target_mic_arch" eq "knc" ) { - return $fmt !~ m{\Aelf64-k1om?\z}; - } else { - return 1; - }; -}; # sub bad_mic_fmt - -# Undesired instructions for mic: all x87 and some other. -# AC: Since compiler 2010-06-30 x87 instructions are supported, removed the check of x87. -my $mic_bad_re; -sub bad_mic_instr($$) { - my ( $instr, $args ) = @_; - if ( "$target_mic_arch" eq "knc" ) { - # workaround of bad code generation on KNF Linux* OS: - return ( defined( $instr ) and $instr =~ $mic_bad_re ); - } else { - return ( defined( $instr ) and $instr =~ $mic_bad_re or defined( $args ) and $args =~ m{xmm}i ); - } -}; # sub bad_mic_instr - -# lin_32-specific details. - -sub bad_ia32_fmt($) { - my ( $fmt ) = @_; - return $fmt !~ m{\Aelf32-i386\z}; -}; # sub bad_ia32_fmt - -my @sse2 = - qw{ - movapd movupd movhpd movlpd movmskpd movsd - addpd addsd subpd subsd mulpd mulsd divpd divsd sqrtpd sqrtsd maxpd maxsd minpd minsd - andpd andnpd orpd xorpd - cmppd cmpsd comisd ucomisd - shufpd unpckhpd unpcklpd - cvtpd2pi cvttpd2pi cvtpi2pd cvtpd2dq cvttpd2dq cvtdq2pd cvtps2pd cvtpd2ps cvtss2sd cvtsd2ss - cvtsd2si cvttsd2si cvtsi2sd cvtdq2ps cvtps2dq cvttps2dq movdqa movdqu movq2dq movdq2q - pmuludq paddq psubq pshuflw pshufhw pshufd pslldq psrldq punpckhqdq punpcklqdq clflush - lfence mfence maskmovdqu movntpd movntdq movnti - }; -my @sse3 = - qw{ - fisttp lddqu addsubps addsubpd haddps hsubps haddpd hsubpd movshdup movsldup movddup monitor - mwait - }; -my @ssse3 = - qw{ - phaddw phaddsw phaddd phsubw phsubsw phsubd pabsb pabsw pabsd pmaddubsw pmulhrsw pshufb - psignb psignw psignd palignr - }; -my @sse4 = - ( - # SSE4.1 - qw{ - pmulld pmuldq dppd dpps movntdqa blendpd blendps blendvpd blendvps pblendvb pblendw pminuw - pminud pminsb pminsd pmaxuw pmaxud pmaxsb pmaxsd roundps roundpd roundss roundsd extractps - insertps pinsrb pinsrd pinsrq pextrb pextrw pextrd pextrq pmovsxbw pmovzxbw pmovsxbd - pmovzxbd pmovsxwd pmovzxwd pmovsxbq pmovzxbq pmovsxwq pmovzxwq pmovsxdq pmovzxdq mpsadbw - phminposuw ptest pcmpeqq packusdw - }, - # SSE4.2 - qw{ - pcmpestri pcmpestrm pcmpistri pcmpistrm pcmpgtq crc32 popcnt - } - ); - -# Undesired instructions for IA-32 architecture: Pentium 4 (SSE2) and newer. -# TODO: It would be much more reliable to list *allowed* instructions rather than list undesired -# instructions. In such a case the list will be stable and not require update when SSE5 is released. -my @ia32_bad_list = ( @sse2, @sse3, @ssse3, @sse4 ); - -my $ia32_bad_re = qr{@{[ "^(?:" . join( "|", @ia32_bad_list ) . ")" ]}}i; - -sub bad_ia32_instr($$) { - my ( $instr, $args ) = @_; - return ( defined( $instr ) and $instr =~ $ia32_bad_re ); -}; # sub bad_ia32_instr - -sub check_file($;$$) { - - my ( $file, $show_instructions, $max_instructions ) = @_; - my @bulk; - - if ( not defined( $max_instructions ) ) { - $max_instructions = 100; - }; # if - - execute( [ "x86_64-k1om-linux-objdump", "-d", $file ], -stdout => \@bulk ); - - my $n = 0; - my $errors = 0; - my $current_func = ""; # Name of current function. - my $reported_func = ""; # name of last reported function. - foreach my $line ( @bulk ) { - ++ $n; - if ( 0 ) { - } elsif ( $line =~ m{^\s*$} ) { - # Empty line. - # Ignore. - } elsif ( $line =~ m{^In archive (.*?):\s*$} ) { - # In archive libomp.a: - } elsif ( $line =~ m{^(?:.*?):\s*file format (.*?)\s*$} ) { - # libomp.so: file format elf64-x86-64-freebsd - # kmp_ftn_cdecl.o: file format elf64-x86-64 - my $fmt = $1; - if ( bad_fmt( $fmt ) ) { - runtime_error( "Invalid file format: $fmt." ); - }; # if - } elsif ( $line =~ m{^Disassembly of section (.*?):\s*$} ) { - # Disassembly of section .plt: - } elsif ( $line =~ m{^$hex+ <([^>]+)>:\s*$} ) { - # 0000000000017e98 <__kmp_str_format@plt-0x10>: - $current_func = $1; - } elsif ( $line =~ m{^\s*\.{3}\s*$} ) { - } elsif ( $line =~ m{^\s*($hex+):\s+($hex$hex(?: $hex$hex)*)\s+(?:lock\s+|rex[.a-z]*\s+)?([^ ]+)(?:\s+([^#]+?))?\s*(?:#|$)} ) { - # 17e98: ff 35 fa 7d 26 00 pushq 0x267dfa(%rip) # 27fc98 <_GLOBAL_OFFSET_TABLE> - my ( $addr, $dump, $instr, $args ) = ( $1, $2, $3, $4 ); - # Check this is not a bad instruction and xmm registers are not used. - if ( bad_instr( $instr, $args ) ) { - if ( $errors == 0 ) { - warning( "Invalid instructions found in `$file':" ); - }; # if - if ( $current_func ne $reported_func ) { - warning( " $current_func" ); - $reported_func = $current_func; - }; # if - ++ $errors; - if ( $show_instructions ) { - warning( " $line" ); - }; # if - if ( $errors >= $max_instructions ) { - info( "$errors invalid instructions found; scanning stopped." ); - last; - }; # if - }; # if - } else { - runtime_error( "Error parsing objdump output line $n:\n>>>> $line\n" ); - }; # if - }; # foreach $line - - return $errors; - -}; # sub check_file - -# -------------------------------------------------------------------------------------------------- - -# Parse command line. -my $max_instructions; -my $show_instructions; -get_options( - "os=s" => \$target_os, - "arch=s" => \$target_arch, - "mic-arch=s" => \$target_mic_arch, - "max-instructions=i" => \$max_instructions, - "show-instructions!" => \$show_instructions, -); -my $target_platform = $target_os . "_" . $target_arch; -if ( "$target_os" eq "lin" and "$target_mic_arch" eq "knf" ) { - $mic_bad_re = qr{^(?:pause|[slm]fence|scatter|gather|cmpxchg16b|clevict[12])}i; -} else { - $mic_bad_re = qr{^(?:pause|[slm]fence|scatter|gather|cmov|cmpxchg16b|clevict[12])}i; -}; -if ( 0 ) { -} elsif ( $target_platform eq "lin_mic" ) { - *bad_instr = \*bad_mic_instr; - *bad_fmt = \*bad_mic_fmt; -} elsif ( $target_platform eq "lin_32" ) { - *bad_instr = \*bad_ia32_instr; - *bad_fmt = \*bad_ia32_fmt; -} else { - runtime_error( "Only works on lin_32 and lin_mic platforms." ); -}; # if - -# Do the work. -my $rc = 0; -if ( not @ARGV ) { - info( "No arguments specified -- nothing to do." ); -} else { - foreach my $arg ( @ARGV ) { - my $errs = check_file( $arg, $show_instructions, $max_instructions ); - if ( $errs > 0 ) { - $rc = 3; - }; # if - }; # foreach $arg -}; # if - -exit( $rc ); - -__END__ - -=pod - -=head1 NAME - -B<check-instruction-set.pl> -- Make sure binary file does not contain undesired instructions. - -=head1 SYNOPSIS - -B<check-instructions.pl> I<option>... I<file>... - -=head1 OPTIONS - -=over - -=item B<--architecture=>I<arch> - -Specify target architecture. - -=item B<--max-instructions=>I<number> - -Stop scanning if I<number> invalid instructions found. 100 by default. - -=item B<--os=>I<os> - -Specify target OS. - -=item B<-->[B<no->]B<show-instructions> - -Show invalid instructions found in the file. Bu default, instructions are not shown. - -=item Standard Options - -=over - -=item B<--doc> - -=item B<--manual> - -Print full help message and exit. - -=item B<--help> - -Print short help message and exit. - -=item B<--usage> - -Print very short usage message and exit. - -=item B<--verbose> - -Do print informational messages. - -=item B<--version> - -Print program version and exit. - -=item B<--quiet> - -Work quiet, do not print informational messages. - -=back - -=back - -=head1 ARGUMENTS - -=over - -=item I<file> - -File (object file or library, either static or dynamic) to check. - -=back - -=head1 DESCRIPTION - -The script runs F<objdump> utility to get disassembler listing and checks the file does not contain -unwanted instructions. - -Currently the script works only for: - -=over - -=item C<lin_mic> - -Intel(R) Many Integrated Core Architecture target OS. Undesired unstructions are: all x87 instructions and some others. - -=item C<lin_32> - -Undesired instructions are instructions not valid for Pentium 3 processor (SSE2 and newer). - -=back - -=cut - diff --git a/openmp/runtime/tools/generate-def.pl b/openmp/runtime/tools/generate-def.pl deleted file mode 100755 index e062f48..0000000 --- a/openmp/runtime/tools/generate-def.pl +++ /dev/null @@ -1,331 +0,0 @@ -#!/usr/bin/env perl - -# -#//===----------------------------------------------------------------------===// -#// -#// 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 -#// -#//===----------------------------------------------------------------------===// -# - -# Some pragmas. -use strict; # Restrict unsafe constructs. -use warnings; # Enable all warnings. - -use FindBin; -use lib "$FindBin::Bin/lib"; - -use tools; - -our $VERSION = "0.004"; - -# -# Subroutines. -# - -sub parse_input($\%) { - - my ( $input, $defs ) = @_; - my @bulk = read_file( $input ); - my %entries; - my %ordinals; - my @dirs; - my $value = 1; - - my $error = - sub { - my ( $msg, $l, $line ) = @_; - runtime_error( - "Error parsing file \"$input\" line $l:\n" . - " $line" . - ( $msg ? $msg . "\n" : () ) - ); - }; # sub - - my $n = 0; # Line number. - foreach my $line ( @bulk ) { - ++ $n; - if ( 0 ) { - } elsif ( $line =~ m{^\s*(?:#|\n)} ) { - # Empty line or comment. Skip it. - } elsif ( $line =~ m{^\s*%} ) { - # A directive. - if ( 0 ) { - } elsif ( $line =~ m{^\s*%\s*if(n)?def\s+([A-Za-z0-9_]+)\s*(?:#|\n)} ) { - my ( $negation, $name ) = ( $1, $2 ); - my $dir = { n => $n, line => $line, name => $name, value => $value }; - push( @dirs, $dir ); - $value = ( $value and ( $negation xor $defs->{ $name } ) ); - } elsif ( $line =~ m{^\s*%\s*endif\s*(?:#|\n)} ) { - if ( not @dirs ) { - $error->( "Orphan %endif directive.", $n, $line ); - }; # if - my $dir = pop( @dirs ); - $value = $dir->{ value }; - } else { - $error->( "Bad directive.", $n, $line ); - }; # if - } elsif ( $line =~ m{^\s*(-)?\s*([A-Za-z0-9_]+)(?:\s+(\d+|DATA))?\s*(?:#|\n)} ) { - my ( $obsolete, $entry, $ordinal ) = ( $1, $2, $3 ); - if ( $value ) { - if ( exists( $entries{ $entry } ) ) { - $error->( "Entry \"$entry\" has already been specified.", $n, $line ); - }; # if - $entries{ $entry } = { ordinal => $ordinal, obsolete => defined( $obsolete ) }; - if ( defined( $ordinal ) and $ordinal ne "DATA" ) { - if ( $ordinal >= 1000 and $entry =~ m{\A[ok]mp_} ) { - $error->( "Ordinal of user-callable entry must be < 1000", $n, $line ); - }; # if - if ( $ordinal >= 1000 and $ordinal < 2000 ) { - $error->( "Ordinals between 1000 and 1999 are reserved.", $n, $line ); - }; # if - if ( exists( $ordinals{ $ordinal } ) ) { - $error->( "Ordinal $ordinal has already been used.", $n, $line ); - }; # if - $ordinals{ $ordinal } = $entry; - }; # if - }; # if - } else { - $error->( "", $n, $line ); - }; # if - }; # foreach - - if ( @dirs ) { - my $dir = pop( @dirs ); - $error->( "Unterminated %if directive.", $dir->{ n }, $dir->{ line } ); - }; # while - - return %entries; - -}; # sub parse_input - -sub process(\%) { - - my ( $entries ) = @_; - - foreach my $entry ( keys( %$entries ) ) { - if ( not $entries->{ $entry }->{ obsolete } ) { - my $ordinal = $entries->{ $entry }->{ ordinal }; - # omp_alloc and omp_free are C/C++ only functions, skip "1000+ordinal" for them - if ( $entry =~ m{\A[ok]mp_} and $entry ne "omp_alloc" and $entry ne "omp_free" and - $entry ne "omp_calloc" and $entry ne "omp_realloc" and - $entry ne "omp_aligned_alloc" and $entry ne "omp_aligned_calloc" ) { - if ( not defined( $ordinal ) ) { - runtime_error( - "Bad entry \"$entry\": ordinal number is not specified." - ); - }; # if - if ( $ordinal ne "DATA" ) { - $entries->{ uc( $entry ) } = { ordinal => 1000 + $ordinal }; - } - }; # if - }; # if - }; # foreach - - return %$entries; - -}; # sub process - -sub generate_output(\%$\%) { - - my ( $entries, $output, $defs ) = @_; - my $lib = %$defs {'NAME'}; - my $bulk; - - if (defined($lib)) { - $bulk = sprintf("NAME %s\n", $lib); - } - $bulk .= sprintf("EXPORTS\n"); - foreach my $entry ( sort( keys( %$entries ) ) ) { - if ( not $entries->{ $entry }->{ obsolete } ) { - $bulk .= sprintf( " %-40s ", $entry ); - my $ordinal = $entries->{ $entry }->{ ordinal }; - if ( defined( $ordinal ) ) { - if ( $ordinal eq "DATA" ) { - $bulk .= "DATA"; - } else { - if (not %$defs {'NOORDINALS'}) { - $bulk .= "\@" . $ordinal; - } - }; # if - }; # if - $bulk .= "\n"; - }; # if - }; # foreach - if ( defined( $output ) ) { - write_file( $output, \$bulk ); - } else { - print( $bulk ); - }; # if - -}; # sub generate_output - -# -# Parse command line. -# - -my $input; # The name of input file. -my $output; # The name of output file. -my %defs; - -get_options( - "output=s" => \$output, - "D|define=s" => - sub { - my ( $opt_name, $opt_value ) = @_; - my ( $def_name, $def_value ); - if ( $opt_value =~ m{\A(.*?)=(.*)\z} ) { - ( $def_name, $def_value ) = ( $1, $2 ); - } else { - ( $def_name, $def_value ) = ( $opt_value, 1 ); - }; # if - $defs{ $def_name } = $def_value; - }, -); - -if ( @ARGV == 0 ) { - cmdline_error( "Not enough arguments." ); -}; # if -if ( @ARGV > 1 ) { - cmdline_error( "Too many arguments." ); -}; # if -$input = shift( @ARGV ); - -# -# Work. -# - -my %data = parse_input( $input, %defs ); -%data = process( %data ); -generate_output( %data, $output, %defs ); -exit( 0 ); - -__END__ - -# -# Embedded documentation. -# - -=pod - -=head1 NAME - -B<generate-def.pl> -- Generate def file for OpenMP RTL. - -=head1 SYNOPSIS - -B<generate-def.pl> I<OPTION>... I<file> - -=head1 OPTIONS - -=over - -=item B<--define=>I<name>[=I<value>] - -=item B<-D> I<name>[=I<value>] - -Define specified name. If I<value> is omitted, I<name> is defined to 1. If I<value> is 0 or empty, -name is B<not> defined. - -=item B<--output=>I<file> - -=item B<-o> I<file> - -Specify output file name. If option is not present, result is printed to stdout. - -=item B<--doc> - -=item B<--manual> - -Print full help message and exit. - -=item B<--help> - -Print short help message and exit. - -=item B<--usage> - -Print very short usage message and exit. - -=item B<--verbose> - -Do print informational messages. - -=item B<--version> - -Print version and exit. - -=item B<--quiet> - -Work quiet, do not print informational messages. - -=back - -=head1 ARGUMENTS - -=over - -=item I<file> - -A name of input file. - -=back - -=head1 DESCRIPTION - -The script reads input file, process conditional directives, checks content for consistency, and -generates output file suitable for linker. - -=head2 Input File Format - -=over - -=item Comments - - # It's a comment. - -Comments start with C<#> symbol and continue to the end of line. - -=item Conditional Directives - - %ifdef name - %ifndef name - %endif - -A part of file surrounded by C<%ifdef I<name>> and C<%endif> directives is a conditional part -- it -has effect only if I<name> is defined in the command line by B<--define> option. C<%ifndef> is a -negated version of C<%ifdef> -- conditional part has an effect only if I<name> is B<not> defined. - -Conditional parts may be nested. - -=item Export Definitions - - symbol - symbol ordinal - symbol DATA - -Symbols starting with C<omp_> or C<kmp_> must have ordinal specified. They are subjects for special -processing: each symbol generates two output lines: original one and upper case version. The ordinal -number of the second is original ordinal increased by 1000. - -=item Obsolete Symbols - - - symbol - - symbol ordinal - - symbol DATA - -Obsolete symbols look like export definitions prefixed with minus sign. Obsolete symbols do not -affect the output, but obsolete symbols and their ordinals cannot be (re)used in export definitions. - -=back - -=head1 EXAMPLES - - $ generate-def.pl -D stub -D USE_TCHECK=0 -o libguide.def dllexport - -=cut - -# end of file # - diff --git a/openmp/runtime/tools/generate-def.py b/openmp/runtime/tools/generate-def.py new file mode 100644 index 0000000..6781fe7 --- /dev/null +++ b/openmp/runtime/tools/generate-def.py @@ -0,0 +1,244 @@ +#!/usr/bin/env python3 + +# +# //===----------------------------------------------------------------------===// +# // +# // 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 +# // +# //===----------------------------------------------------------------------===// +# + +import argparse +import os +import re +import sys +from libomputils import error, ScriptError, print_error_line + + +class DllExports(object): + def __init__(self): + self.filename = None + self.exports = {} + self.ordinals = set([]) + + def add_uppercase_entries(self): + # Ignored entries are C/C++ only functions + ignores = [ + "omp_alloc", + "omp_free", + "omp_calloc", + "omp_realloc", + "omp_aligned_alloc", + "omp_aligned_calloc", + ] + keys = list(self.exports.keys()) + for entry in keys: + info = self.exports[entry] + if info["obsolete"] or info["is_data"] or entry in ignores: + continue + if entry.startswith("omp_") or entry.startswith("kmp_"): + newentry = entry.upper() + if info["ordinal"]: + newordinal = info["ordinal"] + 1000 + else: + newordinal = None + self.exports[newentry] = { + "obsolete": False, + "is_data": False, + "ordinal": newordinal, + } + + @staticmethod + def create(inputFile, defs=None): + """Creates DllExports object from inputFile""" + dllexports = DllExports() + dllexports.filename = inputFile + # Create a (possibly empty) list of definitions + if defs: + definitions = set(list(defs)) + else: + definitions = set([]) + # Different kinds of lines to parse + kw = r"[a-zA-Z_][a-zA-Z0-9_]*" + ifndef = re.compile(r"%ifndef\s+({})".format(kw)) + ifdef = re.compile(r"%ifdef\s+({})".format(kw)) + endif = re.compile(r"%endif") + export = re.compile(r"(-)?\s*({0})(=({0}))?(\s+([0-9]+|DATA))?".format(kw)) + + def err(fil, num, msg): + error("{}: {}: {}".format(fil, num, msg)) + + defs_stack = [] + with open(inputFile) as f: + for lineNumber, line in enumerate(f): + line = line.strip() + # Skip empty lines + if not line: + continue + # Skip comment lines + if line.startswith("#"): + continue + # Encountered %ifndef DEF + m = ifndef.search(line) + if m: + defs_stack.append(m.group(1) not in definitions) + continue + # Encountered %ifdef DEF + m = ifdef.search(line) + if m: + defs_stack.append(m.group(1) in definitions) + continue + # Encountered %endif + m = endif.search(line) + if m: + if not defs_stack: + err(inputFile, lineNumber, "orphan %endif directive") + defs_stack.pop() + continue + # Skip lines when not all %ifdef or %ifndef are true + if defs_stack and not all(defs_stack): + continue + # Encountered an export line + m = export.search(line) + if m: + obsolete = m.group(1) is not None + entry = m.group(2) + rename = m.group(4) + ordinal = m.group(6) + if entry in dllexports.exports: + err( + inputFile, + lineNumber, + "already specified entry: {}".format(entry), + ) + if rename: + entry += "={}".format(rename) + # No ordinal number nor DATA specified + if not ordinal: + ordinal = None + is_data = False + # DATA ordinal + elif ordinal == "DATA": + ordinal = None + is_data = True + # Regular ordinal number + else: + is_data = False + try: + ordinal = int(ordinal) + except: + err( + inputFile, + lineNumber, + "Bad ordinal value: {}".format(ordinal), + ) + if ordinal >= 1000 and ( + entry.startswith("omp_") or entry.startswith("kmp_") + ): + err( + inputFile, + lineNumber, + "Ordinal of user-callable entry must be < 1000", + ) + if ordinal >= 1000 and ordinal < 2000: + err( + inputFile, + lineNumber, + "Ordinals between 1000 and 1999 are reserved.", + ) + if ordinal in dllexports.ordinals: + err( + inputFile, + lineNumber, + "Ordinal {} has already been used.".format(ordinal), + ) + dllexports.exports[entry] = { + "ordinal": ordinal, + "obsolete": obsolete, + "is_data": is_data, + } + continue + err( + inputFile, + lineNumber, + 'Cannot parse line:{}"{}"'.format(os.linesep, line), + ) + if defs_stack: + error("syntax error: Unterminated %if directive") + return dllexports + + +def generate_def(dllexports, f, no_ordinals=False, name=None): + """Using dllexports data, write the exports to file, f""" + if name: + f.write("LIBRARY {}\n".format(name)) + f.write("EXPORTS\n") + for entry in sorted(list(dllexports.exports.keys())): + info = dllexports.exports[entry] + if info["obsolete"]: + continue + f.write(" {:<40} ".format(entry)) + if info["is_data"]: + f.write("DATA\n") + elif no_ordinals or not info["ordinal"]: + f.write("\n") + else: + f.write("@{}\n".format(info["ordinal"])) + + +def main(): + parser = argparse.ArgumentParser( + description="Reads input file of dllexports, processes conditional" + " directives, checks content for consistency, and generates" + " output file suitable for linker" + ) + parser.add_argument( + "-D", + metavar="DEF", + action="append", + dest="defs", + help="Define a variable. Can specify" " this more than once.", + ) + parser.add_argument( + "--no-ordinals", + action="store_true", + help="Specify that no ordinal numbers should be generated", + ) + parser.add_argument( + "-n", + "--name", + dest="name", + help="Specify library name for def file LIBRARY statement", + ) + parser.add_argument( + "-o", + "--output", + metavar="FILE", + dest="output", + help="Specify output file name. If not specified," " output is sent to stdout", + ) + parser.add_argument("dllexports", help="The input file describing dllexports") + commandArgs = parser.parse_args() + defs = set([]) + if commandArgs.defs: + defs = set(commandArgs.defs) + dllexports = DllExports.create(commandArgs.dllexports, defs) + dllexports.add_uppercase_entries() + try: + output = open(commandArgs.output, "w") if commandArgs.output else sys.stdout + generate_def(dllexports, output, commandArgs.no_ordinals, commandArgs.name) + finally: + if commandArgs.output: + output.close() + + +if __name__ == "__main__": + try: + main() + except ScriptError as e: + print_error_line(str(e)) + sys.exit(1) + +# end of file diff --git a/openmp/runtime/tools/lib/Build.pm b/openmp/runtime/tools/lib/Build.pm deleted file mode 100644 index a24cf57..0000000 --- a/openmp/runtime/tools/lib/Build.pm +++ /dev/null @@ -1,263 +0,0 @@ -# -#//===----------------------------------------------------------------------===// -#// -#// 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 Build; - -use strict; -use warnings; - -use Cwd qw{}; - -use LibOMP; -use tools; -use Uname; -use Platform ":vars"; - -my $host = Uname::host_name(); -my $root = $ENV{ LIBOMP_WORK }; -my $tmp = $ENV{ LIBOMP_TMP }; -my $out = $ENV{ LIBOMP_EXPORTS }; - -my @jobs; -our $start = time(); - -# -------------------------------------------------------------------------------------------------- -# Helper functions. -# -------------------------------------------------------------------------------------------------- - -# tstr -- Time string. Returns string "yyyy-dd-mm hh:mm:ss UTC". -sub tstr(;$) { - my ( $time ) = @_; - if ( not defined( $time ) ) { - $time = time(); - }; # if - my ( $sec, $min, $hour, $day, $month, $year ) = gmtime( $time ); - $month += 1; - $year += 1900; - my $str = sprintf( "%04d-%02d-%02d %02d:%02d:%02d UTC", $year, $month, $day, $hour, $min, $sec ); - return $str; -}; # sub tstr - -# dstr -- Duration string. Returns string "hh:mm:ss". -sub dstr($) { - # Get time in seconds and format it as time in hours, minutes, seconds. - my ( $sec ) = @_; - my ( $h, $m, $s ); - $h = int( $sec / 3600 ); - $sec = $sec - $h * 3600; - $m = int( $sec / 60 ); - $sec = $sec - $m * 60; - $s = int( $sec ); - $sec = $sec - $s; - return sprintf( "%02d:%02d:%02d", $h, $m, $s ); -}; # sub dstr - -# rstr -- Result string. -sub rstr($) { - my ( $rc ) = @_; - return ( $rc == 0 ? "+++ Success +++" : "--- Failure ---" ); -}; # sub rstr - -sub shorter($;$) { - # Return shorter variant of path -- either absolute or relative. - my ( $path, $base ) = @_; - my $abs = abs_path( $path ); - my $rel = rel_path( $path, $base ); - if ( $rel eq "" ) { - $rel = "."; - }; # if - $path = ( length( $rel ) < length( $abs ) ? $rel : $abs ); - if ( $target_os eq "win" ) { - $path =~ s{\\}{/}g; - }; # if - return $path; -}; # sub shorter - -sub tee($$) { - - my ( $action, $file ) = @_; - my $pid = 0; - - my $save_stdout = Symbol::gensym(); - my $save_stderr = Symbol::gensym(); - - # --- redirect stdout --- - STDOUT->flush(); - # Save stdout in $save_stdout. - open( $save_stdout, ">&" . STDOUT->fileno() ) - or die( "Cannot dup filehandle: $!; stopped" ); - # Redirect stdout to tee or to file. - if ( $tools::verbose ) { - $pid = open( STDOUT, "| tee -a \"$file\"" ) - or die "Cannot open pipe to \"tee\": $!; stopped"; - } else { - open( STDOUT, ">>$file" ) - or die "Cannot open file \"$file\" for writing: $!; stopped"; - }; # if - - # --- redirect stderr --- - STDERR->flush(); - # Save stderr in $save_stderr. - open( $save_stderr, ">&" . STDERR->fileno() ) - or die( "Cannot dup filehandle: $!; stopped" ); - # Redirect stderr to stdout. - open( STDERR, ">&" . STDOUT->fileno() ) - or die( "Cannot dup filehandle: $!; stopped" ); - - # Perform actions. - $action->(); - - # --- restore stderr --- - STDERR->flush(); - # Restore stderr from $save_stderr. - open( STDERR, ">&" . $save_stderr->fileno() ) - or die( "Cannot dup filehandle: $!; stopped" ); - # Close $save_stderr. - $save_stderr->close() or die ( "Cannot close filehandle: $!; stopped" ); - - # --- restore stdout --- - STDOUT->flush(); - # Restore stdout from $save_stdout. - open( STDOUT, ">&" . $save_stdout->fileno() ) - or die( "Cannot dup filehandle: $!; stopped" ); - # Close $save_stdout. - $save_stdout->close() or die ( "Cannot close filehandle: $!; stopped" ); - - # Wait for the child tee process, otherwise output of make and build.pl interleaves. - if ( $pid != 0 ) { - waitpid( $pid, 0 ); - }; # if - -}; # sub tee - -sub log_it($$@) { - my ( $title, $format, @args ) = @_; - my $message = sprintf( $format, @args ); - my $progress = cat_file( $tmp, sprintf( "%s-%s.log", $target_platform, Uname::host_name() ) ); - if ( $title ne "" and $message ne "" ) { - my $line = sprintf( "%-15s : %s\n", $title, $message ); - info( $line ); - write_file( $progress, tstr() . ": " . $line, -append => 1 ); - } else { - write_file( $progress, "\n", -append => 1 ); - }; # if -}; # sub log_it - -sub progress($$@) { - my ( $title, $format, @args ) = @_; - log_it( $title, $format, @args ); -}; # sub progress - -sub summary() { - my $total = @jobs; - my $success = 0; - my $finish = time(); - foreach my $job ( @jobs ) { - my ( $build_dir, $rc ) = ( $job->{ build_dir }, $job->{ rc } ); - progress( rstr( $rc ), "%s", $build_dir ); - if ( $rc == 0 ) { - ++ $success; - }; # if - }; # foreach $job - my $failure = $total - $success; - progress( "Successes", "%3d of %3d", $success, $total ); - progress( "Failures", "%3d of %3d", $failure, $total ); - progress( "Time elapsed", " %s", dstr( $finish - $start ) ); - progress( "Overall result", "%s", rstr( $failure ) ); - return $failure; -}; # sub summary - -# -------------------------------------------------------------------------------------------------- -# Worker functions. -# -------------------------------------------------------------------------------------------------- - -sub init() { - make_dir( $tmp ); -}; # sub init - -sub clean(@) { - # Clean directories. - my ( @dirs ) = @_; - my $exit = 0; - # Mimisc makefile -- print a command. - print( "rm -f -r " . join( " ", map( shorter( $_ ) . "/*", @dirs ) ) . "\n" ); - $exit = - execute( - [ $^X, cat_file( $ENV{ LIBOMP_WORK }, "tools", "clean-dir.pl" ), @dirs ], - -ignore_status => 1, - ( $tools::verbose ? () : ( -stdout => undef, -stderr => "" ) ), - ); - return $exit; -}; # sub clean - -sub make($$$) { - # Change dir to build one and run make. - my ( $job, $clean, $marker ) = @_; - my $dir = $job->{ build_dir }; - my $makefile = $job->{ makefile }; - my $args = $job->{ make_args }; - my $cwd = Cwd::cwd(); - my $width = -10; - - my $exit; - $dir = cat_dir( $tmp, $dir ); - make_dir( $dir ); - change_dir( $dir ); - - my $actions = - sub { - my $start = time(); - $makefile = shorter( $makefile ); - print( "-" x 79, "\n" ); - printf( "%${width}s: %s\n", "Started", tstr( $start ) ); - printf( "%${width}s: %s\n", "Root dir", $root ); - printf( "%${width}s: %s\n", "Build dir", shorter( $dir, $root ) ); - printf( "%${width}s: %s\n", "Makefile", $makefile ); - print( "-" x 79, "\n" ); - { - # Use shorter LIBOMP_WORK to have shorter command lines. - # Note: Some tools may not work if current dir is changed. - local $ENV{ LIBOMP_WORK } = shorter( $ENV{ LIBOMP_WORK } ); - $exit = - execute( - [ - "make", - "-r", - "-f", $makefile, - "arch=" . $target_arch, - "marker=$marker", - @$args - ], - -ignore_status => 1 - ); - if ( $clean and $exit == 0 ) { - $exit = clean( $dir ); - }; # if - } - my $finish = time(); - print( "-" x 79, "\n" ); - printf( "%${width}s: %s\n", "Finished", tstr( $finish ) ); - printf( "%${width}s: %s\n", "Elapsed", dstr( $finish - $start ) ); - printf( "%${width}s: %s\n", "Result", rstr( $exit ) ); - print( "-" x 79, "\n" ); - print( "\n" ); - }; # sub - tee( $actions, "build.log" ); - - change_dir( $cwd ); - - # Save completed job to be able print summary later. - $job->{ rc } = $exit; - push( @jobs, $job ); - - return $exit; - -}; # sub make - -1; diff --git a/openmp/runtime/tools/lib/LibOMP.pm b/openmp/runtime/tools/lib/LibOMP.pm deleted file mode 100644 index cff7e4a..0000000 --- a/openmp/runtime/tools/lib/LibOMP.pm +++ /dev/null @@ -1,84 +0,0 @@ -# -#//===----------------------------------------------------------------------===// -#// -#// 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 LibOMP; - -use strict; -use warnings; - -use tools; - -sub empty($) { - my ( $var ) = @_; - return ((not exists($ENV{$var})) or (not defined($ENV{$var})) or ($ENV{$var} eq "")); -}; # sub empty - -my ( $base, $out, $tmp ); -if ( empty( "LIBOMP_WORK" ) ) { - # $FindBin::Bin is not used intentionally because it gives real path. I want to use absolute, - # but not real one (real path does not contain symlinks while absolute path may contain - # symlinks). - $base = get_dir( get_dir( abs_path( $0 ) ) ); -} else { - $base = abs_path( $ENV{ LIBOMP_WORK } ); -}; # if - -if ( empty( "LIBOMP_EXPORTS" ) ) { - $out = cat_dir( $base, "exports" ); -} else { - $out = abs_path( $ENV{ LIBOMP_EXPORTS } ); -}; # if - -if ( empty( "LIBOMP_TMP" ) ) { - $tmp = cat_dir( $base, "tmp" ); -} else { - $tmp = abs_path( $ENV{ LIBOMP_TMP } ); -}; # if - -$ENV{ LIBOMP_WORK } = $base; -$ENV{ LIBOMP_EXPORTS } = $out; -$ENV{ LIBOMP_TMP } = $tmp; - -return 1; - -__END__ - -=pod - -=head1 NAME - -B<LibOMP.pm> -- - -=head1 SYNOPSIS - - use FindBin; - use lib "$FindBin::Bin/lib"; - use LibOMP; - - $ENV{ LIBOMP_WORK } - $ENV{ LIBOMP_TMP } - $ENV{ LIBOMP_EXPORTS } - -=head1 DESCRIPTION - -The module checks C<LIBOMP_WORK>, C<LIBOMP_EXPORTS>, and C<LIBOMP_TMP> environments variables. -If a variable set, the module makes sure it is absolute. If a variable does not exist, the module -sets it to default value. - -Default value for C<LIBOMP_EXPORTS> is C<$LIBOMP_WORK/exports>, for C<LIBOMP_TMP> -- -C<$LIBOMP_WORK/tmp>. - -Value for C<LIBOMP_WORK> is guessed. The module assumes the script (which uses the module) is -located in C<tools/> directory of libomp directory tree, and uses path of the script to calculate -C<LIBOMP_WORK>, - -=cut - -# end of file # - diff --git a/openmp/runtime/tools/lib/Platform.pm b/openmp/runtime/tools/lib/Platform.pm deleted file mode 100644 index 36847d5..0000000 --- a/openmp/runtime/tools/lib/Platform.pm +++ /dev/null @@ -1,502 +0,0 @@ -# -# This is not a runnable script, it is a Perl module, a collection of variables, subroutines, etc. -# to be used in Perl scripts. -# -# To get help about exported variables and subroutines, execute the following command: -# -# perldoc Platform.pm -# -# or see POD (Plain Old Documentation) imbedded 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 Platform; - -use strict; -use warnings; - -use base "Exporter"; - -use Uname; - -my @vars; - -BEGIN { - @vars = qw{ $host_arch $host_os $host_platform $target_arch $target_mic_arch $target_os $target_platform }; -} - -our $VERSION = "0.014"; -our @EXPORT = qw{}; -our @EXPORT_OK = ( qw{ canon_arch canon_os canon_mic_arch legal_arch arch_opt }, @vars ); -our %EXPORT_TAGS = ( all => [ @EXPORT_OK ], vars => \@vars ); - -# Canonize architecture name. -sub canon_arch($) { - my ( $arch ) = @_; - if ( defined( $arch ) ) { - if ( $arch =~ m{\A\s*(?:32|IA-?32|IA-?32 architecture|i[3456]86|x86)\s*\z}i ) { - $arch = "32"; - } elsif ( $arch =~ m{\A\s*(?:48|(?:ia)?32e|Intel\s*64|Intel\(R\)\s*64|x86[_-]64|x64|AMD64)\s*\z}i ) { - $arch = "32e"; - } elsif ( $arch =~ m{\Aarm(?:v7\D*)?\z} ) { - $arch = "arm"; - } elsif ( $arch =~ m{\Appc64le} ) { - $arch = "ppc64le"; - } elsif ( $arch =~ m{\Appc64} ) { - $arch = "ppc64"; - } elsif ( $arch =~ m{\Aaarch64_32} ) { - $arch = "aarch64_32"; - } elsif ( $arch =~ m{\Aaarch64} ) { - $arch = "aarch64"; - } elsif ( $arch =~ m{\Amic} ) { - $arch = "mic"; - } elsif ( $arch =~ m{\Amips64} ) { - $arch = "mips64"; - } elsif ( $arch =~ m{\Amips} ) { - $arch = "mips"; - } elsif ( $arch =~ m{\Ariscv64} ) { - $arch = "riscv64"; - } elsif ( $arch =~ m{\Aloongarch64} ) { - $arch = "loongarch64"; - } elsif ( $arch =~ m{\As390x} ) { - $arch = "s390x"; - } else { - $arch = undef; - }; # if - }; # if - return $arch; -}; # sub canon_arch - -# Canonize Intel(R) Many Integrated Core Architecture name. -sub canon_mic_arch($) { - my ( $mic_arch ) = @_; - if ( defined( $mic_arch ) ) { - if ( $mic_arch =~ m{\Aknf} ) { - $mic_arch = "knf"; - } elsif ( $mic_arch =~ m{\Aknc}) { - $mic_arch = "knc"; - } elsif ( $mic_arch =~ m{\Aknl} ) { - $mic_arch = "knl"; - } else { - $mic_arch = undef; - }; # if - }; # if - return $mic_arch; -}; # sub canon_mic_arch - -{ # Return legal approved architecture name. - my %legal = ( - "32" => "IA-32 architecture", - "32e" => "Intel(R) 64", - "arm" => "ARM", - "aarch64" => "AArch64", - "aarch64_32" => "AArch64_32", - "loongarch64" => "LoongArch64", - "mic" => "Intel(R) Many Integrated Core Architecture", - "mips" => "MIPS", - "mips64" => "MIPS64", - "riscv64" => "RISC-V (64-bit)", - ); - - sub legal_arch($) { - my ( $arch ) = @_; - $arch = canon_arch( $arch ); - if ( defined( $arch ) ) { - $arch = $legal{ $arch }; - }; # if - return $arch; - }; # sub legal_arch -} - -{ # Return architecture name suitable for Intel compiler setup scripts. - my %option = ( - "32" => "ia32", - "32e" => "intel64", - "64" => "ia64", - "arm" => "arm", - "aarch64" => "aarch", - "mic" => "intel64", - "mips" => "mips", - "mips64" => "MIPS64", - ); - - sub arch_opt($) { - my ( $arch ) = @_; - $arch = canon_arch( $arch ); - if ( defined( $arch ) ) { - $arch = $option{ $arch }; - }; # if - return $arch; - }; # sub arch_opt -} - -# Canonize OS name. -sub canon_os($) { - my ( $os ) = @_; - if ( defined( $os ) ) { - if ( $os =~ m{\A\s*(?:Linux|lin|l)\s*\z}i ) { - $os = "lin"; - } elsif ( $os =~ m{\A\s*(?:Mac(?:\s*OS(?:\s*X)?)?|mac|m|Darwin)\s*\z}i ) { - $os = "mac"; - } elsif ( $os =~ m{\A\s*(?:Win(?:dows)?(?:(?:_|\s*)?(?:NT|XP|95|98|2003))?|w)\s*\z}i ) { - $os = "win"; - } else { - $os = undef; - }; # if - }; # if - return $os; -}; # sub canon_os - -my ( $_host_os, $_host_arch, $_target_os, $_target_arch, $_target_mic_arch, $_default_mic_arch); - -# Set the default mic-arch value. -$_default_mic_arch = "knc"; - -sub set_target_arch($) { - my ( $arch ) = canon_arch( $_[ 0 ] ); - if ( defined( $arch ) ) { - $_target_arch = $arch; - $ENV{ LIBOMP_ARCH } = $arch; - }; # if - return $arch; -}; # sub set_target_arch - -sub set_target_mic_arch($) { - my ( $mic_arch ) = canon_mic_arch( $_[ 0 ] ); - if ( defined( $mic_arch ) ) { - $_target_mic_arch = $mic_arch; - $ENV{ LIBOMP_MIC_ARCH } = $mic_arch; - }; # if - return $mic_arch; -}; # sub set_target_mic_arch - -sub set_target_os($) { - my ( $os ) = canon_os( $_[ 0 ] ); - if ( defined( $os ) ) { - $_target_os = $os; - $ENV{ LIBOMP_OS } = $os; - }; # if - return $os; -}; # sub set_target_os - -sub target_options() { - my @options = ( - "target-os|os=s" => - sub { - set_target_os( $_[ 1 ] ) or - die "Bad value of --target-os option: \"$_[ 1 ]\"\n"; - }, - "target-architecture|target-arch|architecture|arch=s" => - sub { - set_target_arch( $_[ 1 ] ) or - die "Bad value of --target-architecture option: \"$_[ 1 ]\"\n"; - }, - "target-mic-architecture|target-mic-arch|mic-architecture|mic-arch=s" => - sub { - set_target_mic_arch( $_[ 1 ] ) or - die "Bad value of --target-mic-architecture option: \"$_[ 1 ]\"\n"; - }, - ); - return @options; -}; # sub target_options - -# Detect host arch. -{ - my $hardware_platform = Uname::hardware_platform(); - if ( 0 ) { - } elsif ( $hardware_platform eq "i386" ) { - $_host_arch = "32"; - } elsif ( $hardware_platform eq "ia64" ) { - $_host_arch = "64"; - } elsif ( $hardware_platform eq "x86_64" ) { - $_host_arch = "32e"; - } elsif ( $hardware_platform eq "arm" ) { - $_host_arch = "arm"; - } elsif ( $hardware_platform eq "ppc64le" ) { - $_host_arch = "ppc64le"; - } elsif ( $hardware_platform eq "ppc64" ) { - $_host_arch = "ppc64"; - } elsif ( $hardware_platform eq "aarch64_32" ) { - $_host_arch = "aarch64_32"; - } elsif ( $hardware_platform eq "aarch64" ) { - $_host_arch = "aarch64"; - } elsif ( $hardware_platform eq "mips64" ) { - $_host_arch = "mips64"; - } elsif ( $hardware_platform eq "mips" ) { - $_host_arch = "mips"; - } elsif ( $hardware_platform eq "riscv64" ) { - $_host_arch = "riscv64"; - } elsif ( $hardware_platform eq "loongarch64" ) { - $_host_arch = "loongarch64"; - } elsif ( $hardware_platform eq "s390x" ) { - $_host_arch = "s390x"; - } else { - die "Unsupported host hardware platform: \"$hardware_platform\"; stopped"; - }; # if -} - -# Detect host OS. -{ - my $operating_system = Uname::operating_system(); - if ( 0 ) { - } elsif ( $operating_system eq "GNU/Linux" ) { - $_host_os = "lin"; - } elsif ( $operating_system eq "FreeBSD" ) { - # Host OS resembles Linux. - $_host_os = "lin"; - } elsif ( $operating_system eq "NetBSD" ) { - # Host OS resembles Linux. - $_host_os = "lin"; - } elsif ( $operating_system eq "Darwin" ) { - $_host_os = "mac"; - } elsif ( $operating_system eq "MS Windows" ) { - $_host_os = "win"; - } else { - die "Unsupported host operating system: \"$operating_system\"; stopped"; - }; # if -} - -# Detect target arch. -if ( defined( $ENV{ LIBOMP_ARCH } ) ) { - # Use arch specified in LIBOMP_ARCH. - $_target_arch = canon_arch( $ENV{ LIBOMP_ARCH } ); - if ( not defined( $_target_arch ) ) { - die "Unknown architecture specified in LIBOMP_ARCH environment variable: \"$ENV{ LIBOMP_ARCH }\""; - }; # if -} else { - # Otherwise use host architecture. - $_target_arch = $_host_arch; -}; # if -$ENV{ LIBOMP_ARCH } = $_target_arch; - -# Detect target Intel(R) Many Integrated Core Architecture. -if ( defined( $ENV{ LIBOMP_MIC_ARCH } ) ) { - # Use mic arch specified in LIBOMP_MIC_ARCH. - $_target_mic_arch = canon_mic_arch( $ENV{ LIBOMP_MIC_ARCH } ); - if ( not defined( $_target_mic_arch ) ) { - die "Unknown architecture specified in LIBOMP_MIC_ARCH environment variable: \"$ENV{ LIBOMP_MIC_ARCH }\""; - }; # if -} else { - # Otherwise use default Intel(R) Many Integrated Core Architecture. - $_target_mic_arch = $_default_mic_arch; -}; # if -$ENV{ LIBOMP_MIC_ARCH } = $_target_mic_arch; - -# Detect target OS. -if ( defined( $ENV{ LIBOMP_OS } ) ) { - # Use OS specified in LIBOMP_OS. - $_target_os = canon_os( $ENV{ LIBOMP_OS } ); - if ( not defined( $_target_os ) ) { - die "Unknown OS specified in LIBOMP_OS environment variable: \"$ENV{ LIBOMP_OS }\""; - }; # if -} else { - # Otherwise use host OS. - $_target_os = $_host_os; -}; # if -$ENV{ LIBOMP_OS } = $_target_os; - -use vars @vars; - -tie( $host_arch, "Platform::host_arch" ); -tie( $host_os, "Platform::host_os" ); -tie( $host_platform, "Platform::host_platform" ); -tie( $target_arch, "Platform::target_arch" ); -tie( $target_mic_arch, "Platform::target_mic_arch" ); -tie( $target_os, "Platform::target_os" ); -tie( $target_platform, "Platform::target_platform" ); - -{ package Platform::base; - - use Carp; - - use Tie::Scalar; - use base "Tie::StdScalar"; - - sub STORE { - my $self = shift( @_ ); - croak( "Modifying \$" . ref( $self ) . " is not allowed; stopped" ); - }; # sub STORE - -} # package Platform::base - -{ package Platform::host_arch; - use base "Platform::base"; - sub FETCH { - return $_host_arch; - }; # sub FETCH -} # package Platform::host_arch - -{ package Platform::host_os; - use base "Platform::base"; - sub FETCH { - return $_host_os; - }; # sub FETCH -} # package Platform::host_os - -{ package Platform::host_platform; - use base "Platform::base"; - sub FETCH { - return "${_host_os}_${_host_arch}"; - }; # sub FETCH -} # package Platform::host_platform - -{ package Platform::target_arch; - use base "Platform::base"; - sub FETCH { - return $_target_arch; - }; # sub FETCH -} # package Platform::target_arch - -{ package Platform::target_mic_arch; - use base "Platform::base"; - sub FETCH { - return $_target_mic_arch; - }; # sub FETCH -} # package Platform::target_mic_arch - -{ package Platform::target_os; - use base "Platform::base"; - sub FETCH { - return $_target_os; - }; # sub FETCH -} # package Platform::target_os - -{ package Platform::target_platform; - use base "Platform::base"; - sub FETCH { - if ($_target_arch eq "mic") { - return "${_target_os}_${_target_mic_arch}"; - } else { - return "${_target_os}_${_target_arch}"; - } - }; # sub FETCH -} # package Platform::target_platform - - -return 1; - -__END__ - -=pod - -=head1 NAME - -B<Platform.pm> -- Few subroutines to get OS, architecture and platform name in form suitable for -naming files, directories, macros, etc. - -=head1 SYNOPSIS - - use Platform ":all"; - use tools; - - my $arch = canon_arch( "em64T" ); # Returns "32e". - my $legal = legal_arch( "em64t" ); # Returns "Intel(R) 64". - my $option = arch_opt( "em64t" ); # Returns "intel64". - my $os = canon_os( "Windows NT" ); # Returns "win". - - print( $host_arch, $host_os, $host_platform ); - print( $target_arch, $target_os, $target_platform ); - - tools::get_options( - Platform::target_options(), - ... - ); - - -=head1 DESCRIPTION - -Environment variable LIBOMP_OS specifies target OS to report. If LIBOMP_OS id not defined, -the script assumes host OS is target OS. - -Environment variable LIBOMP_ARCH specifies target architecture to report. If LIBOMP_ARCH is not defined, -the script assumes host architecture is target one. - -=head2 Functions. - -=over - -=item B<canon_arch( $arch )> - -Input string is an architecture name to canonize. The function recognizes many variants, for example: -C<32e>, C<Intel64>, C<Intel(R) 64>, etc. Returned string is a canonized architecture name, -one of: C<32>, C<32e>, C<64>, C<arm>, C<ppc64le>, C<ppc64>, C<mic>, C<mips>, C<mips64>, C<riscv64>, C<loongarch64>, C<s390x>, or C<undef> is input string is not recognized. - -=item B<legal_arch( $arch )> - -Input string is architecture name. The function recognizes the same variants as C<arch_canon()> does. -Returned string is a name approved by Intel Legal, one of: C<IA-32 architecture>, C<Intel(R) 64> -or C<undef> if input string is not recognized. - -=item B<arch_opt( $arch )> - -Input string is architecture name. The function recognizes the same variants as C<arch_canon()> does. -Returned string is an architecture name suitable for passing to compiler setup scripts -(e. g. C<iccvars.sh>), one of: C<IA-32 architecture>, C<Intel(R) 64> or C<undef> if input string is not -recognized. - -=item B<canon_os( $os )> - -Input string is OS name to canonize. The function recognizes many variants, for example: C<mac>, C<OS X>, etc. Returned string is a canonized OS name, one of: C<lin>, -C<mac>, C<win>, or C<undef> is input string is not recognized. - -=item B<target_options()> - -Returns array suitable for passing to C<tools::get_options()> to let a script recognize -C<--target-architecture=I<str>> and C<--target-os=I<str>> options. Typical usage is: - - use tools; - use Platform; - - my ( $os, $arch, $platform ); # Global variables, not initialized. - - ... - - get_options( - Platform::target_options(), # Let script recognize --target-os and --target-arch options. - ... - ); - # Initialize variables after parsing command line. - ( $os, $arch, $platform ) = ( Platform::target_os(), Platform::target_arch(), Platform::target_platform() ); - -=back - -=head2 Variables - -=item B<$host_arch> - -Canonized name of host architecture. - -=item B<$host_os> - -Canonized name of host OS. - -=item B<$host_platform> - -Host platform name (concatenated canonized OS name, underscore, and canonized architecture name). - -=item B<$target_arch> - -Canonized name of target architecture. - -=item B<$target_os> - -Canonized name of target OS. - -=item B<$target_platform> - -Target platform name (concatenated canonized OS name, underscore, and canonized architecture name). - -=back - -=cut - -# end of file # diff --git a/openmp/runtime/tools/lib/Uname.pm b/openmp/runtime/tools/lib/Uname.pm deleted file mode 100644 index 447680c..0000000 --- a/openmp/runtime/tools/lib/Uname.pm +++ /dev/null @@ -1,646 +0,0 @@ -# -# 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 domain 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_32\z} ) { - $values{ hardware_platform } = "aarch64_32"; - } 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"; - } elsif ( $values{ machine } =~ m{\Ariscv64\z} ) { - $values{ hardware_platform } = "riscv64"; - } elsif ( $values{ machine } =~ m{\Aloongarch64\z} ) { - $values{ hardware_platform } = "loongarch64"; - } elsif ( $values{ machine } =~ m{\As390x\z} ) { - $values{ hardware_platform } = "s390x"; - } 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 components), 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 # - diff --git a/openmp/runtime/tools/lib/tools.pm b/openmp/runtime/tools/lib/tools.pm deleted file mode 100644 index 501f54c..0000000 --- a/openmp/runtime/tools/lib/tools.pm +++ /dev/null @@ -1,1976 +0,0 @@ -# -# This is not a runnable script, it is a Perl module, a collection of variables, subroutines, etc. -# to be used in other scripts. -# -# To get help about exported variables and subroutines, please execute the following command: -# -# perldoc tools.pm -# -# or see POD (Plain Old Documentation) imbedded 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 -#// -#//===----------------------------------------------------------------------===// -# - -=head1 NAME - -B<tools.pm> -- A collection of subroutines which are widely used in Perl scripts. - -=head1 SYNOPSIS - - use FindBin; - use lib "$FindBin::Bin/lib"; - use tools; - -=head1 DESCRIPTION - -B<Note:> Because this collection is small and intended for widely using in particular project, -all variables and functions are exported by default. - -B<Note:> I have some ideas how to improve this collection, but it is in my long-term plans. -Current shape is not ideal, but good enough to use. - -=cut - -package tools; - -use strict; -use warnings; - -use vars qw( @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS ); -require Exporter; -@ISA = qw( Exporter ); - -my @vars = qw( $tool ); -my @utils = qw( check_opts validate ); -my @opts = qw( get_options ); -my @print = qw( debug info warning cmdline_error runtime_error question ); -my @name = qw( get_vol get_dir get_file get_name get_ext cat_file cat_dir ); -my @file = qw( which abs_path rel_path real_path make_dir clean_dir copy_dir move_dir del_dir change_dir copy_file move_file del_file ); -my @io = qw( read_file write_file ); -my @exec = qw( execute backticks ); -my @string = qw{ pad }; -@EXPORT = ( @utils, @opts, @vars, @print, @name, @file, @io, @exec, @string ); - -use UNIVERSAL (); - -use FindBin; -use IO::Handle; -use IO::File; -use IO::Dir; -# Not available on some machines: use IO::Zlib; - -use Getopt::Long (); -use Pod::Usage (); -use Carp (); -use File::Copy (); -use File::Path (); -use File::Temp (); -use File::Spec (); -use POSIX qw{ :fcntl_h :errno_h }; -use Cwd (); -use Symbol (); - -use Data::Dumper; - -use vars qw( $tool $verbose $timestamps ); -$tool = $FindBin::Script; - -my @warning = ( sub {}, \&warning, \&runtime_error ); - - -sub check_opts(\%$;$) { - - my $opts = shift( @_ ); # Reference to hash containing real options and their values. - my $good = shift( @_ ); # Reference to an array containing all known option names. - my $msg = shift( @_ ); # Optional (non-mandatory) message. - - if ( not defined( $msg ) ) { - $msg = "unknown option(s) passed"; # Default value for $msg. - }; # if - - # I'll use these hashes as sets of options. - my %good = map( ( $_ => 1 ), @$good ); # %good now is filled with all known options. - my %bad; # %bad is empty. - - foreach my $opt ( keys( %$opts ) ) { # For each real option... - if ( not exists( $good{ $opt } ) ) { # Look its name in the set of known options... - $bad{ $opt } = 1; # Add unknown option to %bad set. - delete( $opts->{ $opt } ); # And delete original option. - }; # if - }; # foreach $opt - if ( %bad ) { # If %bad set is not empty... - my @caller = caller( 1 ); # Issue a warning. - local $Carp::CarpLevel = 2; - Carp::cluck( $caller[ 3 ] . ": " . $msg . ": " . join( ", ", sort( keys( %bad ) ) ) ); - }; # if - - return 1; - -}; # sub check_opts - - -# -------------------------------------------------------------------------------------------------- -# Purpose: -# Check subroutine arguments. -# Synopsis: -# my %opts = validate( params => \@_, spec => { ... }, caller => n ); -# Arguments: -# params -- A reference to subroutine's actual arguments. -# spec -- Specification of expected arguments. -# caller -- ... -# Return value: -# A hash of validated options. -# Description: -# I would like to use Params::Validate module, but it is not a part of default Perl -# distribution, so I cannot rely on it. This subroutine resembles to some extent to -# Params::Validate::validate_with(). -# Specification of expected arguments: -# { $opt => { type => $type, default => $default }, ... } -# $opt -- String, option name. -# $type -- String, expected type(s). Allowed values are "SCALAR", "UNDEF", "BOOLEAN", -# "ARRAYREF", "HASHREF", "CODEREF". Multiple types may listed using bar: -# "SCALAR|ARRAYREF". The type string is case-insensitive. -# $default -- Default value for an option. Will be used if option is not specified or -# undefined. -# -sub validate(@) { - - my %opts = @_; # Temporary use %opts for parameters of `validate' subroutine. - my $params = $opts{ params }; - my $caller = ( $opts{ caller } or 0 ) + 1; - my $spec = $opts{ spec }; - undef( %opts ); # Ok, Clean %opts, now we will collect result of the subroutine. - - # Find out caller package, filename, line, and subroutine name. - my ( $pkg, $file, $line, $subr ) = caller( $caller ); - my @errors; # We will collect errors in array not to stop on the first found error. - my $error = - sub ($) { - my $msg = shift( @_ ); - push( @errors, "$msg at $file line $line.\n" ); - }; # sub - - # Check options. - while ( @$params ) { - # Check option name. - my $opt = shift( @$params ); - if ( not exists( $spec->{ $opt } ) ) { - $error->( "Invalid option `$opt'" ); - shift( @$params ); # Skip value of unknow option. - next; - }; # if - # Check option value exists. - if ( not @$params ) { - $error->( "Option `$opt' does not have a value" ); - next; - }; # if - my $val = shift( @$params ); - # Check option value type. - if ( exists( $spec->{ $opt }->{ type } ) ) { - # Type specification exists. Check option value type. - my $actual_type; - if ( ref( $val ) ne "" ) { - $actual_type = ref( $val ) . "REF"; - } else { - $actual_type = ( defined( $val ) ? "SCALAR" : "UNDEF" ); - }; # if - my @wanted_types = split( m{\|}, lc( $spec->{ $opt }->{ type } ) ); - my $wanted_types = join( "|", map( $_ eq "boolean" ? "scalar|undef" : quotemeta( $_ ), @wanted_types ) ); - if ( $actual_type !~ m{\A(?:$wanted_types)\z}i ) { - $actual_type = lc( $actual_type ); - $wanted_types = lc( join( " or ", map( "`$_'", @wanted_types ) ) ); - $error->( "Option `$opt' value type is `$actual_type' but expected to be $wanted_types" ); - next; - }; # if - }; # if - if ( exists( $spec->{ $opt }->{ values } ) ) { - my $values = $spec->{ $opt }->{ values }; - if ( not grep( $_ eq $val, @$values ) ) { - $values = join( ", ", map( "`$_'", @$values ) ); - $error->( "Option `$opt' value is `$val' but expected to be one of $values" ); - next; - }; # if - }; # if - $opts{ $opt } = $val; - }; # while - - # Assign default values. - foreach my $opt ( keys( %$spec ) ) { - if ( not defined( $opts{ $opt } ) and exists( $spec->{ $opt }->{ default } ) ) { - $opts{ $opt } = $spec->{ $opt }->{ default }; - }; # if - }; # foreach $opt - - # If we found any errors, raise them. - if ( @errors ) { - die join( "", @errors ); - }; # if - - return %opts; - -}; # sub validate - -# ================================================================================================= -# Get option helpers. -# ================================================================================================= - -=head2 Get option helpers. - -=cut - -# ------------------------------------------------------------------------------------------------- - -=head3 get_options - -B<Synopsis:> - - get_options( @arguments ) - -B<Description:> - -It is very simple wrapper arounf Getopt::Long::GetOptions. It passes all arguments to GetOptions, -and add definitions for standard help options: --help, --doc, --verbose, and --quiet. -When GetOptions finishes, this subroutine checks exit code, if it is non-zero, standard error -message is issued and script terminated. - -If --verbose or --quiet option is specified, C<tools.pm_verbose> environment variable is set. -It is the way to propagate verbose/quiet mode to callee Perl scripts. - -=cut - -sub get_options { - - Getopt::Long::Configure( "no_ignore_case" ); - Getopt::Long::GetOptions( - "h0|usage" => sub { Pod::Usage::pod2usage( -exitval => 0, -verbose => 0 ); }, - "h1|h|help" => sub { Pod::Usage::pod2usage( -exitval => 0, -verbose => 1 ); }, - "h2|doc|manual" => sub { Pod::Usage::pod2usage( -exitval => 0, -verbose => 2 ); }, - "version" => sub { print( "$tool version $main::VERSION\n" ); exit( 0 ); }, - "v|verbose" => sub { ++ $verbose; $ENV{ "tools.pm_verbose" } = $verbose; }, - "quiet" => sub { -- $verbose; $ENV{ "tools.pm_verbose" } = $verbose; }, - "with-timestamps" => sub { $timestamps = 1; $ENV{ "tools.pm_timestamps" } = $timestamps; }, - @_, # Caller arguments are at the end so caller options overrides standard. - ) or cmdline_error(); - -}; # sub get_options - - -# ================================================================================================= -# Print utilities. -# ================================================================================================= - -=pod - -=head2 Print utilities. - -Each of the print subroutines prepends each line of its output with the name of current script and -the type of information, for example: - - info( "Writing file..." ); - -will print - - <script>: (i): Writing file... - -while - - warning( "File does not exist!" ); - -will print - - <script>: (!): File does not exist! - -Here are exported items: - -=cut - -# ------------------------------------------------------------------------------------------------- - -sub _format_message($\@;$) { - - my $prefix = shift( @_ ); - my $args = shift( @_ ); - my $no_eol = shift( @_ ); # Do not append "\n" to the last line. - my $message = ""; - - my $ts = ""; - if ( $timestamps ) { - my ( $sec, $min, $hour, $day, $month, $year ) = gmtime(); - $month += 1; - $year += 1900; - $ts = sprintf( "%04d-%02d-%02d %02d:%02d:%02d UTC: ", $year, $month, $day, $hour, $min, $sec ); - }; # if - for my $i ( 1 .. @$args ) { - my @lines = split( "\n", $args->[ $i - 1 ] ); - for my $j ( 1 .. @lines ) { - my $line = $lines[ $j - 1 ]; - my $last_line = ( ( $i == @$args ) and ( $j == @lines ) ); - my $eol = ( ( substr( $line, -1 ) eq "\n" ) or defined( $no_eol ) ? "" : "\n" ); - $message .= "$ts$tool: ($prefix) " . $line . $eol; - }; # foreach $j - }; # foreach $i - return $message; - -}; # sub _format_message - -#-------------------------------------------------------------------------------------------------- - -=pod - -=head3 $verbose - -B<Synopsis:> - - $verbose - -B<Description:> - -Package variable. It determines verbosity level, which affects C<warning()>, C<info()>, and -C<debug()> subroutines . - -The variable gets initial value from C<tools.pm_verbose> environment variable if it is exists. -If the environment variable does not exist, variable is set to 2. - -Initial value may be overridden later directly or by C<get_options> function. - -=cut - -$verbose = exists( $ENV{ "tools.pm_verbose" } ) ? $ENV{ "tools.pm_verbose" } : 2; - -#-------------------------------------------------------------------------------------------------- - -=pod - -=head3 $timestamps - -B<Synopsis:> - - $timestamps - -B<Description:> - -Package variable. It determines whether C<debug()>, C<info()>, C<warning()>, C<runtime_error()> -subroutines print timestamps or not. - -The variable gets initial value from C<tools.pm_timestamps> environment variable if it is exists. -If the environment variable does not exist, variable is set to false. - -Initial value may be overridden later directly or by C<get_options()> function. - -=cut - -$timestamps = exists( $ENV{ "tools.pm_timestamps" } ) ? $ENV{ "tools.pm_timestamps" } : 0; - -# ------------------------------------------------------------------------------------------------- - -=pod - -=head3 debug - -B<Synopsis:> - - debug( @messages ) - -B<Description:> - -If verbosity level is 3 or higher, print debug information to the stderr, prepending it with "(#)" -prefix. - -=cut - -sub debug(@) { - - if ( $verbose >= 3 ) { - STDOUT->flush(); - STDERR->print( _format_message( "#", @_ ) ); - }; # if - return 1; - -}; # sub debug - -#-------------------------------------------------------------------------------------------------- - -=pod - -=head3 info - -B<Synopsis:> - - info( @messages ) - -B<Description:> - -If verbosity level is 2 or higher, print information to the stderr, prepending it with "(i)" prefix. - -=cut - -sub info(@) { - - if ( $verbose >= 2 ) { - STDOUT->flush(); - STDERR->print( _format_message( "i", @_ ) ); - }; # if - -}; # sub info - -#-------------------------------------------------------------------------------------------------- - -=head3 warning - -B<Synopsis:> - - warning( @messages ) - -B<Description:> - -If verbosity level is 1 or higher, issue a warning, prepending it with "(!)" prefix. - -=cut - -sub warning(@) { - - if ( $verbose >= 1 ) { - STDOUT->flush(); - warn( _format_message( "!", @_ ) ); - }; # if - -}; # sub warning - -# ------------------------------------------------------------------------------------------------- - -=head3 cmdline_error - -B<Synopsis:> - - cmdline_error( @message ) - -B<Description:> - -Print error message and exit the program with status 2. - -This function is intended to complain on command line errors, e. g. unknown -options, invalid arguments, etc. - -=cut - -sub cmdline_error(;$) { - - my $message = shift( @_ ); - - if ( defined( $message ) ) { - if ( substr( $message, -1, 1 ) ne "\n" ) { - $message .= "\n"; - }; # if - } else { - $message = ""; - }; # if - STDOUT->flush(); - die $message . "Try --help option for more information.\n"; - -}; # sub cmdline_error - -# ------------------------------------------------------------------------------------------------- - -=head3 runtime_error - -B<Synopsis:> - - runtime_error( @message ) - -B<Description:> - -Print error message and exits the program with status 3. - -This function is intended to complain on runtime errors, e. g. -directories which are not found, non-writable files, etc. - -=cut - -sub runtime_error(@) { - - STDOUT->flush(); - die _format_message( "x", @_ ); - -}; # sub runtime_error - -#-------------------------------------------------------------------------------------------------- - -=head3 question - -B<Synopsis:> - - question( $prompt; $answer, $choices ) - -B<Description:> - -Print $promp to the stderr, prepending it with "question:" prefix. Read a line from stdin, chop -"\n" from the end, it is answer. - -If $answer is defined, it is treated as first user input. - -If $choices is specified, it could be a regexp for validating user input, or a string. In latter -case it interpreted as list of characters, acceptable (case-insensitive) choices. If user enters -non-acceptable answer, question continue asking until answer is acceptable. -If $choices is not specified, any answer is acceptable. - -In case of end-of-file (or Ctrl+D pressed by user), $answer is C<undef>. - -B<Examples:> - - my $answer; - question( "Save file [yn]? ", $answer, "yn" ); - # We accepts only "y", "Y", "n", or "N". - question( "Press enter to continue or Ctrl+C to abort..." ); - # We are not interested in answer value -- in case of Ctrl+C the script will be terminated, - # otherwise we continue execution. - question( "File name? ", $answer ); - # Any answer is acceptable. - -=cut - -sub question($;\$$) { - - my $prompt = shift( @_ ); - my $answer = shift( @_ ); - my $choices = shift( @_ ); - my $a = ( defined( $answer ) ? $$answer : undef ); - - if ( ref( $choices ) eq "Regexp" ) { - # It is already a regular expression, do nothing. - } elsif ( defined( $choices ) ) { - # Convert string to a regular expression. - $choices = qr/[@{ [ quotemeta( $choices ) ] }]/i; - }; # if - - for ( ; ; ) { - STDERR->print( _format_message( "?", @{ [ $prompt ] }, "no_eol" ) ); - STDERR->flush(); - if ( defined( $a ) ) { - STDOUT->print( $a . "\n" ); - } else { - $a = <STDIN>; - }; # if - if ( not defined( $a ) ) { - last; - }; # if - chomp( $a ); - if ( not defined( $choices ) or ( $a =~ m/^$choices$/ ) ) { - last; - }; # if - $a = undef; - }; # forever - if ( defined( $answer ) ) { - $$answer = $a; - }; # if - -}; # sub question - -# ------------------------------------------------------------------------------------------------- - -# Returns volume part of path. -sub get_vol($) { - - my $path = shift( @_ ); - my ( $vol, undef, undef ) = File::Spec->splitpath( $path ); - return $vol; - -}; # sub get_vol - -# Returns directory part of path. -sub get_dir($) { - - my $path = File::Spec->canonpath( shift( @_ ) ); - my ( $vol, $dir, undef ) = File::Spec->splitpath( $path ); - my @dirs = File::Spec->splitdir( $dir ); - pop( @dirs ); - $dir = File::Spec->catdir( @dirs ); - $dir = File::Spec->catpath( $vol, $dir, undef ); - return $dir; - -}; # sub get_dir - -# Returns file part of path. -sub get_file($) { - - my $path = shift( @_ ); - my ( undef, undef, $file ) = File::Spec->splitpath( $path ); - return $file; - -}; # sub get_file - -# Returns file part of path without last suffix. -sub get_name($) { - - my $path = shift( @_ ); - my ( undef, undef, $file ) = File::Spec->splitpath( $path ); - $file =~ s{\.[^.]*\z}{}; - return $file; - -}; # sub get_name - -# Returns last suffix of file part of path. -sub get_ext($) { - - my $path = shift( @_ ); - my ( undef, undef, $file ) = File::Spec->splitpath( $path ); - my $ext = ""; - if ( $file =~ m{(\.[^.]*)\z} ) { - $ext = $1; - }; # if - return $ext; - -}; # sub get_ext - -sub cat_file(@) { - - my $path = shift( @_ ); - my $file = pop( @_ ); - my @dirs = @_; - - my ( $vol, $dirs ) = File::Spec->splitpath( $path, "no_file" ); - @dirs = ( File::Spec->splitdir( $dirs ), @dirs ); - $dirs = File::Spec->catdir( @dirs ); - $path = File::Spec->catpath( $vol, $dirs, $file ); - - return $path; - -}; # sub cat_file - -sub cat_dir(@) { - - my $path = shift( @_ ); - my @dirs = @_; - - my ( $vol, $dirs ) = File::Spec->splitpath( $path, "no_file" ); - @dirs = ( File::Spec->splitdir( $dirs ), @dirs ); - $dirs = File::Spec->catdir( @dirs ); - $path = File::Spec->catpath( $vol, $dirs, "" ); - - return $path; - -}; # sub cat_dir - -# ================================================================================================= -# File and directory manipulation subroutines. -# ================================================================================================= - -=head2 File and directory manipulation subroutines. - -=over - -=cut - -# ------------------------------------------------------------------------------------------------- - -=item C<which( $file, @options )> - -Searches for specified executable file in the (specified) directories. -Raises a runtime eroror if no executable file found. Returns a full path of found executable(s). - -Options: - -=over - -=item C<-all> =E<gt> I<bool> - -Do not stop on the first found file. Note, that list of full paths is returned in this case. - -=item C<-dirs> =E<gt> I<ref_to_array> - -Specify directory list to search through. If option is not passed, PATH environment variable -is used for directory list. - -=item C<-exec> =E<gt> I<bool> - -Whether check for executable files or not. By default, C<which> searches executable files. -However, on Cygwin executable check never performed. - -=back - -Examples: - -Look for "echo" in the directories specified in PATH: - - my $echo = which( "echo" ); - -Look for all occurrences of "cp" in the PATH: - - my @cps = which( "cp", -all => 1 ); - -Look for the first occurrence of "icc" in the specified directories: - - my $icc = which( "icc", -dirs => [ ".", "/usr/local/bin", "/usr/bin", "/bin" ] ); - -=cut - -sub which($@) { - - my $file = shift( @_ ); - my %opts = @_; - - check_opts( %opts, [ qw( -all -dirs -exec ) ] ); - if ( $opts{ -all } and not wantarray() ) { - local $Carp::CarpLevel = 1; - Carp::cluck( "`-all' option passed to `which' but list is not expected" ); - }; # if - if ( not defined( $opts{ -exec } ) ) { - $opts{ -exec } = 1; - }; # if - - my $dirs = ( exists( $opts{ -dirs } ) ? $opts{ -dirs } : [ File::Spec->path() ] ); - my @found; - - my @exts = ( "" ); - if ( $^O eq "MSWin32" and $opts{ -exec } ) { - if ( defined( $ENV{ PATHEXT } ) ) { - push( @exts, split( ";", $ENV{ PATHEXT } ) ); - } else { - # If PATHEXT does not exist, use default value. - push( @exts, qw{ .COM .EXE .BAT .CMD } ); - }; # if - }; # if - - loop: - foreach my $dir ( @$dirs ) { - foreach my $ext ( @exts ) { - my $path = File::Spec->catfile( $dir, $file . $ext ); - if ( -e $path ) { - # Executable bit is not reliable on Cygwin, do not check it. - if ( not $opts{ -exec } or -x $path or $^O eq "cygwin" ) { - push( @found, $path ); - if ( not $opts{ -all } ) { - last loop; - }; # if - }; # if - }; # if - }; # foreach $ext - }; # foreach $dir - - if ( not @found ) { - # TBD: We need to introduce an option for conditional enabling this error. - # runtime_error( "Could not find \"$file\" executable file in PATH." ); - }; # if - if ( @found > 1 ) { - # TBD: Issue a warning? - }; # if - - if ( $opts{ -all } ) { - return @found; - } else { - return $found[ 0 ]; - }; # if - -}; # sub which - -# ------------------------------------------------------------------------------------------------- - -=item C<abs_path( $path, $base )> - -Return absolute path for an argument. - -Most of the work is done by C<File::Spec->rel2abs()>. C<abs_path()> additionally collapses -C<dir1/../dir2> to C<dir2>. - -It is not so naive and made intentionally. For example on Linux* OS in Bash if F<link/> is a symbolic -link to directory F<some_dir/> - - $ cd link - $ cd .. - -brings you back to F<link/>'s parent, not to parent of F<some_dir/>, - -=cut - -sub abs_path($;$) { - - my ( $path, $base ) = @_; - $path = File::Spec->rel2abs( $path, ( defined( $base ) ? $base : $ENV{ PWD } ) ); - my ( $vol, $dir, $file ) = File::Spec->splitpath( $path ); - while ( $dir =~ s{/(?!\.\.)[^/]*/\.\.(?:/|\z)}{/} ) { - }; # while - $path = File::Spec->canonpath( File::Spec->catpath( $vol, $dir, $file ) ); - return $path; - -}; # sub abs_path - -# ------------------------------------------------------------------------------------------------- - -=item C<rel_path( $path, $base )> - -Return relative path for an argument. - -=cut - -sub rel_path($;$) { - - my ( $path, $base ) = @_; - $path = File::Spec->abs2rel( abs_path( $path ), $base ); - return $path; - -}; # sub rel_path - -# ------------------------------------------------------------------------------------------------- - -=item C<real_path( $dir )> - -Return real absolute path for an argument. In the result all relative components (F<.> and F<..>) -and U<symbolic links are resolved>. - -In most cases it is not what you want. Consider using C<abs_path> first. - -C<abs_path> function from B<Cwd> module works with directories only. This function works with files -as well. But, if file is a symbolic link, function does not resolve it (yet). - -The function uses C<runtime_error> to raise an error if something wrong. - -=cut - -sub real_path($) { - - my $orig_path = shift( @_ ); - my $real_path; - my $message = ""; - if ( not -e $orig_path ) { - $message = "\"$orig_path\" does not exists"; - } else { - # Cwd::abs_path does not work with files, so in this case we should handle file separately. - my $file; - if ( not -d $orig_path ) { - ( my $vol, my $dir, $file ) = File::Spec->splitpath( File::Spec->rel2abs( $orig_path ) ); - $orig_path = File::Spec->catpath( $vol, $dir ); - }; # if - { - local $SIG{ __WARN__ } = sub { $message = $_[ 0 ]; }; - $real_path = Cwd::abs_path( $orig_path ); - }; - if ( defined( $file ) ) { - $real_path = File::Spec->catfile( $real_path, $file ); - }; # if - }; # if - if ( not defined( $real_path ) or $message ne "" ) { - $message =~ s/^stat\(.*\): (.*)\s+at .*? line \d+\s*\z/$1/; - runtime_error( "Could not find real path for \"$orig_path\"" . ( $message ne "" ? ": $message" : "" ) ); - }; # if - return $real_path; - -}; # sub real_path - -# ------------------------------------------------------------------------------------------------- - -=item C<make_dir( $dir, @options )> - -Make a directory. - -This function makes a directory. If necessary, more than one level can be created. -If directory exists, warning issues (the script behavior depends on value of -C<-warning_level> option). If directory creation fails or C<$dir> exists but it is not a -directory, error issues. - -Options: - -=over - -=item C<-mode> - -The numeric mode for new directories, 0750 (rwxr-x---) by default. - -=back - -=cut - -sub make_dir($@) { - - my $dir = shift( @_ ); - my %opts = - validate( - params => \@_, - spec => { - parents => { type => "boolean", default => 1 }, - mode => { type => "scalar", default => 0777 }, - }, - ); - - my $prefix = "Could not create directory \"$dir\""; - - if ( -e $dir ) { - if ( -d $dir ) { - } else { - runtime_error( "$prefix: it exists, but not a directory." ); - }; # if - } else { - eval { - File::Path::mkpath( $dir, 0, $opts{ mode } ); - }; # eval - if ( $@ ) { - $@ =~ s{\s+at (?:[a-zA-Z0-9 /_.]*/)?tools\.pm line \d+\s*}{}; - runtime_error( "$prefix: $@" ); - }; # if - if ( not -d $dir ) { # Just in case, check it one more time... - runtime_error( "$prefix." ); - }; # if - }; # if - -}; # sub make_dir - -# ------------------------------------------------------------------------------------------------- - -=item C<copy_dir( $src_dir, $dst_dir, @options )> - -Copy directory recursively. - -This function copies a directory recursively. -If source directory does not exist or not a directory, error issues. - -Options: - -=over - -=item C<-overwrite> - -Overwrite destination directory, if it exists. - -=back - -=cut - -sub copy_dir($$@) { - - my $src = shift( @_ ); - my $dst = shift( @_ ); - my %opts = @_; - my $prefix = "Could not copy directory \"$src\" to \"$dst\""; - - if ( not -e $src ) { - runtime_error( "$prefix: \"$src\" does not exist." ); - }; # if - if ( not -d $src ) { - runtime_error( "$prefix: \"$src\" is not a directory." ); - }; # if - if ( -e $dst ) { - if ( -d $dst ) { - if ( $opts{ -overwrite } ) { - del_dir( $dst ); - } else { - runtime_error( "$prefix: \"$dst\" already exists." ); - }; # if - } else { - runtime_error( "$prefix: \"$dst\" is not a directory." ); - }; # if - }; # if - - execute( [ "cp", "-R", $src, $dst ] ); - -}; # sub copy_dir - -# ------------------------------------------------------------------------------------------------- - -=item C<move_dir( $src_dir, $dst_dir, @options )> - -Move directory. - -Options: - -=over - -=item C<-overwrite> - -Overwrite destination directory, if it exists. - -=back - -=cut - -sub move_dir($$@) { - - my $src = shift( @_ ); - my $dst = shift( @_ ); - my %opts = @_; - my $prefix = "Could not copy directory \"$src\" to \"$dst\""; - - if ( not -e $src ) { - runtime_error( "$prefix: \"$src\" does not exist." ); - }; # if - if ( not -d $src ) { - runtime_error( "$prefix: \"$src\" is not a directory." ); - }; # if - if ( -e $dst ) { - if ( -d $dst ) { - if ( $opts{ -overwrite } ) { - del_dir( $dst ); - } else { - runtime_error( "$prefix: \"$dst\" already exists." ); - }; # if - } else { - runtime_error( "$prefix: \"$dst\" is not a directory." ); - }; # if - }; # if - - execute( [ "mv", $src, $dst ] ); - -}; # sub move_dir - -# ------------------------------------------------------------------------------------------------- - -=item C<clean_dir( $dir, @options )> - -Clean a directory: delete all the entries (recursively), but leave the directory. - -Options: - -=over - -=item C<-force> => bool - -If a directory is not writable, try to change permissions first, then clean it. - -=item C<-skip> => regexp - -Regexp. If a directory entry mached the regexp, it is skipped, not deleted. (As a subsequence, -a directory containing skipped entries is not deleted.) - -=back - -=cut - -sub _clean_dir($); - -sub _clean_dir($) { - our %_clean_dir_opts; - my ( $dir ) = @_; - my $skip = $_clean_dir_opts{ skip }; # Regexp. - my $skipped = 0; # Number of skipped files. - my $prefix = "Cleaning `$dir' failed:"; - my @stat = stat( $dir ); - my $mode = $stat[ 2 ]; - if ( not @stat ) { - runtime_error( $prefix, "Cannot stat `$dir': $!" ); - }; # if - if ( not -d _ ) { - runtime_error( $prefix, "It is not a directory." ); - }; # if - if ( not -w _ ) { # Directory is not writable. - if ( not -o _ or not $_clean_dir_opts{ force } ) { - runtime_error( $prefix, "Directory is not writable." ); - }; # if - # Directory is not writable but mine. Try to change permissions. - chmod( $mode | S_IWUSR, $dir ) - or runtime_error( $prefix, "Cannot make directory writable: $!" ); - }; # if - my $handle = IO::Dir->new( $dir ) or runtime_error( $prefix, "Cannot read directory: $!" ); - my @entries = File::Spec->no_upwards( $handle->read() ); - $handle->close() or runtime_error( $prefix, "Cannot read directory: $!" ); - foreach my $entry ( @entries ) { - my $path = cat_file( $dir, $entry ); - if ( defined( $skip ) and $entry =~ $skip ) { - ++ $skipped; - } else { - if ( -l $path ) { - unlink( $path ) or runtime_error( $prefix, "Cannot delete symlink `$path': $!" ); - } else { - stat( $path ) or runtime_error( $prefix, "Cannot stat `$path': $! " ); - if ( -f _ ) { - del_file( $path ); - } elsif ( -d _ ) { - my $rc = _clean_dir( $path ); - if ( $rc == 0 ) { - rmdir( $path ) or runtime_error( $prefix, "Cannot delete directory `$path': $!" ); - }; # if - $skipped += $rc; - } else { - runtime_error( $prefix, "`$path' is neither a file nor a directory." ); - }; # if - }; # if - }; # if - }; # foreach - return $skipped; -}; # sub _clean_dir - - -sub clean_dir($@) { - my $dir = shift( @_ ); - our %_clean_dir_opts; - local %_clean_dir_opts = - validate( - params => \@_, - spec => { - skip => { type => "regexpref" }, - force => { type => "boolean" }, - }, - ); - my $skipped = _clean_dir( $dir ); - return $skipped; -}; # sub clean_dir - - -# ------------------------------------------------------------------------------------------------- - -=item C<del_dir( $dir, @options )> - -Delete a directory recursively. - -This function deletes a directory. If directory can not be deleted or it is not a directory, error -message issues (and script exists). - -Options: - -=over - -=back - -=cut - -sub del_dir($@) { - - my $dir = shift( @_ ); - my %opts = @_; - my $prefix = "Deleting directory \"$dir\" failed"; - our %_clean_dir_opts; - local %_clean_dir_opts = - validate( - params => \@_, - spec => { - force => { type => "boolean" }, - }, - ); - - if ( not -e $dir ) { - # Nothing to do. - return; - }; # if - if ( not -d $dir ) { - runtime_error( "$prefix: it is not a directory." ); - }; # if - _clean_dir( $dir ); - rmdir( $dir ) or runtime_error( "$prefix." ); - -}; # sub del_dir - -# ------------------------------------------------------------------------------------------------- - -=item C<change_dir( $dir )> - -Change current directory. - -If any error occurred, error issues and script exits. - -=cut - -sub change_dir($) { - - my $dir = shift( @_ ); - - Cwd::chdir( $dir ) - or runtime_error( "Could not chdir to \"$dir\": $!" ); - -}; # sub change_dir - - -# ------------------------------------------------------------------------------------------------- - -=item C<copy_file( $src_file, $dst_file, @options )> - -Copy file. - -This function copies a file. If source does not exist or is not a file, error issues. - -Options: - -=over - -=item C<-overwrite> - -Overwrite destination file, if it exists. - -=back - -=cut - -sub copy_file($$@) { - - my $src = shift( @_ ); - my $dst = shift( @_ ); - my %opts = @_; - my $prefix = "Could not copy file \"$src\" to \"$dst\""; - - if ( not -e $src ) { - runtime_error( "$prefix: \"$src\" does not exist." ); - }; # if - if ( not -f $src ) { - runtime_error( "$prefix: \"$src\" is not a file." ); - }; # if - if ( -e $dst ) { - if ( -f $dst ) { - if ( $opts{ -overwrite } ) { - del_file( $dst ); - } else { - runtime_error( "$prefix: \"$dst\" already exists." ); - }; # if - } else { - runtime_error( "$prefix: \"$dst\" is not a file." ); - }; # if - }; # if - - File::Copy::copy( $src, $dst ) or runtime_error( "$prefix: $!" ); - # On Windows* OS File::Copy preserves file attributes, but on Linux* OS it doesn't. - # So we should do it manually... - if ( $^O =~ m/^linux\z/ ) { - my $mode = ( stat( $src ) )[ 2 ] - or runtime_error( "$prefix: cannot get status info for source file." ); - chmod( $mode, $dst ) - or runtime_error( "$prefix: cannot change mode of destination file." ); - }; # if - -}; # sub copy_file - -# ------------------------------------------------------------------------------------------------- - -sub move_file($$@) { - - my $src = shift( @_ ); - my $dst = shift( @_ ); - my %opts = @_; - my $prefix = "Could not move file \"$src\" to \"$dst\""; - - check_opts( %opts, [ qw( -overwrite ) ] ); - - if ( not -e $src ) { - runtime_error( "$prefix: \"$src\" does not exist." ); - }; # if - if ( not -f $src ) { - runtime_error( "$prefix: \"$src\" is not a file." ); - }; # if - if ( -e $dst ) { - if ( -f $dst ) { - if ( $opts{ -overwrite } ) { - # - } else { - runtime_error( "$prefix: \"$dst\" already exists." ); - }; # if - } else { - runtime_error( "$prefix: \"$dst\" is not a file." ); - }; # if - }; # if - - File::Copy::move( $src, $dst ) or runtime_error( "$prefix: $!" ); - -}; # sub move_file - -# ------------------------------------------------------------------------------------------------- - -sub del_file($) { - my $files = shift( @_ ); - if ( ref( $files ) eq "" ) { - $files = [ $files ]; - }; # if - foreach my $file ( @$files ) { - debug( "Deleting file `$file'..." ); - my $rc = unlink( $file ); - if ( $rc == 0 && $! != ENOENT ) { - # Reporn an error, but ignore ENOENT, because the goal is achieved. - runtime_error( "Deleting file `$file' failed: $!" ); - }; # if - }; # foreach $file -}; # sub del_file - -# ------------------------------------------------------------------------------------------------- - -=back - -=cut - -# ================================================================================================= -# File I/O subroutines. -# ================================================================================================= - -=head2 File I/O subroutines. - -=cut - -#-------------------------------------------------------------------------------------------------- - -=head3 read_file - -B<Synopsis:> - - read_file( $file, @options ) - -B<Description:> - -Read file and return its content. In scalar context function returns a scalar, in list context -function returns list of lines. - -Note: If the last of file does not terminate with newline, function will append it. - -B<Arguments:> - -=over - -=item B<$file> - -A name or handle of file to read from. - -=back - -B<Options:> - -=over - -=item B<-binary> - -If true, file treats as a binary file: no newline conversion, no truncating trailing space, no -newline removing performed. Entire file returned as a scalar. - -=item B<-bulk> - -This option is allowed only in binary mode. Option's value should be a reference to a scalar. -If option present, file content placed to pointee scalar and function returns true (1). - -=item B<-chomp> - -If true, newline characters are removed from file content. By default newline characters remain. -This option is not applicable in binary mode. - -=item B<-keep_trailing_space> - -If true, trainling space remain at the ends of lines. By default all trailing spaces are removed. -This option is not applicable in binary mode. - -=back - -B<Examples:> - -Return file as single line, remove trailing spaces. - - my $bulk = read_file( "message.txt" ); - -Return file as list of lines with removed trailing space and -newline characters. - - my @bulk = read_file( "message.txt", -chomp => 1 ); - -Read a binary file: - - my $bulk = read_file( "message.txt", -binary => 1 ); - -Read a big binary file: - - my $bulk; - read_file( "big_binary_file", -binary => 1, -bulk => \$bulk ); - -Read from standard input: - - my @bulk = read_file( \*STDIN ); - -=cut - -sub read_file($@) { - - my $file = shift( @_ ); # The name or handle of file to read from. - my %opts = @_; # Options. - - my $name; - my $handle; - my @bulk; - my $error = \&runtime_error; - - my @binopts = qw( -binary -error -bulk ); # Options available in binary mode. - my @txtopts = qw( -binary -error -keep_trailing_space -chomp -layer ); # Options available in text (non-binary) mode. - check_opts( %opts, [ @binopts, @txtopts ] ); - if ( $opts{ -binary } ) { - check_opts( %opts, [ @binopts ], "these options cannot be used with -binary" ); - } else { - check_opts( %opts, [ @txtopts ], "these options cannot be used without -binary" ); - }; # if - if ( not exists( $opts{ -error } ) ) { - $opts{ -error } = "error"; - }; # if - if ( $opts{ -error } eq "warning" ) { - $error = \&warning; - } elsif( $opts{ -error } eq "ignore" ) { - $error = sub {}; - } elsif ( ref( $opts{ -error } ) eq "ARRAY" ) { - $error = sub { push( @{ $opts{ -error } }, $_[ 0 ] ); }; - }; # if - - if ( ( ref( $file ) eq "GLOB" ) or UNIVERSAL::isa( $file, "IO::Handle" ) ) { - $name = "unknown"; - $handle = $file; - } else { - $name = $file; - if ( get_ext( $file ) eq ".gz" and not $opts{ -binary } ) { - $handle = IO::Zlib->new( $name, "rb" ); - } else { - $handle = IO::File->new( $name, "r" ); - }; # if - if ( not defined( $handle ) ) { - $error->( "File \"$name\" could not be opened for input: $!" ); - }; # if - }; # if - if ( defined( $handle ) ) { - if ( $opts{ -binary } ) { - binmode( $handle ); - local $/ = undef; # Set input record separator to undef to read entire file as one line. - if ( exists( $opts{ -bulk } ) ) { - ${ $opts{ -bulk } } = $handle->getline(); - } else { - $bulk[ 0 ] = $handle->getline(); - }; # if - } else { - if ( defined( $opts{ -layer } ) ) { - binmode( $handle, $opts{ -layer } ); - }; # if - @bulk = $handle->getlines(); - # Special trick for UTF-8 files: Delete BOM, if any. - if ( defined( $opts{ -layer } ) and $opts{ -layer } eq ":utf8" ) { - if ( substr( $bulk[ 0 ], 0, 1 ) eq "\x{FEFF}" ) { - substr( $bulk[ 0 ], 0, 1 ) = ""; - }; # if - }; # if - }; # if - $handle->close() - or $error->( "File \"$name\" could not be closed after input: $!" ); - } else { - if ( $opts{ -binary } and exists( $opts{ -bulk } ) ) { - ${ $opts{ -bulk } } = ""; - }; # if - }; # if - if ( $opts{ -binary } ) { - if ( exists( $opts{ -bulk } ) ) { - return 1; - } else { - return $bulk[ 0 ]; - }; # if - } else { - if ( ( @bulk > 0 ) and ( substr( $bulk[ -1 ], -1, 1 ) ne "\n" ) ) { - $bulk[ -1 ] .= "\n"; - }; # if - if ( not $opts{ -keep_trailing_space } ) { - map( $_ =~ s/\s+\n\z/\n/, @bulk ); - }; # if - if ( $opts{ -chomp } ) { - chomp( @bulk ); - }; # if - if ( wantarray() ) { - return @bulk; - } else { - return join( "", @bulk ); - }; # if - }; # if - -}; # sub read_file - -#-------------------------------------------------------------------------------------------------- - -=head3 write_file - -B<Synopsis:> - - write_file( $file, $bulk, @options ) - -B<Description:> - -Write file. - -B<Arguments:> - -=over - -=item B<$file> - -The name or handle of file to write to. - -=item B<$bulk> - -Bulk to write to a file. Can be a scalar, or a reference to scalar or an array. - -=back - -B<Options:> - -=over - -=item B<-backup> - -If true, create a backup copy of file overwritten. Backup copy is placed into the same directory. -The name of backup copy is the same as the name of file with `~' appended. By default backup copy -is not created. - -=item B<-append> - -If true, the text will be added to existing file. - -=back - -B<Examples:> - - write_file( "message.txt", \$bulk ); - # Write file, take content from a scalar. - - write_file( "message.txt", \@bulk, -backup => 1 ); - # Write file, take content from an array, create a backup copy. - -=cut - -sub write_file($$@) { - - my $file = shift( @_ ); # The name or handle of file to write to. - my $bulk = shift( @_ ); # The text to write. Can be reference to array or scalar. - my %opts = @_; # Options. - - my $name; - my $handle; - - check_opts( %opts, [ qw( -append -backup -binary -layer ) ] ); - - my $mode = $opts{ -append } ? "a": "w"; - if ( ( ref( $file ) eq "GLOB" ) or UNIVERSAL::isa( $file, "IO::Handle" ) ) { - $name = "unknown"; - $handle = $file; - } else { - $name = $file; - if ( $opts{ -backup } and ( -f $name ) ) { - copy_file( $name, $name . "~", -overwrite => 1 ); - }; # if - $handle = IO::File->new( $name, $mode ) - or runtime_error( "File \"$name\" could not be opened for output: $!" ); - }; # if - if ( $opts{ -binary } ) { - binmode( $handle ); - } elsif ( $opts{ -layer } ) { - binmode( $handle, $opts{ -layer } ); - }; # if - if ( ref( $bulk ) eq "" ) { - if ( defined( $bulk ) ) { - $handle->print( $bulk ); - if ( not $opts{ -binary } and ( substr( $bulk, -1 ) ne "\n" ) ) { - $handle->print( "\n" ); - }; # if - }; # if - } elsif ( ref( $bulk ) eq "SCALAR" ) { - if ( defined( $$bulk ) ) { - $handle->print( $$bulk ); - if ( not $opts{ -binary } and ( substr( $$bulk, -1 ) ne "\n" ) ) { - $handle->print( "\n" ); - }; # if - }; # if - } elsif ( ref( $bulk ) eq "ARRAY" ) { - foreach my $line ( @$bulk ) { - if ( defined( $line ) ) { - $handle->print( $line ); - if ( not $opts{ -binary } and ( substr( $line, -1 ) ne "\n" ) ) { - $handle->print( "\n" ); - }; # if - }; # if - }; # foreach - } else { - Carp::croak( "write_file: \$bulk must be a scalar or reference to (scalar or array)" ); - }; # if - $handle->close() - or runtime_error( "File \"$name\" could not be closed after output: $!" ); - -}; # sub write_file - -#-------------------------------------------------------------------------------------------------- - -=cut - -# ================================================================================================= -# Execution subroutines. -# ================================================================================================= - -=head2 Execution subroutines. - -=over - -=cut - -#-------------------------------------------------------------------------------------------------- - -sub _pre { - - my $arg = shift( @_ ); - - # If redirection is not required, exit. - if ( not exists( $arg->{ redir } ) ) { - return 0; - }; # if - - # Input parameters. - my $mode = $arg->{ mode }; # Mode, "<" (input ) or ">" (output). - my $handle = $arg->{ handle }; # Handle to manipulate. - my $redir = $arg->{ redir }; # Data, a file name if a scalar, or file contents, if a reference. - - # Output parameters. - my $save_handle; - my $temp_handle; - my $temp_name; - - # Save original handle (by duping it). - $save_handle = Symbol::gensym(); - $handle->flush(); - open( $save_handle, $mode . "&" . $handle->fileno() ) - or die( "Cannot dup filehandle: $!" ); - - # Prepare a file to IO. - if ( UNIVERSAL::isa( $redir, "IO::Handle" ) or ( ref( $redir ) eq "GLOB" ) ) { - # $redir is reference to an object of IO::Handle class (or its decedant). - $temp_handle = $redir; - } elsif ( ref( $redir ) ) { - # $redir is a reference to content to be read/written. - # Prepare temp file. - ( $temp_handle, $temp_name ) = - File::Temp::tempfile( - "$tool.XXXXXXXX", - DIR => File::Spec->tmpdir(), - SUFFIX => ".tmp", - UNLINK => 1 - ); - if ( not defined( $temp_handle ) ) { - runtime_error( "Could not create temp file." ); - }; # if - if ( $mode eq "<" ) { - # It is a file to be read by child, prepare file content to be read. - $temp_handle->print( ref( $redir ) eq "SCALAR" ? ${ $redir } : @{ $redir } ); - $temp_handle->flush(); - seek( $temp_handle, 0, 0 ); - # Unfortunatelly, I could not use OO interface to seek. - # ActivePerl 5.6.1 complains on both forms: - # $temp_handle->seek( 0 ); # As declared in IO::Seekable. - # $temp_handle->setpos( 0 ); # As described in documentation. - } elsif ( $mode eq ">" ) { - # It is a file for output. Clear output variable. - if ( ref( $redir ) eq "SCALAR" ) { - ${ $redir } = ""; - } else { - @{ $redir } = (); - }; # if - }; # if - } else { - # $redir is a name of file to be read/written. - # Just open file. - if ( defined( $redir ) ) { - $temp_name = $redir; - } else { - $temp_name = File::Spec->devnull(); - }; # if - $temp_handle = IO::File->new( $temp_name, $mode ) - or runtime_error( "file \"$temp_name\" could not be opened for " . ( $mode eq "<" ? "input" : "output" ) . ": $!" ); - }; # if - - # Redirect handle to temp file. - open( $handle, $mode . "&" . $temp_handle->fileno() ) - or die( "Cannot dup filehandle: $!" ); - - # Save output parameters. - $arg->{ save_handle } = $save_handle; - $arg->{ temp_handle } = $temp_handle; - $arg->{ temp_name } = $temp_name; - -}; # sub _pre - - -sub _post { - - my $arg = shift( @_ ); - - # Input parameters. - my $mode = $arg->{ mode }; # Mode, "<" or ">". - my $handle = $arg->{ handle }; # Handle to save and set. - my $redir = $arg->{ redir }; # Data, a file name if a scalar, or file contents, if a reference. - - # Parameters saved during preprocessing. - my $save_handle = $arg->{ save_handle }; - my $temp_handle = $arg->{ temp_handle }; - my $temp_name = $arg->{ temp_name }; - - # If no handle was saved, exit. - if ( not $save_handle ) { - return 0; - }; # if - - # Close handle. - $handle->close() - or die( "$!" ); - - # Read the content of temp file, if necessary, and close temp file. - if ( ( $mode ne "<" ) and ref( $redir ) ) { - $temp_handle->flush(); - seek( $temp_handle, 0, 0 ); - if ( $^O =~ m/MSWin/ ) { - binmode( $temp_handle, ":crlf" ); - }; # if - if ( ref( $redir ) eq "SCALAR" ) { - ${ $redir } .= join( "", $temp_handle->getlines() ); - } elsif ( ref( $redir ) eq "ARRAY" ) { - push( @{ $redir }, $temp_handle->getlines() ); - }; # if - }; # if - if ( not UNIVERSAL::isa( $redir, "IO::Handle" ) ) { - $temp_handle->close() - or die( "$!" ); - }; # if - - # Restore handle to original value. - $save_handle->flush(); - open( $handle, $mode . "&" . $save_handle->fileno() ) - or die( "Cannot dup filehandle: $!" ); - - # Close save handle. - $save_handle->close() - or die( "$!" ); - - # Delete parameters saved during preprocessing. - delete( $arg->{ save_handle } ); - delete( $arg->{ temp_handle } ); - delete( $arg->{ temp_name } ); - -}; # sub _post - -#-------------------------------------------------------------------------------------------------- - -=item C<execute( [ @command ], @options )> - -Execute specified program or shell command. - -Program is specified by reference to an array, that array is passed to C<system()> function which -executes the command. See L<perlfunc> for details how C<system()> interprets various forms of -C<@command>. - -By default, in case of any error error message is issued and script terminated (by runtime_error()). -Function returns an exit code of program. - -Alternatively, he function may return exit status of the program (see C<-ignore_status>) or signal -(see C<-ignore_signal>) so caller may analyze it and continue execution. - -Options: - -=over - -=item C<-stdin> - -Redirect stdin of program. The value of option can be: - -=over - -=item C<undef> - -Stdin of child is attached to null device. - -=item a string - -Stdin of child is attached to a file with name specified by option. - -=item a reference to a scalar - -A dereferenced scalar is written to a temp file, and child's stdin is attached to that file. - -=item a reference to an array - -A dereferenced array is written to a temp file, and child's stdin is attached to that file. - -=back - -=item C<-stdout> - -Redirect stdout. Possible values are the same as for C<-stdin> option. The only difference is -reference specifies a variable receiving program's output. - -=item C<-stderr> - -It similar to C<-stdout>, but redirects stderr. There is only one additional value: - -=over - -=item an empty string - -means that stderr should be redirected to the same place where stdout is redirected to. - -=back - -=item C<-append> - -Redirected stream will not overwrite previous content of file (or variable). -Note, that option affects both stdout and stderr. - -=item C<-ignore_status> - -By default, subroutine raises an error and exits the script if program returns non-exit status. If -this options is true, no error is raised. Instead, status is returned as function result (and $@ is -set to error message). - -=item C<-ignore_signal> - -By default, subroutine raises an error and exits the script if program die with signal. If -this options is true, no error is raised in such a case. Instead, signal number is returned (as -negative value), error message is placed to C<$@> variable. - -If command is not even started, -256 is returned. - -=back - -Examples: - - execute( [ "cmd.exe", "/c", "dir" ] ); - # Execute NT shell with specified options, no redirections are - # made. - - my $output; - execute( [ "cvs", "-n", "-q", "update", "." ], -stdout => \$output ); - # Execute "cvs -n -q update ." command, output is saved - # in $output variable. - - my @output; - execute( [ qw( cvs -n -q update . ) ], -stdout => \@output, -stderr => undef ); - # Execute specified command, output is saved in @output - # variable, stderr stream is redirected to null device - # (/dev/null in Linux* OS and nul in Windows* OS). - -=cut - -sub execute($@) { - - # !!! Add something to complain on unknown options... - - my $command = shift( @_ ); - my %opts = @_; - my $prefix = "Could not execute $command->[ 0 ]"; - - check_opts( %opts, [ qw( -stdin -stdout -stderr -append -ignore_status -ignore_signal ) ] ); - - if ( ref( $command ) ne "ARRAY" ) { - Carp::croak( "execute: $command must be a reference to array" ); - }; # if - - my $stdin = { handle => \*STDIN, mode => "<" }; - my $stdout = { handle => \*STDOUT, mode => ">" }; - my $stderr = { handle => \*STDERR, mode => ">" }; - my $streams = { - stdin => $stdin, - stdout => $stdout, - stderr => $stderr - }; # $streams - - for my $stream ( qw( stdin stdout stderr ) ) { - if ( exists( $opts{ "-$stream" } ) ) { - if ( ref( $opts{ "-$stream" } ) !~ m/\A(|SCALAR|ARRAY)\z/ ) { - Carp::croak( "execute: -$stream option: must have value of scalar, or reference to (scalar or array)." ); - }; # if - $streams->{ $stream }->{ redir } = $opts{ "-$stream" }; - }; # if - if ( $opts{ -append } and ( $streams->{ $stream }->{ mode } ) eq ">" ) { - $streams->{ $stream }->{ mode } = ">>"; - }; # if - }; # foreach $stream - - _pre( $stdin ); - _pre( $stdout ); - if ( defined( $stderr->{ redir } ) and not ref( $stderr->{ redir } ) and ( $stderr->{ redir } eq "" ) ) { - if ( exists( $stdout->{ redir } ) ) { - $stderr->{ redir } = $stdout->{ temp_handle }; - } else { - $stderr->{ redir } = ${ $stdout->{ handle } }; - }; # if - }; # if - _pre( $stderr ); - my $rc = system( @$command ); - my $errno = $!; - my $child = $?; - _post( $stderr ); - _post( $stdout ); - _post( $stdin ); - - my $exit = 0; - my $signal_num = $child & 127; - my $exit_status = $child >> 8; - $@ = ""; - - if ( $rc == -1 ) { - $@ = "\"$command->[ 0 ]\" failed: $errno"; - $exit = -256; - if ( not $opts{ -ignore_signal } ) { - runtime_error( $@ ); - }; # if - } elsif ( $signal_num != 0 ) { - $@ = "\"$command->[ 0 ]\" failed due to signal $signal_num."; - $exit = - $signal_num; - if ( not $opts{ -ignore_signal } ) { - runtime_error( $@ ); - }; # if - } elsif ( $exit_status != 0 ) { - $@ = "\"$command->[ 0 ]\" returned non-zero status $exit_status."; - $exit = $exit_status; - if ( not $opts{ -ignore_status } ) { - runtime_error( $@ ); - }; # if - }; # if - - return $exit; - -}; # sub execute - -#-------------------------------------------------------------------------------------------------- - -=item C<backticks( [ @command ], @options )> - -Run specified program or shell command and return output. - -In scalar context entire output is returned in a single string. In list context list of strings -is returned. Function issues an error and exits script if any error occurs. - -=cut - - -sub backticks($@) { - - my $command = shift( @_ ); - my %opts = @_; - my @output; - - check_opts( %opts, [ qw( -chomp ) ] ); - - execute( $command, -stdout => \@output ); - - if ( $opts{ -chomp } ) { - chomp( @output ); - }; # if - - return ( wantarray() ? @output : join( "", @output ) ); - -}; # sub backticks - -#-------------------------------------------------------------------------------------------------- - -sub pad($$$) { - my ( $str, $length, $pad ) = @_; - my $lstr = length( $str ); # Length of source string. - if ( $lstr < $length ) { - my $lpad = length( $pad ); # Length of pad. - my $count = int( ( $length - $lstr ) / $lpad ); # Number of pad repetitions. - my $tail = $length - ( $lstr + $lpad * $count ); - $str = $str . ( $pad x $count ) . substr( $pad, 0, $tail ); - }; # if - return $str; -}; # sub pad - -# -------------------------------------------------------------------------------------------------- - -=back - -=cut - -#-------------------------------------------------------------------------------------------------- - -return 1; - -#-------------------------------------------------------------------------------------------------- - -=cut - -# End of file. diff --git a/openmp/runtime/tools/libomputils.py b/openmp/runtime/tools/libomputils.py new file mode 100644 index 0000000..c38b81d --- /dev/null +++ b/openmp/runtime/tools/libomputils.py @@ -0,0 +1,65 @@ +# +# //===----------------------------------------------------------------------===// +# // +# // 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 +# // +# //===----------------------------------------------------------------------===// +# + +import os +import subprocess +import sys + + +class ScriptError(Exception): + """Convenience class for user errors generated""" + + def __init__(self, msg): + super(Exception, self).__init__(msg) + + +def error(msg): + raise ScriptError(msg) + + +def print_line(msg, form="i"): + print("{}: ({}) {}".format(os.path.basename(sys.argv[0]), form, msg)) + + +def print_info_line(msg): + print_line(msg) + + +def print_error_line(msg): + print_line(msg, form="x") + + +class RunResult: + """ + Auxiliary class for execute_command() containing the + results of running a command + """ + + def __init__(self, args, stdout, stderr, returncode): + self.executable = args[0] + self.stdout = stdout.decode("utf-8") + self.stderr = stderr.decode("utf-8") + self.returncode = returncode + self.command = " ".join(args) + + +def execute_command(args): + """ + Run a command with arguments: args + + Return RunResult containing stdout, stderr, returncode + """ + handle = subprocess.Popen(args, stdout=subprocess.PIPE, stderr=subprocess.PIPE) + stdout, stderr = handle.communicate() + returncode = handle.wait() + return RunResult(args, stdout, stderr, returncode) + + +# end of file diff --git a/openmp/runtime/tools/message-converter.pl b/openmp/runtime/tools/message-converter.pl deleted file mode 100755 index 5cc2974..0000000 --- a/openmp/runtime/tools/message-converter.pl +++ /dev/null @@ -1,774 +0,0 @@ -#!/usr/bin/env perl - -# -#//===----------------------------------------------------------------------===// -#// -#// 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 -#// -#//===----------------------------------------------------------------------===// -# - -use strict; -use warnings; - -use File::Glob ":glob"; -use Encode qw{ encode }; - -use FindBin; -use lib "$FindBin::Bin/lib"; - -use tools; - -our $VERSION = "0.04"; -my $escape = qr{%}; -my $placeholder = qr{(\d)\$(s|l?[du])}; -my $target_os; - -my $sections = - { - meta => { short => "prp" }, # "prp" stands for "property". - strings => { short => "str" }, - formats => { short => "fmt" }, - messages => { short => "msg" }, - hints => { short => "hnt" }, - }; -my @sections = qw{ meta strings formats messages hints }; -# Assign section properties: long name, set number, base number. -map( $sections->{ $sections[ $_ ] }->{ long } = $sections[ $_ ], ( 0 .. @sections - 1 ) ); -map( $sections->{ $sections[ $_ ] }->{ set } = ( $_ + 1 ), ( 0 .. @sections - 1 ) ); -map( $sections->{ $sections[ $_ ] }->{ base } = ( ( $_ + 1 ) << 16 ), ( 0 .. @sections - 1 ) ); - -# Properties of Meta section. -my @properties = qw{ Language Country LangId Version Revision }; - - -sub _generate_comment($$$) { - - my ( $data, $open, $close ) = @_; - my $bulk = - $open . " Do not edit this file! " . $close . "\n" . - $open . " The file was generated from " . get_file( $data->{ "%meta" }->{ source } ) . - " by " . $tool . " on " . localtime() . ". " . $close . "\n"; - return $bulk; - -}; # sub _generate_comment - - -sub msg2sgn($) { - - # Convert message string to signature. Signature is a list of placeholders in sorted order. - # For example, signature of "%1$s value \"%2$s\" is invalid." is "%1$s %2$s". - - my ( $msg ) = @_; - my @placeholders; - pos( $msg ) = 0; - while ( $msg =~ m{\G.*?$escape$placeholder}g ) { - $placeholders[ $1 - 1 ] = "%$1\$$2"; - }; # while - for ( my $i = 1; $i <= @placeholders; ++ $i ) { - if ( not defined( $placeholders[ $i - 1 ] ) ) { - $placeholders[ $i - 1 ] = "%$i\$-"; - }; # if - }; # for $i - return join( " ", @placeholders ); - -}; # sub msg2sgn - - -sub msg2src($) { - - # Convert message string to a C string constant. - - my ( $msg ) = @_; - if ( $target_os eq "win" ) { - $msg =~ s{$escape$placeholder}{\%$1!$2!}g; - }; # if - return $msg; - -}; # sub msg2src - - -my $special = - { - "n" => "\n", - "t" => "\t", - }; - -sub msg2mc($) { - my ( $msg ) = @_; - $msg = msg2src( $msg ); # Get windows style placeholders. - $msg =~ s{\\(.)}{ exists( $special->{ $1 } ) ? $special->{ $1 } : $1 }ge; - return $msg; -}; # sub msg2mc - - - -sub parse_message($) { - - my ( $msg ) = @_; - pos( $msg ) = 0; - for ( ; ; ) { - if ( $msg !~ m{\G.*?$escape}gc ) { - last; - } - if ( $msg !~ m{\G$placeholder}gc ) { - return "Bad %-sequence near \"%" . substr( $msg, pos( $msg ), 7 ) . "\""; - }; # if - }; # forever - return undef; - -}; # sub parse_message - - -sub parse_source($) { - - my ( $name ) = @_; - - my @bulk = read_file( $name, -layer => ":utf8" ); - my $data = {}; - - my $line; - my $n = 0; # Line number. - my $obsolete = 0; # Counter of obsolete entries. - my $last_idx; - my %idents; - my $section; - - my $error = - sub { - my ( $n, $line, $msg ) = @_; - runtime_error( "Error parsing $name line $n: " . "$msg:\n" . " $line" ); - }; # sub - - foreach $line ( @bulk ) { - ++ $n; - # Skip empty lines and comments. - if ( $line =~ m{\A\s*(\n|#)} ) { - $last_idx = undef; - next; - }; # if - # Parse section header. - if ( $line =~ m{\A-\*-\s*([A-Z_]*)\s*-\*-\s*\n\z}i ) { - $section = ( lc( $1 ) ); - if ( not grep( $section eq $_, @sections ) ) { - $error->( $n, $line, "Unknown section \"$section\" specified" ); - }; # if - if ( exists( $data->{ $section } ) ) { - $error->( $n, $line, "Multiple sections of the same type specified" ); - }; # if - %idents = (); # Clean list of known message identifiers. - next; - }; # if - if ( not defined( $section ) ) { - $error->( $n, $line, "Section heading expected" ); - }; # if - # Parse section body. - if ( $section eq "meta" ) { - if ( $line =~ m{\A([A-Z_][A-Z_0-9]*)\s+"(.*)"\s*?\n?\z}i ) { - # Parse meta properties (such as Language, Country, and LangId). - my ( $property, $value ) = ( $1, $2 ); - if ( not grep( $_ eq $property , @properties ) ) { - $error->( $n, $line, "Unknown property \"$property\" specified" ); - }; # if - if ( exists( $data->{ "%meta" }->{ $property } ) ) { - $error->( $n, $line, "Property \"$property\" has already been specified" ); - }; # if - $data->{ "%meta" }->{ $property } = $value; - $last_idx = undef; - next; - }; # if - $error->( $n, $line, "Property line expected" ); - }; # if - # Parse message. - if ( $line =~ m{\A([A-Z_][A-Z_0-9]*)\s+"(.*)"\s*?\n?\z}i ) { - my ( $ident, $message ) = ( $1, $2 ); - if ( $ident eq "OBSOLETE" ) { - # If id is "OBSOLETE", add a unique suffix. It provides convenient way to mark - # obsolete messages. - ++ $obsolete; - $ident .= $obsolete; - }; # if - if ( exists( $idents{ $ident } ) ) { - $error->( $n, $line, "Identifier \"$ident\" is redefined" ); - }; # if - # Check %-sequences. - my $err = parse_message( $message ); - if ( $err ) { - $error->( $n, $line, $err ); - }; # if - # Save message. - push( @{ $data->{ $section } }, [ $ident, $message ] ); - $idents{ $ident } = 1; - $last_idx = @{ $data->{ $section } } - 1; - next; - }; # if - # Parse continuation line. - if ( $line =~ m{\A\s*"(.*)"\s*\z} ) { - my $message = $1; - if ( not defined( $last_idx ) ) { - $error->( $n, $line, "Unexpected continuation line" ); - }; # if - # Check %-sequences. - my $err = parse_message( $message ); - if ( $err ) { - $error->( $n, $line, $err ); - }; # if - # Save continuation. - $data->{ $section }->[ $last_idx ]->[ 1 ] .= $message; - next; - }; # if - $error->( $n, $line, "Message definition expected" ); - }; # foreach - $data->{ "%meta" }->{ source } = $name; - foreach my $section ( @sections ) { - if ( not exists( $data->{ $section } ) ) { - $data->{ $section } = []; - }; # if - }; # foreach $section - - foreach my $property ( @properties ) { - if ( not defined( $data->{ "%meta" }->{ $property } ) ) { - runtime_error( - "Error parsing $name: " . - "Required \"$property\" property is not specified" - ); - }; # if - push( @{ $data->{ meta } }, [ $property, $data->{ "%meta" }->{ $property } ] ); - }; # foreach - - return $data; - -}; # sub parse_source - - -sub generate_enum($$$) { - - my ( $data, $file, $prefix ) = @_; - my $bulk = ""; - - $bulk = - _generate_comment( $data, "//", "//" ) . - "\n" . - "enum ${prefix}_id {\n\n" . - " // A special id for absence of message.\n" . - " ${prefix}_null = 0,\n\n"; - - foreach my $section ( @sections ) { - my $props = $sections->{ $section }; # Section properties. - my $short = $props->{ short }; # Short section name, frequently used. - $bulk .= - " // Set #$props->{ set }, $props->{ long }.\n" . - " ${prefix}_${short}_first = $props->{ base },\n"; - foreach my $item ( @{ $data->{ $section } } ) { - my ( $ident, undef ) = @$item; - $bulk .= " ${prefix}_${short}_${ident},\n"; - }; # foreach - $bulk .= " ${prefix}_${short}_last,\n\n"; - }; # foreach $type - $bulk .= " ${prefix}_xxx_lastest\n\n"; - - $bulk .= - "}; // enum ${prefix}_id\n" . - "\n" . - "typedef enum ${prefix}_id ${prefix}_id_t;\n" . - "\n"; - - $bulk .= - "\n" . - "// end of file //\n"; - - write_file( $file, \$bulk ); - -}; # sub generate_enum - - -sub generate_signature($$) { - - my ( $data, $file ) = @_; - my $bulk = ""; - - $bulk .= "// message catalog signature file //\n\n"; - - foreach my $section ( @sections ) { - my $props = $sections->{ $section }; # Section properties. - my $short = $props->{ short }; # Short section name, frequently used. - $bulk .= "-*- " . uc( $props->{ long } ) . "-*-\n\n"; - foreach my $item ( @{ $data->{ $section } } ) { - my ( $ident, $msg ) = @$item; - $bulk .= sprintf( "%-40s %s\n", $ident, msg2sgn( $msg ) ); - }; # foreach - $bulk .= "\n"; - }; # foreach $type - - $bulk .= "// end of file //\n"; - - write_file( $file, \$bulk ); - -}; # sub generate_signature - - -sub generate_default($$$) { - - my ( $data, $file, $prefix ) = @_; - my $bulk = ""; - - $bulk .= - _generate_comment( $data, "//", "//" ) . - "\n"; - - foreach my $section ( @sections ) { - $bulk .= - "static char const *\n" . - "__${prefix}_default_${section}" . "[] =\n" . - " {\n" . - " NULL,\n"; - foreach my $item ( @{ $data->{ $section } } ) { - my ( undef, $msg ) = @$item; - $bulk .= " \"" . msg2src( $msg ) . "\",\n"; - }; # while - $bulk .= - " NULL\n" . - " };\n" . - "\n"; - }; # foreach $type - - $bulk .= - "struct kmp_i18n_section {\n" . - " int size;\n" . - " char const ** str;\n" . - "}; // struct kmp_i18n_section\n" . - "typedef struct kmp_i18n_section kmp_i18n_section_t;\n" . - "\n" . - "static kmp_i18n_section_t\n" . - "__${prefix}_sections[] =\n" . - " {\n" . - " { 0, NULL },\n"; - foreach my $section ( @sections ) { - $bulk .= - " { " . @{ $data->{ $section } } . ", __${prefix}_default_${section} },\n"; - }; # foreach $type - $bulk .= - " { 0, NULL }\n" . - " };\n" . - "\n"; - - $bulk .= - "struct kmp_i18n_table {\n" . - " int size;\n" . - " kmp_i18n_section_t * sect;\n" . - "}; // struct kmp_i18n_table\n" . - "typedef struct kmp_i18n_table kmp_i18n_table_t;\n" . - "\n" . - "static kmp_i18n_table_t __kmp_i18n_default_table =\n" . - " {\n" . - " " . @sections . ",\n" . - " __kmp_i18n_sections\n" . - " };\n" . - "\n" . - "// end of file //\n"; - - write_file( $file, \$bulk ); - -}; # sub generate_default - - -sub generate_message_unix($$) { - - my ( $data, $file ) = @_; - my $bulk = ""; - - $bulk .= - _generate_comment( $data, "\$", "\$" ) . - "\n" . - "\$quote \"\n\n"; - - foreach my $section ( @sections ) { - $bulk .= - "\$ " . ( "-" x 78 ) . "\n\$ $section\n\$ " . ( "-" x 78 ) . "\n\n" . - "\$set $sections->{ $section }->{ set }\n" . - "\n"; - my $n = 0; - foreach my $item ( @{ $data->{ $section } } ) { - my ( undef, $msg ) = @$item; - ++ $n; - $bulk .= "$n \"" . msg2src( $msg ) . "\"\n"; - }; # foreach - $bulk .= "\n"; - }; # foreach $type - - $bulk .= - "\n" . - "\$ end of file \$\n"; - - write_file( $file, \$bulk, -layer => ":utf8" ); - -}; # sub generate_message_linux - - -sub generate_message_windows($$) { - - my ( $data, $file ) = @_; - my $bulk = ""; - my $language = $data->{ "%meta" }->{ Language }; - my $langid = $data->{ "%meta" }->{ LangId }; - - $bulk .= - _generate_comment( $data, ";", ";" ) . - "\n" . - "LanguageNames = ($language=$langid:msg_$langid)\n" . - "\n"; - - $bulk .= - "FacilityNames=(\n"; - foreach my $section ( @sections ) { - my $props = $sections->{ $section }; # Section properties. - $bulk .= - " $props->{ short }=" . $props->{ set } ."\n"; - }; # foreach $section - $bulk .= - ")\n\n"; - - foreach my $section ( @sections ) { - my $short = $sections->{ $section }->{ short }; - my $n = 0; - foreach my $item ( @{ $data->{ $section } } ) { - my ( undef, $msg ) = @$item; - ++ $n; - $bulk .= - "MessageId=$n\n" . - "Facility=$short\n" . - "Language=$language\n" . - msg2mc( $msg ) . "\n.\n\n"; - }; # foreach $item - }; # foreach $section - - $bulk .= - "\n" . - "; end of file ;\n"; - - $bulk = encode( "UTF-16LE", $bulk ); # Convert text to UTF-16LE used in Windows* OS. - write_file( $file, \$bulk, -binary => 1 ); - -}; # sub generate_message_windows - - -# -# Parse command line. -# - -my $input_file; -my $enum_file; -my $signature_file; -my $default_file; -my $message_file; -my $id; -my $prefix = ""; -get_options( - "os=s" => \$target_os, - "enum-file=s" => \$enum_file, - "signature-file=s" => \$signature_file, - "default-file=s" => \$default_file, - "message-file=s" => \$message_file, - "id|lang-id" => \$id, - "prefix=s" => \$prefix, -); -if ( @ARGV == 0 ) { - cmdline_error( "No source file specified -- nothing to do" ); -}; # if -if ( @ARGV > 1 ) { - cmdline_error( "Too many source files specified" ); -}; # if -$input_file = $ARGV[ 0 ]; - - -my $generate_message; -if ( $target_os =~ m{\A(?:lin|mac)\z} ) { - $generate_message = \&generate_message_unix; -} elsif ( $target_os eq "win" ) { - $generate_message = \&generate_message_windows; -} else { - runtime_error( "OS \"$target_os\" is not supported" ); -}; # if - - -# -# Do the work. -# - -my $data = parse_source( $input_file ); -if ( defined( $id ) ) { - print( $data->{ "%meta" }->{ LangId }, "\n" ); -}; # if -if ( defined( $enum_file ) ) { - generate_enum( $data, $enum_file, $prefix ); -}; # if -if ( defined( $signature_file ) ) { - generate_signature( $data, $signature_file ); -}; # if -if ( defined( $default_file ) ) { - generate_default( $data, $default_file, $prefix ); -}; # if -if ( defined( $message_file ) ) { - $generate_message->( $data, $message_file ); -}; # if - -exit( 0 ); - -__END__ - -=pod - -=head1 NAME - -B<message-converter.pl> -- Convert message catalog source file into another text forms. - -=head1 SYNOPSIS - -B<message-converter.pl> I<option>... <file> - -=head1 OPTIONS - -=over - -=item B<--enum-file=>I<file> - -Generate enum file named I<file>. - -=item B<--default-file=>I<file> - -Generate default messages file named I<file>. - -=item B<--lang-id> - -Print language identifier of the message catalog source file. - -=item B<--message-file=>I<file> - -Generate message file. - -=item B<--signature-file=>I<file> - -Generate signature file. - -Signatures are used for checking compatibility. For example, to check a primary -catalog and its translation to another language, signatures of both catalogs should be generated -and compared. If signatures are identical, catalogs are compatible. - -=item B<--prefix=>I<prefix> - -Prefix to be used for all C identifiers (type and variable names) in enum and default messages -files. - -=item B<--os=>I<str> - -Specify OS name the message formats to be converted for. If not specified explicitly, value of -LIBOMP_OS environment variable is used. If LIBOMP_OS is not defined, host OS is detected. - -Depending on OS, B<message-converter.pl> converts message formats to GNU style or MS style. - -=item Standard Options - -=over - -=item B<--doc> - -=item B<--manual> - -Print full documentation and exit. - -=item B<--help> - -Print short help message and exit. - -=item B<--version> - -Print version string and exit. - -=back - -=back - -=head1 ARGUMENTS - -=over - -=item I<file> - -A name of input file. - -=back - -=head1 DESCRIPTION - -=head2 Message Catalog File Format - -It is plain text file in UTF-8 encoding. Empty lines and lines beginning with sharp sign (C<#>) are -ignored. EBNF syntax of content: - - catalog = { section }; - section = header body; - header = "-*- " section-id " -*-" "\n"; - body = { message }; - message = message-id string "\n" { string "\n" }; - section-id = identifier; - message-id = "OBSOLETE" | identifier; - identifier = letter { letter | digit | "_" }; - string = """ { character } """; - -Identifier starts with letter, with following letters, digits, and underscores. Identifiers are -case-sensitive. Setion identifiers are fixed: C<META>, C<STRINGS>, C<FORMATS>, C<MESSAGES> and -C<HINTS>. Message identifiers must be unique within section. Special C<OBSOLETE> pseudo-identifier -may be used many times. - -String is a C string literal which must not cross line boundaries. -Long messages may occupy multiple lines, a string per line. - -Message may include printf-like GNU-style placeholders for arguments: C<%I<n>$I<t>>, -where I<n> is argument number (C<1>, C<2>, ...), -I<t> -- argument type, C<s> (string) or C<d> (32-bit integer). - -See also comments in F<i18n/en_US.txt>. - -=head2 Output Files - -This script can generate 3 different text files from single source: - -=over - -=item Enum file. - -Enum file is a C include file, containing definitions of message identifiers, e. g.: - - enum kmp_i18n_id { - - // Set #1, meta. - kmp_i18n_prp_first = 65536, - kmp_i18n_prp_Language, - kmp_i18n_prp_Country, - kmp_i18n_prp_LangId, - kmp_i18n_prp_Version, - kmp_i18n_prp_Revision, - kmp_i18n_prp_last, - - // Set #2, strings. - kmp_i18n_str_first = 131072, - kmp_i18n_str_Error, - kmp_i18n_str_UnknownFile, - kmp_i18n_str_NotANumber, - ... - - // Set #3, formats. - ... - - kmp_i18n_xxx_lastest - - }; // enum kmp_i18n_id - - typedef enum kmp_i18n_id kmp_i18n_id_t; - -=item Default messages file. - -Default messages file is a C include file containing default messages to be embedded into -application (and used if external message catalog does not exist or could not be open): - - static char const * - __kmp_i18n_default_meta[] = - { - NULL, - "English", - "USA", - "1033", - "2", - "20090806", - NULL - }; - - static char const * - __kmp_i18n_default_strings[] = - { - "Error", - "(unknown file)", - "not a number", - ... - NULL - }; - - ... - -=item Message file. - -Message file is an input for message compiler, F<gencat> on Linux* OS and OS X*, or F<mc.exe> on -Windows* OS. - -Here is the example of Linux* OS message file: - - $quote " - 1 "Japanese" - 2 "Japan" - 3 "1041" - 4 "2" - 5 "Based on English message catalog revision 20090806" - ... - -Example of Windows* OS message file: - - LanguageNames = (Japanese=10041:msg_1041) - - FacilityNames = ( - prp=1 - str=2 - fmt=3 - ... - ) - - MessageId=1 - Facility=prp - Language=Japanese - Japanese - . - - ... - -=item Signature. - -Signature is a processed source file: comments stripped, strings deleted, but placeholders kept and -sorted. - - -*- FORMATS-*- - - Info %1$d %2$s - Warning %1$d %2$s - Fatal %1$d %2$s - SysErr %1$d %2$s - Hint %1$- %2$s - Pragma %1$s %2$s %3$s %4$s - -The purpose of signatures -- compare two message source files for compatibility. If signatures of -two message sources are the same, binary message catalogs will be compatible. - -=back - -=head1 EXAMPLES - -Generate include file containing message identifiers: - - $ message-converter.pl --enum-file=kmp_i18n_id.inc en_US.txt - -Generate include file containing default messages: - - $ message-converter.pl --default-file=kmp_i18n_default.inc en_US.txt - -Generate input file for message compiler, Linux* OS example: - - $ message-converter.pl --message-file=ru_RU.UTF-8.msg ru_RU.txt - -Generate input file for message compiler, Windows* OS example: - - > message-converter.pl --message-file=ru_RU.UTF-8.mc ru_RU.txt - -=cut - -# end of file # - diff --git a/openmp/runtime/tools/message-converter.py b/openmp/runtime/tools/message-converter.py new file mode 100644 index 0000000..b3e0b34 --- /dev/null +++ b/openmp/runtime/tools/message-converter.py @@ -0,0 +1,394 @@ +#!/usr/bin/env python3 + +# +# //===----------------------------------------------------------------------===// +# // +# // 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 +# // +# //===----------------------------------------------------------------------===// +# + +import argparse +import datetime +import os +import platform +import re +import sys +from libomputils import ScriptError, error + + +class ParseMessageDataError(ScriptError): + """Convenience class for parsing message data file errors""" + + def __init__(self, filename, line, msg): + super(ParseMessageDataError, self).__init__(msg) + self.filename = filename + self.line = line + + +def parse_error(filename, line, msg): + raise ParseMessageDataError(filename, line, msg) + + +def display_language_id(inputFile): + """Quickly parse file for LangId and print it""" + regex = re.compile(r'^LangId\s+"([0-9]+)"') + with open(inputFile, encoding="utf-8") as f: + for line in f: + m = regex.search(line) + if not m: + continue + print(m.group(1)) + + +class Message(object): + special = { + "n": "\n", + "t": "\t", + } + + def __init__(self, lineNumber, name, text): + self.lineNumber = lineNumber + self.name = name + self.text = text + + def toSrc(self): + if platform.system() == "Windows": + return re.sub(r"%([0-9])\$(s|l?[du])", r"%\1!\2!", self.text) + return str(self.text) + + def toMC(self): + retval = self.toSrc() + for special, substitute in Message.special.items(): + retval = re.sub(r"\\{}".format(special), substitute, retval) + return retval + + +class MessageData(object): + """ + Convenience class representing message data parsed from i18n/* files + + Generate these objects using static create() factory method + """ + + sectionInfo = { + "meta": {"short": "prp", "long": "meta", "set": 1, "base": 1 << 16}, + "strings": {"short": "str", "long": "strings", "set": 2, "base": 2 << 16}, + "formats": {"short": "fmt", "long": "formats", "set": 3, "base": 3 << 16}, + "messages": {"short": "msg", "long": "messages", "set": 4, "base": 4 << 16}, + "hints": {"short": "hnt", "long": "hints", "set": 5, "base": 5 << 16}, + } + orderedSections = ["meta", "strings", "formats", "messages", "hints"] + + def __init__(self): + self.filename = None + self.sections = {} + + def getMeta(self, name): + metaList = self.sections["meta"] + for meta in metaList: + if meta.name == name: + return meta.text + error( + 'No "{}" detected in meta data' " for file {}".format(name, self.filename) + ) + + @staticmethod + def create(inputFile): + """Creates MessageData object from inputFile""" + data = MessageData() + data.filename = os.path.abspath(inputFile) + obsolete = 1 + sectionRegex = re.compile(r"-\*- ([a-zA-Z0-9_]+) -\*-") + keyValueRegex = re.compile(r'([a-zA-Z_][a-zA-Z0-9_]*)\s+"(.*)"') + moreValueRegex = re.compile(r'"(.*)"') + + with open(inputFile, "r", encoding="utf-8") as f: + currentSection = None + currentKey = None + for lineNumber, line in enumerate(f, 1): + line = line.strip() + # Skip empty lines + if not line: + continue + # Skip comment lines + if line.startswith("#"): + continue + # Matched a section header + match = sectionRegex.search(line) + if match: + currentSection = match.group(1).lower() + if currentSection in data.sections: + parse_error( + inputFile, + lineNumber, + "section: {} already defined".format(currentSection), + ) + data.sections[currentSection] = [] + continue + # Matched a Key "Value" line (most lines) + match = keyValueRegex.search(line) + if match: + if not currentSection: + parse_error(inputFile, lineNumber, "no section defined yet.") + key = match.group(1) + if key == "OBSOLETE": + key = "OBSOLETE{}".format(obsolete) + obsolete += 1 + value = match.group(2) + currentKey = key + data.sections[currentSection].append( + Message(lineNumber, key, value) + ) + continue + # Matched a Continuation of string line + match = moreValueRegex.search(line) + if match: + value = match.group(1) + if not currentSection: + parse_error(inputFile, lineNumber, "no section defined yet.") + if not currentKey: + parse_error(inputFile, lineNumber, "no key defined yet.") + data.sections[currentSection][-1].text += value + continue + # Unknown line syntax + parse_error(inputFile, lineNumber, "bad line:\n{}".format(line)) + return data + + +def insert_header(f, data, commentChar="//"): + f.write( + "{0} Do not edit this file! {0}\n" + "{0} The file was generated from" + " {1} by {2} on {3}. {0}\n\n".format( + commentChar, + os.path.basename(data.filename), + os.path.basename(__file__), + datetime.datetime.now().ctime(), + ) + ) + + +def generate_enum_file(enumFile, prefix, data): + """Create the include file with message enums""" + global g_sections + with open(enumFile, "w") as f: + insert_header(f, data) + f.write( + "enum {0}_id {1}\n" + "\n" + " // A special id for absence of message.\n" + " {0}_null = 0,\n" + "\n".format(prefix, "{") + ) + for section in MessageData.orderedSections: + messages = data.sections[section] + info = MessageData.sectionInfo[section] + shortName = info["short"] + longName = info["long"] + base = info["base"] + setIdx = info["set"] + f.write( + " // Set #{}, {}.\n" + " {}_{}_first = {},\n".format( + setIdx, longName, prefix, shortName, base + ) + ) + for message in messages: + f.write(" {}_{}_{},\n".format(prefix, shortName, message.name)) + f.write(" {}_{}_last,\n\n".format(prefix, shortName)) + f.write( + " {0}_xxx_lastest\n\n" + "{1}; // enum {0}_id\n\n" + "typedef enum {0}_id {0}_id_t;\n\n\n" + "// end of file //\n".format(prefix, "}") + ) + + +def generate_signature_file(signatureFile, data): + """Create the signature file""" + sigRegex = re.compile(r"(%[0-9]\$(s|l?[du]))") + with open(signatureFile, "w") as f: + f.write("// message catalog signature file //\n\n") + for section in MessageData.orderedSections: + messages = data.sections[section] + longName = MessageData.sectionInfo[section]["long"] + f.write("-*- {}-*-\n\n".format(longName.upper())) + for message in messages: + sigs = sorted(list(set([a for a, b in sigRegex.findall(message.text)]))) + i = 0 + # Insert empty placeholders if necessary + while i != len(sigs): + num = i + 1 + if not sigs[i].startswith("%{}".format(num)): + sigs.insert(i, "%{}$-".format(num)) + else: + i += 1 + f.write("{:<40} {}\n".format(message.name, " ".join(sigs))) + f.write("\n") + f.write("// end of file //\n") + + +def generate_default_messages_file(defaultFile, prefix, data): + """Create the include file with message strings organized""" + with open(defaultFile, "w", encoding="utf-8") as f: + insert_header(f, data) + for section in MessageData.orderedSections: + f.write( + "static char const *\n" + "__{}_default_{}[] =\n" + " {}\n" + " NULL,\n".format(prefix, section, "{") + ) + messages = data.sections[section] + for message in messages: + f.write(' "{}",\n'.format(message.toSrc())) + f.write(" NULL\n" " {};\n\n".format("}")) + f.write( + "struct kmp_i18n_section {0}\n" + " int size;\n" + " char const ** str;\n" + "{1}; // struct kmp_i18n_section\n" + "typedef struct kmp_i18n_section kmp_i18n_section_t;\n\n" + "static kmp_i18n_section_t\n" + "__{2}_sections[] =\n" + " {0}\n" + " {0} 0, NULL {1},\n".format("{", "}", prefix) + ) + + for section in MessageData.orderedSections: + messages = data.sections[section] + f.write( + " {} {}, __{}_default_{} {},\n".format( + "{", len(messages), prefix, section, "}" + ) + ) + numSections = len(MessageData.orderedSections) + f.write( + " {0} 0, NULL {1}\n" + " {1};\n\n" + "struct kmp_i18n_table {0}\n" + " int size;\n" + " kmp_i18n_section_t * sect;\n" + "{1}; // struct kmp_i18n_table\n" + "typedef struct kmp_i18n_table kmp_i18n_table_t;\n\n" + "static kmp_i18n_table_t __kmp_i18n_default_table =\n" + " {0}\n" + " {3},\n" + " __{2}_sections\n" + " {1};\n\n" + "// end of file //\n".format("{", "}", prefix, numSections) + ) + + +def generate_message_file_unix(messageFile, data): + """ + Create the message file for Unix OSes + + Encoding is in UTF-8 + """ + with open(messageFile, "w", encoding="utf-8") as f: + insert_header(f, data, commentChar="$") + f.write('$quote "\n\n') + for section in MessageData.orderedSections: + setIdx = MessageData.sectionInfo[section]["set"] + f.write( + "$ ------------------------------------------------------------------------------\n" + "$ {}\n" + "$ ------------------------------------------------------------------------------\n\n" + "$set {}\n\n".format(section, setIdx) + ) + messages = data.sections[section] + for num, message in enumerate(messages, 1): + f.write('{} "{}"\n'.format(num, message.toSrc())) + f.write("\n") + f.write("\n$ end of file $") + + +def generate_message_file_windows(messageFile, data): + """ + Create the message file for Windows OS + + Encoding is in UTF-16LE + """ + language = data.getMeta("Language") + langId = data.getMeta("LangId") + with open(messageFile, "w", encoding="utf-16-le") as f: + insert_header(f, data, commentChar=";") + f.write("\nLanguageNames = ({0}={1}:msg_{1})\n\n".format(language, langId)) + f.write("FacilityNames=(\n") + for section in MessageData.orderedSections: + setIdx = MessageData.sectionInfo[section]["set"] + shortName = MessageData.sectionInfo[section]["short"] + f.write(" {}={}\n".format(shortName, setIdx)) + f.write(")\n\n") + + for section in MessageData.orderedSections: + shortName = MessageData.sectionInfo[section]["short"] + n = 0 + messages = data.sections[section] + for message in messages: + n += 1 + f.write( + "MessageId={}\n" + "Facility={}\n" + "Language={}\n" + "{}\n.\n\n".format(n, shortName, language, message.toMC()) + ) + f.write("\n; end of file ;") + + +def main(): + parser = argparse.ArgumentParser(description="Generate message data files") + parser.add_argument( + "--lang-id", + action="store_true", + help="Print language identifier of the message catalog source file", + ) + parser.add_argument( + "--prefix", + default="kmp_i18n", + help="Prefix to be used for all C identifiers (type and variable names)" + " in enum and default message files.", + ) + parser.add_argument("--enum", metavar="FILE", help="Generate enum file named FILE") + parser.add_argument( + "--default", metavar="FILE", help="Generate default messages file named FILE" + ) + parser.add_argument( + "--signature", metavar="FILE", help="Generate signature file named FILE" + ) + parser.add_argument( + "--message", metavar="FILE", help="Generate message file named FILE" + ) + parser.add_argument("inputfile") + commandArgs = parser.parse_args() + + if commandArgs.lang_id: + display_language_id(commandArgs.inputfile) + return + data = MessageData.create(commandArgs.inputfile) + prefix = commandArgs.prefix + if commandArgs.enum: + generate_enum_file(commandArgs.enum, prefix, data) + if commandArgs.default: + generate_default_messages_file(commandArgs.default, prefix, data) + if commandArgs.signature: + generate_signature_file(commandArgs.signature, data) + if commandArgs.message: + if platform.system() == "Windows": + generate_message_file_windows(commandArgs.message, data) + else: + generate_message_file_unix(commandArgs.message, data) + + +if __name__ == "__main__": + try: + main() + except ScriptError as e: + print("error: {}".format(e)) + sys.exit(1) + +# end of file |