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