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