source: main/trunk/greenstone2/perllib/FileUtils.pm@ 27508

Last change on this file since 27508 was 27508, checked in by ak19, 11 years ago

closeFileHandle() should deal with the case of the file not existing.
File size: 30.3 KB
Line 
1###########################################################################
2#
3# FileUtils.pm -- functions for dealing with files. Skeleton for more
4# advanced system using dynamic class cloading available in extensions.
5#
6# A component of the Greenstone digital library software
7# from the New Zealand Digital Library Project at the
8# University of Waikato, New Zealand.
9#
10# Copyright (C) 2013 New Zealand Digital Library Project
11#
12# This program is free software; you can redistribute it and/or modify
13# it under the terms of the GNU General Public License as published by
14# the Free Software Foundation; either version 2 of the License, or
15# (at your option) any later version.
16#
17# This program is distributed in the hope that it will be useful,
18# but WITHOUT ANY WARRANTY; without even the implied warranty of
19# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20# GNU General Public License for more details.
21#
22# You should have received a copy of the GNU General Public License
23# along with this program; if not, write to the Free Software
24# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
25#
26###########################################################################
27
28package FileUtils;
29
30# Pragma
31use strict;
32use warnings;
33
34use FileHandle;
35
36# Greenstone modules
37use util;
38
39################################################################################
40# util::cachedir() => FileUtils::synchronizeDirectories()
41# util::cp() => FileUtils::copyFiles()
42# util::cp_r() => FileUtils::copyFilesRecursive()
43# util::cp_r_nosvn() => FileUtils::copyFilesRecursiveNoSVN()
44# util::cp_r_toplevel() => FileUtils::copyFilesRecursiveTopLevel()
45# util::different_files() => FileUtils::differentFiles()
46# util::dir_exists() => FileUtils::directoryExists()
47# util::fd_exists() => FileUtils::fileTest()
48# util::file_exists() => FileUtils::fileExists()
49# util::filename_cat() => FileUtils::filenameConcatenate()
50# util::filename_is_absolute() => FileUtils::isFilenameAbsolute()
51# util::filtered_rm_r() => FileUtils::removeFilesFiltered()
52# util::hard_link() => FileUtils::hardLink()
53# util::is_dir_empty() => FileUtils::isDirectoryEmpty()
54# util::mk_all_dir() => FileUtils::makeAllDirectories()
55# util::mv() => FileUtils::moveFiles()
56# util::mk_dir() => FileUtils::makeDirectory()
57# util::mv_dir_contents() => FileUtils::moveDirectoryContents()
58# util::rm() => FileUtils::removeFiles()
59# util::rm_r() => FileUtils::removeFilesRecursive()
60# util::soft_link() => FileUtils::softLink()
61
62################################################################################
63# Note: there are lots of functions involving files/directories/paths
64# etc found in utils.pm that are not represented here. My intention
65# was to just have those functions that need to be dynamic based on
66# filesystem, or need some rejigging to be filesystem aware. There is
67# an argument, I guess, for moving some of the other functions here so
68# that they are nicely encapsulated - but the question is what to do
69# with functions like filename_within_directory_url_format() which is
70# more URL based than file based.
71################################################################################
72
73
74## @function canRead()
75#
76sub canRead
77{
78 my ($filename_full_path) = @_;
79 return &fileTest($filename_full_path, '-R');
80}
81## canRead()
82
83
84## @function closeFileHandle
85#
86sub closeFileHandle
87{
88 my ($path, $fh_ref) = @_;
89 close($$fh_ref) if &fileExists($$fh_ref);
90}
91## closeFileHandle()
92
93
94## @function copyFiles()
95#
96# copies a file or a group of files
97#
98sub copyFiles
99{
100 my $dest = pop (@_);
101 my (@srcfiles) = @_;
102
103 # remove trailing slashes from source and destination files
104 $dest =~ s/[\\\/]+$//;
105 map {$_ =~ s/[\\\/]+$//;} @srcfiles;
106
107 # a few sanity checks
108 if (scalar (@srcfiles) == 0)
109 {
110 print STDERR "FileUtils::copyFiles() no destination directory given\n";
111 return;
112 }
113 elsif ((scalar (@srcfiles) > 1) && (!-d $dest))
114 {
115 print STDERR "FileUtils::copyFiles() if multiple source files are given the destination must be a directory\n";
116 return;
117 }
118
119 # copy the files
120 foreach my $file (@srcfiles)
121 {
122 my $tempdest = $dest;
123 if (-d $tempdest)
124 {
125 my ($filename) = $file =~ /([^\\\/]+)$/;
126 $tempdest .= "/$filename";
127 }
128 if (!-e $file)
129 {
130 print STDERR "FileUtils::copyFiles() $file does not exist\n";
131 }
132 elsif (!-f $file)
133 {
134 print STDERR "FileUtils::copyFiles() $file is not a plain file\n";
135 }
136 else
137 {
138 &File::Copy::copy ($file, $tempdest);
139 }
140 }
141}
142## copyFiles()
143
144
145## @function copyFilesRecursive()
146#
147# recursively copies a file or group of files syntax: cp_r
148# (sourcefiles, destination directory) destination must be a directory
149# to copy one file to another use cp instead
150#
151sub copyFilesRecursive
152{
153 my $dest = pop (@_);
154 my (@srcfiles) = @_;
155
156 # a few sanity checks
157 if (scalar (@srcfiles) == 0)
158 {
159 print STDERR "FileUtils::copyFilesRecursive() no destination directory given\n";
160 return;
161 }
162 elsif (-f $dest)
163 {
164 print STDERR "FileUtils::copyFilesRecursive() destination must be a directory\n";
165 return;
166 }
167
168 # create destination directory if it doesn't exist already
169 if (! -d $dest)
170 {
171 my $store_umask = umask(0002);
172 mkdir ($dest, 0777);
173 umask($store_umask);
174 }
175
176 # copy the files
177 foreach my $file (@srcfiles)
178 {
179
180 if (!-e $file)
181 {
182 print STDERR "FileUtils::copyFilesRecursive() $file does not exist\n";
183 }
184 elsif (-d $file)
185 {
186 # make the new directory
187 my ($filename) = $file =~ /([^\\\/]*)$/;
188 $dest = &filenameConcatenate($dest, $filename);
189 my $store_umask = umask(0002);
190 mkdir ($dest, 0777);
191 umask($store_umask);
192
193 # get the contents of this directory
194 if (!opendir (INDIR, $file))
195 {
196 print STDERR "FileUtils::copyFilesRecursive() could not open directory $file\n";
197 }
198 else
199 {
200 my @filedir = readdir (INDIR);
201 closedir (INDIR);
202 foreach my $f (@filedir)
203 {
204 next if $f =~ /^\.\.?$/;
205 # copy all the files in this directory
206 my $ff = &filenameConcatenate($file, $f);
207 &copyFilesRecursive($ff, $dest);
208 }
209 }
210
211 }
212 else
213 {
214 &copyFiles($file, $dest);
215 }
216 }
217}
218## copyFilesRecursive()
219
220
221## @function copyFilesRecursiveNoSVN()
222#
223# recursively copies a file or group of files, excluding SVN
224# directories, with syntax: cp_r (sourcefiles, destination directory)
225# destination must be a directory - to copy one file to another use cp
226# instead
227#
228# this should be merged with copyFilesRecursive() at some stage - jmt12
229#
230sub copyFilesRecursiveNoSVN
231{
232 my $dest = pop (@_);
233 my (@srcfiles) = @_;
234
235 # a few sanity checks
236 if (scalar (@srcfiles) == 0)
237 {
238 print STDERR "FileUtils::copyFilesRecursiveNoSVN() no destination directory given\n";
239 return;
240 }
241 elsif (-f $dest)
242 {
243 print STDERR "FileUtils::copyFilesRecursiveNoSVN() destination must be a directory\n";
244 return;
245 }
246
247 # create destination directory if it doesn't exist already
248 if (! -d $dest)
249 {
250 my $store_umask = umask(0002);
251 mkdir ($dest, 0777);
252 umask($store_umask);
253 }
254
255 # copy the files
256 foreach my $file (@srcfiles)
257 {
258 if (!-e $file)
259 {
260 print STDERR "copyFilesRecursiveNoSVN() $file does not exist\n";
261 }
262 elsif (-d $file)
263 {
264 # make the new directory
265 my ($filename) = $file =~ /([^\\\/]*)$/;
266 $dest = &filenameConcatnate($dest, $filename);
267 my $store_umask = umask(0002);
268 mkdir ($dest, 0777);
269 umask($store_umask);
270
271 # get the contents of this directory
272 if (!opendir (INDIR, $file))
273 {
274 print STDERR "copyFilesRecursiveNoSVN() could not open directory $file\n";
275 }
276 else
277 {
278 my @filedir = readdir (INDIR);
279 closedir (INDIR);
280 foreach my $f (@filedir)
281 {
282 next if $f =~ /^\.\.?$/;
283 next if $f =~ /^\.svn$/;
284 # copy all the files in this directory
285 my $ff = &filenameConcatenate($file, $f);
286 # util.pm version incorrectly called cp_r here - jmt12
287 &recursiveCopyNoSVN($ff, $dest);
288 }
289 }
290 }
291 else
292 {
293 &copyFiles($file, $dest);
294 }
295 }
296}
297## copyFilesRecursiveNoSVN()
298
299
300## @function copyFilesRecursiveTopLevel()
301#
302# copies a directory and its contents, excluding subdirectories, into a new directory
303#
304# another candidate for merging in with copyFilesRecursive() - jmt12
305#
306sub copyFilesRecursiveTopLevel
307{
308 my $dest = pop (@_);
309 my (@srcfiles) = @_;
310
311 # a few sanity checks
312 if (scalar (@srcfiles) == 0)
313 {
314 print STDERR "FileUtils::copyFilesRecursiveTopLevel() no destination directory given\n";
315 return;
316 }
317 elsif (-f $dest)
318 {
319 print STDERR "FileUtils::copyFilesRecursiveTopLevel() destination must be a directory\n";
320 return;
321 }
322
323 # create destination directory if it doesn't exist already
324 if (! -d $dest)
325 {
326 my $store_umask = umask(0002);
327 mkdir ($dest, 0777);
328 umask($store_umask);
329 }
330
331 # copy the files
332 foreach my $file (@srcfiles)
333 {
334 if (!-e $file)
335 {
336 print STDERR "FileUtils::copyFilesRecursiveTopLevel() $file does not exist\n";
337 }
338 elsif (-d $file)
339 {
340 # make the new directory
341 my ($filename) = $file =~ /([^\\\/]*)$/;
342 $dest = &filenameConcatenate($dest, $filename);
343 my $store_umask = umask(0002);
344 mkdir ($dest, 0777);
345 umask($store_umask);
346
347 # get the contents of this directory
348 if (!opendir (INDIR, $file))
349 {
350 print STDERR "FileUtils::copyFilesRecursiveTopLevel() could not open directory $file\n";
351 }
352 else
353 {
354 my @filedir = readdir (INDIR);
355 closedir (INDIR);
356 foreach my $f (@filedir)
357 {
358 next if $f =~ /^\.\.?$/;
359
360 # copy all the files in this directory, but not directories
361 my $ff = &filenameConcatenate($file, $f);
362 if (-f $ff)
363 {
364 &copyFiles($ff, $dest);
365 #&cp_r ($ff, $dest);
366 }
367 }
368 }
369 }
370 else
371 {
372 &copyFiles($file, $dest);
373 }
374 }
375}
376## copyFilesRecursiveTopLevel()
377
378
379## @function differentFiles()
380#
381# this function returns -1 if either file is not found assumes that
382# $file1 and $file2 are absolute file names or in the current
383# directory $file2 is allowed to be newer than $file1
384#
385sub differentFiles
386{
387 my ($file1, $file2, $verbosity) = @_;
388 $verbosity = 1 unless defined $verbosity;
389
390 $file1 =~ s/\/+$//;
391 $file2 =~ s/\/+$//;
392
393 my ($file1name) = $file1 =~ /\/([^\/]*)$/;
394 my ($file2name) = $file2 =~ /\/([^\/]*)$/;
395
396 return -1 unless (-e $file1 && -e $file2);
397 if ($file1name ne $file2name)
398 {
399 print STDERR "filenames are not the same\n" if ($verbosity >= 2);
400 return 1;
401 }
402
403 my @file1stat = stat ($file1);
404 my @file2stat = stat ($file2);
405
406 if (-d $file1)
407 {
408 if (! -d $file2)
409 {
410 print STDERR "one file is a directory\n" if ($verbosity >= 2);
411 return 1;
412 }
413 return 0;
414 }
415
416 # both must be regular files
417 unless (-f $file1 && -f $file2)
418 {
419 print STDERR "one file is not a regular file\n" if ($verbosity >= 2);
420 return 1;
421 }
422
423 # the size of the files must be the same
424 if ($file1stat[7] != $file2stat[7])
425 {
426 print STDERR "different sized files\n" if ($verbosity >= 2);
427 return 1;
428 }
429
430 # the second file cannot be older than the first
431 if ($file1stat[9] > $file2stat[9])
432 {
433 print STDERR "file is older\n" if ($verbosity >= 2);
434 return 1;
435 }
436
437 return 0;
438}
439## differentFiles()
440
441
442## @function directoryExists()
443#
444sub directoryExists
445{
446 my ($filename_full_path) = @_;
447 return &fileTest($filename_full_path, '-d');
448}
449## directoryExists()
450
451
452## @function fileExists()
453#
454sub fileExists
455{
456 my ($filename_full_path) = @_;
457 return &fileTest($filename_full_path, '-f');
458}
459## fileExists()
460
461## @function filenameConcatenate()
462#
463sub filenameConcatenate
464{
465 my $first_file = shift(@_);
466 my (@filenames) = @_;
467
468 # Useful for debugging
469 # -- might make sense to call caller(0) rather than (1)??
470 # my ($cpackage,$cfilename,$cline,$csubr,$chas_args,$cwantarray) = caller(1);
471 # print STDERR "Calling method: $cfilename:$cline $cpackage->$csubr\n";
472
473 # If first_file is not null or empty, then add it back into the list
474 if (defined $first_file && $first_file =~ /\S/)
475 {
476 unshift(@filenames, $first_file);
477 }
478
479 my $filename = join("/", @filenames);
480
481 # remove duplicate slashes and remove the last slash
482 if ($ENV{'GSDLOS'} =~ /^windows$/i)
483 {
484 $filename =~ s/[\\\/]+/\\/g;
485 }
486 else
487 {
488 $filename =~ s/[\/]+/\//g;
489 # DB: want a filename abc\de.html to remain like this
490 }
491 $filename =~ s/[\\\/]$//;
492
493 return $filename;
494}
495## filenameConcatenate()
496
497## @function filePutContents()
498#
499# Create a file and write the given string directly to it
500# @param $path the full path of the file to write as a String
501# @param $content the String to be written to the file
502#
503sub filePutContents
504{
505 my ($path, $content) = @_;
506 if (open(FOUT, '>:utf8', $path))
507 {
508 print FOUT $content;
509 close(FOUT);
510 }
511 else
512 {
513 die('Error! Failed to open file for writing: ' . $path . "\n");
514 }
515}
516## filePutContents()
517
518## @function fileSize()
519#
520sub fileSize
521{
522 my $path = shift(@_);
523 my $file_size = -s $path;
524 return $file_size;
525}
526## fileSize()
527
528## @function fileTest()
529#
530sub fileTest
531{
532 my $filename_full_path = shift @_;
533 my $test_op = shift @_ || "-e";
534
535 # By default tests for existance of file or directory (-e)
536 # Can be made more specific by providing second parameter (e.g. -f or -d)
537
538 my $exists = 0;
539
540 if ($ENV{'GSDLOS'} =~ m/^windows$/i)
541 {
542 require Win32;
543 my $filename_short_path = Win32::GetShortPathName($filename_full_path);
544 if (!defined $filename_short_path)
545 {
546 # Was probably still in UTF8 form (not what is needed on Windows)
547 my $unicode_filename_full_path = eval "decode(\"utf8\",\$filename_full_path)";
548 if (defined $unicode_filename_full_path)
549 {
550 $filename_short_path = Win32::GetShortPathName($unicode_filename_full_path);
551 }
552 }
553 $filename_full_path = $filename_short_path;
554 }
555
556 if (defined $filename_full_path)
557 {
558 $exists = eval "($test_op \$filename_full_path)";
559 }
560
561 return $exists;
562}
563## fileTest()
564
565## @function hardLink()
566# make hard link to file if supported by OS, otherwise copy the file
567#
568sub hardLink
569{
570 my ($src, $dest, $verbosity) = @_;
571
572 # remove trailing slashes from source and destination files
573 $src =~ s/[\\\/]+$//;
574 $dest =~ s/[\\\/]+$//;
575
576 ## print STDERR "**** src = ", unicode::debug_unicode_string($src),"\n";
577 # a few sanity checks
578 if (-e $dest)
579 {
580 # destination file already exists
581 return;
582 }
583 elsif (!-e $src)
584 {
585 print STDERR "FileUtils::hardLink() source file \"" . $src . "\" does not exist\n";
586 return 1;
587 }
588 elsif (-d $src)
589 {
590 print STDERR "FileUtils::hardLink() source \"" . $src . "\" is a directory\n";
591 return 1;
592 }
593
594 my $dest_dir = &File::Basename::dirname($dest);
595 if (!-e $dest_dir)
596 {
597 &makeAllDirectories($dest_dir);
598 }
599
600 if (!link($src, $dest))
601 {
602 if ((!defined $verbosity) || ($verbosity>2))
603 {
604 print STDERR "FileUtils::hardLink(): unable to create hard link. ";
605 print STDERR " Copying file: $src -> $dest\n";
606 }
607 &File::Copy::copy ($src, $dest);
608 }
609 return 0;
610}
611## hardLink()
612
613## @function isDirectoryEmpty()
614#
615# A method to check if a directory is empty (note that an empty
616# directory still has non-zero size!!!). Code is from
617# http://episteme.arstechnica.com/eve/forums/a/tpc/f/6330927813/m/436007700831
618#
619sub isDirectoryEmpty
620{
621 my ($path) = @_;
622 opendir DIR, $path;
623 while(my $entry = readdir DIR)
624 {
625 next if($entry =~ /^\.\.?$/);
626 closedir DIR;
627 return 0;
628 }
629 closedir DIR;
630 return 1;
631}
632## isDirectoryEmpty()
633
634## @function isFilenameAbsolute()
635#
636sub isFilenameAbsolute
637{
638 my ($filename) = @_;
639 if ($ENV{'GSDLOS'} =~ /^windows$/i)
640 {
641 return ($filename =~ m/^(\w:)?\\/);
642 }
643 return ($filename =~ m/^\//);
644}
645# isFilenameAbsolute()
646
647## @function isSymbolicLink
648#
649# Determine if a given path is a symbolic link (soft link)
650#
651sub isSymbolicLink
652{
653 my $path = shift(@_);
654 my $is_soft_link = -l $path;
655 return $is_soft_link;
656}
657## isSymbolicLink()
658
659## @function makeAllDirectories()
660#
661# in case anyone cares - I did some testing (using perls Benchmark module)
662# on this subroutine against File::Path::mkpath (). mk_all_dir() is apparently
663# slightly faster (surprisingly) - Stefan.
664#
665sub makeAllDirectories
666{
667 my ($dir) = @_;
668
669 # use / for the directory separator, remove duplicate and
670 # trailing slashes
671 $dir=~s/[\\\/]+/\//g;
672 $dir=~s/[\\\/]+$//;
673
674 # make sure the cache directory exists
675 my $dirsofar = "";
676 my $first = 1;
677 foreach my $dirname (split ("/", $dir))
678 {
679 $dirsofar .= "/" unless $first;
680 $first = 0;
681
682 $dirsofar .= $dirname;
683
684 next if $dirname =~ /^(|[a-z]:)$/i;
685 if (!-e $dirsofar)
686 {
687 my $store_umask = umask(0002);
688 my $mkdir_ok = mkdir ($dirsofar, 0777);
689 umask($store_umask);
690 if (!$mkdir_ok)
691 {
692 print STDERR "FileUtils::makeAllDirectories() could not create directory $dirsofar\n";
693 return;
694 }
695 }
696 }
697 return 1;
698}
699## makeAllDirectories()
700
701## @function makeDirectory()
702#
703sub makeDirectory
704{
705 my ($dir) = @_;
706
707 my $store_umask = umask(0002);
708 my $mkdir_ok = mkdir ($dir, 0777);
709 umask($store_umask);
710
711 if (!$mkdir_ok)
712 {
713 print STDERR "FileUtils::makeDirectory() could not create directory $dir\n";
714 return;
715 }
716}
717## makeDirectory()
718
719## @function modificationTime()
720#
721sub modificationTime
722{
723 my $path = shift(@_);
724 my @file_status = stat($path);
725 return $file_status[9];
726}
727## modificationTime()
728
729## @function moveDirectoryContents()
730#
731# Move the contents of source directory into target directory (as
732# opposed to merely replacing target dir with the src dir) This can
733# overwrite any files with duplicate names in the target but other
734# files and folders in the target will continue to exist
735#
736sub moveDirectoryContents
737{
738 my ($src_dir, $dest_dir) = @_;
739
740 # Obtain listing of all files within src_dir
741 # Note that readdir lists relative paths, as well as . and ..
742 opendir(DIR, "$src_dir");
743 my @files= readdir(DIR);
744 close(DIR);
745
746 my @full_path_files = ();
747 foreach my $file (@files)
748 {
749 # process all except . and ..
750 unless($file eq "." || $file eq "..")
751 {
752 my $dest_subdir = &filenameConcatenate($dest_dir, $file); # $file is still a relative path
753
754 # construct absolute paths
755 $file = &filenameConcatenate($src_dir, $file); # $file is now an absolute path
756
757 # Recurse on directories which have an equivalent in target dest_dir
758 # If $file is a directory that already exists in target $dest_dir,
759 # then a simple move operation will fail (definitely on Windows).
760 if(-d $file && -d $dest_subdir)
761 {
762 #print STDERR "**** $file is a directory also existing in target, its contents to be copied to $dest_subdir\n";
763 &moveDirectoryContents($file, $dest_subdir);
764
765 # now all content is moved across, delete empty dir in source folder
766 if(&isDirectoryEmpty($file))
767 {
768 if (!rmdir $file)
769 {
770 print STDERR "ERROR. FileUtils::moveDirectoryContents() couldn't remove directory $file\n";
771 }
772 }
773 # error
774 else
775 {
776 print STDERR "ERROR. FileUtils::moveDirectoryContents(): subfolder $file still non-empty after moving contents to $dest_subdir\n";
777 }
778 }
779 # process files and any directories that don't already exist with a simple move
780 else
781 {
782 push(@full_path_files, $file);
783 }
784 }
785 }
786
787 # create target toplevel folder or subfolders if they don't exist
788 if(!&directoryExists($dest_dir))
789 {
790 &makeDirectory($dest_dir);
791 }
792
793 #print STDERR "@@@@@ Copying files |".join(",", @full_path_files)."| to: $dest_dir\n";
794
795 # if non-empty, there's something to copy across
796 if(@full_path_files)
797 {
798 &moveFiles(@full_path_files, $dest_dir);
799 }
800}
801## moveDirectoryContents()
802
803## @function moveFiles()
804#
805# moves a file or a group of files
806#
807sub moveFiles
808{
809 my $dest = pop (@_);
810 my (@srcfiles) = @_;
811
812 # remove trailing slashes from source and destination files
813 $dest =~ s/[\\\/]+$//;
814 map {$_ =~ s/[\\\/]+$//;} @srcfiles;
815
816 # a few sanity checks
817 if (scalar (@srcfiles) == 0)
818 {
819 print STDERR "FileUtils::moveFiles() no destination directory given\n";
820 return;
821 }
822 elsif ((scalar (@srcfiles) > 1) && (!-d $dest))
823 {
824 print STDERR "FileUtils::moveFiles() if multiple source files are given the destination must be a directory\n";
825 return;
826 }
827
828 # move the files
829 foreach my $file (@srcfiles)
830 {
831 my $tempdest = $dest;
832 if (-d $tempdest)
833 {
834 my ($filename) = $file =~ /([^\\\/]+)$/;
835 $tempdest .= "/$filename";
836 }
837 if (!-e $file)
838 {
839 print STDERR "FileUtils::moveFiles() $file does not exist\n";
840 }
841 else
842 {
843 if(!rename ($file, $tempdest))
844 {
845 print STDERR "**** Failed to rename $file to $tempdest\n";
846 &File::Copy::copy($file, $tempdest);
847 &removeFiles($file);
848 }
849 # rename (partially) succeeded) but srcfile still exists after rename
850 elsif(-e $file)
851 {
852 #print STDERR "*** srcfile $file still exists after rename to $tempdest\n";
853 if(!-e $tempdest)
854 {
855 print STDERR "@@@@ ERROR: $tempdest does not exist\n";
856 }
857 # Sometimes the rename operation fails (as does
858 # File::Copy::move). This turns out to be because the files
859 # are hardlinked. Need to do a copy-delete in this case,
860 # however, the copy step is not necessary: the srcfile got
861 # renamed into tempdest, but srcfile itself still exists,
862 # delete it. &File::Copy::copy($file, $tempdest);
863 &removeFiles($file);
864 }
865 }
866 }
867}
868## moveFiles()
869
870## @function openFileHandle()
871#
872sub openFileHandle
873{
874 my $path = shift(@_);
875 my $mode = shift(@_);
876 my $fh_ref = shift(@_);
877 my $encoding = shift(@_);
878 my $mode_symbol;
879 if ($mode eq 'w' || $mode eq '>')
880 {
881 $mode_symbol = '>';
882 $mode = 'writing';
883 }
884 elsif ($mode eq 'a' || $mode eq '>>')
885 {
886 $mode_symbol = '>>';
887 $mode = 'appending';
888 }
889 else
890 {
891 $mode_symbol = '<';
892 $mode = 'reading';
893 }
894 if (defined $encoding)
895 {
896 $mode_symbol .= ':' . $encoding;
897 }
898 if (!open($$fh_ref, $mode_symbol, $path))
899 {
900 die("Error! Failed to open file for " . $mode . ": " . $path . "\n");
901 }
902 return 1;
903}
904## openFileHandle()
905
906## @function readDirectory()
907#
908sub readDirectory
909{
910 my $path = shift(@_);
911 my @files;
912 if (opendir(DH, $path))
913 {
914 @files = readdir(DH);
915 close(DH);
916 }
917 else
918 {
919 die("Error! Failed to open directory to list files: " . $path . "\n");
920 }
921 return \@files;
922}
923## readDirectory()
924
925## @function removeFiles()
926#
927# removes files (but not directories)
928#
929sub removeFiles
930{
931 my (@files) = @_;
932 my @filefiles = ();
933
934 # make sure the files we want to delete exist
935 # and are regular files
936 foreach my $file (@files)
937 {
938 if (!-e $file)
939 {
940 print STDERR "FileUtils::removeFiles() $file does not exist\n";
941 }
942 elsif ((!-f $file) && (!-l $file))
943 {
944 print STDERR "FileUtils::removeFiles() $file is not a regular (or symbolic) file\n";
945 }
946 else
947 {
948 push (@filefiles, $file);
949 }
950 }
951
952 # remove the files
953 my $numremoved = unlink @filefiles;
954
955 # check to make sure all of them were removed
956 if ($numremoved != scalar(@filefiles))
957 {
958 print STDERR "FileUtils::removeFiles() Not all files were removed\n";
959 }
960}
961## removeFiles()
962
963## @function removeFilesDebug()
964#
965# removes files (but not directories) - can rename this to the default
966# "rm" subroutine when debugging the deletion of individual files.
967# Unused?
968#
969sub removeFilesDebug
970{
971 my (@files) = @_;
972 my @filefiles = ();
973
974 # make sure the files we want to delete exist
975 # and are regular files
976 foreach my $file (@files)
977 {
978 if (!-e $file)
979 {
980 print STDERR "FileUtils::removeFilesDebug() " . $file . " does not exist\n";
981 }
982 elsif ((!-f $file) && (!-l $file))
983 {
984 print STDERR "FileUtils::removeFilesDebug() " . $file . " is not a regular (or symbolic) file\n";
985 }
986 # debug message
987 else
988 {
989 unlink($file) or warn "Could not delete file " . $file . ": " . $! . "\n";
990 }
991 }
992}
993## removeFilesDebug()
994
995## @function removeFilesFiltered()
996#
997sub removeFilesFiltered
998{
999 my ($files,$file_accept_re,$file_reject_re) = @_;
1000
1001 # my ($cpackage,$cfilename,$cline,$csubr,$chas_args,$cwantarray) = caller(2);
1002 # my ($lcfilename) = ($cfilename =~ m/([^\\\/]*)$/);
1003 # print STDERR "** Calling method (2): $lcfilename:$cline $cpackage->$csubr\n";
1004
1005 my @files_array = (ref $files eq "ARRAY") ? @$files : ($files);
1006
1007 # recursively remove the files
1008 foreach my $file (@files_array)
1009 {
1010 $file =~ s/[\/\\]+$//; # remove trailing slashes
1011
1012 if (!-e $file)
1013 {
1014 print STDERR "FileUtils::removeFilesFiltered() $file does not exist\n";
1015 }
1016 # don't recurse down symbolic link
1017 elsif ((-d $file) && (!-l $file))
1018 {
1019 # get the contents of this directory
1020 if (!opendir (INDIR, $file))
1021 {
1022 print STDERR "FileUtils::removeFilesFiltered() could not open directory $file\n";
1023 }
1024 else
1025 {
1026 my @filedir = grep (!/^\.\.?$/, readdir (INDIR));
1027 closedir (INDIR);
1028
1029 # remove all the files in this directory
1030 map {$_="$file/$_";} @filedir;
1031 &removeFilesFiltered(\@filedir,$file_accept_re,$file_reject_re);
1032
1033 if (!defined $file_accept_re && !defined $file_reject_re)
1034 {
1035 # remove this directory
1036 if (!rmdir $file)
1037 {
1038 print STDERR "FileUtils::removeFilesFiltered() couldn't remove directory $file\n";
1039 }
1040 }
1041 }
1042 }
1043 else
1044 {
1045 next if (defined $file_reject_re && ($file =~ m/$file_reject_re/));
1046
1047 if ((!defined $file_accept_re) || ($file =~ m/$file_accept_re/))
1048 {
1049 # remove this file
1050 &removeFiles($file);
1051 }
1052 }
1053 }
1054}
1055## removeFilesFiltered()
1056
1057## @function removeFilesRecursive()
1058#
1059# The equivalent of "rm -rf" with all the dangers therein
1060#
1061sub removeFilesRecursive
1062{
1063 my (@files) = @_;
1064
1065 # use the more general (but reterospectively written) function
1066 # filtered_rm_r function() with no accept or reject expressions
1067 &removeFilesFiltered(\@files,undef,undef);
1068}
1069## removeFilesRecursive()
1070
1071## @function sanitizePath()
1072#
1073sub sanitizePath
1074{
1075 my ($path) = @_;
1076
1077 # fortunately filename concatenate will perform all the double slash
1078 # removal and end slash removal we need, and in a protocol aware
1079 # fashion
1080 return &filenameConcatenate($path);
1081}
1082## sanitizePath()
1083
1084## @function softLink()
1085#
1086# make soft link to file if supported by OS, otherwise copy file
1087#
1088sub softLink
1089{
1090 my ($src, $dest, $ensure_paths_absolute) = @_;
1091
1092 # remove trailing slashes from source and destination files
1093 $src =~ s/[\\\/]+$//;
1094 $dest =~ s/[\\\/]+$//;
1095
1096 # Ensure file paths are absolute IF requested to do so
1097 # Soft_linking didn't work for relative paths
1098 if(defined $ensure_paths_absolute && $ensure_paths_absolute)
1099 {
1100 # We need to ensure that the src file is the absolute path
1101 # See http://perldoc.perl.org/File/Spec.html
1102 # it's relative
1103 if(!File::Spec->file_name_is_absolute( $src ))
1104 {
1105 $src = File::Spec->rel2abs($src); # make absolute
1106 }
1107 # Might as well ensure that the destination file's absolute path is used
1108 if(!File::Spec->file_name_is_absolute( $dest ))
1109 {
1110 $dest = File::Spec->rel2abs($dest); # make absolute
1111 }
1112 }
1113
1114 # a few sanity checks
1115 if (!-e $src)
1116 {
1117 print STDERR "FileUtils::softLink() source file $src does not exist\n";
1118 return 0;
1119 }
1120
1121 my $dest_dir = &File::Basename::dirname($dest);
1122 if (!-e $dest_dir)
1123 {
1124 &makeAllDirectories($dest_dir);
1125 }
1126
1127 if ($ENV{'GSDLOS'} =~ /^windows$/i)
1128 {
1129 # symlink not supported on windows
1130 &File::Copy::copy ($src, $dest);
1131 }
1132 elsif (!eval {symlink($src, $dest)})
1133 {
1134 print STDERR "FileUtils::softLink(): unable to create soft link.\n";
1135 return 0;
1136 }
1137 return 1;
1138}
1139## softLink()
1140
1141## @function synchronizeDirectory()
1142#
1143# updates a copy of a directory in some other part of the filesystem
1144# verbosity settings are: 0=low, 1=normal, 2=high
1145# both $fromdir and $todir should be absolute paths
1146#
1147sub synchronizeDirectory
1148{
1149 my ($fromdir, $todir, $verbosity) = @_;
1150 $verbosity = 1 unless defined $verbosity;
1151
1152 # use / for the directory separator, remove duplicate and
1153 # trailing slashes
1154 $fromdir=~s/[\\\/]+/\//g;
1155 $fromdir=~s/[\\\/]+$//;
1156 $todir=~s/[\\\/]+/\//g;
1157 $todir=~s/[\\\/]+$//;
1158
1159 &makeAllDirectories($todir);
1160
1161 # get the directories in ascending order
1162 if (!opendir (FROMDIR, $fromdir))
1163 {
1164 print STDERR "FileUtils::synchronizeDirectory() could not read directory $fromdir\n";
1165 return;
1166 }
1167 my @fromdir = grep (!/^\.\.?$/, sort(readdir (FROMDIR)));
1168 closedir (FROMDIR);
1169
1170 if (!opendir (TODIR, $todir))
1171 {
1172 print STDERR "FileUtils::synchronizeDirectory() could not read directory $todir\n";
1173 return;
1174 }
1175 my @todir = grep (!/^\.\.?$/, sort(readdir (TODIR)));
1176 closedir (TODIR);
1177
1178 my $fromi = 0;
1179 my $toi = 0;
1180
1181 while ($fromi < scalar(@fromdir) || $toi < scalar(@todir))
1182 {
1183 # print "fromi: $fromi toi: $toi\n";
1184
1185 # see if we should delete a file/directory
1186 # this should happen if the file/directory
1187 # is not in the from list or if its a different
1188 # size, or has an older timestamp
1189 if ($toi < scalar(@todir))
1190 {
1191 if (($fromi >= scalar(@fromdir)) || ($todir[$toi] lt $fromdir[$fromi] || ($todir[$toi] eq $fromdir[$fromi] && &differentFiles("$fromdir/$fromdir[$fromi]","$todir/$todir[$toi]", $verbosity))))
1192 {
1193
1194 # the files are different
1195 &removeFilesRecursive("$todir/$todir[$toi]");
1196 splice(@todir, $toi, 1); # $toi stays the same
1197
1198 }
1199 elsif ($todir[$toi] eq $fromdir[$fromi])
1200 {
1201 # the files are the same
1202 # if it is a directory, check its contents
1203 if (-d "$todir/$todir[$toi]")
1204 {
1205 &synchronizeDirectory("$fromdir/$fromdir[$fromi]", "$todir/$todir[$toi]", $verbosity);
1206 }
1207
1208 $toi++;
1209 $fromi++;
1210 next;
1211 }
1212 }
1213
1214 # see if we should insert a file/directory
1215 # we should insert a file/directory if there
1216 # is no tofiles left or if the tofile does not exist
1217 if ($fromi < scalar(@fromdir) && ($toi >= scalar(@todir) || $todir[$toi] gt $fromdir[$fromi]))
1218 {
1219 &cp_r ("$fromdir/$fromdir[$fromi]", "$todir/$fromdir[$fromi]");
1220 splice (@todir, $toi, 0, $fromdir[$fromi]);
1221
1222 $toi++;
1223 $fromi++;
1224 }
1225 }
1226}
1227## synchronizeDirectory()
1228
12291;
Note: See TracBrowser for help on using the repository browser.