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

Last change on this file since 32123 was 32123, checked in by kjdon, 6 years ago

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