########################################################################### # # FileUtils.pm -- functions for dealing with files. Skeleton for more # advanced system using dynamic class cloading available in extensions. # # A component of the Greenstone digital library software # from the New Zealand Digital Library Project at the # University of Waikato, New Zealand. # # Copyright (C) 2013 New Zealand Digital Library Project # # 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., 675 Mass Ave, Cambridge, MA 02139, USA. # ########################################################################### package FileUtils; # Pragma use strict; use warnings; use FileHandle; use File::stat; # Greenstone modules use util; ################################################################################ # util::cachedir() => FileUtils::synchronizeDirectory() # util::cp() => FileUtils::copyFiles() # util::cp_r() => FileUtils::copyFilesRecursive() # util::cp_r_nosvn() => FileUtils::copyFilesRecursiveNoSVN() # util::cp_r_toplevel() => FileUtils::copyFilesRecursiveTopLevel() # util::differentfiles() => FileUtils::differentFiles() # util::dir_exists() => FileUtils::directoryExists() # util::fd_exists() => FileUtils::fileTest() # util::file_exists() => FileUtils::fileExists() # util::filename_cat() => FileUtils::filenameConcatenate() # util::filename_is_absolute() => FileUtils::isFilenameAbsolute() # util::filtered_rm_r() => FileUtils::removeFilesFiltered() # util::hard_link() => FileUtils::hardLink() # util::is_dir_empty() => FileUtils::isDirectoryEmpty() # util::mk_all_dir() => FileUtils::makeAllDirectories() # util::mk_dir() => FileUtils::makeDirectory() # util::mv() => FileUtils::moveFiles() # util::mv_dir_contents() => FileUtils::moveDirectoryContents() # util::rm() => FileUtils::removeFiles() # util::rm_r() => FileUtils::removeFilesRecursive() # util::soft_link() => FileUtils::softLink() # Functions that have been added, but not by John Thompson, # So the implementations don't support parallel processing yet, but they print a warning and the # correct implementation can be put into here. So that if all calls for reading and writing UTF8 # file content go through here, then they will do the right thing when the functions are updated. # # => FileUtils::readUTF8File() # => FileUtils::writeUTF8File() # # Other functions in this file (perhaps some of these may have counterparts in util.pm too): #canRead #getTimestamp #isSymbolicLink #modificationTime #readDirectory #removeFilesDebug #sanitizePath #openFileHandle #closeFileHandle #differentFiles #filePutContents #fileSize #readDirectory ################################################################################ # Note: there are lots of functions involving files/directories/paths # etc found in utils.pm that are not represented here. My intention # was to just have those functions that need to be dynamic based on # filesystem, or need some rejigging to be filesystem aware. There is # an argument, I guess, for moving some of the other functions here so # that they are nicely encapsulated - but the question is what to do # with functions like filename_within_directory_url_format() which is # more URL based than file based. ################################################################################ ## @function canRead() # sub canRead { my ($filename_full_path) = @_; return &fileTest($filename_full_path, '-R'); } ## canRead() ## @function getTimestamp() # sub getTimestamp { my ($filename) = @_; my $file_stat = stat($filename); my $mtime = $file_stat->mtime; return $mtime; } ## getTimestamp() ## @function closeFileHandle # sub closeFileHandle { my ($path, $fh_ref) = @_; close($$fh_ref); } ## closeFileHandle() ## @function copyFilesGeneral() # # version that copies a file or a group of files # sub copyFilesGeneral { my ($srcfiles_ref,$dest,$options) = @_; # upgrade srcfiles_ref to array reference, if what is passed in is a single (scalar) filename $srcfiles_ref = [ $srcfiles_ref] if (ref $srcfiles_ref eq ""); my $strict = (defined $options && $options->{'strict'}) ? $options->{'strict'} : 0; my $hardlink = (defined $options && $options->{'hardlink'}) ? $options->{'hardlink'} : 0; # remove trailing slashes from source and destination files $dest =~ s/[\\\/]+$//; map {$_ =~ s/[\\\/]+$//;} @$srcfiles_ref; # a few sanity checks if (scalar(@$srcfiles_ref) == 0) { print STDERR "FileUtils::copyFilesGeneral() no destination directory given\n"; return 0; } elsif ((scalar(@$srcfiles_ref) > 1) && (!-d $dest)) { print STDERR "FileUtils::copyFilesGeneral() if multiple source files are given the destination must be a directory\n"; return 0; } my $had_an_error = 0; # copy the files foreach my $file (@$srcfiles_ref) { my $tempdest = $dest; if (-d $tempdest) { my ($filename) = $file =~ /([^\\\/]+)$/; $tempdest .= "/$filename"; } if (!-e $file) { print STDERR "FileUtils::copyFilesGeneral() $file does not exist\n"; $had_an_error = 1; if ($strict) { return 0; } } elsif (!-f $file) { print STDERR "FileUtils::copyFilesGeneral() $file is not a regular file\n"; $had_an_error = 1; if ($strict) { return 0; } } else { my $success = undef; if ($hardlink) { if (!link($file, $tempdest)) { print STDERR "Warning: FileUtils::copyFilesGeneral(): unable to create hard link. "; print STDERR " Attempting file copy: $file -> $tempdest\n"; $success = &File::Copy::copy($file, $tempdest); } else { $success = 1; } } else { $success = &File::Copy::copy($file, $tempdest); } if (!$success) { print STDERR "FileUtils::copyFilesGeneral() failed to copy $file -> $tempdest\n"; $had_an_error = 1; if ($strict) { return 0; } } } } if ($had_an_error) { return 0; } else { # true => everything OK return 1; } } ## copyFilesGeneral() ## @function copyFiles() # # copies a file or a group of files # sub copyFiles { my $dest = pop (@_); my (@srcfiles) = @_; return ©FilesGeneral(\@srcfiles,$dest,undef); } ## copyFiles() ## @function _readdirWithOptions() # # Internal version to support public functions such as readdirFullpath and readDirectory sub _readdirWithOptions { my ($src_dir_fullpath,$options) = @_; my $ret_val_success = 1; # default (true) is to assume things will work out! my $all_files_and_dirs = []; my $strict = 0; my $make_fullpath = 0; my $exclude_dirs = 0; my $exclude_files = 0; my $exclude_filter_re = undef; my $include_filter_re = undef; if (defined $options) { $strict = $options->{'strict'} if defined $options->{'strict'}; $make_fullpath = $options->{'make_fullpath'} if defined $options->{'make_fullpath'}; $exclude_dirs = $options->{'exclude_dirs'} if defined $options->{'exclude_dirs'}; $exclude_files = $options->{'exclude_files'} if defined $options->{'exclude_files'}; $exclude_filter_re = $options->{'exclude_filter_re'} if defined $options->{'exclude_filter_re'}; $include_filter_re = $options->{'include_filter_re'} if defined $options->{'include_filter_re'}; } # get the contents of this directory if (!opendir(INDIR, $src_dir_fullpath)) { print STDERR "FileUtils::readdirFullpath() could not open directory $src_dir_fullpath\n"; $ret_val_success = 0; } else { my @next_files_and_dirs = readdir(INDIR); closedir (INDIR); foreach my $f_or_d (@next_files_and_dirs) { next if $f_or_d =~ /^\.\.?$/; next if $exclude_dirs && -d &filenameConcatenate($src_dir_fullpath, $f_or_d); next if $exclude_files && -f &filenameConcatenate($src_dir_fullpath, $f_or_d); next if (defined $exclude_filter_re && ($f_or_d =~ m/$exclude_filter_re/)); if ((!defined $include_filter_re) || ($f_or_d =~ m/$include_filter_re/)) { if ($make_fullpath) { my $ff_or_dd = &filenameConcatenate($src_dir_fullpath, $f_or_d); push(@$all_files_and_dirs,$ff_or_dd); } else { push(@$all_files_and_dirs,$f_or_d); } } } } return ($ret_val_success,$all_files_and_dirs); } ## @function readdirFullpath() # # For the given input directory, return full-path versions of the # files and directories it contains # # returned data is in the form of the tuple (status, fullpath-listing) # sub readdirFullpath { my ($src_dir_fullpath,$options) = @_; my $topped_up_options = (defined $options) ? { %$options } : {}; $topped_up_options->{'make_fullpath'} = 1; my ($ret_val_success,$fullpath_files_and_dirs) = _readdirWithOptions($src_dir_fullpath,$topped_up_options); return ($ret_val_success,$fullpath_files_and_dirs); } ## @function _copyFilesRecursiveGeneral() # # internal support routine for recursively copying or hard-linking files # # Notes that the src-files are passed as a reference, and so a single arguemnt, # whereas the the public facing functions take a array or arguments, and pops off the # final entry and treats it as the 'dest' sub _copyFilesRecursiveGeneral { my ($srcfiles_ref,$dest,$depth,$options) = @_; # upgrade srcfiles_ref to array reference, if what is passed in is a single (scalar) filename $srcfiles_ref = [ $srcfiles_ref] if (ref $srcfiles_ref eq ""); # 'strict' defaults to false # when false, this means, in situations where it can, even if an error is encountered it keeps going my $strict = (defined $options && $options->{'strict'}) ? $options->{'strict'} : 0; my $hardlink = (defined $options && $options->{'hardlink'}) ? $options->{'hardlink'} : 0; my $copytype = (defined $options && $options->{'copytype'}) ? $options->{'copytype'} : "recursive"; # a few sanity checks my $num_src_files = scalar (@$srcfiles_ref); if ($num_src_files == 0) { print STDERR "FileUtils::_copyFilesRecursiveGeneral() no destination directory given\n"; return 0; } elsif (-f $dest) { print STDERR "FileUtils::_copyFilesRecursiveGeneral() destination must be a directory\n"; return 0; } if ($depth == 0) { # Test for the special (top-level) case where: # there is only one src file # it is a directory # and dest as a directory does not exits # # => This is a case similar to something like cp -r abc/ def/ # where we *don't* want abc ending up inside def if ($num_src_files == 1) { my $src_first_fullpath = $srcfiles_ref->[0]; if (-d $src_first_fullpath) { my $src_dir_fullpath = $src_first_fullpath; if (! -e $dest) { # Do slight of hand, and replace the supplied single src_dir_fullpath with the contents of # that directory my ($readdir_status, $fullpath_subfiles_and_subdirs) = &readdirFullpath($src_dir_fullpath,$options); if (!$readdir_status) { return 0; } else { $srcfiles_ref = $fullpath_subfiles_and_subdirs; } } } } } # create destination directory if it doesn't exist already if (! -d $dest) { my $mkdir_status = &makeAllDirectories($dest); if (!$mkdir_status) { return 0; } } # my $store_umask = umask(0002); # my $mkdir_status = mkdir($dest, 0777); # if (!$mkdir_status) { # print STDERR "$!\n"; # print STDERR "FileUtils::_copyFilesRecursiveGeneral() failed to create directory $dest\n"; # umask($store_umask); # return 0; # } # umask($store_umask); # } my $had_an_error = 0; # copy the files foreach my $file (@$srcfiles_ref) { if (! -e $file) { print STDERR "FileUtils::_copyFilesRecursiveGeneral() $file does not exist\n"; if ($strict) { return 0; } else { $had_an_error = 1; } } elsif (-d $file) { # src-file is a diretory => recursive case my $src_dir_fullpath = $file; # make the new directory my ($src_dirname_tail) = $src_dir_fullpath =~ /([^\\\/]*)$/; my $next_dest = &filenameConcatenate($dest, $src_dirname_tail); my $store_umask = umask(0002); my $mkdir_success_ok = mkdir($next_dest, 0777); umask($store_umask); if (!$mkdir_success_ok) { $had_an_error = 1; if ($strict) { return 0; } } my ($readdir_status, $fullpath_src_subfiles_and_subdirs) = &readdirFullpath($src_dir_fullpath,$options); if (!$readdir_status) { $had_an_error = 1; if ($strict) { return 0; } } else { if ($copytype eq "toplevel") { foreach my $fullpath_subf_or_subd (@$fullpath_src_subfiles_and_subdirs) { if (-f $fullpath_subf_or_subd) { my $fullpath_subf = $fullpath_subf_or_subd; my $ret_val_success = ©FilesGeneral([$fullpath_subf],$dest,$options); if ($ret_val_success == 0) { $had_an_error = 1; if ($strict) { return 0; } } } } } else { # Recursively copy all the files/dirs in this directory: # but first lets check if we actually have anything to copy... my $num_src_files = scalar (@$fullpath_src_subfiles_and_subdirs); if ($num_src_files > 0 ) { my $ret_val_success = &_copyFilesRecursiveGeneral($fullpath_src_subfiles_and_subdirs,$next_dest, $depth+1, $options); if ($ret_val_success == 0) { $had_an_error = 1; if ($strict) { return 0; } } } } } } else { my $ret_val_success = ©FilesGeneral([$file], $dest, $options); if ($ret_val_success == 0) { $had_an_error = 1; if ($strict) { # Error condition encountered in copy => immediately bail, passing the error on to outer calling function return 0; } } } } # get to here, then everything went well if ($had_an_error) { return 0; } else { # true => everything OK return 1; } } ## _copyFilesRecursiveGeneral() sub copyFilesRefRecursive { my ($srcfiles_ref,$dest, $options) = @_; _copyFilesRecursiveGeneral($srcfiles_ref,$dest,0, $options); } ## @function copyFilesRecursive() # # recursively copies a file or group of files syntax: cp_r # (sourcefiles, destination directory) destination must be a directory # to copy one file to another use copyFiles instead # sub copyFilesRecursive { my $dest = pop (@_); my (@srcfiles) = @_; return _copyFilesRecursiveGeneral(\@srcfiles,$dest,0,undef); } ## copyFilesRecursive() ## @function copyFilesRecursiveNoSVN() # # recursively copies a file or group of files, excluding SVN # directories, with syntax: cp_r (sourcefiles, destination directory) # destination must be a directory - to copy one file to another use cp # instead # sub copyFilesRecursiveNoSVN { my $dest = pop (@_); my (@srcfiles) = @_; return _copyFilesRecursiveGeneral(\@srcfiles,$dest, 0, { 'exclude_filter_re' => "^\\.svn\$" } ); } ## copyFilesRecursiveNoSVN() ## @function copyFilesRecursiveTopLevel() # # copies a directory and its contents, excluding subdirectories, into a new directory # sub copyFilesRecursiveTopLevel { my $dest = pop (@_); my (@srcfiles) = @_; return _copyFilesRecursiveGeneral(\@srcfiles,$dest, 0, { 'copytype' => "toplevel" } ); } ## copyFilesRecursiveTopLevel() ## @function hardlinkFilesRecursive() # # recursively hard-links a file or group of files syntax similar to # how 'cp -r' operates (only hard-linking of course!) # (sourcefiles, destination directory) destination must be a directory # to copy one file to another use cp instead # sub hardlinkFilesRefRecursive { my ($srcfiles_ref,$dest, $options) = @_; # only dealing with scalar values in 'options' so OK to shallow copy my $options_clone = (defined $options) ? { %$options } : {}; # top-up with setting to trigger hard-linking $options_clone->{'hardlink'} = 1; _copyFilesRecursiveGeneral($srcfiles_ref,$dest,0, $options_clone); } sub hardlinkFilesRecursive { my $dest = pop (@_); my (@srcfiles) = @_; _copyFilesRecursiveGeneral(\@srcfiles,$dest,0, { 'hardlink' => 1 }); } ## @function differentFiles() # # this function returns -1 if either file is not found assumes that # $file1 and $file2 are absolute file names or in the current # directory $file2 is allowed to be newer than $file1 # sub differentFiles { my ($file1, $file2, $verbosity) = @_; $verbosity = 1 unless defined $verbosity; $file1 =~ s/\/+$//; $file2 =~ s/\/+$//; my ($file1name) = $file1 =~ /\/([^\/]*)$/; my ($file2name) = $file2 =~ /\/([^\/]*)$/; return -1 unless (-e $file1 && -e $file2); if ($file1name ne $file2name) { print STDERR "filenames are not the same\n" if ($verbosity >= 2); return 1; } my @file1stat = stat ($file1); my @file2stat = stat ($file2); if (-d $file1) { if (! -d $file2) { print STDERR "one file is a directory\n" if ($verbosity >= 2); return 1; } return 0; } # both must be regular files unless (-f $file1 && -f $file2) { print STDERR "one file is not a regular file\n" if ($verbosity >= 2); return 1; } # the size of the files must be the same if ($file1stat[7] != $file2stat[7]) { print STDERR "different sized files\n" if ($verbosity >= 2); return 1; } # the second file cannot be older than the first if ($file1stat[9] > $file2stat[9]) { print STDERR "file is older\n" if ($verbosity >= 2); return 1; } return 0; } ## differentFiles() ## @function directoryExists() # sub directoryExists { my ($filename_full_path) = @_; return &fileTest($filename_full_path, '-d'); } ## directoryExists() ## @function fileExists() # sub fileExists { my ($filename_full_path) = @_; return &fileTest($filename_full_path, '-f'); } ## fileExists() ## @function filenameConcatenate() # sub filenameConcatenate { my $first_file = shift(@_); my (@filenames) = @_; # Useful for debugging # -- might make sense to call caller(0) rather than (1)?? # my ($cpackage,$cfilename,$cline,$csubr,$chas_args,$cwantarray) = caller(1); # print STDERR "Calling method: $cfilename:$cline $cpackage->$csubr\n"; # If first_file is not null or empty, then add it back into the list if (defined $first_file && $first_file =~ /\S/) { unshift(@filenames, $first_file); } my $filename = join("/", @filenames); # remove duplicate slashes and remove the last slash if (($ENV{'GSDLOS'} =~ /^windows$/i) && ($^O ne "cygwin")) { $filename =~ s/[\\\/]+/\\/g; } else { $filename =~ s/[\/]+/\//g; # DB: want a filename abc\de.html to remain like this } $filename =~ s/[\\\/]$//; return $filename; } ## filenameConcatenate() ## @function javaFilenameConcatenate() # # Same as filenameConcatenate(), except because on Cygwin # the java we run is still Windows native, then this means # we want the generate filename to be in native Windows format sub javaFilenameConcatenate { my (@filenames) = @_; my $filename_cat = filenameConcatenate(@filenames); if ($^O eq "cygwin") { # java program, using a binary that is native to Windows, so need # Windows directory and path separators $filename_cat = `cygpath -wp "$filename_cat"`; chomp($filename_cat); $filename_cat =~ s%\\%\\\\%g; } return $filename_cat; } ## javaFilenameConcatenate() ## @function filePutContents() # # Create a file and write the given string directly to it # @param $path the full path of the file to write as a String # @param $content the String to be written to the file # sub filePutContents { my ($path, $content) = @_; if (open(FOUT, '>:utf8', $path)) { print FOUT $content; close(FOUT); } else { die('Error! Failed to open file for writing: ' . $path . "\n"); } } ## filePutContents() ## @function fileSize() # sub fileSize { my $path = shift(@_); my $file_size = -s $path; return $file_size; } ## fileSize() ## @function fileTest() # sub fileTest { my $filename_full_path = shift @_; my $test_op = shift @_ || "-e"; # By default tests for existance of file or directory (-e) # Can be made more specific by providing second parameter (e.g. -f or -d) my $exists = 0; if (($ENV{'GSDLOS'} =~ m/^windows$/i) && ($^O ne "cygwin")) { require Win32; my $filename_short_path = Win32::GetShortPathName($filename_full_path); if (!defined $filename_short_path) { # Was probably still in UTF8 form (not what is needed on Windows) my $unicode_filename_full_path = eval "decode(\"utf8\",\$filename_full_path)"; if (defined $unicode_filename_full_path) { $filename_short_path = Win32::GetShortPathName($unicode_filename_full_path); } } $filename_full_path = $filename_short_path; } if (defined $filename_full_path) { $exists = eval "($test_op \$filename_full_path)"; } return $exists || 0; } ## fileTest() ## @function hardLink() # make hard link to file if supported by OS, otherwise copy the file # sub hardLink { my ($src, $dest, $verbosity, $options) = @_; # 'strict' defaults to false # see _copyFilesRecursiveGeneral for more details my $strict = (defined $options && $options->{'strict'}) ? $options->{'strict'} : 0; # remove trailing slashes from source and destination files $src =~ s/[\\\/]+$//; $dest =~ s/[\\\/]+$//; my $had_an_error = 0; ## print STDERR "**** src = ", unicode::debug_unicode_string($src),"\n"; # a few sanity checks if (!-e $src) { print STDERR "FileUtils::hardLink() source file \"" . $src . "\" does not exist\n"; if ($strict) { return 0; } else { $had_an_error = 1; } } elsif (-d $src) { print STDERR "FileUtils::hardLink() source \"" . $src . "\" is a directory\n"; if ($strict) { return 0; } else { $had_an_error = 1; } } elsif (-e $dest) { if ($strict) { return 0; } else { print STDERR "FileUtils::hardLink() dest file ($dest) exists, removing it\n"; my $status_ok = &removeFiles($dest); if (!$status_ok) { $had_an_error = 1; } } } my $dest_dir = &File::Basename::dirname($dest); if (!-e $dest_dir) { my $status_ok = &makeAllDirectories($dest_dir); if ($strict) { return 0; } else { $had_an_error = 1; } } if (!link($src, $dest)) { if ((!defined $verbosity) || ($verbosity>2)) { print STDERR "Warning: FileUtils::hardLink(): unable to create hard link. "; print STDERR " Copying file: $src -> $dest\n"; } my $status_ok = &File::Copy::copy($src, $dest); if (!$status_ok) { $had_an_error = 1; } } if ($had_an_error) { return 0; } else { # no fatal issue encountered => return true return 1; } } ## hardLink() ## @function isDirectoryEmpty() # # A method to check if a directory is empty (note that an empty # directory still has non-zero size!!!). Code is from # http://episteme.arstechnica.com/eve/forums/a/tpc/f/6330927813/m/436007700831 # sub isDirectoryEmpty { my ($path) = @_; opendir DIR, $path; while(my $entry = readdir DIR) { next if($entry =~ /^\.\.?$/); closedir DIR; return 0; } closedir DIR; return 1; } ## isDirectoryEmpty() ## @function isFilenameAbsolute() # sub isFilenameAbsolute { my ($filename) = @_; if (($ENV{'GSDLOS'} =~ /^windows$/i) && ($^O ne "cygwin")) { return ($filename =~ m/^(\w:)?\\/); } return ($filename =~ m/^\//); } # isFilenameAbsolute() ## @function isSymbolicLink # # Determine if a given path is a symbolic link (soft link) # sub isSymbolicLink { my $path = shift(@_); my $is_soft_link = -l $path; return $is_soft_link; } ## isSymbolicLink() ## @function makeAllDirectories() # # in case anyone cares - I did some testing (using perls Benchmark module) # on this subroutine against File::Path::mkpath (). mk_all_dir() is apparently # slightly faster (surprisingly) - Stefan. # sub makeAllDirectories { my ($dir) = @_; # use / for the directory separator, remove duplicate and trailing slashes $dir=~s/[\\\/]+/\//g; $dir=~s/[\\\/]+$//; # make sure the cache directory exists my $dirsofar = ""; my $first = 1; foreach my $dirname (split ("/", $dir)) { $dirsofar .= "/" unless $first; $first = 0; $dirsofar .= $dirname; next if $dirname =~ /^(|[a-z]:)$/i; if (!-e $dirsofar) { my $store_umask = umask(0002); my $mkdir_ok = mkdir ($dirsofar, 0777); umask($store_umask); if (!$mkdir_ok) { print STDERR "FileUtils::makeAllDirectories() could not create directory $dirsofar\n"; return 0; } } } return 1; } ## makeAllDirectories() ## @function makeDirectory() # sub makeDirectory { my ($dir) = @_; my $store_umask = umask(0002); my $mkdir_ok = mkdir ($dir, 0777); umask($store_umask); if (!$mkdir_ok) { print STDERR "FileUtils::makeDirectory() could not create directory $dir\n"; return 0; } # get to here, everything went as expected return 1; } ## makeDirectory() ## @function modificationTime() # sub modificationTime { my $path = shift(@_); my @file_status = stat($path); return $file_status[9]; } ## modificationTime() ## @function moveDirectoryContents() # # Move the contents of source directory into target directory (as # opposed to merely replacing target dir with the src dir) This can # overwrite any files with duplicate names in the target but other # files and folders in the target will continue to exist # sub moveDirectoryContents { # Currently has no return values!!! #### !!!! worthy of upgrading to include $options, and then use #### !!!! 'strict' to determine whether it returns 0 when hitting #### !!!! an issue immediately, or else persevere, and continue my ($src_dir, $dest_dir) = @_; # Obtain listing of all files within src_dir # Note that readdir lists relative paths, as well as . and .. opendir(DIR, "$src_dir"); my @files= readdir(DIR); close(DIR); my @full_path_files = (); foreach my $file (@files) { # process all except . and .. unless($file eq "." || $file eq "..") { my $dest_subdir = &filenameConcatenate($dest_dir, $file); # $file is still a relative path # construct absolute paths $file = &filenameConcatenate($src_dir, $file); # $file is now an absolute path # Recurse on directories which have an equivalent in target dest_dir # If $file is a directory that already exists in target $dest_dir, # then a simple move operation will fail (definitely on Windows). if(-d $file && -d $dest_subdir) { #print STDERR "**** $file is a directory also existing in target, its contents to be copied to $dest_subdir\n"; &moveDirectoryContents($file, $dest_subdir); # now all content is moved across, delete empty dir in source folder if(&isDirectoryEmpty($file)) { if (!rmdir $file) { print STDERR "ERROR. FileUtils::moveDirectoryContents() couldn't remove directory $file\n"; } } # error else { print STDERR "ERROR. FileUtils::moveDirectoryContents(): subfolder $file still non-empty after moving contents to $dest_subdir\n"; } } # process files and any directories that don't already exist with a simple move else { push(@full_path_files, $file); } } } # create target toplevel folder or subfolders if they don't exist if(!&directoryExists($dest_dir)) { &makeDirectory($dest_dir); } #print STDERR "@@@@@ Copying files |".join(",", @full_path_files)."| to: $dest_dir\n"; # if non-empty, there's something to copy across if(@full_path_files) { &moveFiles(@full_path_files, $dest_dir); } } ## moveDirectoryContents() ## @function moveFiles() # # moves a file or a group of files # sub moveFiles { my $dest = pop (@_); my (@srcfiles) = @_; # remove trailing slashes from source and destination files $dest =~ s/[\\\/]+$//; map {$_ =~ s/[\\\/]+$//;} @srcfiles; # a few sanity checks if (scalar (@srcfiles) == 0) { print STDERR "FileUtils::moveFiles() no destination directory given\n"; return 0; } elsif ((scalar (@srcfiles) > 1) && (!-d $dest)) { print STDERR "FileUtils::moveFiles() if multiple source files are given the destination must be a directory\n"; return 0; } my $had_an_error = 0; # move the files foreach my $file (@srcfiles) { my $tempdest = $dest; if (-d $tempdest) { my ($filename) = $file =~ /([^\\\/]+)$/; $tempdest .= "/$filename"; } if (!-e $file) { print STDERR "FileUtils::moveFiles() $file does not exist\n"; $had_an_error = 1; } else { if (!rename($file, $tempdest)) { print STDERR "**** Failed to rename $file to $tempdest. Attempting copy and then delete\n"; my $copy_status_ok = &File::Copy::copy($file, $tempdest); if ($copy_status_ok) { my $remove_status_ok = &removeFiles($file); if (!$remove_status_ok) { $had_an_error = 1; } } else { $had_an_error = 1; } } # rename (partially) succeeded) but srcfile still exists after rename elsif (-e $file) { #print STDERR "*** srcfile $file still exists after rename to $tempdest\n"; if (!-e $tempdest) { print STDERR "@@@@ ERROR: $tempdest does not exist\n"; } # Sometimes the rename operation fails (as does # File::Copy::move). This turns out to be because the files # are hard-linked. Need to do a copy-delete in this case, # however, the copy step is not necessary: the srcfile got # renamed into tempdest, but srcfile itself still exists, # delete it. &File::Copy::copy($file, $tempdest); my $remove_status_ok = &removeFiles($file); if (!$remove_status_ok) { $had_an_error = 1; } } } } if ($had_an_error) { return 0; } else { return 1; } } ## moveFiles() ## @function renameDirectory() # # rename a directory # (effectively a move, where the destination name cannot already exist) # sub renameDirectory { my ($srcdir,$dstdir) = @_; my $had_an_error = 0; if (!-d $srcdir) { print STDERR "FileUtils::renameDirectory() Error - Source name must be an existing directory\n"; print STDERR "Source name was: $srcdir\n"; $had_an_error = 1; } elsif (-e $dstdir) { print STDERR "FileUtils::renameDirectory() Error - Destination name must not already exist\n"; print STDERR "Destination name was: $dstdir\n"; $had_an_error = 1; } else { if (!rename($srcdir,$dstdir)) { print STDERR "FileUtils::renameDirectory() -- Error occured moving source name to destination name\n"; print STDERR "Source name was: $srcdir\n"; print STDERR "Destination name was: $dstdir\n"; $had_an_error = 1; } } if ($had_an_error) { return 0; # i.e., not OK! } else { return 1; } } ## renameDirectory() ## @function openFileHandle() # sub openFileHandle { my $path = shift(@_); my $mode = shift(@_); my $fh_ref = shift(@_); my $encoding = shift(@_); my $mode_symbol; if ($mode eq 'w' || $mode eq '>') { $mode_symbol = '>'; $mode = 'writing'; } elsif ($mode eq 'a' || $mode eq '>>') { $mode_symbol = '>>'; $mode = 'appending'; } else { $mode_symbol = '<'; $mode = 'reading'; } if (defined $encoding) { $mode_symbol .= ':' . $encoding; } return open($$fh_ref, $mode_symbol, $path); } ## openFileHandle() ## @function readDirectory() # sub readDirectory { my $path = shift(@_); my $options = { 'strict' => 1 }; my ($ret_val_success,$files_and_dirs) = _readdirWithOptions($path,$options); if (!$ret_val_success) { die("Error! Failed to list files in directory: " . $path . "\n"); } return $files_and_dirs; } ## readDirectory() ## @function readDirectoryFiltered() # sub readDirectoryFiltered { my ($path,$exclude_filter_re,$include_filter_re) = @_; my $options = { 'strict' => 1 }; $options->{'exclude_filter_re'} = $exclude_filter_re if defined $exclude_filter_re; $options->{'include_filter_re'} = $include_filter_re if defined $include_filter_re; my ($ret_val_success,$files_and_dirs) = _readdirWithOptions($path,$options); if (!$ret_val_success) { die("Error! Failed to list files in directory: " . $path . "\n"); } return $files_and_dirs; } ## readDirectoryFiltered() ## @function readUTF8File() # # read contents from a file containing UTF8 using sysread, a fast implementation of file 'slurp' # # Parameter filename, the filepath to read from. # Returns undef if there was any trouble opening the file or reading from it. # sub readUTF8File { my $filename = shift(@_); print STDERR "@@@ Warning FileUtils::readFile() not yet implemented for parallel processing. Using regular version...\n"; #open(FIN,"<$filename") or die "FileUtils::readFile: Unable to open $filename for reading...ERROR: $!\n"; if(!open(FIN,"<$filename")) { print STDERR "FileUtils::readFile: Unable to open $filename for reading...ERROR: $!\n"; return undef; } # decode the bytes in the file with UTF8 enc, # to get unicode aware strings that represent utf8 chars binmode(FIN,":utf8"); my $contents = undef; # Read in the entire contents of the file in one hit sysread(FIN, $contents, -s FIN); close(FIN); return $contents; } ## readUTF8File() ## @function writeUTF8File() # # write UTF8 contents to a file. # # Parameter filename, the filepath to write to # Parameter contentRef, a *reference* to the contents to write out # sub writeUTF8File { my ($filename, $contentRef) = @_; print STDERR "@@@ Warning FileUtils::writeFile() not yet implemented for parallel processing. Using regular version...\n"; open(FOUT, ">$filename") or die "FileUtils::writeFile: Unable to open $filename for writing out contents...ERROR: $!\n"; # encode the unicode aware characters in the string as utf8 # before writing out the resulting bytes binmode(FOUT,":utf8"); print FOUT $$contentRef; close(FOUT); } ## writeUTF8File() ## @function removeFiles() # # removes files (but not directories) # sub removeFiles { my (@files) = @_; my @filefiles = (); my $ret_val_success = 1; # default (true) is to assume everything works out # make sure the files we want to delete exist # and are regular files foreach my $file (@files) { if (!-e $file) { print STDERR "Warning: FileUtils::removeFiles() $file does not exist\n"; } elsif ((!-f $file) && (!-l $file)) { print STDERR "Warning: FileUtils::removeFiles() $file is not a regular (or symbolic) file\n"; } else { push (@filefiles, $file); } } # remove the files my $numremoved = unlink @filefiles; # check to make sure all of them were removed if ($numremoved != scalar(@filefiles)) { print STDERR "FileUtils::removeFiles() Not all files were removed\n"; if ($numremoved == 0) { # without a '$options' parameter to provide strict=true/false then # interpret this particular situation as a "major" fail # => asked to remove files and not a single one was removed! $ret_val_success = 0; } } return $ret_val_success; } ## removeFiles() ## @function removeFilesDebug() # # removes files (but not directories) - can rename this to the default # "rm" subroutine when debugging the deletion of individual files. # Unused? # sub removeFilesDebug { my (@files) = @_; my @filefiles = (); # make sure the files we want to delete exist # and are regular files foreach my $file (@files) { if (!-e $file) { print STDERR "FileUtils::removeFilesDebug() " . $file . " does not exist\n"; } elsif ((!-f $file) && (!-l $file)) { print STDERR "FileUtils::removeFilesDebug() " . $file . " is not a regular (or symbolic) file\n"; } # debug message else { unlink($file) or warn "Could not delete file " . $file . ": " . $! . "\n"; } } } ## removeFilesDebug() ## @function removeFilesFiltered() # # NOTE: counterintuitively named, the parameter: # $file_accept_re determines which files are blacklisted (will be REMOVED by this sub) # $file_reject_re determines which files are whitelisted (will NOT be REMOVED) # sub removeFilesFiltered { my ($files,$file_accept_re,$file_reject_re, $options) = @_; # 'strict' defaults to false # see _copyFilesRecursiveGeneral for more details my $strict = (defined $options && $options->{'strict'}) ? $options->{'strict'} : 0; # my ($cpackage,$cfilename,$cline,$csubr,$chas_args,$cwantarray) = caller(2); # my ($lcfilename) = ($cfilename =~ m/([^\\\/]*)$/); # print STDERR "** Calling method (2): $lcfilename:$cline $cpackage->$csubr\n"; my @files_array = (ref $files eq "ARRAY") ? @$files : ($files); my $had_an_error = 0; # recursively remove the files foreach my $file (@files_array) { $file =~ s/[\/\\]+$//; # remove trailing slashes if (!-e $file) { # handle this as a warning rather than a fatal error that stops deleting files/dirs print STDERR "FileUtils::removeFilesFiltered() $file does not exist\n"; $had_an_error = 1; last if ($strict); } # don't recurse down symbolic link elsif ((-d $file) && (!-l $file)) { # specified '$file' is a directory => get the contents of this directory if (!opendir (INDIR, $file)) { print STDERR "FileUtils::removeFilesFiltered() could not open directory $file\n"; $had_an_error = 1; last; } else { my @filedir = grep (!/^\.\.?$/, readdir (INDIR)); closedir (INDIR); # remove all the files in this directory map {$_="$file/$_";} @filedir; my $remove_success_ok = &removeFilesFiltered(\@filedir,$file_accept_re,$file_reject_re); if ($remove_success_ok) { if (!defined $file_accept_re && !defined $file_reject_re) { # no filters were in effect, and all files were removed # => remove this directory if (!rmdir $file) { print STDERR "FileUtils::removeFilesFiltered() couldn't remove directory $file\n"; $had_an_error = 1; # back to there being a problem last if ($strict); } } } else { # had a problems in the above $had_an_error = 1; last if ($strict); } } } else { # File exists => skip if it matches the file_reject_re next if (defined $file_reject_re && ($file =~ m/$file_reject_re/)); if ((!defined $file_accept_re) || ($file =~ m/$file_accept_re/)) { # remove this file my $remove_success_ok = &removeFiles($file); if (!$remove_success_ok) { $had_an_error = 1; last if ($strict); } } } } if ($had_an_error) { return 0; } else { return 1; } } ## removeFilesFiltered() ## @function removeFilesRecursive() # # The equivalent of "rm -rf" with all the dangers therein # sub removeFilesRecursive { my (@files) = @_; # use the more general (but reterospectively written) function # filtered_rm_r function() with no accept or reject expressions return &removeFilesFiltered(\@files,undef,undef); } ## removeFilesRecursive() ## @function sanitizePath() # sub sanitizePath { my ($path) = @_; # fortunately filename concatenate will perform all the double slash # removal and end slash removal we need, and in a protocol aware # fashion return &filenameConcatenate($path); } ## sanitizePath() ## @function softLink() # # make soft link to file if supported by OS, otherwise copy file # sub softLink { my ($src, $dest, $ensure_paths_absolute) = @_; # remove trailing slashes from source and destination files $src =~ s/[\\\/]+$//; $dest =~ s/[\\\/]+$//; # Ensure file paths are absolute IF requested to do so # Soft_linking didn't work for relative paths if(defined $ensure_paths_absolute && $ensure_paths_absolute) { # We need to ensure that the src file is the absolute path # See http://perldoc.perl.org/File/Spec.html # it's relative if(!File::Spec->file_name_is_absolute( $src )) { $src = File::Spec->rel2abs($src); # make absolute } # Might as well ensure that the destination file's absolute path is used if(!File::Spec->file_name_is_absolute( $dest )) { $dest = File::Spec->rel2abs($dest); # make absolute } } # a few sanity checks if (!-e $src) { print STDERR "FileUtils::softLink() source file $src does not exist\n"; return 0; } my $dest_dir = &File::Basename::dirname($dest); if (!-e $dest_dir) { &makeAllDirectories($dest_dir); } if (($ENV{'GSDLOS'} =~ /^windows$/i) && ($^O ne "cygwin")) { # symlink not supported on windows &File::Copy::copy ($src, $dest); } elsif (!eval {symlink($src, $dest)}) { print STDERR "FileUtils::softLink(): unable to create soft link.\n"; return 0; } return 1; } ## softLink() ## @function synchronizeDirectory() # # updates a copy of a directory in some other part of the filesystem # verbosity settings are: 0=low, 1=normal, 2=high # both $fromdir and $todir should be absolute paths # sub synchronizeDirectory { my ($fromdir, $todir, $verbosity) = @_; $verbosity = 1 unless defined $verbosity; # use / for the directory separator, remove duplicate and # trailing slashes $fromdir=~s/[\\\/]+/\//g; $fromdir=~s/[\\\/]+$//; $todir=~s/[\\\/]+/\//g; $todir=~s/[\\\/]+$//; &makeAllDirectories($todir); # get the directories in ascending order if (!opendir (FROMDIR, $fromdir)) { print STDERR "FileUtils::synchronizeDirectory() could not read directory $fromdir\n"; return; } my @fromdir = grep (!/^\.\.?$/, sort(readdir (FROMDIR))); closedir (FROMDIR); if (!opendir (TODIR, $todir)) { print STDERR "FileUtils::synchronizeDirectory() could not read directory $todir\n"; return; } my @todir = grep (!/^\.\.?$/, sort(readdir (TODIR))); closedir (TODIR); my $fromi = 0; my $toi = 0; while ($fromi < scalar(@fromdir) || $toi < scalar(@todir)) { # print "fromi: $fromi toi: $toi\n"; # see if we should delete a file/directory # this should happen if the file/directory # is not in the from list or if its a different # size, or has an older timestamp if ($toi < scalar(@todir)) { if (($fromi >= scalar(@fromdir)) || ($todir[$toi] lt $fromdir[$fromi] || ($todir[$toi] eq $fromdir[$fromi] && &differentFiles("$fromdir/$fromdir[$fromi]","$todir/$todir[$toi]", $verbosity)))) { # the files are different &removeFilesRecursive("$todir/$todir[$toi]"); splice(@todir, $toi, 1); # $toi stays the same } elsif ($todir[$toi] eq $fromdir[$fromi]) { # the files are the same # if it is a directory, check its contents if (-d "$todir/$todir[$toi]") { &synchronizeDirectory("$fromdir/$fromdir[$fromi]", "$todir/$todir[$toi]", $verbosity); } $toi++; $fromi++; next; } } # see if we should insert a file/directory # we should insert a file/directory if there # is no tofiles left or if the tofile does not exist if ($fromi < scalar(@fromdir) && ($toi >= scalar(@todir) || $todir[$toi] gt $fromdir[$fromi])) { &cp_r ("$fromdir/$fromdir[$fromi]", "$todir/$fromdir[$fromi]"); splice (@todir, $toi, 0, $fromdir[$fromi]); $toi++; $fromi++; } } } ## synchronizeDirectory() 1;