ef7738240c
Modern Fortran compilers support Fortran 90, so we do not need to use the source code for Fortran compilers that do not support Fortran 90. Differential Revision: https://reviews.llvm.org/D90077
1977 lines
56 KiB
Perl
1977 lines
56 KiB
Perl
#
|
|
# This is not a runnable script, it is a Perl module, a collection of variables, subroutines, etc.
|
|
# to be used in other scripts.
|
|
#
|
|
# To get help about exported variables and subroutines, please execute the following command:
|
|
#
|
|
# perldoc tools.pm
|
|
#
|
|
# or see POD (Plain Old Documentation) imbedded to the source...
|
|
#
|
|
#
|
|
#//===----------------------------------------------------------------------===//
|
|
#//
|
|
#// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
|
|
#// See https://llvm.org/LICENSE.txt for license information.
|
|
#// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
|
|
#//
|
|
#//===----------------------------------------------------------------------===//
|
|
#
|
|
|
|
=head1 NAME
|
|
|
|
B<tools.pm> -- A collection of subroutines which are widely used in Perl scripts.
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use FindBin;
|
|
use lib "$FindBin::Bin/lib";
|
|
use tools;
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
B<Note:> Because this collection is small and intended for widely using in particular project,
|
|
all variables and functions are exported by default.
|
|
|
|
B<Note:> I have some ideas how to improve this collection, but it is in my long-term plans.
|
|
Current shape is not ideal, but good enough to use.
|
|
|
|
=cut
|
|
|
|
package tools;
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
use vars qw( @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS );
|
|
require Exporter;
|
|
@ISA = qw( Exporter );
|
|
|
|
my @vars = qw( $tool );
|
|
my @utils = qw( check_opts validate );
|
|
my @opts = qw( get_options );
|
|
my @print = qw( debug info warning cmdline_error runtime_error question );
|
|
my @name = qw( get_vol get_dir get_file get_name get_ext cat_file cat_dir );
|
|
my @file = qw( which abs_path rel_path real_path make_dir clean_dir copy_dir move_dir del_dir change_dir copy_file move_file del_file );
|
|
my @io = qw( read_file write_file );
|
|
my @exec = qw( execute backticks );
|
|
my @string = qw{ pad };
|
|
@EXPORT = ( @utils, @opts, @vars, @print, @name, @file, @io, @exec, @string );
|
|
|
|
use UNIVERSAL ();
|
|
|
|
use FindBin;
|
|
use IO::Handle;
|
|
use IO::File;
|
|
use IO::Dir;
|
|
# Not available on some machines: use IO::Zlib;
|
|
|
|
use Getopt::Long ();
|
|
use Pod::Usage ();
|
|
use Carp ();
|
|
use File::Copy ();
|
|
use File::Path ();
|
|
use File::Temp ();
|
|
use File::Spec ();
|
|
use POSIX qw{ :fcntl_h :errno_h };
|
|
use Cwd ();
|
|
use Symbol ();
|
|
|
|
use Data::Dumper;
|
|
|
|
use vars qw( $tool $verbose $timestamps );
|
|
$tool = $FindBin::Script;
|
|
|
|
my @warning = ( sub {}, \&warning, \&runtime_error );
|
|
|
|
|
|
sub check_opts(\%$;$) {
|
|
|
|
my $opts = shift( @_ ); # Reference to hash containing real options and their values.
|
|
my $good = shift( @_ ); # Reference to an array containing all known option names.
|
|
my $msg = shift( @_ ); # Optional (non-mandatory) message.
|
|
|
|
if ( not defined( $msg ) ) {
|
|
$msg = "unknown option(s) passed"; # Default value for $msg.
|
|
}; # if
|
|
|
|
# I'll use these hashes as sets of options.
|
|
my %good = map( ( $_ => 1 ), @$good ); # %good now is filled with all known options.
|
|
my %bad; # %bad is empty.
|
|
|
|
foreach my $opt ( keys( %$opts ) ) { # For each real option...
|
|
if ( not exists( $good{ $opt } ) ) { # Look its name in the set of known options...
|
|
$bad{ $opt } = 1; # Add unknown option to %bad set.
|
|
delete( $opts->{ $opt } ); # And delete original option.
|
|
}; # if
|
|
}; # foreach $opt
|
|
if ( %bad ) { # If %bad set is not empty...
|
|
my @caller = caller( 1 ); # Issue a warning.
|
|
local $Carp::CarpLevel = 2;
|
|
Carp::cluck( $caller[ 3 ] . ": " . $msg . ": " . join( ", ", sort( keys( %bad ) ) ) );
|
|
}; # if
|
|
|
|
return 1;
|
|
|
|
}; # sub check_opts
|
|
|
|
|
|
# --------------------------------------------------------------------------------------------------
|
|
# Purpose:
|
|
# Check subroutine arguments.
|
|
# Synopsis:
|
|
# my %opts = validate( params => \@_, spec => { ... }, caller => n );
|
|
# Arguments:
|
|
# params -- A reference to subroutine's actual arguments.
|
|
# spec -- Specification of expected arguments.
|
|
# caller -- ...
|
|
# Return value:
|
|
# A hash of validated options.
|
|
# Description:
|
|
# I would like to use Params::Validate module, but it is not a part of default Perl
|
|
# distribution, so I cannot rely on it. This subroutine resembles to some extent to
|
|
# Params::Validate::validate_with().
|
|
# Specification of expected arguments:
|
|
# { $opt => { type => $type, default => $default }, ... }
|
|
# $opt -- String, option name.
|
|
# $type -- String, expected type(s). Allowed values are "SCALAR", "UNDEF", "BOOLEAN",
|
|
# "ARRAYREF", "HASHREF", "CODEREF". Multiple types may listed using bar:
|
|
# "SCALAR|ARRAYREF". The type string is case-insensitive.
|
|
# $default -- Default value for an option. Will be used if option is not specified or
|
|
# undefined.
|
|
#
|
|
sub validate(@) {
|
|
|
|
my %opts = @_; # Temporary use %opts for parameters of `validate' subroutine.
|
|
my $params = $opts{ params };
|
|
my $caller = ( $opts{ caller } or 0 ) + 1;
|
|
my $spec = $opts{ spec };
|
|
undef( %opts ); # Ok, Clean %opts, now we will collect result of the subroutine.
|
|
|
|
# Find out caller package, filename, line, and subroutine name.
|
|
my ( $pkg, $file, $line, $subr ) = caller( $caller );
|
|
my @errors; # We will collect errors in array not to stop on the first found error.
|
|
my $error =
|
|
sub ($) {
|
|
my $msg = shift( @_ );
|
|
push( @errors, "$msg at $file line $line.\n" );
|
|
}; # sub
|
|
|
|
# Check options.
|
|
while ( @$params ) {
|
|
# Check option name.
|
|
my $opt = shift( @$params );
|
|
if ( not exists( $spec->{ $opt } ) ) {
|
|
$error->( "Invalid option `$opt'" );
|
|
shift( @$params ); # Skip value of unknow option.
|
|
next;
|
|
}; # if
|
|
# Check option value exists.
|
|
if ( not @$params ) {
|
|
$error->( "Option `$opt' does not have a value" );
|
|
next;
|
|
}; # if
|
|
my $val = shift( @$params );
|
|
# Check option value type.
|
|
if ( exists( $spec->{ $opt }->{ type } ) ) {
|
|
# Type specification exists. Check option value type.
|
|
my $actual_type;
|
|
if ( ref( $val ) ne "" ) {
|
|
$actual_type = ref( $val ) . "REF";
|
|
} else {
|
|
$actual_type = ( defined( $val ) ? "SCALAR" : "UNDEF" );
|
|
}; # if
|
|
my @wanted_types = split( m{\|}, lc( $spec->{ $opt }->{ type } ) );
|
|
my $wanted_types = join( "|", map( $_ eq "boolean" ? "scalar|undef" : quotemeta( $_ ), @wanted_types ) );
|
|
if ( $actual_type !~ m{\A(?:$wanted_types)\z}i ) {
|
|
$actual_type = lc( $actual_type );
|
|
$wanted_types = lc( join( " or ", map( "`$_'", @wanted_types ) ) );
|
|
$error->( "Option `$opt' value type is `$actual_type' but expected to be $wanted_types" );
|
|
next;
|
|
}; # if
|
|
}; # if
|
|
if ( exists( $spec->{ $opt }->{ values } ) ) {
|
|
my $values = $spec->{ $opt }->{ values };
|
|
if ( not grep( $_ eq $val, @$values ) ) {
|
|
$values = join( ", ", map( "`$_'", @$values ) );
|
|
$error->( "Option `$opt' value is `$val' but expected to be one of $values" );
|
|
next;
|
|
}; # if
|
|
}; # if
|
|
$opts{ $opt } = $val;
|
|
}; # while
|
|
|
|
# Assign default values.
|
|
foreach my $opt ( keys( %$spec ) ) {
|
|
if ( not defined( $opts{ $opt } ) and exists( $spec->{ $opt }->{ default } ) ) {
|
|
$opts{ $opt } = $spec->{ $opt }->{ default };
|
|
}; # if
|
|
}; # foreach $opt
|
|
|
|
# If we found any errors, raise them.
|
|
if ( @errors ) {
|
|
die join( "", @errors );
|
|
}; # if
|
|
|
|
return %opts;
|
|
|
|
}; # sub validate
|
|
|
|
# =================================================================================================
|
|
# Get option helpers.
|
|
# =================================================================================================
|
|
|
|
=head2 Get option helpers.
|
|
|
|
=cut
|
|
|
|
# -------------------------------------------------------------------------------------------------
|
|
|
|
=head3 get_options
|
|
|
|
B<Synopsis:>
|
|
|
|
get_options( @arguments )
|
|
|
|
B<Description:>
|
|
|
|
It is very simple wrapper arounf Getopt::Long::GetOptions. It passes all arguments to GetOptions,
|
|
and add definitions for standard help options: --help, --doc, --verbose, and --quiet.
|
|
When GetOptions finishes, this subroutine checks exit code, if it is non-zero, standard error
|
|
message is issued and script terminated.
|
|
|
|
If --verbose or --quiet option is specified, C<tools.pm_verbose> environment variable is set.
|
|
It is the way to propagate verbose/quiet mode to callee Perl scripts.
|
|
|
|
=cut
|
|
|
|
sub get_options {
|
|
|
|
Getopt::Long::Configure( "no_ignore_case" );
|
|
Getopt::Long::GetOptions(
|
|
"h0|usage" => sub { Pod::Usage::pod2usage( -exitval => 0, -verbose => 0 ); },
|
|
"h1|h|help" => sub { Pod::Usage::pod2usage( -exitval => 0, -verbose => 1 ); },
|
|
"h2|doc|manual" => sub { Pod::Usage::pod2usage( -exitval => 0, -verbose => 2 ); },
|
|
"version" => sub { print( "$tool version $main::VERSION\n" ); exit( 0 ); },
|
|
"v|verbose" => sub { ++ $verbose; $ENV{ "tools.pm_verbose" } = $verbose; },
|
|
"quiet" => sub { -- $verbose; $ENV{ "tools.pm_verbose" } = $verbose; },
|
|
"with-timestamps" => sub { $timestamps = 1; $ENV{ "tools.pm_timestamps" } = $timestamps; },
|
|
@_, # Caller arguments are at the end so caller options overrides standard.
|
|
) or cmdline_error();
|
|
|
|
}; # sub get_options
|
|
|
|
|
|
# =================================================================================================
|
|
# Print utilities.
|
|
# =================================================================================================
|
|
|
|
=pod
|
|
|
|
=head2 Print utilities.
|
|
|
|
Each of the print subroutines prepends each line of its output with the name of current script and
|
|
the type of information, for example:
|
|
|
|
info( "Writing file..." );
|
|
|
|
will print
|
|
|
|
<script>: (i): Writing file...
|
|
|
|
while
|
|
|
|
warning( "File does not exist!" );
|
|
|
|
will print
|
|
|
|
<script>: (!): File does not exist!
|
|
|
|
Here are exported items:
|
|
|
|
=cut
|
|
|
|
# -------------------------------------------------------------------------------------------------
|
|
|
|
sub _format_message($\@;$) {
|
|
|
|
my $prefix = shift( @_ );
|
|
my $args = shift( @_ );
|
|
my $no_eol = shift( @_ ); # Do not append "\n" to the last line.
|
|
my $message = "";
|
|
|
|
my $ts = "";
|
|
if ( $timestamps ) {
|
|
my ( $sec, $min, $hour, $day, $month, $year ) = gmtime();
|
|
$month += 1;
|
|
$year += 1900;
|
|
$ts = sprintf( "%04d-%02d-%02d %02d:%02d:%02d UTC: ", $year, $month, $day, $hour, $min, $sec );
|
|
}; # if
|
|
for my $i ( 1 .. @$args ) {
|
|
my @lines = split( "\n", $args->[ $i - 1 ] );
|
|
for my $j ( 1 .. @lines ) {
|
|
my $line = $lines[ $j - 1 ];
|
|
my $last_line = ( ( $i == @$args ) and ( $j == @lines ) );
|
|
my $eol = ( ( substr( $line, -1 ) eq "\n" ) or defined( $no_eol ) ? "" : "\n" );
|
|
$message .= "$ts$tool: ($prefix) " . $line . $eol;
|
|
}; # foreach $j
|
|
}; # foreach $i
|
|
return $message;
|
|
|
|
}; # sub _format_message
|
|
|
|
#--------------------------------------------------------------------------------------------------
|
|
|
|
=pod
|
|
|
|
=head3 $verbose
|
|
|
|
B<Synopsis:>
|
|
|
|
$verbose
|
|
|
|
B<Description:>
|
|
|
|
Package variable. It determines verbosity level, which affects C<warning()>, C<info()>, and
|
|
C<debug()> subroutines .
|
|
|
|
The variable gets initial value from C<tools.pm_verbose> environment variable if it is exists.
|
|
If the environment variable does not exist, variable is set to 2.
|
|
|
|
Initial value may be overridden later directly or by C<get_options> function.
|
|
|
|
=cut
|
|
|
|
$verbose = exists( $ENV{ "tools.pm_verbose" } ) ? $ENV{ "tools.pm_verbose" } : 2;
|
|
|
|
#--------------------------------------------------------------------------------------------------
|
|
|
|
=pod
|
|
|
|
=head3 $timestamps
|
|
|
|
B<Synopsis:>
|
|
|
|
$timestamps
|
|
|
|
B<Description:>
|
|
|
|
Package variable. It determines whether C<debug()>, C<info()>, C<warning()>, C<runtime_error()>
|
|
subroutines print timestamps or not.
|
|
|
|
The variable gets initial value from C<tools.pm_timestamps> environment variable if it is exists.
|
|
If the environment variable does not exist, variable is set to false.
|
|
|
|
Initial value may be overridden later directly or by C<get_options()> function.
|
|
|
|
=cut
|
|
|
|
$timestamps = exists( $ENV{ "tools.pm_timestamps" } ) ? $ENV{ "tools.pm_timestamps" } : 0;
|
|
|
|
# -------------------------------------------------------------------------------------------------
|
|
|
|
=pod
|
|
|
|
=head3 debug
|
|
|
|
B<Synopsis:>
|
|
|
|
debug( @messages )
|
|
|
|
B<Description:>
|
|
|
|
If verbosity level is 3 or higher, print debug information to the stderr, prepending it with "(#)"
|
|
prefix.
|
|
|
|
=cut
|
|
|
|
sub debug(@) {
|
|
|
|
if ( $verbose >= 3 ) {
|
|
STDOUT->flush();
|
|
STDERR->print( _format_message( "#", @_ ) );
|
|
}; # if
|
|
return 1;
|
|
|
|
}; # sub debug
|
|
|
|
#--------------------------------------------------------------------------------------------------
|
|
|
|
=pod
|
|
|
|
=head3 info
|
|
|
|
B<Synopsis:>
|
|
|
|
info( @messages )
|
|
|
|
B<Description:>
|
|
|
|
If verbosity level is 2 or higher, print information to the stderr, prepending it with "(i)" prefix.
|
|
|
|
=cut
|
|
|
|
sub info(@) {
|
|
|
|
if ( $verbose >= 2 ) {
|
|
STDOUT->flush();
|
|
STDERR->print( _format_message( "i", @_ ) );
|
|
}; # if
|
|
|
|
}; # sub info
|
|
|
|
#--------------------------------------------------------------------------------------------------
|
|
|
|
=head3 warning
|
|
|
|
B<Synopsis:>
|
|
|
|
warning( @messages )
|
|
|
|
B<Description:>
|
|
|
|
If verbosity level is 1 or higher, issue a warning, prepending it with "(!)" prefix.
|
|
|
|
=cut
|
|
|
|
sub warning(@) {
|
|
|
|
if ( $verbose >= 1 ) {
|
|
STDOUT->flush();
|
|
warn( _format_message( "!", @_ ) );
|
|
}; # if
|
|
|
|
}; # sub warning
|
|
|
|
# -------------------------------------------------------------------------------------------------
|
|
|
|
=head3 cmdline_error
|
|
|
|
B<Synopsis:>
|
|
|
|
cmdline_error( @message )
|
|
|
|
B<Description:>
|
|
|
|
Print error message and exit the program with status 2.
|
|
|
|
This function is intended to complain on command line errors, e. g. unknown
|
|
options, invalid arguments, etc.
|
|
|
|
=cut
|
|
|
|
sub cmdline_error(;$) {
|
|
|
|
my $message = shift( @_ );
|
|
|
|
if ( defined( $message ) ) {
|
|
if ( substr( $message, -1, 1 ) ne "\n" ) {
|
|
$message .= "\n";
|
|
}; # if
|
|
} else {
|
|
$message = "";
|
|
}; # if
|
|
STDOUT->flush();
|
|
die $message . "Try --help option for more information.\n";
|
|
|
|
}; # sub cmdline_error
|
|
|
|
# -------------------------------------------------------------------------------------------------
|
|
|
|
=head3 runtime_error
|
|
|
|
B<Synopsis:>
|
|
|
|
runtime_error( @message )
|
|
|
|
B<Description:>
|
|
|
|
Print error message and exits the program with status 3.
|
|
|
|
This function is intended to complain on runtime errors, e. g.
|
|
directories which are not found, non-writable files, etc.
|
|
|
|
=cut
|
|
|
|
sub runtime_error(@) {
|
|
|
|
STDOUT->flush();
|
|
die _format_message( "x", @_ );
|
|
|
|
}; # sub runtime_error
|
|
|
|
#--------------------------------------------------------------------------------------------------
|
|
|
|
=head3 question
|
|
|
|
B<Synopsis:>
|
|
|
|
question( $prompt; $answer, $choices )
|
|
|
|
B<Description:>
|
|
|
|
Print $promp to the stderr, prepending it with "question:" prefix. Read a line from stdin, chop
|
|
"\n" from the end, it is answer.
|
|
|
|
If $answer is defined, it is treated as first user input.
|
|
|
|
If $choices is specified, it could be a regexp for validating user input, or a string. In latter
|
|
case it interpreted as list of characters, acceptable (case-insensitive) choices. If user enters
|
|
non-acceptable answer, question continue asking until answer is acceptable.
|
|
If $choices is not specified, any answer is acceptable.
|
|
|
|
In case of end-of-file (or Ctrl+D pressed by user), $answer is C<undef>.
|
|
|
|
B<Examples:>
|
|
|
|
my $answer;
|
|
question( "Save file [yn]? ", $answer, "yn" );
|
|
# We accepts only "y", "Y", "n", or "N".
|
|
question( "Press enter to continue or Ctrl+C to abort..." );
|
|
# We are not interested in answer value -- in case of Ctrl+C the script will be terminated,
|
|
# otherwise we continue execution.
|
|
question( "File name? ", $answer );
|
|
# Any answer is acceptable.
|
|
|
|
=cut
|
|
|
|
sub question($;\$$) {
|
|
|
|
my $prompt = shift( @_ );
|
|
my $answer = shift( @_ );
|
|
my $choices = shift( @_ );
|
|
my $a = ( defined( $answer ) ? $$answer : undef );
|
|
|
|
if ( ref( $choices ) eq "Regexp" ) {
|
|
# It is already a regular expression, do nothing.
|
|
} elsif ( defined( $choices ) ) {
|
|
# Convert string to a regular expression.
|
|
$choices = qr/[@{ [ quotemeta( $choices ) ] }]/i;
|
|
}; # if
|
|
|
|
for ( ; ; ) {
|
|
STDERR->print( _format_message( "?", @{ [ $prompt ] }, "no_eol" ) );
|
|
STDERR->flush();
|
|
if ( defined( $a ) ) {
|
|
STDOUT->print( $a . "\n" );
|
|
} else {
|
|
$a = <STDIN>;
|
|
}; # if
|
|
if ( not defined( $a ) ) {
|
|
last;
|
|
}; # if
|
|
chomp( $a );
|
|
if ( not defined( $choices ) or ( $a =~ m/^$choices$/ ) ) {
|
|
last;
|
|
}; # if
|
|
$a = undef;
|
|
}; # forever
|
|
if ( defined( $answer ) ) {
|
|
$$answer = $a;
|
|
}; # if
|
|
|
|
}; # sub question
|
|
|
|
# -------------------------------------------------------------------------------------------------
|
|
|
|
# Returns volume part of path.
|
|
sub get_vol($) {
|
|
|
|
my $path = shift( @_ );
|
|
my ( $vol, undef, undef ) = File::Spec->splitpath( $path );
|
|
return $vol;
|
|
|
|
}; # sub get_vol
|
|
|
|
# Returns directory part of path.
|
|
sub get_dir($) {
|
|
|
|
my $path = File::Spec->canonpath( shift( @_ ) );
|
|
my ( $vol, $dir, undef ) = File::Spec->splitpath( $path );
|
|
my @dirs = File::Spec->splitdir( $dir );
|
|
pop( @dirs );
|
|
$dir = File::Spec->catdir( @dirs );
|
|
$dir = File::Spec->catpath( $vol, $dir, undef );
|
|
return $dir;
|
|
|
|
}; # sub get_dir
|
|
|
|
# Returns file part of path.
|
|
sub get_file($) {
|
|
|
|
my $path = shift( @_ );
|
|
my ( undef, undef, $file ) = File::Spec->splitpath( $path );
|
|
return $file;
|
|
|
|
}; # sub get_file
|
|
|
|
# Returns file part of path without last suffix.
|
|
sub get_name($) {
|
|
|
|
my $path = shift( @_ );
|
|
my ( undef, undef, $file ) = File::Spec->splitpath( $path );
|
|
$file =~ s{\.[^.]*\z}{};
|
|
return $file;
|
|
|
|
}; # sub get_name
|
|
|
|
# Returns last suffix of file part of path.
|
|
sub get_ext($) {
|
|
|
|
my $path = shift( @_ );
|
|
my ( undef, undef, $file ) = File::Spec->splitpath( $path );
|
|
my $ext = "";
|
|
if ( $file =~ m{(\.[^.]*)\z} ) {
|
|
$ext = $1;
|
|
}; # if
|
|
return $ext;
|
|
|
|
}; # sub get_ext
|
|
|
|
sub cat_file(@) {
|
|
|
|
my $path = shift( @_ );
|
|
my $file = pop( @_ );
|
|
my @dirs = @_;
|
|
|
|
my ( $vol, $dirs ) = File::Spec->splitpath( $path, "no_file" );
|
|
@dirs = ( File::Spec->splitdir( $dirs ), @dirs );
|
|
$dirs = File::Spec->catdir( @dirs );
|
|
$path = File::Spec->catpath( $vol, $dirs, $file );
|
|
|
|
return $path;
|
|
|
|
}; # sub cat_file
|
|
|
|
sub cat_dir(@) {
|
|
|
|
my $path = shift( @_ );
|
|
my @dirs = @_;
|
|
|
|
my ( $vol, $dirs ) = File::Spec->splitpath( $path, "no_file" );
|
|
@dirs = ( File::Spec->splitdir( $dirs ), @dirs );
|
|
$dirs = File::Spec->catdir( @dirs );
|
|
$path = File::Spec->catpath( $vol, $dirs, "" );
|
|
|
|
return $path;
|
|
|
|
}; # sub cat_dir
|
|
|
|
# =================================================================================================
|
|
# File and directory manipulation subroutines.
|
|
# =================================================================================================
|
|
|
|
=head2 File and directory manipulation subroutines.
|
|
|
|
=over
|
|
|
|
=cut
|
|
|
|
# -------------------------------------------------------------------------------------------------
|
|
|
|
=item C<which( $file, @options )>
|
|
|
|
Searches for specified executable file in the (specified) directories.
|
|
Raises a runtime eroror if no executable file found. Returns a full path of found executable(s).
|
|
|
|
Options:
|
|
|
|
=over
|
|
|
|
=item C<-all> =E<gt> I<bool>
|
|
|
|
Do not stop on the first found file. Note, that list of full paths is returned in this case.
|
|
|
|
=item C<-dirs> =E<gt> I<ref_to_array>
|
|
|
|
Specify directory list to search through. If option is not passed, PATH environment variable
|
|
is used for directory list.
|
|
|
|
=item C<-exec> =E<gt> I<bool>
|
|
|
|
Whether check for executable files or not. By default, C<which> searches executable files.
|
|
However, on Cygwin executable check never performed.
|
|
|
|
=back
|
|
|
|
Examples:
|
|
|
|
Look for "echo" in the directories specified in PATH:
|
|
|
|
my $echo = which( "echo" );
|
|
|
|
Look for all occurrences of "cp" in the PATH:
|
|
|
|
my @cps = which( "cp", -all => 1 );
|
|
|
|
Look for the first occurrence of "icc" in the specified directories:
|
|
|
|
my $icc = which( "icc", -dirs => [ ".", "/usr/local/bin", "/usr/bin", "/bin" ] );
|
|
|
|
=cut
|
|
|
|
sub which($@) {
|
|
|
|
my $file = shift( @_ );
|
|
my %opts = @_;
|
|
|
|
check_opts( %opts, [ qw( -all -dirs -exec ) ] );
|
|
if ( $opts{ -all } and not wantarray() ) {
|
|
local $Carp::CarpLevel = 1;
|
|
Carp::cluck( "`-all' option passed to `which' but list is not expected" );
|
|
}; # if
|
|
if ( not defined( $opts{ -exec } ) ) {
|
|
$opts{ -exec } = 1;
|
|
}; # if
|
|
|
|
my $dirs = ( exists( $opts{ -dirs } ) ? $opts{ -dirs } : [ File::Spec->path() ] );
|
|
my @found;
|
|
|
|
my @exts = ( "" );
|
|
if ( $^O eq "MSWin32" and $opts{ -exec } ) {
|
|
if ( defined( $ENV{ PATHEXT } ) ) {
|
|
push( @exts, split( ";", $ENV{ PATHEXT } ) );
|
|
} else {
|
|
# If PATHEXT does not exist, use default value.
|
|
push( @exts, qw{ .COM .EXE .BAT .CMD } );
|
|
}; # if
|
|
}; # if
|
|
|
|
loop:
|
|
foreach my $dir ( @$dirs ) {
|
|
foreach my $ext ( @exts ) {
|
|
my $path = File::Spec->catfile( $dir, $file . $ext );
|
|
if ( -e $path ) {
|
|
# Executable bit is not reliable on Cygwin, do not check it.
|
|
if ( not $opts{ -exec } or -x $path or $^O eq "cygwin" ) {
|
|
push( @found, $path );
|
|
if ( not $opts{ -all } ) {
|
|
last loop;
|
|
}; # if
|
|
}; # if
|
|
}; # if
|
|
}; # foreach $ext
|
|
}; # foreach $dir
|
|
|
|
if ( not @found ) {
|
|
# TBD: We need to introduce an option for conditional enabling this error.
|
|
# runtime_error( "Could not find \"$file\" executable file in PATH." );
|
|
}; # if
|
|
if ( @found > 1 ) {
|
|
# TBD: Issue a warning?
|
|
}; # if
|
|
|
|
if ( $opts{ -all } ) {
|
|
return @found;
|
|
} else {
|
|
return $found[ 0 ];
|
|
}; # if
|
|
|
|
}; # sub which
|
|
|
|
# -------------------------------------------------------------------------------------------------
|
|
|
|
=item C<abs_path( $path, $base )>
|
|
|
|
Return absolute path for an argument.
|
|
|
|
Most of the work is done by C<File::Spec->rel2abs()>. C<abs_path()> additionally collapses
|
|
C<dir1/../dir2> to C<dir2>.
|
|
|
|
It is not so naive and made intentionally. For example on Linux* OS in Bash if F<link/> is a symbolic
|
|
link to directory F<some_dir/>
|
|
|
|
$ cd link
|
|
$ cd ..
|
|
|
|
brings you back to F<link/>'s parent, not to parent of F<some_dir/>,
|
|
|
|
=cut
|
|
|
|
sub abs_path($;$) {
|
|
|
|
my ( $path, $base ) = @_;
|
|
$path = File::Spec->rel2abs( $path, ( defined( $base ) ? $base : $ENV{ PWD } ) );
|
|
my ( $vol, $dir, $file ) = File::Spec->splitpath( $path );
|
|
while ( $dir =~ s{/(?!\.\.)[^/]*/\.\.(?:/|\z)}{/} ) {
|
|
}; # while
|
|
$path = File::Spec->canonpath( File::Spec->catpath( $vol, $dir, $file ) );
|
|
return $path;
|
|
|
|
}; # sub abs_path
|
|
|
|
# -------------------------------------------------------------------------------------------------
|
|
|
|
=item C<rel_path( $path, $base )>
|
|
|
|
Return relative path for an argument.
|
|
|
|
=cut
|
|
|
|
sub rel_path($;$) {
|
|
|
|
my ( $path, $base ) = @_;
|
|
$path = File::Spec->abs2rel( abs_path( $path ), $base );
|
|
return $path;
|
|
|
|
}; # sub rel_path
|
|
|
|
# -------------------------------------------------------------------------------------------------
|
|
|
|
=item C<real_path( $dir )>
|
|
|
|
Return real absolute path for an argument. In the result all relative components (F<.> and F<..>)
|
|
and U<symbolic links are resolved>.
|
|
|
|
In most cases it is not what you want. Consider using C<abs_path> first.
|
|
|
|
C<abs_path> function from B<Cwd> module works with directories only. This function works with files
|
|
as well. But, if file is a symbolic link, function does not resolve it (yet).
|
|
|
|
The function uses C<runtime_error> to raise an error if something wrong.
|
|
|
|
=cut
|
|
|
|
sub real_path($) {
|
|
|
|
my $orig_path = shift( @_ );
|
|
my $real_path;
|
|
my $message = "";
|
|
if ( not -e $orig_path ) {
|
|
$message = "\"$orig_path\" does not exists";
|
|
} else {
|
|
# Cwd::abs_path does not work with files, so in this case we should handle file separately.
|
|
my $file;
|
|
if ( not -d $orig_path ) {
|
|
( my $vol, my $dir, $file ) = File::Spec->splitpath( File::Spec->rel2abs( $orig_path ) );
|
|
$orig_path = File::Spec->catpath( $vol, $dir );
|
|
}; # if
|
|
{
|
|
local $SIG{ __WARN__ } = sub { $message = $_[ 0 ]; };
|
|
$real_path = Cwd::abs_path( $orig_path );
|
|
};
|
|
if ( defined( $file ) ) {
|
|
$real_path = File::Spec->catfile( $real_path, $file );
|
|
}; # if
|
|
}; # if
|
|
if ( not defined( $real_path ) or $message ne "" ) {
|
|
$message =~ s/^stat\(.*\): (.*)\s+at .*? line \d+\s*\z/$1/;
|
|
runtime_error( "Could not find real path for \"$orig_path\"" . ( $message ne "" ? ": $message" : "" ) );
|
|
}; # if
|
|
return $real_path;
|
|
|
|
}; # sub real_path
|
|
|
|
# -------------------------------------------------------------------------------------------------
|
|
|
|
=item C<make_dir( $dir, @options )>
|
|
|
|
Make a directory.
|
|
|
|
This function makes a directory. If necessary, more than one level can be created.
|
|
If directory exists, warning issues (the script behavior depends on value of
|
|
C<-warning_level> option). If directory creation fails or C<$dir> exists but it is not a
|
|
directory, error issues.
|
|
|
|
Options:
|
|
|
|
=over
|
|
|
|
=item C<-mode>
|
|
|
|
The numeric mode for new directories, 0750 (rwxr-x---) by default.
|
|
|
|
=back
|
|
|
|
=cut
|
|
|
|
sub make_dir($@) {
|
|
|
|
my $dir = shift( @_ );
|
|
my %opts =
|
|
validate(
|
|
params => \@_,
|
|
spec => {
|
|
parents => { type => "boolean", default => 1 },
|
|
mode => { type => "scalar", default => 0777 },
|
|
},
|
|
);
|
|
|
|
my $prefix = "Could not create directory \"$dir\"";
|
|
|
|
if ( -e $dir ) {
|
|
if ( -d $dir ) {
|
|
} else {
|
|
runtime_error( "$prefix: it exists, but not a directory." );
|
|
}; # if
|
|
} else {
|
|
eval {
|
|
File::Path::mkpath( $dir, 0, $opts{ mode } );
|
|
}; # eval
|
|
if ( $@ ) {
|
|
$@ =~ s{\s+at (?:[a-zA-Z0-9 /_.]*/)?tools\.pm line \d+\s*}{};
|
|
runtime_error( "$prefix: $@" );
|
|
}; # if
|
|
if ( not -d $dir ) { # Just in case, check it one more time...
|
|
runtime_error( "$prefix." );
|
|
}; # if
|
|
}; # if
|
|
|
|
}; # sub make_dir
|
|
|
|
# -------------------------------------------------------------------------------------------------
|
|
|
|
=item C<copy_dir( $src_dir, $dst_dir, @options )>
|
|
|
|
Copy directory recursively.
|
|
|
|
This function copies a directory recursively.
|
|
If source directory does not exist or not a directory, error issues.
|
|
|
|
Options:
|
|
|
|
=over
|
|
|
|
=item C<-overwrite>
|
|
|
|
Overwrite destination directory, if it exists.
|
|
|
|
=back
|
|
|
|
=cut
|
|
|
|
sub copy_dir($$@) {
|
|
|
|
my $src = shift( @_ );
|
|
my $dst = shift( @_ );
|
|
my %opts = @_;
|
|
my $prefix = "Could not copy directory \"$src\" to \"$dst\"";
|
|
|
|
if ( not -e $src ) {
|
|
runtime_error( "$prefix: \"$src\" does not exist." );
|
|
}; # if
|
|
if ( not -d $src ) {
|
|
runtime_error( "$prefix: \"$src\" is not a directory." );
|
|
}; # if
|
|
if ( -e $dst ) {
|
|
if ( -d $dst ) {
|
|
if ( $opts{ -overwrite } ) {
|
|
del_dir( $dst );
|
|
} else {
|
|
runtime_error( "$prefix: \"$dst\" already exists." );
|
|
}; # if
|
|
} else {
|
|
runtime_error( "$prefix: \"$dst\" is not a directory." );
|
|
}; # if
|
|
}; # if
|
|
|
|
execute( [ "cp", "-R", $src, $dst ] );
|
|
|
|
}; # sub copy_dir
|
|
|
|
# -------------------------------------------------------------------------------------------------
|
|
|
|
=item C<move_dir( $src_dir, $dst_dir, @options )>
|
|
|
|
Move directory.
|
|
|
|
Options:
|
|
|
|
=over
|
|
|
|
=item C<-overwrite>
|
|
|
|
Overwrite destination directory, if it exists.
|
|
|
|
=back
|
|
|
|
=cut
|
|
|
|
sub move_dir($$@) {
|
|
|
|
my $src = shift( @_ );
|
|
my $dst = shift( @_ );
|
|
my %opts = @_;
|
|
my $prefix = "Could not copy directory \"$src\" to \"$dst\"";
|
|
|
|
if ( not -e $src ) {
|
|
runtime_error( "$prefix: \"$src\" does not exist." );
|
|
}; # if
|
|
if ( not -d $src ) {
|
|
runtime_error( "$prefix: \"$src\" is not a directory." );
|
|
}; # if
|
|
if ( -e $dst ) {
|
|
if ( -d $dst ) {
|
|
if ( $opts{ -overwrite } ) {
|
|
del_dir( $dst );
|
|
} else {
|
|
runtime_error( "$prefix: \"$dst\" already exists." );
|
|
}; # if
|
|
} else {
|
|
runtime_error( "$prefix: \"$dst\" is not a directory." );
|
|
}; # if
|
|
}; # if
|
|
|
|
execute( [ "mv", $src, $dst ] );
|
|
|
|
}; # sub move_dir
|
|
|
|
# -------------------------------------------------------------------------------------------------
|
|
|
|
=item C<clean_dir( $dir, @options )>
|
|
|
|
Clean a directory: delete all the entries (recursively), but leave the directory.
|
|
|
|
Options:
|
|
|
|
=over
|
|
|
|
=item C<-force> => bool
|
|
|
|
If a directory is not writable, try to change permissions first, then clean it.
|
|
|
|
=item C<-skip> => regexp
|
|
|
|
Regexp. If a directory entry mached the regexp, it is skipped, not deleted. (As a subsequence,
|
|
a directory containing skipped entries is not deleted.)
|
|
|
|
=back
|
|
|
|
=cut
|
|
|
|
sub _clean_dir($);
|
|
|
|
sub _clean_dir($) {
|
|
our %_clean_dir_opts;
|
|
my ( $dir ) = @_;
|
|
my $skip = $_clean_dir_opts{ skip }; # Regexp.
|
|
my $skipped = 0; # Number of skipped files.
|
|
my $prefix = "Cleaning `$dir' failed:";
|
|
my @stat = stat( $dir );
|
|
my $mode = $stat[ 2 ];
|
|
if ( not @stat ) {
|
|
runtime_error( $prefix, "Cannot stat `$dir': $!" );
|
|
}; # if
|
|
if ( not -d _ ) {
|
|
runtime_error( $prefix, "It is not a directory." );
|
|
}; # if
|
|
if ( not -w _ ) { # Directory is not writable.
|
|
if ( not -o _ or not $_clean_dir_opts{ force } ) {
|
|
runtime_error( $prefix, "Directory is not writable." );
|
|
}; # if
|
|
# Directory is not writable but mine. Try to change permissions.
|
|
chmod( $mode | S_IWUSR, $dir )
|
|
or runtime_error( $prefix, "Cannot make directory writable: $!" );
|
|
}; # if
|
|
my $handle = IO::Dir->new( $dir ) or runtime_error( $prefix, "Cannot read directory: $!" );
|
|
my @entries = File::Spec->no_upwards( $handle->read() );
|
|
$handle->close() or runtime_error( $prefix, "Cannot read directory: $!" );
|
|
foreach my $entry ( @entries ) {
|
|
my $path = cat_file( $dir, $entry );
|
|
if ( defined( $skip ) and $entry =~ $skip ) {
|
|
++ $skipped;
|
|
} else {
|
|
if ( -l $path ) {
|
|
unlink( $path ) or runtime_error( $prefix, "Cannot delete symlink `$path': $!" );
|
|
} else {
|
|
stat( $path ) or runtime_error( $prefix, "Cannot stat `$path': $! " );
|
|
if ( -f _ ) {
|
|
del_file( $path );
|
|
} elsif ( -d _ ) {
|
|
my $rc = _clean_dir( $path );
|
|
if ( $rc == 0 ) {
|
|
rmdir( $path ) or runtime_error( $prefix, "Cannot delete directory `$path': $!" );
|
|
}; # if
|
|
$skipped += $rc;
|
|
} else {
|
|
runtime_error( $prefix, "`$path' is neither a file nor a directory." );
|
|
}; # if
|
|
}; # if
|
|
}; # if
|
|
}; # foreach
|
|
return $skipped;
|
|
}; # sub _clean_dir
|
|
|
|
|
|
sub clean_dir($@) {
|
|
my $dir = shift( @_ );
|
|
our %_clean_dir_opts;
|
|
local %_clean_dir_opts =
|
|
validate(
|
|
params => \@_,
|
|
spec => {
|
|
skip => { type => "regexpref" },
|
|
force => { type => "boolean" },
|
|
},
|
|
);
|
|
my $skipped = _clean_dir( $dir );
|
|
return $skipped;
|
|
}; # sub clean_dir
|
|
|
|
|
|
# -------------------------------------------------------------------------------------------------
|
|
|
|
=item C<del_dir( $dir, @options )>
|
|
|
|
Delete a directory recursively.
|
|
|
|
This function deletes a directory. If directory can not be deleted or it is not a directory, error
|
|
message issues (and script exists).
|
|
|
|
Options:
|
|
|
|
=over
|
|
|
|
=back
|
|
|
|
=cut
|
|
|
|
sub del_dir($@) {
|
|
|
|
my $dir = shift( @_ );
|
|
my %opts = @_;
|
|
my $prefix = "Deleting directory \"$dir\" failed";
|
|
our %_clean_dir_opts;
|
|
local %_clean_dir_opts =
|
|
validate(
|
|
params => \@_,
|
|
spec => {
|
|
force => { type => "boolean" },
|
|
},
|
|
);
|
|
|
|
if ( not -e $dir ) {
|
|
# Nothing to do.
|
|
return;
|
|
}; # if
|
|
if ( not -d $dir ) {
|
|
runtime_error( "$prefix: it is not a directory." );
|
|
}; # if
|
|
_clean_dir( $dir );
|
|
rmdir( $dir ) or runtime_error( "$prefix." );
|
|
|
|
}; # sub del_dir
|
|
|
|
# -------------------------------------------------------------------------------------------------
|
|
|
|
=item C<change_dir( $dir )>
|
|
|
|
Change current directory.
|
|
|
|
If any error occurred, error issues and script exits.
|
|
|
|
=cut
|
|
|
|
sub change_dir($) {
|
|
|
|
my $dir = shift( @_ );
|
|
|
|
Cwd::chdir( $dir )
|
|
or runtime_error( "Could not chdir to \"$dir\": $!" );
|
|
|
|
}; # sub change_dir
|
|
|
|
|
|
# -------------------------------------------------------------------------------------------------
|
|
|
|
=item C<copy_file( $src_file, $dst_file, @options )>
|
|
|
|
Copy file.
|
|
|
|
This function copies a file. If source does not exist or is not a file, error issues.
|
|
|
|
Options:
|
|
|
|
=over
|
|
|
|
=item C<-overwrite>
|
|
|
|
Overwrite destination file, if it exists.
|
|
|
|
=back
|
|
|
|
=cut
|
|
|
|
sub copy_file($$@) {
|
|
|
|
my $src = shift( @_ );
|
|
my $dst = shift( @_ );
|
|
my %opts = @_;
|
|
my $prefix = "Could not copy file \"$src\" to \"$dst\"";
|
|
|
|
if ( not -e $src ) {
|
|
runtime_error( "$prefix: \"$src\" does not exist." );
|
|
}; # if
|
|
if ( not -f $src ) {
|
|
runtime_error( "$prefix: \"$src\" is not a file." );
|
|
}; # if
|
|
if ( -e $dst ) {
|
|
if ( -f $dst ) {
|
|
if ( $opts{ -overwrite } ) {
|
|
del_file( $dst );
|
|
} else {
|
|
runtime_error( "$prefix: \"$dst\" already exists." );
|
|
}; # if
|
|
} else {
|
|
runtime_error( "$prefix: \"$dst\" is not a file." );
|
|
}; # if
|
|
}; # if
|
|
|
|
File::Copy::copy( $src, $dst ) or runtime_error( "$prefix: $!" );
|
|
# On Windows* OS File::Copy preserves file attributes, but on Linux* OS it doesn't.
|
|
# So we should do it manually...
|
|
if ( $^O =~ m/^linux\z/ ) {
|
|
my $mode = ( stat( $src ) )[ 2 ]
|
|
or runtime_error( "$prefix: cannot get status info for source file." );
|
|
chmod( $mode, $dst )
|
|
or runtime_error( "$prefix: cannot change mode of destination file." );
|
|
}; # if
|
|
|
|
}; # sub copy_file
|
|
|
|
# -------------------------------------------------------------------------------------------------
|
|
|
|
sub move_file($$@) {
|
|
|
|
my $src = shift( @_ );
|
|
my $dst = shift( @_ );
|
|
my %opts = @_;
|
|
my $prefix = "Could not move file \"$src\" to \"$dst\"";
|
|
|
|
check_opts( %opts, [ qw( -overwrite ) ] );
|
|
|
|
if ( not -e $src ) {
|
|
runtime_error( "$prefix: \"$src\" does not exist." );
|
|
}; # if
|
|
if ( not -f $src ) {
|
|
runtime_error( "$prefix: \"$src\" is not a file." );
|
|
}; # if
|
|
if ( -e $dst ) {
|
|
if ( -f $dst ) {
|
|
if ( $opts{ -overwrite } ) {
|
|
#
|
|
} else {
|
|
runtime_error( "$prefix: \"$dst\" already exists." );
|
|
}; # if
|
|
} else {
|
|
runtime_error( "$prefix: \"$dst\" is not a file." );
|
|
}; # if
|
|
}; # if
|
|
|
|
File::Copy::move( $src, $dst ) or runtime_error( "$prefix: $!" );
|
|
|
|
}; # sub move_file
|
|
|
|
# -------------------------------------------------------------------------------------------------
|
|
|
|
sub del_file($) {
|
|
my $files = shift( @_ );
|
|
if ( ref( $files ) eq "" ) {
|
|
$files = [ $files ];
|
|
}; # if
|
|
foreach my $file ( @$files ) {
|
|
debug( "Deleting file `$file'..." );
|
|
my $rc = unlink( $file );
|
|
if ( $rc == 0 && $! != ENOENT ) {
|
|
# Reporn an error, but ignore ENOENT, because the goal is achieved.
|
|
runtime_error( "Deleting file `$file' failed: $!" );
|
|
}; # if
|
|
}; # foreach $file
|
|
}; # sub del_file
|
|
|
|
# -------------------------------------------------------------------------------------------------
|
|
|
|
=back
|
|
|
|
=cut
|
|
|
|
# =================================================================================================
|
|
# File I/O subroutines.
|
|
# =================================================================================================
|
|
|
|
=head2 File I/O subroutines.
|
|
|
|
=cut
|
|
|
|
#--------------------------------------------------------------------------------------------------
|
|
|
|
=head3 read_file
|
|
|
|
B<Synopsis:>
|
|
|
|
read_file( $file, @options )
|
|
|
|
B<Description:>
|
|
|
|
Read file and return its content. In scalar context function returns a scalar, in list context
|
|
function returns list of lines.
|
|
|
|
Note: If the last of file does not terminate with newline, function will append it.
|
|
|
|
B<Arguments:>
|
|
|
|
=over
|
|
|
|
=item B<$file>
|
|
|
|
A name or handle of file to read from.
|
|
|
|
=back
|
|
|
|
B<Options:>
|
|
|
|
=over
|
|
|
|
=item B<-binary>
|
|
|
|
If true, file treats as a binary file: no newline conversion, no truncating trailing space, no
|
|
newline removing performed. Entire file returned as a scalar.
|
|
|
|
=item B<-bulk>
|
|
|
|
This option is allowed only in binary mode. Option's value should be a reference to a scalar.
|
|
If option present, file content placed to pointee scalar and function returns true (1).
|
|
|
|
=item B<-chomp>
|
|
|
|
If true, newline characters are removed from file content. By default newline characters remain.
|
|
This option is not applicable in binary mode.
|
|
|
|
=item B<-keep_trailing_space>
|
|
|
|
If true, trainling space remain at the ends of lines. By default all trailing spaces are removed.
|
|
This option is not applicable in binary mode.
|
|
|
|
=back
|
|
|
|
B<Examples:>
|
|
|
|
Return file as single line, remove trailing spaces.
|
|
|
|
my $bulk = read_file( "message.txt" );
|
|
|
|
Return file as list of lines with removed trailing space and
|
|
newline characters.
|
|
|
|
my @bulk = read_file( "message.txt", -chomp => 1 );
|
|
|
|
Read a binary file:
|
|
|
|
my $bulk = read_file( "message.txt", -binary => 1 );
|
|
|
|
Read a big binary file:
|
|
|
|
my $bulk;
|
|
read_file( "big_binary_file", -binary => 1, -bulk => \$bulk );
|
|
|
|
Read from standard input:
|
|
|
|
my @bulk = read_file( \*STDIN );
|
|
|
|
=cut
|
|
|
|
sub read_file($@) {
|
|
|
|
my $file = shift( @_ ); # The name or handle of file to read from.
|
|
my %opts = @_; # Options.
|
|
|
|
my $name;
|
|
my $handle;
|
|
my @bulk;
|
|
my $error = \&runtime_error;
|
|
|
|
my @binopts = qw( -binary -error -bulk ); # Options available in binary mode.
|
|
my @txtopts = qw( -binary -error -keep_trailing_space -chomp -layer ); # Options available in text (non-binary) mode.
|
|
check_opts( %opts, [ @binopts, @txtopts ] );
|
|
if ( $opts{ -binary } ) {
|
|
check_opts( %opts, [ @binopts ], "these options cannot be used with -binary" );
|
|
} else {
|
|
check_opts( %opts, [ @txtopts ], "these options cannot be used without -binary" );
|
|
}; # if
|
|
if ( not exists( $opts{ -error } ) ) {
|
|
$opts{ -error } = "error";
|
|
}; # if
|
|
if ( $opts{ -error } eq "warning" ) {
|
|
$error = \&warning;
|
|
} elsif( $opts{ -error } eq "ignore" ) {
|
|
$error = sub {};
|
|
} elsif ( ref( $opts{ -error } ) eq "ARRAY" ) {
|
|
$error = sub { push( @{ $opts{ -error } }, $_[ 0 ] ); };
|
|
}; # if
|
|
|
|
if ( ( ref( $file ) eq "GLOB" ) or UNIVERSAL::isa( $file, "IO::Handle" ) ) {
|
|
$name = "unknown";
|
|
$handle = $file;
|
|
} else {
|
|
$name = $file;
|
|
if ( get_ext( $file ) eq ".gz" and not $opts{ -binary } ) {
|
|
$handle = IO::Zlib->new( $name, "rb" );
|
|
} else {
|
|
$handle = IO::File->new( $name, "r" );
|
|
}; # if
|
|
if ( not defined( $handle ) ) {
|
|
$error->( "File \"$name\" could not be opened for input: $!" );
|
|
}; # if
|
|
}; # if
|
|
if ( defined( $handle ) ) {
|
|
if ( $opts{ -binary } ) {
|
|
binmode( $handle );
|
|
local $/ = undef; # Set input record separator to undef to read entire file as one line.
|
|
if ( exists( $opts{ -bulk } ) ) {
|
|
${ $opts{ -bulk } } = $handle->getline();
|
|
} else {
|
|
$bulk[ 0 ] = $handle->getline();
|
|
}; # if
|
|
} else {
|
|
if ( defined( $opts{ -layer } ) ) {
|
|
binmode( $handle, $opts{ -layer } );
|
|
}; # if
|
|
@bulk = $handle->getlines();
|
|
# Special trick for UTF-8 files: Delete BOM, if any.
|
|
if ( defined( $opts{ -layer } ) and $opts{ -layer } eq ":utf8" ) {
|
|
if ( substr( $bulk[ 0 ], 0, 1 ) eq "\x{FEFF}" ) {
|
|
substr( $bulk[ 0 ], 0, 1 ) = "";
|
|
}; # if
|
|
}; # if
|
|
}; # if
|
|
$handle->close()
|
|
or $error->( "File \"$name\" could not be closed after input: $!" );
|
|
} else {
|
|
if ( $opts{ -binary } and exists( $opts{ -bulk } ) ) {
|
|
${ $opts{ -bulk } } = "";
|
|
}; # if
|
|
}; # if
|
|
if ( $opts{ -binary } ) {
|
|
if ( exists( $opts{ -bulk } ) ) {
|
|
return 1;
|
|
} else {
|
|
return $bulk[ 0 ];
|
|
}; # if
|
|
} else {
|
|
if ( ( @bulk > 0 ) and ( substr( $bulk[ -1 ], -1, 1 ) ne "\n" ) ) {
|
|
$bulk[ -1 ] .= "\n";
|
|
}; # if
|
|
if ( not $opts{ -keep_trailing_space } ) {
|
|
map( $_ =~ s/\s+\n\z/\n/, @bulk );
|
|
}; # if
|
|
if ( $opts{ -chomp } ) {
|
|
chomp( @bulk );
|
|
}; # if
|
|
if ( wantarray() ) {
|
|
return @bulk;
|
|
} else {
|
|
return join( "", @bulk );
|
|
}; # if
|
|
}; # if
|
|
|
|
}; # sub read_file
|
|
|
|
#--------------------------------------------------------------------------------------------------
|
|
|
|
=head3 write_file
|
|
|
|
B<Synopsis:>
|
|
|
|
write_file( $file, $bulk, @options )
|
|
|
|
B<Description:>
|
|
|
|
Write file.
|
|
|
|
B<Arguments:>
|
|
|
|
=over
|
|
|
|
=item B<$file>
|
|
|
|
The name or handle of file to write to.
|
|
|
|
=item B<$bulk>
|
|
|
|
Bulk to write to a file. Can be a scalar, or a reference to scalar or an array.
|
|
|
|
=back
|
|
|
|
B<Options:>
|
|
|
|
=over
|
|
|
|
=item B<-backup>
|
|
|
|
If true, create a backup copy of file overwritten. Backup copy is placed into the same directory.
|
|
The name of backup copy is the same as the name of file with `~' appended. By default backup copy
|
|
is not created.
|
|
|
|
=item B<-append>
|
|
|
|
If true, the text will be added to existing file.
|
|
|
|
=back
|
|
|
|
B<Examples:>
|
|
|
|
write_file( "message.txt", \$bulk );
|
|
# Write file, take content from a scalar.
|
|
|
|
write_file( "message.txt", \@bulk, -backup => 1 );
|
|
# Write file, take content from an array, create a backup copy.
|
|
|
|
=cut
|
|
|
|
sub write_file($$@) {
|
|
|
|
my $file = shift( @_ ); # The name or handle of file to write to.
|
|
my $bulk = shift( @_ ); # The text to write. Can be reference to array or scalar.
|
|
my %opts = @_; # Options.
|
|
|
|
my $name;
|
|
my $handle;
|
|
|
|
check_opts( %opts, [ qw( -append -backup -binary -layer ) ] );
|
|
|
|
my $mode = $opts{ -append } ? "a": "w";
|
|
if ( ( ref( $file ) eq "GLOB" ) or UNIVERSAL::isa( $file, "IO::Handle" ) ) {
|
|
$name = "unknown";
|
|
$handle = $file;
|
|
} else {
|
|
$name = $file;
|
|
if ( $opts{ -backup } and ( -f $name ) ) {
|
|
copy_file( $name, $name . "~", -overwrite => 1 );
|
|
}; # if
|
|
$handle = IO::File->new( $name, $mode )
|
|
or runtime_error( "File \"$name\" could not be opened for output: $!" );
|
|
}; # if
|
|
if ( $opts{ -binary } ) {
|
|
binmode( $handle );
|
|
} elsif ( $opts{ -layer } ) {
|
|
binmode( $handle, $opts{ -layer } );
|
|
}; # if
|
|
if ( ref( $bulk ) eq "" ) {
|
|
if ( defined( $bulk ) ) {
|
|
$handle->print( $bulk );
|
|
if ( not $opts{ -binary } and ( substr( $bulk, -1 ) ne "\n" ) ) {
|
|
$handle->print( "\n" );
|
|
}; # if
|
|
}; # if
|
|
} elsif ( ref( $bulk ) eq "SCALAR" ) {
|
|
if ( defined( $$bulk ) ) {
|
|
$handle->print( $$bulk );
|
|
if ( not $opts{ -binary } and ( substr( $$bulk, -1 ) ne "\n" ) ) {
|
|
$handle->print( "\n" );
|
|
}; # if
|
|
}; # if
|
|
} elsif ( ref( $bulk ) eq "ARRAY" ) {
|
|
foreach my $line ( @$bulk ) {
|
|
if ( defined( $line ) ) {
|
|
$handle->print( $line );
|
|
if ( not $opts{ -binary } and ( substr( $line, -1 ) ne "\n" ) ) {
|
|
$handle->print( "\n" );
|
|
}; # if
|
|
}; # if
|
|
}; # foreach
|
|
} else {
|
|
Carp::croak( "write_file: \$bulk must be a scalar or reference to (scalar or array)" );
|
|
}; # if
|
|
$handle->close()
|
|
or runtime_error( "File \"$name\" could not be closed after output: $!" );
|
|
|
|
}; # sub write_file
|
|
|
|
#--------------------------------------------------------------------------------------------------
|
|
|
|
=cut
|
|
|
|
# =================================================================================================
|
|
# Execution subroutines.
|
|
# =================================================================================================
|
|
|
|
=head2 Execution subroutines.
|
|
|
|
=over
|
|
|
|
=cut
|
|
|
|
#--------------------------------------------------------------------------------------------------
|
|
|
|
sub _pre {
|
|
|
|
my $arg = shift( @_ );
|
|
|
|
# If redirection is not required, exit.
|
|
if ( not exists( $arg->{ redir } ) ) {
|
|
return 0;
|
|
}; # if
|
|
|
|
# Input parameters.
|
|
my $mode = $arg->{ mode }; # Mode, "<" (input ) or ">" (output).
|
|
my $handle = $arg->{ handle }; # Handle to manipulate.
|
|
my $redir = $arg->{ redir }; # Data, a file name if a scalar, or file contents, if a reference.
|
|
|
|
# Output parameters.
|
|
my $save_handle;
|
|
my $temp_handle;
|
|
my $temp_name;
|
|
|
|
# Save original handle (by duping it).
|
|
$save_handle = Symbol::gensym();
|
|
$handle->flush();
|
|
open( $save_handle, $mode . "&" . $handle->fileno() )
|
|
or die( "Cannot dup filehandle: $!" );
|
|
|
|
# Prepare a file to IO.
|
|
if ( UNIVERSAL::isa( $redir, "IO::Handle" ) or ( ref( $redir ) eq "GLOB" ) ) {
|
|
# $redir is reference to an object of IO::Handle class (or its decedant).
|
|
$temp_handle = $redir;
|
|
} elsif ( ref( $redir ) ) {
|
|
# $redir is a reference to content to be read/written.
|
|
# Prepare temp file.
|
|
( $temp_handle, $temp_name ) =
|
|
File::Temp::tempfile(
|
|
"$tool.XXXXXXXX",
|
|
DIR => File::Spec->tmpdir(),
|
|
SUFFIX => ".tmp",
|
|
UNLINK => 1
|
|
);
|
|
if ( not defined( $temp_handle ) ) {
|
|
runtime_error( "Could not create temp file." );
|
|
}; # if
|
|
if ( $mode eq "<" ) {
|
|
# It is a file to be read by child, prepare file content to be read.
|
|
$temp_handle->print( ref( $redir ) eq "SCALAR" ? ${ $redir } : @{ $redir } );
|
|
$temp_handle->flush();
|
|
seek( $temp_handle, 0, 0 );
|
|
# Unfortunatelly, I could not use OO interface to seek.
|
|
# ActivePerl 5.6.1 complains on both forms:
|
|
# $temp_handle->seek( 0 ); # As declared in IO::Seekable.
|
|
# $temp_handle->setpos( 0 ); # As described in documentation.
|
|
} elsif ( $mode eq ">" ) {
|
|
# It is a file for output. Clear output variable.
|
|
if ( ref( $redir ) eq "SCALAR" ) {
|
|
${ $redir } = "";
|
|
} else {
|
|
@{ $redir } = ();
|
|
}; # if
|
|
}; # if
|
|
} else {
|
|
# $redir is a name of file to be read/written.
|
|
# Just open file.
|
|
if ( defined( $redir ) ) {
|
|
$temp_name = $redir;
|
|
} else {
|
|
$temp_name = File::Spec->devnull();
|
|
}; # if
|
|
$temp_handle = IO::File->new( $temp_name, $mode )
|
|
or runtime_error( "file \"$temp_name\" could not be opened for " . ( $mode eq "<" ? "input" : "output" ) . ": $!" );
|
|
}; # if
|
|
|
|
# Redirect handle to temp file.
|
|
open( $handle, $mode . "&" . $temp_handle->fileno() )
|
|
or die( "Cannot dup filehandle: $!" );
|
|
|
|
# Save output parameters.
|
|
$arg->{ save_handle } = $save_handle;
|
|
$arg->{ temp_handle } = $temp_handle;
|
|
$arg->{ temp_name } = $temp_name;
|
|
|
|
}; # sub _pre
|
|
|
|
|
|
sub _post {
|
|
|
|
my $arg = shift( @_ );
|
|
|
|
# Input parameters.
|
|
my $mode = $arg->{ mode }; # Mode, "<" or ">".
|
|
my $handle = $arg->{ handle }; # Handle to save and set.
|
|
my $redir = $arg->{ redir }; # Data, a file name if a scalar, or file contents, if a reference.
|
|
|
|
# Parameters saved during preprocessing.
|
|
my $save_handle = $arg->{ save_handle };
|
|
my $temp_handle = $arg->{ temp_handle };
|
|
my $temp_name = $arg->{ temp_name };
|
|
|
|
# If no handle was saved, exit.
|
|
if ( not $save_handle ) {
|
|
return 0;
|
|
}; # if
|
|
|
|
# Close handle.
|
|
$handle->close()
|
|
or die( "$!" );
|
|
|
|
# Read the content of temp file, if necessary, and close temp file.
|
|
if ( ( $mode ne "<" ) and ref( $redir ) ) {
|
|
$temp_handle->flush();
|
|
seek( $temp_handle, 0, 0 );
|
|
if ( $^O =~ m/MSWin/ ) {
|
|
binmode( $temp_handle, ":crlf" );
|
|
}; # if
|
|
if ( ref( $redir ) eq "SCALAR" ) {
|
|
${ $redir } .= join( "", $temp_handle->getlines() );
|
|
} elsif ( ref( $redir ) eq "ARRAY" ) {
|
|
push( @{ $redir }, $temp_handle->getlines() );
|
|
}; # if
|
|
}; # if
|
|
if ( not UNIVERSAL::isa( $redir, "IO::Handle" ) ) {
|
|
$temp_handle->close()
|
|
or die( "$!" );
|
|
}; # if
|
|
|
|
# Restore handle to original value.
|
|
$save_handle->flush();
|
|
open( $handle, $mode . "&" . $save_handle->fileno() )
|
|
or die( "Cannot dup filehandle: $!" );
|
|
|
|
# Close save handle.
|
|
$save_handle->close()
|
|
or die( "$!" );
|
|
|
|
# Delete parameters saved during preprocessing.
|
|
delete( $arg->{ save_handle } );
|
|
delete( $arg->{ temp_handle } );
|
|
delete( $arg->{ temp_name } );
|
|
|
|
}; # sub _post
|
|
|
|
#--------------------------------------------------------------------------------------------------
|
|
|
|
=item C<execute( [ @command ], @options )>
|
|
|
|
Execute specified program or shell command.
|
|
|
|
Program is specified by reference to an array, that array is passed to C<system()> function which
|
|
executes the command. See L<perlfunc> for details how C<system()> interprets various forms of
|
|
C<@command>.
|
|
|
|
By default, in case of any error error message is issued and script terminated (by runtime_error()).
|
|
Function returns an exit code of program.
|
|
|
|
Alternatively, he function may return exit status of the program (see C<-ignore_status>) or signal
|
|
(see C<-ignore_signal>) so caller may analyze it and continue execution.
|
|
|
|
Options:
|
|
|
|
=over
|
|
|
|
=item C<-stdin>
|
|
|
|
Redirect stdin of program. The value of option can be:
|
|
|
|
=over
|
|
|
|
=item C<undef>
|
|
|
|
Stdin of child is attached to null device.
|
|
|
|
=item a string
|
|
|
|
Stdin of child is attached to a file with name specified by option.
|
|
|
|
=item a reference to a scalar
|
|
|
|
A dereferenced scalar is written to a temp file, and child's stdin is attached to that file.
|
|
|
|
=item a reference to an array
|
|
|
|
A dereferenced array is written to a temp file, and child's stdin is attached to that file.
|
|
|
|
=back
|
|
|
|
=item C<-stdout>
|
|
|
|
Redirect stdout. Possible values are the same as for C<-stdin> option. The only difference is
|
|
reference specifies a variable receiving program's output.
|
|
|
|
=item C<-stderr>
|
|
|
|
It similar to C<-stdout>, but redirects stderr. There is only one additional value:
|
|
|
|
=over
|
|
|
|
=item an empty string
|
|
|
|
means that stderr should be redirected to the same place where stdout is redirected to.
|
|
|
|
=back
|
|
|
|
=item C<-append>
|
|
|
|
Redirected stream will not overwrite previous content of file (or variable).
|
|
Note, that option affects both stdout and stderr.
|
|
|
|
=item C<-ignore_status>
|
|
|
|
By default, subroutine raises an error and exits the script if program returns non-exit status. If
|
|
this options is true, no error is raised. Instead, status is returned as function result (and $@ is
|
|
set to error message).
|
|
|
|
=item C<-ignore_signal>
|
|
|
|
By default, subroutine raises an error and exits the script if program die with signal. If
|
|
this options is true, no error is raised in such a case. Instead, signal number is returned (as
|
|
negative value), error message is placed to C<$@> variable.
|
|
|
|
If command is not even started, -256 is returned.
|
|
|
|
=back
|
|
|
|
Examples:
|
|
|
|
execute( [ "cmd.exe", "/c", "dir" ] );
|
|
# Execute NT shell with specified options, no redirections are
|
|
# made.
|
|
|
|
my $output;
|
|
execute( [ "cvs", "-n", "-q", "update", "." ], -stdout => \$output );
|
|
# Execute "cvs -n -q update ." command, output is saved
|
|
# in $output variable.
|
|
|
|
my @output;
|
|
execute( [ qw( cvs -n -q update . ) ], -stdout => \@output, -stderr => undef );
|
|
# Execute specified command, output is saved in @output
|
|
# variable, stderr stream is redirected to null device
|
|
# (/dev/null in Linux* OS and nul in Windows* OS).
|
|
|
|
=cut
|
|
|
|
sub execute($@) {
|
|
|
|
# !!! Add something to complain on unknown options...
|
|
|
|
my $command = shift( @_ );
|
|
my %opts = @_;
|
|
my $prefix = "Could not execute $command->[ 0 ]";
|
|
|
|
check_opts( %opts, [ qw( -stdin -stdout -stderr -append -ignore_status -ignore_signal ) ] );
|
|
|
|
if ( ref( $command ) ne "ARRAY" ) {
|
|
Carp::croak( "execute: $command must be a reference to array" );
|
|
}; # if
|
|
|
|
my $stdin = { handle => \*STDIN, mode => "<" };
|
|
my $stdout = { handle => \*STDOUT, mode => ">" };
|
|
my $stderr = { handle => \*STDERR, mode => ">" };
|
|
my $streams = {
|
|
stdin => $stdin,
|
|
stdout => $stdout,
|
|
stderr => $stderr
|
|
}; # $streams
|
|
|
|
for my $stream ( qw( stdin stdout stderr ) ) {
|
|
if ( exists( $opts{ "-$stream" } ) ) {
|
|
if ( ref( $opts{ "-$stream" } ) !~ m/\A(|SCALAR|ARRAY)\z/ ) {
|
|
Carp::croak( "execute: -$stream option: must have value of scalar, or reference to (scalar or array)." );
|
|
}; # if
|
|
$streams->{ $stream }->{ redir } = $opts{ "-$stream" };
|
|
}; # if
|
|
if ( $opts{ -append } and ( $streams->{ $stream }->{ mode } ) eq ">" ) {
|
|
$streams->{ $stream }->{ mode } = ">>";
|
|
}; # if
|
|
}; # foreach $stream
|
|
|
|
_pre( $stdin );
|
|
_pre( $stdout );
|
|
if ( defined( $stderr->{ redir } ) and not ref( $stderr->{ redir } ) and ( $stderr->{ redir } eq "" ) ) {
|
|
if ( exists( $stdout->{ redir } ) ) {
|
|
$stderr->{ redir } = $stdout->{ temp_handle };
|
|
} else {
|
|
$stderr->{ redir } = ${ $stdout->{ handle } };
|
|
}; # if
|
|
}; # if
|
|
_pre( $stderr );
|
|
my $rc = system( @$command );
|
|
my $errno = $!;
|
|
my $child = $?;
|
|
_post( $stderr );
|
|
_post( $stdout );
|
|
_post( $stdin );
|
|
|
|
my $exit = 0;
|
|
my $signal_num = $child & 127;
|
|
my $exit_status = $child >> 8;
|
|
$@ = "";
|
|
|
|
if ( $rc == -1 ) {
|
|
$@ = "\"$command->[ 0 ]\" failed: $errno";
|
|
$exit = -256;
|
|
if ( not $opts{ -ignore_signal } ) {
|
|
runtime_error( $@ );
|
|
}; # if
|
|
} elsif ( $signal_num != 0 ) {
|
|
$@ = "\"$command->[ 0 ]\" failed due to signal $signal_num.";
|
|
$exit = - $signal_num;
|
|
if ( not $opts{ -ignore_signal } ) {
|
|
runtime_error( $@ );
|
|
}; # if
|
|
} elsif ( $exit_status != 0 ) {
|
|
$@ = "\"$command->[ 0 ]\" returned non-zero status $exit_status.";
|
|
$exit = $exit_status;
|
|
if ( not $opts{ -ignore_status } ) {
|
|
runtime_error( $@ );
|
|
}; # if
|
|
}; # if
|
|
|
|
return $exit;
|
|
|
|
}; # sub execute
|
|
|
|
#--------------------------------------------------------------------------------------------------
|
|
|
|
=item C<backticks( [ @command ], @options )>
|
|
|
|
Run specified program or shell command and return output.
|
|
|
|
In scalar context entire output is returned in a single string. In list context list of strings
|
|
is returned. Function issues an error and exits script if any error occurs.
|
|
|
|
=cut
|
|
|
|
|
|
sub backticks($@) {
|
|
|
|
my $command = shift( @_ );
|
|
my %opts = @_;
|
|
my @output;
|
|
|
|
check_opts( %opts, [ qw( -chomp ) ] );
|
|
|
|
execute( $command, -stdout => \@output );
|
|
|
|
if ( $opts{ -chomp } ) {
|
|
chomp( @output );
|
|
}; # if
|
|
|
|
return ( wantarray() ? @output : join( "", @output ) );
|
|
|
|
}; # sub backticks
|
|
|
|
#--------------------------------------------------------------------------------------------------
|
|
|
|
sub pad($$$) {
|
|
my ( $str, $length, $pad ) = @_;
|
|
my $lstr = length( $str ); # Length of source string.
|
|
if ( $lstr < $length ) {
|
|
my $lpad = length( $pad ); # Length of pad.
|
|
my $count = int( ( $length - $lstr ) / $lpad ); # Number of pad repetitions.
|
|
my $tail = $length - ( $lstr + $lpad * $count );
|
|
$str = $str . ( $pad x $count ) . substr( $pad, 0, $tail );
|
|
}; # if
|
|
return $str;
|
|
}; # sub pad
|
|
|
|
# --------------------------------------------------------------------------------------------------
|
|
|
|
=back
|
|
|
|
=cut
|
|
|
|
#--------------------------------------------------------------------------------------------------
|
|
|
|
return 1;
|
|
|
|
#--------------------------------------------------------------------------------------------------
|
|
|
|
=cut
|
|
|
|
# End of file.
|