perllib/General/FileSystem.pm

   1 # Copyright (C) 1998-2009, Mikhael Goikhman
   2 #
   3 # This program is free software; you can redistribute it and/or modify
   4 # it under the terms of the GNU General Public License as published by
   5 # the Free Software Foundation; either version 2 of the License, or
   6 # (at your option) any later version.
   7 #
   8 # This program is distributed in the hope that it will be useful,
   9 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 # GNU General Public License for more details.
  12 #
  13 # You should have received a copy of the GNU General Public License
  14 # along with this program; if not, write to the Free Software
  15 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  16
  17 package General::FileSystem;
  18 require 5.004;
  19 use strict;
  20
  21 use vars qw(@ISA @EXPORT);
  22 require Exporter;
  23 @ISA = qw(Exporter);
  24 @EXPORT = qw(
  25         load_file save_file append_file remove_file copy_file move_file
  26         make_dir make_path clean_dir remove_dir copy_dir move_dir
  27         list_filenames find_file find_executable
  28         default_dir_perm preserve_stat parse_path get_cwd
  29 );
  30
  31 use vars qw($CACHE_FILE_NUM $cache_counter @prev_filenames @prev_file_content_refs);
  32 use vars qw($ENABLE_CACHE %NEVER_COPY_FILES %NEVER_REMOVE_FILES);
  33 use vars qw($DEFAULT_DIR_PERM $PRESERVED_STAT);
  34 use vars qw($DEBUG_ENABLED $ERROR_HANDLER $LOAD_FILE_DIRS $SAVE_FILE_DIR);
  35
  36 BEGIN {
  37         $ENABLE_CACHE       = 0;  # this is risky for dynamical files
  38         %NEVER_COPY_FILES   = ( 'CVS' => 1, 'core' => 1 );
  39         %NEVER_REMOVE_FILES = ( 'CVS' => 1 );
  40         $DEFAULT_DIR_PERM   = 0775;
  41         $PRESERVED_STAT     = 0;
  42
  43         # allow these constants to be set directly from outside
  44         $ERROR_HANDLER      ||= "warn";   # may be "die", "warn", "quiet" or CODE
  45         $DEBUG_ENABLED      ||= 0;
  46         $LOAD_FILE_DIRS     ||= [ "." ];  # for non fully qualified files only
  47         $SAVE_FILE_DIR      ||= ".";      # for non fully qualified files only
  48 }
  49
  50
  51 # ----------------------------------------------------------------------------
  52
  53 =head1 NAME
  54
  55 General::FileSystem - file system specific functions
  56
  57 =head1 SYNOPSIS
  58
  59   use General::FileSystem "-die", "-debug";  # die on errors
  60
  61   eval {
  62     make_path("/tmp/my-own/dir");
  63
  64     my $file_content_ref = load_file("/etc/issue");
  65     save_file("/tmp/my-own/dir/issue", $file_content_ref);
  66
  67     # This is equivalent to the previous two lines, but optimized
  68     copy_file("/etc/issue", "/tmp/my-own/dir/issue");
  69
  70     make_dir("/tmp/my-own/dir2", 0711);
  71     copy_file("/etc/issue", "/tmp/my-own/dir2/issue");
  72     move_file("/tmp/my-own/dir2/issue", "/tmp/my-own/dir2/issue2");
  73     remove_file("/tmp/my-own/dir2/issue2");
  74     clean_dir("/tmp/my-own/dir2"); # no effect, it's empty already
  75
  76     remove_dir("/tmp/my-own");
  77   };
  78   if ($@) {
  79     print "File System Error: $@";
  80   };
  81
  82 or just:
  83
  84   use General::FileSystem;
  85   copy_file("origin.txt", "backup.txt");
  86
  87 =head1 DESCRIPTION
  88
  89 This package contains common file operation functions:
  90
  91 B<load_file>, B<save_file>, B<append_file>, B<remove_file>, B<copy_file>, B<move_file>,
  92 B<make_dir>, B<make_path>, B<clean_dir>, B<remove_dir>, B<copy_dir>, B<move_dir>,
  93 B<list_filenames>, B<find_file>, B<find_executable>,
  94 B<default_dir_perm>, B<preserve_stat>, B<parse_path>, B<get_cwd>.
  95
  96 On fatal file system errors all functions call the error handler, that may
  97 throw exception (die), issue a warning or quietly return undef.
  98 You may control this by passing one of the arguments I<-die>, I<-warn>
  99 or I<-quiet> in B<use> or by setting C<$ERROR_HANDLER> to one of these
 100 values (don't specify a dash in this case).
 101
 102 =head1 REQUIREMENTS
 103
 104 L<Cwd>, L<File::Basename>, L<File::Copy>.
 105
 106 =head1 FUNCTIONS
 107
 108 =cut
 109 # ============================================================================
 110
 111
 112 use Cwd;
 113 use File::Basename;
 114 use File::Copy;
 115
 116
 117 sub import ($;$) {
 118         my $package = shift;
 119         while (@_ && $_[0] =~ /^-/) {
 120                 local $_ = shift;
 121                 $ERROR_HANDLER = $1 if /^-(die|warn|quiet)$/i;
 122                 $DEBUG_ENABLED = $1 if /^-(debug)$/i;
 123         }
 124         $package->export_to_level(1, @_);
 125 }
 126
 127
 128 # private function
 129 sub call_error_handler ($) {
 130         my $msg = shift;
 131         die  "$msg: [$!]\n" if $ERROR_HANDLER eq "die";
 132         warn "$msg: [$!]\n" if $ERROR_HANDLER eq "warn";
 133         return undef if $ERROR_HANDLER eq "quiet";
 134         &$ERROR_HANDLER($msg) if ref($ERROR_HANDLER) eq "CODE";
 135         return undef;
 136 }
 137
 138
 139 # private function
 140 sub print_log ($) {
 141         my $msg = shift;
 142         return unless $DEBUG_ENABLED;
 143         print STDERR "FileSystem: $msg\n";
 144 }
 145
 146
 147 # ----------------------------------------------------------------------------
 148
 149 =head2 load_file
 150
 151 =over 4
 152
 153 =item usage
 154
 155   $content_ref = load_file($filename)
 156
 157 =item description
 158
 159 Loads file with given file-name from local filesystem.
 160
 161 =item parameters
 162
 163   * filename - name of the file to be loaded.
 164
 165 =item returns
 166
 167 Reference to file content string on success, otherwise either dies or warns
 168 and returns undef as configured.
 169
 170 =back
 171
 172 =cut
 173 # ============================================================================
 174
 175
 176 BEGIN {
 177         $CACHE_FILE_NUM = 6;
 178         $cache_counter = -1;
 179         @prev_filenames = ("", "", "", "", "", "");
 180         @prev_file_content_refs = \("", "", "", "", "", "");
 181 }
 182
 183
 184 sub load_file ($) {
 185         my $filename = shift;
 186
 187         foreach (@$LOAD_FILE_DIRS) {
 188                 if (-f "$_/$filename") { $filename = "$_/$filename"; last; }
 189         }
 190         print_log("Loading file $filename") if $DEBUG_ENABLED;
 191
 192         if ($ENABLE_CACHE) {
 193                 for (0 .. $CACHE_FILE_NUM-1) {
 194                         if ($filename eq $prev_filenames[$_] && -r $filename) {
 195                                 print_log("getting from file cache") if $DEBUG_ENABLED;
 196                                 return $prev_file_content_refs[$_];
 197                         }
 198                 }
 199         }
 200
 201         open(FILE, "<$filename") || return call_error_handler("Can't open $filename");
 202         my $content = join("", <FILE>);
 203         close(FILE) || return call_error_handler("Can't close $filename");
 204
 205         if ($ENABLE_CACHE) {
 206                 $cache_counter = ($cache_counter+1) % $CACHE_FILE_NUM;
 207                 $prev_filenames[$cache_counter] = $filename;
 208                 $prev_file_content_refs[$cache_counter] = \$content;
 209         }
 210         return \$content;
 211 }
 212
 213
 214 # ----------------------------------------------------------------------------
 215
 216 =head2 save_file
 217
 218 =over 4
 219
 220 =item description
 221
 222 Saves file-content to local filesystem with given file-name.
 223
 224 =item usage
 225
 226   save_file($filename, \$content);
 227
 228 =item parameters
 229
 230   * filename - name of the file to be saved into
 231   * content_ref - reference to file content string
 232   * create_subdirs - optional flag (default is 0 - don't create subdirs)
 233
 234 =item returns
 235
 236 C<1> on success, otherwise either dies or warns and returns undef as configured.
 237
 238 =back
 239
 240 =cut
 241 # ============================================================================
 242
 243
 244 sub save_file ($$;$) {
 245         my ($filename, $content_ref, $create_dirs) = @_;
 246
 247         if ($filename !~ m=^[/\\]|\w:\\=) {
 248                 $filename = "$SAVE_FILE_DIR/$filename";
 249         }
 250         print_log("Saving  file $filename") if $DEBUG_ENABLED;
 251         die("save_file: No SCALAR ref parameter\n")
 252                 unless ref($content_ref) eq 'SCALAR';
 253
 254         if ($ENABLE_CACHE) {
 255                 for (0 .. $CACHE_FILE_NUM-1) {
 256                         $prev_file_content_refs[$_] = $content_ref
 257                                 if $filename eq $prev_filenames[$_];
 258                 }
 259         }
 260         if ($create_dirs) {
 261                 my $dirname = dirname($filename);
 262                 make_path($dirname) unless -d $dirname;
 263         }
 264
 265         open(FILE, ">$filename") || return call_error_handler("Can't open $filename");
 266         print FILE $$content_ref;
 267         close(FILE) || return call_error_handler("Can't close $filename");
 268         return 1;
 269 }
 270
 271
 272 # ----------------------------------------------------------------------------
 273
 274 =head2 append_file
 275
 276 =over 4
 277
 278 =item description
 279
 280 Appends file-content to local filesystem with given file-name.
 281
 282 =item usage
 283
 284   append_file($filename, \$appended_content);
 285
 286 =item parameters
 287
 288   * filename - name of the file to be saved into
 289   * appended_content_ref - reference to appended-content string
 290
 291 =item returns
 292
 293 C<1> on success, otherwise either dies or warns and returns undef as configured.
 294
 295 =back
 296
 297 =cut
 298 # ============================================================================
 299
 300
 301 sub append_file ($$) {
 302         my ($filename, $appended_content_ref) = @_;
 303         print_log("Append>>file $filename") if $DEBUG_ENABLED;
 304
 305         if ($ENABLE_CACHE) {
 306                 for (0 .. $CACHE_FILE_NUM-1 && -r $filename) {
 307                         ${$prev_file_content_refs[$_]} .= $$appended_content_ref
 308                                 if $filename eq $prev_filenames[$_];
 309                 }
 310         }
 311
 312         open(FILE, ">>$filename") || return call_error_handler("Can't append to $filename");
 313         print FILE $$appended_content_ref;
 314         close(FILE) || return call_error_handler("Can't close $filename");
 315         return 1;
 316 }
 317
 318
 319 # ----------------------------------------------------------------------------
 320
 321 =head2 remove_file
 322
 323 =over 4
 324
 325 =item description
 326
 327 Removes all files from given directory.
 328
 329 =item usage
 330
 331   remove_file($filename);
 332
 333 =item parameters
 334
 335   * filename - name of the file to be deleted
 336
 337 =item returns
 338
 339 C<1> on success, otherwise either dies or warns and returns undef as configured.
 340
 341 =back
 342
 343 =cut
 344 # ============================================================================
 345
 346
 347 sub remove_file ($;$) {
 348         my $filename = shift;
 349         print_log("Removin file $filename") if $DEBUG_ENABLED;
 350         unlink($filename) || return call_error_handler("Can't unlink $filename");
 351         return 1;
 352 }
 353
 354
 355 # ----------------------------------------------------------------------------
 356
 357 =head2 make_dir
 358
 359 =over 4
 360
 361 =item description
 362
 363 Removes all files from given directory.
 364
 365 =item usage
 366
 367   make_dir($PREVIEW_DIR);
 368
 369 =item parameters
 370
 371   * directory to make
 372   * optional creating dir permissions (default is $DEFAULT_DIR_PERM)
 373
 374 =item returns
 375
 376 C<1> on success, otherwise either dies or warns and returns undef as configured.
 377
 378 =back
 379
 380 =cut
 381 # ============================================================================
 382
 383
 384 sub make_dir ($;$) {
 385         my $dirname = shift;
 386         my $perm = shift || $DEFAULT_DIR_PERM;
 387         print_log("Creating dir $dirname, " . sprintf("%o", $perm))
 388                 if $DEBUG_ENABLED;
 389         mkdir($dirname, $perm) || return call_error_handler("Can't mkdir $dirname");
 390         return 1;
 391 }
 392
 393
 394 # ----------------------------------------------------------------------------
 395
 396 =head2 make_path
 397
 398 =over 4
 399
 400 =item description
 401
 402 Removes all files from given directory.
 403
 404 =item usage
 405
 406   make_path($PUBLISH_DIR);
 407
 408 =item parameters
 409
 410   * path to make
 411   * optional creating dir permissions (default is $DEFAULT_DIR_PERM)
 412
 413 =item returns
 414
 415 C<1> on success, otherwise either dies or warns and returns undef as configured.
 416
 417 =back
 418
 419 =cut
 420 # ============================================================================
 421
 422
 423 sub make_path ($;$) {
 424         my $dirname = shift;
 425         my $perm = shift || $DEFAULT_DIR_PERM;
 426         print_log("Making  path $dirname, " . sprintf("%o", $perm))
 427                 if $DEBUG_ENABLED;
 428
 429         return 1 if -d $dirname;
 430         my $parent_dir = dirname($dirname);
 431
 432         local $DEBUG_ENABLED = 0;
 433         &make_path($parent_dir, $perm) unless -d $parent_dir;
 434         make_dir($dirname, $perm);
 435
 436         return 1;
 437 }
 438
 439
 440 # ----------------------------------------------------------------------------
 441
 442 =head2 copy_file
 443
 444 =over 4
 445
 446 =item description
 447
 448 Copies a file to another location.
 449
 450 =item usage
 451
 452   copy_file($from, $to);
 453
 454 =item parameters
 455
 456   * file name to copy from
 457   * file name to copy to
 458
 459 =item returns
 460
 461 C<1> on success, otherwise either dies or warns and returns undef as configured.
 462
 463 =back
 464
 465 =cut
 466 # ============================================================================
 467
 468
 469 sub copy_file ($$) {
 470         my ($src_filename, $dst_filename) = @_;
 471         print_log("Copying file $src_filename to $dst_filename")
 472                 if $DEBUG_ENABLED;
 473
 474         # Must manage symbolic links somehow
 475         # return if -l $src_filename;
 476
 477         copy($src_filename, $dst_filename)
 478                 or return call_error_handler("Can't copy $src_filename $dst_filename");
 479
 480         if ($PRESERVED_STAT) {
 481                 my ($device, $inode, $mode) = stat($src_filename);
 482                 chmod($mode, $dst_filename);
 483         }
 484         return 1;
 485 }
 486
 487
 488 # ----------------------------------------------------------------------------
 489
 490 =head2 move_file
 491
 492 =over 4
 493
 494 =item description
 495
 496 Moves (or renames) a file to another location.
 497
 498 =item usage
 499
 500   move_file($from, $to);
 501
 502 =item parameters
 503
 504   * file name to move from
 505   * file name to move to
 506
 507 =item returns
 508
 509 C<1> on success, otherwise either dies or warns and returns undef as configured.
 510
 511 =back
 512
 513 =cut
 514 # ============================================================================
 515
 516
 517 sub move_file ($$) {
 518         my ($src_filename, $dst_filename) = @_;
 519         print_log("Moving  file $src_filename to $dst_filename")
 520                 if $DEBUG_ENABLED;
 521
 522         move($src_filename, $dst_filename)
 523                 or return call_error_handler("Can't move $src_filename $dst_filename");
 524         return 1;
 525 }
 526
 527
 528 # ----------------------------------------------------------------------------
 529
 530 =head2 clean_dir
 531
 532 =over 4
 533
 534 =item description
 535
 536 Removes all files from given directory.
 537
 538 =item usage
 539
 540   clean_dir($PREVIEW_DIR);
 541
 542 =item parameters
 543
 544   * directory to clean
 545   * optional flag:
 546     0 - don't go recursively, unlink files in first level only
 547     1 - recursively clean subdirs (default)
 548     2 - unlink subdirs
 549     3 - unlink given directory
 550
 551 =item returns
 552
 553 C<1> on success, otherwise either dies or warns and returns undef as configured.
 554
 555 =back
 556
 557 =cut
 558 # ============================================================================
 559
 560
 561 sub clean_dir ($;$) {
 562         my $dirname = shift;
 563         my $recursive = shift || 1;
 564         die("clean_dir: Unsupported flag $recursive\n")
 565                 if $recursive > 3 || $recursive < 0;
 566         print_log(($recursive != 3 ? "Cleaning" : "Removing") . " dir $dirname "
 567                 . ["files only", "recursively files only", "recursively", "completely"]->[$recursive])
 568                 if $DEBUG_ENABLED;
 569
 570         local $DEBUG_ENABLED = 0;
 571
 572         my @subdirs = ();
 573         my $filenames = list_filenames($dirname);
 574
 575         # process files
 576         foreach (@$filenames) {
 577                 next if $NEVER_REMOVE_FILES{$_};
 578                 my $filename = "$dirname/$_";
 579                 if (-d $filename) { push @subdirs, $filename; }
 580                 else { unlink("$filename") || return call_error_handler("Can't unlink $filename"); }
 581         }
 582
 583         # process subdirs
 584         map {
 585                 clean_dir($_, $recursive);
 586                 rmdir($_) || return call_error_handler("Can't unlink $_") if $recursive == 2;
 587         } @subdirs if $recursive;
 588         rmdir($dirname) || return call_error_handler("Can't unlink $dirname") if $recursive == 3;
 589
 590         return 1;
 591 }
 592
 593
 594 # ----------------------------------------------------------------------------
 595
 596 =head2 remove_dir
 597
 598 =over 4
 599
 600 =item description
 601
 602 Entirely removes given directory and its content (if any).
 603 This is an alias to C<clean_dir(3)>.
 604
 605 =item usage
 606
 607   remove_dir($TMP_DIR);
 608
 609 =item parameters
 610
 611   * directory to clean
 612
 613 =item returns
 614
 615 C<1> on success, otherwise either dies or warns and returns undef as configured.
 616
 617 =back
 618
 619 =cut
 620 # ============================================================================
 621
 622
 623 sub remove_dir ($) {
 624         my $dirname = shift;
 625         return clean_dir($dirname, 3);
 626 }
 627
 628
 629 # ----------------------------------------------------------------------------
 630
 631 =head2 copy_dir
 632
 633 =over 4
 634
 635 =item description
 636
 637 Recursively copies all files and subdirectories inside given directory
 638 to new location.
 639
 640 Destination directory must not exist. Use: C<trap { remove_dir($dest); };>
 641 to remove it before copying.
 642
 643 =item usage
 644
 645   copy_dir($dir_from, $dir_to);
 646
 647 =item parameters
 648
 649   * source directory to copy
 650   * destination directory to copy to (may not exist)
 651   * optional creating dir permissions (default is $DEFAULT_DIR_PERM)
 652
 653 =item returns
 654
 655 C<1> on success, otherwise either dies or warns and returns undef as configured.
 656
 657 =back
 658
 659 =cut
 660 # ============================================================================
 661
 662
 663 sub copy_dir ($$) {
 664         my ($src_dirname, $dst_dirname, $perm) = @_;
 665
 666         return call_error_handler("Directory $src_dirname does not exist")
 667                 unless -d $src_dirname;
 668         make_dir($dst_dirname, $perm) unless -d $dst_dirname;
 669
 670         print_log("Copying  dir $src_dirname to $dst_dirname recursively")
 671                 if $DEBUG_ENABLED;;
 672
 673         local $DEBUG_ENABLED = 0;
 674
 675         my $error = 0;
 676         my @subdirs = ();
 677         my $filenames = list_filenames($src_dirname);
 678
 679         # process files
 680         foreach (@$filenames) {
 681                 next if $NEVER_COPY_FILES{$_};
 682                 my $src_filename = "$src_dirname/$_";
 683                 my $dst_filename = "$dst_dirname/$_";
 684                 if (-d $src_filename) { push @subdirs, $_; }
 685                 elsif (-l $src_filename) { next if "# We ignore links for now! TO FIX!" }
 686                 else { copy_file($src_filename, $dst_filename) or $error = 1; }
 687         }
 688
 689         # process subdirs
 690         foreach (@subdirs) {
 691                 my $src_subdirname = "$src_dirname/$_";
 692                 my $dst_subdirname = "$dst_dirname/$_";
 693                 &copy_dir($src_subdirname, $dst_subdirname) or $error = 1;
 694         }
 695
 696         return call_error_handler("Errors while copying some files/subdirs in $src_dirname to $dst_dirname")
 697                 if $error;
 698         return 1;
 699 }
 700
 701
 702 # ----------------------------------------------------------------------------
 703
 704 =head2 move_dir
 705
 706 =over 4
 707
 708 =item description
 709
 710 Moves (or actually renames) a directory to another location.
 711
 712 Destination directory must not exist. Use: C<trap { remove_dir($dest); };>
 713 to remove it before copying.
 714
 715 =item usage
 716
 717   move_dir($dir_from, $dir_to);
 718
 719 =item parameters
 720
 721   * source directory to move from
 722   * destination directory to move to (must not exist)
 723
 724 =item returns
 725
 726 C<1> on success, otherwise either dies or warns and returns undef as configured.
 727
 728 =back
 729
 730 =cut
 731 # ============================================================================
 732
 733
 734 sub move_dir ($$) {
 735         my ($src_dirname, $dst_dirname) = @_;
 736         print_log("Moving   dir $src_dirname to $dst_dirname")
 737                 if $DEBUG_ENABLED;
 738
 739         rename($src_dirname, $dst_dirname)
 740                 or return call_error_handler("Can't rename $src_dirname $dst_dirname");
 741         return 1;
 742 }
 743
 744
 745 # ----------------------------------------------------------------------------
 746
 747 =head2 list_filenames
 748
 749 =over 4
 750
 751 =item description
 752
 753 Returns the file names in the given directory including all types of files
 754 (regular, directory, link, other), not including '.' and '..' entries.
 755
 756 =item usage
 757
 758   # mini file lister
 759   $dir = '/home/ftp';
 760   foreach my $file (@{list_filenames($dir)}) {
 761     print "File $file\n" if -f "$dir/$file";
 762     print "Dir  $file\n" if -d "$dir/$file";
 763   }
 764
 765 =item parameters
 766
 767   * directory to list (or array ref of directories)
 768   * optional flag, 1 means work recursively, the default is 0
 769
 770 =item returns
 771
 772 Array ref of scalars (file names) on success.
 773 Otherwise either dies or warns and returns undef as configured.
 774
 775 =back
 776
 777 =cut
 778 # ============================================================================
 779
 780
 781 sub list_filenames ($;$) {
 782         my $dirname = shift;
 783         my $recursive = shift || 0;
 784         if (ref($dirname) eq "ARRAY") {
 785                 my @files = ();
 786                 foreach (@$dirname) { push @files, &list_filenames($_); }
 787                 return \@files;
 788         }
 789         print_log("Listing  dir $dirname") if $DEBUG_ENABLED;
 790
 791         opendir(DIR, $dirname) || return call_error_handler("Can't opendir $dirname");
 792         my @files = grep { $_ ne '.' && $_ ne '..' } readdir(DIR);
 793         closedir(DIR) || return call_error_handler("Can't closedir $dirname");
 794
 795         if ($recursive) {
 796                 my $i = 0;
 797                 for (; $i < @files; ) {
 798                         my $subdir = $files[$i];
 799                         if (-d "$dirname/$subdir") {
 800                                 splice(@files, $i, 1, map { "$subdir/$_" }
 801                                         @{&list_filenames("$dirname/$subdir")});
 802                         } else {
 803                                 $i++;
 804                         }
 805                 }
 806         }
 807
 808         return \@files;
 809 }
 810
 811
 812 # ----------------------------------------------------------------------------
 813
 814 =head2 find_file
 815
 816 =over 4
 817
 818 =item description
 819
 820 Searches for the given file in the given directories.
 821
 822 Returns the fully qualified file name.
 823
 824 =item usage
 825
 826   my $gtkrc = find_file(".gtkrc", [$home, "$home/.gnome"]);
 827
 828 =item parameters
 829
 830   * file name to search for
 831   * array ref of directories to search in
 832
 833 =item returns
 834
 835 File name with full path if found, or undef if not found.
 836
 837 =back
 838
 839 =cut
 840 # ============================================================================
 841
 842
 843 sub find_file ($$) {
 844         my $filename = shift;
 845         my $dirs = shift();
 846         die "find_file: no dirs given\n" unless ref($dirs) eq "ARRAY";
 847         foreach (@$dirs) {
 848                 my $file_path = "$_/$filename";
 849                 return $file_path if -f $file_path;
 850         }
 851         return undef;
 852 }
 853
 854
 855 # ----------------------------------------------------------------------------
 856
 857 =head2 find_executable
 858
 859 =over 4
 860
 861 =item description
 862
 863 Searches for the given executable file in the directories that are in the
 864 environmebt variable $PATH or in the additional parameter.
 865
 866 Returns the fully qualified file name.
 867
 868 =item usage
 869
 870   my $gzip_exe = find_executable("gzip", ["/usr/gnu/bin", "/gnu/bin"]);
 871
 872 =item parameters
 873
 874   * file name to search for (only executables are tested)
 875   * optional array ref of extra directories to search in
 876
 877 =item returns
 878
 879 File name with full path if found, or undef if not found.
 880
 881 =back
 882
 883 =cut
 884 # ============================================================================
 885
 886
 887 sub find_executable ($;$) {
 888         my $filename = shift;
 889         my $extra_dirs = shift;
 890         my @dirs = split(":", $ENV{"PATH"} || "");
 891         if (ref($extra_dirs) eq "ARRAY") {
 892                 push @dirs, @$extra_dirs;
 893         }
 894         foreach (@dirs) {
 895                 my $file_path = "$_/$filename";
 896                 return $file_path if -x $file_path;
 897         }
 898         return undef;
 899 }
 900
 901
 902 # ----------------------------------------------------------------------------
 903
 904 =head2 default_dir_perm
 905
 906 =over 4
 907
 908 =item description
 909
 910 This functions changes default directory permissions, used in
 911 C<make_dir>, C<make_path>, C<copy_dir> and C<move_dir> functions.
 912
 913 The default of this package is 0775.
 914
 915 If no parameters specified, the current value is returned.
 916
 917 =item usage
 918
 919  default_dir_perm(0700);
 920
 921 =item parameters
 922
 923   * optional default directory permission (integer)
 924
 925 =item returns
 926
 927 Previous value.
 928
 929 =back
 930
 931 =cut
 932 # ============================================================================
 933
 934
 935 sub default_dir_perm (;$) {
 936         return if $^O =~ /Win|DOS/;
 937         my $new_value = shift;
 938         my $old_value = $DEFAULT_DIR_PERM;
 939
 940         if (defined $new_value) {
 941                 print_log("default_dir_perm = $new_value") if $DEBUG_ENABLED;
 942                 $DEFAULT_DIR_PERM = $new_value;
 943         }
 944         return $old_value;
 945 }
 946
 947
 948 # ----------------------------------------------------------------------------
 949
 950 =head2 preserve_stat
 951
 952 =over 4
 953
 954 =item description
 955
 956 This functions changes behavior of C<copy_file> and C<copy_dir> functions.
 957 If 0 is given as a parameter stats will not be preserved.
 958
 959 TODO: specify values for diferent preserves:
 960
 961   0 nothing
 962   1 mode   file mode  (type and permissions)
 963   2 uid    numeric user ID of file's owner
 964   4 gid    numeric group ID of file's owner
 965   8 atime  last access time since the epoch
 966  16 mtime  last modify time since the epoch
 967  32 ctime  inode change time (NOT creation time!) since the epo
 968
 969 The default of this package is 0.
 970
 971 If no parameters specified, nothing is set (only current value is returned).
 972
 973 =item usage
 974
 975   preserve_stat(1);
 976
 977 =item parameters
 978
 979   * optional flag (currently 0 or 1)
 980
 981 =item returns
 982
 983 Previous value.
 984
 985 =back
 986
 987 =cut
 988 # ============================================================================
 989
 990
 991 sub preserve_stat (;$) {
 992         return if $^O =~ /Win|DOS/;
 993         my $new_value = shift;
 994         my $old_value = $PRESERVED_STAT;
 995
 996         if (defined $new_value) {
 997                 print_log("preserve_stat = $new_value") if $DEBUG_ENABLED;
 998                 $PRESERVED_STAT = $new_value;
 999         }
1000         return $old_value;
1001 }
1002
1003
1004 # ----------------------------------------------------------------------------
1005
1006 =head2 parse_path
1007
1008 =over 4
1009
1010 =item usage
1011
1012   my ($dirname, $basename) = parse_path($filename);
1013
1014 =item examples
1015
1016   # in: "/data/projects/magazine"  out: ("/data/projects", "magazine")
1017   # in: "/magazine"                out: ("", "magazine")
1018   # in: "dir/"                     out: (dir", "")
1019   # in: "magazine"                 out: (".", "magazine")
1020
1021   # in: "c:\projects\magazine"     out: ("c:\projects", "magazine")
1022   # in: "c:\magazine"              out: ("c:", "magazine")
1023   # in: "c:magazine"               out: ("c:.", "magazine")
1024
1025 =item description
1026
1027 Returns a list of 2 scalars: directory name and base name. All unix and dos
1028 file names supported.
1029
1030 Note, the rule is this: you can join both scalars using a directory delimiter
1031 (slash or backslash) and you will always get the the original (logical)
1032 file name.
1033
1034 =back
1035
1036 =cut
1037 # ============================================================================
1038
1039
1040 sub parse_path ($) {
1041         my $path = shift;
1042         if ($path =~ m=^(.*)[/\\]+([^/\\]*)$=) {
1043                 return ($1, $2);
1044         } else {
1045                 # support even funny dos form c:file
1046                 return $path =~ m=^(\w:)(.*)$=
1047                         ? ($1 . ".", $2)
1048                         : (".", $path);
1049         }
1050 }
1051
1052
1053 # ----------------------------------------------------------------------------
1054
1055 =head2 get_cwd
1056
1057 =over 4
1058
1059 =item usage
1060
1061   my $cwd = get_cwd();
1062
1063 =item description
1064
1065 Returns the current working directory.
1066
1067 =back
1068
1069 =cut
1070 # ============================================================================
1071
1072
1073 sub get_cwd () {
1074         $^O eq "MSWin32" ? Win32::GetCwd() : require "getcwd.pl" && getcwd();
1075 }
1076
1077
1078 # ----------------------------------------------------------------------------
1079
1080 =head1 BUGS
1081
1082 All global functions and constants in this package should probably be
1083 instantiated into a class object. As usual there are pros and cons.
1084
1085 =head1 AUTHOR
1086
1087 Mikhael Goikhman <migo@homemail.com>
1088
1089 =cut
1090 # ============================================================================
1091
1092
1093 1;