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

Last change on this file since 27639 was 27639, checked in by jmt12, 11 years ago

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