FileSystem.pm

# Copyright (c) 1998-2003, Mikhael Goikhman
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

#mod scriptman package General::FileSystem;

require 5.004;
use strict;

use vars qw(@ISA @EXPORT);
require Exporter;
@ISA = qw(Exporter);

=mod scriptman
@EXPORT = qw(
        loadFile saveFile appendFile removeFile copyFile moveFile
        makeDir makePath cleanDir removeDir copyDir moveDir
        listFileNames findFile findExecutable
        defaultDirPerm preserveStat parsePath getCwd
);
=cut

use vars qw($CACHE_FILE_NUM $cacheCounter @prevFileNames @prevFileContentRefs);
use vars qw($ENABLE_CACHE %NEVER_COPY_FILES %NEVER_REMOVE_FILES);
use vars qw($DEFAULT_DIR_PERM $PRESERVED_STAT);
use vars qw($DEBUG_ENABLED $ERROR_HANDLER $LOAD_FILE_DIRS $SAVE_FILE_DIR);

BEGIN {
        $ENABLE_CACHE       = 0;  # this is risky for dynamical files
        %NEVER_COPY_FILES   = ( 'CVS' => 1, 'core' => 1 );
        %NEVER_REMOVE_FILES = ( 'CVS' => 1 );
        $DEFAULT_DIR_PERM   = 0775;
        $PRESERVED_STAT     = 0;

        # allow these constants to be set directly from outside
        $ERROR_HANDLER      ||= "warn";   # may be "die", "warn", "quiet" or CODE
        $DEBUG_ENABLED      ||= 0;
        $LOAD_FILE_DIRS     ||= [ "." ];  # for non fully qualified files only
        $SAVE_FILE_DIR      ||= ".";      # for non fully qualified files only
}


# ----------------------------------------------------------------------------

=head1 NAME

General::FileSystem - file system specific functions

=head1 SYNOPSIS

  use General::FileSystem "-die", "-debug";  # die on errors

  eval {
    makePath("/tmp/my-own/dir");

    my $fileContentRef = loadFile("/etc/issue");
    saveFile("/tmp/my-own/dir/issue", $fileContentRef);

    # This is equivalent to the previous two lines, but optimized
    copyFile("/etc/issue", "/tmp/my-own/dir/issue");

    makeDir("/tmp/my-own/dir2", 0711);
    copyFile("/etc/issue", "/tmp/my-own/dir2/issue");
    moveFile("/tmp/my-own/dir2/issue", "/tmp/my-own/dir2/issue2");
    removeFile("/tmp/my-own/dir2/issue2");
    cleanDir("/tmp/my-own/dir2"); # no effect, it's empty already

    removeDir("/tmp/my-own");
  };
  if ($@) {
    print "File System Error: $@";
  };

or just:

  use General::FileSystem;
  copyFile("origin.txt", "backup.txt");

=head1 DESCRIPTION

This package contains common file operation functions:

B<loadFile>, B<saveFile>, B<appendFile>, B<removeFile>, B<copyFile>, B<moveFile>,
B<makeDir>, B<makePath>, B<cleanDir>, B<removeDir>, B<copyDir>, B<moveDir>,
B<listFileNames>, B<findFile>, B<findExecutable>,
B<defaultDirPerm>, B<preserveStat>, B<parsePath>, B<getCwd>.

