openmp/runtime/tools/lib/tools.pm

   1 #
   2 # This is not a runnable script, it is a Perl module, a collection of variables, subroutines, etc.
   3 # to be used in other scripts.
   4 #
   5 # To get help about exported variables and subroutines, please execute the following command:
   6 #
   7 #     perldoc tools.pm
   8 #
   9 # or see POD (Plain Old Documentation) imbedded to the source...
  10 #
  11 #
  12 #//===----------------------------------------------------------------------===//
  13 #//
  14 #// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
  15 #// See https://llvm.org/LICENSE.txt for license information.
  16 #// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
  17 #//
  18 #//===----------------------------------------------------------------------===//
  19 #
  20
  21 =head1 NAME
  22
  23 B<tools.pm> -- A collection of subroutines which are widely used in Perl scripts.
  24
  25 =head1 SYNOPSIS
  26
  27     use FindBin;
  28     use lib "$FindBin::Bin/lib";
  29     use tools;
  30
  31 =head1 DESCRIPTION
  32
  33 B<Note:> Because this collection is small and intended for widely using in particular project,
  34 all variables and functions are exported by default.
  35
  36 B<Note:> I have some ideas how to improve this collection, but it is in my long-term plans.
  37 Current shape is not ideal, but good enough to use.
  38
  39 =cut
  40
  41 package tools;
  42
  43 use strict;
  44 use warnings;
  45
  46 use vars qw( @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS );
  47 require Exporter;
  48 @ISA = qw( Exporter );
  49
  50 my @vars   = qw( $tool );
  51 my @utils  = qw( check_opts validate );
  52 my @opts   = qw( get_options );
  53 my @print  = qw( debug info warning cmdline_error runtime_error question );
  54 my @name   = qw( get_vol get_dir get_file get_name get_ext cat_file cat_dir );
  55 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 );
  56 my @io     = qw( read_file write_file );
  57 my @exec   = qw( execute backticks );
  58 my @string = qw{ pad };
  59 @EXPORT = ( @utils, @opts, @vars, @print, @name, @file, @io, @exec, @string );
  60
  61 use UNIVERSAL    ();
  62
  63 use FindBin;
  64 use IO::Handle;
  65 use IO::File;
  66 use IO::Dir;
  67 # Not available on some machines: use IO::Zlib;
  68
  69 use Getopt::Long ();
  70 use Pod::Usage   ();
  71 use Carp         ();
  72 use File::Copy   ();
  73 use File::Path   ();
  74 use File::Temp   ();
  75 use File::Spec   ();
  76 use POSIX        qw{ :fcntl_h :errno_h };
  77 use Cwd          ();
  78 use Symbol       ();
  79
  80 use Data::Dumper;
  81
  82 use vars qw( $tool $verbose $timestamps );
  83 $tool = $FindBin::Script;
  84
  85 my @warning = ( sub {}, \&warning, \&runtime_error );
  86
  87
  88 sub check_opts(\%$;$) {
  89
  90     my $opts = shift( @_ );  # Reference to hash containing real options and their values.
  91     my $good = shift( @_ );  # Reference to an array containing all known option names.
  92     my $msg  = shift( @_ );  # Optional (non-mandatory) message.
  93
  94     if ( not defined( $msg ) ) {
  95         $msg = "unknown option(s) passed";   # Default value for $msg.
  96     }; # if
  97
  98     # I'll use these hashes as sets of options.
  99     my %good = map( ( $_ => 1 ), @$good );   # %good now is filled with all known options.
 100     my %bad;                                 # %bad is empty.
 101
 102     foreach my $opt ( keys( %$opts ) ) {     # For each real option...
 103         if ( not exists( $good{ $opt } ) ) { # Look its name in the set of known options...
 104             $bad{ $opt } = 1;                # Add unknown option to %bad set.
 105             delete( $opts->{ $opt } );       # And delete original option.
 106         }; # if
 107     }; # foreach $opt
 108     if ( %bad ) {                            # If %bad set is not empty...
 109         my @caller = caller( 1 );            # Issue a warning.
 110         local $Carp::CarpLevel = 2;
 111         Carp::cluck( $caller[ 3 ] . ": " . $msg . ": " . join( ", ", sort( keys( %bad ) ) ) );
 112     }; # if
 113
 114     return 1;
 115
 116 }; # sub check_opts
 117
 118
 119 # --------------------------------------------------------------------------------------------------
 120 # Purpose:
 121 #     Check subroutine arguments.
 122 # Synopsis:
 123 #     my %opts = validate( params => \@_, spec => { ... }, caller => n );
 124 # Arguments:
 125 #     params -- A reference to subroutine's actual arguments.
 126 #     spec   -- Specification of expected arguments.
 127 #     caller -- ...
 128 # Return value:
 129 #     A hash of validated options.
 130 # Description:
 131 #     I would like to use Params::Validate module, but it is not a part of default Perl
 132 #     distribution, so I cannot rely on it. This subroutine resembles to some extent to
 133 #     Params::Validate::validate_with().
 134 #     Specification of expected arguments:
 135 #        { $opt => { type => $type, default => $default }, ... }
 136 #        $opt     -- String, option name.
 137 #        $type    -- String, expected type(s). Allowed values are "SCALAR", "UNDEF", "BOOLEAN",
 138 #                    "ARRAYREF", "HASHREF", "CODEREF". Multiple types may listed using bar:
 139 #                    "SCALAR|ARRAYREF". The type string is case-insensitive.
 140 #        $default -- Default value for an option. Will be used if option is not specified or
 141 #                    undefined.
 142 #
 143 sub validate(@) {
 144
 145     my %opts = @_;    # Temporary use %opts for parameters of `validate' subroutine.
 146     my $params = $opts{ params };
 147     my $caller = ( $opts{ caller } or 0 ) + 1;
 148     my $spec   = $opts{ spec };
 149     undef( %opts );   # Ok, Clean %opts, now we will collect result of the subroutine.
 150
 151     # Find out caller package, filename, line, and subroutine name.
 152     my ( $pkg, $file, $line, $subr ) = caller( $caller );
 153     my @errors;    # We will collect errors in array not to stop on the first found error.
 154     my $error =
 155         sub ($) {
 156             my $msg = shift( @_ );
 157             push( @errors, "$msg at $file line $line.\n" );
 158         }; # sub
 159
 160     # Check options.
 161     while ( @$params ) {
 162         # Check option name.
 163         my $opt = shift( @$params );
 164         if ( not exists( $spec->{ $opt } ) ) {
 165             $error->( "Invalid option `$opt'" );
 166             shift( @$params ); # Skip value of unknow option.
 167             next;
 168         }; # if
 169         # Check option value exists.
 170         if ( not @$params ) {
 171             $error->( "Option `$opt' does not have a value" );
 172             next;
 173         }; # if
 174         my $val = shift( @$params );
 175         # Check option value type.
 176         if ( exists( $spec->{ $opt }->{ type } ) ) {
 177             # Type specification exists. Check option value type.
 178             my $actual_type;
 179             if ( ref( $val ) ne "" ) {
 180                 $actual_type = ref( $val ) . "REF";
 181             } else {
 182                 $actual_type = ( defined( $val ) ? "SCALAR" : "UNDEF" );
 183             }; # if
 184             my @wanted_types = split( m{\|}, lc( $spec->{ $opt }->{ type } ) );
 185             my $wanted_types = join( "|", map( $_ eq "boolean" ? "scalar|undef" : quotemeta( $_ ), @wanted_types ) );
 186             if ( $actual_type !~ m{\A(?:$wanted_types)\z}i ) {
 187                 $actual_type = lc( $actual_type );
 188                 $wanted_types = lc( join( " or ", map( "`$_'", @wanted_types ) ) );
 189                 $error->( "Option `$opt' value type is `$actual_type' but expected to be $wanted_types" );
 190                 next;
 191             }; # if
 192         }; # if
 193         if ( exists( $spec->{ $opt }->{ values } )  ) {
 194             my $values = $spec->{ $opt }->{ values };
 195             if ( not grep( $_ eq $val, @$values ) ) {
 196                 $values = join( ", ", map( "`$_'", @$values ) );
 197                 $error->( "Option `$opt' value is `$val' but expected to be one of $values" );
 198                 next;
 199             }; # if
 200         }; # if
 201         $opts{ $opt } = $val;
 202     }; # while
 203
 204     # Assign default values.
 205     foreach my $opt ( keys( %$spec ) ) {
 206         if ( not defined( $opts{ $opt } ) and exists( $spec->{ $opt }->{ default } ) ) {
 207             $opts{ $opt } = $spec->{ $opt }->{ default };
 208         }; # if
 209     }; # foreach $opt
 210
 211     # If we found any errors, raise them.
 212     if ( @errors ) {
 213         die join( "", @errors );
 214     }; # if
 215
 216     return %opts;
 217
 218 }; # sub validate
 219
 220 # =================================================================================================
 221 # Get option helpers.
 222 # =================================================================================================
 223
 224 =head2 Get option helpers.
 225
 226 =cut
 227
 228 # -------------------------------------------------------------------------------------------------
 229
 230 =head3 get_options
 231
 232 B<Synopsis:>
 233
 234     get_options( @arguments )
 235
 236 B<Description:>
 237
 238 It is very simple wrapper arounf Getopt::Long::GetOptions. It passes all arguments to GetOptions,
 239 and add definitions for standard help options: --help, --doc, --verbose, and --quiet.
 240 When GetOptions finishes, this subroutine checks exit code, if it is non-zero, standard error
 241 message is issued and script terminated.
 242
 243 If --verbose or --quiet option is specified, C<tools.pm_verbose> environment variable is set.
 244 It is the way to propagate verbose/quiet mode to callee Perl scripts.
 245
 246 =cut
 247
 248 sub get_options {
 249
 250     Getopt::Long::Configure( "no_ignore_case" );
 251     Getopt::Long::GetOptions(
 252         "h0|usage"        => sub { Pod::Usage::pod2usage( -exitval => 0, -verbose => 0 ); },
 253         "h1|h|help"       => sub { Pod::Usage::pod2usage( -exitval => 0, -verbose => 1 ); },
 254         "h2|doc|manual"   => sub { Pod::Usage::pod2usage( -exitval => 0, -verbose => 2 ); },
 255         "version"         => sub { print( "$tool version $main::VERSION\n" ); exit( 0 ); },
 256         "v|verbose"       => sub { ++ $verbose;     $ENV{ "tools.pm_verbose"    } = $verbose;    },
 257         "quiet"           => sub { -- $verbose;     $ENV{ "tools.pm_verbose"    } = $verbose;    },
 258         "with-timestamps" => sub { $timestamps = 1; $ENV{ "tools.pm_timestamps" } = $timestamps; },
 259         @_, # Caller arguments are at the end so caller options overrides standard.
 260     ) or cmdline_error();
 261
 262 }; # sub get_options
 263
 264
 265 # =================================================================================================
 266 # Print utilities.
 267 # =================================================================================================
 268
 269 =pod
 270
 271 =head2 Print utilities.
 272
 273 Each of the print subroutines prepends each line of its output with the name of current script and
 274 the type of information, for example:
 275
 276     info( "Writing file..." );
 277
 278 will print
 279
 280     <script>: (i): Writing file...
 281
 282 while
 283
 284     warning( "File does not exist!" );
 285
 286 will print
 287
 288     <script>: (!): File does not exist!
 289
 290 Here are exported items:
 291
 292 =cut
 293
 294 # -------------------------------------------------------------------------------------------------
 295
 296 sub _format_message($\@;$) {
 297
 298     my $prefix  = shift( @_ );
 299     my $args    = shift( @_ );
 300     my $no_eol  = shift( @_ );  # Do not append "\n" to the last line.
 301     my $message = "";
 302
 303     my $ts = "";
 304     if ( $timestamps ) {
 305         my ( $sec, $min, $hour, $day, $month, $year ) = gmtime();
 306         $month += 1;
 307         $year  += 1900;
 308         $ts = sprintf( "%04d-%02d-%02d %02d:%02d:%02d UTC: ", $year, $month, $day, $hour, $min, $sec );
 309     }; # if
 310     for my $i ( 1 .. @$args ) {
 311         my @lines = split( "\n", $args->[ $i - 1 ] );
 312         for my $j ( 1 .. @lines ) {
 313             my $line = $lines[ $j - 1 ];
 314             my $last_line = ( ( $i == @$args ) and ( $j == @lines ) );
 315             my $eol = ( ( substr( $line, -1 ) eq "\n" ) or defined( $no_eol ) ? "" : "\n" );
 316             $message .= "$ts$tool: ($prefix) " . $line . $eol;
 317         }; # foreach $j
 318     }; # foreach $i
 319     return $message;
 320
 321 }; # sub _format_message
 322
 323 #--------------------------------------------------------------------------------------------------
 324
 325 =pod
 326
 327 =head3 $verbose
 328
 329 B<Synopsis:>
 330
 331     $verbose
 332
 333 B<Description:>
 334
 335 Package variable. It determines verbosity level, which affects C<warning()>, C<info()>, and
 336 C<debug()> subroutines .
 337
 338 The variable gets initial value from C<tools.pm_verbose> environment variable if it is exists.
 339 If the environment variable does not exist, variable is set to 2.
 340
 341 Initial value may be overridden later directly or by C<get_options> function.
 342
 343 =cut
 344
 345 $verbose = exists( $ENV{ "tools.pm_verbose" } ) ? $ENV{ "tools.pm_verbose" } : 2;
 346
 347 #--------------------------------------------------------------------------------------------------
 348
 349 =pod
 350
 351 =head3 $timestamps
 352
 353 B<Synopsis:>
 354
 355     $timestamps
 356
 357 B<Description:>
 358
 359 Package variable. It determines whether C<debug()>, C<info()>, C<warning()>, C<runtime_error()>
 360 subroutines print timestamps or not.
 361
 362 The variable gets initial value from C<tools.pm_timestamps> environment variable if it is exists.
 363 If the environment variable does not exist, variable is set to false.
 364
 365 Initial value may be overridden later directly or by C<get_options()> function.
 366
 367 =cut
 368
 369 $timestamps = exists( $ENV{ "tools.pm_timestamps" } ) ? $ENV{ "tools.pm_timestamps" } : 0;
 370
 371 # -------------------------------------------------------------------------------------------------
 372
 373 =pod
 374
 375 =head3 debug
 376
 377 B<Synopsis:>
 378
 379     debug( @messages )
 380
 381 B<Description:>
 382
 383 If verbosity level is 3 or higher, print debug information to the stderr, prepending it with "(#)"
 384 prefix.
 385
 386 =cut
 387
 388 sub debug(@) {
 389
 390     if ( $verbose >= 3 ) {
 391         STDOUT->flush();
 392         STDERR->print( _format_message( "#", @_ ) );
 393     }; # if
 394     return 1;
 395
 396 }; # sub debug
 397
 398 #--------------------------------------------------------------------------------------------------
 399
 400 =pod
 401
 402 =head3 info
 403
 404 B<Synopsis:>
 405
 406     info( @messages )
 407
 408 B<Description:>
 409
 410 If verbosity level is 2 or higher, print information to the stderr, prepending it with "(i)" prefix.
 411
 412 =cut
 413
 414 sub info(@) {
 415
 416     if ( $verbose >= 2 ) {
 417         STDOUT->flush();
 418         STDERR->print( _format_message( "i", @_  ) );
 419     }; # if
 420
 421 }; # sub info
 422
 423 #--------------------------------------------------------------------------------------------------
 424
 425 =head3 warning
 426
 427 B<Synopsis:>
 428
 429     warning( @messages )
 430
 431 B<Description:>
 432
 433 If verbosity level is 1 or higher, issue a warning, prepending it with "(!)" prefix.
 434
 435 =cut
 436
 437 sub warning(@) {
 438
 439     if ( $verbose >= 1 ) {
 440         STDOUT->flush();
 441         warn( _format_message( "!", @_  ) );
 442     }; # if
 443
 444 }; # sub warning
 445
 446 # -------------------------------------------------------------------------------------------------
 447
 448 =head3 cmdline_error
 449
 450 B<Synopsis:>
 451
 452     cmdline_error( @message )
 453
 454 B<Description:>
 455
 456 Print error message and exit the program with status 2.
 457
 458 This function is intended to complain on command line errors, e. g. unknown
 459 options, invalid arguments, etc.
 460
 461 =cut
 462
 463 sub cmdline_error(;$) {
 464
 465     my $message = shift( @_ );
 466
 467     if ( defined( $message ) ) {
 468         if ( substr( $message, -1, 1 ) ne "\n" ) {
 469             $message .= "\n";
 470         }; # if
 471     } else {
 472         $message = "";
 473     }; # if
 474     STDOUT->flush();
 475     die $message . "Try --help option for more information.\n";
 476
 477 }; # sub cmdline_error
 478
 479 # -------------------------------------------------------------------------------------------------
 480
 481 =head3 runtime_error
 482
 483 B<Synopsis:>
 484
 485     runtime_error( @message )
 486
 487 B<Description:>
 488
 489 Print error message and exits the program with status 3.
 490
 491 This function is intended to complain on runtime errors, e. g.
 492 directories which are not found, non-writable files, etc.
 493
 494 =cut
 495
 496 sub runtime_error(@) {
 497
 498     STDOUT->flush();
 499     die _format_message( "x", @_ );
 500
 501 }; # sub runtime_error
 502
 503 #--------------------------------------------------------------------------------------------------
 504
 505 =head3 question
 506
 507 B<Synopsis:>
 508
 509     question( $prompt; $answer, $choices  )
 510
 511 B<Description:>
 512
 513 Print $promp to the stderr, prepending it with "question:" prefix. Read a line from stdin, chop
 514 "\n" from the end, it is answer.
 515
 516 If $answer is defined, it is treated as first user input.
 517
 518 If $choices is specified, it could be a regexp for validating user input, or a string. In latter
 519 case it interpreted as list of characters, acceptable (case-insensitive) choices. If user enters
 520 non-acceptable answer, question continue asking until answer is acceptable.
 521 If $choices is not specified, any answer is acceptable.
 522
 523 In case of end-of-file (or Ctrl+D pressed by user), $answer is C<undef>.
 524
 525 B<Examples:>
 526
 527     my $answer;
 528     question( "Save file [yn]? ", $answer, "yn" );
 529         # We accepts only "y", "Y", "n", or "N".
 530     question( "Press enter to continue or Ctrl+C to abort..." );
 531         # We are not interested in answer value -- in case of Ctrl+C the script will be terminated,
 532         # otherwise we continue execution.
 533     question( "File name? ", $answer );
 534         # Any answer is acceptable.
 535
 536 =cut
 537
 538 sub question($;\$$) {
 539
 540     my $prompt  = shift( @_ );
 541     my $answer  = shift( @_ );
 542     my $choices = shift( @_ );
 543     my $a       = ( defined( $answer ) ? $$answer : undef );
 544
 545     if ( ref( $choices ) eq "Regexp" ) {
 546         # It is already a regular expression, do nothing.
 547     } elsif ( defined( $choices ) ) {
 548         # Convert string to a regular expression.
 549         $choices = qr/[@{ [ quotemeta( $choices ) ] }]/i;
 550     }; # if
 551
 552     for ( ; ; ) {
 553         STDERR->print( _format_message( "?", @{ [ $prompt ] }, "no_eol" ) );
 554         STDERR->flush();
 555         if ( defined( $a ) ) {
 556             STDOUT->print( $a . "\n" );
 557         } else {
 558             $a = <STDIN>;
 559         }; # if
 560         if ( not defined( $a ) ) {
 561             last;
 562         }; # if
 563         chomp( $a );
 564         if ( not defined( $choices ) or ( $a =~ m/^$choices$/ ) ) {
 565             last;
 566         }; # if
 567         $a = undef;
 568     }; # forever
 569     if ( defined( $answer ) ) {
 570         $$answer = $a;
 571     }; # if
 572
 573 }; # sub question
 574
 575 # -------------------------------------------------------------------------------------------------
 576
 577 # Returns volume part of path.
 578 sub get_vol($) {
 579
 580     my $path = shift( @_ );
 581     my ( $vol, undef, undef ) = File::Spec->splitpath( $path );
 582     return $vol;
 583
 584 }; # sub get_vol
 585
 586 # Returns directory part of path.
 587 sub get_dir($) {
 588
 589     my $path = File::Spec->canonpath( shift( @_ ) );
 590     my ( $vol, $dir, undef ) = File::Spec->splitpath( $path );
 591     my @dirs = File::Spec->splitdir( $dir );
 592     pop( @dirs );
 593     $dir = File::Spec->catdir( @dirs );
 594     $dir = File::Spec->catpath( $vol, $dir, undef );
 595     return $dir;
 596
 597 }; # sub get_dir
 598
 599 # Returns file part of path.
 600 sub get_file($) {
 601
 602     my $path = shift( @_ );
 603     my ( undef, undef, $file ) = File::Spec->splitpath( $path );
 604     return $file;
 605
 606 }; # sub get_file
 607
 608 # Returns file part of path without last suffix.
 609 sub get_name($) {
 610
 611     my $path = shift( @_ );
 612     my ( undef, undef, $file ) = File::Spec->splitpath( $path );
 613     $file =~ s{\.[^.]*\z}{};
 614     return $file;
 615
 616 }; # sub get_name
 617
 618 # Returns last suffix of file part of path.
 619 sub get_ext($) {
 620
 621     my $path = shift( @_ );
 622     my ( undef, undef, $file ) = File::Spec->splitpath( $path );
 623     my $ext = "";
 624     if ( $file =~ m{(\.[^.]*)\z} ) {
 625         $ext = $1;
 626     }; # if
 627     return $ext;
 628
 629 }; # sub get_ext
 630
 631 sub cat_file(@) {
 632
 633     my $path = shift( @_ );
 634     my $file = pop( @_ );
 635     my @dirs = @_;
 636
 637     my ( $vol, $dirs ) = File::Spec->splitpath( $path, "no_file" );
 638     @dirs = ( File::Spec->splitdir( $dirs ), @dirs );
 639     $dirs = File::Spec->catdir( @dirs );
 640     $path = File::Spec->catpath( $vol, $dirs, $file );
 641
 642     return $path;
 643
 644 }; # sub cat_file
 645
 646 sub cat_dir(@) {
 647
 648     my $path = shift( @_ );
 649     my @dirs = @_;
 650
 651     my ( $vol, $dirs ) = File::Spec->splitpath( $path, "no_file" );
 652     @dirs = ( File::Spec->splitdir( $dirs ), @dirs );
 653     $dirs = File::Spec->catdir( @dirs );
 654     $path = File::Spec->catpath( $vol, $dirs, "" );
 655
 656     return $path;
 657
 658 }; # sub cat_dir
 659
 660 # =================================================================================================
 661 # File and directory manipulation subroutines.
 662 # =================================================================================================
 663
 664 =head2 File and directory manipulation subroutines.
 665
 666 =over
 667
 668 =cut
 669
 670 # -------------------------------------------------------------------------------------------------
 671
 672 =item C<which( $file, @options )>
 673
 674 Searches for specified executable file in the (specified) directories.
 675 Raises a runtime eroror if no executable file found. Returns a full path of found executable(s).
 676
 677 Options:
 678
 679 =over
 680
 681 =item C<-all> =E<gt> I<bool>
 682
 683 Do not stop on the first found file. Note, that list of full paths is returned in this case.
 684
 685 =item C<-dirs> =E<gt> I<ref_to_array>
 686
 687 Specify directory list to search through. If option is not passed, PATH environment variable
 688 is used for directory list.
 689
 690 =item C<-exec> =E<gt> I<bool>
 691
 692 Whether check for executable files or not. By default, C<which> searches executable files.
 693 However, on Cygwin executable check never performed.
 694
 695 =back
 696
 697 Examples:
 698
 699 Look for "echo" in the directories specified in PATH:
 700
 701     my $echo = which( "echo" );
 702
 703 Look for all occurrences of "cp" in the PATH:
 704
 705     my @cps = which( "cp", -all => 1 );
 706
 707 Look for the first occurrence of "icc" in the specified directories:
 708
 709     my $icc = which( "icc", -dirs => [ ".", "/usr/local/bin", "/usr/bin", "/bin" ] );
 710
 711 =cut
 712
 713 sub which($@) {
 714
 715     my $file = shift( @_ );
 716     my %opts = @_;
 717
 718     check_opts( %opts, [ qw( -all -dirs -exec ) ] );
 719     if ( $opts{ -all } and not wantarray() ) {
 720         local $Carp::CarpLevel = 1;
 721         Carp::cluck( "`-all' option passed to `which' but list is not expected" );
 722     }; # if
 723     if ( not defined( $opts{ -exec } ) ) {
 724         $opts{ -exec } = 1;
 725     }; # if
 726
 727     my $dirs = ( exists( $opts{ -dirs } ) ? $opts{ -dirs } : [ File::Spec->path() ] );
 728     my @found;
 729
 730     my @exts = ( "" );
 731     if ( $^O eq "MSWin32" and $opts{ -exec } ) {
 732         if ( defined( $ENV{ PATHEXT } ) ) {
 733             push( @exts, split( ";", $ENV{ PATHEXT } ) );
 734         } else {
 735             # If PATHEXT does not exist, use default value.
 736             push( @exts, qw{ .COM .EXE .BAT .CMD } );
 737         }; # if
 738     }; # if
 739
 740     loop:
 741     foreach my $dir ( @$dirs ) {
 742         foreach my $ext ( @exts ) {
 743             my $path = File::Spec->catfile( $dir, $file . $ext );
 744             if ( -e $path ) {
 745                 # Executable bit is not reliable on Cygwin, do not check it.
 746                 if ( not $opts{ -exec } or -x $path or $^O eq "cygwin" ) {
 747                     push( @found, $path );
 748                     if ( not $opts{ -all } ) {
 749                         last loop;
 750                     }; # if
 751                 }; # if
 752             }; # if
 753         }; # foreach $ext
 754     }; # foreach $dir
 755
 756     if ( not @found ) {
 757         # TBD: We need to introduce an option for conditional enabling this error.
 758         # runtime_error( "Could not find \"$file\" executable file in PATH." );
 759     }; # if
 760     if ( @found > 1 ) {
 761         # TBD: Issue a warning?
 762     }; # if
 763
 764     if ( $opts{ -all } ) {
 765         return @found;
 766     } else {
 767         return $found[ 0 ];
 768     }; # if
 769
 770 }; # sub which
 771
 772 # -------------------------------------------------------------------------------------------------
 773
 774 =item C<abs_path( $path, $base )>
 775
 776 Return absolute path for an argument.
 777
 778 Most of the work is done by C<File::Spec->rel2abs()>. C<abs_path()> additionally collapses
 779 C<dir1/../dir2> to C<dir2>.
 780
 781 It is not so naive and made intentionally. For example on Linux* OS in Bash if F<link/> is a symbolic
 782 link to directory F<some_dir/>
 783
 784     $ cd link
 785     $ cd ..
 786
 787 brings you back to F<link/>'s parent, not to parent of F<some_dir/>,
 788
 789 =cut
 790
 791 sub abs_path($;$) {
 792
 793     my ( $path, $base ) = @_;
 794     $path = File::Spec->rel2abs( $path, ( defined( $base ) ? $base : $ENV{ PWD } ) );
 795     my ( $vol, $dir, $file ) = File::Spec->splitpath( $path );
 796     while ( $dir =~ s{/(?!\.\.)[^/]*/\.\.(?:/|\z)}{/} ) {
 797     }; # while
 798     $path = File::Spec->canonpath( File::Spec->catpath( $vol, $dir, $file ) );
 799     return $path;
 800
 801 }; # sub abs_path
 802
 803 # -------------------------------------------------------------------------------------------------
 804
 805 =item C<rel_path( $path, $base )>
 806
 807 Return relative path for an argument.
 808
 809 =cut
 810
 811 sub rel_path($;$) {
 812
 813     my ( $path, $base ) = @_;
 814     $path = File::Spec->abs2rel( abs_path( $path ), $base );
 815     return $path;
 816
 817 }; # sub rel_path
 818
 819 # -------------------------------------------------------------------------------------------------
 820
 821 =item C<real_path( $dir )>
 822
 823 Return real absolute path for an argument. In the result all relative components (F<.> and F<..>)
 824 and U<symbolic links are resolved>.
 825
 826 In most cases it is not what you want. Consider using C<abs_path> first.
 827
 828 C<abs_path> function from B<Cwd> module works with directories only. This function works with files
 829 as well. But, if file is a symbolic link, function does not resolve it (yet).
 830
 831 The function uses C<runtime_error> to raise an error if something wrong.
 832
 833 =cut
 834
 835 sub real_path($) {
 836
 837     my $orig_path = shift( @_ );
 838     my $real_path;
 839     my $message = "";
 840     if ( not -e $orig_path ) {
 841         $message = "\"$orig_path\" does not exists";
 842     } else {
 843         # Cwd::abs_path does not work with files, so in this case we should handle file separately.
 844         my $file;
 845         if ( not -d $orig_path ) {
 846             ( my $vol, my $dir, $file ) = File::Spec->splitpath( File::Spec->rel2abs( $orig_path ) );
 847             $orig_path = File::Spec->catpath( $vol, $dir );
 848         }; # if
 849         {
 850             local $SIG{ __WARN__ } = sub { $message = $_[ 0 ]; };
 851             $real_path = Cwd::abs_path( $orig_path );
 852         };
 853         if ( defined( $file ) ) {
 854             $real_path = File::Spec->catfile( $real_path, $file );
 855         }; # if
 856     }; # if
 857     if ( not defined( $real_path ) or $message ne "" ) {
 858         $message =~ s/^stat\(.*\): (.*)\s+at .*? line \d+\s*\z/$1/;
 859         runtime_error( "Could not find real path for \"$orig_path\"" . ( $message ne "" ? ": $message" : "" ) );
 860     }; # if
 861     return $real_path;
 862
 863 }; # sub real_path
 864
 865 # -------------------------------------------------------------------------------------------------
 866
 867 =item C<make_dir( $dir, @options )>
 868
 869 Make a directory.
 870
 871 This function makes a directory. If necessary, more than one level can be created.
 872 If directory exists, warning issues (the script behavior depends on value of
 873 C<-warning_level> option). If directory creation fails or C<$dir> exists but it is not a
 874 directory, error issues.
 875
 876 Options:
 877
 878 =over
 879
 880 =item C<-mode>
 881
 882 The numeric mode for new directories, 0750 (rwxr-x---) by default.
 883
 884 =back
 885
 886 =cut
 887
 888 sub make_dir($@) {
 889
 890     my $dir    = shift( @_ );
 891     my %opts   =
 892         validate(
 893             params => \@_,
 894             spec => {
 895                 parents => { type => "boolean", default => 1    },
 896                 mode    => { type => "scalar",  default => 0777 },
 897             },
 898         );
 899
 900     my $prefix = "Could not create directory \"$dir\"";
 901
 902     if ( -e $dir ) {
 903         if ( -d $dir ) {
 904         } else {
 905             runtime_error( "$prefix: it exists, but not a directory." );
 906         }; # if
 907     } else {
 908         eval {
 909             File::Path::mkpath( $dir, 0, $opts{ mode } );
 910         }; # eval
 911         if ( $@ ) {
 912             $@ =~ s{\s+at (?:[a-zA-Z0-9 /_.]*/)?tools\.pm line \d+\s*}{};
 913             runtime_error( "$prefix: $@" );
 914         }; # if
 915         if ( not -d $dir ) { # Just in case, check it one more time...
 916             runtime_error( "$prefix." );
 917         }; # if
 918     }; # if
 919
 920 }; # sub make_dir
 921
 922 # -------------------------------------------------------------------------------------------------
 923
 924 =item C<copy_dir( $src_dir, $dst_dir, @options )>
 925
 926 Copy directory recursively.
 927
 928 This function copies a directory recursively.
 929 If source directory does not exist or not a directory, error issues.
 930
 931 Options:
 932
 933 =over
 934
 935 =item C<-overwrite>
 936
 937 Overwrite destination directory, if it exists.
 938
 939 =back
 940
 941 =cut
 942
 943 sub copy_dir($$@) {
 944
 945     my $src  = shift( @_ );
 946     my $dst  = shift( @_ );
 947     my %opts = @_;
 948     my $prefix = "Could not copy directory \"$src\" to \"$dst\"";
 949
 950     if ( not -e $src ) {
 951         runtime_error( "$prefix: \"$src\" does not exist." );
 952     }; # if
 953     if ( not -d $src ) {
 954         runtime_error( "$prefix: \"$src\" is not a directory." );
 955     }; # if
 956     if ( -e $dst ) {
 957         if ( -d $dst ) {
 958             if ( $opts{ -overwrite } ) {
 959                 del_dir( $dst );
 960             } else {
 961                 runtime_error( "$prefix: \"$dst\" already exists." );
 962             }; # if
 963         } else {
 964             runtime_error( "$prefix: \"$dst\" is not a directory." );
 965         }; # if
 966     }; # if
 967
 968     execute( [ "cp", "-R", $src, $dst ] );
 969
 970 }; # sub copy_dir
 971
 972 # -------------------------------------------------------------------------------------------------
 973
 974 =item C<move_dir( $src_dir, $dst_dir, @options )>
 975
 976 Move directory.
 977
 978 Options:
 979
 980 =over
 981
 982 =item C<-overwrite>
 983
 984 Overwrite destination directory, if it exists.
 985
 986 =back
 987
 988 =cut
 989
 990 sub move_dir($$@) {
 991
 992     my $src  = shift( @_ );
 993     my $dst  = shift( @_ );
 994     my %opts = @_;
 995     my $prefix = "Could not copy directory \"$src\" to \"$dst\"";
 996
 997     if ( not -e $src ) {
 998         runtime_error( "$prefix: \"$src\" does not exist." );
 999     }; # if
1000     if ( not -d $src ) {
1001         runtime_error( "$prefix: \"$src\" is not a directory." );
1002     }; # if
1003     if ( -e $dst ) {
1004         if ( -d $dst ) {
1005             if ( $opts{ -overwrite } ) {
1006                 del_dir( $dst );
1007             } else {
1008                 runtime_error( "$prefix: \"$dst\" already exists." );
1009             }; # if
1010         } else {
1011             runtime_error( "$prefix: \"$dst\" is not a directory." );
1012         }; # if
1013     }; # if
1014
1015     execute( [ "mv", $src, $dst ] );
1016
1017 }; # sub move_dir
1018
1019 # -------------------------------------------------------------------------------------------------
1020
1021 =item C<clean_dir( $dir, @options )>
1022
1023 Clean a directory: delete all the entries (recursively), but leave the directory.
1024
1025 Options:
1026
1027 =over
1028
1029 =item C<-force> => bool
1030
1031 If a directory is not writable, try to change permissions first, then clean it.
1032
1033 =item C<-skip> => regexp
1034
1035 Regexp. If a directory entry mached the regexp, it is skipped, not deleted. (As a subsequence,
1036 a directory containing skipped entries is not deleted.)
1037
1038 =back
1039
1040 =cut
1041
1042 sub _clean_dir($);
1043
1044 sub _clean_dir($) {
1045     our %_clean_dir_opts;
1046     my ( $dir ) = @_;
1047     my $skip    = $_clean_dir_opts{ skip };    # Regexp.
1048     my $skipped = 0;                           # Number of skipped files.
1049     my $prefix  = "Cleaning `$dir' failed:";
1050     my @stat    = stat( $dir );
1051     my $mode    = $stat[ 2 ];
1052     if ( not @stat ) {
1053         runtime_error( $prefix, "Cannot stat `$dir': $!" );
1054     }; # if
1055     if ( not -d _ ) {
1056         runtime_error( $prefix, "It is not a directory." );
1057     }; # if
1058     if ( not -w _ ) {        # Directory is not writable.
1059         if ( not -o _ or not $_clean_dir_opts{ force } ) {
1060             runtime_error( $prefix, "Directory is not writable." );
1061         }; # if
1062         # Directory is not writable but mine. Try to change permissions.
1063         chmod( $mode | S_IWUSR, $dir )
1064             or runtime_error( $prefix, "Cannot make directory writable: $!" );
1065     }; # if
1066     my $handle   = IO::Dir->new( $dir ) or runtime_error( $prefix, "Cannot read directory: $!" );
1067     my @entries  = File::Spec->no_upwards( $handle->read() );
1068     $handle->close() or runtime_error( $prefix, "Cannot read directory: $!" );
1069     foreach my $entry ( @entries ) {
1070         my $path = cat_file( $dir, $entry );
1071         if ( defined( $skip ) and $entry =~ $skip ) {
1072             ++ $skipped;
1073         } else {
1074             if ( -l $path ) {
1075                 unlink( $path ) or runtime_error( $prefix, "Cannot delete symlink `$path': $!" );
1076             } else {
1077                 stat( $path ) or runtime_error( $prefix, "Cannot stat `$path': $! " );
1078                 if ( -f _ ) {
1079                     del_file( $path );
1080                 } elsif ( -d _ ) {
1081                     my $rc = _clean_dir( $path );
1082                     if ( $rc == 0 ) {
1083                         rmdir( $path ) or runtime_error( $prefix, "Cannot delete directory `$path': $!" );
1084                     }; # if
1085                     $skipped += $rc;
1086                 } else {
1087                     runtime_error( $prefix, "`$path' is neither a file nor a directory." );
1088                 }; # if
1089             }; # if
1090         }; # if
1091     }; # foreach
1092     return $skipped;
1093 }; # sub _clean_dir
1094
1095
1096 sub clean_dir($@) {
1097     my $dir  = shift( @_ );
1098     our %_clean_dir_opts;
1099     local %_clean_dir_opts =
1100         validate(
1101             params => \@_,
1102             spec => {
1103                 skip  => { type => "regexpref" },
1104                 force => { type => "boolean"   },
1105             },
1106         );
1107     my $skipped = _clean_dir( $dir );
1108     return $skipped;
1109 }; # sub clean_dir
1110
1111
1112 # -------------------------------------------------------------------------------------------------
1113
1114 =item C<del_dir( $dir, @options )>
1115
1116 Delete a directory recursively.
1117
1118 This function deletes a directory. If directory can not be deleted or it is not a directory, error
1119 message issues (and script exists).
1120
1121 Options:
1122
1123 =over
1124
1125 =back
1126
1127 =cut
1128
1129 sub del_dir($@) {
1130
1131     my $dir  = shift( @_ );
1132     my %opts = @_;
1133     my $prefix = "Deleting directory \"$dir\" failed";
1134     our %_clean_dir_opts;
1135     local %_clean_dir_opts =
1136         validate(
1137             params => \@_,
1138             spec => {
1139                 force => { type => "boolean" },
1140             },
1141         );
1142
1143     if ( not -e $dir ) {
1144         # Nothing to do.
1145         return;
1146     }; # if
1147     if ( not -d $dir ) {
1148         runtime_error( "$prefix: it is not a directory." );
1149     }; # if
1150     _clean_dir( $dir );
1151     rmdir( $dir ) or runtime_error( "$prefix." );
1152
1153 }; # sub del_dir
1154
1155 # -------------------------------------------------------------------------------------------------
1156
1157 =item C<change_dir( $dir )>
1158
1159 Change current directory.
1160
1161 If any error occurred, error issues and script exits.
1162
1163 =cut
1164
1165 sub change_dir($) {
1166
1167     my $dir = shift( @_ );
1168
1169     Cwd::chdir( $dir )
1170         or runtime_error( "Could not chdir to \"$dir\": $!" );
1171
1172 }; # sub change_dir
1173
1174
1175 # -------------------------------------------------------------------------------------------------
1176
1177 =item C<copy_file( $src_file, $dst_file, @options )>
1178
1179 Copy file.
1180
1181 This function copies a file. If source does not exist or is not a file, error issues.
1182
1183 Options:
1184
1185 =over
1186
1187 =item C<-overwrite>
1188
1189 Overwrite destination file, if it exists.
1190
1191 =back
1192
1193 =cut
1194
1195 sub copy_file($$@) {
1196
1197     my $src  = shift( @_ );
1198     my $dst  = shift( @_ );
1199     my %opts = @_;
1200     my $prefix = "Could not copy file \"$src\" to \"$dst\"";
1201
1202     if ( not -e $src ) {
1203         runtime_error( "$prefix: \"$src\" does not exist." );
1204     }; # if
1205     if ( not -f $src ) {
1206         runtime_error( "$prefix: \"$src\" is not a file." );
1207     }; # if
1208     if ( -e $dst ) {
1209         if ( -f $dst ) {
1210             if ( $opts{ -overwrite } ) {
1211                 del_file( $dst );
1212             } else {
1213                 runtime_error( "$prefix: \"$dst\" already exists." );
1214             }; # if
1215         } else {
1216             runtime_error( "$prefix: \"$dst\" is not a file." );
1217         }; # if
1218     }; # if
1219
1220     File::Copy::copy( $src, $dst ) or runtime_error( "$prefix: $!" );
1221     # On Windows* OS File::Copy preserves file attributes, but on Linux* OS it doesn't.
1222     # So we should do it manually...
1223     if ( $^O =~ m/^linux\z/ ) {
1224         my $mode = ( stat( $src ) )[ 2 ]
1225             or runtime_error( "$prefix: cannot get status info for source file." );
1226         chmod( $mode, $dst )
1227             or runtime_error( "$prefix: cannot change mode of destination file." );
1228     }; # if
1229
1230 }; # sub copy_file
1231
1232 # -------------------------------------------------------------------------------------------------
1233
1234 sub move_file($$@) {
1235
1236     my $src  = shift( @_ );
1237     my $dst  = shift( @_ );
1238     my %opts = @_;
1239     my $prefix = "Could not move file \"$src\" to \"$dst\"";
1240
1241     check_opts( %opts, [ qw( -overwrite ) ] );
1242
1243     if ( not -e $src ) {
1244         runtime_error( "$prefix: \"$src\" does not exist." );
1245     }; # if
1246     if ( not -f $src ) {
1247         runtime_error( "$prefix: \"$src\" is not a file." );
1248     }; # if
1249     if ( -e $dst ) {
1250         if ( -f $dst ) {
1251             if ( $opts{ -overwrite } ) {
1252                 #
1253             } else {
1254                 runtime_error( "$prefix: \"$dst\" already exists." );
1255             }; # if
1256         } else {
1257             runtime_error( "$prefix: \"$dst\" is not a file." );
1258         }; # if
1259     }; # if
1260
1261     File::Copy::move( $src, $dst ) or runtime_error( "$prefix: $!" );
1262
1263 }; # sub move_file
1264
1265 # -------------------------------------------------------------------------------------------------
1266
1267 sub del_file($) {
1268     my $files = shift( @_ );
1269     if ( ref( $files ) eq "" ) {
1270         $files = [ $files ];
1271     }; # if
1272     foreach my $file ( @$files ) {
1273         debug( "Deleting file `$file'..." );
1274         my $rc = unlink( $file );
1275         if ( $rc == 0 && $! != ENOENT ) {
1276             # Reporn an error, but ignore ENOENT, because the goal is achieved.
1277             runtime_error( "Deleting file `$file' failed: $!" );
1278         }; # if
1279     }; # foreach $file
1280 }; # sub del_file
1281
1282 # -------------------------------------------------------------------------------------------------
1283
1284 =back
1285
1286 =cut
1287
1288 # =================================================================================================
1289 # File I/O subroutines.
1290 # =================================================================================================
1291
1292 =head2 File I/O subroutines.
1293
1294 =cut
1295
1296 #--------------------------------------------------------------------------------------------------
1297
1298 =head3 read_file
1299
1300 B<Synopsis:>
1301
1302     read_file( $file, @options )
1303
1304 B<Description:>
1305
1306 Read file and return its content. In scalar context function returns a scalar, in list context
1307 function returns list of lines.
1308
1309 Note: If the last of file does not terminate with newline, function will append it.
1310
1311 B<Arguments:>
1312
1313 =over
1314
1315 =item B<$file>
1316
1317 A name or handle of file to read from.
1318
1319 =back
1320
1321 B<Options:>
1322
1323 =over
1324
1325 =item B<-binary>
1326
1327 If true, file treats as a binary file: no newline conversion, no truncating trailing space, no
1328 newline removing performed. Entire file returned as a scalar.
1329
1330 =item B<-bulk>
1331
1332 This option is allowed only in binary mode. Option's value should be a reference to a scalar.
1333 If option present, file content placed to pointee scalar and function returns true (1).
1334
1335 =item B<-chomp>
1336
1337 If true, newline characters are removed from file content. By default newline characters remain.
1338 This option is not applicable in binary mode.
1339
1340 =item B<-keep_trailing_space>
1341
1342 If true, trainling space remain at the ends of lines. By default all trailing spaces are removed.
1343 This option is not applicable in binary mode.
1344
1345 =back
1346
1347 B<Examples:>
1348
1349 Return file as single line, remove trailing spaces.
1350
1351     my $bulk = read_file( "message.txt" );
1352
1353 Return file as list of lines with removed trailing space and
1354 newline characters.
1355
1356     my @bulk = read_file( "message.txt", -chomp => 1 );
1357
1358 Read a binary file:
1359
1360     my $bulk = read_file( "message.txt", -binary => 1 );
1361
1362 Read a big binary file:
1363
1364     my $bulk;
1365     read_file( "big_binary_file", -binary => 1, -bulk => \$bulk );
1366
1367 Read from standard input:
1368
1369     my @bulk = read_file( \*STDIN );
1370
1371 =cut
1372
1373 sub read_file($@) {
1374
1375     my $file = shift( @_ );  # The name or handle of file to read from.
1376     my %opts = @_;           # Options.
1377
1378     my $name;
1379     my $handle;
1380     my @bulk;
1381     my $error = \&runtime_error;
1382
1383     my @binopts = qw( -binary -error -bulk );                       # Options available in binary mode.
1384     my @txtopts = qw( -binary -error -keep_trailing_space -chomp -layer ); # Options available in text (non-binary) mode.
1385     check_opts( %opts, [ @binopts, @txtopts ] );
1386     if ( $opts{ -binary } ) {
1387         check_opts( %opts, [ @binopts ], "these options cannot be used with -binary" );
1388     } else {
1389         check_opts( %opts, [ @txtopts ], "these options cannot be used without -binary" );
1390     }; # if
1391     if ( not exists( $opts{ -error } ) ) {
1392         $opts{ -error } = "error";
1393     }; # if
1394     if ( $opts{ -error } eq "warning" ) {
1395         $error = \&warning;
1396     } elsif( $opts{ -error } eq "ignore" ) {
1397         $error = sub {};
1398     } elsif ( ref( $opts{ -error } ) eq "ARRAY" ) {
1399         $error = sub { push( @{ $opts{ -error } }, $_[ 0 ] ); };
1400     }; # if
1401
1402     if ( ( ref( $file ) eq "GLOB" ) or UNIVERSAL::isa( $file, "IO::Handle" ) ) {
1403         $name = "unknown";
1404         $handle = $file;
1405     } else {
1406         $name = $file;
1407         if ( get_ext( $file ) eq ".gz" and not $opts{ -binary } ) {
1408             $handle = IO::Zlib->new( $name, "rb" );
1409         } else {
1410             $handle = IO::File->new( $name, "r" );
1411         }; # if
1412         if ( not defined( $handle ) ) {
1413             $error->( "File \"$name\" could not be opened for input: $!" );
1414         }; # if
1415     }; # if
1416     if ( defined( $handle ) ) {
1417         if ( $opts{ -binary } ) {
1418             binmode( $handle );
1419             local $/ = undef;   # Set input record separator to undef to read entire file as one line.
1420             if ( exists( $opts{ -bulk } ) ) {
1421                 ${ $opts{ -bulk } } = $handle->getline();
1422             } else {
1423                 $bulk[ 0 ] = $handle->getline();
1424             }; # if
1425         } else {
1426             if ( defined( $opts{ -layer } ) ) {
1427                 binmode( $handle, $opts{ -layer } );
1428             }; # if
1429             @bulk = $handle->getlines();
1430             # Special trick for UTF-8 files: Delete BOM, if any.
1431             if ( defined( $opts{ -layer } ) and $opts{ -layer } eq ":utf8" ) {
1432                 if ( substr( $bulk[ 0 ], 0, 1 ) eq "\x{FEFF}" ) {
1433                     substr( $bulk[ 0 ], 0, 1 ) = "";
1434                 }; # if
1435             }; # if
1436         }; # if
1437         $handle->close()
1438             or $error->( "File \"$name\" could not be closed after input: $!" );
1439     } else {
1440         if ( $opts{ -binary } and exists( $opts{ -bulk } ) ) {
1441             ${ $opts{ -bulk } } = "";
1442         }; # if
1443     }; # if
1444     if ( $opts{ -binary } ) {
1445         if ( exists( $opts{ -bulk } ) ) {
1446             return 1;
1447         } else {
1448             return $bulk[ 0 ];
1449         }; # if
1450     } else {
1451         if ( ( @bulk > 0 ) and ( substr( $bulk[ -1 ], -1, 1 ) ne "\n" ) ) {
1452             $bulk[ -1 ] .= "\n";
1453         }; # if
1454         if ( not $opts{ -keep_trailing_space } ) {
1455             map( $_ =~ s/\s+\n\z/\n/, @bulk );
1456         }; # if
1457         if ( $opts{ -chomp } ) {
1458             chomp( @bulk );
1459         }; # if
1460         if ( wantarray() ) {
1461             return @bulk;
1462         } else {
1463             return join( "", @bulk );
1464         }; # if
1465     }; # if
1466
1467 }; # sub read_file
1468
1469 #--------------------------------------------------------------------------------------------------
1470
1471 =head3 write_file
1472
1473 B<Synopsis:>
1474
1475     write_file( $file, $bulk, @options )
1476
1477 B<Description:>
1478
1479 Write file.
1480
1481 B<Arguments:>
1482
1483 =over
1484
1485 =item B<$file>
1486
1487 The name or handle of file to write to.
1488
1489 =item B<$bulk>
1490
1491 Bulk to write to a file. Can be a scalar, or a reference to scalar or an array.
1492
1493 =back
1494
1495 B<Options:>
1496
1497 =over
1498
1499 =item B<-backup>
1500
1501 If true, create a backup copy of file overwritten. Backup copy is placed into the same directory.
1502 The name of backup copy is the same as the name of file with `~' appended. By default backup copy
1503 is not created.
1504
1505 =item B<-append>
1506
1507 If true, the text will be added to existing file.
1508
1509 =back
1510
1511 B<Examples:>
1512
1513     write_file( "message.txt", \$bulk );
1514         # Write file, take content from a scalar.
1515
1516     write_file( "message.txt", \@bulk, -backup => 1 );
1517         # Write file, take content from an array, create a backup copy.
1518
1519 =cut
1520
1521 sub write_file($$@) {
1522
1523     my $file = shift( @_ );  # The name or handle of file to write to.
1524     my $bulk = shift( @_ );  # The text to write. Can be reference to array or scalar.
1525     my %opts = @_;           # Options.
1526
1527     my $name;
1528     my $handle;
1529
1530     check_opts( %opts, [ qw( -append -backup -binary -layer ) ] );
1531
1532     my $mode = $opts{ -append } ? "a": "w";
1533     if ( ( ref( $file ) eq "GLOB" ) or UNIVERSAL::isa( $file, "IO::Handle" ) ) {
1534         $name = "unknown";
1535         $handle = $file;
1536     } else {
1537         $name = $file;
1538         if ( $opts{ -backup } and ( -f $name ) ) {
1539             copy_file( $name, $name . "~", -overwrite => 1 );
1540         }; # if
1541         $handle = IO::File->new( $name, $mode )
1542             or runtime_error( "File \"$name\" could not be opened for output: $!" );
1543     }; # if
1544     if ( $opts{ -binary } ) {
1545         binmode( $handle );
1546     } elsif ( $opts{ -layer } ) {
1547         binmode( $handle, $opts{ -layer } );
1548     }; # if
1549     if ( ref( $bulk ) eq "" ) {
1550         if ( defined( $bulk ) ) {
1551             $handle->print( $bulk );
1552             if ( not $opts{ -binary } and ( substr( $bulk, -1 ) ne "\n" ) ) {
1553                 $handle->print( "\n" );
1554             }; # if
1555         }; # if
1556     } elsif ( ref( $bulk ) eq "SCALAR" ) {
1557         if ( defined( $$bulk ) ) {
1558             $handle->print( $$bulk );
1559             if ( not $opts{ -binary } and ( substr( $$bulk, -1 ) ne "\n" ) ) {
1560                 $handle->print( "\n" );
1561             }; # if
1562         }; # if
1563     } elsif ( ref( $bulk ) eq "ARRAY" ) {
1564         foreach my $line ( @$bulk ) {
1565             if ( defined( $line ) ) {
1566                 $handle->print( $line );
1567                 if ( not $opts{ -binary } and ( substr( $line, -1 ) ne "\n" ) ) {
1568                     $handle->print( "\n" );
1569                 }; # if
1570             }; # if
1571         }; # foreach
1572     } else {
1573         Carp::croak( "write_file: \$bulk must be a scalar or reference to (scalar or array)" );
1574     }; # if
1575     $handle->close()
1576         or runtime_error( "File \"$name\" could not be closed after output: $!" );
1577
1578 }; # sub write_file
1579
1580 #--------------------------------------------------------------------------------------------------
1581
1582 =cut
1583
1584 # =================================================================================================
1585 # Execution subroutines.
1586 # =================================================================================================
1587
1588 =head2 Execution subroutines.
1589
1590 =over
1591
1592 =cut
1593
1594 #--------------------------------------------------------------------------------------------------
1595
1596 sub _pre {
1597
1598     my $arg = shift( @_ );
1599
1600     # If redirection is not required, exit.
1601     if ( not exists( $arg->{ redir } ) ) {
1602         return 0;
1603     }; # if
1604
1605     # Input parameters.
1606     my $mode   = $arg->{ mode   }; # Mode, "<" (input ) or ">" (output).
1607     my $handle = $arg->{ handle }; # Handle to manipulate.
1608     my $redir  = $arg->{ redir  }; # Data, a file name if a scalar, or file contents, if a reference.
1609
1610     # Output parameters.
1611     my $save_handle;
1612     my $temp_handle;
1613     my $temp_name;
1614
1615     # Save original handle (by duping it).
1616     $save_handle = Symbol::gensym();
1617     $handle->flush();
1618     open( $save_handle, $mode . "&" . $handle->fileno() )
1619         or die( "Cannot dup filehandle: $!" );
1620
1621     # Prepare a file to IO.
1622     if ( UNIVERSAL::isa( $redir, "IO::Handle" ) or ( ref( $redir ) eq "GLOB" ) ) {
1623         # $redir is reference to an object of IO::Handle class (or its decedant).
1624         $temp_handle = $redir;
1625     } elsif ( ref( $redir ) ) {
1626         # $redir is a reference to content to be read/written.
1627         # Prepare temp file.
1628         ( $temp_handle, $temp_name ) =
1629             File::Temp::tempfile(
1630                 "$tool.XXXXXXXX",
1631                 DIR    => File::Spec->tmpdir(),
1632                 SUFFIX => ".tmp",
1633                 UNLINK => 1
1634             );
1635         if ( not defined( $temp_handle ) ) {
1636             runtime_error( "Could not create temp file." );
1637         }; # if
1638         if ( $mode eq "<" ) {
1639             # It is a file to be read by child, prepare file content to be read.
1640             $temp_handle->print( ref( $redir ) eq "SCALAR" ? ${ $redir } : @{ $redir } );
1641             $temp_handle->flush();
1642             seek( $temp_handle, 0, 0 );
1643                 # Unfortunatelly, I could not use OO interface to seek.
1644                 # ActivePerl 5.6.1 complains on both forms:
1645                 #    $temp_handle->seek( 0 );    # As declared in IO::Seekable.
1646                 #    $temp_handle->setpos( 0 );  # As described in documentation.
1647         } elsif ( $mode eq ">" ) {
1648             # It is a file for output. Clear output variable.
1649             if ( ref( $redir ) eq "SCALAR" ) {
1650                 ${ $redir } = "";
1651             } else {
1652                 @{ $redir } = ();
1653             }; # if
1654         }; # if
1655     } else {
1656         # $redir is a name of file to be read/written.
1657         # Just open file.
1658         if ( defined( $redir ) ) {
1659             $temp_name = $redir;
1660         } else {
1661             $temp_name = File::Spec->devnull();
1662         }; # if
1663         $temp_handle = IO::File->new( $temp_name, $mode )
1664             or runtime_error( "file \"$temp_name\" could not be opened for " . ( $mode eq "<" ? "input" : "output" ) . ": $!" );
1665     }; # if
1666
1667     # Redirect handle to temp file.
1668     open( $handle, $mode . "&" . $temp_handle->fileno() )
1669         or die( "Cannot dup filehandle: $!" );
1670
1671     # Save output parameters.
1672     $arg->{ save_handle } = $save_handle;
1673     $arg->{ temp_handle } = $temp_handle;
1674     $arg->{ temp_name   } = $temp_name;
1675
1676 }; # sub _pre
1677
1678
1679 sub _post {
1680
1681     my $arg = shift( @_ );
1682
1683     # Input parameters.
1684     my $mode   = $arg->{ mode   }; # Mode, "<" or ">".
1685     my $handle = $arg->{ handle }; # Handle to save and set.
1686     my $redir  = $arg->{ redir  }; # Data, a file name if a scalar, or file contents, if a reference.
1687
1688     # Parameters saved during preprocessing.
1689     my $save_handle = $arg->{ save_handle };
1690     my $temp_handle = $arg->{ temp_handle };
1691     my $temp_name   = $arg->{ temp_name   };
1692
1693     # If no handle was saved, exit.
1694     if ( not $save_handle ) {
1695         return 0;
1696     }; # if
1697
1698     # Close handle.
1699     $handle->close()
1700         or die( "$!" );
1701
1702     # Read the content of temp file, if necessary, and close temp file.
1703     if ( ( $mode ne "<" ) and ref( $redir ) ) {
1704         $temp_handle->flush();
1705         seek( $temp_handle, 0, 0 );
1706         if ( $^O =~ m/MSWin/ ) {
1707             binmode( $temp_handle, ":crlf" );
1708         }; # if
1709         if ( ref( $redir ) eq "SCALAR" ) {
1710             ${ $redir } .= join( "", $temp_handle->getlines() );
1711         } elsif ( ref( $redir ) eq "ARRAY" ) {
1712             push( @{ $redir }, $temp_handle->getlines() );
1713         }; # if
1714     }; # if
1715     if ( not UNIVERSAL::isa( $redir, "IO::Handle" ) ) {
1716         $temp_handle->close()
1717             or die( "$!" );
1718     }; # if
1719
1720     # Restore handle to original value.
1721     $save_handle->flush();
1722     open( $handle, $mode . "&" . $save_handle->fileno() )
1723         or die( "Cannot dup filehandle: $!" );
1724
1725     # Close save handle.
1726     $save_handle->close()
1727         or die( "$!" );
1728
1729     # Delete parameters saved during preprocessing.
1730     delete( $arg->{ save_handle } );
1731     delete( $arg->{ temp_handle } );
1732     delete( $arg->{ temp_name   } );
1733
1734 }; # sub _post
1735
1736 #--------------------------------------------------------------------------------------------------
1737
1738 =item C<execute( [ @command ], @options )>
1739
1740 Execute specified program or shell command.
1741
1742 Program is specified by reference to an array, that array is passed to C<system()> function which
1743 executes the command. See L<perlfunc> for details how C<system()> interprets various forms of
1744 C<@command>.
1745
1746 By default, in case of any error error message is issued and script terminated (by runtime_error()).
1747 Function returns an exit code of program.
1748
1749 Alternatively, he function may return exit status of the program (see C<-ignore_status>) or signal
1750 (see C<-ignore_signal>) so caller may analyze it and continue execution.
1751
1752 Options:
1753
1754 =over
1755
1756 =item C<-stdin>
1757
1758 Redirect stdin of program. The value of option can be:
1759
1760 =over
1761
1762 =item C<undef>
1763
1764 Stdin of child is attached to null device.
1765
1766 =item a string
1767
1768 Stdin of child is attached to a file with name specified by option.
1769
1770 =item a reference to a scalar
1771
1772 A dereferenced scalar is written to a temp file, and child's stdin is attached to that file.
1773
1774 =item a reference to an array
1775
1776 A dereferenced array is written to a temp file, and child's stdin is attached to that file.
1777
1778 =back
1779
1780 =item C<-stdout>
1781
1782 Redirect stdout. Possible values are the same as for C<-stdin> option. The only difference is
1783 reference specifies a variable receiving program's output.
1784
1785 =item C<-stderr>
1786
1787 It similar to C<-stdout>, but redirects stderr. There is only one additional value:
1788
1789 =over
1790
1791 =item an empty string
1792
1793 means that stderr should be redirected to the same place where stdout is redirected to.
1794
1795 =back
1796
1797 =item C<-append>
1798
1799 Redirected stream will not overwrite previous content of file (or variable).
1800 Note, that option affects both stdout and stderr.
1801
1802 =item C<-ignore_status>
1803
1804 By default, subroutine raises an error and exits the script if program returns non-exit status. If
1805 this options is true, no error is raised. Instead, status is returned as function result (and $@ is
1806 set to error message).
1807
1808 =item C<-ignore_signal>
1809
1810 By default, subroutine raises an error and exits the script if program die with signal. If
1811 this options is true, no error is raised in such a case. Instead, signal number is returned (as
1812 negative value), error message is placed to C<$@> variable.
1813
1814 If command is not even started, -256 is returned.
1815
1816 =back
1817
1818 Examples:
1819
1820     execute( [ "cmd.exe", "/c", "dir" ] );
1821         # Execute NT shell with specified options, no redirections are
1822         # made.
1823
1824     my $output;
1825     execute( [ "cvs", "-n", "-q", "update", "." ], -stdout => \$output );
1826         # Execute "cvs -n -q update ." command, output is saved
1827         # in $output variable.
1828
1829     my @output;
1830     execute( [ qw( cvs -n -q update . ) ], -stdout => \@output, -stderr => undef );
1831         # Execute specified command,  output is saved in @output
1832         # variable, stderr stream is redirected to null device
1833         # (/dev/null in Linux* OS and nul in Windows* OS).
1834
1835 =cut
1836
1837 sub execute($@) {
1838
1839     # !!! Add something to complain on unknown options...
1840
1841     my $command = shift( @_ );
1842     my %opts    = @_;
1843     my $prefix  = "Could not execute $command->[ 0 ]";
1844
1845     check_opts( %opts, [ qw( -stdin -stdout -stderr -append -ignore_status -ignore_signal ) ] );
1846
1847     if ( ref( $command ) ne "ARRAY" ) {
1848         Carp::croak( "execute: $command must be a reference to array" );
1849     }; # if
1850
1851     my $stdin  = { handle => \*STDIN,  mode => "<" };
1852     my $stdout = { handle => \*STDOUT, mode => ">" };
1853     my $stderr = { handle => \*STDERR, mode => ">" };
1854     my $streams = {
1855         stdin  => $stdin,
1856         stdout => $stdout,
1857         stderr => $stderr
1858     }; # $streams
1859
1860     for my $stream ( qw( stdin stdout stderr ) ) {
1861         if ( exists( $opts{ "-$stream" } ) ) {
1862             if ( ref( $opts{ "-$stream" } ) !~ m/\A(|SCALAR|ARRAY)\z/ ) {
1863                 Carp::croak( "execute: -$stream option: must have value of scalar, or reference to (scalar or array)." );
1864             }; # if
1865             $streams->{ $stream }->{ redir } = $opts{ "-$stream" };
1866         }; # if
1867         if ( $opts{ -append } and ( $streams->{ $stream }->{ mode } ) eq ">" ) {
1868             $streams->{ $stream }->{ mode } = ">>";
1869         }; # if
1870     }; # foreach $stream
1871
1872     _pre( $stdin  );
1873     _pre( $stdout );
1874     if ( defined( $stderr->{ redir } ) and not ref( $stderr->{ redir } ) and ( $stderr->{ redir } eq "" ) ) {
1875         if ( exists( $stdout->{ redir } ) ) {
1876             $stderr->{ redir } = $stdout->{ temp_handle };
1877         } else {
1878             $stderr->{ redir } = ${ $stdout->{ handle } };
1879         }; # if
1880     }; # if
1881     _pre( $stderr );
1882     my $rc = system( @$command );
1883     my $errno = $!;
1884     my $child = $?;
1885     _post( $stderr );
1886     _post( $stdout );
1887     _post( $stdin  );
1888
1889     my $exit = 0;
1890     my $signal_num  = $child & 127;
1891     my $exit_status = $child >> 8;
1892     $@ = "";
1893
1894     if ( $rc == -1 ) {
1895         $@ = "\"$command->[ 0 ]\" failed: $errno";
1896         $exit = -256;
1897         if ( not $opts{ -ignore_signal } ) {
1898             runtime_error( $@ );
1899         }; # if
1900     } elsif ( $signal_num != 0 ) {
1901         $@ = "\"$command->[ 0 ]\" failed due to signal $signal_num.";
1902         $exit = - $signal_num;
1903         if ( not $opts{ -ignore_signal } ) {
1904             runtime_error( $@ );
1905         }; # if
1906     } elsif ( $exit_status != 0 ) {
1907         $@ = "\"$command->[ 0 ]\" returned non-zero status $exit_status.";
1908         $exit = $exit_status;
1909         if ( not $opts{ -ignore_status } ) {
1910             runtime_error( $@ );
1911         }; # if
1912     }; # if
1913
1914     return $exit;
1915
1916 }; # sub execute
1917
1918 #--------------------------------------------------------------------------------------------------
1919
1920 =item C<backticks( [ @command ], @options )>
1921
1922 Run specified program or shell command and return output.
1923
1924 In scalar context entire output is returned in a single string. In list context list of strings
1925 is returned. Function issues an error and exits script if any error occurs.
1926
1927 =cut
1928
1929
1930 sub backticks($@) {
1931
1932     my $command = shift( @_ );
1933     my %opts    = @_;
1934     my @output;
1935
1936     check_opts( %opts, [ qw( -chomp ) ] );
1937
1938     execute( $command, -stdout => \@output );
1939
1940     if ( $opts{ -chomp } ) {
1941         chomp( @output );
1942     }; # if
1943
1944     return ( wantarray() ? @output : join( "", @output ) );
1945
1946 }; # sub backticks
1947
1948 #--------------------------------------------------------------------------------------------------
1949
1950 sub pad($$$) {
1951     my ( $str, $length, $pad ) = @_;
1952     my $lstr = length( $str );    # Length of source string.
1953     if ( $lstr < $length ) {
1954         my $lpad  = length( $pad );                         # Length of pad.
1955         my $count = int( ( $length - $lstr ) / $lpad );     # Number of pad repetitions.
1956         my $tail  = $length - ( $lstr + $lpad * $count );
1957         $str = $str . ( $pad x $count ) . substr( $pad, 0, $tail );
1958     }; # if
1959     return $str;
1960 }; # sub pad
1961
1962 # --------------------------------------------------------------------------------------------------
1963
1964 =back
1965
1966 =cut
1967
1968 #--------------------------------------------------------------------------------------------------
1969
1970 return 1;
1971
1972 #--------------------------------------------------------------------------------------------------
1973
1974 =cut
1975
1976 # End of file.