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