On fatal file system errors all functions call the error handler, that may
throw exception (die), issue a warning or quietly return undef.
You may control this by passing one of the arguments I<-die>, I<-warn>
or I<-quiet> in B<use> or by setting C<$ERROR_HANDLER> to one of these
values (don't specify a dash in this case).

=head1 REQUIREMENTS

L<Cwd>, L<File::Basename>, L<File::Copy>.

=head1 FUNCTIONS

=cut
# ============================================================================


use Cwd;
use File::Basename;
use File::Copy;


sub import ($;$) {
        my $package = shift;
        while (@_ && $_[0] =~ /^-/) {
                local $_ = shift;
                $ERROR_HANDLER = $1 if /^-(die|warn|quiet)$/i;
                $DEBUG_ENABLED = $1 if /^-(debug)$/i;
        }
        $package->export_to_level(1, @_);
}


# private function
sub callErrorHandler ($) {
        my $msg = shift;
        die  "$msg: [$!]\n" if $ERROR_HANDLER eq "die";
        warn "$msg: [$!]\n" if $ERROR_HANDLER eq "warn";
        return undef if $ERROR_HANDLER eq "quiet";
        &$ERROR_HANDLER($msg) if ref($ERROR_HANDLER) eq "CODE";
        return undef;
}


# private function
sub printLog ($) {
        my $msg = shift;
        return unless $DEBUG_ENABLED;
        print STDERR "FileSystem: $msg\n";
}


# ----------------------------------------------------------------------------

=head2 loadFile

=over 4

=item usage

  $contentRef = loadFile($fileName)

=item description

Loads file with given file-name from local filesystem.

=item parameters

  * fileName - name of the file to be loaded.

=item returns

Reference to file content string on success, otherwise either dies or warns
and returns undef as configured.

=back

=cut
# ============================================================================


BEGIN {
        $CACHE_FILE_NUM = 6;
        $cacheCounter = -1;
        @prevFileNames = ("", "", "", "", "", "");
        @prevFileContentRefs = \("", "", "", "", "", "");
}


sub loadFile ($) {
         my $fileName = shift;

        foreach (@$LOAD_FILE_DIRS) {
                if (-f "$_/$fileName") { $fileName = "$_/$fileName"; last; }
        }
        printLog("Loading file $fileName") if $DEBUG_ENABLED;

        if ($ENABLE_CACHE) {
                for (0 .. $CACHE_FILE_NUM-1) {
                        if ($fileName eq $prevFileNames[$_] && -r $fileName) {
                                printLog("getting from file cache") if $DEBUG_ENABLED;
                                return $prevFileContentRefs[$_];
                        }
                }
        }

        open(FILE, "<$fileName") || return callErrorHandler("Can't open $fileName");
        my $fileContent = join("", <FILE>);
        close(FILE) || return callErrorHandler("Can't close $fileName");

        if ($ENABLE_CACHE) {
                $cacheCounter = ($cacheCounter+1) % $CACHE_FILE_NUM;
                $prevFileNames[$cacheCounter] = $fileName;
                $prevFileContentRefs[$cacheCounter] = \$fileContent;
        }
        return \$fileContent;
}


# ----------------------------------------------------------------------------

=head2 saveFile

=over 4

=item description

Saves file-content to local filesystem with given file-name.

=item usage

  saveFile($fileName, \$fileContent);

=item parameters

  * fileName - name of the file to be saved into
  * fileContentRef - reference to file-content string
  * createSubdirs - optional flag (default is 0 - don't create subdirs)

=item returns

C<1> on success, otherwise either dies or warns and returns undef as configured.

=back

=cut
# ============================================================================


sub saveFile ($$;$) {
        my ($fileName, $fileContentRef, $createDirs) = @_;

        if ($fileName !~ m=^[/\\]|\w:\\=) {
                $fileName = "$SAVE_FILE_DIR/$fileName";
        }
        printLog("Saving  file $fileName") if $DEBUG_ENABLED;
        die("saveFile: No SCALAR ref parameter\n")
                unless ref($fileContentRef) eq 'SCALAR';

        if ($ENABLE_CACHE) {
                for (0 .. $CACHE_FILE_NUM-1) {
                        $prevFileContentRefs[$_] = $fileContentRef
                                if $fileName eq $prevFileNames[$_];
                }
        }
        if ($createDirs) {
                my $dirName = dirname($fileName);
                makePath($dirName) unless -d $dirName;
        }

        open(FILE, ">$fileName") || return callErrorHandler("Can't open $fileName");
        print FILE $$fileContentRef;
        close(FILE) || return callErrorHandler("Can't close $fileName");
        return 1;
}


# ----------------------------------------------------------------------------

=head2 appendFile

=over 4

=item description

Appends file-append-content to local filesystem with given file-name.

=item usage

  appendFile($fileName, \$fileAppendContent);

=item parameters

  * fileName - name of the file to be saved into
  * fileAppendContentRef - reference to file-append-content string

=item returns

C<1> on success, otherwise either dies or warns and returns undef as configured.

=back

=cut
# ============================================================================


sub appendFile ($$) {
        my ($fileName, $fileAppendRef) = @_;
        printLog("Append>>file $fileName") if $DEBUG_ENABLED;

        if ($ENABLE_CACHE) {
                for (0 .. $CACHE_FILE_NUM-1 && -r $fileName) {
                        ${$prevFileContentRefs[$_]} .= $$fileAppendRef
                                if $fileName eq $prevFileNames[$_];
                }
        }

        open(FILE, ">>$fileName") || return callErrorHandler("Can't append to $fileName");
        print FILE $$fileAppendRef;
        close(FILE) || return callErrorHandler("Can't close $fileName");
        return 1;
}


# ----------------------------------------------------------------------------

=head2 removeFile

=over 4

=item description

Removes all files from given directory.

=item usage

  removeFile($fileName);

=item parameters

  * fileName - name of the file to be deleted

=item returns

C<1> on success, otherwise either dies or warns and returns undef as configured.

=back

=cut
# ============================================================================


sub removeFile ($;$) {
        my $fileName = shift;
        printLog("Removin file $fileName") if $DEBUG_ENABLED;
        unlink($fileName) || return callErrorHandler("Can't unlink $fileName");
        return 1;
}


# ----------------------------------------------------------------------------

=head2 makeDir

=over 4

=item description

Removes all files from given directory.

=item usage

  makeDir($PREVIEW_DIR);

=item parameters

  * directory to make
  * optional creating dir permissions (default is $DEFAULT_DIR_PERM)

=item returns

C<1> on success, otherwise either dies or warns and returns undef as configured.

=back

=cut
# ============================================================================


sub makeDir ($;$) {
        my $dirName = shift;
        my $perm = shift || $DEFAULT_DIR_PERM;
        printLog("Creating dir $dirName, " . sprintf("%o", $perm))
                if $DEBUG_ENABLED;
        mkdir($dirName, $perm) || return callErrorHandler("Can't mkdir $dirName");
        return 1;
}


# ----------------------------------------------------------------------------

=head2 makePath

=over 4

=item description

Removes all files from given directory.

=item usage

  makePath($PUBLISH_DIR);

=item parameters

  * path to make
  * optional creating dir permissions (default is $DEFAULT_DIR_PERM)

=item returns

C<1> on success, otherwise either dies or warns and returns undef as configured.

=back

=cut
# ============================================================================


sub makePath ($;$) {
        my $dirName = shift;
        my $perm = shift || $DEFAULT_DIR_PERM;
        printLog("Making  path $dirName, " . sprintf("%o", $perm))
                if $DEBUG_ENABLED;

        return 1 if -d $dirName;
        my $parentDir = dirname($dirName);

        local $DEBUG_ENABLED = 0;
        &makePath($parentDir, $perm) unless -d $parentDir;
        makeDir($dirName, $perm);

        return 1;
}


# ----------------------------------------------------------------------------

=head2 copyFile

=over 4

=item description

Copies a file to another location.

=item usage

  copyFile($from, $to);

=item parameters

  * file name to copy from
  * file name to copy to

=item returns

C<1> on success, otherwise either dies or warns and returns undef as configured.

=back

=cut
# ============================================================================


sub copyFile ($$) {
        my ($srcFileName, $dstFileName) = @_;
        printLog("Copying file $srcFileName to $dstFileName")
                if $DEBUG_ENABLED;

        # Must manage symbolic links somehow
        # return if -l $srcFileName;

        copy($srcFileName, $dstFileName)
                or return callErrorHandler("Can't copy $srcFileName $dstFileName");

        if ($PRESERVED_STAT) {
                my ($device, $inode, $mode) = stat($srcFileName);
                chmod($mode, $dstFileName);
        }
        return 1;
}


# ----------------------------------------------------------------------------

=head2 moveFile

=over 4

=item description

Moves (or renames) a file to another location.

=item usage

  moveFile($from, $to);

=item parameters

  * file name to move from
  * file name to move to

=item returns

C<1> on success, otherwise either dies or warns and returns undef as configured.

=back

=cut
# ============================================================================


sub moveFile ($$) {
        my ($srcFileName, $dstFileName) = @_;
        printLog("Moving  file $srcFileName to $dstFileName")
                if $DEBUG_ENABLED;

        move($srcFileName, $dstFileName)
                or return callErrorHandler("Can't move $srcFileName $dstFileName");
        return 1;
}


# ----------------------------------------------------------------------------

=head2 cleanDir

=over 4

=item description

Removes all files from given directory.

=item usage

  cleanDir($PREVIEW_DIR);

=item parameters

  * directory to clean
  * optional flag:
    0 - don't go recursively, unlink files in first level only
    1 - recursively clean subdirs (default)
    2 - unlink subdirs
    3 - unlink given directory

=item returns

C<1> on success, otherwise either dies or warns and returns undef as configured.

=back

=cut
# ============================================================================


sub cleanDir ($;$) {
        my $dirName = shift;
        my $recursive = shift || 1;
        die("cleanDir: Unsupported flag $recursive\n")
                if $recursive > 3 || $recursive < 0;
        printLog(($recursive != 3? "Cleaning": "Removing") . " dir $dirName "
                . ["files only", "recursively files only", "recursively", "completely"]->[$recursive])
                if $DEBUG_ENABLED;

        local $DEBUG_ENABLED = 0;

        my @subdirs = ();
        my $fileNames = listFileNames($dirName);

        # process files
        foreach (@$fileNames) {
                next if $NEVER_REMOVE_FILES{$_};
                my $fileName = "$dirName/$_";
                if (-d $fileName) { push @subdirs, $fileName; }
                else { unlink("$fileName") || return callErrorHandler("Can't unlink $fileName"); }
        }

        # process subdirs
        map {
                cleanDir($_, $recursive);
                rmdir($_) || return callErrorHandler("Can't unlink $_") if $recursive == 2;
        } @subdirs if $recursive;
        rmdir($dirName) || return callErrorHandler("Can't unlink $dirName") if $recursive == 3;

        return 1;
}


# ----------------------------------------------------------------------------

=head2 removeDir

=over 4

=item description

Entirely removes given directory and its content (if any).
This is an alias to C<cleanDir(3)>.

=item usage

  removeDir($TMP_DIR);

=item parameters

  * directory to clean

=item returns

C<1> on success, otherwise either dies or warns and returns undef as configured.

=back

=cut
# ============================================================================


sub removeDir ($) {
        my $dirName = shift;
        return cleanDir($dirName, 3);
}


# ----------------------------------------------------------------------------

=head2 copyDir

=over 4

=item description

Recursively copies all files and subdirectories inside given directory
to new location.

Destination directory must not exist. Use: C<trap { removeDir($dest); };>
to remove it before copying.

=item usage

  copyDir($dirFrom, $dirTo);

=item parameters

  * source directory to copy
  * destination directory to copy to (may not exist)
  * optional creating dir permissions (default is $DEFAULT_DIR_PERM)

=item returns

C<1> on success, otherwise either dies or warns and returns undef as configured.

=back

=cut
# ============================================================================


sub copyDir ($$) {
        my ($srcDirName, $dstDirName, $perm) = @_;

        return callErrorHandler("Directory $srcDirName does not exist")
                unless -d $srcDirName;
        makeDir($dstDirName, $perm) unless -d $dstDirName;

        printLog("Copying  dir $srcDirName to $dstDirName recursively")
                if $DEBUG_ENABLED;;

        local $DEBUG_ENABLED = 0;

        my $error = 0;
        my @subdirs = ();
        my $fileNames = listFileNames($srcDirName);

        # process files
        foreach (@$fileNames) {
                next if $NEVER_COPY_FILES{$_};
                my $srcFileName = "$srcDirName/$_";
                my $dstFileName = "$dstDirName/$_";
                if (-d $srcFileName) { push @subdirs, $_; }
                elsif (-l $srcFileName) { next if "# We ignore links for now! TO FIX!" }
                else { copyFile($srcFileName, $dstFileName) or $error = 1; }
        }

        # process subdirs
        foreach (@subdirs) {
                my $srcSubDirName = "$srcDirName/$_";
                my $dstSubDirName = "$dstDirName/$_";
                &copyDir($srcSubDirName, $dstSubDirName) or $error = 1;
        }

        return callErrorHandler("Errors while copying some files/subdirs in $srcDirName to $dstDirName")
                if $error;
        return 1;
}


# ----------------------------------------------------------------------------

=head2 moveDir

=over 4

=item description

Moves (or actually renames) a directory to another location.

Destination directory must not exist. Use: C<trap { removeDir($dest); };>
to remove it before copying.

=item usage

  moveDir($dirFrom, $dirTo);

=item parameters

  * source directory to move from
  * destination directory to move to (must not exist)

=item returns

C<1> on success, otherwise either dies or warns and returns undef as configured.

=back

=cut
# ============================================================================


sub moveDir ($$) {
        my ($srcDirName, $dstDirName) = @_;
        printLog("Moving   dir $srcDirName to $dstDirName")
                if $DEBUG_ENABLED;

        rename($srcDirName, $dstDirName)
                or return callErrorHandler("Can't rename $srcDirName $dstDirName");
        return 1;
}


# ----------------------------------------------------------------------------

=head2 listFileNames

=over 4

=item description

Returns the file names in the given directory including all types of files
(regular, directory, link, other), not including '.' and '..' entries.

=item usage

  # mini file lister
  $dir = '/home/ftp';
  foreach my $file (@{listFileNames($dir)}) {
    print "File $file\n" if -f "$dir/$file";
    print "Dir  $file\n" if -d "$dir/$file";
  }

=item parameters

  * directory to list (or array ref of directories)
  * optional flag, 1 means work recursively, the default is 0

=item returns

Array ref of scalars (file names) on success.
Otherwise either dies or warns and returns undef as configured.

=back

=cut
# ============================================================================


sub listFileNames ($;$) {
        my $dirName = shift;
        my $recursive = shift || 0;
        if (ref($dirName) eq "ARRAY") {
                my @files = ();
                foreach (@$dirName) { push @files, &listFileNames($_); }
                return \@files;
        }
        printLog("Listing  dir $dirName") if $DEBUG_ENABLED;

        opendir(DIR, $dirName) || return callErrorHandler("Can't opendir $dirName");
        my @files = grep { $_ ne '.' && $_ ne '..' } readdir(DIR);
        closedir(DIR) || return callErrorHandler("Can't closedir $dirName");

        if ($recursive) {
                my $i = 0;
                for (; $i < @files; ) {
                        my $subdir = $files[$i];
                        if (-d "$dirName/$subdir") {
                                splice(@files, $i, 1, map { "$subdir/$_" }
                                        @{&listFileNames("$dirName/$subdir")});
                        } else {
                                $i++;
                        }
                }
        }

        return \@files;
}


# ----------------------------------------------------------------------------

=head2 findFile

=over 4

=item description

Searches for the given file in the given directories.

Returns the fully qualified file name.

=item usage

  my $gtkrc = findFile(".gtkrc", [$home, "$home/.gnome"]);

=item parameters

  * file name to search for
  * array ref of directories to search in

=item returns

File name with full path if found, or undef if not found.

=back

=cut
# ============================================================================


sub findFile ($$) {
        my $fileName = shift;
        my $dirs = shift();
        die "findFile: no dirs given\n" unless ref($dirs) eq "ARRAY";
        foreach (@$dirs) {
                my $filePath = "$_/$fileName";
                return $filePath if -f $filePath;
        }
        return undef;
}


# ----------------------------------------------------------------------------

=head2 findExecutable

=over 4

=item description

Searches for the given executable file in the directories that are in the
environmebt variable $PATH or in the additional parameter.

Returns the fully qualified file name.

=item usage

  my $gzipExe = findExecutable("gzip", ["/usr/gnu/bin", "/gnu/bin"]);

=item parameters

  * file name to search for (only executables are tested)
  * optional array ref of directories to search in

=item returns

File name with full path if found, or undef if not found.

=back

=cut
# ============================================================================


sub findExecutable ($;$) {
        my $fileName = shift;
        my $addDirs = shift;
        my @dirs = split(":", $ENV{"PATH"} || "");
        if (ref($addDirs) eq "ARRAY") {
                push @dirs, @$addDirs;
        }
        foreach (@dirs) {
                my $filePath = "$_/$fileName";
                return $filePath if -x $filePath;
        }
        return undef;
}


# ----------------------------------------------------------------------------

=head2 defaultDirPerm

=over 4

=item description

This functions changes default directory permissions, used in
C<makeDir>, C<makePath>, C<copyDir> and C<moveDir> functions.

The default of this package is 0775.

If no parameters specified, the current value is returned.

=item usage

 defaultDirPerm(0700);

=item parameters

  * optional default directory permission (integer)

=item returns

Previous value.

=back

=cut
# ============================================================================


sub defaultDirPerm (;$) {
        return if $^O =~ /Win|DOS/;
        my $newValue = shift;
        my $oldValue = $DEFAULT_DIR_PERM;

        if (defined $newValue) {
                printLog("defaultDirPerm = $newValue") if $DEBUG_ENABLED;
                $DEFAULT_DIR_PERM = $newValue;
        }
        return $oldValue;
}


# ----------------------------------------------------------------------------

=head2 preserveStat

=over 4

=item description

This functions changes behavior of C<copyFile> and C<copyDir> functions.
If 0 is given as a parameter stats will not be preserved.

TODO: specify values for diferent preserves:

  0 nothing
  1 mode   file mode  (type and permissions)
  2 uid    numeric user ID of file's owner
  4 gid    numeric group ID of file's owner
  8 atime  last access time since the epoch
 16 mtime  last modify time since the epoch
 32 ctime  inode change time (NOT creation time!) since the epo

The default of this package is 0.

If no parameters specified, nothing is set (only current value is returned).

=item usage

  preserveStat(1);

=item parameters

  * optional flag (currently 0 or 1)

=item returns

Previous value.

=back

=cut
# ============================================================================


sub preserveStat (;$) {
        return if $^O =~ /Win|DOS/;
        my $newValue = shift;
        my $oldValue = $PRESERVED_STAT;

        if (defined $newValue) {
                printLog("preserveStat = $newValue") if $DEBUG_ENABLED;
                $PRESERVED_STAT = $newValue;
        }
        return $oldValue;
}


# ----------------------------------------------------------------------------

=head2 parsePath

=over 4

=item usage

  my ($dirName, $baseName) = parsePath($fileName);

=item examples

  # in: "/data/projects/magazine"  out: ("/data/projects", "magazine")
  # in: "/magazine"                out: ("", "magazine")
  # in: "dir/"                     out: (dir", "")
  # in: "magazine"                 out: (".", "magazine")

  # in: "c:\projects\magazine"     out: ("c:\projects", "magazine")
  # in: "c:\magazine"              out: ("c:", "magazine")
  # in: "c:magazine"               out: ("c:.", "magazine")

=item description

Returns a list of 2 scalars: directory name and base name. All unix and dos
file names supported.

Note, the rule is this: you can join both scalars using a directory delimiter
(slash or backslash) and you will always get the the original (logical)
file name.

=back

=cut
# ============================================================================


sub parsePath ($) {
        my $path = shift;
        if ($path =~ m=^(.*)[/\\]+([^/\\]*)$=) {
                return ($1, $2);
        } else {
                # support even funny dos form c:file
                return $path =~ m=^(\w:)(.*)$=?
                        ($1 . ".", $2):
                        (".", $path);
        }
}


# ----------------------------------------------------------------------------

=head2 getCwd

=over 4

=item usage

  my $cwd = getCwd();

=item description

Returns the current working directory.

=back

=cut
# ============================================================================


sub getCwd () {
        $^O eq "MSWin32"? Win32::GetCwd(): require "getcwd.pl" && getcwd();
}


# ----------------------------------------------------------------------------

=head1 BUGS

All global functions and constants in this package should probably be
instantiated into a class object. As usual there are pros and cons.

=head1 AUTHOR

Mikhael Goikhman <migo@homemail.com>

=cut
# ============================================================================


1;