Changeset 27303 for main/trunk/greenstone2/perllib/util.pm
- Timestamp:
- 2013-05-06T15:23:45+12:00 (11 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
main/trunk/greenstone2/perllib/util.pm
r26976 r27303 35 35 # $^X works better in some cases to return the path to perl used to launch the script, 36 36 # but if launched with plain "perl" (no full-path), that will be just what it returns. 37 use Config; 37 use Config; 38 # New module for file related utility functions - intended as a 39 # placeholder for an extension that allows a variety of different 40 # filesystems (FTP, HTTP, SAMBA, WEBDav, HDFS etc) 41 use FileUtils; 38 42 39 43 # removes files (but not directories) 40 44 sub rm { 41 my (@files) = @_; 42 43 my @filefiles = (); 44 45 # make sure the files we want to delete exist 46 # and are regular files 47 foreach my $file (@files) { 48 if (!-e $file) { 49 print STDERR "util::rm $file does not exist\n"; 50 } elsif ((!-f $file) && (!-l $file)) { 51 print STDERR "util::rm $file is not a regular (or symbolic) file\n"; 52 } else { 53 push (@filefiles, $file); 54 } 55 } 56 57 # remove the files 58 my $numremoved = unlink @filefiles; 59 60 # check to make sure all of them were removed 61 if ($numremoved != scalar(@filefiles)) { 62 print STDERR "util::rm Not all files were removed\n"; 63 } 64 } 65 66 # removes files (but not directories) - can rename this to the default 67 # "rm" subroutine when debugging the deletion of individual files. 68 sub rm_debug { 69 my (@files) = @_; 70 my @filefiles = (); 71 72 # make sure the files we want to delete exist 73 # and are regular files 74 foreach my $file (@files) { 75 if (!-e $file) { 76 print STDERR "util::rm $file does not exist\n"; 77 } elsif ((!-f $file) && (!-l $file)) { 78 print STDERR "util::rm $file is not a regular (or symbolic) file\n"; 79 } else { # debug message 80 unlink($file) or warn "Could not delete file $file: $!\n"; 81 } 82 } 83 } 84 45 warnings::warnif("deprecated", "util::rm() is deprecated, using FileUtils::removeFiles() instead"); 46 return &FileUtils::removeFiles(@_); 47 } 85 48 86 49 # recursive removal 87 50 sub filtered_rm_r { 88 my ($files,$file_accept_re,$file_reject_re) = @_; 89 90 # my ($cpackage,$cfilename,$cline,$csubr,$chas_args,$cwantarray) = caller(2); 91 # my ($lcfilename) = ($cfilename =~ m/([^\\\/]*)$/); 92 # print STDERR "** Calling method (2): $lcfilename:$cline $cpackage->$csubr\n"; 93 94 my @files_array = (ref $files eq "ARRAY") ? @$files : ($files); 95 96 # recursively remove the files 97 foreach my $file (@files_array) { 98 $file =~ s/[\/\\]+$//; # remove trailing slashes 99 100 if (!-e $file) { 101 print STDERR "util::filtered_rm_r $file does not exist\n"; 102 103 } elsif ((-d $file) && (!-l $file)) { # don't recurse down symbolic link 104 # get the contents of this directory 105 if (!opendir (INDIR, $file)) { 106 print STDERR "util::filtered_rm_r could not open directory $file\n"; 107 } else { 108 my @filedir = grep (!/^\.\.?$/, readdir (INDIR)); 109 closedir (INDIR); 110 111 # remove all the files in this directory 112 map {$_="$file/$_";} @filedir; 113 &filtered_rm_r (\@filedir,$file_accept_re,$file_reject_re); 114 115 if (!defined $file_accept_re && !defined $file_reject_re) { 116 # remove this directory 117 if (!rmdir $file) { 118 print STDERR "util::filtered_rm_r couldn't remove directory $file\n"; 119 } 120 } 121 } 122 } else { 123 next if (defined $file_reject_re && ($file =~ m/$file_reject_re/)); 124 125 if ((!defined $file_accept_re) || ($file =~ m/$file_accept_re/)) { 126 # remove this file 127 &rm ($file); 128 } 129 } 130 } 131 } 132 51 warnings::warnif("deprecated", "util::filtered_rm_r() is deprecated, using FileUtils::removeFilesFiltered() instead"); 52 return &FileUtils::removeFilesFiltered(@_); 53 } 133 54 134 55 # recursive removal 135 56 sub rm_r { 136 my (@files) = @_; 137 138 # use the more general (but reterospectively written function 139 # filtered_rm_r function() 140 141 filtered_rm_r(\@files,undef,undef); # no accept or reject expressions 142 } 143 144 145 57 warnings::warnif("deprecated", "util::rm_r() is deprecated, using FileUtils::recursiveRemoveFiles() instead"); 58 return &FileUtils::removeFilesRecursive(@_); 59 } 146 60 147 61 # moves a file or a group of files 148 62 sub mv { 149 my $dest = pop (@_); 150 my (@srcfiles) = @_; 151 152 # remove trailing slashes from source and destination files 153 $dest =~ s/[\\\/]+$//; 154 map {$_ =~ s/[\\\/]+$//;} @srcfiles; 155 156 # a few sanity checks 157 if (scalar (@srcfiles) == 0) { 158 print STDERR "util::mv no destination directory given\n"; 159 return; 160 } elsif ((scalar (@srcfiles) > 1) && (!-d $dest)) { 161 print STDERR "util::mv if multiple source files are given the ". 162 "destination must be a directory\n"; 163 return; 164 } 165 166 # move the files 167 foreach my $file (@srcfiles) { 168 my $tempdest = $dest; 169 if (-d $tempdest) { 170 my ($filename) = $file =~ /([^\\\/]+)$/; 171 $tempdest .= "/$filename"; 172 } 173 if (!-e $file) { 174 print STDERR "util::mv $file does not exist\n"; 175 } else { 176 if(!rename ($file, $tempdest)) { 177 print STDERR "**** Failed to rename $file to $tempdest\n"; 178 &File::Copy::copy($file, $tempdest); 179 &rm($file); 180 } 181 elsif(-e $file) { # rename (partially) succeeded) but srcfile still exists after rename 182 #print STDERR "*** srcfile $file still exists after rename to $tempdest\n"; 183 if(!-e $tempdest) { 184 print STDERR "@@@@ ERROR: $tempdest does not exist\n"; 185 } 186 # Sometimes the rename operation fails (as does File::Copy::move). 187 # This turns out to be because the files are hardlinked. 188 # Need to do a copy-delete in this case, however, the copy step is not necessary: 189 # the srcfile got renamed into tempdest, but srcfile itself still exists, delete it. 190 #&File::Copy::copy($file, $tempdest); 191 192 &rm($file); 193 } 194 } 195 } 63 warnings::warnif("deprecated", "util::mv() is deprecated, using FileUtils::moveFiles() instead"); 64 return &FileUtils::moveFiles(@_); 196 65 } 197 66 … … 201 70 # but other files and folders in the target will continue to exist 202 71 sub mv_dir_contents { 203 my ($src_dir, $dest_dir) = @_; 204 205 # Obtain listing of all files within src_dir 206 # Note that readdir lists relative paths, as well as . and .. 207 opendir(DIR, "$src_dir"); 208 my @files= readdir(DIR); 209 close(DIR); 210 211 my @full_path_files = (); 212 foreach my $file (@files) { 213 # process all except . and .. 214 unless($file eq "." || $file eq "..") { 215 216 my $dest_subdir = &filename_cat($dest_dir, $file); # $file is still a relative path 217 218 # construct absolute paths 219 $file = &filename_cat($src_dir, $file); # $file is now an absolute path 220 221 # Recurse on directories which have an equivalent in target dest_dir 222 # If $file is a directory that already exists in target $dest_dir, 223 # then a simple move operation will fail (definitely on Windows). 224 if(-d $file && -d $dest_subdir) { 225 #print STDERR "**** $file is a directory also existing in target, its contents to be copied to $dest_subdir\n"; 226 &mv_dir_contents($file, $dest_subdir); 227 228 # now all content is moved across, delete empty dir in source folder 229 if(&is_dir_empty($file)) { 230 if (!rmdir $file) { 231 print STDERR "ERROR. util::mv_dir_contents couldn't remove directory $file\n"; 232 } 233 } else { # error 234 print STDERR "ERROR. util::mv_dir_contents: subfolder $file still non-empty after moving contents to $dest_subdir\n"; 235 } 236 } else { # process files and any directories that don't already exist with a simple move 237 push(@full_path_files, $file); 238 } 239 } 240 } 241 242 if(!&dir_exists($dest_dir)) { # create target toplevel folder or subfolders if they don't exist 243 &mk_dir($dest_dir); 244 } 245 246 #print STDERR "@@@@@ Copying files |".join(",", @full_path_files)."| to: $dest_dir\n"; 247 248 if(@full_path_files) { # if non-empty, there's something to copy across 249 &mv(@full_path_files, $dest_dir); 250 } 251 } 252 72 warnings::warnif("deprecated", "util::mv_dir_contents() is deprecated, using FileUtils::moveDirectoryContents() instead"); 73 return &FileUtils::moveDirectoryContents(@_); 74 } 253 75 254 76 # copies a file or a group of files 255 77 sub cp { 256 my $dest = pop (@_); 257 my (@srcfiles) = @_; 258 259 # remove trailing slashes from source and destination files 260 $dest =~ s/[\\\/]+$//; 261 map {$_ =~ s/[\\\/]+$//;} @srcfiles; 262 263 # a few sanity checks 264 if (scalar (@srcfiles) == 0) { 265 print STDERR "util::cp no destination directory given\n"; 266 return; 267 } elsif ((scalar (@srcfiles) > 1) && (!-d $dest)) { 268 print STDERR "util::cp if multiple source files are given the ". 269 "destination must be a directory\n"; 270 return; 271 } 272 273 # copy the files 274 foreach my $file (@srcfiles) { 275 my $tempdest = $dest; 276 if (-d $tempdest) { 277 my ($filename) = $file =~ /([^\\\/]+)$/; 278 $tempdest .= "/$filename"; 279 } 280 if (!-e $file) { 281 print STDERR "util::cp $file does not exist\n"; 282 } elsif (!-f $file) { 283 print STDERR "util::cp $file is not a plain file\n"; 284 } else { 285 &File::Copy::copy ($file, $tempdest); 286 } 287 } 288 } 289 290 78 warnings::warnif("deprecated", "util::cp() is deprecated, using FileUtils::copyFiles() instead"); 79 return &FileUtils::copyFiles(@_); 80 } 291 81 292 82 # recursively copies a file or group of files … … 295 85 # another use cp instead 296 86 sub cp_r { 297 my $dest = pop (@_); 298 my (@srcfiles) = @_; 299 300 # a few sanity checks 301 if (scalar (@srcfiles) == 0) { 302 print STDERR "util::cp_r no destination directory given\n"; 303 return; 304 } elsif (-f $dest) { 305 print STDERR "util::cp_r destination must be a directory\n"; 306 return; 307 } 308 309 # create destination directory if it doesn't exist already 310 if (! -d $dest) { 311 my $store_umask = umask(0002); 312 mkdir ($dest, 0777); 313 umask($store_umask); 314 } 315 316 # copy the files 317 foreach my $file (@srcfiles) { 318 319 if (!-e $file) { 320 print STDERR "util::cp_r $file does not exist\n"; 321 322 } elsif (-d $file) { 323 # make the new directory 324 my ($filename) = $file =~ /([^\\\/]*)$/; 325 $dest = &util::filename_cat ($dest, $filename); 326 my $store_umask = umask(0002); 327 mkdir ($dest, 0777); 328 umask($store_umask); 329 330 # get the contents of this directory 331 if (!opendir (INDIR, $file)) { 332 print STDERR "util::cp_r could not open directory $file\n"; 333 } else { 334 my @filedir = readdir (INDIR); 335 closedir (INDIR); 336 foreach my $f (@filedir) { 337 next if $f =~ /^\.\.?$/; 338 # copy all the files in this directory 339 my $ff = &util::filename_cat ($file, $f); 340 &cp_r ($ff, $dest); 341 } 342 } 343 344 } else { 345 &cp($file, $dest); 346 } 347 } 348 } 87 warnings::warnif("deprecated", "util::cp_r() is deprecated, using FileUtils::copyFilesrecursive() instead"); 88 return &FileUtils::copyFilesRecursive(@_); 89 } 90 349 91 # recursively copies a file or group of files 350 92 # syntax: cp_r (sourcefiles, destination directory) … … 352 94 # another use cp instead 353 95 sub cp_r_nosvn { 354 my $dest = pop (@_); 355 my (@srcfiles) = @_; 356 357 # a few sanity checks 358 if (scalar (@srcfiles) == 0) { 359 print STDERR "util::cp_r no destination directory given\n"; 360 return; 361 } elsif (-f $dest) { 362 print STDERR "util::cp_r destination must be a directory\n"; 363 return; 364 } 365 366 # create destination directory if it doesn't exist already 367 if (! -d $dest) { 368 my $store_umask = umask(0002); 369 mkdir ($dest, 0777); 370 umask($store_umask); 371 } 372 373 # copy the files 374 foreach my $file (@srcfiles) { 375 376 if (!-e $file) { 377 print STDERR "util::cp_r $file does not exist\n"; 378 379 } elsif (-d $file) { 380 # make the new directory 381 my ($filename) = $file =~ /([^\\\/]*)$/; 382 $dest = &util::filename_cat ($dest, $filename); 383 my $store_umask = umask(0002); 384 mkdir ($dest, 0777); 385 umask($store_umask); 386 387 # get the contents of this directory 388 if (!opendir (INDIR, $file)) { 389 print STDERR "util::cp_r could not open directory $file\n"; 390 } else { 391 my @filedir = readdir (INDIR); 392 closedir (INDIR); 393 foreach my $f (@filedir) { 394 next if $f =~ /^\.\.?$/; 395 next if $f =~ /^\.svn$/; 396 # copy all the files in this directory 397 my $ff = &util::filename_cat ($file, $f); 398 &cp_r ($ff, $dest); 399 } 400 } 401 402 } else { 403 &cp($file, $dest); 404 } 405 } 96 warnings::warnif("deprecated", "util::cp_r_nosvn() is deprecated, using FileUtils::copyFilesRecursiveNoSVN() instead"); 97 return &FileUtils::copyFilesRecursiveNoSVN(@_); 406 98 } 407 99 408 100 # copies a directory and its contents, excluding subdirectories, into a new directory 409 101 sub cp_r_toplevel { 410 my $dest = pop (@_); 411 my (@srcfiles) = @_; 412 413 # a few sanity checks 414 if (scalar (@srcfiles) == 0) { 415 print STDERR "util::cp_r no destination directory given\n"; 416 return; 417 } elsif (-f $dest) { 418 print STDERR "util::cp_r destination must be a directory\n"; 419 return; 420 } 421 422 # create destination directory if it doesn't exist already 423 if (! -d $dest) { 424 my $store_umask = umask(0002); 425 mkdir ($dest, 0777); 426 umask($store_umask); 427 } 428 429 # copy the files 430 foreach my $file (@srcfiles) { 431 432 if (!-e $file) { 433 print STDERR "util::cp_r $file does not exist\n"; 434 435 } elsif (-d $file) { 436 # make the new directory 437 my ($filename) = $file =~ /([^\\\/]*)$/; 438 $dest = &util::filename_cat ($dest, $filename); 439 my $store_umask = umask(0002); 440 mkdir ($dest, 0777); 441 umask($store_umask); 442 443 # get the contents of this directory 444 if (!opendir (INDIR, $file)) { 445 print STDERR "util::cp_r could not open directory $file\n"; 446 } else { 447 my @filedir = readdir (INDIR); 448 closedir (INDIR); 449 foreach my $f (@filedir) { 450 next if $f =~ /^\.\.?$/; 451 452 # copy all the files in this directory, but not directories 453 my $ff = &util::filename_cat ($file, $f); 454 if (-f $ff) { 455 &cp($ff, $dest); 456 #&cp_r ($ff, $dest); 457 } 458 } 459 } 460 461 } else { 462 &cp($file, $dest); 463 } 464 } 102 warnings::warnif("deprecated", "util::cp_r_toplevel() is deprecated, using FileUtils::recursiveCopyTopLevel() instead"); 103 return &FileUtils::recursiveCopyTopLevel(@_); 465 104 } 466 105 467 106 sub mk_dir { 468 my ($dir) = @_; 469 470 my $store_umask = umask(0002); 471 my $mkdir_ok = mkdir ($dir, 0777); 472 umask($store_umask); 473 474 if (!$mkdir_ok) 475 { 476 print STDERR "util::mk_dir could not create directory $dir\n"; 477 return; 478 } 107 warnings::warnif("deprecated", "util::mk_dir() is deprecated, using FileUtils::makeDirectory() instead"); 108 return &FileUtils::makeDirectory(@_); 479 109 } 480 110 … … 483 113 # slightly faster (surprisingly) - Stefan. 484 114 sub mk_all_dir { 485 my ($dir) = @_; 486 487 # use / for the directory separator, remove duplicate and 488 # trailing slashes 489 $dir=~s/[\\\/]+/\//g; 490 $dir=~s/[\\\/]+$//; 491 492 # make sure the cache directory exists 493 my $dirsofar = ""; 494 my $first = 1; 495 foreach my $dirname (split ("/", $dir)) { 496 $dirsofar .= "/" unless $first; 497 $first = 0; 498 499 $dirsofar .= $dirname; 500 501 next if $dirname =~ /^(|[a-z]:)$/i; 502 if (!-e $dirsofar) 503 { 504 my $store_umask = umask(0002); 505 my $mkdir_ok = mkdir ($dirsofar, 0777); 506 umask($store_umask); 507 if (!$mkdir_ok) 508 { 509 print STDERR "util::mk_all_dir could not create directory $dirsofar\n"; 510 return; 511 } 512 } 513 } 115 warnings::warnif("deprecated", "util::mk_all_dir() is deprecated, using FileUtils::makeAllDirectories() instead"); 116 return &FileUtils::makeAllDirectories(@_); 514 117 } 515 118 516 119 # make hard link to file if supported by OS, otherwise copy the file 517 120 sub hard_link { 518 my ($src, $dest, $verbosity) = @_; 519 520 # remove trailing slashes from source and destination files 521 $src =~ s/[\\\/]+$//; 522 $dest =~ s/[\\\/]+$//; 523 524 ## print STDERR "**** src = ", unicode::debug_unicode_string($src),"\n"; 525 # a few sanity checks 526 if (-e $dest) { 527 # destination file already exists 528 return; 529 } 530 elsif (!-e $src) { 531 print STDERR "util::hard_link source file \"$src\" does not exist\n"; 532 return 1; 533 } 534 elsif (-d $src) { 535 print STDERR "util::hard_link source \"$src\" is a directory\n"; 536 return 1; 537 } 538 539 my $dest_dir = &File::Basename::dirname($dest); 540 mk_all_dir($dest_dir) if (!-e $dest_dir); 541 542 543 if (!link($src, $dest)) { 544 if ((!defined $verbosity) || ($verbosity>2)) { 545 print STDERR "util::hard_link: unable to create hard link. "; 546 print STDERR " Copying file: $src -> $dest\n"; 547 } 548 &File::Copy::copy ($src, $dest); 549 } 550 return 0; 121 warnings::warnif("deprecated", "util::hard_link() is deprecated, using FileUtils::hardLink() instead"); 122 return &FileUtils::hardLink(@_); 551 123 } 552 124 553 125 # make soft link to file if supported by OS, otherwise copy file 554 126 sub soft_link { 555 my ($src, $dest, $ensure_paths_absolute) = @_; 556 557 # remove trailing slashes from source and destination files 558 $src =~ s/[\\\/]+$//; 559 $dest =~ s/[\\\/]+$//; 560 561 # Ensure file paths are absolute IF requested to do so 562 # Soft_linking didn't work for relative paths 563 if(defined $ensure_paths_absolute && $ensure_paths_absolute) { 564 # We need to ensure that the src file is the absolute path 565 # See http://perldoc.perl.org/File/Spec.html 566 if(!File::Spec->file_name_is_absolute( $src )) { # it's relative 567 $src = File::Spec->rel2abs($src); # make absolute 568 } 569 # Might as well ensure that the destination file's absolute path is used 570 if(!File::Spec->file_name_is_absolute( $dest )) { 571 $dest = File::Spec->rel2abs($dest); # make absolute 572 } 573 } 574 575 # a few sanity checks 576 if (!-e $src) { 577 print STDERR "util::soft_link source file $src does not exist\n"; 578 return 0; 579 } 580 581 my $dest_dir = &File::Basename::dirname($dest); 582 mk_all_dir($dest_dir) if (!-e $dest_dir); 583 584 if ($ENV{'GSDLOS'} =~ /^windows$/i) { 585 586 # symlink not supported on windows 587 &File::Copy::copy ($src, $dest); 588 589 } elsif (!eval {symlink($src, $dest)}) { 590 print STDERR "util::soft_link: unable to create soft link.\n"; 591 return 0; 592 } 593 594 return 1; 127 warnings::warnif("deprecated", "util::soft_link() is deprecated, using FileUtils::softLink() instead"); 128 return &FileUtils::softLink(@_); 595 129 } 596 130 … … 625 159 } 626 160 627 628 sub fd_exists 629 { 630 my $filename_full_path = shift @_; 631 my $test_op = shift @_ || "-e"; 632 633 # By default tests for existance of file or directory (-e) 634 # Can be made more specific by providing second parameter (e.g. -f or -d) 635 636 my $exists = 0; 637 638 if ($ENV{'GSDLOS'} =~ m/^windows$/i) { 639 require Win32; 640 my $filename_short_path = Win32::GetShortPathName($filename_full_path); 641 if (!defined $filename_short_path) { 642 # Was probably still in UTF8 form (not what is needed on Windows) 643 my $unicode_filename_full_path = eval "decode(\"utf8\",\$filename_full_path)"; 644 if (defined $unicode_filename_full_path) { 645 $filename_short_path = Win32::GetShortPathName($unicode_filename_full_path); 646 } 647 } 648 $filename_full_path = $filename_short_path; 649 } 650 651 if (defined $filename_full_path) { 652 $exists = eval "($test_op \$filename_full_path)"; 653 } 654 655 return $exists; 656 } 657 658 sub file_exists 659 { 660 my ($filename_full_path) = @_; 661 662 return fd_exists($filename_full_path,"-f"); 663 } 664 665 sub dir_exists 666 { 667 my ($filename_full_path) = @_; 668 669 return fd_exists($filename_full_path,"-d"); 670 } 671 672 161 sub fd_exists { 162 warnings::warnif("deprecated", "util::fd_exists() is deprecated, using FileUtils::fileTest() instead"); 163 return &FileUtils::fileTest(@_); 164 } 165 166 sub file_exists { 167 warnings::warnif("deprecated", "util::file_exists() is deprecated, using FileUtils::fileExists() instead"); 168 return &FileUtils::fileExists(@_); 169 } 170 171 sub dir_exists { 172 warnings::warnif("deprecated", "util::dir_exists() is deprecated, using FileUtils::directoryExists() instead"); 173 return &FileUtils::directoryExists(@_); 174 } 673 175 674 176 # updates a copy of a directory in some other part of the filesystem … … 676 178 # both $fromdir and $todir should be absolute paths 677 179 sub cachedir { 678 my ($fromdir, $todir, $verbosity) = @_; 679 $verbosity = 1 unless defined $verbosity; 680 681 # use / for the directory separator, remove duplicate and 682 # trailing slashes 683 $fromdir=~s/[\\\/]+/\//g; 684 $fromdir=~s/[\\\/]+$//; 685 $todir=~s/[\\\/]+/\//g; 686 $todir=~s/[\\\/]+$//; 687 688 &mk_all_dir ($todir); 689 690 # get the directories in ascending order 691 if (!opendir (FROMDIR, $fromdir)) { 692 print STDERR "util::cachedir could not read directory $fromdir\n"; 693 return; 694 } 695 my @fromdir = grep (!/^\.\.?$/, sort(readdir (FROMDIR))); 696 closedir (FROMDIR); 697 698 if (!opendir (TODIR, $todir)) { 699 print STDERR "util::cacedir could not read directory $todir\n"; 700 return; 701 } 702 my @todir = grep (!/^\.\.?$/, sort(readdir (TODIR))); 703 closedir (TODIR); 704 705 my $fromi = 0; 706 my $toi = 0; 707 708 while ($fromi < scalar(@fromdir) || $toi < scalar(@todir)) { 709 # print "fromi: $fromi toi: $toi\n"; 710 711 # see if we should delete a file/directory 712 # this should happen if the file/directory 713 # is not in the from list or if its a different 714 # size, or has an older timestamp 715 if ($toi < scalar(@todir)) { 716 if (($fromi >= scalar(@fromdir)) || 717 ($todir[$toi] lt $fromdir[$fromi] || 718 ($todir[$toi] eq $fromdir[$fromi] && 719 &differentfiles("$fromdir/$fromdir[$fromi]","$todir/$todir[$toi]", 720 $verbosity)))) { 721 722 # the files are different 723 &rm_r("$todir/$todir[$toi]"); 724 splice(@todir, $toi, 1); # $toi stays the same 725 726 } elsif ($todir[$toi] eq $fromdir[$fromi]) { 727 # the files are the same 728 # if it is a directory, check its contents 729 if (-d "$todir/$todir[$toi]") { 730 &cachedir ("$fromdir/$fromdir[$fromi]", 731 "$todir/$todir[$toi]", $verbosity); 732 } 733 734 $toi++; 735 $fromi++; 736 next; 737 } 738 } 739 740 # see if we should insert a file/directory 741 # we should insert a file/directory if there 742 # is no tofiles left or if the tofile does not exist 743 if ($fromi < scalar(@fromdir) && ($toi >= scalar(@todir) || 744 $todir[$toi] gt $fromdir[$fromi])) { 745 &cp_r ("$fromdir/$fromdir[$fromi]", "$todir/$fromdir[$fromi]"); 746 splice (@todir, $toi, 0, $fromdir[$fromi]); 747 748 $toi++; 749 $fromi++; 750 } 751 } 180 warnings::warnif("deprecated", "util::cachedir() is deprecated, using FileUtils::synchronizeDirectories() instead"); 181 return &FileUtils::synchronizeDirectories(@_); 752 182 } 753 183 … … 757 187 # $file2 is allowed to be newer than $file1 758 188 sub differentfiles { 759 my ($file1, $file2, $verbosity) = @_; 760 $verbosity = 1 unless defined $verbosity; 761 762 $file1 =~ s/\/+$//; 763 $file2 =~ s/\/+$//; 764 765 my ($file1name) = $file1 =~ /\/([^\/]*)$/; 766 my ($file2name) = $file2 =~ /\/([^\/]*)$/; 767 768 return -1 unless (-e $file1 && -e $file2); 769 if ($file1name ne $file2name) { 770 print STDERR "filenames are not the same\n" if ($verbosity >= 2); 771 return 1; 772 } 773 774 my @file1stat = stat ($file1); 775 my @file2stat = stat ($file2); 776 777 if (-d $file1) { 778 if (! -d $file2) { 779 print STDERR "one file is a directory\n" if ($verbosity >= 2); 780 return 1; 781 } 782 return 0; 783 } 784 785 # both must be regular files 786 unless (-f $file1 && -f $file2) { 787 print STDERR "one file is not a regular file\n" if ($verbosity >= 2); 788 return 1; 789 } 790 791 # the size of the files must be the same 792 if ($file1stat[7] != $file2stat[7]) { 793 print STDERR "different sized files\n" if ($verbosity >= 2); 794 return 1; 795 } 796 797 # the second file cannot be older than the first 798 if ($file1stat[9] > $file2stat[9]) { 799 print STDERR "file is older\n" if ($verbosity >= 2); 800 return 1; 801 } 802 803 return 0; 189 warnings::warnif("deprecated", "util::differentfiles() is deprecated, using FileUtils::differentFiles() instead"); 190 return &FileUtils::differentFiles(@_); 804 191 } 805 192 … … 822 209 } 823 210 824 my $tmpdir = filename_cat($ENV{'GSDLHOME'}, "tmp");211 my $tmpdir = &FileUtils::filenameConcatenate($ENV{'GSDLHOME'}, "tmp"); 825 212 &mk_all_dir ($tmpdir) unless -e $tmpdir; 826 213 827 214 my $count = 1000; 828 215 my $rand = int(rand $count); 829 my $full_tmp_filename = & filename_cat($tmpdir, "F$rand$opt_dot_file_ext");216 my $full_tmp_filename = &FileUtils::filenameConcatenate($tmpdir, "F$rand$opt_dot_file_ext"); 830 217 831 218 while (-e $full_tmp_filename) { 832 219 $rand = int(rand $count); 833 $full_tmp_filename = & filename_cat($tmpdir, "F$rand$opt_dot_file_ext");220 $full_tmp_filename = &FileUtils::filenameConcatenate($tmpdir, "F$rand$opt_dot_file_ext"); 834 221 $count++; 835 222 } … … 850 237 } 851 238 852 $tmp_dirname = & util::filename_cat($tmp_dirname, "tmp");239 $tmp_dirname = &FileUtils::filenameConcatenate($tmp_dirname, "tmp"); 853 240 &util::mk_dir($tmp_dirname) if (!-e $tmp_dirname); 854 241 … … 856 243 # if documents have the same name 857 244 my $timestamp = time; 858 my $time_tmp_dirname = & util::filename_cat($tmp_dirname, $timestamp);245 my $time_tmp_dirname = &FileUtils::filenameConcatenate($tmp_dirname, $timestamp); 859 246 $tmp_dirname = $time_tmp_dirname; 860 247 my $i = 1; … … 895 282 } 896 283 $output_ext= lc($output_ext); 897 my $tmp_filename = & util::filename_cat($tmp_dirname, "$tailname$output_ext");284 my $tmp_filename = &FileUtils::filenameConcatenate($tmp_dirname, "$tailname$output_ext"); 898 285 899 286 return $tmp_filename; … … 902 289 sub get_toplevel_tmp_dir 903 290 { 904 return filename_cat($ENV{'GSDLHOME'}, "tmp");291 return &FileUtils::filenameConcatenate($ENV{'GSDLHOME'}, "tmp"); 905 292 } 906 293 … … 940 327 941 328 sub filename_cat { 942 my $first_file = shift(@_); 943 my (@filenames) = @_; 944 945 # Useful for debugging 946 # -- might make sense to call caller(0) rather than (1)?? 947 # my ($cpackage,$cfilename,$cline,$csubr,$chas_args,$cwantarray) = caller(1); 948 # print STDERR "Calling method: $cfilename:$cline $cpackage->$csubr\n"; 949 950 # If first_file is not null or empty, then add it back into the list 951 if (defined $first_file && $first_file =~ /\S/) { 952 unshift(@filenames, $first_file); 953 } 954 955 my $filename = join("/", @filenames); 956 957 # remove duplicate slashes and remove the last slash 958 if ($ENV{'GSDLOS'} =~ /^windows$/i) { 959 $filename =~ s/[\\\/]+/\\/g; 960 } else { 961 $filename =~ s/[\/]+/\//g; 962 # DB: want a filename abc\de.html to remain like this 963 } 964 $filename =~ s/[\\\/]$//; 965 966 return $filename; 329 # I've disabled this warning for now, as every Greenstone perl 330 # script seems to make use of this function and so you drown in a 331 # sea of deprecated warnings [jmt12] 332 # warnings::warnif("deprecated", "util::filename_cat() is deprecated, using FileUtils::filenameConcatenate() instead"); 333 return &FileUtils::filenameConcatenate(@_); 967 334 } 968 335 … … 1074 441 my $filename_full_path = $file; 1075 442 # add on directory if present 1076 $filename_full_path = & util::filename_cat($base_dir, $file) if $base_dir =~ /\S/;443 $filename_full_path = &FileUtils::filenameConcatenate($base_dir, $file) if $base_dir =~ /\S/; 1077 444 1078 445 my $filename_no_path = $file; … … 1106 473 # use filename_cat to clean up trailing slashes and 1107 474 # multiple slashes 1108 $filename1 = filename_cat($filename1);1109 $filename2 = filename_cat($filename2);475 $filename1 = &FileUtils::filenameConcatenate($filename1); 476 $filename2 = &FileUtils::filenameConcatenate($filename2); 1110 477 1111 478 # filenames not case sensitive on windows … … 1237 604 my ($base_dir,$file,$gli) = @_; 1238 605 1239 my $filename_full_path = & util::filename_cat($base_dir,$file);606 my $filename_full_path = &FileUtils::filenameConcatenate($base_dir,$file); 1240 607 1241 608 if ($ENV{'GSDLOS'} =~ m/^windows$/i) { … … 1327 694 sub filename_is_absolute 1328 695 { 1329 my ($filename) = @_; 1330 1331 if ($ENV{'GSDLOS'} =~ /^windows$/i) { 1332 return ($filename =~ m/^(\w:)?\\/); 1333 } 1334 else { 1335 return ($filename =~ m/^\//); 1336 } 696 warnings::warnif("deprecated", "util::filename_is_absolute() is deprecated, using FileUtils::isFilenameAbsolute() instead"); 697 return &FileUtils::isFilenameAbsolute(@_); 1337 698 } 1338 699 … … 1441 802 1442 803 if (!defined $collectdir || $collectdir eq "") { 1443 $collectdir = & filename_cat($ENV{'GSDLHOME'}, "collect");804 $collectdir = &FileUtils::filenameConcatenate($ENV{'GSDLHOME'}, "collect"); 1444 805 } 1445 806 … … 1462 823 # are defined 1463 824 $ENV{'GSDLCOLLECTION'} = $collection; 1464 $ENV{'GSDLCOLLECTDIR'} = & filename_cat($collectdir, $collection);825 $ENV{'GSDLCOLLECTDIR'} = &FileUtils::filenameConcatenate($collectdir, $collection); 1465 826 1466 827 # make sure this collection exists … … 1487 848 if (!defined $collectdir || $collectdir eq "") { 1488 849 die "GSDL3HOME not set.\n" unless defined $ENV{'GSDL3HOME'}; 1489 $collectdir = & filename_cat($ENV{'GSDL3HOME'}, "sites", $site, "collect");850 $collectdir = &FileUtils::filenameConcatenate($ENV{'GSDL3HOME'}, "sites", $site, "collect"); 1490 851 } 1491 852 … … 1523 884 if (defined $ENV{'GSDLCOLLECTDIR'} && $ENV{'GSDLCOLLECTDIR'} ne "") { 1524 885 my $test_collect_etc_filename 1525 = & util::filename_cat($ENV{'GSDLCOLLECTDIR'},"etc", $file);886 = &FileUtils::filenameConcatenate($ENV{'GSDLCOLLECTDIR'},"etc", $file); 1526 887 1527 888 if (-e $test_collect_etc_filename) { … … 1530 891 } 1531 892 my $test_main_etc_filename 1532 = & util::filename_cat($ENV{'GSDLHOME'},"etc", $file);893 = &FileUtils::filenameConcatenate($ENV{'GSDLHOME'},"etc", $file); 1533 894 if (-e $test_main_etc_filename) { 1534 895 push(@locations,$test_main_etc_filename); … … 1553 914 # A method to check if a directory is empty (note that an empty directory still has non-zero size!!!) 1554 915 # Code is from http://episteme.arstechnica.com/eve/forums/a/tpc/f/6330927813/m/436007700831 1555 sub is_dir_empty 1556 { 1557 my ($path) = @_; 1558 opendir DIR, $path; 1559 while(my $entry = readdir DIR) { 1560 next if($entry =~ /^\.\.?$/); 1561 closedir DIR; 1562 return 0; 1563 } 1564 closedir DIR; 1565 return 1; 916 sub is_dir_empty { 917 warnings::warnif("deprecated", "util::is_dir_empty() is deprecated, using FileUtils::isDirectoryEmpty() instead"); 918 return &FileUtils::isDirectoryEmpty(@_); 1566 919 } 1567 920 … … 1669 1022 if($ENV{'GSDL3SRCHOME'}) { 1670 1023 $defaultUrlprefix = "/greenstone3"; 1671 $configfile = & util::filename_cat($ENV{'GSDL3SRCHOME'}, "packages", "tomcat", "conf", "Catalina", "localhost", "greenstone3.xml");1024 $configfile = &FileUtils::filenameConcatenate($ENV{'GSDL3SRCHOME'}, "packages", "tomcat", "conf", "Catalina", "localhost", "greenstone3.xml"); 1672 1025 push(@propertynames, qw/path\s*\=/); 1673 1026 } else { 1674 1027 $defaultUrlprefix = "/greenstone"; 1675 $configfile = & util::filename_cat($ENV{'GSDLHOME'}, "cgi-bin", &os_dir(), "gsdlsite.cfg");1028 $configfile = &FileUtils::filenameConcatenate($ENV{'GSDLHOME'}, "cgi-bin", &os_dir(), "gsdlsite.cfg"); 1676 1029 push(@propertynames, (qw/\nhttpprefix/, qw/\ngwcgi/)); # inspect one property then the other 1677 1030 } … … 1777 1130 1778 1131 if($ENV{'PERLPATH'}) { 1779 # OR: # $perl_exec = & util::filename_cat($ENV{'PERLPATH'},"perl");1132 # OR: # $perl_exec = &FileUtils::filenameConcatenate($ENV{'PERLPATH'},"perl"); 1780 1133 if($ENV{'GSDLOS'} =~ m/windows/) { 1781 1134 $perl_exec = "$ENV{'PERLPATH'}\\Perl.exe"; … … 1804 1157 if(defined $ENV{'GSDLHOME'}) { # should be, as this script would be launched from the cmd line 1805 1158 # after running setup.bat or from GLI which also runs setup.bat 1806 my $java_bin = & util::filename_cat($ENV{'GSDLHOME'},"packages","jre","bin");1159 my $java_bin = &FileUtils::filenameConcatenate($ENV{'GSDLHOME'},"packages","jre","bin"); 1807 1160 if(-d $java_bin) { 1808 $java = & util::filename_cat($java_bin,"java");1161 $java = &FileUtils::filenameConcatenate($java_bin,"java"); 1809 1162 $java = "\"".$java."\""; # quoted to preserve spaces in path 1810 1163 } … … 1844 1197 1845 1198 if (defined $collect_dir && $collect_dir) { # ensure not empty string either 1846 return & util::filename_cat($collect_dir,$colgroup, $collection);1199 return &FileUtils::filenameConcatenate($collect_dir,$colgroup, $collection); 1847 1200 } 1848 1201 elsif (defined($ENV{'GSDLCOLLECTDIR'})) { … … 1851 1204 else { 1852 1205 if (defined $site) { 1853 return & util::filename_cat($ENV{'GSDL3HOME'},"sites",$site,"collect",$colgroup, $collection);1206 return &FileUtils::filenameConcatenate($ENV{'GSDL3HOME'},"sites",$site,"collect",$colgroup, $collection); 1854 1207 } 1855 1208 else { 1856 return & util::filename_cat($ENV{'GSDLHOME'},"collect",$colgroup, $collection);1209 return &FileUtils::filenameConcatenate($ENV{'GSDLHOME'},"collect",$colgroup, $collection); 1857 1210 } 1858 1211 } … … 1864 1217 { 1865 1218 my ($output_dir, $convert_basename, $convert_to) = @_; 1866 opendir(DIR, $output_dir) || die "can't opendir $output_dir: $!";1867 1868 1219 my $page_num = ""; 1220 1221 opendir(DIR, $output_dir) || die "can't opendir $output_dir: $!"; 1869 1222 my @dir_files = grep {-f "$output_dir/$_"} readdir(DIR); 1870 1871 # Sort files in the directory by page_num 1223 closedir DIR; 1224 1225 # Sort files in the directory by page_num 1872 1226 sub page_number { 1873 1227 my ($dir) = @_; … … 1878 1232 } 1879 1233 1880 # sort the files in the directory in the order of page_num rather than lexically. 1234 # sort the files in the directory in the order of page_num rather than lexically. 1881 1235 @dir_files = sort { page_number($a) <=> page_number($b) } @dir_files; 1882 1236 … … 1889 1243 } 1890 1244 1891 my $item_file = &util::filename_cat($output_dir, $convert_basename.".item"); 1892 open(FILE,">$item_file"); 1893 print FILE "<PagedDocument>\n"; 1245 my $item_file = &FileUtils::filenameConcatenate($output_dir, $convert_basename.".item"); 1246 my $item_fh; 1247 &FileUtils::openFileHandle($item_file, 'w', \$item_fh); 1248 print $item_fh "<PagedDocument>\n"; 1894 1249 1895 1250 foreach my $file (@dir_files){ … … 1897 1252 $page_num = page_number($file); 1898 1253 $page_num++ if $starts_at_0; # image numbers start at 0, so add 1 1899 print FILE " <Page pagenum=\"$page_num\" imgfile=\"$file\" txtfile=\"\"/>\n"; 1900 } 1901 } 1902 1903 print FILE "</PagedDocument>\n"; 1904 close FILE; 1905 closedir DIR; 1254 print $item_fh " <Page pagenum=\"$page_num\" imgfile=\"$file\" txtfile=\"\"/>\n"; 1255 } 1256 } 1257 1258 print $item_fh "</PagedDocument>\n"; 1259 &FileUtils::closeFileHandle($item_file, \$item_fh); 1906 1260 return $item_file; 1907 1261 } 1908 1262 1263 1264 # /** @function augmentINC() 1265 # * Prepend a path (if it exists) onto INC but only if it isn't already in 1266 # * INC 1267 # * @param $new_path The path to add as necessary 1268 # * @author jmt12 1269 # */ 1270 sub augmentINC 1271 { 1272 my ($new_path) = @_; 1273 my $did_add_path = 0; 1274 # will need to be replaced with FileUtils::directoryExists() call eventually 1275 if (-d $new_path) 1276 { 1277 my $did_find_path = 0; 1278 foreach my $existing_path (@INC) 1279 { 1280 if ($existing_path eq $new_path) 1281 { 1282 $did_find_path = 1; 1283 last; 1284 } 1285 } 1286 if (!$did_find_path) 1287 { 1288 unshift(@INC, $new_path); 1289 $did_add_path = 1; 1290 } 1291 } 1292 return $did_add_path; 1293 } 1294 # /** augmentINC($new_path) **/ 1295 1909 1296 1;
Note:
See TracChangeset
for help on using the changeset viewer.