First attempt to import OpenMP runtime

llvm-svn: 191506

5 files changed, 3339 insertions, 0 deletions

diff --git a/openmp/runtime/tools/lib/Build.pm b/openmp/runtime/tools/lib/Build.pm
new file mode 100644
index 00000000000..cf671569e02
--- /dev/null
+++ b/openmp/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/openmp/runtime/tools/lib/LibOMP.pm b/openmp/runtime/tools/lib/LibOMP.pm
new file mode 100644
index 00000000000..06a371f6e06
--- /dev/null
+++ b/openmp/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/openmp/runtime/tools/lib/Platform.pm b/openmp/runtime/tools/lib/Platform.pm
new file mode 100644
index 00000000000..584eeb7491f
--- /dev/null
+++ b/openmp/runtime/tools/lib/Platform.pm
@@ -0,0 +1,386 @@
+#
+# 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_os $target_platform };
+}
+
+our $VERSION     = "0.014";
+our @EXPORT      = qw{};
+our @EXPORT_OK   = ( qw{ canon_arch canon_os 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";
+        } else {
+            $arch = undef;
+        }; # if
+    }; # if
+    return $arch;
+}; # sub canon_arch
+
+{  # Return legal approved architecture name.
+    my %legal = (
+        "32"  => "IA-32 architecture",
+        "32e" => "Intel(R) 64",
+    );
+
+    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",
+    );
+
+    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*(?:lrb)\s*\z}i ) {
+            $os = "lrb";
+        } 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 );
+
+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_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";
+           },
+    );
+    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";
+    } 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 "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 "Uknown 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 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 "Uknown 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_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_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 {
+        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>, 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<lrb>,
+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/openmp/runtime/tools/lib/Uname.pm b/openmp/runtime/tools/lib/Uname.pm
new file mode 100644
index 00000000000..f978f8b8a83
--- /dev/null
+++ b/openmp/runtime/tools/lib/Uname.pm
@@ -0,0 +1,623 @@
+#
+# 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 } )
+    );
+    # Auxillary 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" ) {
+    if ( 0 ) {
+    } elsif ( $values{ machine } =~ m{\Ai[3456]86\z} ) {
+        $values{ hardware_platform } = "i386";
+    } elsif ( $values{ machine } =~ m{\Ax86_64\z} ) {
+        $values{ hardware_platform } = "x86_64";
+    } 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 choosen "*-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";
+} else {
+    die "Unsuppoprted 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();
+
+    # Auxillary 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 Auxillary Functions
+
+Auxillary functions extends base functions with information not reported by C<uname> program.
+
+Auxillary functions collect information from different sources. For example, on OS X*, they may
+call C<sw_vers> program to find out OS release; on Linux* OS they may parse C</etc/redhat-release> file,
+etc.
+
+=over
+
+=item B<host_name()>
+
+Returns host name (FQDN with dropped domain part).
+
+=item B<domain_name()>
+
+Returns domain name (FQDN with dropped host part).
+
+=item B<operating_system_name>
+
+Name of operating system or name of Linux* OS distribution, like "Fedora" or
+"Red Hat Enterprise Linux* OS Server".
+
+=item B<operating_system_release>
+
+Release (version) of operating system or Linux* OS distribution. Usually it is a series of
+dot-separated numbers.
+
+=item B<operating_system_codename>
+
+Codename of operating system release or Linux* OS distribution. For example, Fedora 10 is "Cambridge"
+while OS X* 10.4 is "Tiger".
+
+=item B<operating_system_description>
+
+Longer string. Usually it includes all the operating system properting mentioned above -- name,
+release, codename in parentheses.
+
+=back
+
+=head2 Meta Functions
+
+=over
+
+=item B<base_names()>
+
+This function returns the list of base property names.
+
+=item B<all_names()>
+
+This function returns the list of all property names.
+
+=item B<value(> I<name> B<)>
+
+This function returns the value of the property specified by I<name>.
+
+=back
+
+=head1 EXAMPLES
+
+    use Uname;
+
+    print( Uname::string(), "\n" );
+
+    foreach my $name ( Uname::all_names() ) {
+        print( "$name=\"" . Uname::value( $name ) . "\"\n" );
+    }; # foreach $name
+
+=head1 SEE ALSO
+
+L<POSIX::uname>, L<uname>.
+
+=cut
+
+# end of file #
+
diff --git a/openmp/runtime/tools/lib/tools.pm b/openmp/runtime/tools/lib/tools.pm
new file mode 100644
index 00000000000..23feb505332
--- /dev/null
+++ b/openmp/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 aready 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 occurence 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 occured, 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.