[27386] | 1 | ###############################################################################
|
---|
| 2 | #
|
---|
| 3 | # LocalFS.pm -- file functions acting upon the local filesystem
|
---|
| 4 | #
|
---|
| 5 | # A component of the Greenstone digital library software from the New Zealand
|
---|
| 6 | # Digital Library Project at the University of Waikato, New Zealand.
|
---|
| 7 | #
|
---|
| 8 | # Copyright (C) 2013 New Zealand Digital Library Project
|
---|
| 9 | #
|
---|
| 10 | # This program is free software; you can redistribute it and/or modify it under
|
---|
| 11 | # the terms of the GNU General Public License as published by the Free Software
|
---|
| 12 | # Foundation; either version 2 of the License, or (at your option) any later
|
---|
| 13 | # version.
|
---|
| 14 | #
|
---|
| 15 | # This program is distributed in the hope that it will be useful, but WITHOUT
|
---|
| 16 | # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
|
---|
| 17 | # FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
|
---|
| 18 | # details.
|
---|
| 19 | #
|
---|
| 20 | # You should have received a copy of the GNU General Public License along with
|
---|
| 21 | # this program; if not, write to the Free Software Foundation, Inc., 675 Mass
|
---|
| 22 | # Ave, Cambridge, MA 02139, USA.
|
---|
| 23 | #
|
---|
| 24 | ###############################################################################
|
---|
| 25 |
|
---|
| 26 | package FileUtils::LocalFS;
|
---|
| 27 |
|
---|
| 28 | # Pragma
|
---|
| 29 | use strict;
|
---|
| 30 |
|
---|
| 31 |
|
---|
[27422] | 32 | ## @function canRead()
|
---|
| 33 | #
|
---|
| 34 | sub canRead
|
---|
| 35 | {
|
---|
| 36 | my $path = shift(@_);
|
---|
| 37 | return &fileTest($path, '-R');
|
---|
| 38 | }
|
---|
| 39 | ## canRead()
|
---|
| 40 |
|
---|
| 41 |
|
---|
[27386] | 42 | ## @function closeFileHandle
|
---|
| 43 | #
|
---|
| 44 | sub closeFileHandle
|
---|
| 45 | {
|
---|
| 46 | my $fh_ref = shift(@_);
|
---|
| 47 | close($$fh_ref);
|
---|
| 48 | return 1;
|
---|
| 49 | }
|
---|
| 50 | ## closeFileHandle()
|
---|
| 51 |
|
---|
| 52 |
|
---|
| 53 | ## @function filenameConcatenate()
|
---|
| 54 | #
|
---|
| 55 | sub filenameConcatenate
|
---|
| 56 | {
|
---|
| 57 | my $first_file = shift(@_);
|
---|
| 58 | my (@filenames) = @_;
|
---|
| 59 |
|
---|
| 60 | # Useful for debugging
|
---|
| 61 | # -- might make sense to call caller(0) rather than (1)??
|
---|
| 62 | # my ($cpackage,$cfilename,$cline,$csubr,$chas_args,$cwantarray) = caller(1);
|
---|
| 63 | # print STDERR "Calling method: $cfilename:$cline $cpackage->$csubr\n";
|
---|
| 64 |
|
---|
| 65 | # If first_file is not null or empty, then add it back into the list
|
---|
| 66 | if (defined $first_file && $first_file =~ /\S/) {
|
---|
| 67 | unshift(@filenames, $first_file);
|
---|
| 68 | }
|
---|
| 69 |
|
---|
| 70 | my $filename = join("/", @filenames);
|
---|
| 71 |
|
---|
| 72 | # remove duplicate slashes and remove the last slash
|
---|
| 73 | if ($ENV{'GSDLOS'} =~ /^windows$/i) {
|
---|
| 74 | $filename =~ s/[\\\/]+/\\/g;
|
---|
| 75 | } else {
|
---|
| 76 | $filename =~ s/[\/]+/\//g;
|
---|
| 77 | # DB: want a filename abc\de.html to remain like this
|
---|
| 78 | }
|
---|
| 79 | $filename =~ s/[\\\/]$//;
|
---|
| 80 |
|
---|
| 81 | return $filename;
|
---|
| 82 | }
|
---|
| 83 | ## filenameConcatenate()
|
---|
| 84 |
|
---|
| 85 |
|
---|
| 86 | ## @function fileSize()
|
---|
| 87 | #
|
---|
| 88 | sub fileSize
|
---|
| 89 | {
|
---|
| 90 | my ($filename_full_path) = @_;
|
---|
| 91 | return -s $filename_full_path;
|
---|
| 92 | }
|
---|
| 93 | ## fileStatus()
|
---|
| 94 |
|
---|
| 95 |
|
---|
| 96 | ## @function fileTest()
|
---|
| 97 | #
|
---|
| 98 | sub fileTest
|
---|
| 99 | {
|
---|
| 100 | my $filename_full_path = shift(@_);
|
---|
| 101 | # By default tests for existance of file or directory (-e)
|
---|
| 102 | # Can be made more specific by providing second parameter (e.g. -f or -d)
|
---|
| 103 | my $test_op = shift(@_) || '-e';
|
---|
| 104 |
|
---|
| 105 | my $exists = 0;
|
---|
| 106 |
|
---|
| 107 | if ($ENV{'GSDLOS'} =~ m/^windows$/i) {
|
---|
| 108 | require Win32;
|
---|
| 109 | my $filename_short_path = Win32::GetShortPathName($filename_full_path);
|
---|
| 110 | if (!defined $filename_short_path) {
|
---|
| 111 | # Was probably still in UTF8 form (not what is needed on Windows)
|
---|
| 112 | my $unicode_filename_full_path = eval "decode(\"utf8\",\$filename_full_path)";
|
---|
| 113 | if (defined $unicode_filename_full_path) {
|
---|
| 114 | $filename_short_path = Win32::GetShortPathName($unicode_filename_full_path);
|
---|
| 115 | }
|
---|
| 116 | }
|
---|
| 117 | $filename_full_path = $filename_short_path;
|
---|
| 118 | }
|
---|
| 119 |
|
---|
| 120 | if (defined $filename_full_path) {
|
---|
| 121 | $exists = eval "($test_op \$filename_full_path)";
|
---|
| 122 | }
|
---|
| 123 |
|
---|
| 124 | # The eval may result in exists being undefined, but we need to return
|
---|
| 125 | # something
|
---|
| 126 | return ($exists || 0);
|
---|
| 127 | }
|
---|
| 128 | ## fileTest()
|
---|
| 129 |
|
---|
| 130 |
|
---|
[27422] | 131 | ## @function isFilenameAbsolute()
|
---|
| 132 | #
|
---|
| 133 | sub isFilenameAbsolute
|
---|
| 134 | {
|
---|
| 135 | my ($filename) = @_;
|
---|
| 136 | if ($ENV{'GSDLOS'} =~ /^windows$/i)
|
---|
| 137 | {
|
---|
| 138 | return ($filename =~ m/^(\w:)?\\/);
|
---|
| 139 | }
|
---|
| 140 | return ($filename =~ m/^\//);
|
---|
| 141 | }
|
---|
| 142 | # isFilenameAbsolute()
|
---|
| 143 |
|
---|
| 144 |
|
---|
[27386] | 145 | ## @function linkFile()
|
---|
| 146 | #
|
---|
| 147 | sub linkFile
|
---|
| 148 | {
|
---|
| 149 | my ($mode, $src, $dest, $ensure_paths_absolute) = @_;
|
---|
| 150 |
|
---|
| 151 | # remove trailing slashes from source and destination files
|
---|
| 152 | $src =~ s/[\\\/]+$//;
|
---|
| 153 | $dest =~ s/[\\\/]+$//;
|
---|
| 154 |
|
---|
| 155 | # Ensure file paths are absolute IF requested to do so
|
---|
| 156 | # Soft_linking didn't work for relative paths
|
---|
| 157 | if($mode eq 'HARD' || (defined $ensure_paths_absolute && $ensure_paths_absolute))
|
---|
| 158 | {
|
---|
| 159 | # We need to ensure that the src file is the absolute path
|
---|
| 160 | # See http://perldoc.perl.org/File/Spec.html
|
---|
| 161 | if(!File::Spec->file_name_is_absolute( $src ))
|
---|
| 162 | {
|
---|
| 163 | # it's relative
|
---|
| 164 | $src = File::Spec->rel2abs($src); # make absolute
|
---|
| 165 | }
|
---|
| 166 | # Might as well ensure that the destination file's absolute path is used
|
---|
| 167 | if(!File::Spec->file_name_is_absolute( $dest ))
|
---|
| 168 | {
|
---|
| 169 | $dest = File::Spec->rel2abs($dest); # make absolute
|
---|
| 170 | }
|
---|
| 171 | }
|
---|
| 172 |
|
---|
| 173 | # a few sanity checks
|
---|
| 174 | if (!-e $src)
|
---|
| 175 | {
|
---|
| 176 | &FileUtils::printError('Source file does not exist: ' . $src);
|
---|
| 177 | return 0;
|
---|
| 178 | }
|
---|
| 179 |
|
---|
| 180 | my $dest_dir = &File::Basename::dirname($dest);
|
---|
| 181 | if (!-e $dest_dir)
|
---|
| 182 | {
|
---|
| 183 | &makeAllDirectories($dest_dir);
|
---|
| 184 | }
|
---|
| 185 |
|
---|
| 186 | if ($ENV{'GSDLOS'} =~ /^windows$/i)
|
---|
| 187 | {
|
---|
| 188 | # symlink not supported on windows
|
---|
| 189 | &FileUtils::printWarning('Symlink not supported on windows');
|
---|
| 190 | }
|
---|
| 191 | elsif ($mode eq 'HARD')
|
---|
| 192 | {
|
---|
| 193 | if (!eval {link($src, $dest)})
|
---|
| 194 | {
|
---|
| 195 | &FileUtils::printWarning('Unable to create hard link: ' . $dest);
|
---|
| 196 | }
|
---|
| 197 | }
|
---|
| 198 | elsif ($mode eq 'SOFT')
|
---|
| 199 | {
|
---|
| 200 | if (!eval {symlink($src, $dest)})
|
---|
| 201 | {
|
---|
| 202 | &FileUtils::printWarning('Unable to create soft link: ' . $src);
|
---|
| 203 | }
|
---|
| 204 | }
|
---|
| 205 | else
|
---|
| 206 | {
|
---|
| 207 | &FileUtils::printError('Unknown mode requested: ' . $mode);
|
---|
| 208 | }
|
---|
| 209 | if (!-e $dest)
|
---|
| 210 | {
|
---|
| 211 | &_printWarning('linkFile', 'Link failed. Attempting to copy instead.');
|
---|
| 212 | &File::Copy::copy ($src, $dest);
|
---|
| 213 | }
|
---|
| 214 | return (-e $dest);
|
---|
| 215 | }
|
---|
| 216 | # /** linkFile() **/
|
---|
| 217 |
|
---|
| 218 | ## @function makeAllDirectories()
|
---|
| 219 | #
|
---|
| 220 | # in case anyone cares - I did some testing (using perls Benchmark module)
|
---|
| 221 | # on this subroutine against File::Path::mkpath (). mk_all_dir() is apparently
|
---|
| 222 | # slightly faster (surprisingly) - Stefan.
|
---|
| 223 | #
|
---|
| 224 | sub makeAllDirectories
|
---|
| 225 | {
|
---|
| 226 | my ($dir) = @_;
|
---|
| 227 |
|
---|
| 228 | # use / for the directory separator, remove duplicate and
|
---|
| 229 | # trailing slashes
|
---|
| 230 | $dir=~s/[\\\/]+/\//g;
|
---|
| 231 | $dir=~s/[\\\/]+$//;
|
---|
| 232 |
|
---|
| 233 | # ensure the directory doesn't already exist
|
---|
| 234 | if (-e $dir)
|
---|
| 235 | {
|
---|
| 236 | return 0;
|
---|
| 237 | }
|
---|
| 238 |
|
---|
| 239 | # make sure the cache directory exists
|
---|
| 240 | my $dirsofar = "";
|
---|
| 241 | my $first = 1;
|
---|
| 242 | foreach my $dirname (split ("/", $dir))
|
---|
| 243 | {
|
---|
| 244 | $dirsofar .= "/" unless $first;
|
---|
| 245 | $first = 0;
|
---|
| 246 |
|
---|
| 247 | $dirsofar .= $dirname;
|
---|
| 248 |
|
---|
| 249 | next if $dirname =~ /^(|[a-z]:)$/i;
|
---|
| 250 | if (!-e $dirsofar)
|
---|
| 251 | {
|
---|
| 252 | my $store_umask = umask(0002);
|
---|
| 253 | my $mkdir_ok = mkdir ($dirsofar, 0777);
|
---|
| 254 | umask($store_umask);
|
---|
| 255 | if (!$mkdir_ok)
|
---|
| 256 | {
|
---|
| 257 | &FileUtils::printError('Could not create directory: ' . $dirsofar);
|
---|
| 258 | return 0;
|
---|
| 259 | }
|
---|
| 260 | }
|
---|
| 261 | }
|
---|
| 262 | return (-e $dir);
|
---|
| 263 | }
|
---|
| 264 | ## makeAllDirectories()
|
---|
| 265 |
|
---|
| 266 |
|
---|
| 267 | ## @function makeDirectory()
|
---|
| 268 | #
|
---|
| 269 | sub makeDirectory
|
---|
| 270 | {
|
---|
| 271 | my $dir = shift(@_);
|
---|
| 272 | my $store_umask = umask(0002);
|
---|
| 273 | my $mkdir_ok = mkdir ($dir, 0777);
|
---|
| 274 | umask($store_umask);
|
---|
| 275 | return $mkdir_ok;
|
---|
| 276 | }
|
---|
| 277 | ## makeDirectory()
|
---|
| 278 |
|
---|
| 279 |
|
---|
| 280 | ## @function modificationTime()
|
---|
| 281 | #
|
---|
| 282 | sub modificationTime
|
---|
| 283 | {
|
---|
| 284 | my $path = shift(@_);
|
---|
| 285 | my @file_status = stat($path);
|
---|
| 286 | return $file_status[9];
|
---|
| 287 | }
|
---|
| 288 | ## modificationTime()
|
---|
| 289 |
|
---|
| 290 | ## @function openFileHandle()
|
---|
| 291 | #
|
---|
| 292 | sub openFileHandle
|
---|
| 293 | {
|
---|
| 294 | my $path = shift(@_);
|
---|
| 295 | my $mode = shift(@_);
|
---|
| 296 | my $fh_ref = shift(@_);
|
---|
| 297 | my $encoding = shift(@_);
|
---|
| 298 | my $mode_symbol;
|
---|
| 299 | if ($mode eq 'w' || $mode eq '>')
|
---|
| 300 | {
|
---|
| 301 | $mode_symbol = '>';
|
---|
| 302 | $mode = 'writing';
|
---|
| 303 | }
|
---|
| 304 | elsif ($mode eq 'a' || $mode eq '>>')
|
---|
| 305 | {
|
---|
| 306 | $mode_symbol = '>>';
|
---|
| 307 | $mode = 'appending';
|
---|
| 308 | }
|
---|
| 309 | else
|
---|
| 310 | {
|
---|
| 311 | $mode_symbol = '<';
|
---|
| 312 | $mode = 'reading';
|
---|
| 313 | }
|
---|
| 314 | if (defined $encoding)
|
---|
| 315 | {
|
---|
| 316 | $mode_symbol .= ':' . $encoding;
|
---|
| 317 | }
|
---|
| 318 | if (!open($$fh_ref, $mode_symbol, $path))
|
---|
| 319 | {
|
---|
| 320 | &FileUtils::printError('Failed to open file for ' . $mode . ': ' . $path, 1);
|
---|
| 321 | }
|
---|
| 322 | return 1;
|
---|
| 323 | }
|
---|
| 324 | ## openFileHandle()
|
---|
| 325 |
|
---|
| 326 | # /**
|
---|
| 327 | # */
|
---|
| 328 | sub readDirectory
|
---|
| 329 | {
|
---|
| 330 | my $path = shift(@_);
|
---|
| 331 | opendir(DH, $path) or &FileUtils::printError('Failed to open directory for reading: ' . $path, 1);
|
---|
| 332 | my @files = readdir(DH);
|
---|
| 333 | close(DH);
|
---|
| 334 | return \@files;
|
---|
| 335 | }
|
---|
| 336 | # /** readDirectory() **/
|
---|
| 337 |
|
---|
| 338 |
|
---|
| 339 | ## @function removeFiles()
|
---|
| 340 | #
|
---|
| 341 | sub removeFiles
|
---|
| 342 | {
|
---|
| 343 | my $file = shift(@_);
|
---|
| 344 | my $result = 0;
|
---|
| 345 | if (!-e $file && !-l $file)
|
---|
| 346 | {
|
---|
| 347 | &FileUtils::printError('File does not exist: ' . $file);
|
---|
| 348 | }
|
---|
| 349 | elsif ((!-f $file) && (!-l $file))
|
---|
| 350 | {
|
---|
| 351 | &FileUtils::printError('Not a regular file: ' . $file);
|
---|
| 352 | }
|
---|
| 353 | else
|
---|
| 354 | {
|
---|
| 355 | $result = unlink($file);
|
---|
| 356 | if (!$result)
|
---|
| 357 | {
|
---|
| 358 | &FileUtils::printError('Failed to remove file: ' . $file);
|
---|
| 359 | }
|
---|
| 360 | }
|
---|
| 361 | return $result;
|
---|
| 362 | }
|
---|
| 363 | ## removeFiles()
|
---|
| 364 |
|
---|
| 365 |
|
---|
| 366 | ## @function removeFilesFiltered()
|
---|
| 367 | #
|
---|
| 368 | # recursive removal
|
---|
| 369 | #
|
---|
| 370 | sub removeFilesFiltered
|
---|
| 371 | {
|
---|
| 372 | my ($files, $file_accept_re, $file_reject_re) = @_;
|
---|
| 373 | # my ($cpackage,$cfilename,$cline,$csubr,$chas_args,$cwantarray) = caller(2);
|
---|
| 374 | # my ($lcfilename) = ($cfilename =~ m/([^\\\/]*)$/);
|
---|
| 375 | # print STDERR "** Calling method (2): $lcfilename:$cline $cpackage->$csubr\n";
|
---|
| 376 | my @files_array = (ref $files eq "ARRAY") ? @$files : ($files);
|
---|
| 377 |
|
---|
| 378 | my $num_removed = 0;
|
---|
| 379 |
|
---|
| 380 | foreach my $file (@files_array)
|
---|
| 381 | {
|
---|
| 382 | # remove trailing slashes
|
---|
| 383 | $file =~ s/[\/\\]+$//;
|
---|
| 384 |
|
---|
| 385 | if (!-e $file)
|
---|
| 386 | {
|
---|
| 387 | print STDERR "util::filtered_rm_r $file does not exist\n";
|
---|
| 388 | }
|
---|
| 389 | # don't recurse down symbolic link
|
---|
| 390 | elsif ((-d $file) && (!-l $file))
|
---|
| 391 | {
|
---|
| 392 | # get the contents of this directory
|
---|
| 393 | if (!opendir (INDIR, $file))
|
---|
| 394 | {
|
---|
| 395 | print STDERR "util::filtered_rm_r could not open directory $file\n";
|
---|
| 396 | }
|
---|
| 397 | else
|
---|
| 398 | {
|
---|
| 399 | my @filedir = grep (!/^\.\.?$/, readdir (INDIR));
|
---|
| 400 | closedir (INDIR);
|
---|
| 401 |
|
---|
| 402 | # remove all the files in this directory
|
---|
| 403 | map {$_="$file/$_";} @filedir;
|
---|
| 404 | $num_removed += &FileUtils::LocalFS::removeFilesFiltered(\@filedir, $file_accept_re, $file_reject_re);
|
---|
| 405 |
|
---|
| 406 | if (!defined $file_accept_re && !defined $file_reject_re)
|
---|
| 407 | {
|
---|
| 408 | # remove this directory
|
---|
| 409 | if (!rmdir $file)
|
---|
| 410 | {
|
---|
| 411 | print STDERR "util::filtered_rm_r couldn't remove directory $file\n";
|
---|
| 412 | }
|
---|
| 413 | else
|
---|
| 414 | {
|
---|
| 415 | $num_removed++;
|
---|
| 416 | }
|
---|
| 417 | }
|
---|
| 418 | }
|
---|
| 419 | }
|
---|
| 420 | else
|
---|
| 421 | {
|
---|
| 422 | next if (defined $file_reject_re && ($file =~ m/$file_reject_re/));
|
---|
| 423 |
|
---|
| 424 | if ((!defined $file_accept_re) || ($file =~ m/$file_accept_re/))
|
---|
| 425 | {
|
---|
| 426 | # remove this file
|
---|
| 427 | $num_removed += &removeFiles($file);
|
---|
| 428 | }
|
---|
| 429 | }
|
---|
| 430 | }
|
---|
| 431 | return $num_removed;
|
---|
| 432 | }
|
---|
| 433 | ## removeFilesFiltered()
|
---|
| 434 |
|
---|
| 435 |
|
---|
| 436 | ## @function removeFilesRecursive()
|
---|
| 437 | #
|
---|
| 438 | sub removeFilesRecursive
|
---|
| 439 | {
|
---|
| 440 | my $path = shift(@_);
|
---|
| 441 | # use the more general (but reterospectively written filteredRemove()
|
---|
| 442 | # function with no accept or reject expressions
|
---|
| 443 | return FileUtils::LocalFS::removeFilesFiltered($path, undef, undef);
|
---|
| 444 | }
|
---|
| 445 | ## removeFilesRecursive()
|
---|
| 446 |
|
---|
| 447 |
|
---|
| 448 | ## @function supportsSymbolicLink
|
---|
| 449 | #
|
---|
| 450 | sub supportsSymbolicLink
|
---|
| 451 | {
|
---|
| 452 | return 1;
|
---|
| 453 | }
|
---|
| 454 | ## supportsSymbolicLink()
|
---|
| 455 |
|
---|
| 456 |
|
---|
| 457 | ## @function synchronizeDirectory()
|
---|
| 458 | #
|
---|
| 459 | # updates a copy of a directory in some other part of the filesystem
|
---|
| 460 | # verbosity settings are: 0=low, 1=normal, 2=high
|
---|
| 461 | # both $fromdir and $todir should be absolute paths
|
---|
| 462 | #
|
---|
| 463 | sub synchronizeDirectory
|
---|
| 464 | {
|
---|
| 465 | my ($fromdir, $todir, $verbosity) = @_;
|
---|
| 466 | $verbosity = 1 unless defined $verbosity;
|
---|
| 467 |
|
---|
| 468 | # use / for the directory separator, remove duplicate and
|
---|
| 469 | # trailing slashes
|
---|
| 470 | $fromdir=~s/[\\\/]+/\//g;
|
---|
| 471 | $fromdir=~s/[\\\/]+$//;
|
---|
| 472 | $todir=~s/[\\\/]+/\//g;
|
---|
| 473 | $todir=~s/[\\\/]+$//;
|
---|
| 474 |
|
---|
| 475 | &mk_all_dir ($todir);
|
---|
| 476 |
|
---|
| 477 | # get the directories in ascending order
|
---|
| 478 | if (!opendir (FROMDIR, $fromdir))
|
---|
| 479 | {
|
---|
| 480 | print STDERR "util::cachedir could not read directory $fromdir\n";
|
---|
| 481 | return;
|
---|
| 482 | }
|
---|
| 483 | my @fromdir = grep (!/^\.\.?$/, sort(readdir (FROMDIR)));
|
---|
| 484 | closedir (FROMDIR);
|
---|
| 485 |
|
---|
| 486 | if (!opendir (TODIR, $todir))
|
---|
| 487 | {
|
---|
| 488 | print STDERR "util::cacedir could not read directory $todir\n";
|
---|
| 489 | return;
|
---|
| 490 | }
|
---|
| 491 | my @todir = grep (!/^\.\.?$/, sort(readdir (TODIR)));
|
---|
| 492 | closedir (TODIR);
|
---|
| 493 |
|
---|
| 494 | my $fromi = 0;
|
---|
| 495 | my $toi = 0;
|
---|
| 496 |
|
---|
| 497 | while ($fromi < scalar(@fromdir) || $toi < scalar(@todir))
|
---|
| 498 | {
|
---|
| 499 | # print "fromi: $fromi toi: $toi\n";
|
---|
| 500 |
|
---|
| 501 | # see if we should delete a file/directory
|
---|
| 502 | # this should happen if the file/directory
|
---|
| 503 | # is not in the from list or if its a different
|
---|
| 504 | # size, or has an older timestamp
|
---|
| 505 | if ($toi < scalar(@todir))
|
---|
| 506 | {
|
---|
| 507 | if (($fromi >= scalar(@fromdir)) ||
|
---|
| 508 | ($todir[$toi] lt $fromdir[$fromi] ||
|
---|
| 509 | ($todir[$toi] eq $fromdir[$fromi] &&
|
---|
| 510 | &differentfiles("$fromdir/$fromdir[$fromi]","$todir/$todir[$toi]",
|
---|
| 511 | $verbosity))))
|
---|
| 512 | {
|
---|
| 513 | # the files are different
|
---|
| 514 | &rm_r("$todir/$todir[$toi]");
|
---|
| 515 | splice(@todir, $toi, 1); # $toi stays the same
|
---|
| 516 | }
|
---|
| 517 | elsif ($todir[$toi] eq $fromdir[$fromi])
|
---|
| 518 | {
|
---|
| 519 | # the files are the same
|
---|
| 520 | # if it is a directory, check its contents
|
---|
| 521 | if (-d "$todir/$todir[$toi]")
|
---|
| 522 | {
|
---|
| 523 | &synchronizeDirectory("$fromdir/$fromdir[$fromi]", "$todir/$todir[$toi]", $verbosity);
|
---|
| 524 | }
|
---|
| 525 |
|
---|
| 526 | $toi++;
|
---|
| 527 | $fromi++;
|
---|
| 528 | next;
|
---|
| 529 | }
|
---|
| 530 | }
|
---|
| 531 |
|
---|
| 532 | # see if we should insert a file/directory
|
---|
| 533 | # we should insert a file/directory if there
|
---|
| 534 | # is no tofiles left or if the tofile does not exist
|
---|
| 535 | if ($fromi < scalar(@fromdir) && ($toi >= scalar(@todir) ||
|
---|
| 536 | $todir[$toi] gt $fromdir[$fromi]))
|
---|
| 537 | {
|
---|
| 538 | &cp_r ("$fromdir/$fromdir[$fromi]", "$todir/$fromdir[$fromi]");
|
---|
| 539 | splice (@todir, $toi, 0, $fromdir[$fromi]);
|
---|
| 540 | $toi++;
|
---|
| 541 | $fromi++;
|
---|
| 542 | }
|
---|
| 543 | }
|
---|
| 544 | }
|
---|
| 545 | ## synchronizeDirectory()
|
---|
| 546 |
|
---|
| 547 |
|
---|
| 548 | # /**
|
---|
| 549 | # */
|
---|
| 550 | sub transferFile
|
---|
| 551 | {
|
---|
| 552 | my ($mode, $file, $dest) = @_;
|
---|
| 553 | # remove trailing slashes from source and destination files
|
---|
| 554 | $file =~ s/[\\\/]+$//;
|
---|
| 555 | $dest =~ s/[\\\/]+$//;
|
---|
| 556 | my $tempdest = $dest;
|
---|
| 557 | if (!-e $file)
|
---|
| 558 | {
|
---|
| 559 | &FileUtils::printError('File does not exist: ' . $file);
|
---|
| 560 | }
|
---|
| 561 | else
|
---|
| 562 | {
|
---|
| 563 | if (-d $tempdest)
|
---|
| 564 | {
|
---|
| 565 | my ($filename) = $file =~ /([^\\\/]+)$/;
|
---|
| 566 | $tempdest .= "/$filename";
|
---|
| 567 | }
|
---|
| 568 | # start by processing any move request
|
---|
| 569 | if ($mode eq 'MOVE')
|
---|
| 570 | {
|
---|
| 571 | &File::Copy::move($file, $tempdest);
|
---|
| 572 | }
|
---|
| 573 | # now if we were instead doing a copy, or if the move request above failed
|
---|
| 574 | # for some reason, we process a copy request
|
---|
| 575 | if ($mode eq 'COPY' || !-e $tempdest)
|
---|
| 576 | {
|
---|
| 577 | &File::Copy::copy($file, $tempdest);
|
---|
| 578 | }
|
---|
| 579 | # finally, we check if a successful move command has somehow left the origin
|
---|
| 580 | # file lying around (rename partially succeeded - for instance when moving
|
---|
| 581 | # hardlinks)
|
---|
| 582 | if ($mode eq 'MOVE' && -e $tempdest && -e $file)
|
---|
| 583 | {
|
---|
| 584 | unlink($file);
|
---|
| 585 | }
|
---|
| 586 | }
|
---|
| 587 | # Have we successfully moved the file?
|
---|
| 588 | my $result = 0;
|
---|
| 589 | if (-e $tempdest)
|
---|
| 590 | {
|
---|
| 591 | if ($mode eq 'MOVE')
|
---|
| 592 | {
|
---|
| 593 | if (-e $file)
|
---|
| 594 | {
|
---|
| 595 | &FileUtils::printError('Failed to remove original file during move: ' . $file);
|
---|
| 596 | }
|
---|
| 597 | else
|
---|
| 598 | {
|
---|
| 599 | $result = 1;
|
---|
| 600 | }
|
---|
| 601 | }
|
---|
| 602 | else
|
---|
| 603 | {
|
---|
| 604 | $result = 1;
|
---|
| 605 | }
|
---|
| 606 | }
|
---|
| 607 | else
|
---|
| 608 | {
|
---|
| 609 | &FileUtils::printError('Failed to move/copy file: ' . $file);
|
---|
| 610 | }
|
---|
| 611 | return $result;
|
---|
| 612 | }
|
---|
| 613 | # /** moveFile() **/
|
---|
| 614 |
|
---|
| 615 | 1;
|
---|