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
23B<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
33B<Note:> Because this collection is small and intended for widely using in particular project,
34all variables and functions are exported by default.
35
36B<Note:> I have some ideas how to improve this collection, but it is in my long-term plans.
37Current shape is not ideal, but good enough to use.
38
39=cut
40
41package tools;
42
43use strict;
44use warnings;
45
46use vars qw( @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS );
47require Exporter;
48@ISA = qw( Exporter );
49
50my @vars   = qw( $tool );
51my @utils  = qw( check_opts validate );
52my @opts   = qw( get_options );
53my @print  = qw( debug info warning cmdline_error runtime_error question );
54my @name   = qw( get_vol get_dir get_file get_name get_ext cat_file cat_dir );
55my @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 );
56my @io     = qw( read_file write_file );
57my @exec   = qw( execute backticks );
58my @string = qw{ pad };
59@EXPORT = ( @utils, @opts, @vars, @print, @name, @file, @io, @exec, @string );
60
61use UNIVERSAL    ();
62
63use FindBin;
64use IO::Handle;
65use IO::File;
66use IO::Dir;
67# Not available on some machines: use IO::Zlib;
68
69use Getopt::Long ();
70use Pod::Usage   ();
71use Carp         ();
72use File::Copy   ();
73use File::Path   ();
74use File::Temp   ();
75use File::Spec   ();
76use POSIX        qw{ :fcntl_h :errno_h };
77use Cwd          ();
78use Symbol       ();
79
80use Data::Dumper;
81
82use vars qw( $tool $verbose $timestamps );
83$tool = $FindBin::Script;
84
85my @warning = ( sub {}, \&warning, \&runtime_error );
86
87
88sub 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#
143sub 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
232B<Synopsis:>
233
234    get_options( @arguments )
235
236B<Description:>
237
238It is very simple wrapper arounf Getopt::Long::GetOptions. It passes all arguments to GetOptions,
239and add definitions for standard help options: --help, --doc, --verbose, and --quiet.
240When GetOptions finishes, this subroutine checks exit code, if it is non-zero, standard error
241message is issued and script terminated.
242
243If --verbose or --quiet option is specified, C<tools.pm_verbose> environment variable is set.
244It is the way to propagate verbose/quiet mode to callee Perl scripts.
245
246=cut
247
248sub 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
273Each of the print subroutines prepends each line of its output with the name of current script and
274the type of information, for example:
275
276    info( "Writing file..." );
277
278will print
279
280    <script>: (i): Writing file...
281
282while
283
284    warning( "File does not exist!" );
285
286will print
287
288    <script>: (!): File does not exist!
289
290Here are exported items:
291
292=cut
293
294# -------------------------------------------------------------------------------------------------
295
296sub _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
329B<Synopsis:>
330
331    $verbose
332
333B<Description:>
334
335Package variable. It determines verbosity level, which affects C<warning()>, C<info()>, and
336C<debug()> subroutines .
337
338The variable gets initial value from C<tools.pm_verbose> environment variable if it is exists.
339If the environment variable does not exist, variable is set to 2.
340
341Initial 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
353B<Synopsis:>
354
355    $timestamps
356
357B<Description:>
358
359Package variable. It determines whether C<debug()>, C<info()>, C<warning()>, C<runtime_error()>
360subroutines print timestamps or not.
361
362The variable gets initial value from C<tools.pm_timestamps> environment variable if it is exists.
363If the environment variable does not exist, variable is set to false.
364
365Initial 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
377B<Synopsis:>
378
379    debug( @messages )
380
381B<Description:>
382
383If verbosity level is 3 or higher, print debug information to the stderr, prepending it with "(#)"
384prefix.
385
386=cut
387
388sub 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
404B<Synopsis:>
405
406    info( @messages )
407
408B<Description:>
409
410If verbosity level is 2 or higher, print information to the stderr, prepending it with "(i)" prefix.
411
412=cut
413
414sub 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
427B<Synopsis:>
428
429    warning( @messages )
430
431B<Description:>
432
433If verbosity level is 1 or higher, issue a warning, prepending it with "(!)" prefix.
434
435=cut
436
437sub 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
450B<Synopsis:>
451
452    cmdline_error( @message )
453
454B<Description:>
455
456Print error message and exit the program with status 2.
457
458This function is intended to complain on command line errors, e. g. unknown
459options, invalid arguments, etc.
460
461=cut
462
463sub 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
483B<Synopsis:>
484
485    runtime_error( @message )
486
487B<Description:>
488
489Print error message and exits the program with status 3.
490
491This function is intended to complain on runtime errors, e. g.
492directories which are not found, non-writable files, etc.
493
494=cut
495
496sub runtime_error(@) {
497
498    STDOUT->flush();
499    die _format_message( "x", @_ );
500
501}; # sub runtime_error
502
503#--------------------------------------------------------------------------------------------------
504
505=head3 question
506
507B<Synopsis:>
508
509    question( $prompt; $answer, $choices  )
510
511B<Description:>
512
513Print $promp to the stderr, prepending it with "question:" prefix. Read a line from stdin, chop
514"\n" from the end, it is answer.
515
516If $answer is defined, it is treated as first user input.
517
518If $choices is specified, it could be a regexp for validating user input, or a string. In latter
519case it interpreted as list of characters, acceptable (case-insensitive) choices. If user enters
520non-acceptable answer, question continue asking until answer is acceptable.
521If $choices is not specified, any answer is acceptable.
522
523In case of end-of-file (or Ctrl+D pressed by user), $answer is C<undef>.
524
525B<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
538sub 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.
578sub 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.
587sub 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.
600sub 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.
609sub 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.
619sub 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
631sub 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
646sub 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
674Searches for specified executable file in the (specified) directories.
675Raises a runtime eroror if no executable file found. Returns a full path of found executable(s).
676
677Options:
678
679=over
680
681=item C<-all> =E<gt> I<bool>
682
683Do 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
687Specify directory list to search through. If option is not passed, PATH environment variable
688is used for directory list.
689
690=item C<-exec> =E<gt> I<bool>
691
692Whether check for executable files or not. By default, C<which> searches executable files.
693However, on Cygwin executable check never performed.
694
695=back
696
697Examples:
698
699Look for "echo" in the directories specified in PATH:
700
701    my $echo = which( "echo" );
702
703Look for all occurrences of "cp" in the PATH:
704
705    my @cps = which( "cp", -all => 1 );
706
707Look for the first occurrence of "icc" in the specified directories:
708
709    my $icc = which( "icc", -dirs => [ ".", "/usr/local/bin", "/usr/bin", "/bin" ] );
710
711Look for the C<omp_lib.f> file:
712
713    my @omp_lib = which( "omp_lib.f", -all => 1, -exec => 0, -dirs => [ @include ] );
714
715=cut
716
717sub which($@) {
718
719    my $file = shift( @_ );
720    my %opts = @_;
721
722    check_opts( %opts, [ qw( -all -dirs -exec ) ] );
723    if ( $opts{ -all } and not wantarray() ) {
724        local $Carp::CarpLevel = 1;
725        Carp::cluck( "`-all' option passed to `which' but list is not expected" );
726    }; # if
727    if ( not defined( $opts{ -exec } ) ) {
728        $opts{ -exec } = 1;
729    }; # if
730
731    my $dirs = ( exists( $opts{ -dirs } ) ? $opts{ -dirs } : [ File::Spec->path() ] );
732    my @found;
733
734    my @exts = ( "" );
735    if ( $^O eq "MSWin32" and $opts{ -exec } ) {
736        if ( defined( $ENV{ PATHEXT } ) ) {
737            push( @exts, split( ";", $ENV{ PATHEXT } ) );
738        } else {
739            # If PATHEXT does not exist, use default value.
740            push( @exts, qw{ .COM .EXE .BAT .CMD } );
741        }; # if
742    }; # if
743
744    loop:
745    foreach my $dir ( @$dirs ) {
746        foreach my $ext ( @exts ) {
747            my $path = File::Spec->catfile( $dir, $file . $ext );
748            if ( -e $path ) {
749                # Executable bit is not reliable on Cygwin, do not check it.
750                if ( not $opts{ -exec } or -x $path or $^O eq "cygwin" ) {
751                    push( @found, $path );
752                    if ( not $opts{ -all } ) {
753                        last loop;
754                    }; # if
755                }; # if
756            }; # if
757        }; # foreach $ext
758    }; # foreach $dir
759
760    if ( not @found ) {
761        # TBD: We need to introduce an option for conditional enabling this error.
762        # runtime_error( "Could not find \"$file\" executable file in PATH." );
763    }; # if
764    if ( @found > 1 ) {
765        # TBD: Issue a warning?
766    }; # if
767
768    if ( $opts{ -all } ) {
769        return @found;
770    } else {
771        return $found[ 0 ];
772    }; # if
773
774}; # sub which
775
776# -------------------------------------------------------------------------------------------------
777
778=item C<abs_path( $path, $base )>
779
780Return absolute path for an argument.
781
782Most of the work is done by C<File::Spec->rel2abs()>. C<abs_path()> additionally collapses
783C<dir1/../dir2> to C<dir2>.
784
785It is not so naive and made intentionally. For example on Linux* OS in Bash if F<link/> is a symbolic
786link to directory F<some_dir/>
787
788    $ cd link
789    $ cd ..
790
791brings you back to F<link/>'s parent, not to parent of F<some_dir/>,
792
793=cut
794
795sub abs_path($;$) {
796
797    my ( $path, $base ) = @_;
798    $path = File::Spec->rel2abs( $path, ( defined( $base ) ? $base : $ENV{ PWD } ) );
799    my ( $vol, $dir, $file ) = File::Spec->splitpath( $path );
800    while ( $dir =~ s{/(?!\.\.)[^/]*/\.\.(?:/|\z)}{/} ) {
801    }; # while
802    $path = File::Spec->canonpath( File::Spec->catpath( $vol, $dir, $file ) );
803    return $path;
804
805}; # sub abs_path
806
807# -------------------------------------------------------------------------------------------------
808
809=item C<rel_path( $path, $base )>
810
811Return relative path for an argument.
812
813=cut
814
815sub rel_path($;$) {
816
817    my ( $path, $base ) = @_;
818    $path = File::Spec->abs2rel( abs_path( $path ), $base );
819    return $path;
820
821}; # sub rel_path
822
823# -------------------------------------------------------------------------------------------------
824
825=item C<real_path( $dir )>
826
827Return real absolute path for an argument. In the result all relative components (F<.> and F<..>)
828and U<symbolic links are resolved>.
829
830In most cases it is not what you want. Consider using C<abs_path> first.
831
832C<abs_path> function from B<Cwd> module works with directories only. This function works with files
833as well. But, if file is a symbolic link, function does not resolve it (yet).
834
835The function uses C<runtime_error> to raise an error if something wrong.
836
837=cut
838
839sub real_path($) {
840
841    my $orig_path = shift( @_ );
842    my $real_path;
843    my $message = "";
844    if ( not -e $orig_path ) {
845        $message = "\"$orig_path\" does not exists";
846    } else {
847        # Cwd::abs_path does not work with files, so in this case we should handle file separately.
848        my $file;
849        if ( not -d $orig_path ) {
850            ( my $vol, my $dir, $file ) = File::Spec->splitpath( File::Spec->rel2abs( $orig_path ) );
851            $orig_path = File::Spec->catpath( $vol, $dir );
852        }; # if
853        {
854            local $SIG{ __WARN__ } = sub { $message = $_[ 0 ]; };
855            $real_path = Cwd::abs_path( $orig_path );
856        };
857        if ( defined( $file ) ) {
858            $real_path = File::Spec->catfile( $real_path, $file );
859        }; # if
860    }; # if
861    if ( not defined( $real_path ) or $message ne "" ) {
862        $message =~ s/^stat\(.*\): (.*)\s+at .*? line \d+\s*\z/$1/;
863        runtime_error( "Could not find real path for \"$orig_path\"" . ( $message ne "" ? ": $message" : "" ) );
864    }; # if
865    return $real_path;
866
867}; # sub real_path
868
869# -------------------------------------------------------------------------------------------------
870
871=item C<make_dir( $dir, @options )>
872
873Make a directory.
874
875This function makes a directory. If necessary, more than one level can be created.
876If directory exists, warning issues (the script behavior depends on value of
877C<-warning_level> option). If directory creation fails or C<$dir> exists but it is not a
878directory, error issues.
879
880Options:
881
882=over
883
884=item C<-mode>
885
886The numeric mode for new directories, 0750 (rwxr-x---) by default.
887
888=back
889
890=cut
891
892sub make_dir($@) {
893
894    my $dir    = shift( @_ );
895    my %opts   =
896        validate(
897            params => \@_,
898            spec => {
899                parents => { type => "boolean", default => 1    },
900                mode    => { type => "scalar",  default => 0777 },
901            },
902        );
903
904    my $prefix = "Could not create directory \"$dir\"";
905
906    if ( -e $dir ) {
907        if ( -d $dir ) {
908        } else {
909            runtime_error( "$prefix: it exists, but not a directory." );
910        }; # if
911    } else {
912        eval {
913            File::Path::mkpath( $dir, 0, $opts{ mode } );
914        }; # eval
915        if ( $@ ) {
916            $@ =~ s{\s+at (?:[a-zA-Z0-9 /_.]*/)?tools\.pm line \d+\s*}{};
917            runtime_error( "$prefix: $@" );
918        }; # if
919        if ( not -d $dir ) { # Just in case, check it one more time...
920            runtime_error( "$prefix." );
921        }; # if
922    }; # if
923
924}; # sub make_dir
925
926# -------------------------------------------------------------------------------------------------
927
928=item C<copy_dir( $src_dir, $dst_dir, @options )>
929
930Copy directory recursively.
931
932This function copies a directory recursively.
933If source directory does not exist or not a directory, error issues.
934
935Options:
936
937=over
938
939=item C<-overwrite>
940
941Overwrite destination directory, if it exists.
942
943=back
944
945=cut
946
947sub copy_dir($$@) {
948
949    my $src  = shift( @_ );
950    my $dst  = shift( @_ );
951    my %opts = @_;
952    my $prefix = "Could not copy directory \"$src\" to \"$dst\"";
953
954    if ( not -e $src ) {
955        runtime_error( "$prefix: \"$src\" does not exist." );
956    }; # if
957    if ( not -d $src ) {
958        runtime_error( "$prefix: \"$src\" is not a directory." );
959    }; # if
960    if ( -e $dst ) {
961        if ( -d $dst ) {
962            if ( $opts{ -overwrite } ) {
963                del_dir( $dst );
964            } else {
965                runtime_error( "$prefix: \"$dst\" already exists." );
966            }; # if
967        } else {
968            runtime_error( "$prefix: \"$dst\" is not a directory." );
969        }; # if
970    }; # if
971
972    execute( [ "cp", "-R", $src, $dst ] );
973
974}; # sub copy_dir
975
976# -------------------------------------------------------------------------------------------------
977
978=item C<move_dir( $src_dir, $dst_dir, @options )>
979
980Move directory.
981
982Options:
983
984=over
985
986=item C<-overwrite>
987
988Overwrite destination directory, if it exists.
989
990=back
991
992=cut
993
994sub move_dir($$@) {
995
996    my $src  = shift( @_ );
997    my $dst  = shift( @_ );
998    my %opts = @_;
999    my $prefix = "Could not copy directory \"$src\" to \"$dst\"";
1000
1001    if ( not -e $src ) {
1002        runtime_error( "$prefix: \"$src\" does not exist." );
1003    }; # if
1004    if ( not -d $src ) {
1005        runtime_error( "$prefix: \"$src\" is not a directory." );
1006    }; # if
1007    if ( -e $dst ) {
1008        if ( -d $dst ) {
1009            if ( $opts{ -overwrite } ) {
1010                del_dir( $dst );
1011            } else {
1012                runtime_error( "$prefix: \"$dst\" already exists." );
1013            }; # if
1014        } else {
1015            runtime_error( "$prefix: \"$dst\" is not a directory." );
1016        }; # if
1017    }; # if
1018
1019    execute( [ "mv", $src, $dst ] );
1020
1021}; # sub move_dir
1022
1023# -------------------------------------------------------------------------------------------------
1024
1025=item C<clean_dir( $dir, @options )>
1026
1027Clean a directory: delete all the entries (recursively), but leave the directory.
1028
1029Options:
1030
1031=over
1032
1033=item C<-force> => bool
1034
1035If a directory is not writable, try to change permissions first, then clean it.
1036
1037=item C<-skip> => regexp
1038
1039Regexp. If a directory entry mached the regexp, it is skipped, not deleted. (As a subsequence,
1040a directory containing skipped entries is not deleted.)
1041
1042=back
1043
1044=cut
1045
1046sub _clean_dir($);
1047
1048sub _clean_dir($) {
1049    our %_clean_dir_opts;
1050    my ( $dir ) = @_;
1051    my $skip    = $_clean_dir_opts{ skip };    # Regexp.
1052    my $skipped = 0;                           # Number of skipped files.
1053    my $prefix  = "Cleaning `$dir' failed:";
1054    my @stat    = stat( $dir );
1055    my $mode    = $stat[ 2 ];
1056    if ( not @stat ) {
1057        runtime_error( $prefix, "Cannot stat `$dir': $!" );
1058    }; # if
1059    if ( not -d _ ) {
1060        runtime_error( $prefix, "It is not a directory." );
1061    }; # if
1062    if ( not -w _ ) {        # Directory is not writable.
1063        if ( not -o _ or not $_clean_dir_opts{ force } ) {
1064            runtime_error( $prefix, "Directory is not writable." );
1065        }; # if
1066        # Directory is not writable but mine. Try to change permissions.
1067        chmod( $mode | S_IWUSR, $dir )
1068            or runtime_error( $prefix, "Cannot make directory writable: $!" );
1069    }; # if
1070    my $handle   = IO::Dir->new( $dir ) or runtime_error( $prefix, "Cannot read directory: $!" );
1071    my @entries  = File::Spec->no_upwards( $handle->read() );
1072    $handle->close() or runtime_error( $prefix, "Cannot read directory: $!" );
1073    foreach my $entry ( @entries ) {
1074        my $path = cat_file( $dir, $entry );
1075        if ( defined( $skip ) and $entry =~ $skip ) {
1076            ++ $skipped;
1077        } else {
1078            if ( -l $path ) {
1079                unlink( $path ) or runtime_error( $prefix, "Cannot delete symlink `$path': $!" );
1080            } else {
1081                stat( $path ) or runtime_error( $prefix, "Cannot stat `$path': $! " );
1082                if ( -f _ ) {
1083                    del_file( $path );
1084                } elsif ( -d _ ) {
1085                    my $rc = _clean_dir( $path );
1086                    if ( $rc == 0 ) {
1087                        rmdir( $path ) or runtime_error( $prefix, "Cannot delete directory `$path': $!" );
1088                    }; # if
1089                    $skipped += $rc;
1090                } else {
1091                    runtime_error( $prefix, "`$path' is neither a file nor a directory." );
1092                }; # if
1093            }; # if
1094        }; # if
1095    }; # foreach
1096    return $skipped;
1097}; # sub _clean_dir
1098
1099
1100sub clean_dir($@) {
1101    my $dir  = shift( @_ );
1102    our %_clean_dir_opts;
1103    local %_clean_dir_opts =
1104        validate(
1105            params => \@_,
1106            spec => {
1107                skip  => { type => "regexpref" },
1108                force => { type => "boolean"   },
1109            },
1110        );
1111    my $skipped = _clean_dir( $dir );
1112    return $skipped;
1113}; # sub clean_dir
1114
1115
1116# -------------------------------------------------------------------------------------------------
1117
1118=item C<del_dir( $dir, @options )>
1119
1120Delete a directory recursively.
1121
1122This function deletes a directory. If directory can not be deleted or it is not a directory, error
1123message issues (and script exists).
1124
1125Options:
1126
1127=over
1128
1129=back
1130
1131=cut
1132
1133sub del_dir($@) {
1134
1135    my $dir  = shift( @_ );
1136    my %opts = @_;
1137    my $prefix = "Deleting directory \"$dir\" failed";
1138    our %_clean_dir_opts;
1139    local %_clean_dir_opts =
1140        validate(
1141            params => \@_,
1142            spec => {
1143                force => { type => "boolean" },
1144            },
1145        );
1146
1147    if ( not -e $dir ) {
1148        # Nothing to do.
1149        return;
1150    }; # if
1151    if ( not -d $dir ) {
1152        runtime_error( "$prefix: it is not a directory." );
1153    }; # if
1154    _clean_dir( $dir );
1155    rmdir( $dir ) or runtime_error( "$prefix." );
1156
1157}; # sub del_dir
1158
1159# -------------------------------------------------------------------------------------------------
1160
1161=item C<change_dir( $dir )>
1162
1163Change current directory.
1164
1165If any error occurred, error issues and script exits.
1166
1167=cut
1168
1169sub change_dir($) {
1170
1171    my $dir = shift( @_ );
1172
1173    Cwd::chdir( $dir )
1174        or runtime_error( "Could not chdir to \"$dir\": $!" );
1175
1176}; # sub change_dir
1177
1178
1179# -------------------------------------------------------------------------------------------------
1180
1181=item C<copy_file( $src_file, $dst_file, @options )>
1182
1183Copy file.
1184
1185This function copies a file. If source does not exist or is not a file, error issues.
1186
1187Options:
1188
1189=over
1190
1191=item C<-overwrite>
1192
1193Overwrite destination file, if it exists.
1194
1195=back
1196
1197=cut
1198
1199sub copy_file($$@) {
1200
1201    my $src  = shift( @_ );
1202    my $dst  = shift( @_ );
1203    my %opts = @_;
1204    my $prefix = "Could not copy file \"$src\" to \"$dst\"";
1205
1206    if ( not -e $src ) {
1207        runtime_error( "$prefix: \"$src\" does not exist." );
1208    }; # if
1209    if ( not -f $src ) {
1210        runtime_error( "$prefix: \"$src\" is not a file." );
1211    }; # if
1212    if ( -e $dst ) {
1213        if ( -f $dst ) {
1214            if ( $opts{ -overwrite } ) {
1215                del_file( $dst );
1216            } else {
1217                runtime_error( "$prefix: \"$dst\" already exists." );
1218            }; # if
1219        } else {
1220            runtime_error( "$prefix: \"$dst\" is not a file." );
1221        }; # if
1222    }; # if
1223
1224    File::Copy::copy( $src, $dst ) or runtime_error( "$prefix: $!" );
1225    # On Windows* OS File::Copy preserves file attributes, but on Linux* OS it doesn't.
1226    # So we should do it manually...
1227    if ( $^O =~ m/^linux\z/ ) {
1228        my $mode = ( stat( $src ) )[ 2 ]
1229            or runtime_error( "$prefix: cannot get status info for source file." );
1230        chmod( $mode, $dst )
1231            or runtime_error( "$prefix: cannot change mode of destination file." );
1232    }; # if
1233
1234}; # sub copy_file
1235
1236# -------------------------------------------------------------------------------------------------
1237
1238sub move_file($$@) {
1239
1240    my $src  = shift( @_ );
1241    my $dst  = shift( @_ );
1242    my %opts = @_;
1243    my $prefix = "Could not move file \"$src\" to \"$dst\"";
1244
1245    check_opts( %opts, [ qw( -overwrite ) ] );
1246
1247    if ( not -e $src ) {
1248        runtime_error( "$prefix: \"$src\" does not exist." );
1249    }; # if
1250    if ( not -f $src ) {
1251        runtime_error( "$prefix: \"$src\" is not a file." );
1252    }; # if
1253    if ( -e $dst ) {
1254        if ( -f $dst ) {
1255            if ( $opts{ -overwrite } ) {
1256                #
1257            } else {
1258                runtime_error( "$prefix: \"$dst\" already exists." );
1259            }; # if
1260        } else {
1261            runtime_error( "$prefix: \"$dst\" is not a file." );
1262        }; # if
1263    }; # if
1264
1265    File::Copy::move( $src, $dst ) or runtime_error( "$prefix: $!" );
1266
1267}; # sub move_file
1268
1269# -------------------------------------------------------------------------------------------------
1270
1271sub del_file($) {
1272    my $files = shift( @_ );
1273    if ( ref( $files ) eq "" ) {
1274        $files = [ $files ];
1275    }; # if
1276    foreach my $file ( @$files ) {
1277        debug( "Deleting file `$file'..." );
1278        my $rc = unlink( $file );
1279        if ( $rc == 0 && $! != ENOENT ) {
1280            # Reporn an error, but ignore ENOENT, because the goal is achieved.
1281            runtime_error( "Deleting file `$file' failed: $!" );
1282        }; # if
1283    }; # foreach $file
1284}; # sub del_file
1285
1286# -------------------------------------------------------------------------------------------------
1287
1288=back
1289
1290=cut
1291
1292# =================================================================================================
1293# File I/O subroutines.
1294# =================================================================================================
1295
1296=head2 File I/O subroutines.
1297
1298=cut
1299
1300#--------------------------------------------------------------------------------------------------
1301
1302=head3 read_file
1303
1304B<Synopsis:>
1305
1306    read_file( $file, @options )
1307
1308B<Description:>
1309
1310Read file and return its content. In scalar context function returns a scalar, in list context
1311function returns list of lines.
1312
1313Note: If the last of file does not terminate with newline, function will append it.
1314
1315B<Arguments:>
1316
1317=over
1318
1319=item B<$file>
1320
1321A name or handle of file to read from.
1322
1323=back
1324
1325B<Options:>
1326
1327=over
1328
1329=item B<-binary>
1330
1331If true, file treats as a binary file: no newline conversion, no truncating trailing space, no
1332newline removing performed. Entire file returned as a scalar.
1333
1334=item B<-bulk>
1335
1336This option is allowed only in binary mode. Option's value should be a reference to a scalar.
1337If option present, file content placed to pointee scalar and function returns true (1).
1338
1339=item B<-chomp>
1340
1341If true, newline characters are removed from file content. By default newline characters remain.
1342This option is not applicable in binary mode.
1343
1344=item B<-keep_trailing_space>
1345
1346If true, trainling space remain at the ends of lines. By default all trailing spaces are removed.
1347This option is not applicable in binary mode.
1348
1349=back
1350
1351B<Examples:>
1352
1353Return file as single line, remove trailing spaces.
1354
1355    my $bulk = read_file( "message.txt" );
1356
1357Return file as list of lines with removed trailing space and
1358newline characters.
1359
1360    my @bulk = read_file( "message.txt", -chomp => 1 );
1361
1362Read a binary file:
1363
1364    my $bulk = read_file( "message.txt", -binary => 1 );
1365
1366Read a big binary file:
1367
1368    my $bulk;
1369    read_file( "big_binary_file", -binary => 1, -bulk => \$bulk );
1370
1371Read from standard input:
1372
1373    my @bulk = read_file( \*STDIN );
1374
1375=cut
1376
1377sub read_file($@) {
1378
1379    my $file = shift( @_ );  # The name or handle of file to read from.
1380    my %opts = @_;           # Options.
1381
1382    my $name;
1383    my $handle;
1384    my @bulk;
1385    my $error = \&runtime_error;
1386
1387    my @binopts = qw( -binary -error -bulk );                       # Options available in binary mode.
1388    my @txtopts = qw( -binary -error -keep_trailing_space -chomp -layer ); # Options available in text (non-binary) mode.
1389    check_opts( %opts, [ @binopts, @txtopts ] );
1390    if ( $opts{ -binary } ) {
1391        check_opts( %opts, [ @binopts ], "these options cannot be used with -binary" );
1392    } else {
1393        check_opts( %opts, [ @txtopts ], "these options cannot be used without -binary" );
1394    }; # if
1395    if ( not exists( $opts{ -error } ) ) {
1396        $opts{ -error } = "error";
1397    }; # if
1398    if ( $opts{ -error } eq "warning" ) {
1399        $error = \&warning;
1400    } elsif( $opts{ -error } eq "ignore" ) {
1401        $error = sub {};
1402    } elsif ( ref( $opts{ -error } ) eq "ARRAY" ) {
1403        $error = sub { push( @{ $opts{ -error } }, $_[ 0 ] ); };
1404    }; # if
1405
1406    if ( ( ref( $file ) eq "GLOB" ) or UNIVERSAL::isa( $file, "IO::Handle" ) ) {
1407        $name = "unknown";
1408        $handle = $file;
1409    } else {
1410        $name = $file;
1411        if ( get_ext( $file ) eq ".gz" and not $opts{ -binary } ) {
1412            $handle = IO::Zlib->new( $name, "rb" );
1413        } else {
1414            $handle = IO::File->new( $name, "r" );
1415        }; # if
1416        if ( not defined( $handle ) ) {
1417            $error->( "File \"$name\" could not be opened for input: $!" );
1418        }; # if
1419    }; # if
1420    if ( defined( $handle ) ) {
1421        if ( $opts{ -binary } ) {
1422            binmode( $handle );
1423            local $/ = undef;   # Set input record separator to undef to read entire file as one line.
1424            if ( exists( $opts{ -bulk } ) ) {
1425                ${ $opts{ -bulk } } = $handle->getline();
1426            } else {
1427                $bulk[ 0 ] = $handle->getline();
1428            }; # if
1429        } else {
1430            if ( defined( $opts{ -layer } ) ) {
1431                binmode( $handle, $opts{ -layer } );
1432            }; # if
1433            @bulk = $handle->getlines();
1434            # Special trick for UTF-8 files: Delete BOM, if any.
1435            if ( defined( $opts{ -layer } ) and $opts{ -layer } eq ":utf8" ) {
1436                if ( substr( $bulk[ 0 ], 0, 1 ) eq "\x{FEFF}" ) {
1437                    substr( $bulk[ 0 ], 0, 1 ) = "";
1438                }; # if
1439            }; # if
1440        }; # if
1441        $handle->close()
1442            or $error->( "File \"$name\" could not be closed after input: $!" );
1443    } else {
1444        if ( $opts{ -binary } and exists( $opts{ -bulk } ) ) {
1445            ${ $opts{ -bulk } } = "";
1446        }; # if
1447    }; # if
1448    if ( $opts{ -binary } ) {
1449        if ( exists( $opts{ -bulk } ) ) {
1450            return 1;
1451        } else {
1452            return $bulk[ 0 ];
1453        }; # if
1454    } else {
1455        if ( ( @bulk > 0 ) and ( substr( $bulk[ -1 ], -1, 1 ) ne "\n" ) ) {
1456            $bulk[ -1 ] .= "\n";
1457        }; # if
1458        if ( not $opts{ -keep_trailing_space } ) {
1459            map( $_ =~ s/\s+\n\z/\n/, @bulk );
1460        }; # if
1461        if ( $opts{ -chomp } ) {
1462            chomp( @bulk );
1463        }; # if
1464        if ( wantarray() ) {
1465            return @bulk;
1466        } else {
1467            return join( "", @bulk );
1468        }; # if
1469    }; # if
1470
1471}; # sub read_file
1472
1473#--------------------------------------------------------------------------------------------------
1474
1475=head3 write_file
1476
1477B<Synopsis:>
1478
1479    write_file( $file, $bulk, @options )
1480
1481B<Description:>
1482
1483Write file.
1484
1485B<Arguments:>
1486
1487=over
1488
1489=item B<$file>
1490
1491The name or handle of file to write to.
1492
1493=item B<$bulk>
1494
1495Bulk to write to a file. Can be a scalar, or a reference to scalar or an array.
1496
1497=back
1498
1499B<Options:>
1500
1501=over
1502
1503=item B<-backup>
1504
1505If true, create a backup copy of file overwritten. Backup copy is placed into the same directory.
1506The name of backup copy is the same as the name of file with `~' appended. By default backup copy
1507is not created.
1508
1509=item B<-append>
1510
1511If true, the text will be added to existing file.
1512
1513=back
1514
1515B<Examples:>
1516
1517    write_file( "message.txt", \$bulk );
1518        # Write file, take content from a scalar.
1519
1520    write_file( "message.txt", \@bulk, -backup => 1 );
1521        # Write file, take content from an array, create a backup copy.
1522
1523=cut
1524
1525sub write_file($$@) {
1526
1527    my $file = shift( @_ );  # The name or handle of file to write to.
1528    my $bulk = shift( @_ );  # The text to write. Can be reference to array or scalar.
1529    my %opts = @_;           # Options.
1530
1531    my $name;
1532    my $handle;
1533
1534    check_opts( %opts, [ qw( -append -backup -binary -layer ) ] );
1535
1536    my $mode = $opts{ -append } ? "a": "w";
1537    if ( ( ref( $file ) eq "GLOB" ) or UNIVERSAL::isa( $file, "IO::Handle" ) ) {
1538        $name = "unknown";
1539        $handle = $file;
1540    } else {
1541        $name = $file;
1542        if ( $opts{ -backup } and ( -f $name ) ) {
1543            copy_file( $name, $name . "~", -overwrite => 1 );
1544        }; # if
1545        $handle = IO::File->new( $name, $mode )
1546            or runtime_error( "File \"$name\" could not be opened for output: $!" );
1547    }; # if
1548    if ( $opts{ -binary } ) {
1549        binmode( $handle );
1550    } elsif ( $opts{ -layer } ) {
1551        binmode( $handle, $opts{ -layer } );
1552    }; # if
1553    if ( ref( $bulk ) eq "" ) {
1554        if ( defined( $bulk ) ) {
1555            $handle->print( $bulk );
1556            if ( not $opts{ -binary } and ( substr( $bulk, -1 ) ne "\n" ) ) {
1557                $handle->print( "\n" );
1558            }; # if
1559        }; # if
1560    } elsif ( ref( $bulk ) eq "SCALAR" ) {
1561        if ( defined( $$bulk ) ) {
1562            $handle->print( $$bulk );
1563            if ( not $opts{ -binary } and ( substr( $$bulk, -1 ) ne "\n" ) ) {
1564                $handle->print( "\n" );
1565            }; # if
1566        }; # if
1567    } elsif ( ref( $bulk ) eq "ARRAY" ) {
1568        foreach my $line ( @$bulk ) {
1569            if ( defined( $line ) ) {
1570                $handle->print( $line );
1571                if ( not $opts{ -binary } and ( substr( $line, -1 ) ne "\n" ) ) {
1572                    $handle->print( "\n" );
1573                }; # if
1574            }; # if
1575        }; # foreach
1576    } else {
1577        Carp::croak( "write_file: \$bulk must be a scalar or reference to (scalar or array)" );
1578    }; # if
1579    $handle->close()
1580        or runtime_error( "File \"$name\" could not be closed after output: $!" );
1581
1582}; # sub write_file
1583
1584#--------------------------------------------------------------------------------------------------
1585
1586=cut
1587
1588# =================================================================================================
1589# Execution subroutines.
1590# =================================================================================================
1591
1592=head2 Execution subroutines.
1593
1594=over
1595
1596=cut
1597
1598#--------------------------------------------------------------------------------------------------
1599
1600sub _pre {
1601
1602    my $arg = shift( @_ );
1603
1604    # If redirection is not required, exit.
1605    if ( not exists( $arg->{ redir } ) ) {
1606        return 0;
1607    }; # if
1608
1609    # Input parameters.
1610    my $mode   = $arg->{ mode   }; # Mode, "<" (input ) or ">" (output).
1611    my $handle = $arg->{ handle }; # Handle to manipulate.
1612    my $redir  = $arg->{ redir  }; # Data, a file name if a scalar, or file contents, if a reference.
1613
1614    # Output parameters.
1615    my $save_handle;
1616    my $temp_handle;
1617    my $temp_name;
1618
1619    # Save original handle (by duping it).
1620    $save_handle = Symbol::gensym();
1621    $handle->flush();
1622    open( $save_handle, $mode . "&" . $handle->fileno() )
1623        or die( "Cannot dup filehandle: $!" );
1624
1625    # Prepare a file to IO.
1626    if ( UNIVERSAL::isa( $redir, "IO::Handle" ) or ( ref( $redir ) eq "GLOB" ) ) {
1627        # $redir is reference to an object of IO::Handle class (or its decedant).
1628        $temp_handle = $redir;
1629    } elsif ( ref( $redir ) ) {
1630        # $redir is a reference to content to be read/written.
1631        # Prepare temp file.
1632        ( $temp_handle, $temp_name ) =
1633            File::Temp::tempfile(
1634                "$tool.XXXXXXXX",
1635                DIR    => File::Spec->tmpdir(),
1636                SUFFIX => ".tmp",
1637                UNLINK => 1
1638            );
1639        if ( not defined( $temp_handle ) ) {
1640            runtime_error( "Could not create temp file." );
1641        }; # if
1642        if ( $mode eq "<" ) {
1643            # It is a file to be read by child, prepare file content to be read.
1644            $temp_handle->print( ref( $redir ) eq "SCALAR" ? ${ $redir } : @{ $redir } );
1645            $temp_handle->flush();
1646            seek( $temp_handle, 0, 0 );
1647                # Unfortunatelly, I could not use OO interface to seek.
1648                # ActivePerl 5.6.1 complains on both forms:
1649                #    $temp_handle->seek( 0 );    # As declared in IO::Seekable.
1650                #    $temp_handle->setpos( 0 );  # As described in documentation.
1651        } elsif ( $mode eq ">" ) {
1652            # It is a file for output. Clear output variable.
1653            if ( ref( $redir ) eq "SCALAR" ) {
1654                ${ $redir } = "";
1655            } else {
1656                @{ $redir } = ();
1657            }; # if
1658        }; # if
1659    } else {
1660        # $redir is a name of file to be read/written.
1661        # Just open file.
1662        if ( defined( $redir ) ) {
1663            $temp_name = $redir;
1664        } else {
1665            $temp_name = File::Spec->devnull();
1666        }; # if
1667        $temp_handle = IO::File->new( $temp_name, $mode )
1668            or runtime_error( "file \"$temp_name\" could not be opened for " . ( $mode eq "<" ? "input" : "output" ) . ": $!" );
1669    }; # if
1670
1671    # Redirect handle to temp file.
1672    open( $handle, $mode . "&" . $temp_handle->fileno() )
1673        or die( "Cannot dup filehandle: $!" );
1674
1675    # Save output parameters.
1676    $arg->{ save_handle } = $save_handle;
1677    $arg->{ temp_handle } = $temp_handle;
1678    $arg->{ temp_name   } = $temp_name;
1679
1680}; # sub _pre
1681
1682
1683sub _post {
1684
1685    my $arg = shift( @_ );
1686
1687    # Input parameters.
1688    my $mode   = $arg->{ mode   }; # Mode, "<" or ">".
1689    my $handle = $arg->{ handle }; # Handle to save and set.
1690    my $redir  = $arg->{ redir  }; # Data, a file name if a scalar, or file contents, if a reference.
1691
1692    # Parameters saved during preprocessing.
1693    my $save_handle = $arg->{ save_handle };
1694    my $temp_handle = $arg->{ temp_handle };
1695    my $temp_name   = $arg->{ temp_name   };
1696
1697    # If no handle was saved, exit.
1698    if ( not $save_handle ) {
1699        return 0;
1700    }; # if
1701
1702    # Close handle.
1703    $handle->close()
1704        or die( "$!" );
1705
1706    # Read the content of temp file, if necessary, and close temp file.
1707    if ( ( $mode ne "<" ) and ref( $redir ) ) {
1708        $temp_handle->flush();
1709        seek( $temp_handle, 0, 0 );
1710        if ( $^O =~ m/MSWin/ ) {
1711            binmode( $temp_handle, ":crlf" );
1712        }; # if
1713        if ( ref( $redir ) eq "SCALAR" ) {
1714            ${ $redir } .= join( "", $temp_handle->getlines() );
1715        } elsif ( ref( $redir ) eq "ARRAY" ) {
1716            push( @{ $redir }, $temp_handle->getlines() );
1717        }; # if
1718    }; # if
1719    if ( not UNIVERSAL::isa( $redir, "IO::Handle" ) ) {
1720        $temp_handle->close()
1721            or die( "$!" );
1722    }; # if
1723
1724    # Restore handle to original value.
1725    $save_handle->flush();
1726    open( $handle, $mode . "&" . $save_handle->fileno() )
1727        or die( "Cannot dup filehandle: $!" );
1728
1729    # Close save handle.
1730    $save_handle->close()
1731        or die( "$!" );
1732
1733    # Delete parameters saved during preprocessing.
1734    delete( $arg->{ save_handle } );
1735    delete( $arg->{ temp_handle } );
1736    delete( $arg->{ temp_name   } );
1737
1738}; # sub _post
1739
1740#--------------------------------------------------------------------------------------------------
1741
1742=item C<execute( [ @command ], @options )>
1743
1744Execute specified program or shell command.
1745
1746Program is specified by reference to an array, that array is passed to C<system()> function which
1747executes the command. See L<perlfunc> for details how C<system()> interprets various forms of
1748C<@command>.
1749
1750By default, in case of any error error message is issued and script terminated (by runtime_error()).
1751Function returns an exit code of program.
1752
1753Alternatively, he function may return exit status of the program (see C<-ignore_status>) or signal
1754(see C<-ignore_signal>) so caller may analyze it and continue execution.
1755
1756Options:
1757
1758=over
1759
1760=item C<-stdin>
1761
1762Redirect stdin of program. The value of option can be:
1763
1764=over
1765
1766=item C<undef>
1767
1768Stdin of child is attached to null device.
1769
1770=item a string
1771
1772Stdin of child is attached to a file with name specified by option.
1773
1774=item a reference to a scalar
1775
1776A dereferenced scalar is written to a temp file, and child's stdin is attached to that file.
1777
1778=item a reference to an array
1779
1780A dereferenced array is written to a temp file, and child's stdin is attached to that file.
1781
1782=back
1783
1784=item C<-stdout>
1785
1786Redirect stdout. Possible values are the same as for C<-stdin> option. The only difference is
1787reference specifies a variable receiving program's output.
1788
1789=item C<-stderr>
1790
1791It similar to C<-stdout>, but redirects stderr. There is only one additional value:
1792
1793=over
1794
1795=item an empty string
1796
1797means that stderr should be redirected to the same place where stdout is redirected to.
1798
1799=back
1800
1801=item C<-append>
1802
1803Redirected stream will not overwrite previous content of file (or variable).
1804Note, that option affects both stdout and stderr.
1805
1806=item C<-ignore_status>
1807
1808By default, subroutine raises an error and exits the script if program returns non-exit status. If
1809this options is true, no error is raised. Instead, status is returned as function result (and $@ is
1810set to error message).
1811
1812=item C<-ignore_signal>
1813
1814By default, subroutine raises an error and exits the script if program die with signal. If
1815this options is true, no error is raised in such a case. Instead, signal number is returned (as
1816negative value), error message is placed to C<$@> variable.
1817
1818If command is not even started, -256 is returned.
1819
1820=back
1821
1822Examples:
1823
1824    execute( [ "cmd.exe", "/c", "dir" ] );
1825        # Execute NT shell with specified options, no redirections are
1826        # made.
1827
1828    my $output;
1829    execute( [ "cvs", "-n", "-q", "update", "." ], -stdout => \$output );
1830        # Execute "cvs -n -q update ." command, output is saved
1831        # in $output variable.
1832
1833    my @output;
1834    execute( [ qw( cvs -n -q update . ) ], -stdout => \@output, -stderr => undef );
1835        # Execute specified command,  output is saved in @output
1836        # variable, stderr stream is redirected to null device
1837        # (/dev/null in Linux* OS and nul in Windows* OS).
1838
1839=cut
1840
1841sub execute($@) {
1842
1843    # !!! Add something to complain on unknown options...
1844
1845    my $command = shift( @_ );
1846    my %opts    = @_;
1847    my $prefix  = "Could not execute $command->[ 0 ]";
1848
1849    check_opts( %opts, [ qw( -stdin -stdout -stderr -append -ignore_status -ignore_signal ) ] );
1850
1851    if ( ref( $command ) ne "ARRAY" ) {
1852        Carp::croak( "execute: $command must be a reference to array" );
1853    }; # if
1854
1855    my $stdin  = { handle => \*STDIN,  mode => "<" };
1856    my $stdout = { handle => \*STDOUT, mode => ">" };
1857    my $stderr = { handle => \*STDERR, mode => ">" };
1858    my $streams = {
1859        stdin  => $stdin,
1860        stdout => $stdout,
1861        stderr => $stderr
1862    }; # $streams
1863
1864    for my $stream ( qw( stdin stdout stderr ) ) {
1865        if ( exists( $opts{ "-$stream" } ) ) {
1866            if ( ref( $opts{ "-$stream" } ) !~ m/\A(|SCALAR|ARRAY)\z/ ) {
1867                Carp::croak( "execute: -$stream option: must have value of scalar, or reference to (scalar or array)." );
1868            }; # if
1869            $streams->{ $stream }->{ redir } = $opts{ "-$stream" };
1870        }; # if
1871        if ( $opts{ -append } and ( $streams->{ $stream }->{ mode } ) eq ">" ) {
1872            $streams->{ $stream }->{ mode } = ">>";
1873        }; # if
1874    }; # foreach $stream
1875
1876    _pre( $stdin  );
1877    _pre( $stdout );
1878    if ( defined( $stderr->{ redir } ) and not ref( $stderr->{ redir } ) and ( $stderr->{ redir } eq "" ) ) {
1879        if ( exists( $stdout->{ redir } ) ) {
1880            $stderr->{ redir } = $stdout->{ temp_handle };
1881        } else {
1882            $stderr->{ redir } = ${ $stdout->{ handle } };
1883        }; # if
1884    }; # if
1885    _pre( $stderr );
1886    my $rc = system( @$command );
1887    my $errno = $!;
1888    my $child = $?;
1889    _post( $stderr );
1890    _post( $stdout );
1891    _post( $stdin  );
1892
1893    my $exit = 0;
1894    my $signal_num  = $child & 127;
1895    my $exit_status = $child >> 8;
1896    $@ = "";
1897
1898    if ( $rc == -1 ) {
1899        $@ = "\"$command->[ 0 ]\" failed: $errno";
1900        $exit = -256;
1901        if ( not $opts{ -ignore_signal } ) {
1902            runtime_error( $@ );
1903        }; # if
1904    } elsif ( $signal_num != 0 ) {
1905        $@ = "\"$command->[ 0 ]\" failed due to signal $signal_num.";
1906        $exit = - $signal_num;
1907        if ( not $opts{ -ignore_signal } ) {
1908            runtime_error( $@ );
1909        }; # if
1910    } elsif ( $exit_status != 0 ) {
1911        $@ = "\"$command->[ 0 ]\" returned non-zero status $exit_status.";
1912        $exit = $exit_status;
1913        if ( not $opts{ -ignore_status } ) {
1914            runtime_error( $@ );
1915        }; # if
1916    }; # if
1917
1918    return $exit;
1919
1920}; # sub execute
1921
1922#--------------------------------------------------------------------------------------------------
1923
1924=item C<backticks( [ @command ], @options )>
1925
1926Run specified program or shell command and return output.
1927
1928In scalar context entire output is returned in a single string. In list context list of strings
1929is returned. Function issues an error and exits script if any error occurs.
1930
1931=cut
1932
1933
1934sub backticks($@) {
1935
1936    my $command = shift( @_ );
1937    my %opts    = @_;
1938    my @output;
1939
1940    check_opts( %opts, [ qw( -chomp ) ] );
1941
1942    execute( $command, -stdout => \@output );
1943
1944    if ( $opts{ -chomp } ) {
1945        chomp( @output );
1946    }; # if
1947
1948    return ( wantarray() ? @output : join( "", @output ) );
1949
1950}; # sub backticks
1951
1952#--------------------------------------------------------------------------------------------------
1953
1954sub pad($$$) {
1955    my ( $str, $length, $pad ) = @_;
1956    my $lstr = length( $str );    # Length of source string.
1957    if ( $lstr < $length ) {
1958        my $lpad  = length( $pad );                         # Length of pad.
1959        my $count = int( ( $length - $lstr ) / $lpad );     # Number of pad repetitions.
1960        my $tail  = $length - ( $lstr + $lpad * $count );
1961        $str = $str . ( $pad x $count ) . substr( $pad, 0, $tail );
1962    }; # if
1963    return $str;
1964}; # sub pad
1965
1966# --------------------------------------------------------------------------------------------------
1967
1968=back
1969
1970=cut
1971
1972#--------------------------------------------------------------------------------------------------
1973
1974return 1;
1975
1976#--------------------------------------------------------------------------------------------------
1977
1978=cut
1979
1980# End of file.
1981