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

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

Undoing commit to FileUtils::closeFileHandle since John thinks the underlying issue could be different, which could have merely been screened by the 'fix' I committed and would therefore make it harder to investigate the problem.
File size: 30.6 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 if (!open($$fh_ref, $mode_symbol, $path))
914 {
915 die("Error! Failed to open file for " . $mode . ": " . $path . "\n");
916 }
917 return 1;
918}
919## openFileHandle()
920
921## @function readDirectory()
922#
923sub readDirectory
924{
925 my $path = shift(@_);
926 my @files;
927 if (opendir(DH, $path))
928 {
929 @files = readdir(DH);
930 close(DH);
931 }
932 else
933 {
934 die("Error! Failed to open directory to list files: " . $path . "\n");
935 }
936 return \@files;
937}
938## readDirectory()
939
940## @function removeFiles()
941#
942# removes files (but not directories)
943#
944sub removeFiles
945{
946 my (@files) = @_;
947 my @filefiles = ();
948
949 # make sure the files we want to delete exist
950 # and are regular files
951 foreach my $file (@files)
952 {
953 if (!-e $file)
954 {
955 print STDERR "FileUtils::removeFiles() $file does not exist\n";
956 }
957 elsif ((!-f $file) && (!-l $file))
958 {
959 print STDERR "FileUtils::removeFiles() $file is not a regular (or symbolic) file\n";
960 }
961 else
962 {
963 push (@filefiles, $file);
964 }
965 }
966
967 # remove the files
968 my $numremoved = unlink @filefiles;
969
970 # check to make sure all of them were removed
971 if ($numremoved != scalar(@filefiles))
972 {
973 print STDERR "FileUtils::removeFiles() Not all files were removed\n";
974 }
975}
976## removeFiles()
977
978## @function removeFilesDebug()
979#
980# removes files (but not directories) - can rename this to the default
981# "rm" subroutine when debugging the deletion of individual files.
982# Unused?
983#
984sub removeFilesDebug
985{
986 my (@files) = @_;
987 my @filefiles = ();
988
989 # make sure the files we want to delete exist
990 # and are regular files
991 foreach my $file (@files)
992 {
993 if (!-e $file)
994 {
995 print STDERR "FileUtils::removeFilesDebug() " . $file . " does not exist\n";
996 }
997 elsif ((!-f $file) && (!-l $file))
998 {
999 print STDERR "FileUtils::removeFilesDebug() " . $file . " is not a regular (or symbolic) file\n";
1000 }
1001 # debug message
1002 else
1003 {
1004 unlink($file) or warn "Could not delete file " . $file . ": " . $! . "\n";
1005 }
1006 }
1007}
1008## removeFilesDebug()
1009
1010## @function removeFilesFiltered()
1011#
1012sub removeFilesFiltered
1013{
1014 my ($files,$file_accept_re,$file_reject_re) = @_;
1015
1016 # my ($cpackage,$cfilename,$cline,$csubr,$chas_args,$cwantarray) = caller(2);
1017 # my ($lcfilename) = ($cfilename =~ m/([^\\\/]*)$/);
1018 # print STDERR "** Calling method (2): $lcfilename:$cline $cpackage->$csubr\n";
1019
1020 my @files_array = (ref $files eq "ARRAY") ? @$files : ($files);
1021
1022 # recursively remove the files
1023 foreach my $file (@files_array)
1024 {
1025 $file =~ s/[\/\\]+$//; # remove trailing slashes
1026
1027 if (!-e $file)
1028 {
1029 print STDERR "FileUtils::removeFilesFiltered() $file does not exist\n";
1030 }
1031 # don't recurse down symbolic link
1032 elsif ((-d $file) && (!-l $file))
1033 {
1034 # get the contents of this directory
1035 if (!opendir (INDIR, $file))
1036 {
1037 print STDERR "FileUtils::removeFilesFiltered() could not open directory $file\n";
1038 }
1039 else
1040 {
1041 my @filedir = grep (!/^\.\.?$/, readdir (INDIR));
1042 closedir (INDIR);
1043
1044 # remove all the files in this directory
1045 map {$_="$file/$_";} @filedir;
1046 &removeFilesFiltered(\@filedir,$file_accept_re,$file_reject_re);
1047
1048 if (!defined $file_accept_re && !defined $file_reject_re)
1049 {
1050 # remove this directory
1051 if (!rmdir $file)
1052 {
1053 print STDERR "FileUtils::removeFilesFiltered() couldn't remove directory $file\n";
1054 }
1055 }
1056 }
1057 }
1058 else
1059 {
1060 next if (defined $file_reject_re && ($file =~ m/$file_reject_re/));
1061
1062 if ((!defined $file_accept_re) || ($file =~ m/$file_accept_re/))
1063 {
1064 # remove this file
1065 &removeFiles($file);
1066 }
1067 }
1068 }
1069}
1070## removeFilesFiltered()
1071
1072## @function removeFilesRecursive()
1073#
1074# The equivalent of "rm -rf" with all the dangers therein
1075#
1076sub removeFilesRecursive
1077{
1078 my (@files) = @_;
1079
1080 # use the more general (but reterospectively written) function
1081 # filtered_rm_r function() with no accept or reject expressions
1082 &removeFilesFiltered(\@files,undef,undef);
1083}
1084## removeFilesRecursive()
1085
1086## @function sanitizePath()
1087#
1088sub sanitizePath
1089{
1090 my ($path) = @_;
1091
1092 # fortunately filename concatenate will perform all the double slash
1093 # removal and end slash removal we need, and in a protocol aware
1094 # fashion
1095 return &filenameConcatenate($path);
1096}
1097## sanitizePath()
1098
1099## @function softLink()
1100#
1101# make soft link to file if supported by OS, otherwise copy file
1102#
1103sub softLink
1104{
1105 my ($src, $dest, $ensure_paths_absolute) = @_;
1106
1107 # remove trailing slashes from source and destination files
1108 $src =~ s/[\\\/]+$//;
1109 $dest =~ s/[\\\/]+$//;
1110
1111 # Ensure file paths are absolute IF requested to do so
1112 # Soft_linking didn't work for relative paths
1113 if(defined $ensure_paths_absolute && $ensure_paths_absolute)
1114 {
1115 # We need to ensure that the src file is the absolute path
1116 # See http://perldoc.perl.org/File/Spec.html
1117 # it's relative
1118 if(!File::Spec->file_name_is_absolute( $src ))
1119 {
1120 $src = File::Spec->rel2abs($src); # make absolute
1121 }
1122 # Might as well ensure that the destination file's absolute path is used
1123 if(!File::Spec->file_name_is_absolute( $dest ))
1124 {
1125 $dest = File::Spec->rel2abs($dest); # make absolute
1126 }
1127 }
1128
1129 # a few sanity checks
1130 if (!-e $src)
1131 {
1132 print STDERR "FileUtils::softLink() source file $src does not exist\n";
1133 return 0;
1134 }
1135
1136 my $dest_dir = &File::Basename::dirname($dest);
1137 if (!-e $dest_dir)
1138 {
1139 &makeAllDirectories($dest_dir);
1140 }
1141
1142 if ($ENV{'GSDLOS'} =~ /^windows$/i)
1143 {
1144 # symlink not supported on windows
1145 &File::Copy::copy ($src, $dest);
1146 }
1147 elsif (!eval {symlink($src, $dest)})
1148 {
1149 print STDERR "FileUtils::softLink(): unable to create soft link.\n";
1150 return 0;
1151 }
1152 return 1;
1153}
1154## softLink()
1155
1156## @function synchronizeDirectory()
1157#
1158# updates a copy of a directory in some other part of the filesystem
1159# verbosity settings are: 0=low, 1=normal, 2=high
1160# both $fromdir and $todir should be absolute paths
1161#
1162sub synchronizeDirectory
1163{
1164 my ($fromdir, $todir, $verbosity) = @_;
1165 $verbosity = 1 unless defined $verbosity;
1166
1167 # use / for the directory separator, remove duplicate and
1168 # trailing slashes
1169 $fromdir=~s/[\\\/]+/\//g;
1170 $fromdir=~s/[\\\/]+$//;
1171 $todir=~s/[\\\/]+/\//g;
1172 $todir=~s/[\\\/]+$//;
1173
1174 &makeAllDirectories($todir);
1175
1176 # get the directories in ascending order
1177 if (!opendir (FROMDIR, $fromdir))
1178 {
1179 print STDERR "FileUtils::synchronizeDirectory() could not read directory $fromdir\n";
1180 return;
1181 }
1182 my @fromdir = grep (!/^\.\.?$/, sort(readdir (FROMDIR)));
1183 closedir (FROMDIR);
1184
1185 if (!opendir (TODIR, $todir))
1186 {
1187 print STDERR "FileUtils::synchronizeDirectory() could not read directory $todir\n";
1188 return;
1189 }
1190 my @todir = grep (!/^\.\.?$/, sort(readdir (TODIR)));
1191 closedir (TODIR);
1192
1193 my $fromi = 0;
1194 my $toi = 0;
1195
1196 while ($fromi < scalar(@fromdir) || $toi < scalar(@todir))
1197 {
1198 # print "fromi: $fromi toi: $toi\n";
1199
1200 # see if we should delete a file/directory
1201 # this should happen if the file/directory
1202 # is not in the from list or if its a different
1203 # size, or has an older timestamp
1204 if ($toi < scalar(@todir))
1205 {
1206 if (($fromi >= scalar(@fromdir)) || ($todir[$toi] lt $fromdir[$fromi] || ($todir[$toi] eq $fromdir[$fromi] && &differentFiles("$fromdir/$fromdir[$fromi]","$todir/$todir[$toi]", $verbosity))))
1207 {
1208
1209 # the files are different
1210 &removeFilesRecursive("$todir/$todir[$toi]");
1211 splice(@todir, $toi, 1); # $toi stays the same
1212
1213 }
1214 elsif ($todir[$toi] eq $fromdir[$fromi])
1215 {
1216 # the files are the same
1217 # if it is a directory, check its contents
1218 if (-d "$todir/$todir[$toi]")
1219 {
1220 &synchronizeDirectory("$fromdir/$fromdir[$fromi]", "$todir/$todir[$toi]", $verbosity);
1221 }
1222
1223 $toi++;
1224 $fromi++;
1225 next;
1226 }
1227 }
1228
1229 # see if we should insert a file/directory
1230 # we should insert a file/directory if there
1231 # is no tofiles left or if the tofile does not exist
1232 if ($fromi < scalar(@fromdir) && ($toi >= scalar(@todir) || $todir[$toi] gt $fromdir[$fromi]))
1233 {
1234 &cp_r ("$fromdir/$fromdir[$fromi]", "$todir/$fromdir[$fromi]");
1235 splice (@todir, $toi, 0, $fromdir[$fromi]);
1236
1237 $toi++;
1238 $fromi++;
1239 }
1240 }
1241}
1242## synchronizeDirectory()
1243
12441;
Note: See TracBrowser for help on using the repository browser.